{-# LANGUAGE CPP  #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
-- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and
-- expat-enumerator, this module does not provide IO and ST variants, since the
-- underlying rendering operations are pure functions.
module Text.XML.Stream.Render
    ( -- * Rendering XML files
      renderBuilder
    , renderBuilderFlush
    , renderBytes
    , renderText
    , prettify
      -- * Renderer settings
    , RenderSettings
    , def
    , rsPretty
    , rsNamespaces
    , rsAttrOrder
    , rsUseCDATA
    , rsXMLDeclaration
    , orderAttrs
      -- * Event rendering
    , tag
    , content
      -- * Attribute rendering
    , Attributes
    , attr
    , optionalAttr
    ) where

import           Control.Applicative          ((<$>))
import           Control.Monad.Trans.Resource (MonadThrow)
import           Data.ByteString              (ByteString)
import           Data.ByteString.Builder      (Builder)
import           Conduit
import           Data.Default.Class           (Default (def))
import           Data.List                    (foldl')
import           Data.Map                     (Map)
import qualified Data.Map                     as Map
import           Data.Maybe                   (fromMaybe, mapMaybe)
import           Data.Monoid                  (Monoid, mappend, mempty)
import qualified Data.Set                     as Set
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import           Data.XML.Types               (Content (..), Event (..),
                                               Name (..))
import           Text.XML.Stream.Token

-- | Render a stream of 'Event's into a stream of 'ByteString's. This function
-- wraps around 'renderBuilder' and 'builderToByteString', so it produces
-- optimally sized 'ByteString's with minimal buffer copying.
--
-- The output is UTF8 encoded.
renderBytes :: PrimMonad m => RenderSettings -> ConduitT Event ByteString m ()
renderBytes :: RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
rs = RenderSettings -> ConduitT Event Builder m ()
forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT Event Builder m ()
renderBuilder RenderSettings
rs ConduitT Event Builder m ()
-> ConduitM Builder ByteString m ()
-> ConduitT Event ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Builder ByteString m ()
forall (m :: * -> *).
PrimMonad m =>
ConduitT Builder ByteString m ()
builderToByteString

-- | Render a stream of 'Event's into a stream of 'Text's. This function
-- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it
-- produces optimally sized 'Text's with minimal buffer copying.
renderText :: (PrimMonad m, MonadThrow m) => RenderSettings -> ConduitT Event Text m ()
renderText :: RenderSettings -> ConduitT Event Text m ()
renderText RenderSettings
rs = RenderSettings -> ConduitT Event ByteString m ()
forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
rs ConduitT Event ByteString m ()
-> ConduitM ByteString Text m () -> ConduitT Event Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C

data RenderSettings = RenderSettings
    { RenderSettings -> Bool
rsPretty     :: Bool
    , RenderSettings -> [(Text, Text)]
rsNamespaces :: [(Text, Text)]
      -- ^ Defines some top level namespace definitions to be used, in the form
      -- of (prefix, namespace). This has absolutely no impact on the meaning
      -- of your documents, but can increase readability by moving commonly
      -- used namespace declarations to the top level.
    , RenderSettings -> Name -> Map Name Text -> [(Name, Text)]
rsAttrOrder  :: Name -> Map.Map Name Text -> [(Name, Text)]
      -- ^ Specify how to turn the unordered attributes used by the "Text.XML"
      -- module into an ordered list.
    , RenderSettings -> Content -> Bool
rsUseCDATA   :: Content -> Bool
      -- ^ Determines if for a given text content the renderer should use a
      -- CDATA node.
      --
      -- Default: @False@
      --
      -- @since 1.3.3
    , RenderSettings -> Bool
rsXMLDeclaration :: Bool
      -- ^ Determines whether the XML declaration will be output.
      --
      -- Default: @True@
      --
      -- @since 1.5.1
    }

instance Default RenderSettings where
    def :: RenderSettings
def = RenderSettings :: Bool
-> [(Text, Text)]
-> (Name -> Map Name Text -> [(Name, Text)])
-> (Content -> Bool)
-> Bool
-> RenderSettings
RenderSettings
        { rsPretty :: Bool
rsPretty = Bool
False
        , rsNamespaces :: [(Text, Text)]
rsNamespaces = []
        , rsAttrOrder :: Name -> Map Name Text -> [(Name, Text)]
rsAttrOrder = (Map Name Text -> [(Name, Text)])
-> Name -> Map Name Text -> [(Name, Text)]
forall a b. a -> b -> a
const Map Name Text -> [(Name, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList
        , rsUseCDATA :: Content -> Bool
rsUseCDATA = Bool -> Content -> Bool
forall a b. a -> b -> a
const Bool
False
        , rsXMLDeclaration :: Bool
rsXMLDeclaration = Bool
True
        }

-- | Convenience function to create an ordering function suitable for
-- use as the value of 'rsAttrOrder'. The ordering function is created
-- from an explicit ordering of the attributes, specified as a list of
-- tuples, as follows: In each tuple, the first component is the
-- 'Name' of an element, and the second component is a list of
-- attributes names. When the given element is rendered, the
-- attributes listed, when present, appear first in the given order,
-- followed by any other attributes in arbitrary order. If an element
-- does not appear, all of its attributes are rendered in arbitrary
-- order.
orderAttrs :: [(Name, [Name])] ->
              Name -> Map Name Text -> [(Name, Text)]
orderAttrs :: [(Name, [Name])] -> Name -> Map Name Text -> [(Name, Text)]
orderAttrs [(Name, [Name])]
orderSpec = Name -> Map Name Text -> [(Name, Text)]
forall b. Name -> Map Name b -> [(Name, b)]
order
  where
    order :: Name -> Map Name b -> [(Name, b)]
order Name
elt Map Name b
attrMap =
      let initialAttrs :: [Name]
initialAttrs = [Name] -> Maybe [Name] -> [Name]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Name] -> [Name]) -> Maybe [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Name])] -> Maybe [Name]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
elt [(Name, [Name])]
orderSpec
          mkPair :: Name -> Maybe (Name, b)
