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

{- |
   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                            -- arrow classes
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowIO
import Control.Arrow.ListArrow
import Control.Arrow.ArrowExc

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.XmlArrow
import Text.XML.HXT.Arrow.Edit                  ( addHeadlineToXmlDoc
                                                , addXmlPi
                                                , addXmlPiEncoding
                                                , indentDoc
                                                , numberLinesInXmlDoc
                                                , treeRepOfXmlDoc
                                                , escapeHtmlRefs
                                                , escapeXmlRefs
                                                )
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs

import System.IO                                ( Handle
                                                , IOMode(..)
                                                , openFile
                                                , openBinaryFile
                                                , hSetBinaryMode
                                                , hPutStrLn
                                                , hClose
                                                , 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

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