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

{- |
   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 Data.String.Unicode                      ( getOutputEncodingFct )

import Text.XML.HXT.DOM.Interface

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

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

-- ------------------------------------------------------------
--
-- output arrows

putXmlDocument  :: Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument textMode dst
    = perform putDoc
      where
      putDoc
          = xshow getChildren
            >>>
            arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))
            >>>
            ( ( traceMsg 1 ("io error, document not written to " ++ outFile)
                >>>
                arr show >>> mkError c_fatal
                >>>
                filterErrorMsg
              )
              |||
              ( traceMsg 2 ("document written to " ++ outFile)
                >>>
                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 -> String -> IOStateArrow s XmlTree XmlTree
encodeDocument supressXmlPi defaultEnc
    = encode $< getOutputEncoding defaultEnc
    where
    encode enc
        = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)
          >>>
          ( encodeDocument' supressXmlPi enc
            `orElse`
            ( issueFatal ("encoding scheme not supported: " ++ show enc)
              >>>
              setDocumentStatusFromSystemState "encoding document"
            )
          )

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

getOutputEncoding'      :: String -> String -> LA XmlTree String
getOutputEncoding' defaultEnc defaultEnc2
    =  catA [ 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 -> String -> a XmlTree XmlTree
encodeDocument' supressXmlPi defaultEnc
    = fromLA (encode $< getOutputEncoding' defaultEnc utf8)
    where
    encode      :: String -> LA XmlTree XmlTree
    encode encodingScheme
        = case getOutputEncodingFct encodingScheme of
          Nothing       -> none
          Just ef       -> ( if supressXmlPi
                             then processChildren (none `when` isXmlPi)
                             else ( addXmlPi
                                    >>>
                                    addXmlPiEncoding encodingScheme
                                  )
                           )
                           >>>
                           replaceChildren ( xshow getChildren
                                             >>>
                                             arr ef
                                             >>>
                                             mkText
                                           )
                           >>>
                           addAttr a_output_encoding encodingScheme

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