mkPair Name
attr' = (,) Name
attr' (b -> (Name, b)) -> Maybe b -> Maybe (Name, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Map Name b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
attr' Map Name b
attrMap
          otherAttrMap :: Map Name b
otherAttrMap =
            (Name -> b -> Bool) -> Map Name b -> Map Name b
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Bool -> b -> Bool
forall a b. a -> b -> a
const (Bool -> b -> Bool) -> (Name -> Bool) -> Name -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
initialAttrs)) Map Name b
attrMap
      in (Name -> Maybe (Name, b)) -> [Name] -> [(Name, b)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Name -> Maybe (Name, b)
mkPair [Name]
initialAttrs [(Name, b)] -> [(Name, b)] -> [(Name, b)]
forall a. [a] -> [a] -> [a]
++ Map Name b -> [(Name, b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Name b
otherAttrMap

-- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from
-- the blaze-builder package, and allow the create of optimally sized
-- 'ByteString's with minimal buffer copying.
renderBuilder :: Monad m => RenderSettings -> ConduitT Event Builder m ()
renderBuilder :: RenderSettings -> ConduitT Event Builder m ()
renderBuilder RenderSettings
settings = (Event -> Flush Event) -> ConduitT Event (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC Event -> Flush Event
forall a. a -> Flush a
Chunk ConduitT Event (Flush Event) m ()
-> ConduitM (Flush Event) Builder m ()
-> ConduitT Event Builder m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Flush Builder -> ConduitM (Flush Event) Builder m ())
-> RenderSettings -> ConduitM (Flush Event) Builder m ()
forall (m :: * -> *) o.
Monad m =>
(Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderBuilder' Flush Builder -> ConduitM (Flush Event) Builder m ()
forall (m :: * -> *) o i. Monad m => Flush o -> ConduitT i o m ()
yield' RenderSettings
settings
  where
    yield' :: Flush o -> ConduitT i o m ()
yield' Flush o
Flush = () -> ConduitT i o m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    yield' (Chunk o
bs) = o -> ConduitT i o m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
bs

-- | Same as 'renderBuilder' but allows you to flush XML stream to ensure that all
-- events at needed point are rendered.
--
-- @since 1.3.5
renderBuilderFlush :: Monad m => RenderSettings -> ConduitT (Flush Event) (Flush Builder) m ()
renderBuilderFlush :: RenderSettings -> ConduitT (Flush Event) (Flush Builder) m ()
renderBuilderFlush = (Flush Builder -> ConduitT (Flush Event) (Flush Builder) m ())
-> RenderSettings -> ConduitT (Flush Event) (Flush Builder) m ()
forall (m :: * -> *) o.
Monad m =>
(Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderBuilder' Flush Builder -> ConduitT (Flush Event) (Flush Builder) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield

renderBuilder'
  :: Monad m
  => (Flush Builder -> ConduitT (Flush Event) o m ())
  -> RenderSettings
  -> ConduitT (Flush Event) o m ()
renderBuilder' :: (Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderBuilder' Flush Builder -> ConduitT (Flush Event) o m ()
yield' RenderSettings
settings =
    if RenderSettings -> Bool
rsPretty RenderSettings
settings
    then ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
ConduitT (Flush Event) (Flush Event) m ()
prettify ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) o m () -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT (Flush Event) o m ()
renderEvent'
    else ConduitT (Flush Event) o m ()
renderEvent'
  where
    renderEvent' :: ConduitT (Flush Event) o m ()
renderEvent' = (Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) o.
Monad m =>
(Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderEvent Flush Builder -> ConduitT (Flush Event) o m ()
yield' RenderSettings
settings

renderEvent
  :: Monad m
  => (Flush Builder -> ConduitT (Flush Event) o m ())
  -> RenderSettings
  -> ConduitT (Flush Event) o m ()
renderEvent :: (Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderEvent Flush Builder -> ConduitT (Flush Event) o m ()
yield' RenderSettings { rsPretty :: RenderSettings -> Bool
rsPretty = Bool
isPretty, rsNamespaces :: RenderSettings -> [(Text, Text)]
rsNamespaces = [(Text, Text)]
namespaces0, rsUseCDATA :: RenderSettings -> Content -> Bool
rsUseCDATA = Content -> Bool
useCDATA, rsXMLDeclaration :: RenderSettings -> Bool
rsXMLDeclaration = Bool
useXMLDecl } =
    Stack -> ConduitT (Flush Event) o m ()
loop []
  where
    loop :: Stack -> ConduitT (Flush Event) o m ()
loop Stack
nslevels = ConduitT (Flush Event) o m (Maybe (Flush Event))
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT (Flush Event) o m (Maybe (Flush Event))
-> (Maybe (Flush Event) -> ConduitT (Flush Event) o m ())
-> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT (Flush Event) o m ()
-> (Flush Event -> ConduitT (Flush Event) o m ())
-> Maybe (Flush Event)
-> ConduitT (Flush Event) o m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Stack -> Flush Event -> ConduitT (Flush Event) o m ()
go Stack
nslevels)

    go :: Stack -> Flush Event -> ConduitT (Flush Event) o m ()
go Stack
nslevels Flush Event
Flush = Flush Builder -> ConduitT (Flush Event) o m ()
yield' Flush Builder
forall a. Flush a
Flush ConduitT (Flush Event) o m ()
-> ConduitT (Flush Event) o m () -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stack -> ConduitT (Flush Event) o m ()
loop Stack
nslevels
    go Stack
nslevels (Chunk Event
e) =
        case Event
e of
            EventBeginElement Name
n1 [(Name, [Content])]
as -> do
                Maybe (Flush Event)
mnext <- ConduitT (Flush Event) o m (Maybe (Flush Event))
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
peekC
                Bool
isClosed <-
                    case Maybe (Flush Event)
mnext of
                        Just (Chunk (EventEndElement Name
n2)) | Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2 -> do
                            Int -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                            Bool -> ConduitT (Flush Event) o m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        Maybe (Flush Event)
_ -> Bool -> ConduitT (Flush Event) o m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                let (Builder
token, Stack
nslevels') = Bool
-> Bool
-> [(Text, Text)]
-> Stack
-> Name
-> [(Name, [Content])]
-> (Builder, Stack)
mkBeginToken Bool
isPretty Bool
isClosed [(Text, Text)]
namespaces0 Stack
nslevels Name
n1 [(Name, [Content])]
as
                Flush Builder -> ConduitT (Flush Event) o m ()
yield' (Flush Builder -> ConduitT (Flush Event) o m ())
-> Flush Builder -> ConduitT (Flush Event) o m ()
forall a b. (a -> b) -> a -> b
$ Builder -> Flush Builder
forall a. a -> Flush a
Chunk Builder
token
                Stack -> ConduitT (Flush Event) o m ()
loop Stack
nslevels'
            Event
_ -> do
                let (Builder
token, Stack
nslevels') = Stack -> (Content -> Bool) -> Bool -> Event -> (Builder, Stack)
eventToToken Stack
nslevels Content -> Bool
useCDATA Bool
useXMLDecl Event
e
                Flush Builder -> ConduitT (Flush Event) o m ()
yield' (Flush Builder -> ConduitT (Flush Event) o m ())
-> Flush Builder -> ConduitT (Flush Event) o m ()
forall a b. (a -> b) -> a -> b
$ Builder -> Flush Builder
forall a. a -> Flush a
Chunk Builder
token
                Stack -> ConduitT (Flush Event) o m ()
loop Stack
nslevels'

eventToToken :: Stack -> (Content -> Bool) -> Bool -> Event -> (Builder, [NSLevel])
eventToToken :: Stack -> (Content -> Bool) -> Bool -> Event -> (Builder, Stack)
eventToToken Stack
s Content -> Bool
_ Bool
True Event
EventBeginDocument =
    (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ [TAttribute] -> Token
TokenXMLDeclaration
            [ (TName
"version", [Text -> Content
ContentText Text
"1.0"])
            , (TName
"encoding", [Text -> Content
ContentText Text
"UTF-8"])
            ]
     , Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
False Event
EventBeginDocument = (Builder
forall a. Monoid a => a
mempty, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ Event
EventEndDocument = (Builder
forall a. Monoid a => a
mempty, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventInstruction Instruction
i) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Instruction -> Token
TokenInstruction Instruction
i, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventBeginDoctype Text
n Maybe ExternalID
meid) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ExternalID -> [(Text, Text)] -> Token
TokenDoctype Text
n Maybe ExternalID
meid [], Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ Event
EventEndDoctype = (Builder
forall a. Monoid a => a
mempty, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventCDATA Text
t) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
t, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventEndElement Name
name) =
    (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ TName -> Token
TokenEndElement (TName -> Token) -> TName -> Token
forall a b. (a -> b) -> a -> b
$ NSLevel -> Name -> TName
nameToTName NSLevel
sl Name
name, Stack
s')
  where
    (NSLevel
sl:Stack
s') = Stack
s
eventToToken Stack
s Content -> Bool
useCDATA Bool
_ (EventContent Content
c)
    | Content -> Bool
useCDATA Content
c =
        case Content
c of
          ContentText Text
txt -> (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
txt, Stack
s)
          ContentEntity Text
txt -> (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
txt, Stack
s)
    | Bool
otherwise  = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Content -> Token
TokenContent Content
c, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventComment Text
t) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenComment Text
t, Stack
s)
eventToToken Stack
_ Content -> Bool
_ Bool
_ EventBeginElement{} = [Char] -> (Builder, Stack)
forall a. HasCallStack => [Char] -> a
error [Char]
"eventToToken on EventBeginElement" -- mkBeginToken False s name attrs

type Stack = [NSLevel]

nameToTName :: NSLevel -> Name -> TName
nameToTName :: NSLevel -> Name -> TName
nameToTName NSLevel
_ (Name Text
name Maybe Text
_ (Just Text
pref))
    | Text
pref Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"xml" = Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xml") Text
name
nameToTName NSLevel
_ (Name Text
name Maybe Text
Nothing Maybe Text
_) = Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
name -- invariant that this is true
nameToTName (NSLevel Maybe Text
def' Map Text Text
sl) (Name Text
name (Just Text
ns) Maybe Text
_)
    | Maybe Text
def' Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ns = Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
name
    | Bool
otherwise =
        case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ns Map Text Text
sl of
            Maybe Text
Nothing -> [Char] -> TName
forall a. HasCallStack => [Char] -> a
error [Char]
"nameToTName"
            Just Text
pref -> Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pref) Text
name

mkBeginToken :: Bool -- ^ pretty print attributes?
             -> Bool -- ^ self closing?
             -> [(Text, Text)] -- ^ namespaces to apply to top-level
             -> Stack
             -> Name
             -> [(Name, [Content])]
             -> (Builder, Stack)
mkBeginToken :: Bool
-> Bool
-> [(Text, Text)]
-> Stack
-> Name
-> [(Name, [Content])]
-> (Builder, Stack)
mkBeginToken Bool
isPretty Bool
isClosed [(Text, Text)]
namespaces0 Stack
s Name
name [(Name, [Content])]
attrs =
    (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ TName -> [TAttribute] -> Bool -> Int -> Token
TokenBeginElement TName
tname [TAttribute]
tattrs3 Bool
isClosed Int
indent,
     if Bool
isClosed then Stack
s else NSLevel
sl3 NSLevel -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
s)
  where
    indent :: Int
indent = if Bool
isPretty then Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Stack -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Stack
s else Int
0
    prevsl :: NSLevel
prevsl = case Stack
s of
                [] -> Maybe Text -> Map Text Text -> NSLevel
NSLevel Maybe Text
forall a. Maybe a
Nothing Map Text Text
forall k a. Map k a
Map.empty
                NSLevel
sl':Stack
_ -> NSLevel
sl'
    (NSLevel
sl1, TName
tname, [TAttribute]
tattrs1) = NSLevel -> Name -> (NSLevel, TName, [TAttribute])
newElemStack NSLevel
prevsl Name
name
    (NSLevel
sl2, [TAttribute]
tattrs2) = ((Name, [Content])
 -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute]))
-> (NSLevel, [TAttribute])
-> [(Name, [Content])]
-> (NSLevel, [TAttribute])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, [Content])
-> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute])
newAttrStack (NSLevel
sl1, [TAttribute]
tattrs1) ([(Name, [Content])] -> (NSLevel, [TAttribute]))
-> [(Name, [Content])] -> (NSLevel, [TAttribute])
forall a b. (a -> b) -> a -> b
$ [(Name, [Content])] -> [(Name, [Content])]
forall v. [(Name, v)] -> [(Name, v)]
nubAttrs [(Name, [Content])]
attrs
    (NSLevel
sl3, [TAttribute]
tattrs3) =
        case Stack
