module Text.XML.HaXml.TypeMapping
(
HTypeable(..)
, HType(..)
, Constr(..)
, showHType
, showConstr
, 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
class HTypeable a where
toHType :: a -> HType
data HType =
Maybe HType
| List HType
| Tuple [HType]
| Prim String String
| String
| Defined String [HType] [Constr]
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
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 x :: HType
x) == :: HType -> HType -> Bool
== (Maybe y :: HType
y) = HType
xHType -> HType -> Bool
forall a. Eq a => a -> a -> Bool
==HType
y
(List x :: HType
x) == (List y :: HType
y) = HType
xHType -> HType -> Bool
forall a. Eq a => a -> a -> Bool
==HType
y
(Tuple xs :: [HType]
xs) == (Tuple ys :: [HType]
ys) = [HType]
xs[HType] -> [HType] -> Bool
forall a. Eq a => a -> a -> Bool
==[HType]
ys
(Prim x :: String
x _) == (Prim y :: String
y _) = String
xString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
y
String == String = Bool
True
(Defined n :: String
n _xs :: [HType]
_xs _) == (Defined m :: String
m _ys :: [HType]
_ys _) = String
nString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
m
_ == _ = Bool
False
data Constr = Constr String [HType] [HType]
deriving (Constr -> Constr -> Bool
(Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool) -> Eq Constr
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
(Int -> Constr -> ShowS)
-> (Constr -> String) -> ([Constr] -> ShowS) -> Show Constr
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)
showConstr :: Int -> HType -> String
showConstr :: Int -> HType -> String
showConstr n :: Int
n (Defined _ _ cs :: [Constr]
cs) = Constr -> ShowS
flatConstr ([Constr]
cs[Constr] -> Int -> Constr
forall a. [a] -> Int -> a
!!Int
n) ""
showConstr _ _ = ShowS
forall a. HasCallStack => String -> a
error "no constructors for builtin types"
instance HTypeable Bool where
toHType :: Bool -> HType
toHType _ = String -> String -> HType
Prim "Bool" "bool"
instance HTypeable Int where
toHType :: Int -> HType
toHType _ = String -> String -> HType
Prim "Int" "int"
instance HTypeable Integer where
toHType :: Integer -> HType
toHType _ = String -> String -> HType
Prim "Integer" "integer"
instance HTypeable Float where
toHType :: Float -> HType
toHType _ = String -> String -> HType
Prim "Float" "float"
instance HTypeable Double where
toHType :: Double -> HType
toHType _ = String -> String -> HType
Prim "Double" "double"
instance HTypeable Char where
toHType :: Char -> HType
toHType _ = String -> String -> HType
Prim "Char" "char"
instance HTypeable () where
toHType :: () -> HType
toHType _ = String -> String -> HType
Prim "unit" "unit"
instance (HTypeable a, HTypeable b) => HTypeable (a,b) where
toHType :: (a, b) -> HType
toHType p :: (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
a,b :: b
b) = (a, b)
p
instance (HTypeable a, HTypeable b, HTypeable c) => HTypeable (a,b,c) where
toHType :: (a, b, c) -> HType
toHType p :: (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
a,b :: b
b,c :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: i
i,j :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: i
i,j :: j
j,k :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: i
i,j :: j
j,k :: k
k,l :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: i
i,j :: j
j,k :: k
k,l :: l
l,m :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: i
i,j :: j
j,k :: k
k,l :: l
l,m :: m
m,n :: 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 p :: (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
a,b :: b
b,c :: c
c,d :: d
d,e :: e
e,f :: f
f,g :: g
g,h :: h
h,i :: i
i,j :: j
j,k :: k
k,l :: l
l,m :: m
m,n :: n
n,o :: 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 m :: Maybe a
m = HType -> HType
Maybe (a -> HType
forall a. HTypeable a => a -> HType
toHType a
x) where (Just x :: a
x) = Maybe a
m
instance (HTypeable a, HTypeable b) => HTypeable (Either a b) where
toHType :: Either a b -> HType
toHType m :: Either a b
m = String -> [HType] -> [Constr] -> HType
Defined "Either" [HType
hx, HType
hy]
[ String -> [HType] -> [HType] -> Constr
Constr "Left" [HType
hx] [HType
hx]
, String -> [HType] -> [HType] -> Constr
Constr "Right" [HType
hy] [HType
hy] ]
where (Left x :: a
x) = Either a b
m
(Right y :: 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 xs :: [a]
xs = case a -> HType
forall a. HTypeable a => a -> HType
toHType a
x of (Prim "Char" _) -> HType
String
_ -> HType -> HType
List (a -> HType
forall a. HTypeable a => a -> HType
toHType a
x)
where (x :: a
x:_) = [a]
xs
toDTD :: HType -> DocTypeDecl
toDTD :: HType -> DocTypeDecl
toDTD ht :: 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 decls :: [MarkupDecl]
decls = [[MarkupDecl]] -> [MarkupDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[MarkupDecl]
p, [MarkupDecl]
p'] where (p :: [MarkupDecl]
p, 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 _) = Bool
True
f _ = Bool
False
toplevel :: HType -> QName
toplevel ht :: HType
ht@(Defined _ _ _) = String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ HType -> ShowS
showHType HType
ht "-XML"
toplevel ht :: HType
ht@HType
_ = String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ HType -> ShowS
showHType HType
ht ""
c0 :: Bool
c0 = Bool
False
h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
h2d _c :: Bool
_c _history :: [HType]
_history _chist :: [Constr]
_chist [] = []
h2d c :: Bool
c history :: [HType]
history chist :: [Constr]
chist (ht :: HType
ht:hts :: [HType]
hts) =
if HType
ht HType -> [HType] -> 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 ht0 :: 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 ht0 :: 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 hts0 :: [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 _ _ -> 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
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 _ _ cs :: [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 ht :: 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 "")
(CP -> ContentSpec
ContentSpec (HType -> CP
outerHtExpr HType
ht)))
decltopelem :: HType -> MarkupDecl
decltopelem ht :: 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 "-XML")
(CP -> ContentSpec
ContentSpec (HType -> Modifier -> CP
innerHtExpr HType
ht Modifier
None)))
declmacro :: HType -> t Constr -> [MarkupDecl]
declmacro ht :: HType
ht@(Defined _ _ cs :: [Constr]
cs) chist :: t Constr
chist =
EntityDecl -> MarkupDecl
Entity (PEDecl -> EntityDecl
EntityPEDecl (String -> PEDef -> PEDecl
PEDecl (HType -> ShowS
showHType HType
ht "") (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 chist :: t Constr
chist c :: Constr
c@(Constr s :: String
s fv :: [HType]
fv hts :: [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 "")
(CP -> ContentSpec
ContentSpec (Constr -> CP
constrHtExpr Constr
c)))]
| Bool
otherwise = []
declprim :: HType -> [MarkupDecl]
declprim (Prim _ t :: 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 "value") AttType
StringType DefaultDecl
REQUIRED])]
declstring :: MarkupDecl
declstring =
ElementDecl -> MarkupDecl
Element (QName -> ContentSpec -> ElementDecl
ElementDecl (String -> QName
N "string") (Mixed -> ContentSpec
Mixed Mixed
PCDATA))
grab :: Constr -> [HType]
grab (Constr _ _ hts :: [HType]
hts) = [HType]
hts
(?) :: Bool -> (a->a) -> (a->a)
b :: Bool
b ? :: Bool -> (a -> a) -> a -> a
? f :: a -> a
f | Bool
b = a -> a
f
| Bool -> Bool
not Bool
b = a -> a
forall a. a -> a
id
showHType :: HType -> ShowS
showHType :: HType -> ShowS
showHType (Maybe ht :: HType
ht) = String -> ShowS
showString "maybe-" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HType -> ShowS
showHType HType
ht
showHType (List ht :: HType
ht) = String -> ShowS
showString "list-" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HType -> ShowS
showHType HType
ht
showHType (Tuple hts :: [HType]
hts) = String -> ShowS
showString "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 (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 '-'
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
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 '-')
((HType -> ShowS) -> [HType] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map HType -> ShowS
showHType [HType]
hts))
showHType (Prim _ t :: String
t) = String -> ShowS
showString String
t
showHType String = String -> ShowS
showString "string"
showHType (Defined s :: String
s fv :: [HType]
fv _)
= String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([HType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HType]
fv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) Bool -> ShowS -> ShowS
forall a. Bool -> (a -> a) -> a -> a
? (Char -> ShowS
showChar '-'))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
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 '-')
((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 s :: String
s fv :: [HType]
fv _)
= String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([HType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HType]
fv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) Bool -> ShowS -> ShowS
forall a. Bool -> (a -> a) -> a -> a
? (Char -> ShowS
showChar '-'))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
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 '-') ((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 ht :: HType
ht) = HType -> Modifier -> CP
innerHtExpr HType
ht Modifier
Query
outerHtExpr (List ht :: HType
ht) = HType -> Modifier -> CP
innerHtExpr HType
ht Modifier
Star
outerHtExpr (Defined _s :: String
_s _fv :: [HType]
_fv cs :: [Constr]
cs) =
[CP] -> Modifier -> CP
Choice ((Constr -> CP) -> [Constr] -> [CP]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: 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 "") Modifier
None) [Constr]
cs) Modifier
None
outerHtExpr ht :: HType
ht = HType -> Modifier -> CP
innerHtExpr HType
ht Modifier
None
innerHtExpr :: HType -> Modifier -> CP
innerHtExpr :: HType -> Modifier -> CP
innerHtExpr (Prim _ t :: String
t) m :: Modifier
m = QName -> Modifier -> CP
TagName (String -> QName
N String
t) Modifier
m
innerHtExpr (Tuple hts :: [HType]
hts) m :: Modifier
m = [CP] -> Modifier -> CP
Seq ((HType -> CP) -> [HType] -> [CP]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: HType
c-> HType -> Modifier -> CP
innerHtExpr HType
c Modifier
None) [HType]
hts) Modifier
m
innerHtExpr ht :: HType
ht@(Defined _ _ _) m :: Modifier
m =
QName -> Modifier -> CP
TagName (String -> QName
N ('%'Char -> ShowS
forall a. a -> [a] -> [a]
: HType -> ShowS
showHType HType
ht ";")) Modifier
m
innerHtExpr ht :: HType
ht m :: 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 "") Modifier
m
constrHtExpr :: Constr -> CP
constrHtExpr :: Constr -> CP
constrHtExpr (Constr _s :: String
_s _fv :: [HType]
_fv []) = QName -> Modifier -> CP
TagName (String -> QName
N "EMPTY") Modifier
None
constrHtExpr (Constr _s :: String
_s _fv :: [HType]
_fv hts :: [HType]
hts) = HType -> Modifier -> CP
innerHtExpr ([HType] -> HType
Tuple [HType]
hts) Modifier
None