{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>
-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>

-- | This module provides functions to format a tree
-- structure or SAX stream as UTF-8 encoded XML.
--
-- The formatting functions always outputs only UTF-8, regardless
-- of what encoding is specified in the document's 'Doc.XMLDeclaration'.
-- If you want to output a document in another encoding, then make sure the
-- 'Doc.XMLDeclaration' agrees with the final output encoding, then format the
-- document, and convert from UTF-8 to your desired encoding using some text
-- conversion library.
--
-- The lazy 'L.ByteString' representation of the output in generated with very
-- small chunks, so in some applications you may want to combine them into
-- larger chunks to get better efficiency.
module Text.XML.Expat.Format (
        -- * High level
        format,
        format',
        formatG,
        formatNode,
        formatNode',
        formatNodeG,
        -- * Format document (for use with Extended.hs)
        formatDocument,
        formatDocument',
        formatDocumentG,
        -- * Low level
        xmlHeader,
        treeToSAX,
        documentToSAX,
        formatSAX,
        formatSAX',
        formatSAXG,
        -- * Indentation
        indent,
        indent_
    ) where

import qualified Text.XML.Expat.Internal.DocumentClass as Doc
import Text.XML.Expat.Internal.NodeClass
import Text.XML.Expat.SAX

import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w, w2c)
import Data.Char (isSpace)
import Data.List.Class (List(..), ListItem(..), fromList)
import Data.Monoid
import Data.Word
import Data.Text (Text)
import Text.XML.Expat.Tree (UNode)

-- | Format document with <?xml.. header - lazy variant that returns lazy ByteString.
format :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
          n [] tag text
       -> L.ByteString
