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

{- |
   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
    , 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.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow
                                                ( initialSysState
                                                )
import Text.XML.HXT.Arrow.Edit                  ( 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

for available options see 'Text.XML.HXT.Arrow.XmlState.SystemConfig'


- @withOutputXML@ :
 (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary
                   add XML processing instruction
                   and encode document with respect to output encoding,

- @withOutputHTML@ :
 issue HTML: translate all special XML chars and all HTML chars with a corresponding entity reference
 into entity references. Do not generate empty elements, e.g. @<script .../>@ for HTML elements, that are allowed
 to contain a none empty body. Result is for the example is @<script ...></script>@.
 The short form introduces trouble in various browsers.

- @withOutputXHTML@ :
 same as @withOutputHTML@, but all none ASCII chars are substituted by char references.

- @withOutputPLAIN@ :
 Do not substitute any chars. This is useful when generating something else than XML/HTML, e.g. Haskell source code.

- @withXmlPi yes/no@ :
 Add a @<?xml version=... encoding=... ?>@ processing instruction to the beginning of the document.
 Default is yes.

- @withAddDefaultDTD@ :
  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)

- @withShowTree yes/no@ :
  show DOM tree representation of document (for debugging)

- @withShowHaskell yes/no@ :
  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.Core
>
> main        :: IO ()
> main
>     = do
>       runX ( readDocument  [] "hello.xml"
>              >>>
>              writeDocument [] "bye.xml"
>            )
>       return ()

an example for copying a document from the web to standard output with global trace level 1, input trace level 2,
output encoding isoLatin1,
and evaluation of
error code is:

> module Main
> where
>
> import Text.XML.HXT.Core
> import Text.XML.HXT.Curl
> -- or
> -- import Text.XML.HXT.HTTP
> import System.Exit
>
> main        :: IO ()
> main
>     = do
>       [rc] <- runX
>               ( configSysVars [ withTrace 1          -- set the defaults for all read-,
>                               , withCurl []          -- write- and other operations
>                                 -- or withHTTP []
>                               ]
>                 >>>
>                 readDocument  [ withTrace     2      -- use these additional
>                               , withParseHTML yes    -- options only for this read
>                               ]
>                               "http://www.haskell.org/"
>                 >>>
>                 writeDocument [ withOutputEncoding isoLatin1
>                               ]
>                               ""                     -- output to stdout
>                 >>>
>                 getErrStatus
>               )
>       exitWith ( if rc >= c_err
>                  then ExitFailure 1
>                  else ExitSuccess
>                )
-}

writeDocument           :: SysConfigList -> String -> IOStateArrow s XmlTree XmlTree
writeDocument :: forall s. SysConfigList -> String -> IOStateArrow s XmlTree XmlTree
writeDocument SysConfigList
config String
dst
    = IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall s a b. IOStateArrow s a b -> IOStateArrow s a b
localSysEnv
      (IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree)
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
      SysConfigList -> IOStateArrow s XmlTree XmlTree
forall s c. SysConfigList -> IOStateArrow s c c
configSysVars SysConfigList
config
      IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall b c. IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( ((Bool -> String -> IOStateArrow s XmlTree XmlTree)
-> String -> Bool -> IOStateArrow s XmlTree XmlTree
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> String -> IOStateArrow s XmlTree XmlTree
forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
writeDocument') String
dst (Bool -> IOStateArrow s XmlTree XmlTree)
-> IOSLA (XIOState s) XmlTree Bool
-> IOStateArrow s XmlTree XmlTree
forall c b d.
(c -> IOSLA (XIOState s) b d)
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< Selector XIOSysState Bool -> IOSLA (XIOState s) XmlTree Bool
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState Bool
theTextMode )

writeDocument'          :: Bool -> String -> IOStateArrow s XmlTree XmlTree
writeDocument' :: forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
writeDocument' Bool
textMode String
dst
    = ( Int -> String -> IOStateArrow s XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
1 (String
"writeDocument: destination is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
dst)
        IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        ( ((XIOSysState
 -> (Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree)
 -> IOStateArrow s XmlTree XmlTree)
-> (Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree)
-> XIOSysState
-> IOStateArrow s XmlTree XmlTree
forall a b c. (a -> b -> c) -> b -> a -> c
flip XIOSysState
-> (Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree)
-> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
XIOSysState
-> (Bool -> Bool -> String -> a XmlTree XmlTree)
-> a XmlTree XmlTree
prepareContents) Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
forall s. Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
encodeDocument (XIOSysState -> IOStateArrow s XmlTree XmlTree)
-> IOSLA (XIOState s) XmlTree XIOSysState
-> IOStateArrow s XmlTree XmlTree
forall c b d.
(c -> IOSLA (XIOState s) b d)
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< Selector XIOSysState XIOSysState
-> IOSLA (XIOState s) XmlTree XIOSysState
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState XIOSysState
forall s. Selector s s
idS )
        IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        String -> IOStateArrow s XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
traceDoc String
"document after encoding"
        IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        Bool -> String -> IOStateArrow s XmlTree XmlTree
forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
textMode String
dst
        IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s 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 -> String -> IOStateArrow s XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
1 String
"writeDocument: finished"
      )
      IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall b c.
IOSLA (XIOState s) b b
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
      IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
documentStatusOk

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

-- |
-- 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.Arrow.XmlState.SystemConfig.withOutputEncoding' 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 => SysConfigList  -> a XmlTree String
writeDocumentToString :: forall (a :: * -> * -> *).
ArrowXml a =>
SysConfigList -> a XmlTree String
writeDocumentToString SysConfigList
config
    = XIOSysState
-> (Bool -> Bool -> String -> a XmlTree XmlTree)
-> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
XIOSysState
-> (Bool -> Bool -> String -> a XmlTree XmlTree)
-> a XmlTree XmlTree
prepareContents ( ((XIOSysState -> XIOSysState)
 -> (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState)
-> (XIOSysState -> XIOSysState)
-> SysConfigList
-> XIOSysState
-> XIOSysState
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (XIOSysState -> XIOSysState)
-> (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) XIOSysState -> XIOSysState
forall a. a -> a
id (String -> XIOSysState -> XIOSysState
withOutputEncoding String
unicodeString (XIOSysState -> XIOSysState) -> SysConfigList -> SysConfigList
forall a. a -> [a] -> [a]
:
                                        Bool -> XIOSysState -> XIOSysState
withXmlPi          Bool
no            (XIOSysState -> XIOSysState) -> SysConfigList -> SysConfigList
forall a. a -> [a] -> [a]
:
                                        SysConfigList
config
                                       )
                        (XIOSysState -> XIOSysState) -> XIOSysState -> XIOSysState
forall a b. (a -> b) -> a -> b
$ XIOSysState
initialSysState
                      ) Bool -> Bool -> String -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument'
      a XmlTree XmlTree -> a XmlTree String -> a XmlTree String
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 -> a XmlTree String
forall n. a n XmlTree -> a n String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow a XmlTree XmlTree
forall (t :: * -> *) b. Tree t => a (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren

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

-- |
-- indent and format output

prepareContents :: ArrowXml a => XIOSysState -> (Bool -> Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree
prepareContents :: forall (a :: * -> * -> *).
ArrowXml a =>
XIOSysState
-> (Bool -> Bool -> String -> a XmlTree XmlTree)
-> a XmlTree XmlTree
prepareContents XIOSysState
config Bool -> Bool -> String -> a XmlTree XmlTree
encodeDoc
    = a XmlTree XmlTree
indent
      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
addDtd
      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
format
    where
    indent' :: Bool
indent'      = Selector XIOSysState Bool -> XIOSysState -> Bool
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Bool
theIndent      XIOSysState
config
    removeWS' :: Bool
removeWS'    = Selector XIOSysState Bool -> XIOSysState -> Bool
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Bool
theRemoveWS    XIOSysState
config
    showTree' :: Bool
showTree'    = Selector XIOSysState Bool -> XIOSysState -> Bool
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Bool
theShowTree    XIOSysState
config
    showHaskell' :: Bool
showHaskell' = Selector XIOSysState Bool -> XIOSysState -> Bool
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Bool
theShowHaskell XIOSysState
config
    outHtml' :: Bool
outHtml'     = Selector XIOSysState XIOXoutConfig -> XIOSysState -> XIOXoutConfig
forall s a. Selector s a -> s -> a
getS Selector XIOSysState XIOXoutConfig
theOutputFmt   XIOSysState
config XIOXoutConfig -> XIOXoutConfig -> Bool
forall a. Eq a => a -> a -> Bool
==  XIOXoutConfig
HTMLoutput
    outXhtml' :: Bool
outXhtml'    = Selector XIOSysState XIOXoutConfig -> XIOSysState -> XIOXoutConfig
forall s a. Selector s a -> s -> a
getS Selector XIOSysState XIOXoutConfig
theOutputFmt   XIOSysState
config XIOXoutConfig -> XIOXoutConfig -> Bool
forall a. Eq a => a -> a -> Bool
== XIOXoutConfig
XHTMLoutput
    outXml' :: Bool
outXml'      = Selector XIOSysState XIOXoutConfig -> XIOSysState -> XIOXoutConfig
forall s a. Selector s a -> s -> a
getS Selector XIOSysState XIOXoutConfig
theOutputFmt   XIOSysState
config XIOXoutConfig -> XIOXoutConfig -> Bool
forall a. Eq a => a -> a -> Bool
==   XIOXoutConfig
XMLoutput
    noPi' :: Bool
noPi'        = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Selector XIOSysState Bool -> XIOSysState -> Bool
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Bool
theXmlPi       XIOSysState
config
    noEEsFor' :: [String]
noEEsFor'    = Selector XIOSysState [String] -> XIOSysState -> [String]
forall s a. Selector s a -> s -> a
getS Selector XIOSysState [String]
theNoEmptyElemFor  XIOSysState
config
    addDDTD' :: Bool
addDDTD'     = Selector XIOSysState Bool -> XIOSysState -> Bool
forall s a. Selector s a -> s -> a
getS Selector XIOSysState Bool
theAddDefaultDTD   XIOSysState
config
    outEnc' :: String
outEnc'      = Selector XIOSysState String -> XIOSysState -> String
forall s a. Selector s a -> s -> a
getS Selector XIOSysState String
theOutputEncoding  XIOSysState
config

    addDtd :: a XmlTree XmlTree
addDtd
        | Bool
addDDTD'                      = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
addDefaultDTDecl
        | Bool
otherwise                     = a XmlTree XmlTree
forall b. a b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
    indent :: a XmlTree XmlTree
indent
        | Bool
indent'                       = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc                     -- document indentation
        | Bool
removeWS'                     = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
removeDocWhiteSpace           -- remove all whitespace between tags
        | Bool
otherwise                     = a XmlTree XmlTree
forall b. a b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this

    format :: a XmlTree XmlTree
format
        | Bool
showTree'                     = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc
        | Bool
showHaskell'                  = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
haskellRepOfXmlDoc
        | Bool
outHtml'                      = [String] -> Bool -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowList a =>
[String] -> Bool -> a XmlTree XmlTree
preventEmptyElements [String]
noEEsFor' Bool
True
                                          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
>>>
                                          Bool -> Bool -> String -> a XmlTree XmlTree
encodeDoc                     -- convert doc into text with respect to output encoding with ASCII as default
                                            Bool
False Bool
noPi' ( if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outEnc' then String
usAscii else String
outEnc' )

        | Bool
outXhtml'                     = [String] -> Bool -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowList a =>
[String] -> Bool -> a XmlTree XmlTree
preventEmptyElements [String]
noEEsFor' Bool
True
                                          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
>>>
                                          Bool -> Bool -> String -> a XmlTree XmlTree
encodeDoc                     -- convert doc into text with respect to output encoding
                                            Bool
True Bool
noPi' String
outEnc'
        | Bool
outXml'                       = ( if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
noEEsFor'
                                            then a XmlTree XmlTree
forall b. a b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                                            else [String] -> Bool -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowList a =>
[String] -> Bool -> a XmlTree XmlTree
preventEmptyElements [String]
noEEsFor' Bool
False
                                          )
                                          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
>>>
                                          Bool -> Bool -> String -> a XmlTree XmlTree
encodeDoc                     -- convert doc into text with respect to output encoding
                                            Bool
True Bool
noPi' String
outEnc'
        | Bool
otherwise                     = a XmlTree XmlTree
forall b. a b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this

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