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

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

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

   common edit arrows

-}

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

module Text.XML.HXT.Arrow.Edit
    ( canonicalizeAllNodes
    , canonicalizeForXPath
    , canonicalizeContents
    , collapseAllXText
    , collapseXText

    , xshowEscapeXml

    , escapeXmlRefs
    , escapeHtmlRefs

    , haskellRepOfXmlDoc
    , treeRepOfXmlDoc
    , addHeadlineToXmlDoc

    , indentDoc
    , numberLinesInXmlDoc
    , preventEmptyElements

    , removeComment
    , removeAllComment
    , removeWhiteSpace
    , removeAllWhiteSpace
    , removeDocWhiteSpace

    , transfCdata
    , transfAllCdata
    , transfCharRef
    , transfAllCharRef

    , substAllXHTMLEntityRefs
    , substXHTMLEntityRef

    , rememberDTDAttrl
    , addDefaultDTDecl

    , hasXmlPi
    , addXmlPi
    , addXmlPiEncoding

    , addDoctypeDecl
    , addXHtmlDoctypeStrict
    , addXHtmlDoctypeTransitional
    , addXHtmlDoctypeFrameset
    )
where

import           Control.Arrow
import           Control.Arrow.ArrowIf
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowTree
import           Control.Arrow.ListArrow
import           Control.Arrow.NTreeEdit

import           Data.Char.Properties.XMLCharProps (isXmlSpaceChar)

import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.DOM.FormatXmlTree    (formatXmlTree)
import           Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.ShowXml          as XS
import qualified Text.XML.HXT.DOM.XmlNode          as XN
import           Text.XML.HXT.Parser.HtmlParsec    (emptyHtmlTags)
import           Text.XML.HXT.Parser.XhtmlEntities (xhtmlEntities)
import           Text.XML.HXT.Parser.XmlEntities   (xmlEntities)

import           Data.List                         (isPrefixOf)
import qualified Data.Map                          as M
import           Data.Maybe

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

-- |
-- Applies some "Canonical XML" rules to a document tree.
--
-- The rules differ slightly for canonical XML and XPath in handling of comments
--
-- Note: This is not the whole canonicalization as it is specified by the W3C
-- Recommendation. Adding attribute defaults or sorting attributes in lexicographic
-- order is done by the @transform@ function of module @Text.XML.HXT.Validator.Validation@.
-- Replacing entities or line feed normalization is done by the parser.
--
--
-- Not implemented yet:
--
--  - Whitespace within start and end tags is normalized
--
--  - Special characters in attribute values and character content are replaced by character references
--
-- see 'canonicalizeAllNodes' and 'canonicalizeForXPath'

