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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HType] -> ShowS
$cshowList :: [HType] -> ShowS
show :: HType -> String
$cshow :: HType -> String
showsPrec :: Int -> HType -> ShowS
$cshowsPrec :: Int -> HType -> ShowS
Show)

instance Eq HType where
    (Maybe HType
x)  == :: HType -> HType -> Bool
== (Maybe HType
y)  =  HType
xforall a. Eq a => a -> a -> Bool
==HType
y
    (List HType
x)   == (List HType
y)   =  HType
xforall a. Eq a => a -> a -> Bool
==HType
y
    (Tuple [HType]
xs) == (Tuple [HType]
ys) =  [HType]
xsforall a. Eq a => a -> a -> Bool
==[HType]
ys
    (Prim String
x String
_) == (Prim String
y String
_) =  String
xforall 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
nforall 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Constr -> Constr -> Bool
$c/= :: Constr -> Constr -> Bool
== :: Constr -> Constr -> Bool
$c== :: Constr -> Constr -> Bool
Eq,Int -> Constr -> ShowS
[Constr] -> ShowS
Constr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Constr] -> ShowS
$cshowList :: [Constr] -> ShowS
show :: Constr -> String
$cshow :: Constr -> String
showsPrec :: Int -> Constr -> ShowS
$cshowsPrec :: Int -> 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]
csforall a. [a] -> Int -> a
!!Int
n) String
""
showConstr Int
_ HType
_ = 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 [forall a. HTypeable a => a -> HType
toHType a
a, 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 [forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, 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 [forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , forall a. HTypeable a => a -> HType
toHType i
i, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , forall a. HTypeable a => a -> HType
toHType i
i, forall a. HTypeable a => a -> HType
toHType j
j, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , forall a. HTypeable a => a -> HType
toHType i
i, forall a. HTypeable a => a -> HType
toHType j
j, forall a. HTypeable a => a -> HType
toHType k
k, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , forall a. HTypeable a => a -> HType
toHType i
i, forall a. HTypeable a => a -> HType
toHType j
j, forall a. HTypeable a => a -> HType
toHType k
k, forall a. HTypeable a => a -> HType
toHType l
l
                           , 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , forall a. HTypeable a => a -> HType
toHType i
i, forall a. HTypeable a => a -> HType
toHType j
j, forall a. HTypeable a => a -> HType
toHType k
k, forall a. HTypeable a => a -> HType
toHType l
l
                           , forall a. HTypeable a => a -> HType
toHType m
m, 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 [ forall a. HTypeable a => a -> HType
toHType a
a, forall a. HTypeable a => a -> HType
toHType b
b, forall a. HTypeable a => a -> HType
toHType c
c, forall a. HTypeable a => a -> HType
toHType d
d
                           , forall a. HTypeable a => a -> HType
toHType e
e, forall a. HTypeable a => a -> HType
toHType f
f, forall a. HTypeable a => a -> HType
toHType g
g, forall a. HTypeable a => a -> HType
toHType h
h
                           , forall a. HTypeable a => a -> HType
toHType i
i, forall a. HTypeable a => a -> HType
toHType j
j, forall a. HTypeable a => a -> HType
toHType k
k, forall a. HTypeable a => a -> HType
toHType l
l
                           , forall a. HTypeable a => a -> HType
toHType m
m, forall a. HTypeable a => a -> HType
toHType n
n, 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 (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 = forall a. HTypeable a => a -> HType
toHType a
x
                         hy :: HType
hy = forall a. HTypeable a => a -> HType
toHType b
y

instance HTypeable a => HTypeable [a] where
    toHType :: [a] -> HType
toHType [a]
xs     = case forall a. HTypeable a => a -> HType
toHType a
x of (Prim String
"Char" String
_) -> HType
String
                                       HType
_ -> HType -> HType
List (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) forall a. Maybe a
Nothing ([MarkupDecl] -> [MarkupDecl]
macrosFirst (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 forall a. [a] -> [a] -> [a]
++ [MarkupDecl]
p' where ([MarkupDecl]
p, [MarkupDecl]
p') = 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 forall a b. (a -> b) -> a -> b
$ HType -> ShowS
showHType HType
ht String
"-XML"
    toplevel HType
ht                 = String -> QName
N 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 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
htforall a. a -> [a] -> [a]
: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d Bool
c0 (HType
htforall a. a -> [a] -> [a]
:[HType]
history) [Constr]
chist (HType
ht0forall a. a -> [a] -> [a]
:[HType]
hts)
          List HType
ht0   -> HType -> MarkupDecl
declelem HType
htforall a. a -> [a] -> [a]
: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d Bool
c0 (HType
htforall a. a -> [a] -> [a]
:[HType]
history) [Constr]
chist (HType
ht0forall a. a -> [a] -> [a]
:[HType]
hts)
          Tuple [HType]
hts0 -> (Bool
c forall a. Bool -> (a -> a) -> a -> a
? (HType -> MarkupDecl
declelem HType
htforall a. a -> [a] -> [a]
:))
                                     (Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d Bool
c0 [HType]
history [Constr]
chist ([HType]
hts0forall a. [a] -> [a] -> [a]
++[HType]
hts))
          Prim String
_ String
_   -> HType -> [MarkupDecl]
declprim HType
ht forall a. [a] -> [a] -> [a]
++ Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d Bool
c0 (HType
htforall a. a -> [a] -> [a]
:[HType]
history) [Constr]
chist [HType]
hts
          HType
String     -> MarkupDecl
declstringforall a. a -> [a] -> [a]
:    Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d Bool
c0 (HType
htforall a. a -> [a] -> [a]
:[HType]
history) [Constr]
chist [HType]
hts
          Defined String
_ [HType]
_ [Constr]
cs ->
               let hts0 :: [HType]
hts0 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constr -> [HType]
grab [Constr]
cs in
               (Bool
c forall a. Bool -> (a -> a) -> a -> a
? (HType -> MarkupDecl
decltopelem HType
htforall a. a -> [a] -> [a]
:)) (forall {t :: * -> *}.
Foldable t =>
HType -> t Constr -> [MarkupDecl]
declmacro HType
ht [Constr]
chist)
               forall a. [a] -> [a] -> [a]
++ Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d Bool
c0 (HType
htforall a. a -> [a] -> [a]
:[HType]
history) ([Constr]
csforall a. [a] -> [a] -> [a]
++[Constr]
chist) ([HType]
hts0forall a. [a] -> [a] -> [a]
++[HType]
hts)
    declelem :: HType -> MarkupDecl
declelem HType
ht =
      ElementDecl -> MarkupDecl
Element (QName -> ContentSpec -> ElementDecl
ElementDecl (String -> QName
N 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 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)))forall a. a -> [a] -> [a]
:
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (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 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 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 = 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-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HType -> ShowS
showHType HType
ht
showHType (List HType
ht)   = String -> ShowS
showString String
"list-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HType -> ShowS
showHType HType
ht
showHType (Tuple [HType]
hts) = String -> ShowS
showString String
"tuple" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (forall (t :: * -> *) a. Foldable t => t a -> Int
length [HType]
hts)
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'-'
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'-')
                                                  (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall (t :: * -> *) a. Foldable t => t a -> Int
length [HType]
fv forall a. Ord a => a -> a -> Bool
> Int
0) forall a. Bool -> (a -> a) -> a -> a
? Char -> ShowS
showChar Char
'-')
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'-')
                                                    (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall (t :: * -> *) a. Foldable t => t a -> Int
length [HType]
fv forall a. Ord a => a -> a -> Bool
> Int
0) forall a. Bool -> (a -> a) -> a -> a
? Char -> ShowS
showChar Char
'-')
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'-') (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 (forall a b. (a -> b) -> [a] -> [b]
map (\Constr
c->QName -> Modifier -> CP
TagName (String -> QName
N 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 (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
'%'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 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

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