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