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

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

import Data.List (intercalate,nub)

import Text.XML.HaXml.Types hiding (Name)
import Text.XML.HaXml.DtdToHaskell.TypeDef


---- Internal representation for database of DTD decls ----
data Record = R [AttDef] ContentSpec
-- type Db = [(QName,Record)]


---- Build a database of DTD decls then convert them to typedefs ----
---- (Done in two steps because we need to merge ELEMENT and ATTLIST decls.)
---- Apparently multiple ATTLIST decls for the same element are permitted,
---- although only one ELEMENT decl for it is allowed.
dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
dtd2TypeDef =
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName, Record) -> [TypeDef]
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database []
  where
  database :: [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database [(QName, Record)]
db [] = [(QName, Record)]
db
  database [(QName, Record)]
db (MarkupDecl
m:[MarkupDecl]
ms) =
      case MarkupDecl
m of
        (Element (ElementDecl QName
n ContentSpec
cs)) ->
          case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
n [(QName, Record)]
db of
            Maybe Record
Nothing -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database ((QName
n, [AttDef] -> ContentSpec -> Record
R [] ContentSpec
cs)forall a. a -> [a] -> [a]
:[(QName, Record)]
db) [MarkupDecl]
ms
            (Just (R [AttDef]
as ContentSpec
_)) -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database (forall {t} {t}. Eq t => t -> t -> [(t, t)] -> [(t, t)]
replace QName
n ([AttDef] -> ContentSpec -> Record
R [AttDef]
as ContentSpec
cs) [(QName, Record)]
db) [MarkupDecl]
ms
        (AttList (AttListDecl QName
n [AttDef]
as)) ->
          case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
n [(QName, Record)]
db of
            Maybe Record
Nothing -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database ((QName
n, [AttDef] -> ContentSpec -> Record
R [AttDef]
as ContentSpec
EMPTY)forall a. a -> [a] -> [a]
:[(QName, Record)]
db) [MarkupDecl]
ms
            (Just (R [AttDef]
a ContentSpec
cs)) -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database (forall {t} {t}. Eq t => t -> t -> [(t, t)] -> [(t, t)]
replace QName
n ([AttDef] -> ContentSpec -> Record
R (forall a. Eq a => [a] -> [a]
nub ([AttDef]
aforall a. [a] -> [a] -> [a]
++[AttDef]
as)) ContentSpec
cs) [(QName, Record)]
db) [MarkupDecl]
ms
    --  (MarkupPE _ m') -> database db (m':ms)
        MarkupDecl
_ -> [(QName, Record)] -> [MarkupDecl] -> [(QName, Record)]
database [(QName, Record)]
db [MarkupDecl]
ms

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



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

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

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

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

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

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

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