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

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

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