format :: forall (n :: (* -> *) -> * -> * -> *) tag text.
(NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
n [] tag text -> ByteString
format n [] tag text
node = [StrictByteString] -> ByteString
L.fromChunks (StrictByteString
xmlHeader StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
: n [] tag text -> [StrictByteString]
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
n c tag text -> c StrictByteString
formatNodeG n [] tag text
node)
{-# SPECIALIZE format :: UNode Text -> L.ByteString #-}

-- | Format document with <?xml.. header - generalized variant that returns a generic
-- list of strict ByteStrings.
formatG :: (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
          n c tag text
       -> c B.ByteString
formatG :: forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
n c tag text -> c StrictByteString
formatG n c tag text
node = StrictByteString -> c StrictByteString -> c StrictByteString
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons StrictByteString
xmlHeader (c StrictByteString -> c StrictByteString)
-> c StrictByteString -> c StrictByteString
forall a b. (a -> b) -> a -> b
$ n c tag text -> c StrictByteString
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
n c tag text -> c StrictByteString
formatNodeG n c tag text
node

-- | Format document with <?xml.. header - strict variant that returns strict ByteString.
format' :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
           n [] tag text
        -> B.ByteString
format' :: forall (n :: (* -> *) -> * -> * -> *) tag text.
(NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
n [] tag text -> StrictByteString
format' = [StrictByteString] -> StrictByteString
B.concat ([StrictByteString] -> StrictByteString)
-> (n [] tag text -> [StrictByteString])
-> n [] tag text
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [StrictByteString]
L.toChunks (ByteString -> [StrictByteString])
-> (n [] tag text -> ByteString)
-> n [] tag text
-> [StrictByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n [] tag text -> ByteString
forall (n :: (* -> *) -> * -> * -> *) tag text.
(NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
n [] tag text -> ByteString
format

-- | Format XML node with no header - lazy variant that returns lazy ByteString.
formatNode :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
              n [] tag text
           -> L.ByteString
formatNode :: forall (n :: (* -> *) -> * -> * -> *) tag text.
(NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
n [] tag text -> ByteString
formatNode = [SAXEvent tag text] -> ByteString
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
[SAXEvent tag text] -> ByteString
formatSAX ([SAXEvent tag text] -> ByteString)
-> (n [] tag text -> [SAXEvent tag text])
-> n [] tag text
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n [] tag text -> [SAXEvent tag text]
forall tag text (n :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 NodeClass n c) =>
n c tag text -> c (SAXEvent tag text)
treeToSAX

-- | Format XML node with no header - strict variant that returns strict ByteString.
formatNode' :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
               n [] tag text
            -> B.ByteString
formatNode' :: forall (n :: (* -> *) -> * -> * -> *) tag text.
(NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
n [] tag text -> StrictByteString
formatNode' = [StrictByteString] -> StrictByteString
B.concat ([StrictByteString] -> StrictByteString)
-> (n [] tag text -> [StrictByteString])
-> n [] tag text
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [StrictByteString]
L.toChunks (ByteString -> [StrictByteString])
-> (n [] tag text -> ByteString)
-> n [] tag text
-> [StrictByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n [] tag text -> ByteString
forall (n :: (* -> *) -> * -> * -> *) tag text.
(NodeClass n [], GenericXMLString tag, GenericXMLString text) =>
n [] tag text -> ByteString
formatNode

-- | Format XML node with no header - generalized variant that returns a generic
-- list of strict ByteStrings.
formatNodeG :: (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
              n c tag text
           -> c B.ByteString
formatNodeG :: forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
n c tag text -> c StrictByteString
formatNodeG = c (SAXEvent tag text) -> c StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> c StrictByteString
formatSAXG (c (SAXEvent tag text) -> c StrictByteString)
-> (n c tag text -> c (SAXEvent tag text))
-> n c tag text
-> c StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n c tag text -> c (SAXEvent tag text)
forall tag text (n :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 NodeClass n c) =>
n c tag text -> c (SAXEvent tag text)
treeToSAX
{-# SPECIALIZE formatNodeG :: UNode Text -> [B.ByteString] #-}

-- | Format an XML document - lazy variant that returns lazy ByteString.
formatDocument :: (Doc.DocumentClass d [], GenericXMLString tag, GenericXMLString text) =>
                  d [] tag text
               -> L.ByteString
formatDocument :: forall (d :: (* -> *) -> * -> * -> *) tag text.
(DocumentClass d [], GenericXMLString tag,
 GenericXMLString text) =>
d [] tag text -> ByteString
formatDocument = [SAXEvent tag text] -> ByteString
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
[SAXEvent tag text] -> ByteString
formatSAX ([SAXEvent tag text] -> ByteString)
-> (d [] tag text -> [SAXEvent tag text])
-> d [] tag text
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d [] tag text -> [SAXEvent tag text]
forall tag text (d :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 DocumentClass d c) =>
d c tag text -> c (SAXEvent tag text)
documentToSAX

-- | Format an XML document - strict variant that returns strict ByteString.
formatDocument' :: (Doc.DocumentClass d [], GenericXMLString tag, GenericXMLString text) =>
                   d [] tag text
                -> B.ByteString
formatDocument' :: forall (d :: (* -> *) -> * -> * -> *) tag text.
(DocumentClass d [], GenericXMLString tag,
 GenericXMLString text) =>
d [] tag text -> StrictByteString
formatDocument' = [StrictByteString] -> StrictByteString
B.concat ([StrictByteString] -> StrictByteString)
-> (d [] tag text -> [StrictByteString])
-> d [] tag text
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [StrictByteString]
L.toChunks (ByteString -> [StrictByteString])
-> (d [] tag text -> ByteString)
-> d [] tag text
-> [StrictByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d [] tag text -> ByteString
forall (d :: (* -> *) -> * -> * -> *) tag text.
(DocumentClass d [], GenericXMLString tag,
 GenericXMLString text) =>
d [] tag text -> ByteString
formatDocument

-- | Format an XML document - generalized variant that returns a generic
-- list of strict ByteStrings.
formatDocumentG :: (Doc.DocumentClass d c, GenericXMLString tag, GenericXMLString text) =>
                   d c tag text
                -> c B.ByteString
formatDocumentG :: forall (d :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(DocumentClass d c, GenericXMLString tag, GenericXMLString text) =>
d c tag text -> c StrictByteString
formatDocumentG = c (SAXEvent tag text) -> c StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> c StrictByteString
formatSAXG (c (SAXEvent tag text) -> c StrictByteString)
-> (d c tag text -> c (SAXEvent tag text))
-> d c tag text
-> c StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d c tag text -> c (SAXEvent tag text)
forall tag text (d :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 DocumentClass d c) =>
d c tag text -> c (SAXEvent tag text)
documentToSAX

-- | The standard XML header with UTF-8 encoding.
xmlHeader :: B.ByteString
xmlHeader :: StrictByteString
xmlHeader = [Word8] -> StrictByteString
B.pack ([Word8] -> StrictByteString) -> [Word8] -> StrictByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
c2w [Char]
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"

documentToSAX :: forall tag text d c . (GenericXMLString tag, GenericXMLString text,
                     Monoid text, Doc.DocumentClass d c) =>
                 d c tag text -> c (SAXEvent tag text)
documentToSAX :: forall tag text (d :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 DocumentClass d c) =>
d c tag text -> c (SAXEvent tag text)
documentToSAX d c tag text
doc =
    (case d c tag text -> Maybe (XMLDeclaration text)
forall tag text. d c tag text -> Maybe (XMLDeclaration text)
forall (d :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
DocumentClass d c =>
d c tag text -> Maybe (XMLDeclaration text)
Doc.getXMLDeclaration d c tag text
doc of
        Just (Doc.XMLDeclaration text
ver Maybe text
mEnc Maybe Bool
sd) -> [SAXEvent tag text] -> c (SAXEvent tag text)
forall (l :: * -> *) a. List l => [a] -> l a
fromList [
                  text -> Maybe text -> Maybe Bool -> SAXEvent tag text
forall tag text.
text -> Maybe text -> Maybe Bool -> SAXEvent tag text
XMLDeclaration text
ver Maybe text
mEnc Maybe Bool
sd, text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
CharacterData ([Char] -> text
forall s. GenericXMLString s => [Char] -> s
gxFromString [Char]
"\n")]
        Maybe (XMLDeclaration text)
Nothing                               -> c (SAXEvent tag text)
forall a. c a
forall (m :: * -> *) a. MonadPlus m => m a
mzero) c (SAXEvent tag text)
-> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a. c a -> c a -> c a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
    c (c (SAXEvent tag text)) -> c (SAXEvent tag text)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ((Misc text -> c (SAXEvent tag text))
-> c (Misc text) -> c (c (SAXEvent tag text))
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Misc text
misc -> [SAXEvent tag text] -> c (SAXEvent tag text)
forall (l :: * -> *) a. List l => [a] -> l a
fromList [case Misc text
misc of
            Doc.ProcessingInstruction text
target text
text -> text -> text -> SAXEvent tag text
forall tag text. text -> text -> SAXEvent tag text
ProcessingInstruction text
target text
text
            Doc.Comment text
text                      -> text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
Comment text
text,
            text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
CharacterData ([Char] -> text
forall s. GenericXMLString s => [Char] -> s
gxFromString [Char]
"\n")]
        ) (d c tag text -> c (Misc text)
forall tag text. d c tag text -> c (Misc text)
forall (d :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
DocumentClass d c =>
d c tag text -> c (Misc text)
Doc.getTopLevelMiscs d c tag text
doc)) c (SAXEvent tag text)
-> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a. c a -> c a -> c a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
    NodeType d c tag text -> c (SAXEvent tag text)
forall tag text (n :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 NodeClass n c) =>
n c tag text -> c (SAXEvent tag text)
treeToSAX (d c tag text -> NodeType d c tag text
forall tag text. d c tag text -> NodeType d c tag text
forall (d :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
DocumentClass d c =>
d c tag text -> NodeType d c tag text
Doc.getRoot d c tag text
doc)

-- | Flatten a tree structure into SAX events, monadic version.
treeToSAX :: forall tag text n c . (GenericXMLString tag, GenericXMLString text,
                 Monoid text, NodeClass n c) =>
             n c tag text -> c (SAXEvent tag text)
treeToSAX :: forall tag text (n :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 NodeClass n c) =>
n c tag text -> c (SAXEvent tag text)
treeToSAX n c tag text
node
    | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isElement n c tag text
node =
        let name :: tag
name = n c tag text -> tag
forall tag text. Monoid tag => n c tag text -> tag
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, Monoid tag) =>
n c tag text -> tag
getName n c tag text
node
            atts :: [(tag, text)]
atts = n c tag text -> [(tag, text)]
forall tag text. n c tag text -> [(tag, text)]
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> [(tag, text)]
getAttributes n c tag text
node
            children :: c (n c tag text)
children = n c tag text -> c (n c tag text)
forall tag text. n c tag text -> c (n c tag text)
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> c (n c tag text)
getChildren n c tag text
node
            postpend :: c (SAXEvent tag text) -> c (SAXEvent tag text)
            postpend :: c (SAXEvent tag text) -> c (SAXEvent tag text)
postpend c (SAXEvent tag text)
l = ItemM c (c (SAXEvent tag text)) -> c (SAXEvent tag text)
forall a. ItemM c (c a) -> c a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (ItemM c (c (SAXEvent tag text)) -> c (SAXEvent tag text))
-> ItemM c (c (SAXEvent tag text)) -> c (SAXEvent tag text)
forall a b. (a -> b) -> a -> b
$ do
                li <- c (SAXEvent tag text) -> ItemM c (ListItem c (SAXEvent tag text))
forall a. c a -> ItemM c (ListItem c a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList c (SAXEvent tag text)
l
                return $ case li of
                    ListItem c (SAXEvent tag text)
Nil -> SAXEvent tag text -> c (SAXEvent tag text)
forall {a}. a -> c a
singleton (tag -> SAXEvent tag text
forall tag text. tag -> SAXEvent tag text
EndElement tag
name)
                    Cons SAXEvent tag text
n c (SAXEvent tag text)
l' -> SAXEvent tag text -> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons SAXEvent tag text
n (c (SAXEvent tag text) -> c (SAXEvent tag text)
postpend c (SAXEvent tag text)
l')
        in  SAXEvent tag text -> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (tag -> [(tag, text)] -> SAXEvent tag text
forall tag text. tag -> [(tag, text)] -> SAXEvent tag text
StartElement tag
name [(tag, text)]
atts) (c (SAXEvent tag text) -> c (SAXEvent tag text))
-> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a b. (a -> b) -> a -> b
$
            c (SAXEvent tag text) -> c (SAXEvent tag text)
postpend (c (c (SAXEvent tag text)) -> c (SAXEvent tag text)
forall {a}. c (c a) -> c a
concatL (c (c (SAXEvent tag text)) -> c (SAXEvent tag text))
-> c (c (SAXEvent tag text)) -> c (SAXEvent tag text)
forall a b. (a -> b) -> a -> b
$ (n c tag text -> c (SAXEvent tag text))
-> c (n c tag text) -> c (c (SAXEvent tag text))
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n c tag text -> c (SAXEvent tag text)
forall tag text (n :: (* -> *) -> * -> * -> *) (c :: * -> *).
(GenericXMLString tag, GenericXMLString text, Monoid text,
 NodeClass n c) =>
n c tag text -> c (SAXEvent tag text)
treeToSAX c (n c tag text)
children)
    | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isCData n c tag text
node =
        SAXEvent tag text -> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons SAXEvent tag text
forall tag text. SAXEvent tag text
StartCData (SAXEvent tag text -> c (SAXEvent tag text) -> c (SAXEvent tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
CharacterData (text -> SAXEvent tag text) -> text -> SAXEvent tag text
forall a b. (a -> b) -> a -> b
$ n c tag text -> text
forall text tag. Monoid text => n c tag text -> text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> text
getText n c tag text
node) (SAXEvent tag text -> c (SAXEvent tag text)
forall {a}. a -> c a
singleton SAXEvent tag text
forall tag text. SAXEvent tag text
EndCData))
    | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isText n c tag text
node =
        SAXEvent tag text -> c (SAXEvent tag text)
forall {a}. a -> c a
singleton (text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
CharacterData (text -> SAXEvent tag text) -> text -> SAXEvent tag text
forall a b. (a -> b) -> a -> b
$ n c tag text -> text
forall text tag. Monoid text => n c tag text -> text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> text
getText n c tag text
node)        
    | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isProcessingInstruction n c tag text
node =
        SAXEvent tag text -> c (SAXEvent tag text)
forall {a}. a -> c a
singleton (text -> text -> SAXEvent tag text
forall tag text. text -> text -> SAXEvent tag text
ProcessingInstruction (n c tag text -> text
forall text tag. Monoid text => n c tag text -> text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> text
getTarget n c tag text
node) (n c tag text -> text
forall text tag. Monoid text => n c tag text -> text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> text
getText n c tag text
node))
    | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isComment n c tag text
node =
        SAXEvent tag text -> c (SAXEvent tag text)
forall {a}. a -> c a
singleton (text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
Comment (text -> SAXEvent tag text) -> text -> SAXEvent tag text
forall a b. (a -> b) -> a -> b
$ n c tag text -> text
forall text tag. Monoid text => n c tag text -> text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> text
getText n c tag text
node)    
    | Bool
otherwise = c (SAXEvent tag text)
forall a. c a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  where
    singleton :: a -> c a
singleton = a -> c a
forall {a}. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return
    concatL :: c (c a) -> c a
concatL = c (c a) -> c a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
{-# SPECIALIZE treeToSAX :: UNode Text -> [(SAXEvent Text Text)] #-}

-- | Format SAX events with no header - lazy variant that returns lazy ByteString.
formatSAX :: (GenericXMLString tag, GenericXMLString text) =>
             [SAXEvent tag text]
          -> L.ByteString
formatSAX :: forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
[SAXEvent tag text] -> ByteString
formatSAX = [StrictByteString] -> ByteString
L.fromChunks ([StrictByteString] -> ByteString)
-> ([SAXEvent tag text] -> [StrictByteString])
-> [SAXEvent tag text]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SAXEvent tag text] -> [StrictByteString]
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> c StrictByteString
formatSAXG

-- | Format SAX events with no header - strict variant that returns strict ByteString.
formatSAX' :: (GenericXMLString tag, GenericXMLString text) =>
              [SAXEvent tag text]
           -> B.ByteString
formatSAX' :: forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
[SAXEvent tag text] -> StrictByteString
formatSAX' = [StrictByteString] -> StrictByteString
B.concat ([StrictByteString] -> StrictByteString)
-> ([SAXEvent tag text] -> [StrictByteString])
-> [SAXEvent tag text]
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SAXEvent tag text] -> [StrictByteString]
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> c StrictByteString
formatSAXG

-- Do start tag and attributes but omit closing >
startTagHelper :: (GenericXMLString tag, GenericXMLString text) =>
                  tag
               -> [(tag, text)]
               -> [B.ByteString]
startTagHelper :: forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
tag -> [(tag, text)] -> [StrictByteString]
startTagHelper tag
name [(tag, text)]
atts =
    Word8 -> StrictByteString
B.singleton (Char -> Word8
c2w Char
'<')StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:
    tag -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString tag
nameStrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:
    ((tag, text) -> [StrictByteString])
-> [(tag, text)] -> [StrictByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
Prelude.concatMap (
            \(tag
aname, text
avalue) ->
                Word8 -> StrictByteString
B.singleton (Char -> Word8
c2w Char
' ')StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:
                tag -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString tag
anameStrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:
                [Char] -> StrictByteString
pack [Char]
"=\""StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:
                StrictByteString -> [StrictByteString]
escapeText (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
avalue)[StrictByteString] -> [StrictByteString] -> [StrictByteString]
forall a. [a] -> [a] -> [a]
++
                [Word8 -> StrictByteString
B.singleton (Char -> Word8
c2w Char
'"')]
        ) [(tag, text)]
atts

-- | Format SAX events with no header - generalized variant that uses generic
-- list.
formatSAXG :: forall c tag text . (List c, GenericXMLString tag,
              GenericXMLString text) =>
          c (SAXEvent tag text)    -- ^ SAX events
       -> c B.ByteString
formatSAXG :: forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> c StrictByteString
formatSAXG c (SAXEvent tag text)
l1 = c (SAXEvent tag text) -> Bool -> c StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb c (SAXEvent tag text)
l1 Bool
False
{-# SPECIALIZE formatSAXG :: [SAXEvent Text Text] -> [B.ByteString] #-}

formatSAXGb :: forall c tag text . (List c, GenericXMLString tag,
              GenericXMLString text) =>
          c (SAXEvent tag text)    -- ^ SAX events
       -> Bool                     -- ^ True if processing CDATA
       -> c B.ByteString
formatSAXGb :: forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb c (SAXEvent tag text)
l1 Bool
cd = ItemM c (c StrictByteString) -> c StrictByteString
forall a. ItemM c (c a) -> c a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (ItemM c (c StrictByteString) -> c StrictByteString)
-> ItemM c (c StrictByteString) -> c StrictByteString
forall a b. (a -> b) -> a -> b
$ do
    it1 <- c (SAXEvent tag text) -> ItemM c (ListItem c (SAXEvent tag text))
forall a. c a -> ItemM c (ListItem c a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList c (SAXEvent tag text)
l1
    return $ formatItem it1
  where
    formatItem :: ListItem l (SAXEvent tag text) -> l StrictByteString
formatItem ListItem l (SAXEvent tag text)
it1 = case ListItem l (SAXEvent tag text)
it1 of
        ListItem l (SAXEvent tag text)
Nil -> l StrictByteString
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Cons (XMLDeclaration text
ver Maybe text
mEnc Maybe Bool
mSD) l (SAXEvent tag text)
l2 ->
            StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack [Char]
"<?xml version=\"") l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            [StrictByteString] -> l StrictByteString
forall (l :: * -> *) a. List l => [a] -> l a
fromList (StrictByteString -> [StrictByteString]
escapeText (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
ver)) l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack [Char]
"\"") l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            (
                case Maybe text
mEnc of
                    Maybe text
Nothing -> l StrictByteString
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                    Just text
enc ->
                        StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack [Char]
" encoding=\"") l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                        [StrictByteString] -> l StrictByteString
forall (l :: * -> *) a. List l => [a] -> l a
fromList (StrictByteString -> [StrictByteString]
escapeText (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
enc)) l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                        StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack [Char]
"\"")
            ) l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            (
                case Maybe Bool
mSD of
                    Maybe Bool
Nothing -> l StrictByteString
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                    Just Bool
True  -> StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack [Char]
" standalone=\"yes\"")
                    Just Bool
False -> StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack [Char]
" standalone=\"no\"")
            ) l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            StrictByteString -> l StrictByteString
forall a. a -> l a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> StrictByteString
pack ([Char]
"?>"))
            l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
cd
        Cons (StartElement tag
name [(tag, text)]
attrs) l (SAXEvent tag text)
l2 ->
            [StrictByteString] -> l StrictByteString
forall (l :: * -> *) a. List l => [a] -> l a
fromList (tag -> [(tag, text)] -> [StrictByteString]
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
tag -> [(tag, text)] -> [StrictByteString]
startTagHelper tag
name [(tag, text)]
attrs)
            l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (
                ItemM l (l StrictByteString) -> l StrictByteString
forall a. ItemM l (l a) -> l a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (ItemM l (l StrictByteString) -> l StrictByteString)
-> ItemM l (l StrictByteString) -> l StrictByteString
forall a b. (a -> b) -> a -> b
$ do
                    it2 <- l (SAXEvent tag text) -> ItemM l (ListItem l (SAXEvent tag text))
forall a. l a -> ItemM l (ListItem l a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList l (SAXEvent tag text)
l2
                    return $ case it2 of
                        Cons (EndElement tag
_) l (SAXEvent tag text)
l3 ->
                            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
"/>") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
                            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l3 Bool
cd
                        ListItem l (SAXEvent tag text)
_ ->
                            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (Word8 -> StrictByteString
B.singleton (Char -> Word8
c2w Char
'>')) (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
                            ListItem l (SAXEvent tag text) -> l StrictByteString
formatItem ListItem l (SAXEvent tag text)
it2
            )
        Cons (EndElement tag
name) l (SAXEvent tag text)
l2 ->
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
"</") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (tag -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString tag
name) (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (Word8 -> StrictByteString
B.singleton (Char -> Word8
c2w Char
'>')) (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
cd
        Cons (CharacterData text
txt) l (SAXEvent tag text)
l2 ->
            (if Bool
cd then
                [StrictByteString] -> l StrictByteString
forall (l :: * -> *) a. List l => [a] -> l a
fromList [text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
txt]
             else
                [StrictByteString] -> l StrictByteString
forall (l :: * -> *) a. List l => [a] -> l a
fromList (StrictByteString -> [StrictByteString]
escapeText (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
txt))
            ) l StrictByteString -> l StrictByteString -> l StrictByteString
forall a. l a -> l a -> l a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
cd)
        Cons SAXEvent tag text
StartCData l (SAXEvent tag text)
l2 ->
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons([Char] -> StrictByteString
pack [Char]
"<![CDATA[") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
True
        Cons SAXEvent tag text
EndCData l (SAXEvent tag text)
l2 ->
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons([Char] -> StrictByteString
pack [Char]
"]]>") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
False
        Cons (ProcessingInstruction text
target text
txt) l (SAXEvent tag text)
l2 ->
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
"<?") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
target) (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
" ") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
txt) (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
"?>") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
cd
        Cons (Comment text
txt) l (SAXEvent tag text)
l2 ->
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
"<!--") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (text -> StrictByteString
forall s. GenericXMLString s => s -> StrictByteString
gxToByteString text
txt) (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            StrictByteString -> l StrictByteString -> l StrictByteString
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons ([Char] -> StrictByteString
pack [Char]
"-->") (l StrictByteString -> l StrictByteString)
-> l StrictByteString -> l StrictByteString
forall a b. (a -> b) -> a -> b
$
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
cd
        Cons (FailDocument XMLParseError
_) l (SAXEvent tag text)
l2 ->
            l (SAXEvent tag text) -> Bool -> l StrictByteString
forall (c :: * -> *) tag text.
(List c, GenericXMLString tag, GenericXMLString text) =>
c (SAXEvent tag text) -> Bool -> c StrictByteString
formatSAXGb l (SAXEvent tag text)
l2 Bool
cd
{-# SPECIALIZE formatSAXGb :: [SAXEvent Text Text] -> Bool -> [B.ByteString] #-}

pack :: String -> B.ByteString
pack :: [Char] -> StrictByteString
pack = [Word8] -> StrictByteString
B.pack ([Word8] -> StrictByteString)
-> ([Char] -> [Word8]) -> [Char] -> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
c2w

isSafeChar :: Word8 -> Bool
isSafeChar :: Word8 -> Bool
isSafeChar Word8
c =
     (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'&')
  Bool -> Bool -> Bool
&& (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'<')
  Bool -> Bool -> Bool
&& (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'>')
  Bool -> Bool -> Bool
&& (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'"')
  Bool -> Bool -> Bool
&& (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'\'')
{-# INLINE isSafeChar #-}

escapeText :: B.ByteString -> [B.ByteString]
escapeText :: StrictByteString -> [StrictByteString]
escapeText StrictByteString
str | StrictByteString -> Bool
B.null StrictByteString
str = []
escapeText StrictByteString
str =
    let (StrictByteString
good, StrictByteString
bad) = (Word8 -> Bool)
-> StrictByteString -> (StrictByteString, StrictByteString)
B.span Word8 -> Bool
isSafeChar StrictByteString
str
    in  if StrictByteString -> Bool
B.null StrictByteString
good
            then case Word8 -> Char
w2c (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ HasCallStack => StrictByteString -> Word8
StrictByteString -> Word8
B.head StrictByteString
str of
                Char
'&'  -> [Char] -> StrictByteString
pack [Char]
"&amp;"StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:StrictByteString -> [StrictByteString]
escapeText StrictByteString
rema
                Char
'<'  -> [Char] -> StrictByteString
pack [Char]
"&lt;"StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:StrictByteString -> [StrictByteString]
escapeText StrictByteString
rema
                Char
'>'  -> [Char] -> StrictByteString
pack [Char]
"&gt;"StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:StrictByteString -> [StrictByteString]
escapeText StrictByteString
rema
                Char
'"'  -> [Char] -> StrictByteString
pack [Char]
"&quot;"StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:StrictByteString -> [StrictByteString]
escapeText StrictByteString
rema
                Char
'\'' -> [Char] -> StrictByteString
pack [Char]
"&apos;"StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:StrictByteString -> [StrictByteString]
escapeText StrictByteString
rema
                Char
_        -> [Char] -> [StrictByteString]
forall a. HasCallStack => [Char] -> a
error [Char]
"hexpat: impossible"
            else StrictByteString
goodStrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:StrictByteString -> [StrictByteString]
escapeText StrictByteString
bad
  where
    rema :: StrictByteString
rema = HasCallStack => StrictByteString -> StrictByteString
StrictByteString -> StrictByteString
B.tail StrictByteString
str

-- | Make the output prettier by adding indentation.
indent :: (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
          Int   -- ^ Number of indentation spaces per nesting level
       -> n c tag text
       -> n c tag text
indent :: forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
Int -> n c tag text -> n c tag text
indent = Int -> Int -> n c tag text -> n c tag text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
Int -> Int -> n c tag text -> n c tag text
indent_ Int
0

-- | Make the output prettier by adding indentation, specifying initial indent.
indent_ :: forall n c tag text . (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
           Int   -- ^ Initial indent (spaces)
        -> Int   -- ^ Number of indentation spaces per nesting level
        -> n c tag text
        -> n c tag text
indent_ :: forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
Int -> Int -> n c tag text -> n c tag text
indent_ Int
cur Int
perLevel n c tag text
elt | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isElement n c tag text
elt =
    ((c (n c tag text) -> c (n c tag text))
 -> n c tag text -> n c tag text)
-> n c tag text
-> (c (n c tag text) -> c (n c tag text))
-> n c tag text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (c (n c tag text) -> c (n c tag text))
-> n c tag text -> n c tag text
forall tag text.
(c (n c tag text) -> c (n c tag text))
-> n c tag text -> n c tag text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
(c (n c tag text) -> c (n c tag text))
-> n c tag text -> n c tag text
modifyChildren n c tag text
elt ((c (n c tag text) -> c (n c tag text)) -> n c tag text)
-> (c (n c tag text) -> c (n c tag text)) -> n c tag text
forall a b. (a -> b) -> a -> b
$ \c (n c tag text)
chs -> ItemM c (c (n c tag text)) -> c (n c tag text)
forall a. ItemM c (c a) -> c a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (ItemM c (c (n c tag text)) -> c (n c tag text))
-> ItemM c (c (n c tag text)) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$ do
        (anyElts, chs') <- [n c tag text]
-> c (n c tag text) -> ItemM c (Bool, c (n c tag text))
anyElements [] c (n c tag text)
chs
        -- The new list chs' is the same as the old list chs, but some of its
        -- nodes have been loaded into memory.  This is to avoid evaluating
        -- list elements twice.
        if anyElts
            then addSpace True chs'
            else return chs'
  where
    addSpace :: Bool -> c (n c tag text) -> ItemM c (c (n c tag text))
    addSpace :: Bool -> c (n c tag text) -> ItemM c (c (n c tag text))
addSpace Bool
startOfText c (n c tag text)
l = do
        ch <- c (n c tag text) -> ItemM c (ListItem c (n c tag text))
forall a. c a -> ItemM c (ListItem c a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList c (n c tag text)
l
        case ch of
            ListItem c (n c tag text)
Nil -> c (n c tag text) -> ItemM c (c (n c tag text))
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (n c tag text) -> ItemM c (c (n c tag text)))
-> c (n c tag text) -> ItemM c (c (n c tag text))
forall a b. (a -> b) -> a -> b
$ n c tag text -> c (n c tag text)
forall {a}. a -> c a
singleton (text -> n c tag text
forall text tag. text -> n c tag text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
NodeClass n c =>
text -> n c tag text
mkText (text -> n c tag text) -> text -> n c tag text
forall a b. (a -> b) -> a -> b
$ [Char] -> text
forall s. GenericXMLString s => [Char] -> s
gxFromString (Char
'\n'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
cur Char
' '))
            Cons n c tag text
elt c (n c tag text)
l' | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isElement n c tag text
elt -> do
                let cur' :: Int
cur' = Int
cur Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
perLevel
                c (n c tag text) -> ItemM c (c (n c tag text))
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (n c tag text) -> ItemM c (c (n c tag text)))
-> c (n c tag text) -> ItemM c (c (n c tag text))
forall a b. (a -> b) -> a -> b
$
                    n c tag text -> c (n c tag text) -> c (n c tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (text -> n c tag text
forall text tag. text -> n c tag text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
NodeClass n c =>
text -> n c tag text
mkText (text -> n c tag text) -> text -> n c tag text
forall a b. (a -> b) -> a -> b
$ [Char] -> text
forall s. GenericXMLString s => [Char] -> s
gxFromString (Char
'\n'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
cur' Char
' ')) (c (n c tag text) -> c (n c tag text))
-> c (n c tag text) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$
                    n c tag text -> c (n c tag text) -> c (n c tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (Int -> Int -> n c tag text -> n c tag text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
(NodeClass n c, GenericXMLString tag, GenericXMLString text) =>
Int -> Int -> n c tag text -> n c tag text
indent_ Int
cur' Int
perLevel n c tag text
elt) (c (n c tag text) -> c (n c tag text))
-> c (n c tag text) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$
                    ItemM c (c (n c tag text)) -> c (n c tag text)
forall a. ItemM c (c a) -> c a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (Bool -> c (n c tag text) -> ItemM c (c (n c tag text))
addSpace Bool
True c (n c tag text)
l')

            Cons n c tag text
tx c (n c tag text)
l' | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isText n c tag text
tx Bool -> Bool -> Bool
&& Bool
startOfText ->
                case text -> Maybe text
forall {a}. GenericXMLString a => a -> Maybe a
strip (n c tag text -> text
forall text tag. Monoid text => n c tag text -> text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> text
getText n c tag text
tx) of
                    Maybe text
Nothing -> Bool -> c (n c tag text) -> ItemM c (c (n c tag text))
addSpace Bool
True c (n c tag text)
l'
                    Just text
t' -> c (n c tag text) -> ItemM c (c (n c tag text))
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (n c tag text) -> ItemM c (c (n c tag text)))
-> c (n c tag text) -> ItemM c (c (n c tag text))
forall a b. (a -> b) -> a -> b
$
                        n c tag text -> c (n c tag text) -> c (n c tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons (text -> n c tag text
forall text tag. text -> n c tag text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
NodeClass n c =>
text -> n c tag text
mkText text
t') (c (n c tag text) -> c (n c tag text))
-> c (n c tag text) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$
                        ItemM c (c (n c tag text)) -> c (n c tag text)
forall a. ItemM c (c a) -> c a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (ItemM c (c (n c tag text)) -> c (n c tag text))
-> ItemM c (c (n c tag text)) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$ Bool -> c (n c tag text) -> ItemM c (c (n c tag text))
addSpace Bool
False c (n c tag text)
l'
            Cons n c tag text
n c (n c tag text)
l' ->
                c (n c tag text) -> ItemM c (c (n c tag text))
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (n c tag text) -> ItemM c (c (n c tag text)))
-> c (n c tag text) -> ItemM c (c (n c tag text))
forall a b. (a -> b) -> a -> b
$
                    n c tag text -> c (n c tag text) -> c (n c tag text)
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons n c tag text
n (c (n c tag text) -> c (n c tag text))
-> c (n c tag text) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$
                    ItemM c (c (n c tag text)) -> c (n c tag text)
forall a. ItemM c (c a) -> c a
forall (l :: * -> *) a. List l => ItemM l (l a) -> l a
joinL (ItemM c (c (n c tag text)) -> c (n c tag text))
-> ItemM c (c (n c tag text)) -> c (n c tag text)
forall a b. (a -> b) -> a -> b
$ Bool -> c (n c tag text) -> ItemM c (c (n c tag text))
addSpace Bool
False c (n c tag text)
l'

    -- acc is used to keep the nodes we've scanned into memory.
    -- We then construct a new list that looks the same as the old list, but
    -- which starts with the nodes in memory, to prevent the list being
    -- demanded more than once (in case it's monadic and it's expensive to
    -- evaluate).
    anyElements :: [n c tag text]   -- ^ Accumulator for tags we've looked at.
                -> c (n c tag text)
                -> ItemM c (Bool, c (n c tag text))
    anyElements :: [n c tag text]
-> c (n c tag text) -> ItemM c (Bool, c (n c tag text))
anyElements [n c tag text]
acc c (n c tag text)
l = do
        n <- c (n c tag text) -> ItemM c (ListItem c (n c tag text))
forall a. c a -> ItemM c (ListItem c a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList c (n c tag text)
l
        case n of
            ListItem c (n c tag text)
Nil                     -> (Bool, c (n c tag text)) -> ItemM c (Bool, c (n c tag text))
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [n c tag text] -> c (n c tag text) -> c (n c tag text)
instantiatedList [n c tag text]
acc c (n c tag text)
forall a. c a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
            Cons n c tag text
n c (n c tag text)
l' | n c tag text -> Bool
forall tag text. n c tag text -> Bool
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag text.
NodeClass n c =>
n c tag text -> Bool
isElement n c tag text
n -> (Bool, c (n c tag text)) -> ItemM c (Bool, c (n c tag text))
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,  [n c tag text] -> c (n c tag text) -> c (n c tag text)
instantiatedList (n c tag text
nn c tag text -> [n c tag text] -> [n c tag text]
forall a. a -> [a] -> [a]
:[n c tag text]
acc) c (n c tag text)
l')
            Cons n c tag text
n c (n c tag text)
l'               -> [n c tag text]
-> c (n c tag text) -> ItemM c (Bool, c (n c tag text))
anyElements (n c tag text
nn c tag text -> [n c tag text] -> [n c tag text]
forall a. a -> [a] -> [a]
:[n c tag text]
acc) c (n c tag text)
l'
      where
        instantiatedList :: [n c tag text] -> c (n c tag text) -> c (n c tag text)
        instantiatedList :: [n c tag text] -> c (n c tag text) -> c (n c tag text)
instantiatedList [n c tag text]
acc c (n c tag text)
l' = [n c tag text] -> [n c tag text]
forall a. [a] -> [a]
reverse [n c tag text]
acc [n c tag text] -> c (n c tag text) -> c (n c tag text)
forall a. [a] -> c a -> c a
`prepend` c (n c tag text)
l'

        prepend :: forall a . [a] -> c a -> c a
        prepend :: forall a. [a] -> c a -> c a
prepend [a]
xs c a
l = (a -> c a -> c a) -> c a -> [a] -> c a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> c a -> c a
forall a. a -> c a -> c a
forall (l :: * -> *) a. List l => a -> l a -> l a
cons c a
l [a]
xs

    strip :: a -> Maybe a
strip a
t | a -> Bool
forall s. GenericXMLString s => s -> Bool
gxNullString a
t = Maybe a
forall a. Maybe a
Nothing
    strip a
t | Char -> Bool
isSpace (a -> Char
forall s. GenericXMLString s => s -> Char
gxHead a
t) = a -> Maybe a
strip (a -> a
forall s. GenericXMLString s => s -> s
gxTail a
t)
    strip a
t = a -> Maybe a
forall a. a -> Maybe a
Just a
t

    singleton :: a -> c a
singleton = a -> c a
forall {a}. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return
indent_ Int
_ Int
_ n c tag text
n = n c tag text
n