canonicalizeTree'       :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeTree' :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeTree' LA XmlTree XmlTree
toBeRemoved
    = ( LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren
        ( (LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` (LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isText LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isXmlPi))    -- remove XML PI and all text around XML root element
          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 :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
deep LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isDTD)              -- remove DTD parts, except PIs whithin DTD
        )
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot
      )
      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
canonicalizeNodes LA XmlTree XmlTree
toBeRemoved

canonicalizeNodes       :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeNodes :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeNodes LA XmlTree XmlTree
toBeRemoved
    = [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall b c.
[IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))]
-> LA (NTree b) (NTree b)
editNTreeA ([IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
 -> LA XmlTree XmlTree)
-> [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
      [ LA XmlTree XmlTree
toBeRemoved     LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      , ( 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 :: * -> * -> *) (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
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCharRef )   -- canonicalize attribute list
                        LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> ( LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl
                              ( LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
transfCharRef
                                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
collapseXText'                  -- combine text in attribute values
                              )
                              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
collapseXText'                  -- and combine text in content
                                LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                                (LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree XmlTree
-> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. [XmlTree] -> [XmlTree]
has2XText)
                              )
                            )
      , ( 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 :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree XmlTree
-> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. [XmlTree] -> [XmlTree]
has2XText) )
                        LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree
collapseXText'                      -- combine text in content

      , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCharRef       LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> ( LA XmlTree Int
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
getCharRef
                              LA XmlTree Int -> LA Int 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
>>>
                              (Int -> [Char]) -> LA Int [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ Int
i -> [Int -> Char
forall a. Enum a => Int -> a
toEnum Int
i])
                              LA Int [Char] -> LA [Char] XmlTree -> LA Int XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText
                            )
      , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCdata         LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> ( LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getCdata
                              LA XmlTree [Char] -> LA [Char] 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 [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText
                            )
      ]

-- |
-- Applies some "Canonical XML" rules to a document tree.
--
-- The rule differ slightly for canonical XML and XPath in handling of comments
--
-- Note: This is not the whole canonicalization as it is specified by the W3C
-- Recommendation. Adding attribute defaults or sorting attributes in lexicographic
-- order is done by the @transform@ function of module @Text.XML.HXT.Validator.Validation@.
-- Replacing entities or line feed normalization is done by the parser.
--
-- Rules: remove DTD parts, processing instructions, comments and substitute char refs in attribute
-- values and text
--
-- Not implemented yet:
--
--  - Whitespace within start and end tags is normalized
--
--  - Special characters in attribute values and character content are replaced by character references

canonicalizeAllNodes    :: ArrowList a => a XmlTree XmlTree
canonicalizeAllNodes :: a XmlTree XmlTree
canonicalizeAllNodes    = 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 XmlTree -> LA XmlTree XmlTree
canonicalizeTree' LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCmt                       -- remove comment
{-# INLINE canonicalizeAllNodes #-}

-- |
-- Canonicalize a tree for XPath
-- Like 'canonicalizeAllNodes' but comment nodes are not removed
--
-- see 'canonicalizeAllNodes'

canonicalizeForXPath    :: ArrowList a => a XmlTree XmlTree
canonicalizeForXPath :: a XmlTree XmlTree
canonicalizeForXPath    = 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 XmlTree -> LA XmlTree XmlTree
canonicalizeTree' LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none               -- comment remains there
{-# INLINE canonicalizeForXPath #-}

-- |
-- Canonicalize the contents of a document
--
-- substitutes all char refs in text and attribute values,
-- removes CDATA section and combines all sequences of resulting text
-- nodes into a single text node
--
-- see 'canonicalizeAllNodes'

canonicalizeContents    :: ArrowList a => a XmlTree XmlTree
canonicalizeContents :: a XmlTree XmlTree
canonicalizeContents    = 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 XmlTree -> LA XmlTree XmlTree
canonicalizeNodes LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
{-# INLINE canonicalizeContents #-}

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

has2XText               :: XmlTrees -> XmlTrees
has2XText :: [XmlTree] -> [XmlTree]
has2XText ts0 :: [XmlTree]
ts0@(XmlTree
t1 : ts1 :: [XmlTree]
ts1@(XmlTree
t2 : [XmlTree]
ts2))
    | XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
t1      = if XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
t2
                          then [XmlTree]
ts0
                          else [XmlTree] -> [XmlTree]
has2XText [XmlTree]
ts2
    | Bool
otherwise         = [XmlTree] -> [XmlTree]
has2XText [XmlTree]
ts1
has2XText [XmlTree]
_             = []

collapseXText'          :: LA XmlTree XmlTree
collapseXText' :: LA XmlTree XmlTree
collapseXText'
    = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren ( LA XmlTree XmlTree -> LA XmlTree [XmlTree]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree [XmlTree] -> LA [XmlTree] XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([XmlTree] -> [XmlTree]) -> LA [XmlTree] XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL ((XmlTree -> [XmlTree] -> [XmlTree])
-> [XmlTree] -> [XmlTree] -> [XmlTree]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr XmlTree -> [XmlTree] -> [XmlTree]
mergeText' []) )
    where
    mergeText'  :: XmlTree -> XmlTrees -> XmlTrees
    mergeText' :: XmlTree -> [XmlTree] -> [XmlTree]
mergeText' XmlTree
t1 (XmlTree
t2 : [XmlTree]
ts2)
        | XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
t1 Bool -> Bool -> Bool
&& XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
t2
            = let
              s1 :: [Char]
s1 = Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char])
-> (XmlTree -> Maybe [Char]) -> XmlTree -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe [Char]
forall a. XmlNode a => a -> Maybe [Char]
XN.getText (XmlTree -> [Char]) -> XmlTree -> [Char]
forall a b. (a -> b) -> a -> b
$ XmlTree
t1
              s2 :: [Char]
s2 = Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char])
-> (XmlTree -> Maybe [Char]) -> XmlTree -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe [Char]
forall a. XmlNode a => a -> Maybe [Char]
XN.getText (XmlTree -> [Char]) -> XmlTree -> [Char]
forall a b. (a -> b) -> a -> b
$ XmlTree
t2
              t :: XmlTree
t  = [Char] -> XmlTree
forall a. XmlNode a => [Char] -> a
XN.mkText ([Char]
s1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s2)
              in
              XmlTree
t XmlTree -> [XmlTree] -> [XmlTree]
forall a. a -> [a] -> [a]
: [XmlTree]
ts2
    mergeText' XmlTree
t1 [XmlTree]
ts
        = XmlTree
t1 XmlTree -> [XmlTree] -> [XmlTree]
forall a. a -> [a] -> [a]
: [XmlTree]
ts

-- |
-- Collects sequences of text nodes in the list of children of a node into one single text node.
-- This is useful, e.g. after char and entity reference substitution

collapseXText           :: ArrowList a => a XmlTree XmlTree
collapseXText :: a XmlTree XmlTree
collapseXText           = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA LA XmlTree XmlTree
collapseXText'

-- |
-- Applies collapseXText recursively.
--
--
-- see also : 'collapseXText'

collapseAllXText        :: ArrowList a => a XmlTree XmlTree
collapseAllXText :: a XmlTree XmlTree
collapseAllXText        = 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 XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processBottomUp LA XmlTree XmlTree
collapseXText'

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

-- | apply an arrow to the input and convert the resulting XML trees into an XML escaped string
--
-- This is a save variant for converting a tree into an XML string representation
-- that is parsable with 'Text.XML.HXT.Arrow.ReadDocument'.
-- It is implemented with 'Text.XML.HXT.Arrow.XmlArrow.xshow',
-- but xshow does no XML escaping. The XML escaping is done with
-- 'Text.XML.HXT.Arrow.Edit.escapeXmlDoc' before xshow is applied.
--
-- So the following law holds
--
-- > xshowEscapeXml f >>> xread == f

xshowEscapeXml          :: ArrowXml a => a n XmlTree -> a n String
xshowEscapeXml :: a n XmlTree -> a n [Char]
xshowEscapeXml a n XmlTree
f        = a n XmlTree
f a n XmlTree -> ([XmlTree] -> [Char]) -> a n [Char]
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (((Char -> [Char] -> [Char])
 -> (Char -> [Char] -> [Char]) -> [XmlTree] -> [Char])
-> (Char -> [Char] -> [Char], Char -> [Char] -> [Char])
-> [XmlTree]
-> [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Char -> [Char] -> [Char])
-> (Char -> [Char] -> [Char]) -> [XmlTree] -> [Char]
XS.xshow'' (Char -> [Char] -> [Char], Char -> [Char] -> [Char])
escapeXmlRefs)

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

-- |
-- escape XmlText,
-- transform all special XML chars into char- or entity- refs

type EntityRefTable     = M.Map Int String

xmlEntityRefTable
 , xhtmlEntityRefTable  :: EntityRefTable

xmlEntityRefTable :: EntityRefTable
xmlEntityRefTable       = [([Char], Int)] -> EntityRefTable
buildEntityRefTable ([([Char], Int)] -> EntityRefTable)
-> [([Char], Int)] -> EntityRefTable
forall a b. (a -> b) -> a -> b
$ [([Char], Int)]
xmlEntities
xhtmlEntityRefTable :: EntityRefTable
xhtmlEntityRefTable     = [([Char], Int)] -> EntityRefTable
buildEntityRefTable ([([Char], Int)] -> EntityRefTable)
-> [([Char], Int)] -> EntityRefTable
forall a b. (a -> b) -> a -> b
$ [([Char], Int)]
xhtmlEntities

buildEntityRefTable     :: [(String, Int)] -> EntityRefTable
buildEntityRefTable :: [([Char], Int)] -> EntityRefTable
buildEntityRefTable     = [(Int, [Char])] -> EntityRefTable
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, [Char])] -> EntityRefTable)
-> ([([Char], Int)] -> [(Int, [Char])])
-> [([Char], Int)]
-> EntityRefTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], Int) -> (Int, [Char]))
-> [([Char], Int)] -> [(Int, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([Char]
x,Int
y) -> (Int
y,[Char]
x) )

type EntitySubstTable   = M.Map String String

xhtmlEntitySubstTable   :: EntitySubstTable
xhtmlEntitySubstTable :: EntitySubstTable
xhtmlEntitySubstTable   = [([Char], [Char])] -> EntitySubstTable
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([([Char], [Char])] -> EntitySubstTable)
-> ([([Char], Int)] -> [([Char], [Char])])
-> [([Char], Int)]
-> EntitySubstTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], Int) -> ([Char], [Char]))
-> [([Char], Int)] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> [Char]) -> ([Char], Int) -> ([Char], [Char])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Int -> [Char]) -> ([Char], Int) -> ([Char], [Char]))
-> (Int -> [Char]) -> ([Char], Int) -> ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[]) (Char -> [Char]) -> (Int -> Char) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
forall a. Enum a => Int -> a
toEnum) ([([Char], Int)] -> EntitySubstTable)
-> [([Char], Int)] -> EntitySubstTable
forall a b. (a -> b) -> a -> b
$ [([Char], Int)]
xhtmlEntities

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

substXHTMLEntityRef     :: LA XmlTree XmlTree
substXHTMLEntityRef :: LA XmlTree XmlTree
substXHTMLEntityRef
    = ( LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getEntityRef
        LA XmlTree [Char] -> LA [Char] 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
>>>
        ([Char] -> [[Char]]) -> LA [Char] [Char]
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL [Char] -> [[Char]]
subst
        LA [Char] [Char] -> LA [Char] XmlTree -> LA [Char] XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText
      )
      LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse` LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
    where
      subst :: [Char] -> [[Char]]
subst [Char]
name
          = [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[]) (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> EntitySubstTable -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
name EntitySubstTable
xhtmlEntitySubstTable

substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree
substAllXHTMLEntityRefs :: a XmlTree XmlTree
substAllXHTMLEntityRefs
    = 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 XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processBottomUp LA XmlTree XmlTree
substXHTMLEntityRef

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

escapeXmlRefs           :: (Char -> String -> String, Char -> String -> String)
escapeXmlRefs :: (Char -> [Char] -> [Char], Char -> [Char] -> [Char])
escapeXmlRefs           = (Char -> [Char] -> [Char]
cquote, Char -> [Char] -> [Char]
aquote)
    where
    cquote :: Char -> [Char] -> [Char]
cquote Char
c
        | Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"<&" = (Char
'&' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> EntityRefTable -> [Char]
lookupRef Char
c EntityRefTable
xmlEntityRefTable) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
';' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
        | Bool
otherwise     = (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
    aquote :: Char -> [Char] -> [Char]
aquote Char
c
        | Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"<>\"\'&\n\r\t"
                        = (Char
'&' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> EntityRefTable -> [Char]
lookupRef Char
c EntityRefTable
xmlEntityRefTable) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
';' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
        | Bool
otherwise     = (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)

escapeHtmlRefs          :: (Char -> String -> String, Char -> String -> String)
escapeHtmlRefs :: (Char -> [Char] -> [Char], Char -> [Char] -> [Char])
escapeHtmlRefs          = (Char -> [Char] -> [Char]
cquote, Char -> [Char] -> [Char]
aquote)
    where
    cquote :: Char -> [Char] -> [Char]
cquote Char
c
        | Char -> Bool
isHtmlTextEsc Char
c
                        = (Char
'&' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> EntityRefTable -> [Char]
lookupRef Char
c EntityRefTable
xhtmlEntityRefTable) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
';' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
        | Bool
otherwise     = (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
    aquote :: Char -> [Char] -> [Char]
aquote Char
c
        | Char -> Bool
isHtmlAttrEsc Char
c
                        = (Char
'&' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> EntityRefTable -> [Char]
lookupRef Char
c EntityRefTable
xhtmlEntityRefTable) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
                          ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
';' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)
        | Bool
otherwise     = (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)

    isHtmlTextEsc :: Char -> Bool
isHtmlTextEsc Char
c     = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Char
forall a. Enum a => Int -> a
toEnum(Int
128) Bool -> Bool -> Bool
|| ( Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"<&" )
    isHtmlAttrEsc :: Char -> Bool
isHtmlAttrEsc Char
c     = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Char
forall a. Enum a => Int -> a
toEnum(Int
128) Bool -> Bool -> Bool
|| ( Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"<>\"\'&\n\r\t" )

lookupRef               :: Char -> EntityRefTable -> String
lookupRef :: Char -> EntityRefTable -> [Char]
lookupRef Char
c             = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe (Char
'#' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c))
                          (Maybe [Char] -> [Char])
-> (EntityRefTable -> Maybe [Char]) -> EntityRefTable -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> EntityRefTable -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c)
{-# INLINE lookupRef #-}

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

preventEmptyElements    :: ArrowList a => [String] -> Bool -> a XmlTree XmlTree
preventEmptyElements :: [[Char]] -> Bool -> a XmlTree XmlTree
preventEmptyElements [[Char]]
ns Bool
isHtml
    = 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
$
      [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall b c.
[IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))]
-> LA (NTree b) (NTree b)
editNTreeA [ ( 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
isNoneEmpty
                     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 :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
neg LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                   )
                   LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren ([Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
"")
                 ]
    where
    isNoneEmpty :: LA XmlTree XmlTree
isNoneEmpty
        | Bool -> Bool
not ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ns) = (QName -> Bool) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> Bool) -> a XmlTree XmlTree
hasNameWith (QName -> [Char]
localPart (QName -> [Char]) -> ([Char] -> Bool) -> QName -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
ns))
        | Bool
isHtml        = (QName -> Bool) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(QName -> Bool) -> a XmlTree XmlTree
hasNameWith (QName -> [Char]
localPart (QName -> [Char]) -> ([Char] -> Bool) -> QName -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
emptyHtmlTags))
        | Bool