s of
            [] -> (NSLevel
sl2 { prefixes :: Map Text Text
prefixes = Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (NSLevel -> Map Text Text
prefixes NSLevel
sl2) (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
namespaceSL }, [TAttribute]
namespaceAttrs [TAttribute] -> [TAttribute] -> [TAttribute]
forall a. [a] -> [a] -> [a]
++ [TAttribute]
tattrs2)
            Stack
_ -> (NSLevel
sl2, [TAttribute]
tattrs2)

    ([(Text, Text)]
namespaceSL, [TAttribute]
namespaceAttrs) = [((Text, Text), TAttribute)] -> ([(Text, Text)], [TAttribute])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Text, Text), TAttribute)] -> ([(Text, Text)], [TAttribute]))
-> [((Text, Text), TAttribute)] -> ([(Text, Text)], [TAttribute])
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Maybe ((Text, Text), TAttribute))
-> [(Text, Text)] -> [((Text, Text), TAttribute)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Text) -> Maybe ((Text, Text), TAttribute)
unused [(Text, Text)]
namespaces0
    unused :: (Text, Text) -> Maybe ((Text, Text), TAttribute)
unused (Text
k, Text
v) =
        case TName -> [TAttribute] -> Maybe [Content]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TName
k' [TAttribute]
tattrs2 of
            Just{} -> Maybe ((Text, Text), TAttribute)
