    -- | This module performs the translation of a parsed XML DTD into the
    --   internal representation of corresponding Haskell data\/newtypes.
    --
    --   Note that dtdToTypeDef is partial - it will crash if you resolve
    --   qualified names (namespaces) to URIs beforehand.  It will only work
    --   on the original literal name forms "prefix:name".

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

    import Data.List (intercalate,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 = [(QName,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 :: [MarkupDecl] -> [TypeDef]
    dtd2TypeDef =
      ((QName, Record) -> [TypeDef]) -> [(QName, Record)] -> [TypeDef]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (QName, Record) -> [TypeDef]
    convert ([(QName, Record)] -> [TypeDef])
    -> ([MarkupDecl] -> [(QName, Record)]) -> [MarkupDecl] -> [TypeDef]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(QName, Record)] -> [(QName, Record)]
    forall a. [a] -> [a]
    reverse ([(QName, Record)] -> [(QName, Record)])
    -> ([MarkupDecl] -> [(QName, Record)])
    -> [MarkupDecl]
    -> [(QName, Record)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database []
      where
      database :: [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database [(QName, Record)]
    db [] = [(QName, Record)]
    db
      database [(QName, Record)]
    db (MarkupDecl
    m:[MarkupDecl]
    ms) =
          case MarkupDecl
    m of
            (Element (ElementDecl QName
    n ContentSpec
    cs)) ->
              case QName -> [(QName, Record)] -> Maybe Record
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup QName
    n [(QName, Record)]
    db of
                Maybe Record
    Nothing -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database ((QName
    n, [AttDef] -> ContentSpec -> Record
    R [] ContentSpec
    cs)(QName, Record) -> [(QName, Record)] -> [(QName, Record)]
    forall a. a -> [a] -> [a]
    :[(QName, Record)]
    db) [MarkupDecl]
    ms
                (Just (R [AttDef]
    as ContentSpec
    _)) -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database (QName -> Record -> [(QName, Record)] -> [(QName, Record)]
    forall {t} {t}. Eq t => t -> t -> [(t, t)] -> [(t, t)]
    replace QName
    n ([AttDef] -> ContentSpec -> Record
    R [AttDef]
    as ContentSpec
    cs) [(QName, Record)]
    db) [MarkupDecl]
    ms
            (AttList (AttListDecl QName
    n [AttDef]
    as)) ->
              case QName -> [(QName, Record)] -> Maybe Record
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup QName
    n [(QName, Record)]
    db of
                Maybe Record
    Nothing -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database ((QName
    n, [AttDef] -> ContentSpec -> Record
    R [AttDef]
    as ContentSpec
    EMPTY)(QName, Record) -> [(QName, Record)] -> [(QName, Record)]
    forall a. a -> [a] -> [a]
    :[(QName, Record)]
    db) [MarkupDecl]
    ms
                (Just (R [AttDef]
    a ContentSpec
    cs)) -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database (QName -> Record -> [(QName, Record)] -> [(QName, Record)]
    forall {t} {t}. Eq t => t -> t -> [(t, t)] -> [(t, t)]
    replace QName
    n ([AttDef] -> ContentSpec -> Record
    R ([AttDef] -> [AttDef]
    forall a. Eq a => [a] -> [a]
    nub ([AttDef]
    a[AttDef] -> [AttDef] -> [AttDef]
    forall a. [a] -> [a] -> [a]
    ++[AttDef]
    as)) ContentSpec
    cs) [(QName, Record)]
    db) [MarkupDecl]
    ms
        --  (MarkupPE _ m') -> database db (m':ms)
            MarkupDecl
    _ -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
    database [(QName, Record)]
    db [MarkupDecl]
    ms

      replace :: t -> t -> [(t, t)] -> [(t, t)]
    replace t
    _ t
    _ [] = [Char] -> [(t, t)]
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "dtd2TypeDef.replace: no element to replace"
      replace t
    n t
    v (x :: (t, t)
    x@(t
    n0,t
    _):[(t, t)]
    db)
          | t
    nt -> t -> Bool
    forall a. Eq a => a -> a -> Bool
    ==t
    n0     = (t
    n,t
    v)(t, t) -> [(t, t)] -> [(t, t)]
    forall a. a -> [a] -> [a]
    : [(t, t)]
    db
          | Bool
    otherwise = (t, t)
    x(t, t) -> [(t, t)] -> [(t, t)]
    forall a. a -> [a] -> [a]
    : t -> t -> [(t, t)] -> [(t, t)]
    replace t
    n t
    v [(t, t)]
    db

    ---- Convert DTD record to typedef ----
    convert :: (QName, Record) -> [TypeDef]
    convert :: (QName, Record) -> [TypeDef]
    convert (N [Char]
    n, R [AttDef]
    as ContentSpec
    cs) =
        case ContentSpec
    cs of
          ContentSpec
    EMPTY                   -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    None []
          ContentSpec
    ANY                     -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    None [[StructType
    Any]]
                                     --error "NYI: contentspec of ANY"
          (Mixed Mixed
    PCDATA)          -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    None [[StructType
    String]]
          (Mixed (PCDATAplus [QName]
    ns)) -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    Star ([StructType
    StringMixed]
                                                    [StructType] -> [[StructType]] -> [[StructType]]
    forall a. a -> [a] -> [a]
    : (QName -> [StructType]) -> [QName] -> [[StructType]]
    forall a b. (a -> b) -> [a] -> [b]
    map ((StructType -> [StructType] -> [StructType]
    forall a. a -> [a] -> [a]
    :[]) (StructType -> [StructType])
    -> (QName -> StructType) -> QName -> [StructType]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> StructType
    Defined (Name -> StructType) -> (QName -> Name) -> QName -> StructType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> Name
    name
                                                           ([Char] -> Name) -> (QName -> [Char]) -> QName -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . \(N [Char]
    n)->[Char]
    n)
                                                           [QName]
    ns)
          (ContentSpec CP
    cp)        ->
              case CP
    cp of
                (TagName (N [Char]
    n') Modifier
    m) -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    m [[Name -> StructType
    Defined ([Char] -> Name
    name [Char]
    n')]]
                (Choice [CP]
    cps Modifier
    m)     -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    m ((CP -> [StructType]) -> [CP] -> [[StructType]]
    forall a b. (a -> b) -> [a] -> [b]
    map ((StructType -> [StructType] -> [StructType]
    forall a. a -> [a] -> [a]
    :[])(StructType -> [StructType])
    -> (CP -> StructType) -> CP -> [StructType]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .CP -> StructType
    inner) [CP]
    cps)
                (Seq [CP]
    cps Modifier
    m)        -> Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    m [(CP -> StructType) -> [CP] -> [StructType]
    forall a b. (a -> b) -> [a] -> [b]
    map CP -> StructType
    inner [CP]
    cps]
        [TypeDef] -> [TypeDef] -> [TypeDef]
    forall a. [a] -> [a] -> [a]
    ++ (AttDef -> [TypeDef]) -> [AttDef] -> [TypeDef]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (QName -> AttDef -> [TypeDef]
    mkAttrDef ([Char] -> QName
    N [Char]
    n)) [AttDef]
    as
      where
        attrs    :: AttrFields
        attrs :: AttrFields
    attrs     = (AttDef -> (Name, StructType)) -> [AttDef] -> AttrFields
    forall a b. (a -> b) -> [a] -> [b]
    map (QName -> AttDef -> (Name, StructType)
    mkAttrField ([Char] -> QName
    N [Char]
    n)) [AttDef]
    as

        modifier :: Modifier -> [[StructType]] -> [TypeDef]
    modifier Modifier
    None [[StructType]]
    sts   = [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
    mkData [[StructType]]
    sts            AttrFields
    attrs Bool
    False ([Char] -> Name
    name [Char]
    n)
        modifier Modifier
    m   [[StructType
    st]] = [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
    mkData [[Modifier -> StructType -> StructType
    modf Modifier
    m StructType
    st]]  AttrFields
    attrs Bool
    False ([Char] -> Name
    name [Char]
    n)
        modifier Modifier
    m    [[StructType]]
    sts   = [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
    mkData [[Modifier -> StructType -> StructType
    modf Modifier
    m (Name -> StructType
    Defined ([Char] -> Name
    name_ [Char]
    n))]]
                                                    AttrFields
    attrs Bool
    False ([Char] -> Name
    name [Char]
    n) [TypeDef] -> [TypeDef] -> [TypeDef]
    forall a. [a] -> [a] -> [a]
    ++
                              [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
    mkData [[StructType]]
    sts            []    Bool
    True  ([Char] -> Name
    name_ [Char]
    n)

        inner :: CP -> StructType
        inner :: CP -> StructType
    inner (TagName (N [Char]
    n') Modifier
    m) = Modifier -> StructType -> StructType
    modf Modifier
    m (Name -> StructType
    Defined ([Char] -> Name
    name [Char]
    n'))
        inner (Choice [CP]
    cps Modifier
    m)     = Modifier -> StructType -> StructType
    modf Modifier
    m ([StructType] -> StructType
    OneOf ((CP -> StructType) -> [CP] -> [StructType]
    forall a b. (a -> b) -> [a] -> [b]
    map CP -> StructType
    inner [CP]
    cps))
        inner (Seq [CP]
    cps Modifier
    None)     = [StructType] -> StructType
    Tuple ((CP -> StructType) -> [CP] -> [StructType]
    forall a b. (a -> b) -> [a] -> [b]
    map CP -> StructType
    inner [CP]
    cps)
        inner (Seq [CP]
    cps Modifier
    m)        = Modifier -> StructType -> StructType
    modf Modifier
    m ([StructType] -> StructType
    Tuple ((CP -> StructType) -> [CP] -> [StructType]
    forall a b. (a -> b) -> [a] -> [b]
    map CP -> StructType
    inner [CP]
    cps))

        modf :: Modifier -> StructType -> StructType
    modf Modifier
    None StructType
    x  = StructType
    x
        modf Modifier
    Query StructType
    x = StructType -> StructType
    Maybe StructType
    x
        modf Modifier
    Star StructType
    x  = StructType -> StructType
    List StructType
    x
        modf Modifier
    Plus StructType
    x  = StructType -> StructType
    List1 StructType
    x

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

    mkAttrDef :: QName -> AttDef -> [TypeDef]
    mkAttrDef :: QName -> AttDef -> [TypeDef]
    mkAttrDef QName
    _ (AttDef QName
    _ AttType
    StringType DefaultDecl
    _) =
        []
    mkAttrDef QName
    _ (AttDef QName
    _ (TokenizedType TokenizedType
    _) DefaultDecl
    _) =
        [] -- mkData [[String]] [] False (name n)
    mkAttrDef (N [Char]
    e) (AttDef (N [Char]
    n) (EnumeratedType (NotationType [[Char]]
    nt)) DefaultDecl
    _) =
        [Name -> [Name] -> TypeDef
    EnumDef ([Char] -> [Char] -> Name
    name_a [Char]
    e [Char]
    n) (([Char] -> Name) -> [[Char]] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Char] -> [Char] -> [Char] -> Name
    name_ac [Char]
    e [Char]
    n) [[Char]]
    nt)]
    mkAttrDef (N [Char]
    e) (AttDef (N [Char]
    n) (EnumeratedType (Enumeration [[Char]]
    es)) DefaultDecl
    _) =
        [Name -> [Name] -> TypeDef
    EnumDef ([Char] -> [Char] -> Name
    name_a [Char]
    e [Char]
    n) (([Char] -> Name) -> [[Char]] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Char] -> [Char] -> [Char] -> Name
    name_ac [Char]
    e [Char]
    n) [[Char]]
    es)]
            -- Default attribute values not handled here

    mkAttrField :: QName -> AttDef -> (Name,StructType)
    mkAttrField :: QName -> AttDef -> (Name, StructType)
    mkAttrField (N [Char]
    e) (AttDef (N [Char]
    n) AttType
    typ DefaultDecl
    req) = ([Char] -> [Char] -> Name
    name_f [Char]
    e [Char]
    n, AttType -> DefaultDecl -> StructType
    mkType AttType
    typ DefaultDecl
    req)
      where
        mkType :: AttType -> DefaultDecl -> StructType
    mkType AttType
    StringType DefaultDecl
    REQUIRED = StructType
    String
        mkType AttType
    StringType DefaultDecl
    IMPLIED  = StructType -> StructType
    Maybe StructType
    String
        mkType AttType
    StringType (DefaultTo v :: AttValue
    v@(AttValue [Either [Char] Reference]
    _) Maybe FIXED
    _) = StructType -> [Char] -> StructType
    Defaultable StructType
    String (AttValue -> [Char]
    forall a. Show a => a -> [Char]
    show AttValue
    v)
        mkType (TokenizedType TokenizedType
    _) DefaultDecl
    REQUIRED  = StructType
    String
        mkType (TokenizedType TokenizedType
    _) DefaultDecl
    IMPLIED   = StructType -> StructType
    Maybe StructType
    String
        mkType (TokenizedType TokenizedType
    _) (DefaultTo v :: AttValue
    v@(AttValue [Either [Char] Reference]
    _) Maybe FIXED
    _) =
                                                            StructType -> [Char] -> StructType
    Defaultable StructType
    String (AttValue -> [Char]
    forall a. Show a => a -> [Char]
    show AttValue
    v)
        mkType (EnumeratedType EnumeratedType
    _) DefaultDecl
    REQUIRED = Name -> StructType
    Defined ([Char] -> [Char] -> Name
    name_a [Char]
    e [Char]
    n)
        mkType (EnumeratedType EnumeratedType
    _) DefaultDecl
    IMPLIED  = StructType -> StructType
    Maybe (Name -> StructType
    Defined ([Char] -> [Char] -> Name
    name_a [Char]
    e [Char]
    n))
        mkType (EnumeratedType EnumeratedType
    _) (DefaultTo v :: AttValue
    v@(AttValue [Either [Char] Reference]
    _) Maybe FIXED
    _) =
                    StructType -> [Char] -> StructType
    Defaultable (Name -> StructType
    Defined ([Char] -> [Char] -> Name
    name_a [Char]
    e [Char]
    n)) (Name -> [Char]
    hName ([Char] -> [Char] -> [Char] -> Name
    name_ac [Char]
    e [Char]
    n (AttValue -> [Char]
    forall a. Show a => a -> [Char]
    show AttValue
    v)))