{- | 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 DtdToHaskell.Convert

( dtd2TypeDef

) where

import Data.List (intercalate, 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 = [(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 = concatMap convert . reverse . database []

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 :: (QName, Record) -> [TypeDef]

convert (N 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 ([StringMixed]

: map ((: []) . Defined . name

. \ (N n) -> n)

ns)

(ContentSpec cp) ->

case cp of

(TagName (N 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 n)) as

where

attrs :: AttrFields

attrs = map (mkAttrField (N 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 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 ++ intercalate "_" (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) ++ "_" ++

intercalate "_" (map flatten sts)

flatten StringMixed = "Str"

flatten String = "Str"

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

intercalate "_" (map flatten sts)

flatten Any = "Any"

flatten (Defined (Name _ m)) = m

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

mkAttrDef _ (AttDef _ StringType _) =

[]

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

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

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

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

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

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

-- Default attribute values not handled here

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

mkAttrField (N e) (AttDef (N 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)))