module Text.XML.HXT.Validator.IdValidation
( validateIds
)
where
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.Validator.AttributeValueValidation
type IdEnvTable = [IdEnv]
type IdEnv = (ElemName, IdFct)
type ElemName = String
type IdFct = XmlFilter
validateIds :: XmlTree -> XmlTree -> XmlTrees
validateIds dtdPart doc
= checkForUniqueIds idNodeList dtdNodes
++
checkIdReferences idRefEnv doc
where
idEnv = buildIdCollectorFcts dtdNodes
idRefEnv = buildIdrefValidationFcts dtdNodes idNodeList
idNodeList = traverseTree idEnv doc
dtdNodes = getChildren dtdPart
traverseTree :: IdEnvTable -> XmlFilter
traverseTree idEnv n@(NTree (XTag name _) cs)
= (idFct n) ++ concatMap (traverseTree idEnv) cs
where
idFct :: XmlFilter
idFct
= case (lookup (tName name) idEnv) of
Nothing -> none
Just f -> f
traverseTree _ _ = []
getIdValue :: XmlTrees -> XmlTree -> String
getIdValue (x@(NTree (XDTD ATTLIST al) _):xs) n@(NTree (XTag name _al') _)
= if (tName name) == elemName
then attrValue
else getIdValue xs n
where
elemName = lookup1 a_name al
attrName = lookup1 a_value al
attrValue = normalizeAttributeValue (Just x) (valueOf attrName n)
getIdValue _ _ = ""
buildIdCollectorFcts :: XmlTrees -> IdEnvTable
buildIdCollectorFcts dtdPart
= map (buildIdCollectorFct) (isIdAttrType $$ dtdPart)
where
buildIdCollectorFct :: XmlTree -> IdEnv
buildIdCollectorFct (NTree (XDTD ATTLIST al) _)
= (elemName, hasAttr attrName)
where
elemName = lookup1 a_name al
attrName = lookup1 a_value al
buildIdCollectorFct nd
= error ("buildIdCollectorFct: illegeal parameter:\n" ++ show nd)
buildIdrefValidationFcts :: XmlTrees -> XmlTrees -> IdEnvTable
buildIdrefValidationFcts dtdPart idNodeList
= map buildElemValidationFct elements
where
elements = isElement $$ dtdPart
idValueList = getIdValues (isIdAttrType $$ dtdPart)
getIdValues :: XmlTrees -> [String]
getIdValues idAttrTypes
= map (getIdValue idAttrTypes) idNodeList
buildElemValidationFct :: XmlTree -> IdEnv
buildElemValidationFct (NTree (XDTD ELEMENT al) _)
= (elemName, buildIdrefValidationFct idRefAttrTypes)
where
elemName = lookup1 a_name al
idRefAttrTypes = isIdRefAttrType $$ (isAttlistOfElement elemName) $$ dtdPart
buildElemValidationFct nd
= error ("buildIdrefValidationFct: illegeal parameter:\n" ++ show nd)
buildIdrefValidationFct :: XmlTrees -> XmlFilter
buildIdrefValidationFct (nd@(NTree (XDTD ATTLIST al) _):xs)
= checkIdref +++ buildIdrefValidationFct xs
where
attrName = lookup1 a_value al
attrType = lookup1 a_type al
checkIdref :: XmlFilter
checkIdref n@(NTree (XTag name _) _)
= if satisfies (hasAttr attrName) n
then if attrType == k_idref
then checkValueDeclared n attrValue
else let valueList = words attrValue
in if null valueList
then err ("Attribute " ++ show attrName ++
" of Element " ++ show (tName name) ++
" must have at least one name.") n
else concatMap (checkValueDeclared n) (words attrValue)
else []
where
attrValue = normalizeAttributeValue (Just nd) (valueOf attrName n)
checkIdref _ = []
checkValueDeclared :: XmlTree -> String -> XmlTrees
checkValueDeclared n@(NTree (XTag _ _) _) attrValue
= if attrValue `elem` idValueList
then []
else err ("An Element with identifier " ++ show attrValue ++
" must appear in the document.") n
checkValueDeclared _ _ = []
buildIdrefValidationFct []
= none
buildIdrefValidationFct nd
= error ("buildIdCollectorFct: illegeal parameter:\n" ++ show nd)
checkForUniqueIds :: XmlTrees -> XmlTrees -> XmlTrees
checkForUniqueIds idNodeList dtdPart
= checkForUniqueId idNodeList []
where
idAttrTypes = isIdAttrType $$ dtdPart
checkForUniqueId :: XmlTrees -> [String] -> XmlTrees
checkForUniqueId (x@(NTree (XTag name _) _):xs) used
= if attrValue `elem` used
then err ("Attribute value " ++ show attrValue ++ " of type ID for element " ++
show (tName name) ++ " must be unique within the document.") x
++
checkForUniqueId xs used
else checkForUniqueId xs (attrValue : used)
where
attrValue = getIdValue (isAttlistOfElement (tName name) $$ idAttrTypes) x
checkForUniqueId _ _ = []
checkIdReferences :: IdEnvTable -> XmlTree -> XmlTrees
checkIdReferences idRefEnv doc
= traverseTree idRefEnv doc