-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.Namespace
   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   namespace specific arrows

-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.Namespace
    ( attachNsEnv
    , cleanupNamespaces
    , collectNamespaceDecl
    , collectPrefixUriPairs
    , isNamespaceDeclAttr
    , getNamespaceDecl
    , processWithNsEnv
    , processWithNsEnvWithoutAttrl
    , propagateNamespaces
    , uniqueNamespaces
    , uniqueNamespacesFromDeclAndQNames
    , validateNamespaces
    )
where

import Control.Arrow                            -- arrow classes
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 )

-- ------------------------------------------------------------

-- | test whether an attribute node contains an XML Namespace declaration

isNamespaceDeclAttr     :: ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr :: a XmlTree XmlTree
isNamespaceDeclAttr
    = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree XmlTree -> a XmlTree XmlTree)
-> LA XmlTree XmlTree -> a XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
      (LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getAttrName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA QName -> Bool
isNameSpaceName) LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
{-# INLINE isNamespaceDeclAttr #-}

-- | get the namespace prefix and the namespace URI out of
-- an attribute tree with a namespace declaration (see 'isNamespaceDeclAttr')
-- for all other nodes this arrow fails

getNamespaceDecl        :: ArrowXml a => a XmlTree (String, String)
getNamespaceDecl :: a XmlTree (String, String)
getNamespaceDecl
    = LA XmlTree (String, String) -> a XmlTree (String, String)
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree (String, String) -> a XmlTree (String, String))
-> LA XmlTree (String, String) -> a XmlTree (String, String)
forall a b. (a -> b) -> a -> b
$
      LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr
      LA XmlTree XmlTree
-> LA XmlTree (String, String) -> LA XmlTree (String, String)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      ( ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getAttrName
          LA XmlTree QName -> LA QName String -> LA XmlTree String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (QName -> String) -> LA QName String
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr QName -> String
getNsPrefix
        )
        LA XmlTree String
-> LA XmlTree String -> LA XmlTree (String, String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& LA XmlTree XmlTree -> LA XmlTree String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
      )
      where
      getNsPrefix :: QName -> String
getNsPrefix = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
6 (String -> String) -> (QName -> String) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
qualifiedName      -- drop "xmlns:"

-- ------------------------------------------------------------

-- | collect all namespace declarations contained in a document
--
-- apply 'getNamespaceDecl' to a whole XmlTree

collectNamespaceDecl    :: LA XmlTree (String, String)
collectNamespaceDecl :: LA XmlTree (String, String)
collectNamespaceDecl    = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl LA XmlTree XmlTree
-> LA XmlTree (String, String) -> LA XmlTree (String, String)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree (String, String)
forall (a :: * -> * -> *). ArrowXml a => a XmlTree (String, String)
getNamespaceDecl

-- | collect all (namePrefix, namespaceUri) pairs from a tree
--
-- all qualified names are inspected, whether a namespace uri is defined,
-- for these uris the prefix and uri is returned. This arrow is useful for
-- namespace cleanup, e.g. for documents generated with XSLT. It can be used
-- together with 'collectNamespaceDecl' to 'cleanupNamespaces'

collectPrefixUriPairs   :: LA XmlTree (String, String)
collectPrefixUriPairs :: LA XmlTree (String, String)
collectPrefixUriPairs
    = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi (LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi)
      LA XmlTree XmlTree
-> LA XmlTree (String, String) -> LA XmlTree (String, String)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName
      LA XmlTree QName
-> LA QName (String, String) -> LA XmlTree (String, String)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      (QName -> [(String, String)]) -> LA QName (String, String)
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
        | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri      = []
        | String
px String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a_xmlns
          Bool -> Bool -> Bool
||
          String
px String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a_xml   = []                            -- these ones are reserved an predefined
        | 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

-- ------------------------------------------------------------

-- | generate unique namespaces and add all namespace declarations to all top nodes containing a namespace declaration
-- Usually the top node containing namespace declarations is the root node, but this isn't mandatory.
--
-- Calls 'cleanupNamespaces' with 'collectNamespaceDecl'