forall a. Maybe a
Nothing
            Maybe [Content]
Nothing -> ((Text, Text), TAttribute) -> Maybe ((Text, Text), TAttribute)
forall a. a -> Maybe a
Just ((Text
v, Text
k), (TName
k', [Content]
v'))
      where
        k' :: TName
k' = Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xmlns") Text
k
        v' :: [Content]
v' = [Text -> Content
ContentText Text
v]

newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute])
newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute])
newElemStack nsl :: NSLevel
nsl@(NSLevel Maybe Text
def' Map Text Text
_) (Name Text
local Maybe Text
ns Maybe Text
_)
    | Maybe Text
def' Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
ns = (NSLevel
nsl, Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
local, [])
newElemStack (NSLevel Maybe Text
_ Map Text Text
nsmap) (Name Text
local Maybe Text
Nothing Maybe Text
_) =
    (Maybe Text -> Map Text Text -> NSLevel
NSLevel Maybe Text
forall a. Maybe a
Nothing Map Text Text
nsmap, Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
local, [(Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
"xmlns", [])])
newElemStack (NSLevel Maybe Text
_ Map Text Text
nsmap) (Name Text
local (Just Text
ns) Maybe Text
Nothing) =
    (Maybe Text -> Map Text Text -> NSLevel
NSLevel (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ns) Map Text Text
nsmap, Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
local, [(Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
"xmlns", [Text -> Content
ContentText Text
ns])])
newElemStack (NSLevel Maybe Text
def' Map Text Text
nsmap) (Name Text
local (Just Text
ns) (Just Text
pref)) =
    case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ns Map Text Text
