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)
putXmlDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument :: forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
textMode String
dst
= forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform forall {s}. IOSLA (XIOState s) XmlTree XmlTree
putDoc
where
putDoc :: IOSLA (XIOState s) XmlTree XmlTree
putDoc
= ( if Bool
textMode
then ( forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b c.
ArrowExc a =>
a b c -> a b (Either SomeException c)
tryA (forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO (\ String
s -> (Handle -> IO ()) -> IO ()
hPutDocument (\Handle
h -> Handle -> String -> IO ()
hPutStrLn Handle
h String
s)))
)
else ( forall (a :: * -> * -> *) n. ArrowXml a => a n XmlTree -> a n Blob
xshowBlob forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b c.
ArrowExc a =>
a b c -> a b (Either SomeException c)
tryA (forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO (\ Blob
s -> (Handle -> IO ()) -> IO ()
hPutDocument (\Handle
h -> do Handle -> Blob -> IO ()
BS.hPutStr Handle
h Blob
s
Handle -> Blob -> IO ()
BS.hPutStr Handle
h (String -> Blob
stringToBlob String
"\n")
)
)
)
)
)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( ( forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
1 (String
"io error, document not written to " forall a. [a] -> [a] -> [a]
++ String
outFile)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. Show a => a -> String
show forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
mkError Int
c_fatal
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall {s}. IOSLA (XIOState s) XmlTree XmlTree
filterErrorMsg
)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
|||
( forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 (String
"document written to " forall a. [a] -> [a] -> [a]
++ String
outFile forall a. [a] -> [a] -> [a]
++ String
", textMode = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
textMode)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
)
)
where
isStdout :: Bool
isStdout = forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dst Bool -> Bool -> Bool
|| String
dst forall a. Eq a => a -> a -> Bool
== String
"-"
outFile :: String
outFile = if Bool
isStdout
then String
"stdout"
else forall a. Show a => a -> String
show String
dst
hPutDocument :: (Handle -> IO ()) -> IO ()
hPutDocument :: (Handle -> IO ()) -> IO ()
hPutDocument Handle -> IO ()
action
| Bool
isStdout
= do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
stdout (Bool -> Bool
not Bool
textMode)
Handle -> IO ()
action Handle
stdout
Handle -> Bool -> IO ()
hSetBinaryMode Handle
stdout Bool
False
| Bool
otherwise
= do
Handle
handle <- ( if Bool
textMode
then String -> IOMode -> IO Handle
openFile
else String -> IOMode -> IO Handle
openBinaryFile
) String
dst IOMode
WriteMode
Handle -> IO ()
action Handle
handle
Handle -> IO ()
hClose Handle
handle
putXmlTree :: String -> IOStateArrow s XmlTree XmlTree
putXmlTree :: forall s. String -> IOStateArrow s XmlTree XmlTree
putXmlTree String
dst
= forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
True String
dst
)
putXmlSource :: String -> IOStateArrow s XmlTree XmlTree
putXmlSource :: forall s. String -> IOStateArrow s XmlTree XmlTree
putXmlSource String
dst
= forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( (forall (a :: * -> * -> *) b. ArrowList a => a b b
this ) forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`whenNot` forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
numberLinesInXmlDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
True String
dst
)
getEncodingParam :: IOStateArrow s XmlTree String
getEncodingParam :: forall s. IOStateArrow s XmlTree String
getEncodingParam
= forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theOutputEncoding
, forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theInputEncoding
, forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
utf8
]
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null))
getOutputEncoding :: String -> IOStateArrow s XmlTree String
getOutputEncoding :: forall s. String -> IOStateArrow s XmlTree String
getOutputEncoding String
defaultEnc
= forall {a :: * -> * -> *}.
ArrowList a =>
String -> a XmlTree String
getEC forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall s. IOStateArrow s XmlTree String
getEncodingParam
where
getEC :: String -> a XmlTree String
getEC String
enc' = forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA forall a b. (a -> b) -> a -> b
$ String -> String -> LA XmlTree String
getOutputEncoding' String
defaultEnc String
enc'
encodeDocument :: Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
encodeDocument :: forall s. Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
encodeDocument Bool
quoteXml Bool
supressXmlPi String
defaultEnc
= forall s. String -> IOStateArrow s XmlTree XmlTree
encode forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall s. String -> IOStateArrow s XmlTree String
getOutputEncoding String
defaultEnc
where
encode :: String -> IOSLA (XIOState s) XmlTree XmlTree
encode String
enc
= forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 (String
"encodeDocument: encoding is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
enc)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument' Bool
quoteXml Bool
supressXmlPi String
enc
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
( forall s b. String -> IOStateArrow s b b
issueFatal (String
"encoding scheme not supported: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
enc)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall s. String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState String
"encoding document"
)
)
isBinaryDoc :: LA XmlTree XmlTree
isBinaryDoc :: LA XmlTree XmlTree
isBinaryDoc = ( ( forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
transferMimeType forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ String -> String
stringToLower )
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (\ String
t -> Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t Bool -> Bool -> Bool
|| String -> Bool
isTextMimeType String
t Bool -> Bool -> Bool
|| String -> Bool
isXmlMimeType String
t))
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` forall (a :: * -> * -> *) b. ArrowList a => a b b
this
getOutputEncoding' :: String -> String -> LA XmlTree String
getOutputEncoding' :: String -> String -> LA XmlTree String
getOutputEncoding' String
defaultEnc String
defaultEnc2
= forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ LA XmlTree XmlTree
isBinaryDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
isoLatin1
, forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
t_xml )
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
a_encoding
)
, forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
defaultEnc
, forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
a_output_encoding
, forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
defaultEnc2
]
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null))
encodeDocument' :: ArrowXml a => Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument' :: forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument' Bool
quoteXml Bool
supressXmlPi String
defaultEnc
= forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (String -> LA XmlTree XmlTree
encode forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< String -> String -> LA XmlTree String
getOutputEncoding' String
defaultEnc String
utf8)
where
encode :: String -> LA XmlTree XmlTree
encode :: String -> LA XmlTree XmlTree
encode String
encodingScheme
| String
encodingScheme forall a. Eq a => a -> a -> Bool
== String
unicodeString
= forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
( (forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (Char -> String -> String)
-> (Char -> String -> String) -> XmlTrees -> String
XS.xshow'' Char -> String -> String
cQuot Char -> String -> String
aQuot)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
mkText
)
| forall a. Maybe a -> Bool
isNothing Maybe (Char -> String -> String)
encodeFct
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= ( if Bool
supressXmlPi
then forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren (forall (a :: * -> * -> *) b c. ArrowList a => a b c
none forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isXmlPi)
else ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addXmlPi
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
addXmlPiEncoding String
encodingScheme
)
)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( LA XmlTree XmlTree
isLatin1Blob
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
forall {a :: * -> * -> *}.
ArrowXml a =>
(Char -> String -> String) -> a XmlTree XmlTree
encodeDoc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Char -> String -> String)
encodeFct)
)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
a_output_encoding String
encodingScheme
where
(Char -> String -> String
cQuot, Char -> String -> String
aQuot)
| Bool
quoteXml = (Char -> String -> String, Char -> String -> String)
escapeXmlRefs
| Bool
otherwise = (Char -> String -> String, Char -> String -> String)
escapeHtmlRefs
encodeFct :: Maybe (Char -> String -> String)
encodeFct = String -> Maybe (Char -> String -> String)
getOutputEncodingFct' String
encodingScheme
encodeDoc :: (Char -> String -> String) -> a XmlTree XmlTree
encodeDoc Char -> String -> String
ef = forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
( forall {a :: * -> * -> *} {b}.
ArrowList a =>
(Char -> String -> String)
-> (Char -> String -> String)
-> (Char -> String -> String)
-> a b XmlTree
-> a b Blob
xshowBlobWithEnc Char -> String -> String
cQuot Char -> String -> String
aQuot Char -> String -> String
ef forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a Blob XmlTree
mkBlob
)
xshowBlobWithEnc :: (Char -> String -> String)
-> (Char -> String -> String)
-> (Char -> String -> String)
-> a b XmlTree
-> a b Blob
xshowBlobWithEnc Char -> String -> String
cenc Char -> String -> String
aenc Char -> String -> String
enc a b XmlTree
f
= a b XmlTree
f forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (Char -> String -> String)
-> (Char -> String -> String)
-> (Char -> String -> String)
-> XmlTrees
-> Blob
XS.xshow' Char -> String -> String
cenc Char -> String -> String
aenc Char -> String -> String
enc
isLatin1Blob :: LA XmlTree XmlTree
isLatin1Blob
| String
encodingScheme forall a. Eq a => a -> a -> Bool
/= String
isoLatin1
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise = LA XmlTree XmlTree
childIsSingleBlob forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` forall (a :: * -> * -> *) b. ArrowList a => a b b
this
where
childIsSingleBlob :: LA XmlTree XmlTree
childIsSingleBlob
= forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall a. Eq a => a -> a -> Bool
== Int
1))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isBlob