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 :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr
= forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$
(forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getAttrName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA QName -> Bool
isNameSpaceName) forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` forall (a :: * -> * -> *) b. ArrowList a => a b b
this
{-# INLINE isNamespaceDeclAttr #-}
getNamespaceDecl :: ArrowXml a => a XmlTree (String, String)
getNamespaceDecl :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree (String, String)
getNamespaceDecl
= forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getAttrName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr QName -> String
getNsPrefix
)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
)
where
getNsPrefix :: QName -> String
getNsPrefix = forall a. Int -> [a] -> [a]
drop Int
6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
qualifiedName
collectNamespaceDecl :: LA XmlTree (String, String)
collectNamespaceDecl :: LA XmlTree (String, String)
collectNamespaceDecl = forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a XmlTree (String, String)
getNamespaceDecl
collectPrefixUriPairs :: LA XmlTree (String, String)
collectPrefixUriPairs :: LA XmlTree (String, String)
collectPrefixUriPairs
= forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL QName -> [(String, String)]
getPrefixUri
where
getPrefixUri :: QName -> [(String, String)]
getPrefixUri :: QName -> [(String, String)]
getPrefixUri QName
n
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri = []
| String
px forall a. Eq a => a -> a -> Bool
== String
a_xmlns
Bool -> Bool -> Bool
||
String
px forall a. Eq a => a -> a -> Bool
== String
a_xml = []
| Bool
otherwise = [(QName -> String
namePrefix QName
n, String
uri)]
where
uri :: String
uri = QName -> String
namespaceUri QName
n
px :: String
px = QName -> String
namePrefix QName
n
uniqueNamespaces :: ArrowXml a => a XmlTree XmlTree
uniqueNamespaces :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
uniqueNamespaces = forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$
LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces' LA XmlTree (String, String)
collectNamespaceDecl
uniqueNamespacesFromDeclAndQNames :: ArrowXml a => a XmlTree XmlTree
uniqueNamespacesFromDeclAndQNames :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
uniqueNamespacesFromDeclAndQNames = forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$
LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces' ( LA XmlTree (String, String)
collectNamespaceDecl
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
LA XmlTree (String, String)
collectPrefixUriPairs
)
cleanupNamespaces' :: LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces' :: LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces' LA XmlTree (String, String)
collectNamespaces = forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processTopDownUntil
( LA XmlTree XmlTree
hasNamespaceDecl forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces LA XmlTree (String, String)
collectNamespaces )
where
hasNamespaceDecl :: LA XmlTree XmlTree
hasNamespaceDecl = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr
cleanupNamespaces :: LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces :: LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces LA XmlTree (String, String)
collectNamespaces
= NsEnv -> LA XmlTree XmlTree
renameNamespaces forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< (forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA LA XmlTree (String, String)
collectNamespaces forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ ([(String, String)] -> NsEnv
toNsEnv forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Eq a => [a] -> [a]
nub))
where
renameNamespaces :: NsEnv -> LA XmlTree XmlTree
renameNamespaces :: NsEnv -> LA XmlTree XmlTree
renameNamespaces NsEnv
env
= forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processBottomUp
( forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl
( ( forall (a :: * -> * -> *) b c. ArrowList a => a b c
none forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr )
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeQName QName -> QName
renamePrefix
)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeQName QName -> QName
renamePrefix
)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
NsEnv -> LA XmlTree XmlTree
attachEnv NsEnv
env1
where
renamePrefix :: QName -> QName
renamePrefix :: QName -> QName
renamePrefix QName
n
| XName -> Bool
isNullXName XName
uri = QName
n
| forall a. Maybe a -> Bool
isNothing Maybe XName
newPx = QName
n
| Bool
otherwise = XName -> QName -> QName
setNamePrefix' (forall a. HasCallStack => Maybe a -> a
fromJust Maybe XName
newPx) QName
n
where
uri :: XName
uri = QName -> XName
namespaceUri' QName
n
newPx :: Maybe XName
newPx = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup XName
uri NsEnv
revEnv1
revEnv1 :: NsEnv
revEnv1 = forall a b. (a -> b) -> [a] -> [b]
map (\ (XName
x, XName
y) -> (XName
y, XName
x)) NsEnv
env1
env1 :: NsEnv
env1 :: NsEnv
env1 = NsEnv -> [XName] -> NsEnv
newEnv [] [XName]
uris
uris :: [XName]
uris :: [XName]
uris = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ NsEnv
env
genPrefixes :: [XName]
genPrefixes :: [XName]
genPrefixes = forall a b. (a -> b) -> [a] -> [b]
map (String -> XName
newXName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"ns" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [(Int
0::Int)..]
newEnv :: NsEnv -> [XName] -> NsEnv
newEnv :: NsEnv -> [XName] -> NsEnv
newEnv NsEnv
env' []
= NsEnv
env'
newEnv NsEnv
env' (XName
uri:[XName]
rest)
= NsEnv -> [XName] -> NsEnv
newEnv NsEnv
env'' [XName]
rest
where
env'' :: NsEnv
env'' = (XName
prefix, XName
uri) forall a. a -> [a] -> [a]
: NsEnv
env'
prefix :: XName
prefix
= forall a. [a] -> a
head (forall a. (a -> Bool) -> [a] -> [a]
filter XName -> Bool
notAlreadyUsed forall a b. (a -> b) -> a -> b
$ [XName]
preferedPrefixes forall a. [a] -> [a] -> [a]
++ [XName]
genPrefixes)
preferedPrefixes :: [XName]
preferedPrefixes
= forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==XName
uri)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ NsEnv
env
notAlreadyUsed :: XName -> Bool
notAlreadyUsed XName
s
= forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup XName
s forall a b. (a -> b) -> a -> b
$ NsEnv
env'
processWithNsEnv1 :: ArrowXml a => Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 :: forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 Bool
withAttr NsEnv -> a XmlTree XmlTree
f NsEnv
env
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
( NsEnv -> a XmlTree XmlTree
processWithExtendedEnv forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (NsEnv -> XmlTree -> NsEnv
extendEnv NsEnv
env) )
( NsEnv -> a XmlTree XmlTree
processWithExtendedEnv NsEnv
env )
where
processWithExtendedEnv :: NsEnv -> a XmlTree XmlTree
processWithExtendedEnv NsEnv
env'
= NsEnv -> a XmlTree XmlTree
f NsEnv
env'
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( ( if Bool
withAttr
then forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl (NsEnv -> a XmlTree XmlTree
f NsEnv
env')
else forall (a :: * -> * -> *) b. ArrowList a => a b b
this
)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren (forall (a :: * -> * -> *).
ArrowXml a =>
(NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv NsEnv -> a XmlTree XmlTree
f NsEnv
env')
)
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
extendEnv :: NsEnv -> XmlTree -> NsEnv
extendEnv :: NsEnv -> XmlTree -> NsEnv
extendEnv NsEnv
env' XmlTree
t'
= forall k v. Eq k => AssocList k v -> AssocList k v -> AssocList k v
addEntries ([(String, String)] -> NsEnv
toNsEnv [(String, String)]
newDecls) NsEnv
env'
where
newDecls :: [(String, String)]
newDecls = forall a b. LA a b -> a -> [b]
runLA ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a XmlTree (String, String)
getNamespaceDecl ) XmlTree
t'
processWithNsEnv :: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv :: forall (a :: * -> * -> *).
ArrowXml a =>
(NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv = forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 Bool
True
processWithNsEnvWithoutAttrl :: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnvWithoutAttrl :: forall (a :: * -> * -> *).
ArrowXml a =>
(NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnvWithoutAttrl = forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 Bool
False
attachNsEnv :: ArrowXml a => NsEnv -> a XmlTree XmlTree
attachNsEnv :: forall (a :: * -> * -> *). ArrowXml a => NsEnv -> a XmlTree XmlTree
attachNsEnv NsEnv
initialEnv
= forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *).
ArrowXml a =>
(NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnvWithoutAttrl NsEnv -> LA XmlTree XmlTree
attachEnv NsEnv
initialEnv
where
attachEnv :: NsEnv -> LA XmlTree XmlTree
attachEnv :: NsEnv -> LA XmlTree XmlTree
attachEnv NsEnv
env
= ( forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl (forall (a :: * -> * -> *) b c. ArrowList a => a b c
none forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
addAttrl (forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [LA XmlTree XmlTree]
nsAttrl)
)
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
where
nsAttrl :: [LA XmlTree XmlTree]
nsAttrl :: [LA XmlTree XmlTree]
nsAttrl = forall a b. (a -> b) -> [a] -> [b]
map (XName, XName) -> LA XmlTree XmlTree
nsDeclToAttr NsEnv
env
nsDeclToAttr :: (XName, XName) -> LA XmlTree XmlTree
nsDeclToAttr :: (XName, XName) -> LA XmlTree XmlTree
nsDeclToAttr (XName
n, XName
uri)
= forall (a :: * -> * -> *) n.
ArrowXml a =>
QName -> a n XmlTree -> a n XmlTree
mkAttr QName
qn (forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
txt (XName -> String
unXN XName
uri))
where
qn :: QName
qn :: QName
qn | XName -> Bool
isNullXName XName
n = XName -> XName -> XName -> QName
newQName XName
xmlnsXName XName
nullXName XName
xmlnsNamespaceXName
| Bool
otherwise = XName -> XName -> XName -> QName
newQName XName
n XName
xmlnsXName XName
xmlnsNamespaceXName
propagateNamespaces :: ArrowXml a => a XmlTree XmlTree
propagateNamespaces :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
propagateNamespaces = forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$
NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv [ (XName
xmlXName, XName
xmlNamespaceXName)
, (XName
xmlnsXName, XName
xmlnsNamespaceXName)
]
propagateNamespaceEnv :: NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv :: NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv
= forall (a :: * -> * -> *).
ArrowXml a =>
(NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv NsEnv -> LA XmlTree XmlTree
addNamespaceUri
where
addNamespaceUri :: NsEnv -> LA XmlTree XmlTree
addNamespaceUri :: NsEnv -> LA XmlTree XmlTree
addNamespaceUri NsEnv
env'
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeElemName (NsEnv -> QName -> QName
setNamespace NsEnv
env')
, forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isAttr forall a b. a -> b -> IfThen a b
:-> NsEnv -> LA XmlTree XmlTree
attachNamespaceUriToAttr NsEnv
env'
, forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changePiName (NsEnv -> QName -> QName
setNamespace NsEnv
env')
, forall (a :: * -> * -> *) b. ArrowList a => a b b
this forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b. ArrowList a => a b b
this
]
attachNamespaceUriToAttr :: NsEnv -> LA XmlTree XmlTree
attachNamespaceUriToAttr :: NsEnv -> LA XmlTree XmlTree
attachNamespaceUriToAttr NsEnv
attrEnv
= ( ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
namePrefix) )
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeAttrName (NsEnv -> QName -> QName
setNamespace NsEnv
attrEnv)
)
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
( forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeAttrName (forall a b. a -> b -> a
const QName
xmlnsQN)
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
a_xmlns
)
validateNamespaces :: ArrowXml a => a XmlTree XmlTree
validateNamespaces :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
validateNamespaces = forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA LA XmlTree XmlTree
validateNamespaces1
validateNamespaces1 :: LA XmlTree XmlTree
validateNamespaces1 :: LA XmlTree XmlTree
validateNamespaces1
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot forall a b. a -> b -> IfThen a b
:-> ( forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree XmlTree
validateNamespaces1 )
, forall (a :: * -> * -> *) b. ArrowList a => a b b
this forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi LA XmlTree XmlTree
validate1Namespaces
]
validate1Namespaces :: LA XmlTree XmlTree
validate1Namespaces :: LA XmlTree XmlTree
validate1Namespaces
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
[ forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isWellformedQName )
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"element name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" is not a wellformed qualified name" )
, ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isDeclaredNamespace )
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"namespace for prefix in element name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" is undefined" )
, String -> LA XmlTree XmlTree
doubleOcc forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< ( (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getUniversalName) forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. forall a. Eq a => [a] -> [a]
doubles )
, forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree XmlTree
validate1Namespaces
]
, forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isAttr forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isWellformedQName )
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"attribute name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" is not a wellformed qualified name" )
, ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isDeclaredNamespace )
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"namespace for prefix in attribute name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" is undefined" )
, ( forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasNamePrefix String
a_xmlns forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA forall (t :: * -> *) a. Foldable t => t a -> Bool
null
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"namespace value of namespace declaration for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" has no value" )
, ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isWellformedNSDecl )
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"illegal namespace declaration for name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" starting with reserved prefix " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
"xml" )
]
, forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isDTD forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
getDTDAttrValue String
a_name
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isWellformedQualifiedName)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"a DTD part contains a not wellformed qualified Name: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n)
)
, forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
getDTDAttrValue String
a_value
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isWellformedQualifiedName)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n)
)
, forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDPEntity forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
getDTDAttrValue String
a_name
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isNCName)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"an entity or notation declaration contains a not wellformed NCName: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n)
)
]
, forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isNCName)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"a PI contains a not wellformed NCName: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n)
)
]
]
where
nsError :: (QName -> String) -> LA XmlTree XmlTree
nsError :: (QName -> String) -> LA XmlTree XmlTree
nsError QName -> String
msg
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. (a -> String) -> LA a XmlTree
nsErr QName -> String
msg
nsErr :: (a -> String) -> LA a XmlTree
nsErr :: forall a. (a -> String) -> LA a XmlTree
nsErr a -> String
msg = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> String
msg forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
mkError Int
c_err
doubleOcc :: String -> LA XmlTree XmlTree
doubleOcc :: String -> LA XmlTree XmlTree
doubleOcc String
an
= (QName -> String) -> LA XmlTree XmlTree
nsError (\ QName
n -> String
"multiple occurences of universal name for attributes of tag " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show QName
n forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
an )