nsmap of
        Just Text
pref'
            | Text
pref Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
pref' ->
                ( Maybe Text -> Map Text Text -> NSLevel
NSLevel Maybe Text
def' Map Text Text
nsmap
                , Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pref) Text
local
                , []
                )
        Maybe Text
_ -> ( Maybe Text -> Map Text Text -> NSLevel
NSLevel Maybe Text
def' Map Text Text
nsmap'
             , Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pref) Text
local
             , [(Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xmlns") Text
pref, [Text -> Content
ContentText Text
ns])]
             )
  where
    nsmap' :: Map Text Text
nsmap' = Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
ns Text
pref Map Text Text
nsmap

newAttrStack :: (Name, [Content]) -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute])
newAttrStack :: (Name, [Content])
-> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute])
newAttrStack (Name
name, [Content]
value) (NSLevel Maybe Text
def' Map Text Text
nsmap, [TAttribute]
attrs) =
    (Maybe Text -> Map Text Text -> NSLevel
NSLevel Maybe Text
def' Map Text Text
nsmap', [TAttribute] -> [TAttribute]
addNS ([TAttribute] -> [TAttribute]) -> [TAttribute] -> [TAttribute]
forall a b. (a -> b) -> a -> b
$ (TName
tname, [Content]
value) TAttribute -> [TAttribute] -> [TAttribute]
forall a. a -> [a] -> [a]
: [TAttribute]
attrs)
  where
    (Map Text Text
nsmap', TName
tname, [TAttribute] -> [TAttribute]
addNS) =
        case Name
