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

{- |
   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 config dst
    = localSysEnv
      $
      configSysVars config
      >>>
      perform ( (flip writeDocument') dst $< getSysVar theTextMode )

writeDocument'          :: Bool -> String -> IOStateArrow s XmlTree XmlTree
writeDocument' textMode dst
    = ( traceMsg 1 ("writeDocument: destination is " ++ show dst)
        >>>
        ( (flip prepareContents) encodeDocument $< getSysVar idS )
        >>>
        traceDoc "document after encoding"
        >>>
        putXmlDocument textMode dst
        >>>
        traceMsg 1 "writeDocument: finished"
      )
      `when`
      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 config
    = prepareContents ( foldr (>>>) id (withOutputEncoding unicodeString :
                                        withXmlPi          no            :
                                        config
                                       )
                        $ initialSysState
                      ) encodeDocument'
      >>>
      xshow getChildren

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

-- |
-- indent and format output

prepareContents :: ArrowXml a => XIOSysState -> (Bool -> Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree
prepareContents config encodeDoc
    = indent
      >>>
      addDtd
      >>>
      format
    where
    indent'      = getS theIndent      config
    removeWS'    = getS theRemoveWS    config
    showTree'    = getS theShowTree    config
    showHaskell' = getS theShowHaskell config
    outHtml'     = getS theOutputFmt   config ==  HTMLoutput
    outXhtml'    = getS theOutputFmt   config == XHTMLoutput
    outXml'      = getS theOutputFmt   config ==   XMLoutput
    noPi'        = not $ getS theXmlPi       config
    noEEsFor'    = getS theNoEmptyElemFor  config
    addDDTD'     = getS theAddDefaultDTD   config
    outEnc'      = getS theOutputEncoding  config

    addDtd
        | addDDTD'                      = addDefaultDTDecl
        | otherwise                     = this
    indent
        | indent'                       = indentDoc                     -- document indentation
        | removeWS'                     = removeDocWhiteSpace           -- remove all whitespace between tags
        | otherwise                     = this

    format
        | showTree'                     = treeRepOfXmlDoc
        | showHaskell'                  = haskellRepOfXmlDoc
        | outHtml'                      = preventEmptyElements noEEsFor' True
                                          >>>
                                          encodeDoc                     -- convert doc into text with respect to output encoding with ASCII as default
                                            False noPi' ( if null outEnc' then usAscii else outEnc' )

        | outXhtml'                     = preventEmptyElements noEEsFor' True
                                          >>>
                                          encodeDoc                     -- convert doc into text with respect to output encoding
                                            True noPi' outEnc'
        | outXml'                       = ( if null noEEsFor'
                                            then this
                                            else preventEmptyElements noEEsFor' False
                                          )
                                          >>>
                                          encodeDoc                     -- convert doc into text with respect to output encoding
                                            True noPi' outEnc'
        | otherwise                     = this

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