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

{- |
   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 :: Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
textMode String
dst
    = IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform IOStateArrow s XmlTree XmlTree
forall s. IOSLA (XIOState s) XmlTree XmlTree
putDoc
      where
      putDoc :: IOSLA (XIOState s) XmlTree XmlTree
putDoc
          = ( if Bool
textMode
              then ( IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow IOSLA (XIOState s) XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                     IOSLA (XIOState s) XmlTree String
-> IOSLA (XIOState s) String (Either SomeException ())
-> IOSLA (XIOState s) XmlTree (Either SomeException ())
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                     IOSLA (XIOState s) String ()
-> IOSLA (XIOState s) String (Either SomeException ())
forall (a :: * -> * -> *) b c.
ArrowExc a =>
a b c -> a b (Either SomeException c)
tryA ((String -> IO ()) -> IOSLA (XIOState s) String ()
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 ( IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree Blob
forall (a :: * -> * -> *) n. ArrowXml a => a n XmlTree -> a n Blob
xshowBlob IOSLA (XIOState s) XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                     IOSLA (XIOState s) XmlTree Blob
-> IOSLA (XIOState s) Blob (Either SomeException ())
-> IOSLA (XIOState s) XmlTree (Either SomeException ())
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                     IOSLA (XIOState s) Blob ()
-> IOSLA (XIOState s) Blob (Either SomeException ())
forall (a :: * -> * -> *) b c.
ArrowExc a =>
a b c -> a b (Either SomeException c)
tryA ((Blob -> IO ()) -> IOSLA (XIOState s) Blob ()
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")
                                                      )
                                 )
                          )
                   )
            )
            IOSLA (XIOState s) XmlTree (Either SomeException ())
-> IOSLA (XIOState s) (Either SomeException ()) XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ( ( Int -> String -> IOStateArrow s SomeException SomeException
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
1 (String
"io error, document not written to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outFile)
                IOStateArrow s SomeException SomeException
-> IOSLA (XIOState s) SomeException XmlTree
-> IOSLA (XIOState s) SomeException XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                (SomeException -> String)
-> IOSLA (XIOState s) SomeException String
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr SomeException -> String
forall a. Show a => a -> String
show IOSLA (XIOState s) SomeException String
-> IOSLA (XIOState s) String XmlTree
-> IOSLA (XIOState s) SomeException XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Int -> IOSLA (XIOState s) String XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
mkError Int
c_fatal
                IOSLA (XIOState s) String XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) String XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                IOSLA (XIOState s) XmlTree XmlTree
forall s. IOSLA (XIOState s) XmlTree XmlTree
filterErrorMsg
              )
              IOSLA (XIOState s) SomeException XmlTree
-> IOSLA (XIOState s) () XmlTree
-> IOSLA (XIOState s) (Either SomeException ()) XmlTree
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
|||
              ( Int -> String -> IOStateArrow s () ()
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 (String
"document written to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", textMode = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
textMode)
                IOStateArrow s () ()
-> IOSLA (XIOState s) () XmlTree -> IOSLA (XIOState s) () XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                IOSLA (XIOState s) () XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
              )
            )
          where
          isStdout :: Bool
isStdout  = String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dst Bool -> Bool -> Bool
|| String
dst String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"

          outFile :: String
outFile   = if Bool
isStdout
                      then String
"stdout"
                      else String -> String
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

-- |
-- write the tree representation of a document to a file

putXmlTree      :: String -> IOStateArrow s XmlTree XmlTree
putXmlTree :: String -> IOStateArrow s XmlTree XmlTree
putXmlTree String
dst
    = IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc
                IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc
                IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                Bool -> String -> IOStateArrow s XmlTree XmlTree
forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
True String
dst
              )

-- |
-- write a document with indentaion and line numers

putXmlSource    :: String -> IOStateArrow s XmlTree XmlTree
putXmlSource :: String -> IOStateArrow s XmlTree XmlTree
putXmlSource String
dst
    = IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( (IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this ) IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`whenNot` IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot
                IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc
                IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
numberLinesInXmlDoc
                IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc
                IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                Bool -> String -> IOStateArrow s XmlTree XmlTree
forall s. Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument Bool
True String
dst
              )

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

getEncodingParam        :: IOStateArrow s XmlTree String
getEncodingParam :: IOStateArrow s XmlTree String
getEncodingParam
    = [IOStateArrow s XmlTree String] -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ Selector XIOSysState String -> IOStateArrow s XmlTree String
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theOutputEncoding   -- 4. guess: take output encoding parameter from global state
           , Selector XIOSysState String -> IOStateArrow s XmlTree String
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theInputEncoding    -- 5. guess: take encoding parameter from global state
           , String -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
utf8                   -- default : utf8
           ]
      IOStateArrow s XmlTree String
-> ([String] -> String) -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. ([String] -> String
forall a. [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null))

getOutputEncoding       :: String -> IOStateArrow s XmlTree String
getOutputEncoding :: String -> IOStateArrow s XmlTree String
getOutputEncoding String
defaultEnc
    = String -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *).
ArrowList a =>
String -> a XmlTree String
getEC (String -> IOStateArrow s XmlTree String)
-> IOStateArrow s XmlTree String -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< IOStateArrow s XmlTree String
forall s. IOStateArrow s XmlTree String
getEncodingParam
    where
    getEC :: String -> a XmlTree String
getEC String
enc' = LA XmlTree String -> a XmlTree String
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (LA XmlTree String -> a XmlTree String)
-> LA XmlTree String -> a XmlTree String
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 :: Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
encodeDocument Bool
quoteXml Bool
supressXmlPi String
defaultEnc
    = String -> IOStateArrow s XmlTree XmlTree