name of
            Name Text
local Maybe Text
Nothing Maybe Text
_ -> (Map Text Text
nsmap, Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
local, [TAttribute] -> [TAttribute]
forall a. a -> a
id)
            Name Text
local (Just Text
ns) Maybe Text
mpref ->
                let ppref :: Text
ppref = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"ns" Maybe Text
mpref
                    (Text
pref, [TAttribute] -> [TAttribute]
addNS') = Text
-> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute])
getPrefix Text
ppref Map Text Text
nsmap Text
ns
                 in (Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
ns Text
pref Map Text Text
nsmap, Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pref) Text
local, [TAttribute] -> [TAttribute]
addNS')

getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute])
getPrefix :: Text
-> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute])
getPrefix Text
_ Map Text Text
_ Text
"http://www.w3.org/XML/1998/namespace" = (Text
"xml", [TAttribute] -> [TAttribute]
forall a. a -> a
id)
getPrefix Text
ppref Map Text Text
nsmap Text
ns =
    case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ns Map Text Text
nsmap of
        Just Text
pref -> (Text
pref, [TAttribute] -> [TAttribute]
forall a. a -> a
id)
        Maybe Text
Nothing ->
            let pref :: Text
pref = Text -> [Text] -> Text
forall (t :: * -> *). Foldable t => Text -> t Text -> Text
findUnused Text
ppref ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Map Text Text -> [Text]
forall k a. Map k a -> [a]
Map.elems Map Text Text
nsmap
             in (Text
pref, (:) (Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xmlns") Text
pref, [Text -> Content
ContentText Text
ns]))
  where
    findUnused :: Text -> t Text -> Text
findUnused Text
x t Text
xs
        | Text
x Text -> t Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Text
xs = Text -> t Text -> Text
findUnused (Text
x Text -> Char -> Text
`T.snoc` Char
'_') t Text
xs
        | Bool
otherwise = Text
x

-- | Convert a stream of 'Event's into a prettified one, adding extra
-- whitespace. Note that this can change the meaning of your XML.
prettify :: Monad m => ConduitT (Flush Event) (Flush Event) m ()
prettify :: ConduitT (Flush Event) (Flush Event) m ()
prettify = Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
0

prettify' :: Monad m => Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' :: Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level =
    ConduitT (Flush Event) (Flush Event) m (Maybe (Flush Event))
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT (Flush Event) (Flush Event) m (Maybe (Flush Event))
-> (Maybe (Flush Event)
    -> ConduitT (Flush Event) (Flush Event) m ())
-> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT (Flush Event) (Flush Event) m ()
-> (Flush Event -> ConduitT (Flush Event) (Flush Event) m ())
-> Maybe (Flush Event)
-> ConduitT (Flush Event) (Flush Event) m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Flush Event -> ConduitT (Flush Event) (Flush Event) m ()
goC
  where
    yield' :: a -> ConduitT i (Flush a) m ()
yield' = Flush a -> ConduitT i (Flush a) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Flush a -> ConduitT i (Flush a) m ())
-> (a -> Flush a) -> a -> ConduitT i (Flush a) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Flush a
forall a. a -> Flush a
Chunk

    goC :: Flush Event -> ConduitT (Flush Event) (Flush Event) m ()
goC Flush Event
Flush = Flush Event -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Flush Event
forall a. Flush a
Flush ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    goC (Chunk Event
e) = Event -> ConduitT (Flush Event) (Flush Event) m ()
go Event
e

    go :: Event -> ConduitT (Flush Event) (Flush Event) m ()
go e :: Event
e@Event
EventBeginDocument = do
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' (Event -> ConduitT (Flush Event) (Flush Event) m ())
-> Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a b. (a -> b) -> a -> b
$ Content -> Event
EventContent (Content -> Event) -> Content -> Event
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
"\n"
        Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go e :: Event
e@EventBeginElement{} = do
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
before
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e
        Maybe (Flush Event)
mnext <- ConduitT (Flush Event) (Flush Event) m (Maybe (Flush Event))
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
peekC
        case Maybe (Flush Event)
mnext of
            Just (Chunk next :: Event
next@EventEndElement{}) -> do
                Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
next
                Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after
                Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
            Maybe (Flush Event)
_ -> do
                Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after
                Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' (Int -> ConduitT (Flush Event) (Flush Event) m ())
