content: -- |
  -- XML editing filters
  
  module Text.XML.HXT.DOM.EditFilters
      ( canonicalizeTree
      , canonicalizeAllNodes
      , canonicalizeForXPath
  
      , collapseXText
      , collapseAllXText
  
      , indentDoc
  
      , removeWhiteSpace
      , removeAllWhiteSpace
      , removeDocWhiteSpace
  
      , removeComment
      , removeAllComment
  
      , transfCdata               , transfAllCdata        -- CDATA to text
      , transfCdataEscaped        , transfAllCdataEscaped -- CDATA to text
      , transfCharRef             , transfAllCharRef      -- &#nnn; to text
  
      , escapeXmlDoc
      , escapeXmlText
      , escapeXmlAttrValue
  
      , unparseXmlDoc
      , numberLinesInXmlDoc       , numberLines
      , treeRepOfXmlDoc
      , haskellRepOfXmlDoc
      , addHeadlineToXmlDoc
      , addXmlPiToDoc
      )
  where
  
  import Text.XML.HXT.DOM.XmlTree
  
  import Text.XML.HXT.DOM.Unicode
      ( getOutputEncodingFct)
  
  import Text.XML.HXT.DOM.FormatXmlTree
      ( formatXmlContents )
  
  import Data.Maybe
  
  -- ------------------------------------------------------------
  
  -- |
  -- remove Comments
  
  removeComment           :: XmlFilter
  removeComment           = none `when` isXCmt
  
  -- |
  -- remove all Comments recursively
  
  removeAllComment        :: XmlFilter
  removeAllComment        = processBottomUp removeComment
  
  -- ------------------------------------------------------------
  
  -- |
  -- simple filter for removing whitespace.
  --
  -- no check on sigificant whitespace is done.
  --
  --
  -- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'
  
  removeWhiteSpace        :: XmlFilter
  removeWhiteSpace        = none `when` 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     :: XmlFilter
  removeAllWhiteSpace     = processBottomUp removeWhiteSpace
  
  -- ------------------------------------------------------------
  -- |
  -- converts CDATA sections in whole document tree into normal text nodes
  
  transfAllCdataEscaped   :: XmlFilter
  transfAllCdataEscaped   = processBottomUp transfCdataEscaped
  
  -- |
  -- converts CDATA section in normal text nodes
  
  transfCdataEscaped      :: XmlFilter
  transfCdataEscaped (NTree (XCdata str) _)
      = xtext str
  
  transfCdataEscaped n
      = [n]
  
  
  -- ------------------------------------------------------------
  -- |
  -- converts CDATA sections in whole document tree
  
  transfAllCdata          :: XmlFilter
  transfAllCdata          = processBottomUp transfCdata
  
  -- |
  -- converts CDATA section in normal text sections
  
  transfCdata             :: XmlFilter
  transfCdata (NTree (XCdata str) _)
      = xtext str
  
  transfCdata n
      = [n]
  
  
  -- ------------------------------------------------------------
  -- |
  -- converts character references to normal text
  
  transfCharRef           :: XmlFilter
  transfCharRef (NTree (XCharRef i) _)
      = xtext $ [toEnum i]
  
  transfCharRef n
      = [n]
  
  -- ------------------------------------------------------------
  -- |
  -- recursively converts all character references to normal text
  
  transfAllCharRef        :: XmlFilter
  transfAllCharRef        = processBottomUp transfCharRef
  
  -- ------------------------------------------------------------
  
  -- |
  -- Applies some "Canonical XML" rules to the nodes of a 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.
  --
  --
  -- 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        :: XmlFilter -> XmlFilter
  canonicalizeTree toBeRemoved
      = processChildren (none `when` isXText)
        .>
        processBottomUp canonicalize1Node
        where
        canonicalize1Node :: XmlFilter
        canonicalize1Node
            = (deep isXPi `when` isXDTD)          -- remove DTD parts, except PIs
              .>
              (none `when` toBeRemoved)           -- remove unintersting nodes
              .>
              ( processAttr ( processChildren transfCharRef
                              .>
                              collapseXText
                            ) `when` isXTag)
              .>
              transfCdata                         -- CDATA -> text
              .>
              transfCharRef                       -- Char refs -> text
              .>
              collapseXText                       -- combine text
  
  
  -- |
  -- canonicalize tree and remove comments and \<?xml ... ?> declarations
  --
  -- see 'canonicalizeTree'
  
  canonicalizeAllNodes    :: XmlFilter
  canonicalizeAllNodes
      = canonicalizeTree (isXCmt          -- remove comment
                          +++
                          isPi t_xml      -- remove xml declaration
                         )
  
  -- |
  -- Canonicalize a tree for XPath
  -- Comment nodes are not removed
  --
  -- see 'canonicalizeTree'
  
  canonicalizeForXPath    :: XmlFilter
  canonicalizeForXPath
      = canonicalizeTree (isPi t_xml)
  
  -- ------------------------------------------------------------
  
  -- |
  -- Collects sequences of child XText nodes into one XText node.
  
  collapseXText           :: XmlFilter
  collapseXText n
      = replaceChildren (collapseXText' $ getChildren n) n
      where
      collapseXText' :: XmlSFilter
      collapseXText' ((NTree n1 _) : (NTree n2 _) : zs)
          | isXTextNode n1 && isXTextNode n2
              = collapseXText' $ (xtext (t1 ++ t2)) ++ zs
                where
                t1 = textOfXNode n1
                t2 = textOfXNode n2
  
      collapseXText' (x:xs)
          = x : (collapseXText' xs)
  
      collapseXText' []
          = []
  
  
  -- |
  -- Applies collapseXText recursively.
  --
  --
  -- see also : 'collapseXText'
  
  collapseAllXText        :: XmlFilter
  collapseAllXText        = processBottomUp collapseXText
  
  
  -- ------------------------------------------------------------
  --
  
  -- |
  -- 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.
  -- result the semantically equivalent formatted tree.
  --
  --
  -- see also : 'removeDocWhiteSpace'
  
  indentDoc       :: XmlFilter
  indentDoc
      = modifyChildren (indentRootChildren $$)
        `when`
        isRoot
        where
        indentRootChildren        :: XmlFilter
        indentRootChildren
            = insertNL `o` indentChild `o` removeText
              where
              removeText
                  = none `when` isXText
              insertNL
                  = this +++ txt "\n"
              indentChild
                  = modifyChildren (indentTrees (insertIndentation 2) False 1)
                    `whenNot`
                    isXDTD                -- DTD elements are not indented
  
  -- |
  -- filter for removing all not significant whitespace.
  --
  -- the tree traversed for removing whitespace between tags,
  -- 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     :: XmlFilter
  removeDocWhiteSpace
      =  processChildren processRootElement
        `when`
        isRoot
        where
        processRootElement        :: XmlFilter
        processRootElement
            = removeText .> processChild
              where
              removeText
                  = none `when` isWhiteSpace
              processChild
                  = choice [ isXDTD
                             :-> removeAllWhiteSpace                      -- whitespace in DTD is redundant
                           , this
                             :-> modifyChildren                           -- same strategie as for indentation
                                   (indentTrees insertNothing False 1)
                           ]
  
  indentTrees     :: (Int -> XmlFilter) -> Bool -> Int -> XmlTrees -> XmlTrees
  indentTrees _ _ _ []
      = []
  indentTrees indentFilter preserveSpace level ts
      = (lsf $$ ls) ++ indentRest rs
        where
        (ls, rs)
            = break (satisfies isXTag) ts
  
        isSignificant     :: Bool
        isSignificant
            = preserveSpace
              ||
              any (satisfies isSignificantPart) ls
  
        isSignificantPart :: XmlFilter
        isSignificantPart
            = cat [ isXText `guards` neg isWhiteSpace
                  , isXCdata
                  , isXCharRef
                  , isXEntityRef
                  ]
  
        lsf       :: XmlFilter
        lsf
            | isSignificant
                = this
            | otherwise
                = (none `when` isWhiteSpace)
                  .>
                  (indentFilter level +++ this)
  
        indentRest        :: XmlSFilter
  
        indentRest []
            | isSignificant
                = []
            | otherwise
                = indentFilter (level - 1) (mkXTextTree "")
  
        indentRest (t':ts')
                = ( (modifyChildren indentChildren .> lsf)
                    `when`
                    isXTag
                    $ t'
                  )
                  ++
                  ( if null ts'
                    then indentRest ts'
                    else indentTrees indentFilter preserveSpace level ts'
                  )
                  where
                  xmlSpaceAttrName  = "xml:space"
                  xmlSpaceAttrValue = valueOf xmlSpaceAttrName t'
                  preserveSpace'
                      = fromMaybe preserveSpace
                        .
                        lookup xmlSpaceAttrValue
                        $ [ ("preserve", True)
                          , ("default",  False)
                          ]
                  indentChildren
                      | all (satisfies isWhiteSpace) $ getChildren t'
                          = (none $$)
                      | otherwise
                          = indentTrees indentFilter preserveSpace' (level + 1)
  
  -- filter for indenting tags
  
  insertIndentation       :: Int -> Int -> XmlFilter
  insertIndentation indentWidth level
      = txt ('\n' : replicate (level * indentWidth) ' ')
  
  -- filter for removing all whitespace
  
  insertNothing           :: Int -> XmlFilter
  insertNothing _         = none
  
  -- ------------------------------------------------------------
  
  -- |
  -- escape XmlText,
  -- transform all special XML chars into CharRefs
  
  escapeString    :: (Char -> Bool) -> String -> XmlTrees
  escapeString _isEsc []
      = []
  escapeString isEsc (c:s1)
      | isEsc c
          = mkXCharRefTree (fromEnum c) : escapeString isEsc s1
  escapeString isEsc s
      = mkXTextTree s1 : escapeString isEsc s2
        where
        (s1, s2) = break isEsc s
  
  escapeText              :: (Char -> Bool) -> XmlFilter
  escapeText isEsc (NTree n _)
      | isXTextNode n
          = escapeString isEsc (textOfXNode n)
  
  escapeText isEsc (NTree (XCmt c) _)
      = xcmt (xshow . escapeString isEsc $ c)
  
  escapeText _ t
      = [t]
  
  -- |
  -- convert the special XML chars in a text or comment node
  -- into character references
  --
  -- see also 'escapeXmlDoc'
  
  escapeXmlText           :: XmlFilter
  escapeXmlText           = escapeText (`elem` "<&")      -- no escape for ", ' and > required: XML standard 2.4
  
  -- |
  -- convert the special XML chars in an attribute value into
  -- charachter references. Not only the XML specials but also \\n, \\r and \\t are converted
  --
  -- see also: 'escapeXmlDoc', 'escapeXmlText'
  
  escapeXmlAttrValue      :: XmlFilter
  escapeXmlAttrValue      = escapeText (`elem` "<>\"\'&\n\r\t")
  
  -- |
  -- convert the special XML chars \", \<, \>, & and \' in a document to char references,
  -- attribute values are converted with 'escapeXmlAttrValue'
  --
  -- see also: 'escapeXmlText', 'escapeXmlAttrValue'
  
  escapeXmlDoc            :: XmlFilter
  escapeXmlDoc
      = choice [ isXTag  :-> (processChildren (escapeXmlDoc)
                              .>
                              processAttr escVal
                             )
               , isXText :-> escapeXmlText
               -- , isXCmt  :-> escapeXmlText -- no escape in comments reqired: XML standard 2.4
               , isXDTD  :-> processTopDown escDTD
               , this    :-> this
               ]
        where
        escVal   = processChildren escapeXmlAttrValue
        escDTD   = escVal `when` (isEntity +++ isParameterEntity)
  
  -- ------------------------------------------------------------
  
  -- |
  -- convert a document tree into an output string representation
  -- with respect to the output encoding.
  --
  -- The children of the document root are stubstituted by
  -- a single text node for the text representation of the document.
  --
  -- Encoding of the document is performed with respect
  -- to the @output-encoding@ attribute in the root node, or if not present,
  -- of the @encoding@ attribute for the original input encoding.
  -- If the encoding is not specified or not supported, UTF-8 is taken.
  
  unparseXmlDoc   :: XmlFilter
  unparseXmlDoc n
      = modifyChildren ((modifyText encFct $$) . xmlTreesToText) n
      where
      encFct = fromMaybe id (getOutputEncodingFct (encSpec n))
  
  encSpec :: XmlTree -> String
  encSpec n
      = head . filter (not . null)
        $ [ valueOf a_output_encoding n
          , valueOf a_encoding n
          , utf8
          ]
  
  -- ------------------------------------------------------------
  --
  -- add or modify a XML directive for a document
  -- for specifying the encoding scheme
  
  addXmlPiToDoc           :: XmlFilter
  addXmlPiToDoc n
      = ( modifyChildren addX                             -- add <?xml ...>, if neccessary
          `whenNot`
          (getChildren .> isPi t_xml)
        )
        .>
        processChildren ( addAttr a_encoding enc          -- set or replace encoding="..."
                          `when`
                          isPi t_xml
                        )
        $ n
      where
      enc = encSpec n
      addX cs = mkXmlDeclTree (xattr a_version "1.0") : xtext "\n" ++ cs
  
  -- ------------------------------------------------------------
  
  -- |
  -- 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     :: XmlFilter
  numberLinesInXmlDoc
      = modifyChildren ((modifyText numberLines $$) . xmlTreesToText)
  
  numberLines     :: String -> String
  numberLines str
      = concat $
        zipWith (\ n l -> lineNr n ++ l ++ "\n") [1..] (lines str)
        where
        lineNr    :: Int -> String
        lineNr n  = (reverse (take 6(reverse (show n) ++ replicate 6 ' '))) ++ "  "
  
  -- ------------------------------------------------------------
  
  -- |
  -- convert a document into a text representation in tree form.
  --
  -- Useful for debugging and trace output.
  -- see also : 'haskellRepOfXmlDoc', 'numberLinesInXmlDoc'
  
  treeRepOfXmlDoc         :: XmlFilter
  treeRepOfXmlDoc
      = rootTag [getAttrl] [formatXmlContents]
  
  -- |
  -- convert a document into a Haskell representation (with show).
  --
  -- Useful for debugging and trace output.
  -- see also : 'treeRepOfXmlDoc', 'numberLinesInXmlDoc'
  
  haskellRepOfXmlDoc      :: XmlFilter
  haskellRepOfXmlDoc n
      = rootTag [getAttrl] [txt $ show n] n
  
  -- ------------------------------------------------------------
  
  addHeadlineToXmlDoc     :: XmlFilter
  addHeadlineToXmlDoc n
      = replaceChildren (xtext title ++ getChildren n ++ xtext "\n") n
        where
        headline  = "content of: " ++ valueOf a_source n
        underline = map (\_ -> '=') headline
        title     = "\n" ++ headline ++ "\n" ++ underline ++ "\n\n"
  
  -- ------------------------------------------------------------
  