module Text.XML.HXT.Validator.DocTransformation
( transform
)
where
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.Validator.AttributeValueValidation
import Data.Maybe
import Data.List
type TransEnvTable = [TransEnv]
type TransEnv = (ElemName, TransFct)
type ElemName = String
type TransFct = XmlFilter
transform :: XmlTree -> XmlTree -> XmlTrees
transform dtdPart dom
= traverseTree transTable dom
where
transTable = buildAllTransformationFunctions dtdPart
traverseTree :: TransEnvTable -> XmlFilter
traverseTree transEnv n@(NTree (XTag name _) cs)
= replaceChildren (concatMap (traverseTree transEnv) cs) (head (transFct n))
where
transFct = case (lookup (qualifiedName name) transEnv) of
Nothing -> this
Just f -> f
traverseTree _ n = [n]
buildAllTransformationFunctions :: XmlTree -> TransEnvTable
buildAllTransformationFunctions dtdPart
= buildTransRoot
:
map (buildTransformationFunctions dtdNodes) (isElement $$ dtdNodes)
where
dtdNodes = getChildren dtdPart
buildTransRoot :: TransEnv
buildTransRoot = (t_root, this)
buildTransformationFunctions :: XmlTrees -> XmlTree -> TransEnv
buildTransformationFunctions dtdPart n@(NTree (XDTD ELEMENT al) _)
= (name, transFct)
where
name = lookup1 a_name al
transFct = lexicographicAttributeOrder
`o`
normalizeAttributeValues n dtdPart
`o`
setDefaultAttributeValues n dtdPart
buildTransformationFunctions _ n
= error ("buildTransformationFunctions: illegeal parameter:\n" ++ show n)
lexicographicAttributeOrder :: XmlFilter
lexicographicAttributeOrder
= processAttrl sortAttrl
where
sortAttrl al
= map (al !!) ixs
where
ns = map nameOf al
ixs = map snd . sort . zip ns $ [(0::Int)..]
normalizeAttributeValues :: XmlTree -> XmlTrees -> XmlFilter
normalizeAttributeValues elemDescr@(NTree (XDTD ELEMENT _) _) dtdPart
= processAttr normalizeAttr
where
elemName = valueOfDTD a_name elemDescr
declaredAtts = isAttlistOfElement elemName $$ dtdPart
normalizeAttr :: XmlFilter
normalizeAttr att
= normalizeAttrValue (if null attDescr
then Nothing
else Just (head attDescr)) att
where
attDescr = filter (\ x -> (valueOfDTD a_value x) == nameOf att) declaredAtts
normalizeAttrValue :: Maybe XmlTree -> XmlFilter
normalizeAttrValue descr
= modifyChildren ((modifyText (normalizeAttributeValue descr) $$) . xmlTreesToText)
normalizeAttributeValues n _
= error ("normalizeAttributeValues: illegeal parameter:\n" ++ show n)
setDefaultAttributeValues :: XmlTree -> XmlTrees -> XmlFilter
setDefaultAttributeValues elemDescr@(NTree (XDTD ELEMENT _) _) dtdPart
= seqF (map setDefault defaultAtts)
where
elemName = valueOfDTD a_name elemDescr
defaultAtts = ( isFixedAttrKind
`orElse`
isDefaultAttrKind
)
$$
(isAttlistOfElement elemName $$ dtdPart)
setDefault :: XmlTree -> XmlFilter
setDefault attrDescr
= ( addAttr attName defaultValue
`whenNot`
hasAttr attName
)
`when`
isXTag
where
attName = valueOfDTD a_value attrDescr
defaultValue = valueOfDTD a_default attrDescr
setDefaultAttributeValues n _
= error ("setDefaultAttributeValues: illegeal parameter:\n" ++ show n)