uniqueNamespaces                        :: ArrowXml a => a XmlTree XmlTree
uniqueNamespaces :: a XmlTree XmlTree
uniqueNamespaces                        = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree XmlTree -> a XmlTree XmlTree)
-> LA XmlTree XmlTree -> a XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                                          LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces' LA XmlTree (String, String)
collectNamespaceDecl

-- | generate unique namespaces and add all namespace declarations for all prefix-uri pairs in all qualified names
--
-- useful for cleanup of namespaces in generated documents.
-- Calls 'cleanupNamespaces' with @ collectNamespaceDecl \<+> collectPrefixUriPairs @

uniqueNamespacesFromDeclAndQNames       :: ArrowXml a => a XmlTree XmlTree
uniqueNamespacesFromDeclAndQNames :: a XmlTree XmlTree
uniqueNamespacesFromDeclAndQNames       = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree XmlTree -> a XmlTree XmlTree)
-> LA XmlTree XmlTree -> a XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                                          LA XmlTree (String, String) -> LA XmlTree XmlTree
cleanupNamespaces' ( LA XmlTree (String, String)
collectNamespaceDecl
                                                               LA XmlTree (String, String)
-> LA XmlTree (String, String) -> LA XmlTree (String, String)
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    = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processTopDownUntil
                                          ( LA XmlTree XmlTree
hasNamespaceDecl LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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                    = LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
                                          LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl
                                          LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr

-- | does the real work for namespace cleanup.
--
-- The parameter is used for collecting namespace uris and prefixes from the input tree

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 (NsEnv -> LA XmlTree XmlTree)
-> LA XmlTree NsEnv -> LA XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< (LA XmlTree (String, String) -> LA XmlTree [(String, String)]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA LA XmlTree (String, String)
collectNamespaces LA XmlTree [(String, String)]
-> ([(String, String)] -> NsEnv) -> LA XmlTree NsEnv
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ ([(String, String)] -> NsEnv
toNsEnv ([(String, String)] -> NsEnv)
-> (NsEnv -> NsEnv) -> [(String, String)] -> NsEnv
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NsEnv -> NsEnv
forall a. Eq a => [a] -> [a]
nub))
    where
    renameNamespaces :: NsEnv -> LA XmlTree XmlTree
    renameNamespaces :: NsEnv -> LA XmlTree XmlTree
renameNamespaces NsEnv
env
        = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processBottomUp
          ( LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl
            ( ( LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr )       -- remove all namespace declarations
              LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
              (QName -> QName) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeQName QName -> QName
renamePrefix                  -- update namespace prefix of attribute names, if namespace uri is set
            )
            LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            (QName -> QName) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeQName QName -> QName
renamePrefix                    -- update namespace prefix of element names
          )
          LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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                                -- add all namespaces as attributes to the root node attribute list
        where
        renamePrefix    :: QName -> QName
        renamePrefix :: QName -> QName
renamePrefix QName
n
            | XName -> Bool
isNullXName XName
uri   = QName
n
            | Maybe XName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe XName
newPx   = QName
n
            | Bool
otherwise         = XName -> QName -> QName
setNamePrefix' (Maybe XName -> XName
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 = XName -> NsEnv -> Maybe XName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup XName
uri NsEnv
revEnv1

        revEnv1 :: NsEnv
revEnv1 = ((XName, XName) -> (XName, XName)) -> NsEnv -> NsEnv
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 = [XName] -> [XName]
forall a. Eq a => [a] -> [a]
nub ([XName] -> [XName]) -> (NsEnv -> [XName]) -> NsEnv -> [XName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((XName, XName) -> XName) -> NsEnv -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map (XName, XName) -> XName
forall a b. (a, b) -> b
snd (NsEnv -> [XName]) -> NsEnv -> [XName]
forall a b. (a -> b) -> a -> b
$ NsEnv
env

        genPrefixes :: [XName]
        genPrefixes :: [XName]
genPrefixes = (Int -> XName) -> [Int] -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> XName
newXName (String -> XName) -> (Int -> String) -> Int -> XName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"ns" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
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) (XName, XName) -> NsEnv -> NsEnv
forall a. a -> [a] -> [a]
: NsEnv
env'
            prefix :: XName
prefix
                = [XName] -> XName
forall a. [a] -> a
head ((XName -> Bool) -> [XName] -> [XName]
forall a. (a -> Bool) -> [a] -> [a]
filter XName -> Bool
notAlreadyUsed ([XName] -> [XName]) -> [XName] -> [XName]
forall a b. (a -> b) -> a -> b
$ [XName]
preferedPrefixes [XName] -> [XName] -> [XName]
forall a. [a] -> [a] -> [a]
++ [XName]
genPrefixes)
            preferedPrefixes :: [XName]
preferedPrefixes
                = ((XName, XName) -> XName) -> NsEnv -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map (XName, XName) -> XName
forall a b. (a, b) -> a
fst (NsEnv -> [XName]) -> (NsEnv -> NsEnv) -> NsEnv -> [XName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((XName, XName) -> Bool) -> NsEnv -> NsEnv
forall a. (a -> Bool) -> [a] -> [a]
filter ((XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
==XName
uri)(XName -> Bool)
-> ((XName, XName) -> XName) -> (XName, XName) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(XName, XName) -> XName
forall a b. (a, b) -> b
snd) (NsEnv -> [XName]) -> NsEnv -> [XName]
forall a b. (a -> b) -> a -> b
$ NsEnv
env
            notAlreadyUsed :: XName -> Bool
notAlreadyUsed XName
s
                = Maybe XName -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe XName -> Bool) -> (NsEnv -> Maybe XName) -> NsEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XName -> NsEnv -> Maybe XName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup XName
s (NsEnv -> Bool) -> NsEnv -> Bool
forall a b. (a -> b) -> a -> b
$ NsEnv
env'

-- ------------------------------------------------------------

-- | auxiliary arrow for processing with a namespace environment
--
-- process a document tree with an arrow, containing always the
-- valid namespace environment as extra parameter.
-- The namespace environment is implemented as a 'Data.AssocList.AssocList'.
-- Processing of attributes can be controlled by a boolean parameter

processWithNsEnv1       :: ArrowXml a => Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 :: Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 Bool
withAttr NsEnv -> a XmlTree XmlTree
f NsEnv
env
    = a XmlTree XmlTree
-> a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem                                                -- the test is just an optimization
      ( NsEnv -> a XmlTree XmlTree
processWithExtendedEnv (NsEnv -> a XmlTree XmlTree)
-> a XmlTree NsEnv -> a XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< (XmlTree -> NsEnv) -> a XmlTree NsEnv
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (NsEnv -> XmlTree -> NsEnv
extendEnv NsEnv
env) )         -- only element nodes contain namespace declarations
      ( NsEnv -> a XmlTree XmlTree
processWithExtendedEnv NsEnv
env )
    where
    processWithExtendedEnv :: NsEnv -> a XmlTree XmlTree
processWithExtendedEnv NsEnv
env'
        = NsEnv -> a XmlTree XmlTree
f NsEnv
env'                                                -- apply the env filter
          a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
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 a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl (NsEnv -> a XmlTree XmlTree
f NsEnv
env')                        -- apply the env to all attributes
              else a XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
            )
            a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren ((NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv NsEnv -> a XmlTree XmlTree
f NsEnv
env')           -- apply the env recursively to all children
          )
          a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem                                         -- attrl and children only need processing for elem nodes

    extendEnv   :: NsEnv -> XmlTree -> NsEnv
    extendEnv :: NsEnv -> XmlTree -> NsEnv
extendEnv NsEnv
env' XmlTree
t'
        = NsEnv -> NsEnv -> NsEnv
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 = LA XmlTree (String, String) -> XmlTree -> [(String, String)]
forall a b. LA a b -> a -> [b]
runLA ( LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl LA XmlTree XmlTree
-> LA XmlTree (String, String) -> LA XmlTree (String, String)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree (String, String)
forall (a :: * -> * -> *). ArrowXml a => a XmlTree (String, String)
getNamespaceDecl ) XmlTree
t'

-- ------------------------------------------------------------

-- | process a document tree with an arrow, containing always the
-- valid namespace environment as extra parameter.
--
-- The namespace environment is implemented as a 'Data.AssocList.AssocList'

processWithNsEnv                :: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv :: (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv                = Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 Bool
True

-- | process all element nodes of a document tree with an arrow, containing always the
-- valid namespace environment as extra parameter. Attribute lists are not processed.
--
-- See also: 'processWithNsEnv'

processWithNsEnvWithoutAttrl    :: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnvWithoutAttrl :: (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnvWithoutAttrl    = Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree
processWithNsEnv1 Bool
False

-- -----------------------------------------------------------------------------

-- | attach all valid namespace declarations to the attribute list of element nodes.
--
-- This arrow is useful for document processing, that requires access to all namespace
-- declarations at any element node, but which cannot be done with a simple 'processWithNsEnv'.

attachNsEnv     :: ArrowXml a => NsEnv -> a XmlTree XmlTree
attachNsEnv :: NsEnv -> a XmlTree XmlTree
attachNsEnv NsEnv
initialEnv
    = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree XmlTree -> a XmlTree XmlTree)
-> LA XmlTree XmlTree -> a XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$ (NsEnv -> LA XmlTree XmlTree) -> NsEnv -> LA XmlTree XmlTree
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
    = ( LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl (LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isNamespaceDeclAttr)
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
addAttrl ([LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [LA XmlTree XmlTree]
nsAttrl)
      )
      LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
    where
    nsAttrl             :: [LA XmlTree XmlTree]
    nsAttrl :: [LA XmlTree XmlTree]
nsAttrl             = ((XName, XName) -> LA XmlTree XmlTree)
-> NsEnv -> [LA XmlTree XmlTree]
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)
        = QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
QName -> a n XmlTree -> a n XmlTree
mkAttr QName
qn (String -> LA XmlTree XmlTree
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

-- -----------------------------------------------------------------------------

-- |
-- propagate all namespace declarations \"xmlns:ns=...\" to all element and attribute nodes of a document.
--
-- This arrow does not check for illegal use of namespaces.
-- The real work is done by 'propagateNamespaceEnv'.
--
-- The arrow may be applied repeatedly if neccessary.

propagateNamespaces     :: ArrowXml a => a XmlTree XmlTree
propagateNamespaces :: a XmlTree XmlTree
propagateNamespaces     = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree XmlTree -> a XmlTree XmlTree)
-> LA XmlTree XmlTree -> a XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                          NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv [ (XName
xmlXName,   XName
xmlNamespaceXName)
                                                , (XName
xmlnsXName, XName
xmlnsNamespaceXName)
                                                ]

-- |
-- attaches the namespace info given by the namespace table
-- to a tag node and its attributes and children.

propagateNamespaceEnv   :: NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv :: NsEnv -> LA XmlTree XmlTree
propagateNamespaceEnv
    = (NsEnv -> LA XmlTree XmlTree) -> NsEnv -> LA XmlTree XmlTree
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'
        = [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> (QName -> QName) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeElemName (NsEnv -> QName -> QName
setNamespace NsEnv
env')
                  , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isAttr LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> NsEnv -> LA XmlTree XmlTree
attachNamespaceUriToAttr NsEnv
env'
                  , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi   LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> (QName -> QName) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changePiName   (NsEnv -> QName -> QName
setNamespace NsEnv
env')
                  , LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this   LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                  ]

    attachNamespaceUriToAttr    :: NsEnv -> LA XmlTree XmlTree
    attachNamespaceUriToAttr :: NsEnv -> LA XmlTree XmlTree
attachNamespaceUriToAttr NsEnv
attrEnv
        = ( ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (QName -> String) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
namePrefix) )
            LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
            (QName -> QName) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeAttrName (NsEnv -> QName -> QName
setNamespace NsEnv
attrEnv)
          )
          LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
          ( (QName -> QName) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> QName) -> a XmlTree XmlTree
changeAttrName (QName -> QName -> QName
forall a b. a -> b -> a
const QName
xmlnsQN)
            LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
            String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
a_xmlns
          )

-- -----------------------------------------------------------------------------

-- |
-- validate the namespace constraints in a whole tree.
--
-- Result is the list of errors concerning namespaces.
-- Predicates 'isWellformedQName', 'isWellformedQualifiedName', 'isDeclaredNamespace'
-- and 'isWellformedNSDecl' are applied to the appropriate elements and attributes.

validateNamespaces      :: ArrowXml a => a XmlTree XmlTree
validateNamespaces :: a XmlTree XmlTree
validateNamespaces      = LA XmlTree XmlTree -> a XmlTree XmlTree
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
    = [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot  LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> ( LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 )             -- root is correct by definition
              , LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this    LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi LA XmlTree XmlTree
validate1Namespaces
              ]

-- |
-- a single node for namespace constrains.

validate1Namespaces     :: LA XmlTree XmlTree
validate1Namespaces :: LA XmlTree XmlTree
validate1Namespaces
    = [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
      [ LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem  LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isWellformedQName )
                           )
                           LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a wellformed qualified name" )

                         , ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isDeclaredNamespace )
                           )
                           LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is undefined" )

                         , String -> LA XmlTree XmlTree
