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

{- |
   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 :: 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 #-}

-- | 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 :: 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      -- 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    = 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

-- | 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
    = 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   = []                            -- 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 :: 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

-- | 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 :: 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

-- | 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 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 )       -- remove all namespace declarations
              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                  -- update namespace prefix of attribute names, if namespace uri is set
            )
            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                    -- update namespace prefix of element names
          )
          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
            | 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'

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

-- | 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 :: 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                                                -- the test is just an optimization
      ( 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) )         -- 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
          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')                        -- apply the env to all attributes
              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')           -- apply the env recursively to all children
          )
          forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` 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'
        = 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'

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

-- | 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 :: 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

-- | 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 :: 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

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

-- | 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 :: 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

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

-- |
-- 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 :: 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)
                                                ]

-- |
-- 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
    = 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
          )

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

-- |
-- 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 :: 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 )             -- root is correct by definition
              , 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
              ]

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

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 )

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