-> Int -> ConduitT (Flush Event) (Flush Event) m ()
forall a b. (a -> b) -> a -> b
$ Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    go e :: Event
e@EventEndElement{} = do
        let level' :: Int
level' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' (Event -> ConduitT (Flush Event) (Flush Event) m ())
-> Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a b. (a -> b) -> a -> b
$ Int -> Event
before' Int
level'
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after
        Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level'
    go (EventContent Content
c) = do
        [Content]
cs <- ([Content] -> [Content])
-> ConduitT (Flush Event) (Flush Event) m [Content]
forall (m :: * -> *) b o.
Monad m =>
([Content] -> b) -> ConduitT (Flush Event) o m b
takeContents (Content
cContent -> [Content] -> [Content]
forall a. a -> [a] -> [a]
:)
        let cs' :: [Content]
cs' = (Content -> Maybe Content) -> [Content] -> [Content]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Content -> Maybe Content
normalize [Content]
cs
        case [Content]
cs' of
            [] -> () -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [Content]
_ -> do
                Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
before
                (Content -> ConduitT (Flush Event) (Flush Event) m ())
-> [Content] -> ConduitT (Flush Event) (Flush Event) m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' (Event -> ConduitT (Flush Event) (Flush Event) m ())
-> (Content -> Event)
-> Content
-> ConduitT (Flush Event) (Flush Event) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Event
EventContent) [Content]
cs'
                Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after
        Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go (EventCDATA Text
t) = Event -> ConduitT (Flush Event) (Flush Event) m ()
go (Event -> ConduitT (Flush Event) (Flush Event) m ())
-> Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a b. (a -> b) -> a -> b
$ Content -> Event
EventContent (Content -> Event) -> Content -> Event
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t
    go e :: Event
e@EventInstruction{} = do
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
before
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after
        Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go (EventComment Text
t) = do
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
before
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' (Event -> ConduitT (Flush Event) (Flush Event) m ())
-> Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a b. (a -> b) -> a -> b
$ Text -> Event
EventComment (Text -> Event) -> Text -> Event
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ Text
" "
            , [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
t
            , Text
" "
            ]
        Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after
        Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level

    go e :: Event
e@Event
EventEndDocument = Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go e :: Event
e@EventBeginDoctype{} = Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go e :: Event
e@EventEndDoctype{} = Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
e ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Event -> ConduitT (Flush Event) (Flush Event) m ()
forall a i. a -> ConduitT i (Flush a) m ()
yield' Event
after ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
-> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ConduitT (Flush Event) (Flush Event) m ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level

    takeContents :: ([Content] -> b) -> ConduitT (Flush Event) o m b
takeContents [Content] -> b
front = do
        Maybe (Flush Event)
me <- ConduitT (Flush Event) o m (Maybe (Flush Event))
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
peekC
        case Maybe (Flush Event)
me of
            Just (Chunk (EventContent Content
c)) -> do
                Int -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                ([Content] -> b) -> ConduitT (Flush Event) o m b
takeContents (([Content] -> b) -> ConduitT (Flush Event) o m b)
-> ([Content] -> b) -> ConduitT (Flush Event) o m b
forall a b. (a -> b) -> a -> b
$ [Content] -> b
front ([Content] -> b) -> ([Content] -> [Content]) -> [Content] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content
cContent -> [Content] -> [Content]
forall a. a -> [a] -> [a]
:)
            Just (Chunk (EventCDATA Text
t)) -> do
                Int -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                ([Content] -> b) -> ConduitT (Flush Event) o m b
takeContents (([Content] -> b) -> ConduitT (Flush Event) o m b)
-> ([Content] -> b) -> ConduitT (Flush Event) o m b
forall a b. (a -> b) -> a -> b
$ [Content] -> b
front ([Content] -> b) -> ([Content] -> [Content]) -> [Content] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Content
ContentText Text
tContent -> [Content] -> [Content]
forall a. a -> [a] -> [a]
:)
            Maybe (Flush Event)
_ -> b -> ConduitT (Flush Event) o m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ConduitT (Flush Event) o m b)
-> b -> ConduitT (Flush Event) o m b
forall a b. (a -> b) -> a -> b
$ [Content] -> b
front []

    normalize :: Content -> Maybe Content
normalize (ContentText Text
t)
        | Text -> Bool
T.null Text
t' = Maybe Content
forall a. Maybe a
Nothing
        | Bool
otherwise = Content -> Maybe Content
forall a. a -> Maybe a
Just (Content -> Maybe Content) -> Content -> Maybe Content
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t'
      where
        t' :: Text
t' = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
t
    normalize Content
c = Content -> Maybe Content
forall a. a -> Maybe a
Just Content
c

    before :: Event