doubleOcc (String -> LA XmlTree XmlTree)
-> LA XmlTree String -> LA XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< ( (LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getUniversalName) LA XmlTree String -> ([String] -> [String]) -> LA XmlTree String
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. [String] -> [String]
forall a. Eq a => [a] -> [a]
doubles )

                         , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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
                         ]

      , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isAttr  LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isWellformedQName )
                           )
                           LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a wellformed qualified name" )

                         , ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isDeclaredNamespace )
                           )
                           LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is undefined" )

                         , ( String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasNamePrefix String
a_xmlns LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
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 -> LA XmlTree String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree String -> LA String String -> LA XmlTree String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (String -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
                           )
                           LA XmlTree String -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no value" )

                         , ( LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName QName -> LA XmlTree QName
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> Bool) -> LA QName QName
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isWellformedNSDecl )
                           )
                           LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" starting with reserved prefix " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
"xml" )
                         ]

      , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isDTD   LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName
                           LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
getDTDAttrValue String
a_name
                           LA XmlTree String -> LA String XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           ( (String -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isWellformedQualifiedName)
                             LA String String -> LA String XmlTree -> LA String XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                             (String -> String) -> LA String XmlTree
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"a DTD part contains a not wellformed qualified Name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n)
                           )

                         , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
                           LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