forall s. String -> IOSLA (XIOState s) XmlTree XmlTree
encode (String -> IOStateArrow s XmlTree XmlTree)
-> IOSLA (XIOState s) XmlTree String
-> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< String -> IOSLA (XIOState s) XmlTree String
forall s. String -> IOStateArrow s XmlTree String
getOutputEncoding String
defaultEnc
    where
    encode :: String -> IOSLA (XIOState s) XmlTree XmlTree
encode String
enc
        = Int -> String -> IOSLA (XIOState s) XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 (String
"encodeDocument: encoding is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
enc)
          IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          ( Bool -> Bool -> String -> IOSLA (XIOState s) XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument' Bool
quoteXml Bool
supressXmlPi String
enc
            IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
            ( String -> IOSLA (XIOState s) XmlTree XmlTree
forall s b. String -> IOStateArrow s b b
issueFatal (String
"encoding scheme not supported: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
enc)
              IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
              String -> IOSLA (XIOState s) XmlTree XmlTree
forall s. String -> IOSLA (XIOState s) XmlTree XmlTree
setDocumentStatusFromSystemState String
"encoding document"
            )
          )

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

isBinaryDoc               :: LA XmlTree XmlTree
isBinaryDoc :: LA XmlTree XmlTree
isBinaryDoc               = ( ( String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
transferMimeType LA XmlTree String -> (String -> String) -> LA XmlTree String
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ String -> String
stringToLower )
                              LA XmlTree String -> LA String String -> LA XmlTree String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              (String -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (\ String
t -> Bool -> Bool
not (String -> Bool
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))
                            )
                            LA XmlTree String -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` LA XmlTree XmlTree
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
    =  [LA XmlTree String] -> LA XmlTree String
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [ LA XmlTree XmlTree
isBinaryDoc
              LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>                               -- 0. guess: binary data found: no encoding at all
              String -> LA XmlTree String
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
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
            , LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren                       -- 1. guess: evaluate <?xml ... encoding="..."?>
              LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
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
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
t_xml )
                LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
a_encoding
              )
            , String -> LA XmlTree String
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
defaultEnc                 -- 2. guess: explicit parameter, may be ""
            , String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
a_output_encoding    -- 3. guess: take output encoding parameter in root node
            , String -> LA XmlTree String
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
defaultEnc2                -- default : UNICODE or utf8
            ]
      LA XmlTree String -> ([String] -> String) -> LA XmlTree String
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. ([String] -> String
forall a. [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null))           -- make the filter deterministic: take 1. entry from list of guesses

encodeDocument' :: ArrowXml a => Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument' :: Bool -> Bool -> String -> a XmlTree XmlTree
encodeDocument' Bool
quoteXml Bool
supressXmlPi String
defaultEnc
    = LA XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (String -> LA XmlTree XmlTree
encode (String -> LA XmlTree XmlTree)
-> LA XmlTree String -> LA XmlTree XmlTree
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
unicodeString
            = LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
              ( (LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree XmlTree -> ([XmlTree] -> String) -> LA XmlTree String
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (Char -> String -> String)
-> (Char -> String -> String) -> [XmlTree] -> String
XS.xshow'' Char -> String -> String
cQuot Char -> String -> String
aQuot)
                LA XmlTree String -> LA String XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
mkText
              )
        | Maybe (Char -> String -> String) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Char -> String -> String)
encodeFct
            = LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
        | Bool
otherwise
            = ( if Bool
supressXmlPi
                then LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processChildren (LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isXmlPi)
                else ( LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addXmlPi
                       LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                       String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
addXmlPiEncoding String
encodingScheme
                     )
              )
              LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
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
                LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
                (Char -> String -> String) -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
(Char -> String -> String) -> a XmlTree XmlTree
encodeDoc (Maybe (Char -> String -> String) -> Char -> String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Char -> String -> String)
encodeFct)
              )
              LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
              String -> String -> LA XmlTree XmlTree
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    = a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
                          ( (Char -> String -> String)
-> (Char -> String -> String)
-> (Char -> String -> String)
-> a XmlTree XmlTree
-> a XmlTree Blob
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 a XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                            a XmlTree Blob -> a Blob XmlTree -> a XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                            a Blob XmlTree
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 a b XmlTree -> ([XmlTree] -> Blob) -> a b Blob
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> d) -> a b d
>. (Char -> String -> String)
-> (Char -> String -> String)
-> (Char -> String -> String)
-> [XmlTree]
-> Blob
XS.xshow' Char -> String -> String
cenc Char -> String -> String
aenc Char -> String -> String
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 :: LA XmlTree XmlTree
isLatin1Blob
            | String
encodingScheme String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
isoLatin1
                        = LA XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
            | Bool
otherwise = LA XmlTree XmlTree
childIsSingleBlob LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
            where
            childIsSingleBlob :: LA XmlTree XmlTree
childIsSingleBlob
                        = LA XmlTree XmlTree -> LA XmlTree [XmlTree]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA LA XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                          LA XmlTree [XmlTree] -> LA [XmlTree] XmlTree -> LA XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ([XmlTree] -> Bool) -> LA [XmlTree] [XmlTree]
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ([XmlTree] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([XmlTree] -> Int) -> (Int -> Bool) -> [XmlTree] -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1))
                          LA [XmlTree] [XmlTree]
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
                          LA [XmlTree] XmlTree -> LA XmlTree XmlTree -> LA [XmlTree] XmlTree
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
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isBlob

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