hxt-9.1.0: src/Text/XML/HXT/Arrow/XmlArrow.hs

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

{- |
   Module     : Text.XML.HXT.Arrow.XmlArrow
   Copyright  : Copyright (C) 2011 Uwe Schmidt
   License    : MIT

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

   Basic arrows for processing XML documents

   All arrows use IO and a global state for options, errorhandling, ...

-}

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

module Text.XML.HXT.Arrow.XmlArrow
    ( module Text.XML.HXT.Arrow.XmlArrow )
where

import           Control.Arrow                  -- classes
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowIf
import           Control.Arrow.ArrowTree

import           Control.Arrow.ListArrow                -- arrow types
import           Control.Arrow.StateListArrow
import           Control.Arrow.IOListArrow
import           Control.Arrow.IOStateListArrow

import           Data.Char.Properties.XMLCharProps        ( isXmlSpaceChar )
import           Data.Maybe

import           Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.DOM.ShowXml as XS

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

{- | Arrows for processing 'Text.XML.HXT.DOM.TypeDefs.XmlTree's

These arrows can be grouped into predicates, selectors, constructors, and transformers.

All predicates (tests) act like 'Control.Arrow.ArrowIf.none' for failure and 'Control.Arrow.ArrowIf.this' for success.
A logical and can be formed by @ a1 >>> a2 @, a locical or by @ a1 \<+\> a2 @.

Selector arrows will fail, when applied to wrong input, e.g. selecting the text of a node with 'getText'
will fail when applied to a none text node.

Edit arrows will remain the input unchanged, when applied to wrong argument, e.g. editing the content of a text node
with 'changeText' applied to an element node will return the unchanged element node.
-}

infixl 7 +=

