module Text.XML.HXT.Arrow.Pickle.DTD
where
import Data.Maybe
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.Pickle.Schema
import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames
data DTDdescr = DTDdescr Name Schemas [(Name,Schemas)]
instance Show DTDdescr where
show (DTDdescr n es as)
= "root element: " ++ n ++ "\n"
++
"elements:\n"
++
concatMap ((++ "\n") .show) es
++
"attributes:\n"
++
concatMap ((++ "\n") . showAttr) as
where
showAttr (n1, sc) = n1 ++ ": " ++ show sc
dtdDescrToXml :: DTDdescr -> XmlTrees
dtdDescrToXml (DTDdescr rt es as)
= checkErr (null rt) "no unique root element found in pickler DTD, add an \"xpElem\" pickler"
++
concatMap (checkErr True . ("no element decl found in: " ++) . show) (filter (not . isScElem) es)
++
concatMap (uncurry checkContentModell . \ (Element n sc) -> (n,sc)) es1
++
concatMap (uncurry checkAttrModell) as
++
[ XN.mkDTDElem DOCTYPE docAttrs ( concatMap elemDTD es1
++
concatMap (uncurry attrDTDs) as
) ]
where
es1 = filter isScElem es
docAttrs = [(a_name, if null rt then "no-unique-root-element-found" else rt)]
elemDTD (Element n sc)
| lookup1 a_type al == "unknown"
= cl
| otherwise
= [ XN.mkDTDElem ELEMENT ((a_name, n) : al) cl ]
where
(al, cl) = scContToXml sc
elemDTD _
= error "illegal case in elemDTD"
attrDTDs en = concatMap (attrDTD en)
attrDTD en (Attribute an sc)
= [ XN.mkDTDElem ATTLIST ((a_name, en) : (a_value, an) : al) cl ]
where
(al, cl) = scAttrToXml sc
attrDTD _ _ = error "illegal case in attrDTD"
checkAttrModell :: Name -> Schemas -> XmlTrees
checkAttrModell n = concatMap (checkAM n)
checkAM :: Name -> Schema -> XmlTrees
checkAM en (Attribute an sc) = checkAMC en an sc
checkAM _ _ = []
checkAMC :: Name -> Name -> Schema -> XmlTrees
checkAMC _en _an (CharData _) = []
checkAMC en an sc
| isScCharData sc = []
| isScList sc
&&
(sc_1 sc == scNmtoken)
= []
| isScOpt sc = checkAMC en an (sc_1 sc)
| otherwise = foundErr
( "weird attribute type found for attribute "
++ show an
++ " for element "
++ show en
++ "\n\t(internal structure: " ++ show sc ++ ")"
++ "\n\thint: create an element instead of an attribute for "
++ show an
)
checkContentModell :: Name -> Schema -> XmlTrees
checkContentModell _ Any
= []
checkContentModell _ (ElemRef _)
= []
checkContentModell _ (CharData _)
= []
checkContentModell _ (Seq [])
= []
checkContentModell n (Seq scs)
= checkErr pcDataInCM
( "PCDATA found in a sequence spec in the content modell for "
++ show n
++ "\n\thint: create an element for this data"
)
++
checkErr somethingElseInCM
( "something weired found in a sequence spec in the content modell for "
++ show n
)
++
concatMap (checkContentModell n) scs
where
pcDataInCM = any isScCharData scs
somethingElseInCM = any (\ sc -> not (isScSARE sc) && not (isScCharData sc)) scs
checkContentModell n (Alt scs)
= checkErr mixedCM
( "PCDATA mixed up with illegal content spec in mixed contents for "
++ show n
++ "\n\thint: create an element for this data"
)
++
concatMap (checkContentModell n) scs
where
mixedCM
| any isScCharData scs
= any (not . isScElemRef) . filter (not . isScCharData) $ scs
| otherwise
= False
checkContentModell _ (Rep _ _ (ElemRef _))
= []
checkContentModell n (Rep _ _ sc@(Seq _))
= checkContentModell n sc
checkContentModell n (Rep _ _ sc@(Alt _))
= checkContentModell n sc
checkContentModell n (Rep _ _ _)
= foundErr
( "illegal content spec found for "
++ show n
)
checkContentModell _ _
= []
scContToXml :: Schema -> (Attributes, XmlTrees)
scContToXml Any = ( [(a_type, v_any)], [] )
scContToXml (CharData _) = ( [(a_type, v_pcdata)], [] )
scContToXml (Seq []) = ( [(a_type, v_empty)], [] )
scContToXml sc@(ElemRef _) = scContToXml (Seq [sc])
scContToXml sc@(Seq _) = ( [(a_type, v_children)]
, scCont [] sc
)
scContToXml sc@(Alt sc1)
| isMixed sc1 = ( [(a_type, v_mixed)]
, scCont [ (a_modifier, "*") ] sc
)
| otherwise = ( [(a_type, v_children)]
, scCont [] sc
)
where
isMixed = not . null . filter isScCharData
scContToXml sc@(Rep _ _ _) = ( [(a_type, v_children)]
, scCont [] sc
)
scContToXml _sc = ( [(a_type, v_any)]
, []
)
scWrap :: Schema -> Schema
scWrap sc@(Alt _) = sc
scWrap sc@(Seq _) = sc
scWrap sc@(Rep _ _ _) = sc
scWrap sc = Seq [sc]
scCont :: Attributes -> Schema -> XmlTrees
scCont al (Seq scs) = scConts ((a_kind, v_seq ) : al) scs
scCont al (Alt scs) = scConts ((a_kind, v_choice) : al) scs
scCont al (Rep 0 (1) sc) = scCont ((a_modifier, "*") : al) (scWrap sc)
scCont al (Rep 1 (1) sc) = scCont ((a_modifier, "+") : al) (scWrap sc)
scCont al (Rep 0 1 sc) = scCont ((a_modifier, "?") : al) (scWrap sc)
scCont al (ElemRef n) = [XN.mkDTDElem NAME ((a_name, n) : al) []]
scCont _ (CharData _) = [XN.mkDTDElem NAME [(a_name, "#PCDATA")] []]
scCont _ _sc = [XN.mkDTDElem NAME [(a_name, "bad-content-spec")] []]
scConts :: Attributes -> Schemas -> XmlTrees
scConts al scs = [XN.mkDTDElem CONTENT al (concatMap (scCont []) scs)]
scAttrToXml :: Schema -> (Attributes, XmlTrees)
scAttrToXml sc
| isScFixed sc = ( [ (a_kind, k_fixed)
, (a_type, k_cdata)
, (a_default, (xsdParam xsd_enumeration sc))
]
, [])
| isScEnum sc = ( [ (a_kind, k_required)
, (a_type, k_enumeration)
]
, map (\ n -> XN.mkDTDElem NAME [(a_name, n)] []) enums
)
| isScCharData sc = ( [ (a_kind, k_required)
, (a_type, d_type)
]
, [])
| isScOpt sc = (addEntry a_kind k_implied al, cl)
| isScList sc = (addEntry a_type k_nmtokens al, cl)
| otherwise = ( [ (a_kind, k_fixed)
, (a_default, "bad-attribute-type: " ++ show sc)
]
, [] )
where
(al, cl) = scAttrToXml (sc_1 sc)
d_type
| sc == scNmtoken = k_nmtoken
| otherwise = k_cdata
enums = words . xsdParam xsd_enumeration $ sc
checkErr :: Bool -> String -> XmlTrees
checkErr True s = [XN.mkError c_err s]
checkErr _ _ = []
foundErr :: String -> XmlTrees
foundErr = checkErr True
dtdDescr :: Schema -> DTDdescr
dtdDescr sc
= DTDdescr rt es1 as
where
es = elementDeclarations sc
es1 = map remAttrDec es
as = filter (not. null . snd) . concatMap attrDec $ es
rt = fromMaybe "" . elemName $ sc
elementDeclarations :: Schema -> Schemas
elementDeclarations sc = elemRefs . elementDecs [] $ [sc]
elementDecs :: Schemas -> Schemas -> Schemas
elementDecs es []
= es
elementDecs es (s:ss)
= elementDecs (elemDecs s) ss
where
elemDecs (Seq scs) = elementDecs es scs
elemDecs (Alt scs) = elementDecs es scs
elemDecs (Rep _ _ sc) = elemDecs sc
elemDecs e@(Element n sc)
| n `elem` elemNames es = es
| otherwise = elementDecs (e:es) [sc]
elemDecs _ = es
elemNames :: Schemas -> [Name]
elemNames = concatMap (maybeToList . elemName)
elemName :: Schema -> Maybe Name
elemName (Element n _) = Just n
elemName _ = Nothing
elemRefs :: Schemas -> Schemas
elemRefs = map elemRef
where
elemRef (Element n sc) = Element n (pruneElem sc)
elemRef sc = sc
pruneElem (Element n _) = ElemRef n
pruneElem (Seq scs) = Seq (map pruneElem scs)
pruneElem (Alt scs) = Alt (map pruneElem scs)
pruneElem (Rep l u sc) = Rep l u (pruneElem sc)
pruneElem sc = sc
attrDec :: Schema -> [(Name, Schemas)]
attrDec (Element n sc)
= [(n, attrDecs sc)]
where
attrDecs a@(Attribute _ _) = [a]
attrDecs (Seq scs) = concatMap attrDecs scs
attrDecs _ = []
attrDec _ = []
remAttrDec :: Schema -> Schema
remAttrDec (Element n sc)
= Element n (remA sc)
where
remA (Attribute _ _) = scEmpty
remA (Seq scs) = scSeqs . map remA $ scs
remA sc1 = sc1
remAttrDec _
= error "illegal case in remAttrDec"