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

    {- |
       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
        = 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 b. (b -> Bool) -> LA b b
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA QName -> Bool
    isNameSpaceName) LA XmlTree QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall b c d. LA b c -> LA b d -> LA b d
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d
    `guards` LA XmlTree XmlTree
    forall b. LA b b
    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
        = 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 b c. (b -> c) -> LA b c
    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 b c c'. LA b c -> LA b c' -> LA b (c, c')
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& LA XmlTree XmlTree -> LA XmlTree String
    forall n. LA n XmlTree -> LA n String
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    a n XmlTree -> a n String
    xshow LA XmlTree XmlTree
    forall (t :: * -> *) b. Tree t => LA (t b) (t b)
    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 (t :: * -> *) b c. Tree t => LA (t b) c -> LA (t b) c
    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 (t :: * -> *) b c. Tree t => LA (t b) c -> LA (t b) c
    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 b c. LA b c -> LA b c -> LA b c
    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 b c. LA b c -> LA b c -> LA b c
    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 b c. (b -> [c]) -> LA b 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
            | String -> Bool
    forall a. [a] -> 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 :: forall (a :: * -> * -> *). ArrowXml a => 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 :: forall (a :: * -> * -> *). ArrowXml a => 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 b c. LA b c -> LA b c -> LA b c
    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 (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
    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 b c d. LA b c -> LA b d -> LA b d
    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 c b d. (c -> LA b d) -> LA b c -> LA b d
    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 b c. LA b c -> LA b [c]
    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 (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
    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 b c. LA b c
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall b c. LA b b -> LA b c -> LA b b
    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. HasCallStack => [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 :: forall (a :: * -> * -> *).
    ArrowXml a =>
    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 b c d. a b c -> a b d -> a b d -> a b d
    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 c b d. (c -> a b d) -> a b c -> a b d
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< (XmlTree -> NsEnv) -> a XmlTree NsEnv
    forall b c. (b -> c) -> a b c
    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 b. a b b
    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 (t :: * -> *) b. Tree t => a (t b) (t b) -> a (t b) (t b)
    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 b c. a b b -> a b c -> a b b
    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 :: forall (a :: * -> * -> *).
    ArrowXml a =>
    (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 :: forall (a :: * -> * -> *).
    ArrowXml a =>
    (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 :: forall (a :: * -> * -> *). ArrowXml a => 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 b c. LA b c
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall b c. LA b b -> LA b c -> LA b b
    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 b c. [LA b c] -> LA b c
    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 b c. LA b b -> LA b c -> LA b b
    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 n. QName -> LA n XmlTree -> LA n XmlTree
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    QName -> a n XmlTree -> a n XmlTree
    mkAttr QName
    qn (String -> LA XmlTree XmlTree
    forall n. String -> LA n 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 :: forall (a :: * -> * -> *). ArrowXml a => 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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
    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 b. LA b b
    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 b. LA b b
    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 b. (b -> Bool) -> LA b b
    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 a. [a] -> 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 b c d. LA b c -> LA b d -> LA b d
    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 b c. LA b c -> LA b c -> LA b c
    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 b c. LA b b -> LA b c -> LA b b
    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 :: forall (a :: * -> * -> *). ArrowXml a => 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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
    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 (t :: * -> *) b. Tree t => LA (t b) (t b)
    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 b. LA b b
    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 (t :: * -> *) b c. Tree t => LA (t b) c -> LA (t b) c
    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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
    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 b c. [LA b c] -> LA b c
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 c b d. (c -> LA b d) -> LA b c -> LA b d
    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 b c d. LA b c -> ([c] -> [d]) -> LA b d
    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 b c. [LA b c] -> LA b c
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 n. LA n XmlTree -> LA n String
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    a n XmlTree -> a n String
    xshow LA XmlTree XmlTree
    forall (t :: * -> *) b. Tree t => LA (t b) (t b)
    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 b. (b -> Bool) -> LA b b
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null
                               )
                               LA XmlTree String -> LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall b c d. LA b c -> LA b d -> LA b d
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 b c. [LA b c] -> LA b c
    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 b c. LA b c -> LA b c -> LA b c
    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 b c. LA b c -> LA b c -> LA b c
    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 b c. LA b c -> LA b c -> LA b c
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 b c. LA b c -> LA b c -> LA b c
    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 b c. LA b c -> LA b c -> LA b c
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 b c. [LA b c] -> LA b c
    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 b. (b -> Bool) -> LA b b
    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 b c d. LA b c -> LA b d -> LA b d
    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 :: forall a. (a -> String) -> LA a XmlTree
    nsErr a -> String
    msg   = (a -> String) -> LA a String
    forall b c. (b -> c) -> LA b c
    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 )

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