otherwise     = LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this

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

-- |
-- convert a document into a Haskell representation (with show).
--
-- Useful for debugging and trace output.
-- see also : 'treeRepOfXmlDoc', 'numberLinesInXmlDoc'

haskellRepOfXmlDoc      :: ArrowList a => a XmlTree XmlTree
haskellRepOfXmlDoc :: a XmlTree XmlTree
haskellRepOfXmlDoc
    = 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 XmlTree] -> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
[a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root [LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl] [XmlTree -> [Char]
forall a. Show a => a -> [Char]
show (XmlTree -> [Char]) -> LA [Char] XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText]

-- |
-- convert a document into a text and add line numbers to the text representation.
--
-- Result is a root node with a single text node as child.
-- Useful for debugging and trace output.
-- see also : 'haskellRepOfXmlDoc', 'treeRepOfXmlDoc'

numberLinesInXmlDoc     :: ArrowList a => a XmlTree XmlTree
numberLinesInXmlDoc :: a XmlTree XmlTree
numberLinesInXmlDoc
    = 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 XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren (([Char] -> [Char]) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
([Char] -> [Char]) -> a XmlTree XmlTree
changeText [Char] -> [Char]
numberLines)
    where
    numberLines :: String -> String
    numberLines :: [Char] -> [Char]
numberLines [Char]
str
        = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
          (Int -> [Char] -> [Char]) -> [Int] -> [[Char]] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Int
n [Char]
l -> Int -> [Char]
lineNr Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n") [Int
1..] ([Char] -> [[Char]]
lines [Char]
str)
        where
        lineNr   :: Int -> String
        lineNr :: Int -> [Char]
