module Text.XML.HXT.Validator.DTDValidation
( removeDoublicateDefs
, validateDTD
)
where
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.Validator.AttributeValueValidation
validateDTD :: XmlFilter
validateDTD dtdPart
= validateNotations dtdPart'
++
validateEntities dtdPart' notationNames
++
validateElements dtdPart' elemNames
++
validateAttributes dtdPart' elemNames notationNames
where
dtdPart' = getChildren dtdPart
notationNames :: [String]
notationNames
= getXTextValues (isNotation .> getDTDValue a_name $$ dtdPart')
elemNames :: [String]
elemNames
= getXTextValues (isElement .> getDTDValue a_name $$ dtdPart')
getXTextValues :: XmlTrees -> [String]
getXTextValues
= concatMap showT
where
showT (NTree n _)
| isXTextNode n = [textOfXNode n]
showT _ = []
validateNotations :: XmlTrees -> XmlTrees
validateNotations dtdPart
= checkForUniqueNotation notations []
where
notations = isNotation $$ dtdPart
checkForUniqueNotation :: XmlTrees -> [String] -> XmlTrees
checkForUniqueNotation (x@(NTree (XDTD NOTATION al) _):xs) used
= if name `elem` used
then err ("Notation "++ show name ++ " was already specified.") x
++
checkForUniqueNotation xs used
else checkForUniqueNotation xs (name : used)
where
name = lookup1 a_name al
checkForUniqueNotation [] _ = []
checkForUniqueNotation nd _
= error ("checkForUniqueNotation: illegeal parameter:\n" ++ show nd)
validateEntities :: XmlTrees -> [String] -> XmlTrees
validateEntities dtdPart notationNames
= checkForUniqueEntity entities []
++
checkNotationDecls notationNames upEntities
where
entities = isEntity $$ dtdPart
upEntities = isUnparsedEntity $$ dtdPart
checkForUniqueEntity :: XmlTrees -> [String] -> XmlTrees
checkForUniqueEntity (x@(NTree (XDTD ENTITY al) _):xs) used
= if name `elem` used
then warn ("Entity "++ show name ++ " was already specified. " ++
"First declaration will be used.") x
++
checkForUniqueEntity xs used
else checkForUniqueEntity xs (name : used)
where
name = lookup1 a_name al
checkForUniqueEntity [] _ = []
checkForUniqueEntity nd _
= error ("checkForUniqueEntity: illegeal parameter:\n" ++ show nd)
checkNotationDecls :: [String] -> XmlTrees -> XmlTrees
checkNotationDecls notationNames' upEntities'
= concatMap (checkNotationDecl) upEntities'
where
checkNotationDecl :: XmlTree -> XmlTrees
checkNotationDecl n@(NTree (XDTD ENTITY al) _)
= if (notationName al) `elem` notationNames'
then []
else err ("The notation " ++ show (notationName al) ++ " must be declared " ++
"when referenced in the unparsed entity declaration for " ++
show (upEntityName al) ++ ".") n
where
notationName = lookup1 k_ndata
upEntityName = lookup1 a_name
checkNotationDecl nd
= error ("checkNotationDecl: illegeal parameter:\n" ++ show nd)
validateElements :: XmlTrees -> [String] -> XmlTrees
validateElements dtdPart elemNames
= checkForUniqueElement elements []
++
checkMixedContents mixedContentElems
++
checkContentModels elemNames elements
where
elements = isElement $$ dtdPart
mixedContentElems = isMixedContentElement $$ dtdPart
checkForUniqueElement :: XmlTrees -> [String] -> XmlTrees
checkForUniqueElement (x@(NTree (XDTD ELEMENT al) _):xs) used
= if name `elem` used
then err ("Element type " ++ show name ++
" must not be declared more than once.") x
++
checkForUniqueElement xs used
else checkForUniqueElement xs (name : used)
where
name = lookup1 a_name al
checkForUniqueElement [] _ = []
checkForUniqueElement nd _
= error ("checkForUniqueElement: illegeal parameter:\n" ++ show nd)
checkMixedContents elems
= concatMap (checkMixedContent) elems
where
checkMixedContent (NTree (XDTD ELEMENT al) cs)
= checkMC (getChildren (head cs)) []
where
elemName = lookup1 a_name al
checkMC :: XmlTrees -> [String] -> XmlTrees
checkMC (x@(NTree (XDTD NAME al') _):xs) used
= if name `elem` used
then err ("The element type " ++ show name ++
" was already specified in the mixed-content model of the element declaration " ++
show elemName ++ ".") x
++
checkMC xs used
else checkMC xs (name : used)
where
name = lookup1 a_name al'
checkMC [] _ = []
checkMC nd _
= error ("checkMC: illegeal parameter:\n" ++ show nd)
checkMixedContent nd
= error ("checkMixedContent: illegeal parameter:\n" ++ show nd)
checkContentModels names elems
= concatMap checkContentModel elems
where
checkContentModel :: XmlFilter
checkContentModel (NTree (XDTD ELEMENT al) cs)
= validateContent (lookup1 a_type al)
where
elemName = lookup1 a_name al
validateContent :: String -> XmlTrees
validateContent cm
| cm == v_children = checkContent (head cs)
| cm == v_mixed = checkContent (head cs)
| otherwise = []
checkContent :: XmlFilter
checkContent n@(NTree (XDTD NAME al') _)
= if childElemName `elem` names
then []
else warn ("The element type "++ show childElemName ++
", used in content model of element "++ show elemName ++
", is not declared.") n
where
childElemName = lookup1 a_name al'
checkContent (NTree (XDTD CONTENT _) cs')
= concatMap (checkContent) cs'
checkContent nd
= error ("checkContent: illegeal parameter:\n" ++ show nd)
checkContentModel nd
= error ("checkContentModel: illegeal parameter:\n" ++ show nd)
validateAttributes :: XmlTrees -> [String] -> [String] -> XmlTrees
validateAttributes dtdPart elemNames notationNames
=
((checkDeclaredElements elemNames) $$ attributes)
++
(checkForUniqueAttributeDeclaration attributes [])
++
(checkEnumeratedTypes
`o`
(isEnumAttrType `orElse` isNotationAttrType) $$ attributes)
++
(checkForUniqueId idAttributes [])
++
(checkForUniqueNotation notationAttributes [])
++
(checkIdKindConstraint $$ idAttributes)
++
((checkNotationDeclaration notationNames) $$ notationAttributes)
++
((checkNoNotationForEmptyElement
(
getXTextValues (getDTDValue a_name $$ (isEmptyElement $$ dtdPart))
)
) $$ notationAttributes)
++
((checkDefaultValueTypes dtdPart) $$ (isDefaultAttrKind $$ attributes))
where
attributes = isAttlist $$ dtdPart
idAttributes = isIdAttrType $$ attributes
notationAttributes = isNotationAttrType $$ attributes
elemName = lookup1 a_name
attName = lookup1 a_value
checkDeclaredElements :: [String] -> XmlFilter
checkDeclaredElements elemNames' n@(NTree (XDTD ATTLIST al) _)
= if (elemName al) `elem` elemNames'
then []
else warn ("The element type \""++ elemName al ++ "\" used in declaration "++
"of attribute \""++ attName al ++"\" is not declared.") n
checkDeclaredElements _ nd
= error ("checkDeclaredElements: illegeal parameter:\n" ++ show nd)
checkForUniqueAttributeDeclaration :: XmlTrees -> [String] -> XmlTrees
checkForUniqueAttributeDeclaration (x@(NTree (XDTD ATTLIST al) _):xs) used
= if name `elem` used
then warn ("Attribute \""++ aname ++"\" for element type \""++
ename ++"\" is already declared. First "++
"declaration will be used.") x
++
checkForUniqueAttributeDeclaration xs used
else checkForUniqueAttributeDeclaration xs (name : used)
where
ename = elemName al
aname = attName al
name = ename ++ "|" ++ aname
checkForUniqueAttributeDeclaration [] _ = []
checkForUniqueAttributeDeclaration nd _
= error ("checkForUniqueAttributeDeclaration: illegeal parameter:\n" ++ show nd)
checkEnumeratedTypes :: XmlFilter
checkEnumeratedTypes (NTree (XDTD ATTLIST al) cs)
= checkForUniqueType cs []
where
checkForUniqueType :: XmlTrees -> [String] -> XmlTrees
checkForUniqueType (x@(NTree (XDTD NAME al') _):xs) used
= if nmtoken `elem` used
then warn ("Nmtoken \""++ nmtoken ++"\" should not "++
"occur more than once in attribute \""++ attName al ++
"\" for element \""++ elemName al ++ "\".") x
++
checkForUniqueType xs used
else checkForUniqueType xs (nmtoken : used)
where
nmtoken = lookup1 a_name al'
checkForUniqueType [] _ = []
checkForUniqueType nd _
= error ("checkForUniqueType: illegeal parameter:\n" ++ show nd)
checkEnumeratedTypes nd
= error ("checkEnumeratedTypes: illegeal parameter:\n" ++ show nd)
checkForUniqueId :: XmlTrees -> [String] -> XmlTrees
checkForUniqueId (x@(NTree (XDTD ATTLIST al) _):xs) used
= if ename `elem` used
then err ("Element \""++ ename ++ "\" already has attribute of type "++
"ID, another attribute \""++ attName al ++ "\" of type ID is "++
"not permitted.") x
++
checkForUniqueId xs used
else checkForUniqueId xs (ename : used)
where
ename = elemName al
checkForUniqueId [] _ = []
checkForUniqueId nd _
= error ("checkForUniqueId: illegeal parameter:\n" ++ show nd)
checkForUniqueNotation :: XmlTrees -> [String] -> XmlTrees
checkForUniqueNotation (x@(NTree (XDTD ATTLIST al) _):xs) used
= if ename `elem` used
then err ("Element \""++ elemName al ++ "\" already has attribute of type "++
"NOTATION, another attribute \""++ attName al ++ "\" of type NOTATION "++
"is not permitted.") x
++
checkForUniqueNotation xs used
else checkForUniqueNotation xs (ename : used)
where
ename = elemName al
checkForUniqueNotation [] _ = []
checkForUniqueNotation nd _
= error ("checkForUniqueNotation: illegeal parameter:\n" ++ show nd)
checkIdKindConstraint :: XmlFilter
checkIdKindConstraint nd@(NTree (XDTD ATTLIST al) _)
= if (attKind == k_implied) || (attKind == k_required)
then []
else err ("ID attribute \""++ attName al ++"\" must have a declared default "++
"of \"#IMPLIED\" or \"REQUIRED\"") nd
where
attKind = lookup1 a_kind al
checkIdKindConstraint nd
= error ("checkIdKindConstraint: illegeal parameter:\n" ++ show nd)
checkNotationDeclaration :: [String] -> XmlFilter
checkNotationDeclaration notations (NTree (XDTD ATTLIST al) cs)
= checkNotations $$ cs
where
checkNotations :: XmlFilter
checkNotations nd@(NTree (XDTD NAME al') _)
= if notation `elem` notations
then []
else err ("The notation \""++ notation ++"\" must be declared when "++
"referenced in the notation type list for attribute \""++ attName al ++
"\" of element \""++ elemName al ++"\".") nd
where
notation = lookup1 a_name al'
checkNotations nd
= error ("checkNotations: illegeal parameter:\n" ++ show nd)
checkNotationDeclaration _ nd
= error ("checkNotationDeclaration: illegeal parameter:\n" ++ show nd)
checkNoNotationForEmptyElement :: [String] -> XmlFilter
checkNoNotationForEmptyElement emptyElems nd@(NTree (XDTD ATTLIST al) _)
= if (elemName al) `elem` emptyElems
then err ("Attribute \""++ attName al ++"\" of type NOTATION must not be "++
"declared on the element \""++ elemName al ++"\" declared EMPTY.")
nd
else []
checkNoNotationForEmptyElement _ nd
= error ("checkNoNotationForEmptyElement: illegeal parameter:\n" ++ show nd)
checkDefaultValueTypes :: XmlTrees -> XmlFilter
checkDefaultValueTypes dtdPart' n@(NTree (XDTD ATTLIST _) _)
= checkAttributeValue dtdPart' n n
checkDefaultValueTypes _ nd
= error ("checkDefaultValueTypes: illegeal parameter:\n" ++ show nd)
removeDoublicateDefs :: XmlFilter
removeDoublicateDefs n@(NTree (XDTD DOCTYPE _) cs)
= replaceChildren (removeDoubleDefs [] cs) n
where
removeDoubleDefs :: [String] -> XmlTrees -> XmlTrees
removeDoubleDefs used (x@(NTree (XDTD ATTLIST al) _):xs)
= if elemAttr `elem` used
then removeDoubleDefs used xs
else x
:
removeDoubleDefs (elemAttr : used) xs
where
elemAttr = elemName ++ "|" ++ attrName
attrName = lookup1 a_value al
elemName = lookup1 a_name al
removeDoubleDefs used (x@(NTree (XDTD ENTITY al) _):xs)
= if name `elem` used
then removeDoubleDefs used xs
else x
:
removeDoubleDefs (name : used) xs
where
name = lookup1 a_name al
removeDoubleDefs used (x:xs)
= x : removeDoubleDefs used xs
removeDoubleDefs _ []
= []
removeDoublicateDefs n
= [n]