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

    {- |
       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
        = fromLA $
          (getAttrName >>> isA isNameSpaceName) `guards` this

    -- | 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
        = fromLA $
          isNamespaceDeclAttr
          >>>
          ( ( getAttrName
              >>>
              arr getNsPrefix
            )
            &&& xshow getChildren
          )
          where
          getNsPrefix = drop 6 . qualifiedName      -- drop "xmlns:"

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

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

    collectNamespaceDecl    :: LA XmlTree (String, String)
    collectNamespaceDecl    = multi getAttrl >>> 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
        = multi (isElem <+> getAttrl <+> isPi)
          >>>
          getQName
          >>>
          arrL getPrefixUri
        where
        getPrefixUri        :: QName -> [(String, String)]
        getPrefixUri n
            | null uri      = []
            | px == a_xmlns
              ||
              px == a_xml   = []                            -- these ones are reserved an predefined
            | otherwise     = [(namePrefix n, uri)]
            where
            uri = namespaceUri n
            px  = namePrefix   n

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

    -- | generate unique namespaces and add all namespace declarations to the root element
    --
    -- Calls 'cleanupNamespaces' with 'collectNamespaceDecl'

    uniqueNamespaces                :: ArrowXml a => a XmlTree XmlTree
    uniqueNamespaces
        = fromLA $
          cleanupNamespaces 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
        = fromLA $
          cleanupNamespaces (collectNamespaceDecl <+> collectPrefixUriPairs)

    -- | 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 collectNamespaces
        = renameNamespaces $< (listA collectNamespaces >>^ (toNsEnv >>> nub))
        where
        renameNamespaces :: NsEnv -> LA XmlTree XmlTree
        renameNamespaces env
            = processBottomUp
              ( processAttrl
                ( ( none `when` isNamespaceDeclAttr )       -- remove all namespace declarations
                  >>>
                  changeQName renamePrefix                  -- update namespace prefix of attribute names, if namespace uri is set
                )
                >>>
                changeQName renamePrefix                    -- update namespace prefix of element names
              )
              >>>
              attachEnv env1                                -- all all namespaces as attributes to the root node attribute list
            where
            renamePrefix    :: QName -> QName
            renamePrefix n
                | isNullXName uri   = n
                | isNothing newPx   = n
                | otherwise         = setNamePrefix' (fromJust newPx) n
                where
                uri   = namespaceUri' n
                newPx = lookup uri revEnv1

            revEnv1 = map (\ (x, y) -> (y, x)) env1

            env1 :: NsEnv
            env1 = newEnv [] uris

            uris :: [XName]
            uris = nub . map snd $ env

            genPrefixes :: [XName]
            genPrefixes = map (newXName . ("ns" ++) . show) [(0::Int)..]

            newEnv  :: NsEnv -> [XName] -> NsEnv
            newEnv env' []
                = env'

            newEnv env' (uri:rest)
                = newEnv env'' rest
                where
                env''    = (prefix, uri) : env'
                prefix
                    = head (filter notAlreadyUsed $ preferedPrefixes ++ genPrefixes)
                preferedPrefixes
                    = map fst . filter ((==uri).snd) $ env
                notAlreadyUsed s
                    = isNothing . lookup s $ env'

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

    -- | 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 withAttr f env
        = ifA isElem                                                -- the test is just an optimization
          ( processWithExtendedEnv $< arr (extendEnv env) )         -- only element nodes contain namespace declarations
          ( processWithExtendedEnv env )
        where
        processWithExtendedEnv env'
            = f env'                                                -- apply the env filter
              >>>
              ( ( if withAttr
                  then processAttrl (f env')                        -- apply the env to all attributes
                  else this
                )
                >>>
                processChildren (processWithNsEnv f env')           -- apply the env recursively to all children
              )
              `when` isElem                                         -- attrl and children only need processing for elem nodes

        extendEnv   :: NsEnv -> XmlTree -> NsEnv
        extendEnv env' t'
            = addEntries (toNsEnv newDecls) env'
            where
            newDecls = runLA ( getAttrl >>> getNamespaceDecl ) 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                = processWithNsEnv1 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    = processWithNsEnv1 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 initialEnv
        = fromLA $ processWithNsEnvWithoutAttrl attachEnv initialEnv
        where

    attachEnv       :: NsEnv -> LA XmlTree XmlTree
    attachEnv env
        = ( processAttrl (none `when` isNamespaceDeclAttr)
            >>>
            addAttrl (catA nsAttrl)
          )
          `when` isElem
        where
        nsAttrl             :: [LA XmlTree XmlTree]
        nsAttrl             = map nsDeclToAttr env

        nsDeclToAttr        :: (XName, XName) -> LA XmlTree XmlTree
        nsDeclToAttr (n, uri)
            = mkAttr qn (txt (show uri))
            where
            qn :: QName
            qn | isNullXName n      = mkQName' nullXName  xmlnsXName xmlnsNamespaceXName
               | otherwise          = mkQName' xmlnsXName n          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     = fromLA $
                              propagateNamespaceEnv [ (xmlXName,   xmlNamespaceXName)
                                                    , (xmlnsXName, 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
        = processWithNsEnv addNamespaceUri
        where
        addNamespaceUri     :: NsEnv -> LA XmlTree XmlTree
        addNamespaceUri env'
            = choiceA [ isElem :-> changeElemName (setNamespace env')
                      , isAttr :-> attachNamespaceUriToAttr env'
                      , isPi   :-> changePiName   (setNamespace env')
                      , this   :-> this
                      ]

        attachNamespaceUriToAttr    :: NsEnv -> LA XmlTree XmlTree
        attachNamespaceUriToAttr attrEnv
            = ( ( getQName >>> isA (not . null . namePrefix) )
                `guards`
                changeAttrName (setNamespace attrEnv)
              )
              `orElse`
              ( changeAttrName (const xmlnsQN)
                `when`
                hasName 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      = fromLA validateNamespaces1

    validateNamespaces1     :: LA XmlTree XmlTree
    validateNamespaces1
        = choiceA [ isRoot  :-> ( getChildren >>> validateNamespaces1 )             -- root is correct by definition
                  , this    :-> multi validate1Namespaces
                  ]

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

    validate1Namespaces     :: LA XmlTree XmlTree
    validate1Namespaces
        = choiceA
          [ isElem  :-> catA [ ( getQName >>> isA ( not . isWellformedQName )
                               )
                               `guards` nsError (\ n -> "element name " ++ show n ++ " is not a wellformed qualified name" )

                             , ( getQName >>> isA ( not . isDeclaredNamespace )
                               )
                               `guards` nsError (\ n -> "namespace for prefix in element name " ++ show n ++ " is undefined" )

                             , doubleOcc $< ( (getAttrl >>> getUniversalName) >>. doubles )

                             , getAttrl >>> validate1Namespaces
                             ]

          , isAttr  :-> catA [ ( getQName >>> isA ( not . isWellformedQName )
                               )
                               `guards` nsError (\ n -> "attribute name " ++ show n ++ " is not a wellformed qualified name" )

                             , ( getQName >>> isA ( not . isDeclaredNamespace )
                               )
                               `guards` nsError (\ n -> "namespace for prefix in attribute name " ++ show n ++ " is undefined" )

                             , ( hasNamePrefix a_xmlns >>> xshow getChildren >>> isA null
                               )
                               `guards` nsError (\ n -> "namespace value of namespace declaration for " ++ show n ++ " has no value" )

                             , ( getQName >>> isA (not . isWellformedNSDecl )
                               )
                               `guards`  nsError (\ n -> "illegal namespace declaration for name " ++ n ++ " starting with reserved prefix " ++ show "xml" )
                             ]

          , isDTD   :-> catA [ isDTDDoctype <+> isDTDAttlist <+> isDTDElement <+> isDTDName
                               >>>
                               getDTDAttrValue a_name
                               >>>
                               ( isA (not . isWellformedQualifiedName)
                                 `guards`
                                 nsErr (\ n -> "a DTD part contains a not wellformed qualified Name: " ++ show n)
                               )

                             , isDTDAttlist
                               >>>
                               getDTDAttrValue a_value
                               >>>
                               ( isA (not . isWellformedQualifiedName)
                                 `guards`
                                 nsErr (\ n -> "an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " ++ show n)
                               )

                             , isDTDEntity <+> isDTDPEntity <+> isDTDNotation
                               >>>
                               getDTDAttrValue a_name
                               >>>
                               ( isA (not . isNCName)
                                 `guards`
                                 nsErr (\ n -> "an entity or notation declaration contains a not wellformed NCName: " ++ show n)
                               )
                             ]
          , isPi    :-> catA [ getName
                               >>>
                               ( isA (not . isNCName)
                                 `guards`
                                 nsErr (\ n -> "a PI contains a not wellformed NCName: " ++ show n)
                               )
                             ]
          ]
        where
        nsError     :: (String -> String) -> LA XmlTree XmlTree
        nsError msg
            = (getQName >>> arr show) >>> nsErr msg

        nsErr       :: (String -> String) -> LA String XmlTree
        nsErr msg   = arr msg >>> mkError c_err

        doubleOcc   :: String -> LA XmlTree XmlTree
        doubleOcc an
            = nsError (\ n -> "multiple occurences of universal name for attributes of tag " ++ show n ++ " : " ++ show an )

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