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

    {- |
       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

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