hxt-9.3.1.14: src/Text/XML/HXT/Arrow/Edit.hs
-- ------------------------------------------------------------
{- |
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' toBeRemoved
= ( processChildren
( (none `when` (isText <+> isXmlPi)) -- remove XML PI and all text around XML root element
>>>
(deep isPi `when` isDTD) -- remove DTD parts, except PIs whithin DTD
)
`when` isRoot
)
>>>
canonicalizeNodes toBeRemoved
canonicalizeNodes :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeNodes toBeRemoved
= editNTreeA $
[ toBeRemoved :-> none
, ( isElem >>> getAttrl >>> getChildren >>> isCharRef ) -- canonicalize attribute list
:-> ( processAttrl
( processChildren transfCharRef
>>>
collapseXText' -- combine text in attribute values
)
>>>
( collapseXText' -- and combine text in content
`when`
(getChildren >>. has2XText)
)
)
, ( isElem >>> (getChildren >>. has2XText) )
:-> collapseXText' -- combine text in content
, isCharRef :-> ( getCharRef
>>>
arr (\ i -> [toEnum i])
>>>
mkText
)
, isCdata :-> ( getCdata
>>>
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 = fromLA $
canonicalizeTree' 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 = fromLA $ canonicalizeTree' 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 = fromLA $
canonicalizeNodes none
{-# INLINE canonicalizeContents #-}
-- ------------------------------------------------------------
has2XText :: XmlTrees -> XmlTrees
has2XText ts0@(t1 : ts1@(t2 : ts2))
| XN.isText t1 = if XN.isText t2
then ts0
else has2XText ts2
| otherwise = has2XText ts1
has2XText _ = []
collapseXText' :: LA XmlTree XmlTree
collapseXText'
= replaceChildren ( listA getChildren >>> arrL (foldr mergeText' []) )
where
mergeText' :: XmlTree -> XmlTrees -> XmlTrees
mergeText' t1 (t2 : ts2)
| XN.isText t1 && XN.isText t2
= let
s1 = fromJust . XN.getText $ t1
s2 = fromJust . XN.getText $ t2
t = XN.mkText (s1 ++ s2)
in
t : ts2
mergeText' t1 ts
= t1 : 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 = fromLA collapseXText'
-- |
-- Applies collapseXText recursively.
--
--
-- see also : 'collapseXText'
collapseAllXText :: ArrowList a => a XmlTree XmlTree
collapseAllXText = fromLA $ processBottomUp 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 f = f >. (uncurry XS.xshow'' escapeXmlRefs)
-- ------------------------------------------------------------
-- |
-- escape XmlText,
-- transform all special XML chars into char- or entity- refs
type EntityRefTable = M.Map Int String
xmlEntityRefTable
, xhtmlEntityRefTable :: EntityRefTable
xmlEntityRefTable = buildEntityRefTable $ xmlEntities
xhtmlEntityRefTable = buildEntityRefTable $ xhtmlEntities
buildEntityRefTable :: [(String, Int)] -> EntityRefTable
buildEntityRefTable = M.fromList . map (\ (x,y) -> (y,x) )
type EntitySubstTable = M.Map String String
xhtmlEntitySubstTable :: EntitySubstTable
xhtmlEntitySubstTable = M.fromList . map (second $ (:[]) . toEnum) $ xhtmlEntities
-- ------------------------------------------------------------
substXHTMLEntityRef :: LA XmlTree XmlTree
substXHTMLEntityRef
= ( getEntityRef
>>>
arrL subst
>>>
mkText
)
`orElse` this
where
subst name
= maybe [] (:[]) $ M.lookup name xhtmlEntitySubstTable
substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree
substAllXHTMLEntityRefs
= fromLA $
processBottomUp substXHTMLEntityRef
-- ------------------------------------------------------------
escapeXmlRefs :: (Char -> String -> String, Char -> String -> String)
escapeXmlRefs = (cquote, aquote)
where
cquote c
| c `elem` "<&" = ('&' :)
. ((lookupRef c xmlEntityRefTable) ++)
. (';' :)
| otherwise = (c :)
aquote c
| c `elem` "<>\"\'&\n\r\t"
= ('&' :)
. ((lookupRef c xmlEntityRefTable) ++)
. (';' :)
| otherwise = (c :)
escapeHtmlRefs :: (Char -> String -> String, Char -> String -> String)
escapeHtmlRefs = (cquote, aquote)
where
cquote c
| isHtmlTextEsc c
= ('&' :)
. ((lookupRef c xhtmlEntityRefTable) ++)
. (';' :)
| otherwise = (c :)
aquote c
| isHtmlAttrEsc c
= ('&' :)
. ((lookupRef c xhtmlEntityRefTable) ++)
. (';' :)
| otherwise = (c :)
isHtmlTextEsc c = c >= toEnum(128) || ( c `elem` "<&" )
isHtmlAttrEsc c = c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" )
lookupRef :: Char -> EntityRefTable -> String
lookupRef c = fromMaybe ('#' : show (fromEnum c))
. M.lookup (fromEnum c)
{-# INLINE lookupRef #-}
-- ------------------------------------------------------------
preventEmptyElements :: ArrowList a => [String] -> Bool -> a XmlTree XmlTree
preventEmptyElements ns isHtml
= fromLA $
editNTreeA [ ( isElem
>>>
isNoneEmpty
>>>
neg getChildren
)
:-> replaceChildren (txt "")
]
where
isNoneEmpty
| not (null ns) = hasNameWith (localPart >>> (`elem` ns))
| isHtml = hasNameWith (localPart >>> (`notElem` emptyHtmlTags))
| otherwise = 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
= fromLA $
root [getAttrl] [show ^>> 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
= fromLA $
processChildren (changeText numberLines)
where
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 :: ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc
= fromLA $
root [getAttrl] [formatXmlTree ^>> mkText]
addHeadlineToXmlDoc :: ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc
= fromLA $ ( addTitle $< (getAttrValue a_source >>^ formatTitle) )
where
addTitle str
= replaceChildren ( txt str <+> getChildren <+> txt "\n" )
formatTitle str
= "\n" ++ headline ++ "\n" ++ underline ++ "\n\n"
where
headline = "content of: " ++ str
underline = map (const '=') headline
-- ------------------------------------------------------------
-- |
-- remove a Comment node
removeComment :: ArrowXml a => a XmlTree XmlTree
removeComment = none `when` isCmt
-- |
-- remove all comments in a tree recursively
removeAllComment :: ArrowXml a => a XmlTree XmlTree
removeAllComment = fromLA $ editNTreeA [isCmt :-> 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 = fromLA $ 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 :: ArrowXml a => a XmlTree XmlTree
removeAllWhiteSpace = fromLA $ editNTreeA [isWhiteSpace :-> 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 = fromLA $ removeRootWhiteSpace
removeRootWhiteSpace :: LA XmlTree XmlTree
removeRootWhiteSpace
= processChildren processRootElement
`when`
isRoot
where
processRootElement :: LA XmlTree XmlTree
processRootElement
= removeWhiteSpace >>> processChild
where
processChild
= choiceA [ isDTD
:-> removeAllWhiteSpace -- whitespace in DTD is redundant
, this
:-> replaceChildren ( getChildren
>>. indentTrees insertNothing False 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 = fromLA $
( ( isRoot `guards` indentRoot )
`orElse`
(root [] [this] >>> indentRoot >>> getChildren)
)
-- ------------------------------------------------------------
indentRoot :: LA XmlTree XmlTree
indentRoot = processChildren indentRootChildren
where
indentRootChildren
= removeText >>> indentChild >>> insertNL
where
removeText = none `when` isText
insertNL = this <+> txt "\n"
indentChild = ( replaceChildren
( getChildren
>>.
indentTrees (insertIndentation 2) False 1
)
`whenNot` 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 _ _ _ []
= []
indentTrees indentFilter preserveSpace level ts
= runLAs lsf ls
++
indentRest rs
where
runLAs f l
= runLA (constL l >>> f) undefined
(ls, rs)
= break XN.isElem ts
isSignificant :: Bool
isSignificant
= preserveSpace
||
(not . null . runLAs isSignificantPart) ls
isSignificantPart :: LA XmlTree XmlTree
isSignificantPart
= catA
[ isText `guards` neg isWhiteSpace
, isCdata
, isCharRef
, isEntityRef
]
lsf :: LA XmlTree XmlTree
lsf
| isSignificant
= this
| otherwise
= (none `when` isWhiteSpace)
>>>
(indentFilter level <+> this)
indentRest :: XmlTrees -> XmlTrees
indentRest []
| isSignificant
= []
| otherwise
= runLA (indentFilter (level - 1)) undefined
indentRest (t':ts')
= runLA ( ( indentElem
>>>
lsf
)
`when` isElem
) t'
++
( if null ts'
then indentRest
else indentTrees indentFilter preserveSpace level
) ts'
where
indentElem
= replaceChildren ( getChildren
>>.
indentChildren
)
xmlSpaceAttrValue :: String
xmlSpaceAttrValue
= concat . runLA (getAttrValue "xml:space") $ t'
preserveSpace' :: Bool
preserveSpace'
= ( fromMaybe preserveSpace
.
lookup xmlSpaceAttrValue
) [ ("preserve", True)
, ("default", False)
]
indentChildren :: XmlTrees -> XmlTrees
indentChildren cs'
| all (maybe False (all isXmlSpaceChar) . XN.getText) cs'
= []
| otherwise
= indentTrees indentFilter preserveSpace' (level + 1) cs'
-- filter for indenting elements
insertIndentation :: Int -> Int -> LA a XmlTree
insertIndentation indentWidth level
= txt ('\n' : replicate (level * indentWidth) ' ')
-- filter for removing all whitespace
insertNothing :: Int -> LA a XmlTree
insertNothing _ = none
-- ------------------------------------------------------------
-- |
-- converts a CDATA section into normal text nodes
transfCdata :: ArrowXml a => a XmlTree XmlTree
transfCdata = fromLA $
(getCdata >>> mkText) `when` isCdata
-- |
-- converts CDATA sections in whole document tree into normal text nodes
transfAllCdata :: ArrowXml a => a XmlTree XmlTree
transfAllCdata = fromLA $ editNTreeA [isCdata :-> (getCdata >>> mkText)]
-- |
-- converts a character reference to normal text
transfCharRef :: ArrowXml a => a XmlTree XmlTree
transfCharRef = fromLA $
( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )
`when`
isCharRef
-- |
-- recursively converts all character references to normal text
transfAllCharRef :: ArrowXml a => a XmlTree XmlTree
transfAllCharRef = fromLA $ editNTreeA [isCharRef :-> (getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText)]
-- ------------------------------------------------------------
rememberDTDAttrl :: ArrowList a => a XmlTree XmlTree
rememberDTDAttrl
= fromLA $
( ( addDTDAttrl $< ( getChildren >>> isDTDDoctype >>> getDTDAttrl ) )
`orElse`
this
)
where
addDTDAttrl al
= seqA . map (uncurry addAttr) . map (first (dtdPrefix ++)) $ al
addDefaultDTDecl :: ArrowList a => a XmlTree XmlTree
addDefaultDTDecl
= fromLA $
( addDTD $< listA (getAttrl >>> (getName &&& xshow getChildren) >>> hasDtdPrefix) )
where
hasDtdPrefix
= isA (fst >>> (dtdPrefix `isPrefixOf`))
>>>
arr (first (drop (length dtdPrefix)))
addDTD []
= this
addDTD al
= replaceChildren
( mkDTDDoctype al none
<+>
txt "\n"
<+>
( getChildren >>> (none `when` isDTDDoctype) ) -- remove old DTD decl
)
-- ------------------------------------------------------------
hasXmlPi :: ArrowXml a => a XmlTree XmlTree
hasXmlPi
= fromLA
( getChildren
>>>
isPi
>>>
hasName t_xml
)
-- | add an \<?xml version=\"1.0\"?\> processing instruction
-- if it's not already there
addXmlPi :: ArrowXml a => a XmlTree XmlTree
addXmlPi
= fromLA
( insertChildrenAt 0 ( ( mkPi (mkName t_xml) none
>>>
addAttr a_version "1.0"
)
<+>
txt "\n"
)
`whenNot`
hasXmlPi
)
-- | add an encoding spec to the \<?xml version=\"1.0\"?\> processing instruction
addXmlPiEncoding :: ArrowXml a => String -> a XmlTree XmlTree
addXmlPiEncoding enc
= fromLA $
processChildren ( addAttr a_encoding enc
`when`
( isPi >>> hasName 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
= addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"
-- | add an XHTML transitional doctype declaration to a document
addXHtmlDoctypeTransitional
= addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"
-- | add an XHTML frameset doctype declaration to a document
addXHtmlDoctypeFrameset
= addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Frameset//EN" "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 rootElem public system
= fromLA $
replaceChildren
( mkDTDDoctype ( ( if null public then id else ( (k_public, public) : ) )
.
( if null system then id else ( (k_system, system) : ) )
$ [ (a_name, rootElem) ]
) none
<+>
txt "\n"
<+>
getChildren
)
-- ------------------------------------------------------------