lineNr Int
n = ([Char] -> [Char]
forall a. [a] -> [a]
reverse (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
6 ([Char] -> [Char]
forall a. [a] -> [a]
reverse (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
6 Char
' '))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "

-- |
-- convert a document into a text representation in tree form.
--
-- Useful for debugging and trace output.
-- see also : 'haskellRepOfXmlDoc', 'numberLinesInXmlDoc'

treeRepOfXmlDoc :: ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc :: a XmlTree XmlTree
treeRepOfXmlDoc
    = 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 XmlTree] -> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
[a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root [LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl] [XmlTree -> [Char]
formatXmlTree (XmlTree -> [Char]) -> LA [Char] XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText]

addHeadlineToXmlDoc     :: ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc :: a XmlTree XmlTree
addHeadlineToXmlDoc
    = 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
$ ( [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
addTitle ([Char] -> LA XmlTree XmlTree)
-> LA XmlTree [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< ([Char] -> LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
a_source LA XmlTree [Char] -> ([Char] -> [Char]) -> LA XmlTree [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [Char] -> [Char]
formatTitle) )
    where
    addTitle :: [Char] -> a XmlTree XmlTree
addTitle [Char]
str
        = a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren ( [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
str a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
"\n" )
    formatTitle :: [Char] -> [Char]
formatTitle [Char]
str
        = [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
headline [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
underline [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n"
        where
        headline :: [Char]
headline  = [Char]
"content of: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str
        underline :: [Char]
underline = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'=') [Char]
headline

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

-- |
-- remove a Comment node

removeComment           :: ArrowXml a => a XmlTree XmlTree
removeComment :: a XmlTree XmlTree
removeComment           = a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCmt

-- |
-- remove all comments in a tree recursively

removeAllComment        :: ArrowXml a => a XmlTree XmlTree
removeAllComment :: a XmlTree XmlTree
removeAllComment        = 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
$ [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall b c.
[IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))]
-> LA (NTree b) (NTree b)
editNTreeA [LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCmt LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none]

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

-- |
-- simple filter for removing whitespace.
--
-- no check on sigificant whitespace, e.g. in HTML \<pre\>-elements, is done.
--
--
-- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'

removeWhiteSpace        :: ArrowXml a => a XmlTree XmlTree
removeWhiteSpace :: a XmlTree XmlTree
removeWhiteSpace        = 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 XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isWhiteSpace

-- |
-- simple recursive filter for removing all whitespace.
--
-- removes all text nodes in a tree that consist only of whitespace.
--
--
-- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'

removeAllWhiteSpace     :: ArrowXml a => a XmlTree XmlTree
removeAllWhiteSpace :: a XmlTree XmlTree
removeAllWhiteSpace     = 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
$ [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall b c.
[IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))]
-> LA (NTree b) (NTree b)
editNTreeA [LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isWhiteSpace LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none]
                       -- fromLA $ processBottomUp removeWhiteSpace'    -- less efficient

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

-- |
-- filter for removing all not significant whitespace.
--
-- the tree traversed for removing whitespace between elements,
-- that was inserted for indentation and readability.
-- whitespace is only removed at places, where it's not significat
-- preserving whitespace may be controlled in a document tree
-- by a tag attribute @xml:space@
--
-- allowed values for this attribute are @default | preserve@
--
-- input is root node of the document to be cleaned up,
-- output the semantically equivalent simplified tree
--
--
-- see also : 'indentDoc', 'removeAllWhiteSpace'

removeDocWhiteSpace     :: ArrowXml a => a XmlTree XmlTree
removeDocWhiteSpace :: a XmlTree XmlTree
removeDocWhiteSpace     = 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 XmlTree
removeRootWhiteSpace


removeRootWhiteSpace    :: LA XmlTree XmlTree
removeRootWhiteSpace :: LA XmlTree XmlTree
removeRootWhiteSpace
    =  LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren LA XmlTree XmlTree
processRootElement
       LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
       LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot
    where
    processRootElement  :: LA XmlTree XmlTree
    processRootElement :: LA XmlTree XmlTree
processRootElement
        = LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
removeWhiteSpace 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
processChild
        where
        processChild :: LA XmlTree XmlTree
processChild
            = [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
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
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
removeAllWhiteSpace                 -- whitespace in DTD is redundant
                      , LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                        LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren ( LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                                              LA XmlTree XmlTree
-> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. (Int -> LA XmlTree XmlTree)
-> Bool -> Int -> [XmlTree] -> [XmlTree]
indentTrees Int -> LA XmlTree XmlTree
forall a. Int -> LA a XmlTree
insertNothing Bool
False Int
1
                                            )
                      ]

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

-- |
-- filter for indenting a document tree for pretty printing.
--
-- the tree is traversed for inserting whitespace for tag indentation.
--
-- whitespace is only inserted or changed at places, where it isn't significant,
-- is's not inserted between tags and text containing non whitespace chars.
--
-- whitespace is only inserted or changed at places, where it's not significant.
-- preserving whitespace may be controlled in a document tree
-- by a tag attribute @xml:space@
--
-- allowed values for this attribute are @default | preserve@.
--
-- input is a complete document tree or a document fragment
-- result is the semantically equivalent formatted tree.
--
--
-- see also : 'removeDocWhiteSpace'

indentDoc               :: ArrowXml a => a XmlTree XmlTree
indentDoc :: a XmlTree XmlTree
indentDoc               = 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 XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` LA XmlTree XmlTree
indentRoot )
                            LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
                            ([LA XmlTree XmlTree] -> [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
[a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root [] [LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this] 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
indentRoot 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 :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren)
                          )

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

indentRoot              :: LA XmlTree XmlTree
indentRoot :: LA XmlTree XmlTree
indentRoot              = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren LA XmlTree XmlTree
indentRootChildren
    where
    indentRootChildren :: LA XmlTree XmlTree
indentRootChildren
        = LA XmlTree XmlTree
removeText 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
indentChild 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
insertNL
        where
        removeText :: LA XmlTree XmlTree
removeText      = LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isText
        insertNL :: LA XmlTree XmlTree
insertNL        = LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
"\n"
        indentChild :: LA XmlTree XmlTree
indentChild     = ( LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
                            ( LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                              LA XmlTree XmlTree
-> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>.
                              (Int -> LA XmlTree XmlTree)
-> Bool -> Int -> [XmlTree] -> [XmlTree]
indentTrees (Int -> Int -> LA XmlTree XmlTree
forall a. Int -> Int -> LA a XmlTree
insertIndentation Int
2) Bool
False Int
1
                            )
                            LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`whenNot` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isDTD
                          )

-- ------------------------------------------------------------
--
-- copied from EditFilter and rewritten for arrows
-- to remove dependency to the filter module

indentTrees     :: (Int -> LA XmlTree XmlTree) -> Bool -> Int -> XmlTrees -> XmlTrees
indentTrees :: (Int -> LA XmlTree XmlTree)
-> Bool -> Int -> [XmlTree] -> [XmlTree]
indentTrees Int -> LA XmlTree XmlTree
_ Bool
_ Int
_ []
    = []
indentTrees Int -> LA XmlTree XmlTree
indentFilter Bool
preserveSpace Int
level [XmlTree]
ts
    = LA XmlTree XmlTree -> [XmlTree] -> [XmlTree]
forall b b. LA b b -> [b] -> [b]
runLAs LA XmlTree XmlTree
lsf [XmlTree]
ls
      [XmlTree] -> [XmlTree] -> [XmlTree]
forall a. [a] -> [a] -> [a]
++
      [XmlTree] -> [XmlTree]
indentRest [XmlTree]
rs
      where
      runLAs :: LA b b -> [b] -> [b]
runLAs LA b b
f [b]
l
          = LA Any b -> Any -> [b]
forall a b. LA a b -> a -> [b]
runLA ([b] -> LA Any b
forall (a :: * -> * -> *) c b. ArrowList a => [c] -> a b c
constL [b]
l LA Any b -> LA b b -> LA Any b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA b b
f) Any
forall a. HasCallStack => a
undefined

      ([XmlTree]
ls, [XmlTree]
rs)
          = (XmlTree -> Bool) -> [XmlTree] -> ([XmlTree], [XmlTree])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isElem [XmlTree]
ts

      isSignificant     :: Bool
      isSignificant :: Bool
isSignificant
          = Bool
preserveSpace
            Bool -> Bool -> Bool
||
            (Bool -> Bool
not (Bool -> Bool) -> ([XmlTree] -> Bool) -> [XmlTree] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([XmlTree] -> Bool)
-> ([XmlTree] -> [XmlTree]) -> [XmlTree] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree XmlTree -> [XmlTree] -> [XmlTree]
forall b b. LA b b -> [b] -> [b]
runLAs LA XmlTree XmlTree
isSignificantPart) [XmlTree]
ls

      isSignificantPart :: LA XmlTree XmlTree
      isSignificantPart :: LA XmlTree XmlTree
isSignificantPart
          = [LA XmlTree XmlTree] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA
            [ LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isText LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
neg LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isWhiteSpace
            , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCdata
            , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCharRef
            , LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isEntityRef
            ]

      lsf       :: LA XmlTree XmlTree
      lsf :: LA XmlTree XmlTree
lsf
          | Bool
isSignificant
              = LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
          | Bool
otherwise
              = (LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isWhiteSpace)
                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
>>>
                (Int -> LA XmlTree XmlTree
indentFilter Int
level LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this)

      indentRest        :: XmlTrees -> XmlTrees
      indentRest :: [XmlTree] -> [XmlTree]
indentRest []
          | Bool
isSignificant
              = []
          | Bool
otherwise
              = LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
runLA (Int -> LA XmlTree XmlTree
indentFilter (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) XmlTree
forall a. HasCallStack => a
undefined

      indentRest (XmlTree
t':[XmlTree]
ts')
          = LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
runLA ( ( LA XmlTree XmlTree
indentElem
                      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
lsf
                    )
                    LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
                  ) XmlTree
t'
            [XmlTree] -> [XmlTree] -> [XmlTree]
forall a. [a] -> [a] -> [a]
++
            ( if [XmlTree] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XmlTree]
ts'
              then [XmlTree] -> [XmlTree]
indentRest
              else (Int -> LA XmlTree XmlTree)
-> Bool -> Int -> [XmlTree] -> [XmlTree]
indentTrees Int -> LA XmlTree XmlTree
indentFilter Bool
preserveSpace Int
level
            ) [XmlTree]
ts'
          where
          indentElem :: LA XmlTree XmlTree
indentElem
              = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren ( LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                                  LA XmlTree XmlTree
-> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>.
                                  [XmlTree] -> [XmlTree]
indentChildren
                                )

          xmlSpaceAttrValue     :: String
          xmlSpaceAttrValue :: [Char]
xmlSpaceAttrValue
              = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> (XmlTree -> [[Char]]) -> XmlTree -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree [Char] -> XmlTree -> [[Char]]
forall a b. LA a b -> a -> [b]
runLA ([Char] -> LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"xml:space") (XmlTree -> [Char]) -> XmlTree -> [Char]
forall a b. (a -> b) -> a -> b
$ XmlTree
t'

          preserveSpace'        :: Bool
          preserveSpace' :: Bool
preserveSpace'
              = ( Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
preserveSpace
                  (Maybe Bool -> Bool)
-> ([([Char], Bool)] -> Maybe Bool) -> [([Char], Bool)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  [Char] -> [([Char], Bool)] -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
xmlSpaceAttrValue
                ) [ ([Char]
"preserve", Bool
True)
                  , ([Char]
"default",  Bool
False)
                  ]

          indentChildren        :: XmlTrees -> XmlTrees
          indentChildren :: [XmlTree] -> [XmlTree]
indentChildren [XmlTree]
cs'
              | (XmlTree -> Bool) -> [XmlTree] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isXmlSpaceChar) (Maybe [Char] -> Bool)
-> (XmlTree -> Maybe [Char]) -> XmlTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe [Char]
forall a. XmlNode a => a -> Maybe [Char]
XN.getText) [XmlTree]
cs'
                  = []
              | Bool
otherwise
                  = (Int -> LA XmlTree XmlTree)
-> Bool -> Int -> [XmlTree] -> [XmlTree]
indentTrees Int -> LA XmlTree XmlTree
indentFilter Bool
preserveSpace' (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [XmlTree]
cs'


-- filter for indenting elements

insertIndentation       :: Int -> Int -> LA a XmlTree
insertIndentation :: Int -> Int -> LA a XmlTree
insertIndentation Int
indentWidth Int
level
    = [Char] -> LA a XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt (Char
'\n' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indentWidth) Char
' ')

-- filter for removing all whitespace

insertNothing           :: Int -> LA a XmlTree
insertNothing :: Int -> LA a XmlTree
insertNothing Int
_         = LA a XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none

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

-- |
-- converts a CDATA section into normal text nodes

transfCdata             :: ArrowXml a => a XmlTree XmlTree
transfCdata :: a XmlTree XmlTree
transfCdata             = 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 [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getCdata LA XmlTree [Char] -> LA [Char] 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 [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText) LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCdata

-- |
-- converts CDATA sections in whole document tree into normal text nodes

transfAllCdata          :: ArrowXml a => a XmlTree XmlTree
transfAllCdata :: a XmlTree XmlTree
transfAllCdata          = 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
$ [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall b c.
[IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))]
-> LA (NTree b) (NTree b)
editNTreeA [LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCdata LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> (LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getCdata LA XmlTree [Char] -> LA [Char] 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 [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText)]

-- |
-- converts a character reference to normal text

transfCharRef           :: ArrowXml a => a XmlTree XmlTree
transfCharRef :: a XmlTree XmlTree
transfCharRef           = 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 Int
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
getCharRef LA XmlTree Int -> LA Int 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
>>> (Int -> [Char]) -> LA Int [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ Int
i -> [Int -> Char
forall a. Enum a => Int -> a
toEnum Int
i]) LA Int [Char] -> LA [Char] XmlTree -> LA Int XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText )
                          LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                          LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCharRef

-- |
-- recursively converts all character references to normal text

transfAllCharRef        :: ArrowXml a => a XmlTree XmlTree
transfAllCharRef :: a XmlTree XmlTree
transfAllCharRef        = 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
$ [IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)]
-> LA XmlTree XmlTree
forall b c.
[IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))]
-> LA (NTree b) (NTree b)
editNTreeA [LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isCharRef LA XmlTree XmlTree
-> LA XmlTree XmlTree
-> IfThen (LA XmlTree XmlTree) (LA XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> (LA XmlTree Int
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
getCharRef LA XmlTree Int -> LA Int 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
>>> (Int -> [Char]) -> LA Int [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ Int
i -> [Int -> Char
forall a. Enum a => Int -> a
toEnum Int
i]) LA Int [Char] -> LA [Char] XmlTree -> LA Int XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText)]

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

rememberDTDAttrl        :: ArrowList a => a XmlTree XmlTree
rememberDTDAttrl :: a XmlTree XmlTree
rememberDTDAttrl
    = 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
$
      ( ( [([Char], [Char])] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[([Char], [Char])] -> a XmlTree XmlTree
addDTDAttrl ([([Char], [Char])] -> LA XmlTree XmlTree)
-> LA XmlTree [([Char], [Char])] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< ( LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree XmlTree
-> LA XmlTree [([Char], [Char])] -> LA XmlTree [([Char], [Char])]
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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype LA XmlTree XmlTree
-> LA XmlTree [([Char], [Char])] -> LA XmlTree [([Char], [Char])]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree [([Char], [Char])]
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree [([Char], [Char])]
getDTDAttrl ) )
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
        LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
      )
    where
    addDTDAttrl :: [([Char], [Char])] -> a XmlTree XmlTree
addDTDAttrl [([Char], [Char])]
al
        = [a XmlTree XmlTree] -> a XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => [a b b] -> a b b
seqA ([a XmlTree XmlTree] -> a XmlTree XmlTree)
-> ([([Char], [Char])] -> [a XmlTree XmlTree])
-> [([Char], [Char])]
-> a XmlTree XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> a XmlTree XmlTree)
-> [([Char], [Char])] -> [a XmlTree XmlTree]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> a XmlTree XmlTree)
-> ([Char], [Char]) -> a XmlTree XmlTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> a XmlTree XmlTree
addAttr) ([([Char], [Char])] -> [a XmlTree XmlTree])
-> ([([Char], [Char])] -> [([Char], [Char])])
-> [([Char], [Char])]
-> [a XmlTree XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> ([Char], [Char]))
-> [([Char], [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char]) -> ([Char], [Char]) -> ([Char], [Char])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([Char]
dtdPrefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) ([([Char], [Char])] -> a XmlTree XmlTree)
-> [([Char], [Char])] -> a XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
al

addDefaultDTDecl        :: ArrowList a => a XmlTree XmlTree
addDefaultDTDecl :: a XmlTree XmlTree
addDefaultDTDecl
    = 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
$
      ( [([Char], [Char])] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowDTD a =>
[([Char], [Char])] -> a XmlTree XmlTree
addDTD ([([Char], [Char])] -> LA XmlTree XmlTree)
-> LA XmlTree [([Char], [Char])] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree ([Char], [Char]) -> LA XmlTree [([Char], [Char])]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl LA XmlTree XmlTree
-> LA XmlTree ([Char], [Char]) -> LA XmlTree ([Char], [Char])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getName LA XmlTree [Char]
-> LA XmlTree [Char] -> LA XmlTree ([Char], [Char])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& LA XmlTree XmlTree -> LA XmlTree [Char]
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n [Char]
xshow LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren) LA XmlTree ([Char], [Char])
-> LA ([Char], [Char]) ([Char], [Char])
-> LA XmlTree ([Char], [Char])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA ([Char], [Char]) ([Char], [Char])
forall b. LA ([Char], b) ([Char], b)
hasDtdPrefix) )
    where
    hasDtdPrefix :: LA ([Char], b) ([Char], b)
hasDtdPrefix
        = (([Char], b) -> Bool) -> LA ([Char], b) ([Char], b)
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (([Char], b) -> [Char]
forall a b. (a, b) -> a
fst (([Char], b) -> [Char]) -> ([Char] -> Bool) -> ([Char], b) -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([Char]
dtdPrefix [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
          LA ([Char], b) ([Char], b)
-> LA ([Char], b) ([Char], b) -> LA ([Char], b) ([Char], b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          (([Char], b) -> ([Char], b)) -> LA ([Char], b) ([Char], b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (([Char] -> [Char]) -> ([Char], b) -> ([Char], b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
dtdPrefix)))
    addDTD :: [([Char], [Char])] -> a XmlTree XmlTree
addDTD []
        = a XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
    addDTD [([Char], [Char])]
al
        = a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
          ( [([Char], [Char])] -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowDTD a =>
[([Char], [Char])] -> a n XmlTree -> a n XmlTree
mkDTDDoctype [([Char], [Char])]
al a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
            a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
            [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
"\n"
            a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
            ( a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren 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
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype) )      -- remove old DTD decl
          )

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

hasXmlPi                :: ArrowXml a => a XmlTree XmlTree
hasXmlPi :: a XmlTree XmlTree
hasXmlPi
    = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA
      ( LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi
        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
>>>
        [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
t_xml
      )

-- | add an \<?xml version=\"1.0\"?\> processing instruction
-- if it's not already there

addXmlPi                :: ArrowXml a => a XmlTree XmlTree
addXmlPi :: a XmlTree XmlTree
addXmlPi
    = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA
      ( Int -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
Int -> a (t b) (t b) -> a (t b) (t b)
insertChildrenAt Int
0 ( ( QName -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
QName -> a n XmlTree -> a n XmlTree
mkPi ([Char] -> QName
mkName [Char]
t_xml) LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                               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
>>>
                               [Char] -> [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> a XmlTree XmlTree
addAttr [Char]
a_version [Char]
"1.0"
                             )
                             LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
                             [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
"\n"
                           )
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`whenNot`
        LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
hasXmlPi
      )

-- | add an encoding spec to the \<?xml version=\"1.0\"?\> processing instruction

addXmlPiEncoding        :: ArrowXml a => String -> a XmlTree XmlTree
addXmlPiEncoding :: [Char] -> a XmlTree XmlTree
addXmlPiEncoding [Char]
enc
    = 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 XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren ( [Char] -> [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> a XmlTree XmlTree
addAttr [Char]
a_encoding [Char]
enc
                        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                        ( LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi 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
>>> [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
t_xml )
                      )

-- | add an XHTML strict doctype declaration to a document

addXHtmlDoctypeStrict
  , addXHtmlDoctypeTransitional
  , addXHtmlDoctypeFrameset     :: ArrowXml a => a XmlTree XmlTree

-- | add an XHTML strict doctype declaration to a document

addXHtmlDoctypeStrict :: a XmlTree XmlTree
addXHtmlDoctypeStrict
    = [Char] -> [Char] -> [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> [Char] -> a XmlTree XmlTree
addDoctypeDecl [Char]
"html" [Char]
"-//W3C//DTD XHTML 1.0 Strict//EN" [Char]
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"

-- | add an XHTML transitional doctype declaration to a document

addXHtmlDoctypeTransitional :: a XmlTree XmlTree
addXHtmlDoctypeTransitional
    = [Char] -> [Char] -> [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> [Char] -> a XmlTree XmlTree
addDoctypeDecl [Char]
"html" [Char]
"-//W3C//DTD XHTML 1.0 Transitional//EN" [Char]
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"

-- | add an XHTML frameset doctype declaration to a document

addXHtmlDoctypeFrameset :: a XmlTree XmlTree
addXHtmlDoctypeFrameset
    = [Char] -> [Char] -> [Char] -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> [Char] -> a XmlTree XmlTree
addDoctypeDecl [Char]
"html" [Char]
"-//W3C//DTD XHTML 1.0 Frameset//EN" [Char]
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"

-- | add a doctype declaration to a document
--
-- The arguments are the root element name, the PUBLIC id and the SYSTEM id

addDoctypeDecl  :: ArrowXml a => String -> String -> String -> a XmlTree XmlTree
addDoctypeDecl :: [Char] -> [Char] -> [Char] -> a XmlTree XmlTree
addDoctypeDecl [Char]
rootElem [Char]
public [Char]
system
    = 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 XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
      ( [([Char], [Char])] -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowDTD a =>
[([Char], [Char])] -> a n XmlTree -> a n XmlTree
mkDTDDoctype ( ( if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
public then [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> a
id else ( ([Char]
k_public, [Char]
public) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: ) )
                       ([([Char], [Char])] -> [([Char], [Char])])
-> ([([Char], [Char])] -> [([Char], [Char])])
-> [([Char], [Char])]
-> [([Char], [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       ( if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
system then [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> a
id else ( ([Char]
k_system, [Char]
system) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: ) )
                       ([([Char], [Char])] -> [([Char], [Char])])
-> [([Char], [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$  [ ([Char]
a_name, [Char]
rootElem) ]
                     ) LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
        [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
txt [Char]
"\n"
        LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
        LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
      )

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