-- | This module performs the translation of a parsed XML DTD into the

-- internal representation of corresponding Haskell data\/newtypes.

module DtdToHaskell.Convert

( dtd2TypeDef

) where

import Data.List (intersperse,nub)

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

import DtdToHaskell.TypeDef

---- Internal representation for database of DTD decls ----

data Record = R [AttDef] ContentSpec

-- type Db = [(String,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 mds =

(concatMap convert . reverse . database []) mds

where

database db [] = db

database db (m:ms) =

case m of

(Element (ElementDecl n cs)) ->

case lookup n db of

Nothing -> database ((n, R [] cs):db) ms

(Just (R as _)) -> database (replace n (R as cs) db) ms

(AttList (AttListDecl n as)) ->

case lookup n db of

Nothing -> database ((n, R as EMPTY):db) ms

(Just (R a cs)) -> database (replace n (R (nub (a++as)) cs) db) ms

-- (MarkupPE _ m') -> database db (m':ms)

_ -> database db ms

replace _ _ [] = error "dtd2TypeDef.replace: no element to replace"

replace n v (x@(n0,_):db)

| n==n0 = (n,v): db

| otherwise = x: replace n v db

---- Convert DTD record to typedef ----

convert :: (String, Record) -> [TypeDef]

convert (n, R as cs) =

case cs of

EMPTY -> modifier None []

ANY -> modifier None [[Any]]

--error "NYI: contentspec of ANY"

(Mixed PCDATA) -> modifier None [[String]]

(Mixed (PCDATAplus ns)) -> modifier Star ([String]: map ((:[]) . Defined . name) ns)

(ContentSpec cp) ->

case cp of

(TagName n' m) -> modifier m [[Defined (name n')]]

(Choice cps m) -> modifier m (map ((:[]).inner) cps)

(Seq cps m) -> modifier m [map inner cps]

++ concatMap (mkAttrDef n) as

where

attrs :: AttrFields

attrs = map (mkAttrField n) as

modifier None sts = mkData sts attrs False (name n)

modifier m [[st]] = mkData [[modf m st]] attrs False (name n)

modifier m sts = mkData [[modf m (Defined (name_ n))]]

attrs False (name n) ++

mkData sts [] True (name_ n)

inner :: CP -> StructType

inner (TagName n' m) = modf m (Defined (name n'))

inner (Choice cps m) = modf m (OneOf (map inner cps))

inner (Seq cps None) = Tuple (map inner cps)

inner (Seq cps m) = modf m (Tuple (map inner cps))

modf None x = x

modf Query x = Maybe x

modf Star x = List x

modf Plus x = List1 x

mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]

mkData [] fs aux n = [DataDef aux n fs []]

mkData [ts] fs aux n = [DataDef aux n fs [(n, ts)]]

mkData tss fs aux n = [DataDef aux n fs (map (mkConstr n) tss)]

where

mkConstr m ts = (mkConsName m ts, ts)

mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts)))

flatten (Maybe st) = {-"Maybe_" ++ -} flatten st

flatten (List st) = {-"List_" ++ -} flatten st

flatten (List1 st) = {-"List1_" ++ -} flatten st

flatten (Tuple sts) = {-"Tuple" ++ show (length sts) ++ "_" ++ -}

concat (intersperse "_" (map flatten sts))

flatten String = "Str"

flatten (OneOf sts) = {-"OneOf" ++ show (length sts) ++ "_" ++ -}

concat (intersperse "_" (map flatten sts))

flatten Any = "Any"

flatten (Defined (Name _ m)) = m

mkAttrDef :: String -> AttDef -> [TypeDef]

mkAttrDef _ (AttDef _ StringType _) =

[]

mkAttrDef _ (AttDef _ (TokenizedType _) _) =

[] -- mkData [[String]] [] False (name n)

mkAttrDef e (AttDef n (EnumeratedType (NotationType nt)) _) =

[EnumDef (name_a e n) (map (name_ac e n) nt)]

mkAttrDef e (AttDef n (EnumeratedType (Enumeration es)) _) =

[EnumDef (name_a e n) (map (name_ac e n) es)]

-- Default attribute values not handled here

mkAttrField :: String -> AttDef -> (Name,StructType)

mkAttrField e (AttDef n typ req) = (name_f e n, mkType typ req)

where

mkType StringType REQUIRED = String

mkType StringType IMPLIED = Maybe String

mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v)

mkType (TokenizedType _) REQUIRED = String

mkType (TokenizedType _) IMPLIED = Maybe String

mkType (TokenizedType _) (DefaultTo v@(AttValue _) _) =

Defaultable String (show v)

mkType (EnumeratedType _) REQUIRED = Defined (name_a e n)

mkType (EnumeratedType _) IMPLIED = Maybe (Defined (name_a e n))

mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) =

Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))