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

    {- |
       Module     : Text.XML.HXT.Arrow.DocumentOutput
       Copyright  : Copyright (C) 2005-9 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable

       State arrows for document output

    -}

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

    module Text.XML.HXT.Arrow.DocumentOutput
        ( putXmlDocument
        , putXmlTree
        , putXmlSource
        , encodeDocument
        , encodeDocument'
        )
    where

    import           Control.Arrow
    import           Control.Arrow.ArrowExc
    import           Control.Arrow.ArrowIf
    import           Control.Arrow.ArrowIO
    import           Control.Arrow.ArrowList
    import           Control.Arrow.ArrowTree
    import           Control.Arrow.ListArrow

    import qualified Data.ByteString.Lazy                 as BS
    import           Data.Maybe
    import           Data.String.Unicode                  (getOutputEncodingFct')

    import           Text.XML.HXT.DOM.Interface
    import qualified Text.XML.HXT.DOM.ShowXml             as XS

    import           Text.XML.HXT.Arrow.Edit              (addHeadlineToXmlDoc,
                                                           addXmlPi,
                                                           addXmlPiEncoding,
                                                           escapeHtmlRefs,
                                                           escapeXmlRefs, indentDoc,
                                                           numberLinesInXmlDoc,
                                                           treeRepOfXmlDoc)
    import           Text.XML.HXT.Arrow.XmlArrow
    import           Text.XML.HXT.Arrow.XmlState
    import           Text.XML.HXT.Arrow.XmlState.TypeDefs

    import           System.IO                            (Handle, IOMode (..),
                                                           hClose, hPutStrLn,
                                                           hSetBinaryMode,
                                                           openBinaryFile, openFile,
                                                           stdout)

    -- ------------------------------------------------------------
    --
    -- | Write the contents of a document tree into an output stream (file or stdout).
    --
    -- If textMode is set, writing is done with Haskell string output, else (default)
    -- writing is done with lazy ByteString output

    putXmlDocument  :: Bool -> String -> IOStateArrow s XmlTree XmlTree
    putXmlDocument textMode dst
        = perform putDoc
          where
          putDoc
              = ( if textMode
                  then ( xshow getChildren
                         >>>
                         tryA (arrIO (\ s -> hPutDocument (\h -> hPutStrLn h s)))
                       )
                  else ( xshowBlob getChildren
                         >>>
                         tryA (arrIO (\ s -> hPutDocument (\h -> do BS.hPutStr h s
                                                                    BS.hPutStr h (stringToBlob "\n")
                                                          )
                                     )
                              )
                       )
                )
                >>>
                ( ( traceMsg 1 ("io error, document not written to " ++ outFile)
                    >>>
                    arr show >>> mkError c_fatal
                    >>>
                    filterErrorMsg
                  )
                  |||
                  ( traceMsg 2 ("document written to " ++ outFile ++ ", textMode = " ++ show textMode)
                    >>>
                    none
                  )
                )
              where
              isStdout  = null dst || dst == "-"

              outFile   = if isStdout
                          then "stdout"
                          else show dst

              hPutDocument      :: (Handle -> IO ()) -> IO ()
              hPutDocument action
                  | isStdout
                      = do
                        hSetBinaryMode stdout (not textMode)
                        action stdout
                        hSetBinaryMode stdout False
                  | otherwise
                      = do
                        handle <- ( if textMode
                                    then openFile
                                    else openBinaryFile
                                  ) dst WriteMode
                        action handle
                        hClose handle

    -- |
    -- write the tree representation of a document to a file

    putXmlTree      :: String -> IOStateArrow s XmlTree XmlTree
    putXmlTree dst
        = perform ( treeRepOfXmlDoc
                    >>>
                    addHeadlineToXmlDoc
                    >>>
                    putXmlDocument True dst
                  )

    -- |
    -- write a document with indentaion and line numers

    putXmlSource    :: String -> IOStateArrow s XmlTree XmlTree
    putXmlSource dst
        = perform ( (this ) `whenNot` isRoot
                    >>>
                    indentDoc
                    >>>
                    numberLinesInXmlDoc
                    >>>
                    addHeadlineToXmlDoc
                    >>>
                    putXmlDocument True dst
                  )

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

    getEncodingParam        :: IOStateArrow s XmlTree String
    getEncodingParam
        = catA [ getSysVar theOutputEncoding   -- 4. guess: take output encoding parameter from global state
               , getSysVar theInputEncoding    -- 5. guess: take encoding parameter from global state
               , constA utf8                   -- default : utf8
               ]
          >. (head . filter (not . null))

    getOutputEncoding       :: String -> IOStateArrow s XmlTree String
    getOutputEncoding defaultEnc
        = getEC $< getEncodingParam
        where
        getEC enc' = fromLA $ getOutputEncoding' defaultEnc enc'

    encodeDocument  :: Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
    encodeDocument quoteXml supressXmlPi defaultEnc
        = encode $< getOutputEncoding defaultEnc
        where
        encode enc
            = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)
              >>>
              ( encodeDocument' quoteXml supressXmlPi enc
                `orElse`
                ( issueFatal ("encoding scheme not supported: " ++ show enc)
                  >>>
                  setDocumentStatusFromSystemState "encoding document"
                )
              )

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

    isBinaryDoc               :: LA XmlTree XmlTree
    isBinaryDoc               = ( ( getAttrValue transferMimeType >>^ stringToLower )
                                  >>>
                                  isA (\ t -> not (null t || isTextMimeType t || isXmlMimeType t))
                                )
                                `guards` this

    getOutputEncoding'      :: String -> String -> LA XmlTree String
    getOutputEncoding' defaultEnc defaultEnc2
        =  catA [ isBinaryDoc
                  >>>                               -- 0. guess: binary data found: no encoding at all
                  constA isoLatin1                  --           the content should usually be a blob
                                                    --           this handling is like the decoding in DocumentInput,
                                                    --           there nothing is decoded for non text or non xml contents
                , getChildren                       -- 1. guess: evaluate <?xml ... encoding="..."?>
                  >>>
                  ( ( isPi >>> hasName t_xml )
                    `guards`
                    getAttrValue a_encoding
                  )
                , constA defaultEnc                 -- 2. guess: explicit parameter, may be ""
                , getAttrValue a_output_encoding    -- 3. guess: take output encoding parameter in root node
                , constA defaultEnc2                -- default : UNICODE or utf8
                ]
          >. (head . filter (not . null))           -- make the filter deterministic: take 1. entry from list of guesses

    encodeDocument' :: ArrowXml a => Bool -> Bool -> String -> a XmlTree XmlTree
    encodeDocument' quoteXml supressXmlPi defaultEnc
        = fromLA (encode $< getOutputEncoding' defaultEnc utf8)
        where
        encode      :: String -> LA XmlTree XmlTree
        encode encodingScheme
            | encodingScheme == unicodeString
                = replaceChildren
                  ( (getChildren >. XS.xshow'' cQuot aQuot)
                    >>>
                    mkText
                  )
            | isNothing encodeFct
                = none
            | otherwise
                = ( if supressXmlPi
                    then processChildren (none `when` isXmlPi)
                    else ( addXmlPi
                           >>>
                           addXmlPiEncoding encodingScheme
                         )
                  )
                  >>>
                  ( isLatin1Blob
                    `orElse`
                    encodeDoc (fromJust encodeFct)
                  )
                  >>>
                  addAttr a_output_encoding encodingScheme
            where
            (cQuot, aQuot)
                | quoteXml  = escapeXmlRefs
                | otherwise = escapeHtmlRefs

            encodeFct       = getOutputEncodingFct' encodingScheme

            encodeDoc ef    = replaceChildren
                              ( xshowBlobWithEnc cQuot aQuot ef getChildren
                                >>>
                                mkBlob
                              )
            xshowBlobWithEnc cenc aenc enc f
                            = f >. XS.xshow' cenc aenc enc

            -- if encoding scheme is isolatin1 and the contents is a single blob (bytestring)
            -- the encoding is the identity.
            -- This optimization enables processing (copying) of none XML contents
            -- without any conversions from and to strings
            isLatin1Blob
                | encodingScheme /= isoLatin1
                            = none
                | otherwise = childIsSingleBlob `guards` this
                where
                childIsSingleBlob
                            = listA getChildren
                              >>>
                              isA (length >>> (== 1))
                              >>>
                              unlistA
                              >>>
                              isBlob

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