    -- | This module performs the translation of a parsed XML DTD into the
    --   internal representation of corresponding Haskell data\/newtypes.

    module Text.XML.HaXml.DtdToHaskell.Convert
      ( dtd2TypeDef
      ) where

    import List (intersperse,nub)

    import Text.XML.HaXml.Types hiding (Name)
    import Text.XML.HaXml.DtdToHaskell.TypeDef

    ---- Internal representation for database of DTD decls ----
    data Record = R [AttDef] ContentSpec
    -- type Db = [(String,Record)]

    ---- Build a database of DTD decls then convert them to typedefs ----
    ---- (Done in two steps because we need to merge ELEMENT and ATTLIST decls.)
    ---- Apparently multiple ATTLIST decls for the same element are permitted,
    ---- although only one ELEMENT decl for it is allowed.
    dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
    dtd2TypeDef mds =
      (concatMap convert . reverse . database []) mds
      where
      database db [] = db
      database db (m:ms) =
          case m of
            (Element (ElementDecl n cs)) ->
              case lookup n db of
                Nothing -> database ((n, R [] cs):db) ms
                (Just (R as _)) -> database (replace n (R as cs) db) ms
            (AttList (AttListDecl n as)) ->
              case lookup n db of
                Nothing -> database ((n, R as EMPTY):db) ms
                (Just (R a cs)) -> database (replace n (R (nub (a++as)) cs) db) ms
        --  (MarkupPE _ m') -> database db (m':ms)
            _ -> database db ms

      replace _ _ [] = error "dtd2TypeDef.replace: no element to replace"
      replace n v (x@(n0,_):db)
          | n==n0     = (n,v): db
          | otherwise = x: replace n v db

    ---- Convert DTD record to typedef ----
    convert :: (String, Record) -> [TypeDef]
    convert (n, R as cs) =
        case cs of
          EMPTY                   -> modifier None []
          ANY                     -> modifier None [[Any]]
                                     --error "NYI: contentspec of ANY"
          (Mixed PCDATA)          -> modifier None [[String]]
          (Mixed (PCDATAplus ns)) -> modifier Star ([StringMixed]
                                                    : map ((:[]) . Defined . name) ns)
          (ContentSpec cp)        ->
              case cp of
                (TagName n' m) -> modifier m [[Defined (name n')]]
                (Choice cps m) -> modifier m (map ((:[]).inner) cps)
                (Seq cps m)    -> modifier m [map inner cps]
        ++ concatMap (mkAttrDef n) as
      where
        attrs    :: AttrFields
        attrs     = map (mkAttrField n) as

        modifier None sts   = mkData sts            attrs False (name n)
        modifier m   [[st]] = mkData [[modf m st]]  attrs False (name n)
        modifier m    sts   = mkData [[modf m (Defined (name_ n))]]
                                                    attrs False (name n) ++
                              mkData sts            []    True  (name_ n)

        inner :: CP -> StructType
        inner (TagName n' m) = modf m (Defined (name n'))
        inner (Choice cps m) = modf m (OneOf (map inner cps))
        inner (Seq cps None) = Tuple (map inner cps)
        inner (Seq cps m)    = modf m (Tuple (map inner cps))

        modf None x  = x
        modf Query x = Maybe x
        modf Star x  = List x
        modf Plus x  = List1 x

    mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
    mkData []   fs aux n  = [DataDef aux n fs []]
    mkData [ts] fs aux n  = [DataDef aux n fs [(n, ts)]]
    mkData tss  fs aux n  = [DataDef aux n fs (map (mkConstr n) tss)]
      where
        mkConstr m ts = (mkConsName m ts, ts)
        mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts)))
        flatten (Maybe st)   = {-"Maybe_" ++ -} flatten st
        flatten (List st)    = {-"List_" ++ -} flatten st
        flatten (List1 st)   = {-"List1_" ++ -} flatten st
        flatten (Tuple sts)  = {-"Tuple" ++ show (length sts) ++ "_" ++ -}
                                concat (intersperse "_" (map flatten sts))
        flatten StringMixed  = "Str"
        flatten String       = "Str"
        flatten (OneOf sts)  = {-"OneOf" ++ show (length sts) ++ "_" ++ -}
                                concat (intersperse "_" (map flatten sts))
        flatten Any          = "Any"
        flatten (Defined (Name _ m))  = m

    mkAttrDef :: String -> AttDef -> [TypeDef]
    mkAttrDef _ (AttDef _ StringType _) =
        []
    mkAttrDef _ (AttDef _ (TokenizedType _) _) =
        [] -- mkData [[String]] [] False (name n)
    mkAttrDef e (AttDef n (EnumeratedType (NotationType nt)) _) =
        [EnumDef (name_a e n) (map (name_ac e n) nt)]
    mkAttrDef e (AttDef n (EnumeratedType (Enumeration es)) _) =
        [EnumDef (name_a e n) (map (name_ac e n) es)]
            -- Default attribute values not handled here

    mkAttrField :: String -> AttDef -> (Name,StructType)
    mkAttrField e (AttDef n typ req) = (name_f e n, mkType typ req)
      where
        mkType StringType REQUIRED = String
        mkType StringType IMPLIED  = Maybe String
        mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v)
        mkType (TokenizedType _) REQUIRED  = String
        mkType (TokenizedType _) IMPLIED   = Maybe String
        mkType (TokenizedType _) (DefaultTo v@(AttValue _) _) =
                                                            Defaultable String (show v)
        mkType (EnumeratedType _) REQUIRED = Defined (name_a e n)
        mkType (EnumeratedType _) IMPLIED  = Maybe (Defined (name_a e n))
        mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) =
                    Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))