module Text.XML.HXT.Arrow.DocumentOutput
( module Text.XML.HXT.Arrow.DocumentOutput )
where
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowIO
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 Data.Maybe
import System.IO
( Handle
, IOMode(..)
, openFile
, hPutStrLn
, hClose
, stdout
)
import System.IO.Error
( try )
putXmlDocument :: String -> IOStateArrow s XmlTree XmlTree
putXmlDocument 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
= action stdout
| otherwise
= do
handle <- openFile dst WriteMode
action handle
hClose handle
putXmlTree :: String -> IOStateArrow s XmlTree XmlTree
putXmlTree dst
= perform ( treeRepOfXmlDoc
>>>
addHeadlineToXmlDoc
>>>
putXmlDocument dst
)
putXmlSource :: String -> IOStateArrow s XmlTree XmlTree
putXmlSource dst
= perform ( (this ) `whenNot` isRoot
>>>
indentDoc
>>>
numberLinesInXmlDoc
>>>
addHeadlineToXmlDoc
>>>
putXmlDocument dst
)
getOutputEncoding :: String -> IOStateArrow s XmlTree String
getOutputEncoding defaultEnc
= catA [ getChildren
>>>
( ( isPi >>> hasName t_xml )
`guards`
getAttrValue a_encoding
)
, constA defaultEnc
, getAttrValue a_output_encoding
, getParamString a_output_encoding
, getParamString a_encoding
, constA utf8
]
>. (head . filter (not . null))
encodeDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree
encodeDocument supressXmlPi defaultEnc
= applyA ( getOutputEncoding defaultEnc
>>>
arr encArr
)
`when`
isRoot
where
encArr :: String -> IOStateArrow s XmlTree XmlTree
encArr enc = maybe notFound found . getOutputEncodingFct $ enc
where
found ef = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)
>>>
( if supressXmlPi
then processChildren (none `when` isXmlPi)
else ( addXmlPi
>>>
addXmlPiEncoding enc
)
)
>>>
replaceChildren ( xshow getChildren
>>>
arr ef
>>>
mkText
)
>>>
addAttr a_output_encoding enc
notFound = issueFatal ("encoding scheme not supported: " ++ show enc)
>>>
setDocumentStatusFromSystemState "encoding document"