hxt-8.4.0: src/Text/XML/HXT/Arrow/WriteDocument.hs
-- ------------------------------------------------------------
{- |
Module : Text.XML.HXT.Arrow.WriteDocument
Copyright : Copyright (C) 2005-9 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : experimental
Portability: portable
Compound arrow for writing XML documents
-}
-- ------------------------------------------------------------
module Text.XML.HXT.Arrow.WriteDocument
( writeDocument
, writeDocumentToString
, prepareContents
)
where
import Control.Arrow -- arrow classes
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.Arrow.Edit ( escapeHtmlDoc
, escapeXmlDoc
, haskellRepOfXmlDoc
, indentDoc
, addDefaultDTDecl
, preventEmptyElements
, removeDocWhiteSpace
, treeRepOfXmlDoc
)
import Text.XML.HXT.Arrow.DocumentOutput ( putXmlDocument
, encodeDocument
, encodeDocument'
)
-- ------------------------------------------------------------
{- |
the main filter for writing documents
this filter can be configured by an option list like 'Text.XML.HXT.Arrow.ReadDocument.readDocument'
usage: @ writeDocument optionList destination @
if @ destination @ is the empty string or \"-\", stdout is used as output device
available options are
* 'a_indent' : indent document for readability, (default: no indentation)
- 'a_remove_whitespace' : remove all redundant whitespace for shorten text (default: no removal)
- 'a_output_encoding' : encoding of document, default is 'a_encoding' or 'utf8'
- 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary
add XML processing instruction
and encode document with respect to 'a_output_encoding',
if explicitly switched of, the plain text is issued, this is useful
for non XML output, e.g. generated Haskell code, LaTex, Java, ...
- 'a_output_html' : issue XHTML: quote alle XML chars, use HTML entity refs or char refs for none ASCII chars
- 'a_no_empty_elements' : do not write the short form \<name .../\> for empty elements. When 'a_output_html' is set,
the always empty HTML elements are still written in short form, but not the others, as e.g. the script element.
Empty script elements, like \<script href=\"...\"/\>, are always a problem for firefox and others.
When XML output is generated with this option, all empty elements are written in the long form.
- 'a_no_empty_elem_for' : do not generate empty elements for the element names given in the comma separated list of this option value.
This option overwrites the above described 'a_no_empty_elements' option
- 'a_add_default_dtd' : if the document to be written was build by reading another document containing a Document Type Declaration,
this DTD is inserted into the output document (default: no insert)
- 'a_no_xml_pi' : suppress generation of \<?xml ... ?\> processing instruction
- 'a_show_tree' : show tree representation of document (for debugging)
- 'a_show_haskell' : show Haskell representaion of document (for debugging)
a minimal main program for copying a document
has the following structure:
> module Main
> where
>
> import Text.XML.HXT.Arrow
>
> main :: IO ()
> main
> = do
> runX ( readDocument [] "hello.xml"
> >>>
> writeDocument [] "bye.xml"
> )
> return ()
an example for copying a document to standard output with tracing and evaluation of
error code is:
> module Main
> where
>
> import Text.XML.HXT.Arrow
> import System.Exit
>
> main :: IO ()
> main
> = do
> [rc] <- runX ( readDocument [ (a_trace, "1")
> ] "hello.xml"
> >>>
> writeDocument [ (a_output_encoding, isoLatin1)
> ] "-" -- output to stdout
> >>>
> getErrStatus
> )
> exitWith ( if rc >= c_err
> then ExitFailure 1
> else ExitSuccess
> )
-}
writeDocument :: Attributes -> String -> IOStateArrow s XmlTree XmlTree
writeDocument userOptions dst
= perform ( traceMsg 1 ("writeDocument: destination is " ++ show dst)
>>>
prepareContents userOptions encodeDocument
>>>
putXmlDocument textMode dst
>>>
traceMsg 1 "writeDocument: finished"
)
`when`
documentStatusOk
where
textMode = optionIsSet a_text_mode userOptions
-- ------------------------------------------------------------
-- |
-- Convert a document into a string. Formating is done the same way
-- and with the same options as in 'writeDocument'. Default output encoding is
-- no encoding, that means the result is a normal unicode encode haskell string.
-- The default may be overwritten with the 'Text.XML.HXT.XmlKeywords.a_output_encoding' option.
-- The XML PI can be suppressed by the 'Text.XML.HXT.XmlKeywords.a_no_xml_pi' option.
--
-- This arrow fails, when the encoding scheme is not supported.
-- The arrow is pure, it does not run in the IO monad.
-- The XML PI is suppressed, if not explicitly turned on with an
-- option @ (a_no_xml_pi, v_0) @
writeDocumentToString :: ArrowXml a => Attributes -> a XmlTree String
writeDocumentToString userOptions
= prepareContents ( addEntries
userOptions
[ (a_output_encoding, unicodeString)
, (a_no_xml_pi, v_1)
]
) encodeDocument'
>>>
xshow getChildren
-- ------------------------------------------------------------
-- |
-- indent and format output
prepareContents :: ArrowXml a => Attributes -> (Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree
prepareContents userOptions encodeDoc
= indent
>>>
addDtd
>>>
format
where
formatEmptyElems
| not (null noEmptyElemFor) = preventEmptyElements noEmptyElemFor
| hasOption a_no_empty_elements
||
hasOption a_output_xhtml = preventEmptyElements []
| otherwise = const this
addDtd
| hasOption a_add_default_dtd = addDefaultDTDecl
| otherwise = this
indent
| hasOption a_indent = indentDoc -- document indentation
| hasOption a_remove_whitespace = removeDocWhiteSpace -- remove all whitespace between tags
| otherwise = this
format
| hasOption a_show_tree = treeRepOfXmlDoc
| hasOption a_show_haskell = haskellRepOfXmlDoc
| hasOption a_output_html = formatEmptyElems True
>>>
escapeHtmlDoc -- escape al XML and HTML chars >= 128
>>>
encodeDoc -- convert doc into text with respect to output encoding with ASCII as default
suppressXmlPi ( lookupDef usAscii a_output_encoding options )
| hasOption a_output_xml = formatEmptyElems (hasOption a_output_xhtml)
>>>
escapeXmlDoc -- escape lt, gt, amp, quot,
>>>
encodeDoc -- convert doc into text with respect to output encoding
suppressXmlPi ( lookupDef "" a_output_encoding options )
| otherwise = this
suppressXmlPi -- remove <?xml ... ?> when set
= hasOption a_no_xml_pi
noEmptyElemFor
= words
. map (\ c -> if c == ',' then ' ' else c)
. lookup1 a_no_empty_elem_for
$ options
hasOption n
= optionIsSet n options
options = addEntries
userOptions
[ ( a_indent, v_0 )
, ( a_remove_whitespace, v_0 )
, ( a_output_xml, v_1 )
, ( a_show_tree, v_0 )
, ( a_show_haskell, v_0 )
, ( a_output_html, v_0 )
, ( a_output_xhtml, v_0 )
, ( a_no_xml_pi, v_0 )
, ( a_no_empty_elements, v_0 )
, ( a_no_empty_elem_for, "" )
, ( a_add_default_dtd, v_0 )
]
-- ------------------------------------------------------------