{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
module Text.XML.Generator (
Xml
, Doc, DocInfo(..), doc, defaultDocInfo
, Namespace, Prefix, Uri, Name
, namespace, noNamespace, defaultNamespace
, Elem, xelem, xelemQ, xelemEmpty, xelemQEmpty, AddChildren
, xelems, noElems, xelemWithText, (<>), (<#>)
, Attr, xattr, xattrQ, xattrQRaw
, xattrs, noAttrs
, TextContent
, xtext, xtextRaw, xentityRef
, xempty , Misc(xprocessingInstruction, xcomment)
, xrender
, XmlOutput(fromBuilder), Renderable
, xhtmlFramesetDocInfo, xhtmlStrictDocInfo, xhtmlTransitionalDocInfo
, xhtmlRootElem
) where
import Prelude hiding (elem)
import Control.Monad.Reader (Reader(..), ask, asks, runReader)
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Monoid as M
import Blaze.ByteString.Builder
import qualified Blaze.ByteString.Builder as Blaze
import Blaze.ByteString.Builder.Char.Utf8
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Char (isPrint, ord)
import qualified Data.String as S
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup
import Data.Monoid hiding (mconcat, (<>))
#else
import Data.Monoid hiding (mconcat)
#endif
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,5,0)
#define BASE_AT_LEAST_4_5_0_0
#endif
#else
#if __GLASGOW_HASKELL__ >= 704
#define BASE_AT_LEAST_4_5_0_0
#endif
#endif
newtype Elem = Elem { Elem -> Builder
unElem :: Builder }
newtype Attr = Attr { Attr -> Builder
unAttr :: Builder }
newtype Doc = Doc { Doc -> Builder
unDoc :: Builder }
type Prefix = T.Text
type Uri = T.Text
type Name = T.Text
nameBuilder :: Name -> Builder
nameBuilder :: Text -> Builder
nameBuilder = Text -> Builder
fromText
data Namespace
= NoNamespace
| DefaultNamespace
| QualifiedNamespace Prefix Uri
deriving (Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> String
(Int -> Namespace -> ShowS)
-> (Namespace -> String)
-> ([Namespace] -> ShowS)
-> Show Namespace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Namespace -> ShowS
showsPrec :: Int -> Namespace -> ShowS
$cshow :: Namespace -> String
show :: Namespace -> String
$cshowList :: [Namespace] -> ShowS
showList :: [Namespace] -> ShowS
Show, Namespace -> Namespace -> Bool
(Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool) -> Eq Namespace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
/= :: Namespace -> Namespace -> Bool
Eq)
namespace :: Prefix -> Uri -> Namespace
namespace :: Text -> Text -> Namespace
namespace Text
p Text
u = if Text -> Bool
T.null Text
u
then String -> Namespace
forall a. HasCallStack => String -> a
error String
"Text.XML.Generator.ns: namespace URI must not be empty"
else Text -> Text -> Namespace
QualifiedNamespace Text
p Text
u
noNamespace :: Namespace
noNamespace :: Namespace
noNamespace = Namespace
NoNamespace
defaultNamespace :: Namespace
defaultNamespace :: Namespace
defaultNamespace = Namespace
DefaultNamespace
data NsEnv = NsEnv { NsEnv -> Map Text Text
ne_namespaceMap :: Map.Map Prefix Uri
, NsEnv -> Bool
ne_noNamespaceInUse :: Bool }
emptyNsEnv :: NsEnv
emptyNsEnv :: NsEnv
emptyNsEnv = Map Text Text -> Bool -> NsEnv
NsEnv Map Text Text
forall k a. Map k a
Map.empty Bool
False
newtype Xml t = Xml { forall t. Xml t -> Reader NsEnv (t, NsEnv)
unXml :: Reader NsEnv (t, NsEnv) }
runXml :: NsEnv -> Xml t -> (t, NsEnv)
runXml :: forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
nsEnv (Xml Reader NsEnv (t, NsEnv)
x) = Reader NsEnv (t, NsEnv) -> NsEnv -> (t, NsEnv)
forall r a. Reader r a -> r -> a
runReader Reader NsEnv (t, NsEnv)
x NsEnv
nsEnv
xempty :: Renderable t => Xml t
xempty :: forall t. Renderable t => Xml t
xempty = Reader NsEnv (t, NsEnv) -> Xml t
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (t, NsEnv) -> Xml t)
-> Reader NsEnv (t, NsEnv) -> Xml t
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(t, NsEnv) -> Reader NsEnv (t, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> t
forall t. Renderable t => Builder -> t
mkRenderable Builder
forall a. Monoid a => a
mempty, NsEnv
env)
data DocInfo
= DocInfo
{ DocInfo -> Bool
docInfo_standalone :: Bool
, DocInfo -> Maybe String
docInfo_docType :: Maybe String
, DocInfo -> Xml Doc
docInfo_preMisc :: Xml Doc
, DocInfo -> Xml Doc
docInfo_postMisc :: Xml Doc
}
defaultDocInfo :: DocInfo
defaultDocInfo :: DocInfo
defaultDocInfo = DocInfo { docInfo_standalone :: Bool
docInfo_standalone = Bool
True
, docInfo_docType :: Maybe String
docInfo_docType = Maybe String
forall a. Maybe a
Nothing
, docInfo_preMisc :: Xml Doc
docInfo_preMisc = Xml Doc
forall t. Renderable t => Xml t
xempty
, docInfo_postMisc :: Xml Doc
docInfo_postMisc = Xml Doc
forall t. Renderable t => Xml t
xempty }
doc :: DocInfo -> Xml Elem -> Xml Doc
doc :: DocInfo -> Xml Elem -> Xml Doc
doc DocInfo
di Xml Elem
rootElem = Reader NsEnv (Doc, NsEnv) -> Xml Doc
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Doc, NsEnv) -> Xml Doc)
-> Reader NsEnv (Doc, NsEnv) -> Xml Doc
forall a b. (a -> b) -> a -> b
$
do let prologBuf :: Builder
prologBuf = String -> Builder
fromString String
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString (if Bool
standalone then String
"yes" else String
"no") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString String
"\"?>\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
case Maybe String
mDocType of
Maybe String
Nothing -> Builder
forall a. Monoid a => a
mempty
Just String
s -> String -> Builder
fromString String
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
"\n"
NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let Doc Builder
preBuf = (Doc, NsEnv) -> Doc
forall a b. (a, b) -> a
fst ((Doc, NsEnv) -> Doc) -> (Doc, NsEnv) -> Doc
forall a b. (a -> b) -> a -> b
$ NsEnv -> Xml Doc -> (Doc, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Doc
preMisc
Elem Builder
elemBuf = (Elem, NsEnv) -> Elem
forall a b. (a, b) -> a
fst ((Elem, NsEnv) -> Elem) -> (Elem, NsEnv) -> Elem
forall a b. (a -> b) -> a -> b
$ NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Elem
rootElem
Doc Builder
postBuf = (Doc, NsEnv) -> Doc
forall a b. (a, b) -> a
fst ((Doc, NsEnv) -> Doc) -> (Doc, NsEnv) -> Doc
forall a b. (a -> b) -> a -> b
$ NsEnv -> Xml Doc -> (Doc, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Doc
postMisc
(Doc, NsEnv) -> Reader NsEnv (Doc, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Doc, NsEnv) -> Reader NsEnv (Doc, NsEnv))
-> (Doc, NsEnv) -> Reader NsEnv (Doc, NsEnv)
forall a b. (a -> b) -> a -> b
$ (Builder -> Doc
Doc (Builder -> Doc) -> Builder -> Doc
forall a b. (a -> b) -> a -> b
$ Builder
prologBuf Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
preBuf Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
elemBuf Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
postBuf, NsEnv
env)
where
standalone :: Bool
standalone = DocInfo -> Bool
docInfo_standalone DocInfo
di
mDocType :: Maybe String
mDocType = DocInfo -> Maybe String
docInfo_docType DocInfo
di
preMisc :: Xml Doc
preMisc = DocInfo -> Xml Doc
docInfo_preMisc DocInfo
di
postMisc :: Xml Doc
postMisc = DocInfo -> Xml Doc
docInfo_postMisc DocInfo
di
type TextContent = T.Text
textBuilder :: TextContent -> Builder
textBuilder :: Text -> Builder
textBuilder = Text -> Builder
fromText (Text -> Builder) -> (Text -> Text) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeText
xtext :: TextContent -> Xml Elem
xtext :: Text -> Xml Elem
xtext Text
content = Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Elem, NsEnv) -> Xml Elem)
-> Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(Elem, NsEnv) -> Reader NsEnv (Elem, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Elem
Elem (Builder -> Elem) -> Builder -> Elem
forall a b. (a -> b) -> a -> b
$ Text -> Builder
textBuilder Text
content, NsEnv
env)
xtextRaw :: Builder -> Xml Elem
Builder
content = Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Elem, NsEnv) -> Xml Elem)
-> Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(Elem, NsEnv) -> Reader NsEnv (Elem, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Elem
Elem Builder
content, NsEnv
env)
xentityRef :: Name -> Xml Elem
xentityRef :: Text -> Xml Elem
xentityRef Text
name = Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Elem, NsEnv) -> Xml Elem)
-> Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(Elem, NsEnv) -> Reader NsEnv (Elem, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Elem
Elem (Builder -> Elem) -> Builder -> Elem
forall a b. (a -> b) -> a -> b
$ Char -> Builder
fromChar Char
'&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
fromChar Char
';', NsEnv
env)
xattr :: Name -> TextContent -> Xml Attr
xattr :: Text -> Text -> Xml Attr
xattr = Namespace -> Text -> Text -> Xml Attr
xattrQ Namespace
DefaultNamespace
xattrQ :: Namespace -> Name -> TextContent -> Xml Attr
xattrQ :: Namespace -> Text -> Text -> Xml Attr
xattrQ Namespace
ns Text
key Text
value = Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' Namespace
ns (Text -> Builder
nameBuilder Text
key) (Text -> Builder
textBuilder Text
value)
xattrQRaw :: Namespace -> Name -> Builder -> Xml Attr
xattrQRaw :: Namespace -> Text -> Builder -> Xml Attr
xattrQRaw Namespace
ns Text
key Builder
value = Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' Namespace
ns (Text -> Builder
nameBuilder Text
key) Builder
value
xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' Namespace
ns' Builder
key Builder
valueBuilder = Reader NsEnv (Attr, NsEnv) -> Xml Attr
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Attr, NsEnv) -> Xml Attr)
-> Reader NsEnv (Attr, NsEnv) -> Xml Attr
forall a b. (a -> b) -> a -> b
$
do NsEnv
uriMap' <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let (Maybe (Text, Text)
mDecl, Text
prefix, NsEnv
uriMap) = Bool -> NsEnv -> Namespace -> (Maybe (Text, Text), Text, NsEnv)
extendNsEnv Bool
True NsEnv
uriMap' Namespace
ns'
nsDeclBuilder :: Builder
nsDeclBuilder =
case Maybe (Text, Text)
mDecl of
Maybe (Text, Text)
Nothing -> Builder
forall a. Monoid a => a
mempty
Just (Text
p, Text
u) ->
let uriBuilder :: Builder
uriBuilder = Text -> Builder
fromText Text
u
prefixBuilder :: Builder
prefixBuilder =
if Text -> Bool
T.null Text
p then Builder
forall a. Monoid a => a
mempty else Builder
colonBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
p
in Builder
spaceBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
nsDeclStartBuilder
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
prefixBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
startBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
uriBuilder
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
endBuilder
prefixBuilder :: Builder
prefixBuilder =
if Text -> Bool
T.null Text
prefix
then Builder
spaceBuilder
else Builder
spaceBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
prefix Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
colonBuilder
builder :: Builder
builder = Builder
nsDeclBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
prefixBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
Builder
key Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
startBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
Builder
valueBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
endBuilder
(Attr, NsEnv) -> Reader NsEnv (Attr, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Attr, NsEnv) -> Reader NsEnv (Attr, NsEnv))
-> (Attr, NsEnv) -> Reader NsEnv (Attr, NsEnv)
forall a b. (a -> b) -> a -> b
$ (Builder -> Attr
Attr Builder
builder, NsEnv
uriMap)
where
spaceBuilder :: Builder
spaceBuilder = String -> Builder
fromString String
" "
startBuilder :: Builder
startBuilder = String -> Builder
fromString String
"=\""
endBuilder :: Builder
endBuilder = String -> Builder
fromString String
"\""
nsDeclStartBuilder :: Builder
nsDeclStartBuilder = String -> Builder
fromString String
"xmlns"
colonBuilder :: Builder
colonBuilder = String -> Builder
fromString String
":"
xattrs :: [Xml Attr] -> Xml Attr
xattrs :: [Xml Attr] -> Xml Attr
xattrs = [Xml Attr] -> Xml Attr
forall a. Monoid a => [a] -> a
M.mconcat
noAttrs :: Xml Attr
noAttrs :: Xml Attr
noAttrs = Xml Attr
forall t. Renderable t => Xml t
xempty
{-# INLINE mappendAttr #-}
mappendAttr :: Xml Attr -> Xml Attr -> Xml Attr
mappendAttr :: Xml Attr -> Xml Attr -> Xml Attr
mappendAttr Xml Attr
x1 Xml Attr
x2 = Reader NsEnv (Attr, NsEnv) -> Xml Attr
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Attr, NsEnv) -> Xml Attr)
-> Reader NsEnv (Attr, NsEnv) -> Xml Attr
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let (Attr Builder
b1, NsEnv
env') = NsEnv -> Xml Attr -> (Attr, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Attr
x1
let (Attr Builder
b2, NsEnv
env'') = NsEnv -> Xml Attr -> (Attr, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env' Xml Attr
x2
(Attr, NsEnv) -> Reader NsEnv (Attr, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Attr, NsEnv) -> Reader NsEnv (Attr, NsEnv))
-> (Attr, NsEnv) -> Reader NsEnv (Attr, NsEnv)
forall a b. (a -> b) -> a -> b
$ (Builder -> Attr
Attr (Builder -> Attr) -> Builder -> Attr
forall a b. (a -> b) -> a -> b
$ Builder
b1 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b2, NsEnv
env'')
#if MIN_VERSION_base(4,9,0)
instance Semigroup (Xml Attr) where
<> :: Xml Attr -> Xml Attr -> Xml Attr
(<>) = Xml Attr -> Xml Attr -> Xml Attr
mappendAttr
instance Monoid (Xml Attr) where
mempty :: Xml Attr
mempty = Xml Attr
noAttrs
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
#else
instance Monoid (Xml Attr) where
mempty = noAttrs
mappend = mappendAttr
#endif
class AddChildren c where
addChildren :: c -> NsEnv -> Builder
instance AddChildren (Xml Attr) where
addChildren :: Xml Attr -> NsEnv -> Builder
addChildren Xml Attr
attrs NsEnv
uriMap =
let (Attr Builder
builder', NsEnv
_) = NsEnv -> Xml Attr -> (Attr, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
uriMap Xml Attr
attrs
in Builder
builder' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
"\n>"
instance AddChildren (Xml Elem) where
addChildren :: Xml Elem -> NsEnv -> Builder
addChildren Xml Elem
elems NsEnv
uriMap =
let (Elem Builder
builder', NsEnv
_) = NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
uriMap Xml Elem
elems
in String -> Builder
fromString String
"\n>" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
builder'
instance AddChildren (Xml Attr, Xml Elem) where
addChildren :: (Xml Attr, Xml Elem) -> NsEnv -> Builder
addChildren (Xml Attr
attrs, Xml Elem
elems) NsEnv
uriMap =
let (Attr Builder
builder, NsEnv
uriMap') = NsEnv -> Xml Attr -> (Attr, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
uriMap Xml Attr
attrs
(Elem Builder
builder', NsEnv
_) = NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
uriMap' Xml Elem
elems
in Builder
builder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"\n>" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
builder'
instance AddChildren (Xml Attr, [Xml Elem]) where
addChildren :: (Xml Attr, [Xml Elem]) -> NsEnv -> Builder
addChildren (Xml Attr
attrs, [Xml Elem]
elems) NsEnv
uriMap = (Xml Attr, Xml Elem) -> NsEnv -> Builder
forall c. AddChildren c => c -> NsEnv -> Builder
addChildren (Xml Attr
attrs, [Xml Elem] -> Xml Elem
xelems [Xml Elem]
elems) NsEnv
uriMap
instance AddChildren TextContent where
addChildren :: Text -> NsEnv -> Builder
addChildren Text
t NsEnv
_ = Char -> Builder
fromChar Char
'>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
textBuilder Text
t
instance AddChildren String where
addChildren :: String -> NsEnv -> Builder
addChildren String
t NsEnv
_ = Char -> Builder
fromChar Char
'>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
t
instance AddChildren () where
addChildren :: () -> NsEnv -> Builder
addChildren ()
_ NsEnv
_ = Char -> Builder
fromChar Char
'>'
xelem :: (AddChildren c) => Name -> c -> Xml Elem
xelem :: forall c. AddChildren c => Text -> c -> Xml Elem
xelem = Namespace -> Text -> c -> Xml Elem
forall c. AddChildren c => Namespace -> Text -> c -> Xml Elem
xelemQ Namespace
DefaultNamespace
xelemEmpty :: Name -> Xml Elem
xelemEmpty :: Text -> Xml Elem
xelemEmpty Text
name = Namespace -> Text -> Xml Elem -> Xml Elem
forall c. AddChildren c => Namespace -> Text -> c -> Xml Elem
xelemQ Namespace
DefaultNamespace Text
name (Xml Elem
forall a. Monoid a => a
mempty :: Xml Elem)
xelemQ :: (AddChildren c) => Namespace -> Name -> c -> Xml Elem
xelemQ :: forall c. AddChildren c => Namespace -> Text -> c -> Xml Elem
xelemQ Namespace
ns' Text
name c
children = Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Elem, NsEnv) -> Xml Elem)
-> Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
do NsEnv
oldUriMap <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let (Maybe (Text, Text)
mDecl, Text
prefix,!NsEnv
uriMap) = NsEnv
oldUriMap NsEnv
-> (Maybe (Text, Text), Text, NsEnv)
-> (Maybe (Text, Text), Text, NsEnv)
forall a b. a -> b -> b
`seq` Bool -> NsEnv -> Namespace -> (Maybe (Text, Text), Text, NsEnv)
extendNsEnv Bool
False NsEnv
oldUriMap Namespace
ns'
let elemNameBuilder :: Builder
elemNameBuilder =
if Text -> Bool
T.null Text
prefix
then Text -> Builder
nameBuilder Text
name
else Text -> Builder
fromText Text
prefix Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
":" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
nameBuilder Text
name
let nsDeclBuilder :: Builder
nsDeclBuilder =
case Maybe (Text, Text)
mDecl of
Maybe (Text, Text)
Nothing -> Builder
forall a. Monoid a => a
mempty
Just (Text
p, Text
u) ->
let prefixBuilder :: Builder
prefixBuilder =
if Text -> Bool
T.null Text
p then Builder
forall a. Monoid a => a
mempty else Char -> Builder
fromChar Char
':' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
p
in String -> Builder
fromString String
" xmlns" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
prefixBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"=\""
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
u Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"\""
let b1 :: Builder
b1 = String -> Builder
fromString String
"<"
let b2 :: Builder
b2 = Builder
b1 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
elemNameBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
nsDeclBuilder
let b3 :: Builder
b3 = Builder
b2 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` c -> NsEnv -> Builder
forall c. AddChildren c => c -> NsEnv -> Builder
addChildren c
children NsEnv
uriMap
let builderOut :: Elem
builderOut = Builder -> Elem
Elem (Builder
b3 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"</" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
elemNameBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"\n>")
(Elem, NsEnv) -> Reader NsEnv (Elem, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Elem
builderOut, NsEnv
oldUriMap)
xelemQEmpty :: Namespace -> Name -> Xml Elem
xelemQEmpty :: Namespace -> Text -> Xml Elem
xelemQEmpty Namespace
ns Text
name = Namespace -> Text -> Xml Elem -> Xml Elem
forall c. AddChildren c => Namespace -> Text -> c -> Xml Elem
xelemQ Namespace
ns Text
name (Xml Elem
forall a. Monoid a => a
mempty :: Xml Elem)
xelems :: [Xml Elem] -> Xml Elem
xelems :: [Xml Elem] -> Xml Elem
xelems = [Xml Elem] -> Xml Elem
forall a. Monoid a => [a] -> a
M.mconcat
noElems :: Xml Elem
noElems :: Xml Elem
noElems = Xml Elem
forall t. Renderable t => Xml t
xempty
xelemWithText :: Name -> TextContent -> Xml Elem
xelemWithText :: Text -> Text -> Xml Elem
xelemWithText Text
n Text
t = Text -> Xml Elem -> Xml Elem
forall c. AddChildren c => Text -> c -> Xml Elem
xelem Text
n (Text -> Xml Elem
xtext Text
t)
{-# INLINE mappendElem #-}
mappendElem :: Xml Elem -> Xml Elem -> Xml Elem
mappendElem :: Xml Elem -> Xml Elem -> Xml Elem
mappendElem Xml Elem
x1 Xml Elem
x2 = Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (Elem, NsEnv) -> Xml Elem)
-> Reader NsEnv (Elem, NsEnv) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let (Elem Builder
b1, NsEnv
env') = NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Elem
x1
(Elem Builder
b2, NsEnv
env'') = NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env' Xml Elem
x2
(Elem, NsEnv) -> Reader NsEnv (Elem, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Elem
Elem (Builder -> Elem) -> Builder -> Elem
forall a b. (a -> b) -> a -> b
$ Builder
b1 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b2, NsEnv
env'')
#if MIN_VERSION_base(4,9,0)
instance Semigroup (Xml Elem) where
<> :: Xml Elem -> Xml Elem -> Xml Elem
(<>) = Xml Elem -> Xml Elem -> Xml Elem
mappendElem
instance Monoid (Xml Elem) where
mempty :: Xml Elem
mempty = Xml Elem
noElems
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
#else
instance Monoid (Xml Elem) where
mempty = noElems
mappend = mappendElem
#endif
class Renderable t => Misc t where
xprocessingInstruction :: String -> String -> Xml t
xprocessingInstruction String
target String
content = Reader NsEnv (t, NsEnv) -> Xml t
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (t, NsEnv) -> Xml t)
-> Reader NsEnv (t, NsEnv) -> Xml t
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(t, NsEnv) -> Reader NsEnv (t, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> t
forall t. Renderable t => Builder -> t
mkRenderable (Builder -> t) -> Builder -> t
forall a b. (a -> b) -> a -> b
$
String -> Builder
fromString String
"<?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString String
target Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
fromChar Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString String
content Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString String
"?>",
NsEnv
env)
:: String -> Xml t
xcomment String
content = Reader NsEnv (t, NsEnv) -> Xml t
forall t. Reader NsEnv (t, NsEnv) -> Xml t
Xml (Reader NsEnv (t, NsEnv) -> Xml t)
-> Reader NsEnv (t, NsEnv) -> Xml t
forall a b. (a -> b) -> a -> b
$
do NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(t, NsEnv) -> Reader NsEnv (t, NsEnv)
forall a. a -> ReaderT NsEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> t
forall t. Renderable t => Builder -> t
mkRenderable (Builder -> t) -> Builder -> t
forall a b. (a -> b) -> a -> b
$
String -> Builder
fromString String
"<!--" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString String
content Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString String
"-->",
NsEnv
env)
instance Misc Elem
instance Misc Doc
#ifndef BASE_AT_LEAST_4_5_0_0
infixl 6 <>
(<>) :: Monoid t => t -> t -> t
(<>) = mappend
#endif
infixl 5 <#>
(<#>) :: a -> b -> (a, b)
<#> :: forall a b. a -> b -> (a, b)
(<#>) a
x b
y = (a
x, b
y)
class XmlOutput t where
fromBuilder :: Builder -> t
instance XmlOutput Builder where
fromBuilder :: Builder -> Builder
fromBuilder Builder
b = Builder
b
instance XmlOutput BS.ByteString where
fromBuilder :: Builder -> ByteString
fromBuilder = Builder -> ByteString
toByteString
instance XmlOutput BSL.ByteString where
fromBuilder :: Builder -> ByteString
fromBuilder = Builder -> ByteString
toLazyByteString
class Renderable t where
builder :: t -> Builder
mkRenderable :: Builder -> t
instance Renderable Elem where
builder :: Elem -> Builder
builder (Elem Builder
b) = Builder
b
mkRenderable :: Builder -> Elem
mkRenderable = Builder -> Elem
Elem
instance Renderable Attr where
builder :: Attr -> Builder
builder (Attr Builder
b) = Builder
b
mkRenderable :: Builder -> Attr
mkRenderable = Builder -> Attr
Attr
instance Renderable Doc where
builder :: Doc -> Builder
builder (Doc Builder
b) = Builder
b
mkRenderable :: Builder -> Doc
mkRenderable = Builder -> Doc
Doc
xrender :: (Renderable r, XmlOutput t) => Xml r -> t
xrender :: forall r t. (Renderable r, XmlOutput t) => Xml r -> t
xrender Xml r
r = Builder -> t
forall t. XmlOutput t => Builder -> t
fromBuilder (Builder -> t) -> Builder -> t
forall a b. (a -> b) -> a -> b
$ r -> Builder
forall t. Renderable t => t -> Builder
builder r
r'
where
r' :: r
r' = (r, NsEnv) -> r
forall a b. (a, b) -> a
fst ((r, NsEnv) -> r) -> (r, NsEnv) -> r
forall a b. (a -> b) -> a -> b
$ NsEnv -> Xml r -> (r, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
emptyNsEnv Xml r
r
extendNsEnv :: Bool -> NsEnv -> Namespace -> (Maybe (Prefix, Uri), Prefix, NsEnv)
extendNsEnv :: Bool -> NsEnv -> Namespace -> (Maybe (Text, Text), Text, NsEnv)
extendNsEnv Bool
isAttr NsEnv
env Namespace
ns =
case Namespace
ns of
Namespace
NoNamespace
| Bool
isAttr -> (Maybe (Text, Text)
forall a. Maybe a
Nothing, Text
T.empty, NsEnv
env)
| Bool
otherwise ->
case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
T.empty (NsEnv -> Map Text Text
ne_namespaceMap NsEnv
env) of
Maybe Text
Nothing ->
(Maybe (Text, Text)
forall a. Maybe a
Nothing, Text
T.empty, NsEnv
env { ne_noNamespaceInUse :: Bool
ne_noNamespaceInUse = Bool
True })
Just Text
uri ->
((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
T.empty, Text
T.empty), Text
T.empty, NsEnv
env { ne_namespaceMap :: Map Text Text
ne_namespaceMap = Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
T.empty (NsEnv -> Map Text Text
ne_namespaceMap NsEnv
env)
, ne_noNamespaceInUse :: Bool
ne_noNamespaceInUse = Bool
True })
Namespace
DefaultNamespace ->
(Maybe (Text, Text)
forall a. Maybe a
Nothing, Text
T.empty, NsEnv
env)
QualifiedNamespace Text
p' Text
u ->
let p :: Text
p = if Text -> Bool
T.null Text
p' Bool -> Bool -> Bool
&& (Bool
isAttr Bool -> Bool -> Bool
|| NsEnv -> Bool
ne_noNamespaceInUse NsEnv
env) then String -> Text
T.pack String
"_" else Text
p'
(Maybe (Text, Text)
mDecl, Text
prefix, Map Text Text
newMap) = Map Text Text
-> Text -> Text -> (Maybe (Text, Text), Text, Map Text Text)
forall {t}.
Eq t =>
Map Text t -> Text -> t -> (Maybe (Text, t), Text, Map Text t)
genValidPrefix (NsEnv -> Map Text Text
ne_namespaceMap NsEnv
env) Text
p Text
u
in (Maybe (Text, Text)
mDecl, Text
prefix, NsEnv
env { ne_namespaceMap :: Map Text Text
ne_namespaceMap = Map Text Text
newMap })
where
genValidPrefix :: Map Text t -> Text -> t -> (Maybe (Text, t), Text, Map Text t)
genValidPrefix Map Text t
map Text
prefix t
uri =
case Text -> Map Text t -> Maybe t
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
prefix Map Text t
map of
Maybe t
Nothing -> ((Text, t) -> Maybe (Text, t)
forall a. a -> Maybe a
Just (Text
prefix, t
uri), Text
prefix, Text -> t -> Map Text t -> Map Text t
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
prefix t
uri Map Text t
map)
Just t
foundUri ->
if t
foundUri t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
uri
then (Maybe (Text, t)
forall a. Maybe a
Nothing, Text
prefix, Map Text t
map)
else Map Text t -> Text -> t -> (Maybe (Text, t), Text, Map Text t)
genValidPrefix Map Text t
map (Char -> Text -> Text
T.cons Char
'_' Text
prefix) t
uri
escapeText :: T.Text -> T.Text
escapeText :: Text -> Text
escapeText = (Char -> Text -> Text) -> Text -> Text -> Text
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> Text -> Text
escChar Text
T.empty
where
escChar :: Char -> Text -> Text
escChar Char
c = case Char
c of
Char
'<' -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"<")
Char
'>' -> Text -> Text -> Text
T.append (String -> Text
T.pack String
">")
Char
'&' -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&")
Char
'"' -> Text -> Text -> Text
T.append (String -> Text
T.pack String
""")
Char
'\'' -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"'")
Char
_ | (Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7f Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' -> Char -> Text -> Text
T.cons Char
c
| Bool
otherwise -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&#") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
oc)) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
';'
where oc :: Int
oc = Char -> Int
ord Char
c
xhtmlDoctypeStrict :: String
xhtmlDoctypeStrict :: String
xhtmlDoctypeStrict =
String
"<!DOCTYPE html\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
xhtmlStrictDocInfo :: DocInfo
xhtmlStrictDocInfo :: DocInfo
xhtmlStrictDocInfo = DocInfo
defaultDocInfo { docInfo_docType :: Maybe String
docInfo_docType = String -> Maybe String
forall a. a -> Maybe a
Just String
xhtmlDoctypeStrict }
xhtmlDoctypeTransitional :: String
xhtmlDoctypeTransitional :: String
xhtmlDoctypeTransitional =
String
"<!DOCTYPE html\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
xhtmlTransitionalDocInfo :: DocInfo
xhtmlTransitionalDocInfo :: DocInfo
xhtmlTransitionalDocInfo = DocInfo
defaultDocInfo { docInfo_docType :: Maybe String
docInfo_docType = String -> Maybe String
forall a. a -> Maybe a
Just String
xhtmlDoctypeTransitional }
xhtmlDoctypeFrameset :: String
xhtmlDoctypeFrameset :: String
xhtmlDoctypeFrameset =
String
"<!DOCTYPE html\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
xhtmlFramesetDocInfo :: DocInfo
xhtmlFramesetDocInfo :: DocInfo
xhtmlFramesetDocInfo = DocInfo
defaultDocInfo { docInfo_docType :: Maybe String
docInfo_docType = String -> Maybe String
forall a. a -> Maybe a
Just String
xhtmlDoctypeFrameset }
xhtmlRootElem :: T.Text -> Xml Elem -> Xml Elem
xhtmlRootElem :: Text -> Xml Elem -> Xml Elem
xhtmlRootElem Text
lang Xml Elem
children =
Namespace -> Text -> (Xml Attr, Xml Elem) -> Xml Elem
forall c. AddChildren c => Namespace -> Text -> c -> Xml Elem
xelemQ (Text -> Text -> Namespace
namespace (String -> Text
T.pack String
"") (String -> Text
T.pack String
"http://www.w3.org/1999/xhtml")) (String -> Text
T.pack String
"html")
(Text -> Text -> Xml Attr
xattr (String -> Text
T.pack String
"xml:lang") Text
lang Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr (String -> Text
T.pack String
"lang") Text
lang Xml Attr -> Xml Elem -> (Xml Attr, Xml Elem)
forall a b. a -> b -> (a, b)
<#>
Xml Elem
children)