getDTDAttrValue String
a_value
                           LA XmlTree String -> LA String XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           ( (String -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isWellformedQualifiedName)
                             LA String String -> LA String XmlTree -> LA String XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                             (String -> String) -> LA String XmlTree
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n)
                           )

                         , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDPEntity LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation
                           LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
getDTDAttrValue String
a_name
                           LA XmlTree String -> LA String XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           ( (String -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isNCName)
                             LA String String -> LA String XmlTree -> LA String XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                             (String -> String) -> LA String XmlTree
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"an entity or notation declaration contains a not wellformed NCName: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n)
                           )
                         ]
      , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi    LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName
                           LA XmlTree String -> LA String XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                           ( (String -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isNCName)
                             LA String String -> LA String XmlTree -> LA String XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                             (String -> String) -> LA String XmlTree
forall a. (a -> String) -> LA a XmlTree
nsErr (\ String
n -> String
"a PI contains a not wellformed NCName: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
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
        = LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName LA XmlTree QName -> LA QName XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (QName -> String) -> LA QName XmlTree
forall a. (a -> String) -> LA a XmlTree
nsErr QName -> String
msg

    nsErr       :: (a -> String) -> LA a XmlTree
    nsErr :: (a -> String) -> LA a XmlTree
nsErr a -> String
msg   = (a -> String) -> LA a String
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> String
msg LA a String -> LA String XmlTree -> LA a XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Int -> LA String XmlTree
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
an )

-- ------------------------------------------------------------