{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Text.XML.Stream.Render
(
renderBuilder
, renderBuilderFlush
, renderBytes
, renderText
, prettify
, RenderSettings
, def
, rsPretty
, rsNamespaces
, rsAttrOrder
, rsUseCDATA
, rsXMLDeclaration
, orderAttrs
, tag
, content
, 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
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
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)]
, RenderSettings -> Name -> Map Name Text -> [(Name, Text)]
rsAttrOrder :: Name -> Map.Map Name Text -> [(Name, Text)]
, RenderSettings -> Content -> Bool
rsUseCDATA :: Content -> Bool
, RenderSettings -> Bool
rsXMLDeclaration :: Bool
}
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
}
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
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
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"
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
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
-> Bool
-> [(Text, Text)]
-> 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
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)
tag :: (Monad m) => Name -> Attributes -> ConduitT i Event m ()
-> 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
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
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
attr :: Name
-> Text
-> Attributes
attr :: Name -> Text -> Attributes
attr Name
name Text
value = [(Name, [Content])] -> Attributes
Attributes [(Name
name, [Text -> Content
ContentText Text
value])]
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)