{-# 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 :: Name -> Builder
nameBuilder = Name -> 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
showList :: [Namespace] -> ShowS
$cshowList :: [Namespace] -> ShowS
show :: Namespace -> String
$cshow :: Namespace -> String
showsPrec :: Int -> Namespace -> ShowS
$cshowsPrec :: Int -> Namespace -> ShowS
Show, Namespace -> Namespace -> Bool
(Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool) -> Eq Namespace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: Namespace -> Namespace -> Bool
Eq)
namespace :: Prefix -> Uri -> Namespace
namespace :: Name -> Name -> Namespace
namespace p :: Name
p u :: Name
u = if Name -> Bool
T.null Name
u
then String -> Namespace
forall a. HasCallStack => String -> a
error "Text.XML.Generator.ns: namespace URI must not be empty"
else Name -> Name -> Namespace
QualifiedNamespace Name
p Name
u
noNamespace :: Namespace
noNamespace :: Namespace
noNamespace = Namespace
NoNamespace
defaultNamespace :: Namespace
defaultNamespace :: Namespace
defaultNamespace = Namespace
DefaultNamespace
data NsEnv = NsEnv { NsEnv -> Map Name Name
ne_namespaceMap :: Map.Map Prefix Uri
, NsEnv -> Bool
ne_noNamespaceInUse :: Bool }
emptyNsEnv :: NsEnv
emptyNsEnv :: NsEnv
emptyNsEnv = Map Name Name -> Bool -> NsEnv
NsEnv Map Name Name
forall k a. Map k a
Map.empty Bool
False
newtype Xml t = Xml { Xml t -> Reader NsEnv (t, NsEnv)
unXml :: Reader NsEnv (t, NsEnv) }
runXml :: NsEnv -> Xml t -> (t, NsEnv)
runXml :: NsEnv -> Xml t -> (t, NsEnv)
runXml nsEnv :: NsEnv
nsEnv (Xml x :: 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 :: 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 (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 :: Bool -> Maybe String -> Xml Doc -> Xml Doc -> DocInfo
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 di :: DocInfo
di rootElem :: 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 "<?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 "yes" else "no") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Builder
fromString "\"?>\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
case Maybe String
mDocType of
Nothing -> Builder
forall a. Monoid a => a
mempty
Just s :: String
s -> String -> Builder
fromString String
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString "\n"
NsEnv
env <- ReaderT NsEnv Identity NsEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let Doc preBuf :: 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 elemBuf :: 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 postBuf :: 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 (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 :: Name -> Builder
textBuilder = Name -> Builder
fromText (Name -> Builder) -> (Name -> Name) -> Name -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
escapeText
xtext :: TextContent -> Xml Elem
xtext :: Name -> Xml Elem
xtext content :: Name
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 (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Elem
Elem (Builder -> Elem) -> Builder -> Elem
forall a b. (a -> b) -> a -> b
$ Name -> Builder
textBuilder Name
content, NsEnv
env)
xtextRaw :: Builder -> Xml Elem
content :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Elem
Elem Builder
content, NsEnv
env)
xentityRef :: Name -> Xml Elem
xentityRef :: Name -> Xml Elem
xentityRef name :: Name
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 (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 '&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Name -> Builder
fromText Name
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
fromChar ';', NsEnv
env)
xattr :: Name -> TextContent -> Xml Attr
xattr :: Name -> Name -> Xml Attr
xattr = Namespace -> Name -> Name -> Xml Attr
xattrQ Namespace
DefaultNamespace
xattrQ :: Namespace -> Name -> TextContent -> Xml Attr
xattrQ :: Namespace -> Name -> Name -> Xml Attr
xattrQ ns :: Namespace
ns key :: Name
key value :: Name
value = Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' Namespace
ns (Name -> Builder
nameBuilder Name
key) (Name -> Builder
textBuilder Name
value)
xattrQRaw :: Namespace -> Name -> Builder -> Xml Attr
xattrQRaw :: Namespace -> Name -> Builder -> Xml Attr
xattrQRaw ns :: Namespace
ns key :: Name
key value :: Builder
value = Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' Namespace
ns (Name -> Builder
nameBuilder Name
key) Builder
value
xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' ns' :: Namespace
ns' key :: Builder
key valueBuilder :: 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 (mDecl :: Maybe (Name, Name)
mDecl, prefix :: Name
prefix, uriMap :: NsEnv
uriMap) = Bool -> NsEnv -> Namespace -> (Maybe (Name, Name), Name, NsEnv)
extendNsEnv Bool
True NsEnv
uriMap' Namespace
ns'
nsDeclBuilder :: Builder
nsDeclBuilder =
case Maybe (Name, Name)
mDecl of
Nothing -> Builder
forall a. Monoid a => a
mempty
Just (p :: Name
p, u :: Name
u) ->
let uriBuilder :: Builder
uriBuilder = Name -> Builder
fromText Name
u
prefixBuilder :: Builder
prefixBuilder =
if Name -> Bool
T.null Name
p then Builder
forall a. Monoid a => a
mempty else Builder
colonBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Name -> Builder
fromText Name
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 Name -> Bool
T.null Name
prefix
then Builder
spaceBuilder
else Builder
spaceBuilder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Name -> Builder
fromText Name
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 (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 " "
startBuilder :: Builder
startBuilder = String -> Builder
fromString "=\""
endBuilder :: Builder
endBuilder = String -> Builder
fromString "\""
nsDeclStartBuilder :: Builder
nsDeclStartBuilder = String -> Builder
fromString "xmlns"
colonBuilder :: Builder
colonBuilder = String -> Builder
fromString ":"
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 x1 :: Xml Attr
x1 x2 :: 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 b1 :: Builder
b1, env' :: NsEnv
env') = NsEnv -> Xml Attr -> (Attr, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Attr
x1
let (Attr b2 :: Builder
b2, env'' :: 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 (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 attrs :: Xml Attr
attrs uriMap :: NsEnv
uriMap =
let (Attr builder' :: Builder
builder', _) = 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 "\n>"
instance AddChildren (Xml Elem) where
addChildren :: Xml Elem -> NsEnv -> Builder
addChildren elems :: Xml Elem
elems uriMap :: NsEnv
uriMap =
let (Elem builder' :: Builder
builder', _) = NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
uriMap Xml Elem
elems
in String -> Builder
fromString "\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 (attrs :: Xml Attr
attrs, elems :: Xml Elem
elems) uriMap :: NsEnv
uriMap =
let (Attr builder :: Builder
builder, uriMap' :: NsEnv
uriMap') = NsEnv -> Xml Attr -> (Attr, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
uriMap Xml Attr
attrs
(Elem builder' :: Builder
builder', _) = 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 "\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 (attrs :: Xml Attr
attrs, elems :: [Xml Elem]
elems) uriMap :: 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 :: Name -> NsEnv -> Builder
addChildren t :: Name
t _ = Char -> Builder
fromChar '>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Name -> Builder
textBuilder Name
t
instance AddChildren String where
addChildren :: String -> NsEnv -> Builder
addChildren t :: String
t _ = Char -> Builder
fromChar '>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
t
instance AddChildren () where
addChildren :: () -> NsEnv -> Builder
addChildren _ _ = Char -> Builder
fromChar '>'
xelem :: (AddChildren c) => Name -> c -> Xml Elem
xelem :: Name -> c -> Xml Elem
xelem = Namespace -> Name -> c -> Xml Elem
forall c. AddChildren c => Namespace -> Name -> c -> Xml Elem
xelemQ Namespace
DefaultNamespace
xelemEmpty :: Name -> Xml Elem
xelemEmpty :: Name -> Xml Elem
xelemEmpty name :: Name
name = Namespace -> Name -> Xml Elem -> Xml Elem
forall c. AddChildren c => Namespace -> Name -> c -> Xml Elem
xelemQ Namespace
DefaultNamespace Name
name (Xml Elem
forall a. Monoid a => a
mempty :: Xml Elem)
xelemQ :: (AddChildren c) => Namespace -> Name -> c -> Xml Elem
xelemQ :: Namespace -> Name -> c -> Xml Elem
xelemQ ns' :: Namespace
ns' name :: Name
name children :: 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 (mDecl :: Maybe (Name, Name)
mDecl, prefix :: Name
prefix,!NsEnv
uriMap) = NsEnv
oldUriMap NsEnv
-> (Maybe (Name, Name), Name, NsEnv)
-> (Maybe (Name, Name), Name, NsEnv)
forall a b. a -> b -> b
`seq` Bool -> NsEnv -> Namespace -> (Maybe (Name, Name), Name, NsEnv)
extendNsEnv Bool
False NsEnv
oldUriMap Namespace
ns'
let elemNameBuilder :: Builder
elemNameBuilder =
if Name -> Bool
T.null Name
prefix
then Name -> Builder
nameBuilder Name
name
else Name -> Builder
fromText Name
prefix Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString ":" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Name -> Builder
nameBuilder Name
name
let nsDeclBuilder :: Builder
nsDeclBuilder =
case Maybe (Name, Name)
mDecl of
Nothing -> Builder
forall a. Monoid a => a
mempty
Just (p :: Name
p, u :: Name
u) ->
let prefixBuilder :: Builder
prefixBuilder =
if Name -> Bool
T.null Name
p then Builder
forall a. Monoid a => a
mempty else Char -> Builder
fromChar ':' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Name -> Builder
fromText Name
p
in String -> Builder
fromString " 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 "=\""
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Name -> Builder
fromText Name
u Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString "\""
let b1 :: Builder
b1 = String -> Builder
fromString "<"
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 "</" 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 "\n>")
(Elem, NsEnv) -> Reader NsEnv (Elem, NsEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Elem
builderOut, NsEnv
oldUriMap)
xelemQEmpty :: Namespace -> Name -> Xml Elem
xelemQEmpty :: Namespace -> Name -> Xml Elem
xelemQEmpty ns :: Namespace
ns name :: Name
name = Namespace -> Name -> Xml Elem -> Xml Elem
forall c. AddChildren c => Namespace -> Name -> c -> Xml Elem
xelemQ Namespace
ns Name
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 :: Name -> Name -> Xml Elem
xelemWithText n :: Name
n t :: Name
t = Name -> Xml Elem -> Xml Elem
forall c. AddChildren c => Name -> c -> Xml Elem
xelem Name
n (Name -> Xml Elem
xtext Name
t)
{-# INLINE mappendElem #-}
mappendElem :: Xml Elem -> Xml Elem -> Xml Elem
mappendElem :: Xml Elem -> Xml Elem -> Xml Elem
mappendElem x1 :: Xml Elem
x1 x2 :: 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 b1 :: Builder
b1, env' :: NsEnv
env') = NsEnv -> Xml Elem -> (Elem, NsEnv)
forall t. NsEnv -> Xml t -> (t, NsEnv)
runXml NsEnv
env Xml Elem
x1
(Elem b2 :: Builder
b2, env'' :: 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 (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 target :: String
target content :: 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 (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 "<?" 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 ' ' 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 "?>",
NsEnv
env)
:: String -> Xml t
xcomment content :: 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 (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 "<!--" 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 "-->",
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)
<#> :: a -> b -> (a, b)
(<#>) x :: a
x y :: b
y = (a
x, b
y)
class XmlOutput t where
fromBuilder :: Builder -> t
instance XmlOutput Builder where
fromBuilder :: Builder -> Builder
fromBuilder b :: 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 b :: Builder
b) = Builder
b
mkRenderable :: Builder -> Elem
mkRenderable = Builder -> Elem
Elem
instance Renderable Attr where
builder :: Attr -> Builder
builder (Attr b :: Builder
b) = Builder
b
mkRenderable :: Builder -> Attr
mkRenderable = Builder -> Attr
Attr
instance Renderable Doc where
builder :: Doc -> Builder
builder (Doc b :: Builder
b) = Builder
b
mkRenderable :: Builder -> Doc
mkRenderable = Builder -> Doc
Doc
xrender :: (Renderable r, XmlOutput t) => Xml r -> t
xrender :: Xml r -> t
xrender r :: 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 (Name, Name), Name, NsEnv)
extendNsEnv isAttr :: Bool
isAttr env :: NsEnv
env ns :: Namespace
ns =
case Namespace
ns of
NoNamespace
| Bool
isAttr -> (Maybe (Name, Name)
forall a. Maybe a
Nothing, Name
T.empty, NsEnv
env)
| Bool
otherwise ->
case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
T.empty (NsEnv -> Map Name Name
ne_namespaceMap NsEnv
env) of
Nothing ->
(Maybe (Name, Name)
forall a. Maybe a
Nothing, Name
T.empty, NsEnv
env { ne_noNamespaceInUse :: Bool
ne_noNamespaceInUse = Bool
True })
Just uri :: Name
uri ->
((Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (Name
T.empty, Name
T.empty), Name
T.empty, NsEnv
env { ne_namespaceMap :: Map Name Name
ne_namespaceMap = Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
T.empty (NsEnv -> Map Name Name
ne_namespaceMap NsEnv
env)
, ne_noNamespaceInUse :: Bool
ne_noNamespaceInUse = Bool
True })
DefaultNamespace ->
(Maybe (Name, Name)
forall a. Maybe a
Nothing, Name
T.empty, NsEnv
env)
QualifiedNamespace p' :: Name
p' u :: Name
u ->
let p :: Name
p = if Name -> Bool
T.null Name
p' Bool -> Bool -> Bool
&& (Bool
isAttr Bool -> Bool -> Bool
|| NsEnv -> Bool
ne_noNamespaceInUse NsEnv
env) then String -> Name
T.pack "_" else Name
p'
(mDecl :: Maybe (Name, Name)
mDecl, prefix :: Name
prefix, newMap :: Map Name Name
newMap) = Map Name Name
-> Name -> Name -> (Maybe (Name, Name), Name, Map Name Name)
forall t.
Eq t =>
Map Name t -> Name -> t -> (Maybe (Name, t), Name, Map Name t)
genValidPrefix (NsEnv -> Map Name Name
ne_namespaceMap NsEnv
env) Name
p Name
u
in (Maybe (Name, Name)
mDecl, Name
prefix, NsEnv
env { ne_namespaceMap :: Map Name Name
ne_namespaceMap = Map Name Name
newMap })
where
genValidPrefix :: Map Name t -> Name -> t -> (Maybe (Name, t), Name, Map Name t)
genValidPrefix map :: Map Name t
map prefix :: Name
prefix uri :: t
uri =
case Name -> Map Name t -> Maybe t
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
prefix Map Name t
map of
Nothing -> ((Name, t) -> Maybe (Name, t)
forall a. a -> Maybe a
Just (Name
prefix, t
uri), Name
prefix, Name -> t -> Map Name t -> Map Name t
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
prefix t
uri Map Name t
map)
Just foundUri :: t
foundUri ->
if t
foundUri t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
uri
then (Maybe (Name, t)
forall a. Maybe a
Nothing, Name
prefix, Map Name t
map)
else Map Name t -> Name -> t -> (Maybe (Name, t), Name, Map Name t)
genValidPrefix Map Name t
map (Char -> Name -> Name
T.cons '_' Name
prefix) t
uri
escapeText :: T.Text -> T.Text
escapeText :: Name -> Name
escapeText = (Char -> Name -> Name) -> Name -> Name -> Name
forall a. (Char -> a -> a) -> a -> Name -> a
T.foldr Char -> Name -> Name
escChar Name
T.empty
where
escChar :: Char -> Name -> Name
escChar c :: Char
c = case Char
c of
'<' -> Name -> Name -> Name
T.append (String -> Name
T.pack "<")
'>' -> Name -> Name -> Name
T.append (String -> Name
T.pack ">")
'&' -> Name -> Name -> Name
T.append (String -> Name
T.pack "&")
'"' -> Name -> Name -> Name
T.append (String -> Name
T.pack """)
'\'' -> Name -> Name -> Name
T.append (String -> Name
T.pack "'")
_ | (Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7f Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' -> Char -> Name -> Name
T.cons Char
c
| Bool
otherwise -> Name -> Name -> Name
T.append (String -> Name
T.pack "&#") (Name -> Name) -> (Name -> Name) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Name
T.append (String -> Name
T.pack (Int -> String
forall a. Show a => a -> String
show Int
oc)) (Name -> Name) -> (Name -> Name) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Name -> Name
T.cons ';'
where oc :: Int
oc = Char -> Int
ord Char
c
xhtmlDoctypeStrict :: String
xhtmlDoctypeStrict :: String
xhtmlDoctypeStrict =
"<!DOCTYPE html\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" \"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 =
"<!DOCTYPE html\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" \"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 =
"<!DOCTYPE html\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" \"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 :: Name -> Xml Elem -> Xml Elem
xhtmlRootElem lang :: Name
lang children :: Xml Elem
children =
Namespace -> Name -> (Xml Attr, Xml Elem) -> Xml Elem
forall c. AddChildren c => Namespace -> Name -> c -> Xml Elem
xelemQ (Name -> Name -> Namespace
namespace (String -> Name
T.pack "") (String -> Name
T.pack "http://www.w3.org/1999/xhtml")) (String -> Name
T.pack "html")
(Name -> Name -> Xml Attr
xattr (String -> Name
T.pack "xml:lang") Name
lang Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Name -> Name -> Xml Attr
xattr (String -> Name
T.pack "lang") Name
lang Xml Attr -> Xml Elem -> (Xml Attr, Xml Elem)
forall a b. a -> b -> (a, b)
<#>
Xml Elem
children)