{-# 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 :: RenderSettings -> ConduitT Event ByteString m ()
renderBytes rs :: RenderSettings
rs = RenderSettings -> ConduitT Event Builder m ()
forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT Event Builder m ()
renderBuilder RenderSettings
rs ConduitT Event Builder m ()
-> ConduitT Builder ByteString m ()
-> ConduitT Event ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Builder ByteString m ()
forall (m :: * -> *).
PrimMonad m =>
ConduitT Builder ByteString m ()
builderToByteString
renderText :: (PrimMonad m, MonadThrow m) => RenderSettings -> ConduitT Event Text m ()
renderText :: RenderSettings -> ConduitT Event Text m ()
renderText rs :: RenderSettings
rs = RenderSettings -> ConduitT Event ByteString m ()
forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
rs ConduitT Event ByteString m ()
-> ConduitT ByteString Text m () -> ConduitT Event Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT 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)]
, 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 :: 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
}
orderAttrs :: [(Name, [Name])] ->
Name -> Map Name Text -> [(Name, Text)]
orderAttrs :: [(Name, [Name])] -> Name -> Map Name Text -> [(Name, Text)]
orderAttrs orderSpec :: [(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 elt :: Name
elt attrMap :: 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 attr' :: 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
renderBuilder :: Monad m => RenderSettings -> ConduitT Event Builder m ()
renderBuilder :: RenderSettings -> ConduitT Event Builder m ()
renderBuilder settings :: 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 ()
-> ConduitT (Flush Event) Builder m ()
-> ConduitT Event Builder m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Flush Builder -> ConduitT (Flush Event) Builder m ())
-> RenderSettings -> ConduitT (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 -> ConduitT (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 = () -> ConduitT i o m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
yield' (Chunk bs :: o
bs) = o -> ConduitT i o m ()
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 :: 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' yield' :: Flush Builder -> ConduitT (Flush Event) o m ()
yield' settings :: 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 =>
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' = (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 yield' :: 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 nslevels :: Stack
nslevels = ConduitT (Flush Event) o m (Maybe (Flush Event))
forall (m :: * -> *) i o. Monad m => ConduitT i o 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 nslevels :: Stack
nslevels 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 nslevels :: Stack
nslevels (Chunk e :: Event
e) =
case Event
e of
EventBeginElement n1 :: Name
n1 as :: [(Name, [Content])]
as -> do
Maybe (Flush Event)
mnext <- ConduitT (Flush Event) o m (Maybe (Flush Event))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
peekC
Bool
isClosed <-
case Maybe (Flush Event)
mnext of
Just (Chunk (EventEndElement n2 :: 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 1
Bool -> ConduitT (Flush Event) o m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
_ -> Bool -> ConduitT (Flush Event) o m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
let (token :: Builder
token, nslevels' :: 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'
_ -> do
let (token :: Builder
token, nslevels' :: 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 s :: Stack
s _ True EventBeginDocument =
(Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ [TAttribute] -> Token
TokenXMLDeclaration
[ ("version", [Text -> Content
ContentText "1.0"])
, ("encoding", [Text -> Content
ContentText "UTF-8"])
]
, Stack
s)
eventToToken s :: Stack
s _ False EventBeginDocument = (Builder
forall a. Monoid a => a
mempty, Stack
s)
eventToToken s :: Stack
s _ _ EventEndDocument = (Builder
forall a. Monoid a => a
mempty, Stack
s)
eventToToken s :: Stack
s _ _ (EventInstruction i :: Instruction
i) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Instruction -> Token
TokenInstruction Instruction
i, Stack
s)
eventToToken s :: Stack
s _ _ (EventBeginDoctype n :: Text
n meid :: 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 s :: Stack
s _ _ EventEndDoctype = (Builder
forall a. Monoid a => a
mempty, Stack
s)
eventToToken s :: Stack
s _ _ (EventCDATA t :: Text
t) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
t, Stack
s)
eventToToken s :: Stack
s _ _ (EventEndElement name :: 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
(sl :: NSLevel
sl:s' :: Stack
s') = Stack
s
eventToToken s :: Stack
s useCDATA :: Content -> Bool
useCDATA _ (EventContent c :: Content
c)
| Content -> Bool
useCDATA Content
c =
case Content
c of
ContentText txt :: Text
txt -> (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenCDATA Text
txt, Stack
s)
ContentEntity txt :: 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 s :: Stack
s _ _ (EventComment t :: Text
t) = (Token -> Builder
tokenToBuilder (Token -> Builder) -> Token -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Token
TokenComment Text
t, Stack
s)
eventToToken _ _ _ EventBeginElement{} = [Char] -> (Builder, Stack)
forall a. HasCallStack => [Char] -> a
error "eventToToken on EventBeginElement"
type Stack = [NSLevel]
nameToTName :: NSLevel -> Name -> TName
nameToTName :: NSLevel -> Name -> TName
nameToTName _ (Name name :: Text
name _ (Just pref :: Text
pref))
| Text
pref Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "xml" = Maybe Text -> Text -> TName
TName (Text -> Maybe Text
forall a. a -> Maybe a
Just "xml") Text
name
nameToTName _ (Name name :: Text
name Nothing _) = Maybe Text -> Text -> TName
TName Maybe Text
forall a. Maybe a
Nothing Text
name
nameToTName (NSLevel def' :: Maybe Text
def' sl :: Map Text Text
sl) (Name name :: Text
name (Just ns :: Text
ns) _)
| 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
Nothing -> [Char] -> TName
forall a. HasCallStack => [Char] -> a
error "nameToTName"
Just pref :: Text
pref -> Maybe Text -> Text -> TName
TName (Text -> Maybe Text
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 isPretty :: Bool
isPretty isClosed :: Bool
isClosed namespaces0 :: [(Text, Text)]
namespaces0 s :: Stack
s name :: Name
name attrs :: [(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 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 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
sl' :: NSLevel
sl':_ -> NSLevel
sl'
(sl1 :: NSLevel
sl1, tname :: TName
tname, tattrs1 :: [TAttribute]
tattrs1) = NSLevel -> Name -> (NSLevel, TName, [TAttribute])
newElemStack NSLevel
prevsl Name
name
(sl2 :: NSLevel
sl2, tattrs2 :: [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
(sl3 :: NSLevel
sl3, tattrs3 :: [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)
_ -> (NSLevel
sl2, [TAttribute]
tattrs2)
(namespaceSL :: [(Text, Text)]
namespaceSL, namespaceAttrs :: [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 (k :: Text
k, v :: 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
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 "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 def' :: Maybe Text
def' _) (Name local :: Text
local ns :: Maybe Text
ns _)
| 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 _ nsmap :: Map Text Text
nsmap) (Name local :: Text
local Nothing _) =
(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 "xmlns", [])])
newElemStack (NSLevel _ nsmap :: Map Text Text
nsmap) (Name local :: Text
local (Just ns :: Text
ns) 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 "xmlns", [Text -> Content
ContentText Text
ns])])
newElemStack (NSLevel def' :: Maybe Text
def' nsmap :: Map Text Text
nsmap) (Name local :: Text
local (Just ns :: Text
ns) (Just pref :: 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 pref' :: 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 -> 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 "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
name, value :: [Content]
value) (NSLevel def' :: Maybe Text
def' nsmap :: Map Text Text
nsmap, attrs :: [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
(nsmap' :: Map Text Text
nsmap', tname :: TName
tname, addNS :: [TAttribute] -> [TAttribute]
addNS) =
case Name
name of
Name local :: Text
local Nothing _ -> (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 local :: Text
local (Just ns :: Text
ns) mpref :: Maybe Text
mpref ->
let ppref :: Text
ppref = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "ns" Maybe Text
mpref
(pref :: Text
pref, addNS' :: [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 _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", [TAttribute] -> [TAttribute]
forall a. a -> a
id)
getPrefix ppref :: Text
ppref nsmap :: Map Text Text
nsmap ns :: 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 pref :: Text
pref -> (Text
pref, [TAttribute] -> [TAttribute]
forall a. a -> a
id)
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 "xmlns") Text
pref, [Text -> Content
ContentText Text
ns]))
where
findUnused :: Text -> t Text -> Text
findUnused x :: Text
x xs :: 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` '_') t Text
xs
| Bool
otherwise = Text
x
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' 0
prettify' :: Monad m => Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' :: Int -> ConduitT (Flush Event) (Flush Event) m ()
prettify' level :: Int
level =
ConduitT (Flush Event) (Flush Event) m (Maybe (Flush Event))
forall (m :: * -> *) i o. Monad m => ConduitT i o 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 = 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 e :: 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 "\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 :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
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 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
_ -> 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
+ 1
go e :: Event
e@EventEndElement{} = do
let level' :: Int
level' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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 c :: 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 ()
_ -> 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 t :: 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 t :: 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
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
t
, " "
]
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 front :: [Content] -> b
front = do
Maybe (Flush Event)
me <- ConduitT (Flush Event) o m (Maybe (Flush Event))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
peekC
case Maybe (Flush Event)
me of
Just (Chunk (EventContent c :: Content
c)) -> do
Int -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC 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 t :: Text
t)) -> do
Int -> ConduitT (Flush Event) o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
dropC 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]
:)
_ -> 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 t :: 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 c :: 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 " "
before' :: Int -> Event
before' l :: 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 " "
after :: Event
after = Content -> Event
EventContent (Content -> Event) -> Content -> Event
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText "\n"
nubAttrs :: [(Name, v)] -> [(Name, v)]
nubAttrs :: [(Name, v)] -> [(Name, v)]
nubAttrs orig :: [(Name, v)]
orig =
[(Name, v)] -> [(Name, v)]
front []
where
(front :: [(Name, v)] -> [(Name, v)]
front, _) = (([(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 (dlist :: [(a, b)] -> c
dlist, used :: Set a
used) (k :: a
k, v :: 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)
tag :: (Monad m) => Name -> Attributes -> ConduitT i Event m ()
-> ConduitT i Event m ()
tag :: Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag name :: Name
name (Attributes a :: [(Name, [Content])]
a) content' :: 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
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
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 a :: [(Name, [Content])]
a) <> :: Attributes -> Attributes -> Attributes
<> (Attributes b :: [(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
attr :: Name
-> Text
-> Attributes
attr :: Name -> Text -> Attributes
attr name :: Name
name value :: 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
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)