before = Content -> Event
EventContent (Content -> Event) -> Content -> Event
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate Int
level Text
"    "
    before' :: Int -> Event
before' Int
l = Content -> Event
EventContent (Content -> Event) -> Content -> Event
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate Int
l Text
"    "
    after :: Event
after = Content -> Event
EventContent (Content -> Event) -> Content -> Event
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
"\n"

nubAttrs :: [(Name, v)] -> [(Name, v)]
nubAttrs :: [(Name, v)] -> [(Name, v)]
nubAttrs [(Name, v)]
orig =
    [(Name, v)] -> [(Name, v)]
front []
  where
    ([(Name, v)] -> [(Name, v)]
front, Set Name
_) = (([(Name, v)] -> [(Name, v)], Set Name)
 -> (Name, v) -> ([(Name, v)] -> [(Name, v)], Set Name))
-> ([(Name, v)] -> [(Name, v)], Set Name)
-> [(Name, v)]
-> ([(Name, v)] -> [(Name, v)], Set Name)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Name, v)] -> [(Name, v)], Set Name)
-> (Name, v) -> ([(Name, v)] -> [(Name, v)], Set Name)
forall a b c.
Ord a =>
([(a, b)] -> c, Set a) -> (a, b) -> ([(a, b)] -> c, Set a)
go ([(Name, v)] -> [(Name, v)]
forall a. a -> a
id, Set Name
forall a. Set a
Set.empty) [(Name, v)]
orig
    go :: ([(a, b)] -> c, Set a) -> (a, b) -> ([(a, b)] -> c, Set a)
go ([(a, b)] -> c
dlist, Set a
used) (a
k, b
v)
        | a
k a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
used = ([(a, b)] -> c
dlist, Set a
used)
        | Bool
otherwise = ([(a, b)] -> c
dlist ([(a, b)] -> c) -> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a
k, b
v)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:), a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
used)


-- | Generate a complete XML 'Element'.
tag :: (Monad m) => Name -> Attributes -> ConduitT i Event m ()  -- ^ 'Element''s subnodes.
                                       -> ConduitT i Event m ()
tag :: Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
name (Attributes [(Name, [Content])]
a) ConduitT i Event m ()
content' = do
  Event -> ConduitT i Event m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Event -> ConduitT i Event m ()) -> Event -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> Event
EventBeginElement Name
name [(Name, [Content])]
a
  ConduitT i Event m ()
content'
  Event -> ConduitT i Event m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Event -> ConduitT i Event m ()) -> Event -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ Name -> Event
EventEndElement Name
name

-- | Generate a textual 'EventContent'.
content :: (Monad m) => Text -> ConduitT i Event m ()
content :: Text -> ConduitT i Event m ()
content = Event -> ConduitT i Event m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Event -> ConduitT i Event m ())
-> (Text -> Event) -> Text -> ConduitT i Event m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Event
EventContent (Content -> Event) -> (Text -> Content) -> Text -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Content
ContentText

-- | A list of attributes.
data Attributes = Attributes [(Name, [Content])]

instance Monoid Attributes where
  mempty :: Attributes
mempty = [(Name, [Content])] -> Attributes
Attributes [(Name, [Content])]
forall a. Monoid a => a
mempty
#if !MIN_VERSION_base(4,11,0)
  (Attributes a) `mappend` (Attributes b) = Attributes (a `mappend` b)
#else
instance Semigroup Attributes where
  (Attributes [(Name, [Content])]
a) <> :: Attributes -> Attributes -> Attributes
<> (Attributes [(Name, [Content])]
b) = [(Name, [Content])] -> Attributes
Attributes ([(Name, [Content])]
a [(Name, [Content])] -> [(Name, [Content])] -> [(Name, [Content])]
forall a. Semigroup a => a -> a -> a
<> [(Name, [Content])]
b)
#endif

-- | Generate a single attribute.
attr :: Name        -- ^ Attribute's name
     -> Text        -- ^ Attribute's value
     -> Attributes
attr :: Name -> Text -> Attributes
attr Name
name Text
value = [(Name, [Content])] -> Attributes
Attributes [(Name
name, [Text -> Content
ContentText Text
value])]

-- | Helper function that generates a valid attribute if input isn't 'Nothing', or 'mempty' otherwise.
optionalAttr :: Name -> Maybe Text -> Attributes
optionalAttr :: Name -> Maybe Text -> Attributes
optionalAttr Name
name = Attributes -> (Text -> Attributes) -> Maybe Text -> Attributes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attributes
forall a. Monoid a => a
mempty (Name -> Text -> Attributes
attr Name
name)