class (Arrow a, ArrowList a, ArrowTree a) => ArrowXml a where

    -- discriminating predicates

    -- | test for text nodes
    isText              :: a XmlTree XmlTree
    isText              = isA XN.isText
    {-# INLINE isText #-}

    isBlob              :: a XmlTree XmlTree
    isBlob              = isA XN.isBlob
    {-# INLINE isBlob #-}

    -- | test for char reference, used during parsing
    isCharRef           :: a XmlTree XmlTree
    isCharRef           = isA XN.isCharRef
    {-# INLINE isCharRef #-}

    -- | test for entity reference, used during parsing
    isEntityRef         :: a XmlTree XmlTree
    isEntityRef         = isA XN.isEntityRef
    {-# INLINE isEntityRef #-}

    -- | test for comment
    isCmt               :: a XmlTree XmlTree
    isCmt               = isA XN.isCmt
    {-# INLINE isCmt #-}

    -- | test for CDATA section, used during parsing
    isCdata             :: a XmlTree XmlTree
    isCdata             = isA XN.isCdata
    {-# INLINE isCdata #-}

    -- | test for processing instruction
    isPi                :: a XmlTree XmlTree
    isPi                = isA XN.isPi
    {-# INLINE isPi #-}

    -- | test for processing instruction \<?xml ...\>
    isXmlPi             :: a XmlTree XmlTree
    isXmlPi             = isPi >>> hasName "xml"

    -- | test for element
    isElem              :: a XmlTree XmlTree
    isElem              = isA XN.isElem
    {-# INLINE isElem #-}

    -- | test for DTD part, used during parsing
    isDTD               :: a XmlTree XmlTree
    isDTD               = isA XN.isDTD
    {-# INLINE isDTD #-}

    -- | test for attribute tree
    isAttr              :: a XmlTree XmlTree
    isAttr              = isA XN.isAttr
    {-# INLINE isAttr #-}

    -- | test for error message
    isError             :: a XmlTree XmlTree
    isError             = isA XN.isError
    {-# INLINE isError #-}

    -- | test for root node (element with name \"\/\")
    isRoot              :: a XmlTree XmlTree
    isRoot              = isA XN.isRoot
    {-# INLINE isRoot #-}

    -- | test for text nodes with text, for which a predicate holds
    --
    -- example: @hasText (all (\`elem\` \" \\t\\n\"))@ check for text nodes with only whitespace content

    hasText             :: (String -> Bool) -> a XmlTree XmlTree
    hasText p           = (isText >>> getText >>> isA p) `guards` this

    -- | test for text nodes with only white space
    --
    -- implemented with 'hasTest'

    isWhiteSpace        :: a XmlTree XmlTree
    isWhiteSpace        = hasText (all isXmlSpaceChar)
    {-# INLINE isWhiteSpace #-}

    -- |
    -- test whether a node (element, attribute, pi) has a name with a special property

    hasNameWith         :: (QName  -> Bool) -> a XmlTree XmlTree
    hasNameWith p       = (getQName        >>> isA p) `guards` this
    {-# INLINE hasNameWith #-}

    -- |
    -- test whether a node (element, attribute, pi) has a specific qualified name
    -- useful only after namespace propagation
    hasQName            :: QName  -> a XmlTree XmlTree
    hasQName n          = (getQName        >>> isA (== n)) `guards` this
    {-# INLINE hasQName #-}

    -- |
    -- test whether a node has a specific name (prefix:localPart ore localPart),
    -- generally useful, even without namespace handling
    hasName             :: String -> a XmlTree XmlTree
    hasName n           = (getName         >>> isA (== n)) `guards` this
    {-# INLINE hasName #-}

    -- |
    -- test whether a node has a specific name as local part,
    -- useful only after namespace propagation
    hasLocalPart        :: String -> a XmlTree XmlTree
    hasLocalPart n      = (getLocalPart    >>> isA (== n)) `guards` this
    {-# INLINE hasLocalPart #-}

    -- |
    -- test whether a node has a specific name prefix,
    -- useful only after namespace propagation
    hasNamePrefix       :: String -> a XmlTree XmlTree
    hasNamePrefix n     = (getNamePrefix   >>> isA (== n)) `guards` this
    {-# INLINE hasNamePrefix #-}

    -- |
    -- test whether a node has a specific namespace URI
    -- useful only after namespace propagation
    hasNamespaceUri     :: String -> a XmlTree XmlTree
    hasNamespaceUri n   = (getNamespaceUri >>> isA (== n)) `guards` this
    {-# INLINE hasNamespaceUri #-}

    -- |
    -- test whether an element node has an attribute node with a specific name
    hasAttr             :: String -> a XmlTree XmlTree
    hasAttr n           = (getAttrl        >>> hasName n)  `guards` this
    {-# INLINE hasAttr #-}

    -- |
    -- test whether an element node has an attribute node with a specific qualified name
    hasQAttr            :: QName -> a XmlTree XmlTree
    hasQAttr n          = (getAttrl        >>> hasQName n)  `guards` this
    {-# INLINE hasQAttr #-}

    -- |
    -- test whether an element node has an attribute with a specific value
    hasAttrValue        :: String -> (String -> Bool) -> a XmlTree XmlTree
    hasAttrValue n p    = (getAttrl >>> hasName n >>> xshow getChildren >>> isA p)  `guards` this

    -- |
    -- test whether an element node has an attribute with a qualified name and a specific value
    hasQAttrValue       :: QName -> (String -> Bool) -> a XmlTree XmlTree
    hasQAttrValue n p   = (getAttrl >>> hasQName n >>> xshow getChildren >>> isA p)  `guards` this

    -- constructor arrows ------------------------------------------------------------

    -- | text node construction arrow
    mkText              :: a String XmlTree
    mkText              = arr  XN.mkText
    {-# INLINE mkText #-}

    -- | blob node construction arrow
    mkBlob              :: a Blob XmlTree
    mkBlob              = arr  XN.mkBlob
    {-# INLINE mkBlob #-}

    -- | char reference construction arrow, useful for document output
    mkCharRef           :: a Int    XmlTree
    mkCharRef           = arr  XN.mkCharRef
    {-# INLINE mkCharRef #-}

    -- | entity reference construction arrow, useful for document output
    mkEntityRef         :: a String XmlTree
    mkEntityRef         = arr  XN.mkEntityRef
    {-# INLINE mkEntityRef #-}

    -- | comment node construction, useful for document output
    mkCmt               :: a String XmlTree
    mkCmt               = arr  XN.mkCmt
    {-# INLINE mkCmt #-}

    -- | CDATA construction, useful for document output
    mkCdata             :: a String XmlTree
    mkCdata             = arr  XN.mkCdata
    {-# INLINE mkCdata #-}

    -- | error node construction, useful only internally
    mkError             :: Int -> a String XmlTree
    mkError level       = arr (XN.mkError level)

    -- | element construction:
    -- | the attributes and the content of the element are computed by applying arrows
    -- to the input
    mkElement           :: QName -> a n XmlTree -> a n XmlTree -> a n XmlTree
    mkElement n af cf   = (listA af &&& listA cf)
                          >>>
                          arr2 (\ al cl -> XN.mkElement n al cl)

    -- | attribute node construction:
    -- | the attribute value is computed by applying an arrow to the input
    mkAttr              :: QName -> a n XmlTree -> a n XmlTree
    mkAttr qn f         = listA f >>> arr (XN.mkAttr qn)

    -- | processing instruction construction:
    -- | the content of the processing instruction is computed by applying an arrow to the input
    mkPi                :: QName -> a n XmlTree -> a n XmlTree
    mkPi qn f           = listA f >>> arr (XN.mkPi   qn)

    -- convenient arrows for constructors --------------------------------------------------

    -- | convenient arrow for element construction, more comfortable variant of 'mkElement'
    --
    -- example for simplifying 'mkElement' :
    --
    -- > mkElement qn (a1 <+> ... <+> ai) (c1 <+> ... <+> cj)
    --
    -- equals
    --
    -- > mkqelem qn [a1,...,ai] [c1,...,cj]

    mkqelem             :: QName -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree
    mkqelem  n afs cfs  = mkElement n (catA afs) (catA cfs)
    {-# INLINE mkqelem #-}

    -- | convenient arrow for element construction with strings instead of qualified names as element names, see also 'mkElement' and 'mkelem'
    mkelem              :: String -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree
    mkelem  n afs cfs   = mkElement (mkName n) (catA afs) (catA cfs)
    {-# INLINE mkelem #-}

    -- | convenient arrow for element constrution with attributes but without content, simple variant of 'mkelem' and 'mkElement'
    aelem               :: String -> [a n XmlTree]                  -> a n XmlTree
    aelem n afs         = catA afs >. \ al -> XN.mkElement (mkName n) al []
    {-# INLINE aelem #-}

    -- | convenient arrow for simple element constrution without attributes, simple variant of 'mkelem' and 'mkElement'
    selem               :: String                  -> [a n XmlTree] -> a n XmlTree
    selem n cfs         = catA cfs >.         XN.mkElement (mkName n) []
    {-# INLINE selem #-}

    -- | convenient arrow for constrution of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'
    eelem               :: String                                   -> a n XmlTree
    eelem n             = constA      (XN.mkElement (mkName n) [] [])
    {-# INLINE eelem #-}

    -- | construction of an element node with name \"\/\" for document roots
    root                ::           [a n XmlTree] -> [a n XmlTree] -> a n XmlTree
    root                = mkelem t_root
    {-# INLINE root #-}

    -- | alias for 'mkAttr'
    qattr               :: QName -> a n XmlTree -> a n XmlTree
    qattr               = mkAttr
    {-# INLINE qattr #-}

    -- | convenient arrow for attribute constrution, simple variant of 'mkAttr'
    attr                :: String -> a n XmlTree -> a n XmlTree
    attr                = mkAttr . mkName
    {-# INLINE attr #-}

    -- constant arrows (ignoring the input) for tree construction ------------------------------

    -- | constant arrow for text nodes
    txt                 :: String -> a n XmlTree
    txt                 = constA .  XN.mkText
    {-# INLINE txt #-}

    -- | constant arrow for blob nodes
    blb                 :: Blob -> a n XmlTree
    blb                 = constA .  XN.mkBlob
    {-# INLINE blb #-}

    -- | constant arrow for char reference nodes
    charRef             :: Int    -> a n XmlTree
    charRef             = constA .  XN.mkCharRef
    {-# INLINE charRef #-}

    -- | constant arrow for entity reference nodes
    entityRef           :: String -> a n XmlTree
    entityRef           = constA .  XN.mkEntityRef
    {-# INLINE entityRef #-}

    -- | constant arrow for comment
    cmt                 :: String -> a n XmlTree
    cmt                 = constA .  XN.mkCmt
    {-# INLINE cmt #-}

    -- | constant arrow for warning
    warn                :: String -> a n XmlTree
    warn                = constA . (XN.mkError c_warn)
    {-# INLINE warn #-}

    -- | constant arrow for errors
    err                 :: String -> a n XmlTree
    err                 = constA . (XN.mkError c_err)
    {-# INLINE err #-}

    -- | constant arrow for fatal errors
    fatal               :: String -> a n XmlTree
    fatal               = constA . (XN.mkError c_fatal)
    {-# INLINE fatal #-}

    -- | constant arrow for simple processing instructions, see 'mkPi'
    spi                 :: String -> String -> a n XmlTree
    spi piName piCont   = constA (XN.mkPi (mkName piName) [XN.mkAttr (mkName a_value) [XN.mkText piCont]])
    {-# INLINE spi #-}

    -- | constant arrow for attribute nodes, attribute name is a qualified name and value is a text,
    -- | see also 'mkAttr', 'qattr', 'attr'
    sqattr              :: QName -> String -> a n XmlTree
    sqattr an av        = constA (XN.mkAttr an                 [XN.mkText av])
    {-# INLINE sqattr #-}

    -- | constant arrow for attribute nodes, attribute name and value are
    -- | given by parameters, see 'mkAttr'
    sattr               :: String -> String -> a n XmlTree
    sattr an av         = constA (XN.mkAttr (mkName an)     [XN.mkText av])
    {-# INLINE sattr #-}

    -- selector arrows --------------------------------------------------

    -- | select the text of a text node
    getText             :: a XmlTree String
    getText             = arrL (maybeToList  . XN.getText)
    {-# INLINE getText #-}

    -- | select the value of a char reference
    getCharRef          :: a XmlTree Int
    getCharRef          = arrL (maybeToList  . XN.getCharRef)
    {-# INLINE getCharRef #-}

    -- | select the name of a entity reference node
    getEntityRef        :: a XmlTree String
    getEntityRef        = arrL (maybeToList  . XN.getEntityRef)
    {-# INLINE getEntityRef #-}

    -- | select the comment of a comment node
    getCmt              :: a XmlTree String
    getCmt              = arrL (maybeToList  . XN.getCmt)
    {-# INLINE getCmt #-}

    -- | select the content of a CDATA node
    getCdata            :: a XmlTree String
    getCdata            = arrL (maybeToList  . XN.getCdata)
    {-# INLINE getCdata #-}

    -- | select the name of a processing instruction
    getPiName           :: a XmlTree QName
    getPiName           = arrL (maybeToList  . XN.getPiName)
    {-# INLINE getPiName #-}

    -- | select the content of a processing instruction
    getPiContent        :: a XmlTree XmlTree
    getPiContent        = arrL (fromMaybe [] . XN.getPiContent)
    {-# INLINE getPiContent #-}

    -- | select the name of an element node
    getElemName         :: a XmlTree QName
    getElemName         = arrL (maybeToList  . XN.getElemName)
    {-# INLINE getElemName #-}

    -- | select the attribute list of an element node
    getAttrl            :: a XmlTree XmlTree
    getAttrl            = arrL (fromMaybe [] . XN.getAttrl)
    {-# INLINE getAttrl #-}

    -- | select the DTD type of a DTD node
    getDTDPart          :: a XmlTree DTDElem
    getDTDPart          = arrL (maybeToList  . XN.getDTDPart)
    {-# INLINE getDTDPart #-}

    -- | select the DTD attributes of a DTD node
    getDTDAttrl         :: a XmlTree Attributes
    getDTDAttrl         = arrL (maybeToList  . XN.getDTDAttrl)
    {-# INLINE getDTDAttrl #-}

    -- | select the name of an attribute
    getAttrName         :: a XmlTree QName
    getAttrName         = arrL (maybeToList  . XN.getAttrName)
    {-# INLINE getAttrName #-}

    -- | select the error level (c_warn, c_err, c_fatal) from an error node
    getErrorLevel       :: a XmlTree Int
    getErrorLevel       = arrL (maybeToList  . XN.getErrorLevel)
    {-# INLINE getErrorLevel #-}

    -- | select the error message from an error node
    getErrorMsg         :: a XmlTree String
    getErrorMsg         = arrL (maybeToList  . XN.getErrorMsg)
    {-# INLINE getErrorMsg #-}

    -- | select the qualified name from an element, attribute or pi
    getQName            :: a XmlTree QName
    getQName            = arrL (maybeToList  . XN.getName)
    {-# INLINE getQName #-}

    -- | select the prefix:localPart or localPart from an element, attribute or pi
    getName             :: a XmlTree String
    getName             = arrL (maybeToList  . XN.getQualifiedName)
    {-# INLINE getName #-}

    -- | select the univeral name ({namespace URI} ++ localPart)
    getUniversalName    :: a XmlTree String
    getUniversalName    = arrL (maybeToList  . XN.getUniversalName)
    {-# INLINE getUniversalName #-}

    -- | select the univeral name (namespace URI ++ localPart)
    getUniversalUri     :: a XmlTree String
    getUniversalUri     = arrL (maybeToList  . XN.getUniversalUri)
    {-# INLINE getUniversalUri #-}

    -- | select the local part
    getLocalPart        :: a XmlTree String
    getLocalPart        = arrL (maybeToList  . XN.getLocalPart)
    {-# INLINE getLocalPart #-}

    -- | select the name prefix
    getNamePrefix       :: a XmlTree String
    getNamePrefix       = arrL (maybeToList  . XN.getNamePrefix)
    {-# INLINE getNamePrefix #-}

    -- | select the namespace URI
    getNamespaceUri     :: a XmlTree String
    getNamespaceUri     = arrL (maybeToList  . XN.getNamespaceUri)
    {-# INLINE getNamespaceUri #-}

    -- | select the value of an attribute of an element node,
    -- always succeeds with empty string as default value \"\"
    getAttrValue        :: String -> a XmlTree String
    getAttrValue n      = xshow (getAttrl >>> hasName n >>> getChildren)

    -- | like 'getAttrValue', but fails if the attribute does not exist
    getAttrValue0       :: String -> a XmlTree String
    getAttrValue0 n     = getAttrl >>> hasName n >>> xshow getChildren

    -- | like 'getAttrValue', but select the value of an attribute given by a qualified name,
    -- always succeeds with empty string as default value \"\"
    getQAttrValue       :: QName -> a XmlTree String
    getQAttrValue n     = xshow (getAttrl >>> hasQName n >>> getChildren)

    -- | like 'getQAttrValue', but fails if attribute does not exist
    getQAttrValue0      :: QName -> a XmlTree String
    getQAttrValue0 n    = getAttrl >>> hasQName n >>> xshow getChildren

    -- edit arrows --------------------------------------------------

    -- | edit the string of a text node
    changeText          :: (String -> String) -> a XmlTree XmlTree
    changeText cf       = arr (XN.changeText     cf) `when` isText

    -- | edit the blob of a blob node
    changeBlob          :: (Blob -> Blob) -> a XmlTree XmlTree
    changeBlob cf       = arr (XN.changeBlob     cf) `when` isBlob

    -- | edit the comment string of a comment node
    changeCmt           :: (String -> String) -> a XmlTree XmlTree
    changeCmt  cf       = arr (XN.changeCmt      cf) `when` isCmt

    -- | edit an element-, attribute- or pi- name
    changeQName         :: (QName  -> QName) -> a XmlTree XmlTree
    changeQName cf      = arr (XN.changeName  cf) `when` getQName

    -- | edit an element name
    changeElemName      :: (QName  -> QName) -> a XmlTree XmlTree
    changeElemName cf   = arr (XN.changeElemName  cf) `when` isElem

    -- | edit an attribute name
    changeAttrName      :: (QName  -> QName) -> a XmlTree XmlTree
    changeAttrName cf   = arr (XN.changeAttrName cf) `when` isAttr

    -- | edit a pi name
    changePiName        :: (QName  -> QName) -> a XmlTree XmlTree
    changePiName cf     = arr (XN.changePiName  cf) `when` isPi

    -- | edit an attribute value
    changeAttrValue     :: (String -> String) -> a XmlTree XmlTree
    changeAttrValue cf  = replaceChildren ( xshow getChildren
                                            >>> arr cf
                                            >>> mkText
                                          )
                          `when` isAttr


    -- | edit an attribute list of an element node
    changeAttrl         :: (XmlTrees -> XmlTrees -> XmlTrees) -> a XmlTree XmlTree -> a XmlTree XmlTree
    changeAttrl cf f    = ( ( listA f &&& this )
                            >>>
                            arr2 changeAL
                          )
                          `when`
                          ( isElem <+> isPi )
                        where
                        changeAL as x = XN.changeAttrl (\ xs -> cf xs as) x

    -- | replace an element, attribute or pi name
    setQName            :: QName -> a XmlTree XmlTree
    setQName  n         = changeQName  (const n)
    {-# INLINE setQName #-}

    -- | replace an element name
    setElemName         :: QName -> a XmlTree XmlTree
    setElemName  n      = changeElemName  (const n)
    {-# INLINE setElemName #-}

    -- | replace an attribute name
    setAttrName         :: QName -> a XmlTree XmlTree
    setAttrName n       = changeAttrName (const n)
    {-# INLINE setAttrName #-}

    -- | replace an element name
    setPiName           :: QName -> a XmlTree XmlTree
    setPiName  n        = changePiName  (const n)
    {-# INLINE setPiName #-}

    -- | replace an atribute list of an element node
    setAttrl            :: a XmlTree XmlTree -> a XmlTree XmlTree
    setAttrl            = changeAttrl (const id)                -- (\ x y -> y)
    {-# INLINE setAttrl #-}

    -- | add a list of attributes to an element
    addAttrl            :: a XmlTree XmlTree -> a XmlTree XmlTree
    addAttrl            = changeAttrl (XN.mergeAttrl)
    {-# INLINE addAttrl #-}

    -- | add (or replace) an attribute
    addAttr             :: String -> String  -> a XmlTree XmlTree
    addAttr an av       = addAttrl (sattr an av)
    {-# INLINE addAttr #-}

    -- | remove an attribute
    removeAttr          :: String  -> a XmlTree XmlTree
    removeAttr an       = processAttrl (none `when` hasName an)

    -- | remove an attribute with a qualified name
    removeQAttr         :: QName  -> a XmlTree XmlTree
    removeQAttr an      = processAttrl (none `when` hasQName an)

    -- | process the attributes of an element node with an arrow
    processAttrl        :: a XmlTree XmlTree -> a XmlTree XmlTree
    processAttrl f      = setAttrl (getAttrl >>> f)

    -- | process a whole tree inclusive attribute list of element nodes
    -- see also: 'Control.Arrow.ArrowTree.processTopDown'

    processTopDownWithAttrl     :: a XmlTree XmlTree -> a XmlTree XmlTree
    processTopDownWithAttrl f   = processTopDown ( f >>> ( processAttrl (processTopDown f) `when` isElem))

    -- | convenient op for adding attributes or children to a node
    --
    -- usage: @ tf += cf @
    --
    -- the @tf@ arrow computes an element node, and all trees computed by @cf@ are
    -- added to this node, if a tree is an attribute, it is inserted in the attribute list
    -- else it is appended to the content list.
    --
    -- attention: do not build long content list this way because '+=' is implemented by ++
    --
    -- examples:
    --
    -- > eelem "a"
    -- >   += sattr "href" "page.html"
    -- >   += sattr "name" "here"
    -- >   += txt "look here"
    --
    -- is the same as
    --
    -- > mkelem [ sattr "href" "page.html"
    -- >        , sattr "name" "here"
    -- >        ]
    -- >        [ txt "look here" ]
    --
    -- and results in the XML fragment: \<a href=\"page.html\" name=\"here\"\>look here\<\/a\>
    --
    -- advantage of the '+=' operator is, that attributes and content can be added
    -- any time step by step.
    -- if @tf@ computes a whole list of trees, e.g. a list of \"td\" or \"tr\" elements,
    -- the attributes or content is added to all trees. useful for adding \"class\" or \"style\" attributes
    -- to table elements.

    (+=)                :: a b XmlTree -> a b XmlTree -> a b XmlTree
    tf += cf            = (tf &&& listA cf) >>> arr2 addChildren
                        where
                        addChildren     :: XmlTree -> XmlTrees -> XmlTree
                        addChildren t cs
                            = foldl addChild t cs
                        addChild        :: XmlTree -> XmlTree -> XmlTree
                        addChild t c
                            | not (XN.isElem t)
                                = t
                            | XN.isAttr c
                                = XN.changeAttrl (XN.addAttr c) t
                            | otherwise
                                = XN.changeChildren (++ [c]) t


    -- | apply an arrow to the input and convert the resulting XML trees into a string representation

    xshow               :: a n XmlTree -> a n String
    xshow f             = f >. XS.xshow
    {-# INLINE xshow #-}


    -- | apply an arrow to the input and convert the resulting XML trees into a string representation

    xshowBlob           :: a n XmlTree -> a n Blob
    xshowBlob f         = f >. XS.xshowBlob
    {-# INLINE xshowBlob #-}


{- | Document Type Definition arrows

These are separated, because they are not needed for document processing,
only when processing the DTD, e.g. for generating access funtions for the toolbox
from a DTD (se example DTDtoHaskell in the examples directory)
-}


class (ArrowXml a) => ArrowDTD a where
    isDTDDoctype        :: a XmlTree XmlTree
    isDTDDoctype        = isA (maybe False (== DOCTYPE ) . XN.getDTDPart)

    isDTDElement        :: a XmlTree XmlTree
    isDTDElement        = isA (maybe False (== ELEMENT ) . XN.getDTDPart)

    isDTDContent        :: a XmlTree XmlTree
    isDTDContent        = isA (maybe False (== CONTENT ) . XN.getDTDPart)

    isDTDAttlist        :: a XmlTree XmlTree
    isDTDAttlist        = isA (maybe False (== ATTLIST ) . XN.getDTDPart)

    isDTDEntity         :: a XmlTree XmlTree
    isDTDEntity         = isA (maybe False (== ENTITY  ) . XN.getDTDPart)

    isDTDPEntity        :: a XmlTree XmlTree
    isDTDPEntity        = isA (maybe False (== PENTITY ) . XN.getDTDPart)

    isDTDNotation       :: a XmlTree XmlTree
    isDTDNotation       = isA (maybe False (== NOTATION) . XN.getDTDPart)

    isDTDCondSect       :: a XmlTree XmlTree
    isDTDCondSect       = isA (maybe False (== CONDSECT) . XN.getDTDPart)

    isDTDName           :: a XmlTree XmlTree
    isDTDName           = isA (maybe False (== NAME    ) . XN.getDTDPart)

    isDTDPERef          :: a XmlTree XmlTree
    isDTDPERef          = isA (maybe False (== PEREF   ) . XN.getDTDPart)

    hasDTDAttr          :: String -> a XmlTree XmlTree
    hasDTDAttr n        = isA (isJust . lookup n . fromMaybe [] . XN.getDTDAttrl)

    getDTDAttrValue     :: String -> a XmlTree String
    getDTDAttrValue n   = arrL (maybeToList . lookup n . fromMaybe [] . XN.getDTDAttrl)

    setDTDAttrValue     :: String -> String -> a XmlTree XmlTree
    setDTDAttrValue n v = arr (XN.changeDTDAttrl (addEntry n v)) `when` isDTD

    mkDTDElem           :: DTDElem -> Attributes -> a n XmlTree -> a n XmlTree
    mkDTDElem e al cf   = listA cf >>> arr (XN.mkDTDElem e al)

    mkDTDDoctype        :: Attributes -> a n XmlTree -> a n XmlTree
    mkDTDDoctype        = mkDTDElem DOCTYPE

    mkDTDElement        :: Attributes -> a n XmlTree
    mkDTDElement al     = mkDTDElem ELEMENT al none

    mkDTDEntity         :: Attributes -> a n XmlTree
    mkDTDEntity al      = mkDTDElem ENTITY al none

    mkDTDPEntity        :: Attributes -> a n XmlTree
    mkDTDPEntity al     = mkDTDElem PENTITY al none

instance ArrowXml LA
instance ArrowXml (SLA s)
instance ArrowXml IOLA
instance ArrowXml (IOSLA s)

instance ArrowDTD LA
instance ArrowDTD (SLA s)
instance ArrowDTD IOLA
instance ArrowDTD (IOSLA s)

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