module Text.XML.HXT.Arrow.DocumentOutput
( putXmlDocument
, putXmlTree
, putXmlSource
, encodeDocument
, encodeDocument'
)
where
import Control.Arrow
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 )
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
putXmlTree :: String -> IOStateArrow s XmlTree XmlTree
putXmlTree dst
= perform ( treeRepOfXmlDoc
>>>
addHeadlineToXmlDoc
>>>
putXmlDocument True dst
)
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
, getParamString a_encoding
, constA 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
>>>
( ( isPi >>> hasName t_xml )
`guards`
getAttrValue a_encoding
)
, constA defaultEnc
, getAttrValue a_output_encoding
, constA defaultEnc2
]
>. (head . filter (not . null))
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