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

    {- |
       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 Text.XML.HXT.DOM.Unicode                 ( getOutputEncodingFct )
    import Text.XML.HXT.DOM.Interface

    import Text.XML.HXT.Arrow.XmlArrow
    import Text.XML.HXT.Arrow.XmlIOStateArrow

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

    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 ( 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 [ getParamString a_output_encoding   -- 4. guess: take output encoding parameter from global state
               , getParamString a_encoding          -- 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

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