    module Text.XML.HaXml.TypeMapping
      (
      -- * A class to get an explicit type representation for any value
        HTypeable(..)       -- sole method, toHType
      -- * Explicit representation of Haskell datatype information
      , HType(..)           -- instance of Eq, Show
      , Constr(..)          -- instance of Eq, Show
      -- * Helper functions to extract type info as strings
      , showHType           -- :: HType -> ShowS
      , showConstr          -- :: Int -> HType -> String
      -- * Conversion from Haskell datatype to DTD
      , toDTD
      ) where

    import Text.XML.HaXml.Types
    import Data.List (partition, intersperse)
    import Text.PrettyPrint.HughesPJ (render)
    import qualified Text.XML.HaXml.Pretty as PP

    ------------------------------------------------------------------------
            -- idea: in DrIFT,
            --      named field == primitive type, becomes an attribute
            --      named field == single-constructor type, renames the tag
            --      named field == multi-constructor type, as normal
            -- if prefix of all named fields is roughly typename, delete it

    -- | @HTypeable@ promises that we can create an explicit representation of
    --   of the type of any value.
    class HTypeable a where
        toHType :: a -> HType

    -- | A concrete representation of any Haskell type.
    data HType =
          Maybe HType
        | List HType
        | Tuple [HType]
        | Prim String String        -- ^ separate Haskell name and XML name
        | String
        | Defined String [HType] [Constr]
            -- ^ A user-defined type has a name, a sequence of type variables,
            --   and a set of constructors.  (The variables might already be
            --   instantiated to actual types.)
        deriving (Int -> HType -> ShowS
    [HType] -> ShowS
    HType -> String
    (Int -> HType -> ShowS)
    -> (HType -> String) -> ([HType] -> ShowS) -> Show HType
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> HType -> ShowS
    showsPrec :: Int -> HType -> ShowS
    $cshow :: HType -> String
    show :: HType -> String
    $cshowList :: [HType] -> ShowS
    showList :: [HType] -> ShowS
    Show)

    instance Eq HType where
        (Maybe HType
    x)  == :: HType -> HType -> Bool
    == (Maybe HType
    y)  =  HType
    xHType -> HType -> Bool
    forall a. Eq a => a -> a -> Bool
    ==HType
    y
        (List HType
    x)   == (List HType
    y)   =  HType
    xHType -> HType -> Bool
    forall a. Eq a => a -> a -> Bool
    ==HType
    y
        (Tuple [HType]
    xs) == (Tuple [HType]
    ys) =  [HType]
    xs[HType] -> [HType] -> Bool
    forall a. Eq a => a -> a -> Bool
    ==[HType]
    ys
        (Prim String
    x String
    _) == (Prim String
    y String
    _) =  String
    xString -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==String
    y
        HType
    String     == HType
    String     =  Bool
    True
        (Defined String
    n [HType]
    _xs [Constr]
    _) == (Defined String
    m [HType]
    _ys [Constr]
    _)  =  String
    nString -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==String
    m     -- && xs==ys
        HType
    _          == HType
    _          =  Bool
    False

    -- | A concrete representation of any user-defined Haskell constructor.
    --   The constructor has a name, and a sequence of component types.  The
    --   first sequence of types represents the minimum set of free type
    --   variables occurring in the (second) list of real component types.
    --   If there are fieldnames, they are contained in the final list, and
    --   correspond one-to-one with the component types.
    data Constr = Constr String [HType] [HType] -- (Maybe [String])
        deriving (Constr -> Constr -> Bool
    (Constr -> Constr -> Bool)
    -> (Constr -> Constr -> Bool) -> Eq Constr
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Constr -> Constr -> Bool
    == :: Constr -> Constr -> Bool
    $c/= :: Constr -> Constr -> Bool
    /= :: Constr -> Constr -> Bool
    Eq,Int -> Constr -> ShowS
    [Constr] -> ShowS
    Constr -> String
    (Int -> Constr -> ShowS)
    -> (Constr -> String) -> ([Constr] -> ShowS) -> Show Constr
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Constr -> ShowS
    showsPrec :: Int -> Constr -> ShowS
    $cshow :: Constr -> String
    show :: Constr -> String
    $cshowList :: [Constr] -> ShowS
    showList :: [Constr] -> ShowS
    Show)

    -- | Project the n'th constructor from an HType and convert it to a string
    --   suitable for an XML tagname.
    showConstr :: Int -> HType -> String
    showConstr :: Int -> HType -> String
    showConstr Int
    n (Defined String
    _ [HType]
    _ [Constr]
    cs) = Constr -> ShowS
    flatConstr ([Constr]
    cs[Constr] -> Int -> Constr
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    n) String
    ""
    showConstr Int
    _ HType
    _ = ShowS
    forall a. HasCallStack => String -> a
    error String
    "no constructors for builtin types"

    ------------------------------------------------------------------------
    -- Some instances
    instance HTypeable Bool where
        toHType :: Bool -> HType
    toHType   Bool
    _    = String -> String -> HType
    Prim String
    "Bool" String
    "bool"
    instance HTypeable Int where
        toHType :: Int -> HType
    toHType   Int
    _    = String -> String -> HType
    Prim String
    "Int" String
    "int"
    instance HTypeable Integer where
        toHType :: Integer -> HType
    toHType   Integer
    _    = String -> String -> HType
    Prim String
    "Integer" String
    "integer"
    instance HTypeable Float where
        toHType :: Float -> HType
    toHType   Float
    _    = String -> String -> HType
    Prim String
    "Float" String
    "float"
    instance HTypeable Double where
        toHType :: Double -> HType
    toHType   Double
    _    = String -> String -> HType
    Prim String
    "Double" String
    "double"
    instance HTypeable Char where
        toHType :: Char -> HType
    toHType   Char
    _    = String -> String -> HType
    Prim String
    "Char" String
    "char"

    instance HTypeable () where
        toHType :: () -> HType
    toHType ()
    _      = String -> String -> HType
    Prim String
    "unit" String
    "unit"
    instance (HTypeable a, HTypeable b) => HTypeable (a,b) where
        toHType :: (a, b) -> HType
    toHType (a, b)
    p      = [HType] -> HType
    Tuple [a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b]
                       where  (a
    a,b
    b) = (a, b)
    p
    instance (HTypeable a, HTypeable b, HTypeable c) => HTypeable (a,b,c) where
        toHType :: (a, b, c) -> HType
    toHType (a, b, c)
    p      = [HType] -> HType
    Tuple [a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c]
                       where  (a
    a,b
    b,c
    c) = (a, b, c)
    p
    instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d) =>
             HTypeable (a,b,c,d) where
        toHType :: (a, b, c, d) -> HType
    toHType (a, b, c, d)
    p      = [HType] -> HType
    Tuple [a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d]
                       where  (a
    a,b
    b,c
    c,d
    d) = (a, b, c, d)
    p
    instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e) =>
             HTypeable (a,b,c,d,e) where
        toHType :: (a, b, c, d, e) -> HType
    toHType (a, b, c, d, e)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e) = (a, b, c, d, e)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f) =>
             HTypeable (a,b,c,d,e,f) where
        toHType :: (a, b, c, d, e, f) -> HType
    toHType (a, b, c, d, e, f)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f) = (a, b, c, d, e, f)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g) =>
             HTypeable (a,b,c,d,e,f,g) where
        toHType :: (a, b, c, d, e, f, g) -> HType
    toHType (a, b, c, d, e, f, g)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g) = (a, b, c, d, e, f, g)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h) =>
             HTypeable (a,b,c,d,e,f,g,h) where
        toHType :: (a, b, c, d, e, f, g, h) -> HType
    toHType (a, b, c, d, e, f, g, h)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h) = (a, b, c, d, e, f, g, h)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i) =>
             HTypeable (a,b,c,d,e,f,g,h,i) where
        toHType :: (a, b, c, d, e, f, g, h, i) -> HType
    toHType (a, b, c, d, e, f, g, h, i)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i) = (a, b, c, d, e, f, g, h, i)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j) =>
             HTypeable (a,b,c,d,e,f,g,h,i,j) where
        toHType :: (a, b, c, d, e, f, g, h, i, j) -> HType
    toHType (a, b, c, d, e, f, g, h, i, j)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i, j -> HType
    forall a. HTypeable a => a -> HType
    toHType j
    j ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i,j
    j) = (a, b, c, d, e, f, g, h, i, j)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
             , HTypeable k) =>
             HTypeable (a,b,c,d,e,f,g,h,i,j,k) where
        toHType :: (a, b, c, d, e, f, g, h, i, j, k) -> HType
    toHType (a, b, c, d, e, f, g, h, i, j, k)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i, j -> HType
    forall a. HTypeable a => a -> HType
    toHType j
    j, k -> HType
    forall a. HTypeable a => a -> HType
    toHType k
    k ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i,j
    j,k
    k) = (a, b, c, d, e, f, g, h, i, j, k)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
             , HTypeable k, HTypeable l) =>
             HTypeable (a,b,c,d,e,f,g,h,i,j,k,l) where
        toHType :: (a, b, c, d, e, f, g, h, i, j, k, l) -> HType
    toHType (a, b, c, d, e, f, g, h, i, j, k, l)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i, j -> HType
    forall a. HTypeable a => a -> HType
    toHType j
    j, k -> HType
    forall a. HTypeable a => a -> HType
    toHType k
    k, l -> HType
    forall a. HTypeable a => a -> HType
    toHType l
    l ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i,j
    j,k
    k,l
    l) = (a, b, c, d, e, f, g, h, i, j, k, l)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
             , HTypeable k, HTypeable l, HTypeable m) =>
             HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m) where
        toHType :: (a, b, c, d, e, f, g, h, i, j, k, l, m) -> HType
    toHType (a, b, c, d, e, f, g, h, i, j, k, l, m)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i, j -> HType
    forall a. HTypeable a => a -> HType
    toHType j
    j, k -> HType
    forall a. HTypeable a => a -> HType
    toHType k
    k, l -> HType
    forall a. HTypeable a => a -> HType
    toHType l
    l
                               , m -> HType
    forall a. HTypeable a => a -> HType
    toHType m
    m ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i,j
    j,k
    k,l
    l,m
    m) = (a, b, c, d, e, f, g, h, i, j, k, l, m)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
             , HTypeable k, HTypeable l, HTypeable m, HTypeable n) =>
             HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
        toHType :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> HType
    toHType (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i, j -> HType
    forall a. HTypeable a => a -> HType
    toHType j
    j, k -> HType
    forall a. HTypeable a => a -> HType
    toHType k
    k, l -> HType
    forall a. HTypeable a => a -> HType
    toHType l
    l
                               , m -> HType
    forall a. HTypeable a => a -> HType
    toHType m
    m, n -> HType
    forall a. HTypeable a => a -> HType
    toHType n
    n ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i,j
    j,k
    k,l
    l,m
    m,n
    n) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
    p
    instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
             , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
             , HTypeable k, HTypeable l, HTypeable m, HTypeable n, HTypeable o) =>
             HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
        toHType :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> HType
    toHType (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
    p      = [HType] -> HType
    Tuple [ a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    a, b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    b, c -> HType
    forall a. HTypeable a => a -> HType
    toHType c
    c, d -> HType
    forall a. HTypeable a => a -> HType
    toHType d
    d
                               , e -> HType
    forall a. HTypeable a => a -> HType
    toHType e
    e, f -> HType
    forall a. HTypeable a => a -> HType
    toHType f
    f, g -> HType
    forall a. HTypeable a => a -> HType
    toHType g
    g, h -> HType
    forall a. HTypeable a => a -> HType
    toHType h
    h
                               , i -> HType
    forall a. HTypeable a => a -> HType
    toHType i
    i, j -> HType
    forall a. HTypeable a => a -> HType
    toHType j
    j, k -> HType
    forall a. HTypeable a => a -> HType
    toHType k
    k, l -> HType
    forall a. HTypeable a => a -> HType
    toHType l
    l
                               , m -> HType
    forall a. HTypeable a => a -> HType
    toHType m
    m, n -> HType
    forall a. HTypeable a => a -> HType
    toHType n
    n, o -> HType
    forall a. HTypeable a => a -> HType
    toHType o
    o ]
                       where  (a
    a,b
    b,c
    c,d
    d,e
    e,f
    f,g
    g,h
    h,i
    i,j
    j,k
    k,l
    l,m
    m,n
    n,o
    o) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
    p

    instance (HTypeable a) => HTypeable (Maybe a) where
        toHType :: Maybe a -> HType
    toHType Maybe a
    m      = HType -> HType
    Maybe (a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    x)   where   (Just a
    x) = Maybe a
    m
    instance (HTypeable a, HTypeable b) => HTypeable (Either a b) where
        toHType :: Either a b -> HType
    toHType Either a b
    m      = String -> [HType] -> [Constr] -> HType
    Defined String
    "Either" [HType
    hx, HType
    hy]
                             [ String -> [HType] -> [HType] -> Constr
    Constr String
    "Left" [HType
    hx] [HType
    hx] {-Nothing-}
                             , String -> [HType] -> [HType] -> Constr
    Constr String
    "Right" [HType
    hy] [HType
    hy] {-Nothing-}]
                       where (Left a
    x)  = Either a b
    m
                             (Right b
    y) = Either a b
    m
                             hx :: HType
    hx = a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    x
                             hy :: HType
    hy = b -> HType
    forall a. HTypeable a => a -> HType
    toHType b
    y

    instance HTypeable a => HTypeable [a] where
        toHType :: [a] -> HType
    toHType [a]
    xs     = case a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    x of (Prim String
    "Char" String
    _) -> HType
    String
                                           HType
    _ -> HType -> HType
    List (a -> HType
    forall a. HTypeable a => a -> HType
    toHType a
    x)
                       where  (a
    x:[a]
    _) = [a]
    xs

    ------------------------------------------------------------------------

    -- | 'toDTD' converts a concrete representation of the Haskell type of
    --   a value (obtained by the method 'toHType') into a real DocTypeDecl.
    --   It ensures that PERefs are defined before they are used, and that no
    --   element or attribute-list is declared more than once.
    toDTD :: HType -> DocTypeDecl
    toDTD :: HType -> DocTypeDecl
    toDTD HType
    ht =
      QName -> Maybe ExternalID -> [MarkupDecl] -> DocTypeDecl
    DTD (HType -> QName
    toplevel HType
    ht) Maybe ExternalID
    forall a. Maybe a
    Nothing ([MarkupDecl] -> [MarkupDecl]
    macrosFirst ([MarkupDecl] -> [MarkupDecl]
    forall a. [a] -> [a]
    reverse (Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    True [] [] [HType
    ht])))
      where
        macrosFirst :: [MarkupDecl] -> [MarkupDecl]
        macrosFirst :: [MarkupDecl] -> [MarkupDecl]
    macrosFirst [MarkupDecl]
    decls = [MarkupDecl]
    p [MarkupDecl] -> [MarkupDecl] -> [MarkupDecl]
    forall a. [a] -> [a] -> [a]
    ++ [MarkupDecl]
    p' where ([MarkupDecl]
    p, [MarkupDecl]
    p') = (MarkupDecl -> Bool)
    -> [MarkupDecl] -> ([MarkupDecl], [MarkupDecl])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition MarkupDecl -> Bool
    f [MarkupDecl]
    decls
                                          f :: MarkupDecl -> Bool
    f (Entity EntityDecl
    _) = Bool
    True
                                          f MarkupDecl
    _ = Bool
    False
        toplevel :: HType -> QName
    toplevel ht :: HType
    ht@(Defined String
    _ [HType]
    _ [Constr]
    _) = String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ HType -> ShowS
    showHType HType
    ht String
    "-XML"
        toplevel HType
    ht                 = String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ HType -> ShowS
    showHType HType
    ht String
    ""
        c0 :: Bool
    c0 = Bool
    False
        h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
        -- toplevel?   history    history   remainingwork     result
        h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    _c [HType]
    _history [Constr]
    _chist []       = []
        h2d  Bool
    c  [HType]
    history  [Constr]
    chist (HType
    ht:[HType]
    hts) =
          if HType
    ht HType -> [HType] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [HType]
    history then Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 [HType]
    history [Constr]
    chist [HType]
    hts
          else
            case HType
    ht of
              Maybe HType
    ht0  -> HType -> MarkupDecl
    declelem HType
    htMarkupDecl -> [MarkupDecl] -> [MarkupDecl]
    forall a. a -> [a] -> [a]
    : Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 (HType
    htHType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    history) [Constr]
    chist (HType
    ht0HType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    hts)
              List HType
    ht0   -> HType -> MarkupDecl
    declelem HType
    htMarkupDecl -> [MarkupDecl] -> [MarkupDecl]
    forall a. a -> [a] -> [a]
    : Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 (HType
    htHType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    history) [Constr]
    chist (HType
    ht0HType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    hts)
              Tuple [HType]
    hts0 -> (Bool
    c Bool
    -> ([MarkupDecl] -> [MarkupDecl]) -> [MarkupDecl] -> [MarkupDecl]
    forall a. Bool -> (a -> a) -> a -> a
    ? (HType -> MarkupDecl
    declelem HType
    htMarkupDecl -> [MarkupDecl] -> [MarkupDecl]
    forall a. a -> [a] -> [a]
    :))
                                         (Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 [HType]
    history [Constr]
    chist ([HType]
    hts0[HType] -> [HType] -> [HType]
    forall a. [a] -> [a] -> [a]
    ++[HType]
    hts))
              Prim String
    _ String
    _   -> HType -> [MarkupDecl]
    declprim HType
    ht [MarkupDecl] -> [MarkupDecl] -> [MarkupDecl]
    forall a. [a] -> [a] -> [a]
    ++ Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 (HType
    htHType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    history) [Constr]
    chist [HType]
    hts
              HType
    String     -> MarkupDecl
    declstringMarkupDecl -> [MarkupDecl] -> [MarkupDecl]
    forall a. a -> [a] -> [a]
    :    Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 (HType
    htHType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    history) [Constr]
    chist [HType]
    hts
              Defined String
    _ [HType]
    _ [Constr]
    cs ->
                   let hts0 :: [HType]
    hts0 = (Constr -> [HType]) -> [Constr] -> [HType]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Constr -> [HType]
    grab [Constr]
    cs in
                   (Bool
    c Bool
    -> ([MarkupDecl] -> [MarkupDecl]) -> [MarkupDecl] -> [MarkupDecl]
    forall a. Bool -> (a -> a) -> a -> a
    ? (HType -> MarkupDecl
    decltopelem HType
    htMarkupDecl -> [MarkupDecl] -> [MarkupDecl]
    forall a. a -> [a] -> [a]
    :)) (HType -> [Constr] -> [MarkupDecl]
    forall {t :: * -> *}.
    Foldable t =>
    HType -> t Constr -> [MarkupDecl]
    declmacro HType
    ht [Constr]
    chist)
                   [MarkupDecl] -> [MarkupDecl] -> [MarkupDecl]
    forall a. [a] -> [a] -> [a]
    ++ Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    h2d Bool
    c0 (HType
    htHType -> [HType] -> [HType]
    forall a. a -> [a] -> [a]
    :[HType]
    history) ([Constr]
    cs[Constr] -> [Constr] -> [Constr]
    forall a. [a] -> [a] -> [a]
    ++[Constr]
    chist) ([HType]
    hts0[HType] -> [HType] -> [HType]
    forall a. [a] -> [a] -> [a]
    ++[HType]
    hts)
        declelem :: HType -> MarkupDecl
    declelem HType
    ht =
          ElementDecl -> MarkupDecl
    Element (QName -> ContentSpec -> ElementDecl
    ElementDecl (String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ HType -> ShowS
    showHType HType
    ht String
    "")
                               (CP -> ContentSpec
    ContentSpec (HType -> CP
    outerHtExpr HType
    ht)))
        decltopelem :: HType -> MarkupDecl
    decltopelem HType
    ht =    -- hack to avoid peref at toplevel
          ElementDecl -> MarkupDecl
    Element (QName -> ContentSpec -> ElementDecl
    ElementDecl (String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ HType -> ShowS
    showHType HType
    ht String
    "-XML")
                               (CP -> ContentSpec
    ContentSpec (HType -> Modifier -> CP
    innerHtExpr HType
    ht Modifier
    None)))
        declmacro :: HType -> t Constr -> [MarkupDecl]
    declmacro ht :: HType
    ht@(Defined String
    _ [HType]
    _ [Constr]
    cs) t Constr
    chist =
          EntityDecl -> MarkupDecl
    Entity (PEDecl -> EntityDecl
    EntityPEDecl (String -> PEDef -> PEDecl
    PEDecl (HType -> ShowS
    showHType HType
    ht String
    "") (EntityValue -> PEDef
    PEDefEntityValue EntityValue
    ev)))MarkupDecl -> [MarkupDecl] -> [MarkupDecl]
    forall a. a -> [a] -> [a]
    :
          (Constr -> [MarkupDecl]) -> [Constr] -> [MarkupDecl]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (t Constr -> Constr -> [MarkupDecl]
    forall {t :: * -> *}.
    Foldable t =>
    t Constr -> Constr -> [MarkupDecl]
    declConstr t Constr
    chist) [Constr]
    cs
          where ev :: EntityValue
    ev = [EV] -> EntityValue
    EntityValue [String -> EV
    EVString (Doc -> String
    render (CP -> Doc
    PP.cp (HType -> CP
    outerHtExpr HType
    ht)))]
        declConstr :: t Constr -> Constr -> [MarkupDecl]
    declConstr t Constr
    chist c :: Constr
    c@(Constr String
    s [HType]
    fv [HType]
    hts)
          | Constr
    c Constr -> t Constr -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` t Constr
    chist = [ElementDecl -> MarkupDecl
    Element (QName -> ContentSpec -> ElementDecl
    ElementDecl (String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ Constr -> ShowS
    flatConstr Constr
    c String
    "")
                                             (CP -> ContentSpec
    ContentSpec (Constr -> CP
    constrHtExpr Constr
    c)))]
          | Bool
    otherwise = []
        declprim :: HType -> [MarkupDecl]
    declprim (Prim String
    _ String
    t) =
          [ ElementDecl -> MarkupDecl
    Element (QName -> ContentSpec -> ElementDecl
    ElementDecl (String -> QName
    N String
    t) ContentSpec
    EMPTY)
          , AttListDecl -> MarkupDecl
    AttList (QName -> [AttDef] -> AttListDecl
    AttListDecl (String -> QName
    N String
    t) [QName -> AttType -> DefaultDecl -> AttDef
    AttDef (String -> QName
    N String
    "value") AttType
    StringType DefaultDecl
    REQUIRED])]
        declstring :: MarkupDecl
    declstring =
          ElementDecl -> MarkupDecl
    Element (QName -> ContentSpec -> ElementDecl
    ElementDecl (String -> QName
    N String
    "string") (Mixed -> ContentSpec
    Mixed Mixed
    PCDATA))
        grab :: Constr -> [HType]
    grab (Constr String
    _ [HType]
    _ [HType]
    hts) = [HType]
    hts

    (?) :: Bool -> (a->a) -> (a->a)
    Bool
    b ? :: forall a. Bool -> (a -> a) -> a -> a
    ? a -> a
    f | Bool
    b     = a -> a
    f
          | Bool -> Bool
    not Bool
    b = a -> a
    forall a. a -> a
    id

    -- Flatten an HType to a String suitable for an XML tagname.
    showHType :: HType -> ShowS
    showHType :: HType -> ShowS
    showHType (Maybe HType
    ht)  = String -> ShowS
    showString String
    "maybe-" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HType -> ShowS
    showHType HType
    ht
    showHType (List HType
    ht)   = String -> ShowS
    showString String
    "list-" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HType -> ShowS
    showHType HType
    ht
    showHType (Tuple [HType]
    hts) = String -> ShowS
    showString String
    "tuple" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> ShowS
    forall a. Show a => a -> ShowS
    shows ([HType] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [HType]
    hts)
                            ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> ShowS
    showChar Char
    '-'
                            ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    (.) (ShowS -> [ShowS] -> [ShowS]
    forall a. a -> [a] -> [a]
    intersperse (Char -> ShowS
    showChar Char
    '-')
                                                      ((HType -> ShowS) -> [HType] -> [ShowS]
    forall a b. (a -> b) -> [a] -> [b]
    map HType -> ShowS
    showHType [HType]
    hts))
    showHType (Prim String
    _ String
    t)  = String -> ShowS
    showString String
    t
    showHType HType
    String      = String -> ShowS
    showString String
    "string"
    showHType (Defined String
    s [HType]
    fv [Constr]
    _)
                          = String -> ShowS
    showString String
    s ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (([HType] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [HType]
    fv Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) Bool -> ShowS -> ShowS
    forall a. Bool -> (a -> a) -> a -> a
    ? Char -> ShowS
    showChar Char
    '-')
                            ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    (.) ShowS
    forall a. a -> a
    id (ShowS -> [ShowS] -> [ShowS]
    forall a. a -> [a] -> [a]
    intersperse (Char -> ShowS
    showChar Char
    '-')
                                                        ((HType -> ShowS) -> [HType] -> [ShowS]
    forall a b. (a -> b) -> [a] -> [b]
    map HType -> ShowS
    showHType [HType]
    fv))

    flatConstr :: Constr -> ShowS
    flatConstr :: Constr -> ShowS
    flatConstr (Constr String
    s [HType]
    fv [HType]
    _)
            = String -> ShowS
    showString String
    s ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (([HType] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [HType]
    fv Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) Bool -> ShowS -> ShowS
    forall a. Bool -> (a -> a) -> a -> a
    ? Char -> ShowS
    showChar Char
    '-')
              ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    (.) ShowS
    forall a. a -> a
    id (ShowS -> [ShowS] -> [ShowS]
    forall a. a -> [a] -> [a]
    intersperse (Char -> ShowS
    showChar Char
    '-') ((HType -> ShowS) -> [HType] -> [ShowS]
    forall a b. (a -> b) -> [a] -> [b]
    map HType -> ShowS
    showHType [HType]
    fv))

    outerHtExpr :: HType -> CP
    outerHtExpr :: HType -> CP
    outerHtExpr (Maybe HType
    ht)      = HType -> Modifier -> CP
    innerHtExpr HType
    ht Modifier
    Query
    outerHtExpr (List HType
    ht)       = HType -> Modifier -> CP
    innerHtExpr HType
    ht Modifier
    Star
    outerHtExpr (Defined String
    _s [HType]
    _fv [Constr]
    cs) =
        [CP] -> Modifier -> CP
    Choice ((Constr -> CP) -> [Constr] -> [CP]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Constr
    c->QName -> Modifier -> CP
    TagName (String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ Constr -> ShowS
    flatConstr Constr
    c String
    "") Modifier
    None) [Constr]
    cs) Modifier
    None
    outerHtExpr HType
    ht              = HType -> Modifier -> CP
    innerHtExpr HType
    ht Modifier
    None

    innerHtExpr :: HType -> Modifier -> CP
    innerHtExpr :: HType -> Modifier -> CP
    innerHtExpr (Prim String
    _ String
    t)  Modifier
    m = QName -> Modifier -> CP
    TagName (String -> QName
    N String
    t) Modifier
    m
    innerHtExpr (Tuple [HType]
    hts) Modifier
    m = [CP] -> Modifier -> CP
    Seq ((HType -> CP) -> [HType] -> [CP]
    forall a b. (a -> b) -> [a] -> [b]
    map (HType -> Modifier -> CP
    `innerHtExpr` Modifier
    None) [HType]
    hts) Modifier
    m
    innerHtExpr ht :: HType
    ht@(Defined String
    _ [HType]
    _ [Constr]
    _) Modifier
    m = -- CPPE (showHType ht "") (outerHtExpr ht)
                                       QName -> Modifier -> CP
    TagName (String -> QName
    N (Char
    '%'Char -> ShowS
    forall a. a -> [a] -> [a]
    : HType -> ShowS
    showHType HType
    ht String
    ";")) Modifier
    m
                                                            --  ***HACK!!!***
    innerHtExpr HType
    ht Modifier
    m = QName -> Modifier -> CP
    TagName (String -> QName
    N (String -> QName) -> String -> QName
    forall a b. (a -> b) -> a -> b
    $ HType -> ShowS
    showHType HType
    ht String
    "") Modifier
    m

    constrHtExpr :: Constr -> CP
    constrHtExpr :: Constr -> CP
    constrHtExpr (Constr String
    _s [HType]
    _fv [])  = QName -> Modifier -> CP
    TagName (String -> QName
    N String
    "EMPTY") Modifier
    None   --  ***HACK!!!***
    constrHtExpr (Constr String
    _s [HType]
    _fv [HType]
    hts) = HType -> Modifier -> CP
    innerHtExpr ([HType] -> HType
    Tuple [HType]
    hts) Modifier
    None

    ------------------------------------------------------------------------