module Text.XML.HXT.Arrow.Namespace
( attachNsEnv
, cleanupNamespaces
, collectNamespaceDecl
, collectPrefixUriPairs
, isNamespaceDeclAttr
, getNamespaceDecl
, processWithNsEnv
, processWithNsEnvWithoutAttrl
, propagateNamespaces
, uniqueNamespaces
, uniqueNamespacesFromDeclAndQNames
, validateNamespaces
)
where
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ListArrow
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
import Data.Maybe
( isNothing
, fromJust
)
import Data.List
( nub )
isNamespaceDeclAttr :: ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr
= fromLA $
(getAttrName >>> isA isNsQName) `guards` this
where
isNsQName n
= px == a_xmlns
&&
(null lp || (not . null . tail $ lp))
where
(px, lp) = span (/= ':') . qualifiedName $ n
getNamespaceDecl :: ArrowXml a => a XmlTree (String, String)
getNamespaceDecl
= fromLA $
isNamespaceDeclAttr
>>>
( ( getAttrName
>>>
arr getNsPrefix
)
&&& xshow getChildren
)
where
getNsPrefix = drop 6 . qualifiedName
collectNamespaceDecl :: LA XmlTree (String, String)
collectNamespaceDecl = multi getAttrl >>> getNamespaceDecl
collectPrefixUriPairs :: LA XmlTree (String, String)
collectPrefixUriPairs
= multi (isElem <+> getAttrl <+> isPi)
>>>
getQName
>>>
arrL getPrefixUri
where
getPrefixUri :: QName -> [(String, String)]
getPrefixUri n
| null uri = []
| px == a_xmlns
||
px == a_xml = []
| otherwise = [(namePrefix n, uri)]
where
uri = namespaceUri n
px = namePrefix n
uniqueNamespaces :: ArrowXml a => a XmlTree XmlTree
uniqueNamespaces
= fromLA $
cleanupNamespaces collectNamespaceDecl
uniqueNamespacesFromDeclAndQNames :: ArrowXml a => a XmlTree XmlTree
uniqueNamespacesFromDeclAndQNames
= fromLA $
cleanupNamespaces (collectNamespaceDecl <+> collectPrefixUriPairs)
cleanupNamespaces :: LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces collectNamespaces
= renameNamespaces $< (listA collectNamespaces >>^ nub)
where
renameNamespaces :: NsEnv -> LA XmlTree XmlTree
renameNamespaces env
= processBottomUp
( processAttrl
( ( none `when` isNamespaceDeclAttr )
>>>
changeQName renamePrefix
)
>>>
changeQName renamePrefix
)
>>>
attachEnv env1
where
renamePrefix :: QName -> QName
renamePrefix n
| null uri = n
| isNothing newPx = n
| otherwise = n {namePrefix = fromJust newPx}
where
uri = namespaceUri n
newPx = lookup uri revEnv1
revEnv1 = map (\ (x, y) -> (y, x)) env1
env1 :: NsEnv
env1 = newEnv [] uris
uris :: [String]
uris = nub . map snd $ env
genPrefixes :: [String]
genPrefixes = map (("ns" ++) . show) [(0::Int)..]
newEnv :: NsEnv -> [String] -> NsEnv
newEnv env' []
= env'
newEnv env' (uri:rest)
= newEnv env'' rest
where
env'' = (prefix, uri) : env'
prefix
= head (filter notAlreadyUsed $ preferedPrefixes ++ genPrefixes)
preferedPrefixes
= map fst . filter ((==uri).snd) $ env
notAlreadyUsed s
= isNothing . lookup s $ env'
processWithNsEnv1 :: ArrowXml a => Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 withAttr f env
= ifA isElem
( processWithExtendedEnv $< arr (extendEnv env) )
( processWithExtendedEnv env )
where
processWithExtendedEnv env'
= f env'
>>>
( ( if withAttr
then processAttrl (f env')
else this
)
>>>
processChildren (processWithNsEnv f env')
)
`when` isElem
extendEnv :: NsEnv -> XmlTree -> NsEnv
extendEnv env' t'
= addEntries newDecls env'
where
newDecls = runLA ( getAttrl >>> getNamespaceDecl ) t'
processWithNsEnv :: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv = processWithNsEnv1 True
processWithNsEnvWithoutAttrl :: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnvWithoutAttrl = processWithNsEnv1 False
attachNsEnv :: ArrowXml a => NsEnv -> a XmlTree XmlTree
attachNsEnv initialEnv
= fromLA $ processWithNsEnvWithoutAttrl attachEnv initialEnv
where
attachEnv :: NsEnv -> LA XmlTree XmlTree
attachEnv env
= ( processAttrl (none `when` isNamespaceDeclAttr)
>>>
addAttrl (catA nsAttrl)
)
`when` isElem
where
nsAttrl :: [LA XmlTree XmlTree]
nsAttrl = map nsDeclToAttr env
nsDeclToAttr :: (String, String) -> LA XmlTree XmlTree
nsDeclToAttr (n, uri)
= mkAttr qn (txt uri)
where
qn :: QName
qn = mkNsName (a_xmlns ++ (if null n then "" else ':' : n)) xmlnsNamespace
propagateNamespaces :: ArrowXml a => a XmlTree XmlTree
propagateNamespaces = fromLA $ propagateNamespaceEnv [ (a_xml, xmlNamespace), (a_xmlns, xmlnsNamespace) ]
propagateNamespaceEnv :: NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv
= processWithNsEnv addNamespaceUri
where
addNamespaceUri :: NsEnv -> LA XmlTree XmlTree
addNamespaceUri env'
= choiceA [ isElem :-> changeElemName (setNamespace env')
, isAttr :-> attachNamespaceUriToAttr env'
, isPi :-> changePiName (setNamespace env')
, this :-> this
]
attachNamespaceUriToAttr :: NsEnv -> LA XmlTree XmlTree
attachNamespaceUriToAttr attrEnv
= ( ( getName >>> isA hasPrefixLocalPart )
`guards`
changeAttrName (setNamespace attrEnv)
)
`orElse`
( changeAttrName (const xmlnsQN)
`when`
hasName a_xmlns
)
where
hasPrefixLocalPart :: String -> Bool
hasPrefixLocalPart s
= ( ':' `elem` s )
&&
( let
(px, lp) = span (/= ':') s
in
not (null px) && not (null (drop 1 lp))
)
validateNamespaces :: ArrowXml a => a XmlTree XmlTree
validateNamespaces = fromLA validateNamespaces1
validateNamespaces1 :: LA XmlTree XmlTree
validateNamespaces1
= choiceA [ isRoot :-> ( getChildren >>> validateNamespaces1 )
, this :-> multi validate1Namespaces
]
validate1Namespaces :: LA XmlTree XmlTree
validate1Namespaces
= choiceA
[ isElem :-> catA [ ( getQName >>> isA ( not . isWellformedQName )
)
`guards` nsError (\ n -> "element name " ++ show n ++ " is not a wellformed qualified name" )
, ( getQName >>> isA ( not . isDeclaredNamespace )
)
`guards` nsError (\ n -> "namespace for prefix in element name " ++ show n ++ " is undefined" )
, doubleOcc $< ( (getAttrl >>> getUniversalName) >>. doubles )
, getAttrl >>> validate1Namespaces
]
, isAttr :-> catA [ ( getQName >>> isA ( not . isWellformedQName )
)
`guards` nsError (\ n -> "attribute name " ++ show n ++ " is not a wellformed qualified name" )
, ( getQName >>> isA ( not . isDeclaredNamespace )
)
`guards` nsError (\ n -> "namespace for prefix in attribute name " ++ show n ++ " is undefined" )
, ( hasNamePrefix a_xmlns >>> xshow getChildren >>> isA null
)
`guards` nsError (\ n -> "namespace value of namespace declaration for " ++ show n ++ " has no value" )
, ( getQName >>> isA (not . isWellformedNSDecl )
)
`guards` nsError (\ n -> "illegal namespace declaration for name " ++ n ++ " starting with reserved prefix " ++ show "xml" )
]
, isDTD :-> catA [ isDTDDoctype <+> isDTDAttlist <+> isDTDElement <+> isDTDName
>>>
getDTDAttrValue a_name
>>>
( isA (not . isWellformedQualifiedName)
`guards`
nsErr (\ n -> "a DTD part contains a not wellformed qualified Name: " ++ show n)
)
, isDTDAttlist
>>>
getDTDAttrValue a_value
>>>
( isA (not . isWellformedQualifiedName)
`guards`
nsErr (\ n -> "an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " ++ show n)
)
, isDTDEntity <+> isDTDPEntity <+> isDTDNotation
>>>
getDTDAttrValue a_name
>>>
( isA (not . isNCName)
`guards`
nsErr (\ n -> "an entity or notation declaration contains a not wellformed NCName: " ++ show n)
)
]
, isPi :-> catA [ getName
>>>
( isA (not . isNCName)
`guards`
nsErr (\ n -> "a PI contains a not wellformed NCName: " ++ show n)
)
]
]
where
nsError :: (String -> String) -> LA XmlTree XmlTree
nsError msg
= getName >>> nsErr msg
nsErr :: (String -> String) -> LA String XmlTree
nsErr msg = arr msg >>> mkError c_err
doubleOcc :: String -> LA XmlTree XmlTree
doubleOcc an
= nsError (\ n -> "multiple occurences of universal name for attributes of tag " ++ show n ++ " : " ++ show an )