module Text.XML.HaXml.DtdToHaskell.Convert
( dtd2TypeDef
) where
import Data.List (intersperse,nub)
import Text.XML.HaXml.Types hiding (Name)
import Text.XML.HaXml.DtdToHaskell.TypeDef
data Record = R [AttDef] ContentSpec
dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
dtd2TypeDef mds :: [MarkupDecl]
mds =
(((QName, Record) -> [TypeDef]) -> [(QName, Record)] -> [TypeDef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName, Record) -> [TypeDef]
convert ([(QName, Record)] -> [TypeDef])
-> ([MarkupDecl] -> [(QName, Record)]) -> [MarkupDecl] -> [TypeDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(QName, Record)] -> [(QName, Record)]
forall a. [a] -> [a]
reverse ([(QName, Record)] -> [(QName, Record)])
-> ([MarkupDecl] -> [(QName, Record)])
-> [MarkupDecl]
-> [(QName, Record)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database []) [MarkupDecl]
mds
where
database :: [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database db :: [(QName, Record)]
db [] = [(QName, Record)]
db
database db :: [(QName, Record)]
db (m :: MarkupDecl
m:ms :: [MarkupDecl]
ms) =
case MarkupDecl
m of
(Element (ElementDecl n :: QName
n cs :: ContentSpec
cs)) ->
case QName -> [(QName, Record)] -> Maybe Record
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
n [(QName, Record)]
db of
Nothing -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database ((QName
n, [AttDef] -> ContentSpec -> Record
R [] ContentSpec
cs)(QName, Record) -> [(QName, Record)] -> [(QName, Record)]
forall a. a -> [a] -> [a]
:[(QName, Record)]
db) [MarkupDecl]
ms
(Just (R as :: [AttDef]
as _)) -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database (QName -> Record -> [(QName, Record)] -> [(QName, Record)]
forall t t. Eq t => t -> t -> [(t, t)] -> [(t, t)]
replace QName
n ([AttDef] -> ContentSpec -> Record
R [AttDef]
as ContentSpec
cs) [(QName, Record)]
db) [MarkupDecl]
ms
(AttList (AttListDecl n :: QName
n as :: [AttDef]
as)) ->
case QName -> [(QName, Record)] -> Maybe Record
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
n [(QName, Record)]
db of
Nothing -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database ((QName
n, [AttDef] -> ContentSpec -> Record
R [AttDef]
as ContentSpec
EMPTY)(QName, Record) -> [(QName, Record)] -> [(QName, Record)]
forall a. a -> [a] -> [a]
:[(QName, Record)]
db) [MarkupDecl]
ms
(Just (R a :: [AttDef]
a cs :: ContentSpec
cs)) -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database (QName -> Record -> [(QName, Record)] -> [(QName, Record)]
forall t t. Eq t => t -> t -> [(t, t)] -> [(t, t)]
replace QName
n ([AttDef] -> ContentSpec -> Record
R ([AttDef] -> [AttDef]
forall a. Eq a => [a] -> [a]
nub ([AttDef]
a[AttDef] -> [AttDef] -> [AttDef]
forall a. [a] -> [a] -> [a]
++[AttDef]
as)) ContentSpec
cs) [(QName, Record)]
db) [MarkupDecl]
ms
_ -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database [(QName, Record)]
db [MarkupDecl]
ms
replace :: t -> t -> [(t, t)] -> [(t, t)]
replace _ _ [] = [Char] -> [(t, t)]
forall a. HasCallStack => [Char] -> a
error "dtd2TypeDef.replace: no element to replace"
replace n :: t
n v :: t
v (x :: (t, t)
x@(n0 :: t
n0,_):db :: [(t, t)]
db)
| t
nt -> t -> Bool
forall a. Eq a => a -> a -> Bool
==t
n0 = (t
n,t
v)(t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: [(t, t)]
db
| Bool
otherwise = (t, t)
x(t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: t -> t -> [(t, t)] -> [(t, t)]
replace t
n t
v [(t, t)]
db
convert :: (QName, Record) -> [TypeDef]
convert :: (QName, Record) -> [TypeDef]
convert (N n :: [Char]
n, R as :: [AttDef]
as cs :: ContentSpec
cs) =
case ContentSpec
cs of
EMPTY -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
None []
ANY -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
None [[StructType
Any]]
(Mixed PCDATA) -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
None [[StructType
String]]
(Mixed (PCDATAplus ns :: [QName]
ns)) -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
Star ([StructType
StringMixed]
[StructType] -> [[StructType]] -> [[StructType]]
forall a. a -> [a] -> [a]
: (QName -> [StructType]) -> [QName] -> [[StructType]]
forall a b. (a -> b) -> [a] -> [b]
map ((StructType -> [StructType] -> [StructType]
forall a. a -> [a] -> [a]
:[]) (StructType -> [StructType])
-> (QName -> StructType) -> QName -> [StructType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> StructType
Defined (Name -> StructType) -> (QName -> Name) -> QName -> StructType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
name
([Char] -> Name) -> (QName -> [Char]) -> QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(N n :: [Char]
n)->[Char]
n)
[QName]
ns)
(ContentSpec cp :: CP
cp) ->
case CP
cp of
(TagName (N n' :: [Char]
n') m :: Modifier
m) -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
m [[Name -> StructType
Defined ([Char] -> Name
name [Char]
n')]]
(Choice cps :: [CP]
cps m :: Modifier
m) -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
m ((CP -> [StructType]) -> [CP] -> [[StructType]]
forall a b. (a -> b) -> [a] -> [b]
map ((StructType -> [StructType] -> [StructType]
forall a. a -> [a] -> [a]
:[])(StructType -> [StructType])
-> (CP -> StructType) -> CP -> [StructType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CP -> StructType
inner) [CP]
cps)
(Seq cps :: [CP]
cps m :: Modifier
m) -> Modifier -> [[StructType]] -> [TypeDef]
modifier Modifier
m [(CP -> StructType) -> [CP] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map CP -> StructType
inner [CP]
cps]
[TypeDef] -> [TypeDef] -> [TypeDef]
forall a. [a] -> [a] -> [a]
++ (AttDef -> [TypeDef]) -> [AttDef] -> [TypeDef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName -> AttDef -> [TypeDef]
mkAttrDef ([Char] -> QName
N [Char]
n)) [AttDef]
as
where
attrs :: AttrFields
attrs :: AttrFields
attrs = (AttDef -> (Name, StructType)) -> [AttDef] -> AttrFields
forall a b. (a -> b) -> [a] -> [b]
map (QName -> AttDef -> (Name, StructType)
mkAttrField ([Char] -> QName
N [Char]
n)) [AttDef]
as
modifier :: Modifier -> [[StructType]] -> [TypeDef]
modifier None sts :: [[StructType]]
sts = [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
mkData [[StructType]]
sts AttrFields
attrs Bool
False ([Char] -> Name
name [Char]
n)
modifier m :: Modifier
m [[st :: StructType
st]] = [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
mkData [[Modifier -> StructType -> StructType
modf Modifier
m StructType
st]] AttrFields
attrs Bool
False ([Char] -> Name
name [Char]
n)
modifier m :: Modifier
m sts :: [[StructType]]
sts = [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
mkData [[Modifier -> StructType -> StructType
modf Modifier
m (Name -> StructType
Defined ([Char] -> Name
name_ [Char]
n))]]
AttrFields
attrs Bool
False ([Char] -> Name
name [Char]
n) [TypeDef] -> [TypeDef] -> [TypeDef]
forall a. [a] -> [a] -> [a]
++
[[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
mkData [[StructType]]
sts [] Bool
True ([Char] -> Name
name_ [Char]
n)
inner :: CP -> StructType
inner :: CP -> StructType
inner (TagName (N n' :: [Char]
n') m :: Modifier
m) = Modifier -> StructType -> StructType
modf Modifier
m (Name -> StructType
Defined ([Char] -> Name
name [Char]
n'))
inner (Choice cps :: [CP]
cps m :: Modifier
m) = Modifier -> StructType -> StructType
modf Modifier
m ([StructType] -> StructType
OneOf ((CP -> StructType) -> [CP] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map CP -> StructType
inner [CP]
cps))
inner (Seq cps :: [CP]
cps None) = [StructType] -> StructType
Tuple ((CP -> StructType) -> [CP] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map CP -> StructType
inner [CP]
cps)
inner (Seq cps :: [CP]
cps m :: Modifier
m) = Modifier -> StructType -> StructType
modf Modifier
m ([StructType] -> StructType
Tuple ((CP -> StructType) -> [CP] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map CP -> StructType
inner [CP]
cps))
modf :: Modifier -> StructType -> StructType
modf None x :: StructType
x = StructType
x
modf Query x :: StructType
x = StructType -> StructType
Maybe StructType
x
modf Star x :: StructType
x = StructType -> StructType
List StructType
x
modf Plus x :: StructType
x = StructType -> StructType
List1 StructType
x
mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
mkData [] fs :: AttrFields
fs aux :: Bool
aux n :: Name
n = [Bool -> Name -> AttrFields -> Constructors -> TypeDef
DataDef Bool
aux Name
n AttrFields
fs []]
mkData [ts :: [StructType]
ts] fs :: AttrFields
fs aux :: Bool
aux n :: Name
n = [Bool -> Name -> AttrFields -> Constructors -> TypeDef
DataDef Bool
aux Name
n AttrFields
fs [(Name
n, [StructType]
ts)]]
mkData tss :: [[StructType]]
tss fs :: AttrFields
fs aux :: Bool
aux n :: Name
n = [Bool -> Name -> AttrFields -> Constructors -> TypeDef
DataDef Bool
aux Name
n AttrFields
fs (([StructType] -> (Name, [StructType]))
-> [[StructType]] -> Constructors
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [StructType] -> (Name, [StructType])
mkConstr Name
n) [[StructType]]
tss)]
where
mkConstr :: Name -> [StructType] -> (Name, [StructType])
mkConstr m :: Name
m ts :: [StructType]
ts = (Name -> [StructType] -> Name
mkConsName Name
m [StructType]
ts, [StructType]
ts)
mkConsName :: Name -> [StructType] -> Name
mkConsName (Name x :: [Char]
x m :: [Char]
m) sts :: [StructType]
sts = [Char] -> [Char] -> Name
Name [Char]
x ([Char]
m[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse "_" ((StructType -> [Char]) -> [StructType] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> [Char]
flatten [StructType]
sts)))
flatten :: StructType -> [Char]
flatten (Maybe st :: StructType
st) = StructType -> [Char]
flatten StructType
st
flatten (List st :: StructType
st) = StructType -> [Char]
flatten StructType
st
flatten (List1 st :: StructType
st) = StructType -> [Char]
flatten StructType
st
flatten (Tuple sts :: [StructType]
sts) =
[[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse "_" ((StructType -> [Char]) -> [StructType] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> [Char]
flatten [StructType]
sts))
flatten StringMixed = "Str"
flatten String = "Str"
flatten (OneOf sts :: [StructType]
sts) =
[[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse "_" ((StructType -> [Char]) -> [StructType] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> [Char]
flatten [StructType]
sts))
flatten Any = "Any"
flatten (Defined (Name _ m :: [Char]
m)) = [Char]
m
mkAttrDef :: QName -> AttDef -> [TypeDef]
mkAttrDef :: QName -> AttDef -> [TypeDef]
mkAttrDef _ (AttDef _ StringType _) =
[]
mkAttrDef _ (AttDef _ (TokenizedType _) _) =
[]
mkAttrDef (N e :: [Char]
e) (AttDef (N n :: [Char]
n) (EnumeratedType (NotationType nt :: [[Char]]
nt)) _) =
[Name -> [Name] -> TypeDef
EnumDef ([Char] -> [Char] -> Name
name_a [Char]
e [Char]
n) (([Char] -> Name) -> [[Char]] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char] -> Name
name_ac [Char]
e [Char]
n) [[Char]]
nt)]
mkAttrDef (N e :: [Char]
e) (AttDef (N n :: [Char]
n) (EnumeratedType (Enumeration es :: [[Char]]
es)) _) =
[Name -> [Name] -> TypeDef
EnumDef ([Char] -> [Char] -> Name
name_a [Char]
e [Char]
n) (([Char] -> Name) -> [[Char]] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char] -> Name
name_ac [Char]
e [Char]
n) [[Char]]
es)]
mkAttrField :: QName -> AttDef -> (Name,StructType)
mkAttrField :: QName -> AttDef -> (Name, StructType)
mkAttrField (N e :: [Char]
e) (AttDef (N n :: [Char]
n) typ :: AttType
typ req :: DefaultDecl
req) = ([Char] -> [Char] -> Name
name_f [Char]
e [Char]
n, AttType -> DefaultDecl -> StructType
mkType AttType
typ DefaultDecl
req)
where
mkType :: AttType -> DefaultDecl -> StructType
mkType StringType REQUIRED = StructType
String
mkType StringType IMPLIED = StructType -> StructType
Maybe StructType
String
mkType StringType (DefaultTo v :: AttValue
v@(AttValue _) _) = StructType -> [Char] -> StructType
Defaultable StructType
String (AttValue -> [Char]
forall a. Show a => a -> [Char]
show AttValue
v)
mkType (TokenizedType _) REQUIRED = StructType
String
mkType (TokenizedType _) IMPLIED = StructType -> StructType
Maybe StructType
String
mkType (TokenizedType _) (DefaultTo v :: AttValue
v@(AttValue _) _) =
StructType -> [Char] -> StructType
Defaultable StructType
String (AttValue -> [Char]
forall a. Show a => a -> [Char]
show AttValue
v)
mkType (EnumeratedType _) REQUIRED = Name -> StructType
Defined ([Char] -> [Char] -> Name
name_a [Char]
e [Char]
n)
mkType (EnumeratedType _) IMPLIED = StructType -> StructType
Maybe (Name -> StructType
Defined ([Char] -> [Char] -> Name
name_a [Char]
e [Char]
n))
mkType (EnumeratedType _) (DefaultTo v :: AttValue
v@(AttValue _) _) =
StructType -> [Char] -> StructType
Defaultable (Name -> StructType
Defined ([Char] -> [Char] -> Name
name_a [Char]
e [Char]
n)) (Name -> [Char]
hName ([Char] -> [Char] -> [Char] -> Name
name_ac [Char]
e [Char]
n (AttValue -> [Char]
forall a. Show a => a -> [Char]
show AttValue
v)))