module Text.XML.HXT.DOM.NamespaceFilter
( module Text.XML.HXT.DOM.NamespaceFilter
, module Text.XML.HXT.DOM.NamespacePredicates
)
where
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.DOM.NamespacePredicates
import Text.XML.HXT.DOM.Util
( doubles )
type NamespaceTable = NsEnv
propagateNamespaces :: XmlFilter
propagateNamespaces = propagateNamespaceEnv [ (a_xml, xmlNamespace), (a_xmlns, xmlnsNamespace) ]
propagateNamespaceEnv :: NamespaceTable -> XmlFilter
propagateNamespaceEnv env n
= ( ( processAttr (attachNamespaceUrisToAttr newEnv)
.>
processChildren (propagateNamespaceEnv newEnv)
.>
modifyQName (setNamespace newEnv)
)
`when`
isXTag
)
$ n
where
nsAttrs = getAttrl
.>
isOfAttr ( (\ (px, lp)
-> (px == a_xmlns
&&
lp /= ":"
)
)
. span (/= ':')
. qualifiedName
)
$ n
nsDecl = zip (map (drop 1
. snd
. span (/= ':')
. nameOf
) nsAttrs)
(map (xshow
.
getChildren
) nsAttrs)
newEnv = addEntries nsDecl env
attachNamespaceUrisToAttr :: NamespaceTable -> XmlFilter
attachNamespaceUrisToAttr attrEnv
= ( isOfAttr ( (\ (px, lp)
-> ( (not . null . drop 1) lp
&&
(not . null) px
)
)
. span (/= ':')
. qualifiedName
)
`guards`
modifyQName (setNamespace attrEnv)
)
`orElse`
( modifyQName (const xmlnsQN)
`when`
isAttr a_xmlns
)
validateNamespaces :: XmlFilter
validateNamespaces
= choice [ isRoot
:-> getChildren .> validateNamespaces
, this
:-> multi validate1Namespaces
]
validate1Namespaces :: XmlFilter
validate1Namespaces
= choice [ isXTag
:->
cat [ isOfTag ( not . isWellformedQName )
`guards`
(\ n -> err ("tag name " ++ show (nameOf n) ++ " is not a wellformed qualified name") n )
, isOfTag ( not . isDeclaredNamespace )
`guards`
(\ n -> err ("namespace for prefix in tag name " ++ show (nameOf n) ++ " is undefined") n )
, (\ n -> ( let
dbls = doubles ((map universalNameOf . getAttrl) n)
in
if null dbls
then none
else err ( "multiple occurences of universal names for attributes of tag "
++ show (nameOf n)
++ " : " ++ foldr1 (\ x y -> x ++ ", " ++ y) (map show dbls)
)
) $ n
)
, getAttrl .> validate1Namespaces
]
, isXAttr
:->
cat [ isOfAttr ( not . isWellformedQName )
`guards`
(\ n -> err ("attribute name " ++ show (nameOf n) ++ " is not a wellformed qualified name") n )
, isOfAttr ( not . isDeclaredNamespace )
`guards`
(\ n -> err ("namespace for prefix in attribute name " ++ show (nameOf n) ++ " is undefined") n )
, ( hasPrefix a_xmlns .> neg (xmlTreesToText . getChildren) )
`guards`
(\ n -> err ("namespace value of namespace declaration for " ++ show (nameOf n) ++ " has no value") n )
, isOfAttr ( not . isWellformedNSDecl )
`guards`
(\ n -> err ("illegal namespace declaration with reserved prefix " ++ show (localPartOf n) ++ " starting with \"xml\"") n )
]
, isXDTD
:->
cat [ ( ( isDoctype +++ isAttlist +++ isElement +++ isDTDName )
.>
isOf ( not . isWellformedQualifiedName . valueOfDTD a_name )
)
`guards`
(\ n -> err ("a DTD part contains a not wellformed qualified Name: " ++ show (valueOfDTD a_name n)) n )
, ( isAttlist
.>
isOf ( not . isWellformedQualifiedName . valueOfDTD a_value )
)
`guards`
(\ n -> err ("an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " ++ show (valueOfDTD a_value n)) n )
, ( ( isEntity +++ isParameterEntity +++ isNotation )
.>
isOf ( not . isNCName . valueOfDTD a_name )
)
`guards`
(\ n -> err ("an entity or notation declaration contains a not wellformed NCName: " ++ show (valueOfDTD a_name n)) n )
]
, isXPi
:->
( isOf ( not . isNCName . nameOf )
`guards`
(\ n -> err ("a PI contains a not wellformed NCName: " ++ show (nameOf n)) n )
)
]
isNamespaceDecl :: XmlFilter
isNamespaceDecl
= isOfAttr xmlnsName
where
xmlnsName :: AttrName -> Bool
xmlnsName a
= px == a_xmlns
&&
( null ln || head ln == ':')
where
(px, ln) = splitAt 5 . qualifiedName $ a