{-# 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 :: forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
rs = forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT Event Builder m ()
renderBuilder RenderSettings
rs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 :: forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
renderText RenderSettings
rs = forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
rs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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
        { rsPretty :: Bool
rsPretty = Bool
False
        , rsNamespaces :: [(Text, Text)]
rsNamespaces = []
        , rsAttrOrder :: Name -> Map Name Text -> [(Name, Text)]
rsAttrOrder = forall a b. a -> b -> a
const forall k a. Map k a -> [(k, a)]
Map.toList
        , rsUseCDATA :: Content -> Bool
rsUseCDATA = 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 = forall {a}. Name -> Map Name a -> [(Name, a)]
order
  where
    order :: Name -> Map Name a -> [(Name, a)]
order Name
elt Map Name a
attrMap =
      let initialAttrs :: [Name]
initialAttrs = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
elt [(Name, [Name])]
orderSpec
          mkPair :: Name -> Maybe (Name, a)
mkPair Name
attr' = (,) Name
attr' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
attr' Map Name a
attrMap
          otherAttrMap :: Map Name a
otherAttrMap =
            forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
initialAttrs)) Map Name a
attrMap
      in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Name -> Maybe (Name, a)
mkPair [Name]
initialAttrs forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [(k, a)]
Map.toAscList Map Name a
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 :: forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT Event Builder m ()
renderBuilder RenderSettings
settings = forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC forall a. a -> Flush a
Chunk forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
Monad m =>
(Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderBuilder' 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    yield' (Chunk o
bs) = 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 :: forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT (Flush Event) (Flush Builder) m ()
renderBuilderFlush = forall (m :: * -> *) o.
Monad m =>
(Flush Builder -> ConduitT (Flush Event) o m ())
-> RenderSettings -> ConduitT (Flush Event) o m ()
renderBuilder' 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' :: forall (m :: * -> *) o.
Monad m =>
(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 forall (m :: * -> *).
Monad m =>
ConduitT (Flush Event) (Flush Event) m ()
prettify forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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' = 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 :: 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 { 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 = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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' forall a. Flush a
Flush 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 <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
peekC
                Bool
isClosed <-
                    case Maybe (Flush Event)
mnext of
                        Just (Chunk (EventEndElement Name
n2)) | Name
n1 forall a. Eq a => a -> a -> Bool
== Name
n2 -> do
                            forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        Maybe (Flush Event)
_ -> 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' forall a b. (a -> b) -> a -> b
$ 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' forall a b. (a -> b) -> a -> b
$ 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 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 = (forall a. Monoid a => a
mempty, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ Event
EventEndDocument = (forall a. Monoid a => a
mempty, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventInstruction Instruction
i) = (Token -> Builder
tokenToBuilder 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 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 = (forall a. Monoid a => a
mempty, Stack
s)
eventToToken Stack
s Content -> Bool
_ Bool
_ (EventCDATA Text
t) = (Token -> Builder
tokenToBuilder 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 forall a b. (a -> b) -> a -> b
$ TName -> Token
TokenEndElement 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 forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
txt, Stack
s)
          ContentEntity Text
txt -> (Token -> Builder
tokenToBuilder forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
txt, Stack
s)
    | Bool
otherwise  = (Token -> Builder
tokenToBuilder 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 forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenComment Text
t, Stack
s)
eventToToken Stack
_ Content -> Bool
_ Bool
_ EventBeginElement{} = 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 forall a. Eq a => a -> a -> Bool
== Text
"xml" = Maybe Text -> Text -> TName
TName (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 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' forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
ns = Maybe Text -> Text -> TName
TName forall a. Maybe a
Nothing Text
name
    | Bool
otherwise =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ns Map Text Text
sl of
            Maybe Text
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"nameToTName"
            Just Text
pref -> Maybe Text -> Text -> TName
TName (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 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 forall a. a -> [a] -> [a]
: Stack
s)
  where
    indent :: Int
indent = if Bool
isPretty then Int
2 forall a. Num a => a -> a -> a
+ Int
4 forall a. Num a => a -> a -> a
* 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 forall a. Maybe a
Nothing 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) = 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) forall a b. (a -> b) -> a -> b
$ 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 = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (NSLevel -> Map Text Text
prefixes NSLevel
sl2) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
namespaceSL }, [TAttribute]
namespaceAttrs forall a. [a] -> [a] -> [a]
++ [TAttribute]
tattrs2)
            Stack
_ -> (NSLevel
sl2, [TAttribute]
tattrs2)

    ([(Text, Text)]
namespaceSL, [TAttribute]
namespaceAttrs) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TName
k' [TAttribute]
tattrs2 of
            Just{} -> forall a. Maybe a
Nothing
            Maybe [Content]
Nothing -> forall a. a -> Maybe a
Just ((Text
v, Text
k), (TName
k', [Content]
v'))
      where
        k' :: TName
k' = Maybe Text -> Text -> TName
TName (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' forall a. Eq a => a -> a -> Bool
== Maybe Text
ns = (NSLevel
nsl, Maybe Text -> Text -> TName
TName 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 forall a. Maybe a
Nothing Map Text Text
nsmap, Maybe Text -> Text -> TName
TName forall a. Maybe a
Nothing Text
local, [(Maybe Text -> Text -> TName
TName 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 (forall a. a -> Maybe a
Just Text
ns) Map Text Text
nsmap, Maybe Text -> Text -> TName
TName forall a. Maybe a
Nothing Text
local, [(Maybe Text -> Text -> TName
TName 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 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 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 (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 (forall a. a -> Maybe a
Just Text
pref) Text
local
             , [(Maybe Text -> Text -> TName
TName (forall a. a -> Maybe a
Just Text
"xmlns") Text
pref, [Text -> Content
ContentText Text
ns])]
             )
  where
    nsmap' :: Map Text Text
nsmap' = 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 forall a b. (a -> b) -> a -> b
$ (TName
tname, [Content]
value) 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 forall a. Maybe a
Nothing Text
local, forall a. a -> a
id)
            Name Text
local (Just Text
ns) Maybe Text
mpref ->
                let ppref :: Text
ppref = 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 (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 (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", forall a. a -> a
id)
getPrefix Text
ppref Map Text Text
nsmap Text
ns =
    case 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, forall a. a -> a
id)
        Maybe Text
Nothing ->
            let pref :: Text
pref = forall {t :: * -> *}. Foldable t => Text -> t Text -> Text
findUnused Text
ppref forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Text Text
nsmap
             in (Text
pref, (:) (Maybe Text -> Text -> TName
TName (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 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 :: forall (m :: * -> *).
Monad m =>
ConduitT (Flush Event) (Flush Event) m ()
prettify = 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' :: forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level =
    forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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' = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Flush a
Chunk

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

    go e :: Event
e@Event
EventEndDocument = forall {a} {i}. a -> ConduitT i (Flush a) m ()
yield' Event
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go e :: Event
e@EventBeginDoctype{} = forall {a} {i}. a -> ConduitT i (Flush a) m ()
yield' Event
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
Monad m =>
Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' Int
level
    go e :: Event
e@EventEndDoctype{} = forall {a} {i}. a -> ConduitT i (Flush a) m ()
yield' Event
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {a} {i}. a -> ConduitT i (Flush a) m ()
yield' Event
after forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
peekC
        case Maybe (Flush Event)
me of
            Just (Chunk (EventContent Content
c)) -> do
                forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                ([Content] -> b) -> ConduitT (Flush Event) o m b
takeContents forall a b. (a -> b) -> a -> b
$ [Content] -> b
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content
cforall a. a -> [a] -> [a]
:)
            Just (Chunk (EventCDATA Text
t)) -> do
                forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC Int
1
                ([Content] -> b) -> ConduitT (Flush Event) o m b
takeContents forall a b. (a -> b) -> a -> b
$ [Content] -> b
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Content
ContentText Text
tforall a. a -> [a] -> [a]
:)
            Maybe (Flush Event)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content] -> b
front []

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

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

nubAttrs :: [(Name, v)] -> [(Name, v)]
nubAttrs :: forall v. [(Name, v)] -> [(Name, v)]
nubAttrs [(Name, v)]
orig =
    [(Name, v)] -> [(Name, v)]
front []
  where
    ([(Name, v)] -> [(Name, v)]
front, Set Name
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {b} {c}.
Ord a =>
([(a, b)] -> c, Set a) -> (a, b) -> ([(a, b)] -> c, Set a)
go (forall a. a -> a
id, 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a
k, b
v)forall a. a -> [a] -> [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 :: forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
name (Attributes [(Name, [Content])]
a) ConduitT i Event m ()
content' = do
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> Event
EventBeginElement Name
name [(Name, [Content])]
a
  ConduitT i Event m ()
content'
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield 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 :: forall (m :: * -> *) i. Monad m => Text -> ConduitT i Event m ()
content = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Event
EventContent 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 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 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Name -> Text -> Attributes
attr Name
name)