-- | 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 (intersperse,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 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
    --  (MarkupPE _ m') -> database db (m':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 DTD record to typedef ----
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]]
                                 --error "NYI: contentspec of 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)   = {-"Maybe_" ++ -} StructType -> [Char]
flatten StructType
st
    flatten (List st :: StructType
st)    = {-"List_" ++ -} StructType -> [Char]
flatten StructType
st
    flatten (List1 st :: StructType
st)   = {-"List1_" ++ -} StructType -> [Char]
flatten StructType
st
    flatten (Tuple sts :: [StructType]
sts)  = {-"Tuple" ++ show (length 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)  = {-"OneOf" ++ show (length 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 _) _) =
    [] -- mkData [[String]] [] False (name n)
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)]
        -- Default attribute values not handled here

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)))