{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
-- | This module provides combinators for generating XML documents.
--
-- As an example, suppose you want to generate the following XML document:
--
-- > <?xml version="1.0"?>
-- > <people>
-- >   <person age="32">Stefan</person>
-- >   <person age="4">Judith</person>
-- > </people>
--
-- Then you could use the following Haskell code:
--
--
-- @
-- let people = [(\"Stefan\", \"32\"), (\"Judith\", \"4\")]
-- in 'doc' 'defaultDocInfo' $
--      'xelem' \"people\" $
--        'xelems' $ map (\(name, age) -> 'xelem' \"person\" ('xattr' \"age\" age '<#>' 'xtext' name)) people
-- @

module Text.XML.Generator (

  -- * General
    Xml
  -- * Documents
  , Doc, DocInfo(..), doc, defaultDocInfo
  -- * Namespaces
  , Namespace, Prefix, Uri, Name
  , namespace, noNamespace, defaultNamespace
  -- * Elements
  , Elem, xelem, xelemQ, xelemEmpty, xelemQEmpty, AddChildren
  , xelems, noElems, xelemWithText, (<>), (<#>)
  -- * Attributes
  , Attr, xattr, xattrQ, xattrQRaw
  , xattrs, noAttrs
  -- * Text
  , TextContent
  , xtext, xtextRaw, xentityRef
  -- * Other
  , xempty , Misc(xprocessingInstruction, xcomment)
  -- * Rendering
  , xrender
  , XmlOutput(fromBuilder), Renderable
  -- * XHTML documents
  , 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
-- for ghc 7.10
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

-- Fallback for ghci
#if __GLASGOW_HASKELL__ >= 704
#define BASE_AT_LEAST_4_5_0_0
#endif

#endif

--
-- Basic definitions
--

-- | A piece of XML at the element level.
newtype Elem = Elem { Elem -> Builder
unElem :: Builder }

-- | A piece of XML at the attribute level.
newtype Attr = Attr { Attr -> Builder
unAttr :: Builder }

-- | A piece of XML at the document level.
newtype Doc = Doc { Doc -> Builder
unDoc :: Builder }

-- | Namespace prefix.
type Prefix = T.Text

-- | Namespace URI.
type Uri = T.Text -- must not be empty

-- | A type for names
type Name = T.Text

nameBuilder :: Name -> Builder
nameBuilder :: Text -> Builder
nameBuilder = Text -> Builder
fromText

-- | Type for representing presence or absence of an XML namespace.
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)

-- | Constructs a qualified XML namespace.
--   The given URI must not be the empty string.
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

-- | A 'Namespace' value denoting the absence of any XML namespace information.
noNamespace :: Namespace
noNamespace :: Namespace
noNamespace = Namespace
NoNamespace

-- | A 'Namespace' value denoting the default namespace.
--
-- * For elements, this is the namespace currently mapped to the empty prefix.
--
-- * For attributes, the default namespace does not carry any namespace information.
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

-- | The type @Xml t@ represent a piece of XML of type @t@, where @t@
--   is usually one of 'Elem', 'Attr', or 'Doc'.
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

-- | An empty, polymorphic piece of XML.
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 (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)

--
-- Document
--

-- | The 'DocInfo' type contains all information of an XML document except the root element.
data DocInfo
    = DocInfo
      { DocInfo -> Bool
docInfo_standalone :: Bool          -- ^ Value of the @standalone@ attribute in the @\<?xml ... ?\>@ header
      , DocInfo -> Maybe String
docInfo_docType    :: Maybe String  -- ^ Document type (N.B.: rendering does not escape this value)
      , DocInfo -> Xml Doc
docInfo_preMisc    :: Xml Doc       -- ^ Content before the root element
      , DocInfo -> Xml Doc
docInfo_postMisc   :: Xml Doc       -- ^ Content after the root element
      }

-- | The default document info (standalone, without document type, without content before/after the root element).
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 }

-- | Constructs an XML document from a 'DocInfo' value and the root element.
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 (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

--
-- Text content
--

-- | Text content subject to escaping.
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

-- | Constructs a text node by escaping the given argument.
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 (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)

-- | Constructs a text node /without/ escaping the given argument.
xtextRaw :: Builder -> Xml Elem
xtextRaw :: Builder -> Xml Elem
xtextRaw 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)

-- | Constructs a reference to the named entity.
-- /Note:/ no escaping is performed on the name of the entity
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 (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)

--
-- Attributes
--

-- | Construct a simple-named attribute by escaping its value.
xattr :: Name -> TextContent -> Xml Attr
xattr :: Text -> Text -> Xml Attr
xattr = Namespace -> Text -> Text -> Xml Attr
xattrQ Namespace
DefaultNamespace

-- | Construct an attribute by escaping its value.
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)

-- | Construct an attribute without escaping its value.
-- /Note:/ attribute values are quoted with double quotes.
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 (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
":"

-- |  Merge a list of attributes into a single piece of XML at the attribute level.
xattrs :: [Xml Attr] -> Xml Attr
xattrs :: [Xml Attr] -> Xml Attr
xattrs = [Xml Attr] -> Xml Attr
forall a. Monoid a => [a] -> a
M.mconcat

-- | The empty attribute list.
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 (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))
    -- this is redundant starting with base-4.11 / GHC 8.4
    mappend = (<>)
#endif
#else
-- for ghc 7.10
instance Monoid (Xml Attr) where
    mempty = noAttrs
    mappend = mappendAttr
#endif


--
-- Elements
--

-- | Class for adding children to an element.
--
-- The various instances of this class allow the addition of different kinds
-- of children.
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
'>'

-- | Construct a simple-named element with the given children.
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

-- | Construct a simple-named element without any children.
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)

-- | Construct an element with the given children.
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)
`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 (m :: * -> *) a. Monad m => a -> m a
return (Elem
builderOut, NsEnv
oldUriMap)

-- | Construct an element without any children.
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)

-- |  Merges a list of elements into a single piece of XML at the element level.
xelems :: [Xml Elem] -> Xml Elem
xelems :: [Xml Elem] -> Xml Elem
xelems = [Xml Elem] -> Xml Elem
forall a. Monoid a => [a] -> a
M.mconcat

-- | No elements at all.
noElems :: Xml Elem
noElems :: Xml Elem
noElems = Xml Elem
forall t. Renderable t => Xml t
xempty

-- | The expression @xelemWithText n t@ constructs an XML element with name @n@ and text content @t@.
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 (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))
    -- this is redundant starting with base-4.11 / GHC 8.4
    mappend = (<>)
#endif
#else
-- for ghc 7.10
instance Monoid (Xml Elem) where
    mempty = noElems
    mappend = mappendElem
#endif
--
-- Other XML constructs
--

-- | Class providing methods for adding processing instructions and comments.
class Renderable t => Misc t where
    -- | Constructs a processing instruction with the given target and content.
    -- /Note:/ Rendering does not perform escaping on the target and the content.
    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 (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)
    -- | Constructs an XML comment.
    -- /Note:/ No escaping is performed on the text of the comment.
    xcomment :: 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 (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

--
-- Operators
--

-- Note: (<>) is defined in Data.Monoid starting with base 4.5.0.0
#ifndef BASE_AT_LEAST_4_5_0_0
infixl 6 <>
-- | Shortcut for the 'mappend' functions of monoids. Used to concatenate elements, attributes
--   and text nodes.
(<>) :: Monoid t => t -> t -> t
(<>) = mappend
#endif

infixl 5 <#>
-- | Shortcut for constructing pairs. Used in combination with 'xelem' for separating child-attributes
--   from child-elements.
(<#>) :: a -> b -> (a, b)
<#> :: forall a b. a -> b -> (a, b)
(<#>) a
x b
y = (a
x, b
y)

--
-- Rendering
--

-- | Instances of the @XmlOutput@ class may serve as target of serializing an XML document.
class XmlOutput t where
    -- | Creates the target type from a 'Builder'.
    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

-- | Any type subject to rendering must implement this type class.
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

-- | Renders a given piece of XML.
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

--
-- Utilities
--

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 ->  -- empty prefix not in use
                  (Maybe (Text, Text)
forall a. Maybe a
Nothing, Text
T.empty, NsEnv
env { ne_noNamespaceInUse :: Bool
ne_noNamespaceInUse = Bool
True })
                Just Text
uri -> -- empty prefix mapped to 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
      -- copied from xml-light
      escChar :: Char -> Text -> Text
escChar Char
c = case Char
c of
        Char
'<'   -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&lt;")
        Char
'>'   -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&gt;")
        Char
'&'   -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&amp;")
        Char
'"'   -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&quot;")
        -- we use &#39 instead of &apos; because IE apparently has difficulties
        -- rendering &apos; in xhtml.
        -- Reported by Rohan Drape <rohan.drape@gmail.com>.
        Char
'\''  -> Text -> Text -> Text
T.append (String -> Text
T.pack String
"&#39;")
        -- XXX: Is this really wortherd?
        -- We could deal with these issues when we convert characters to bytes.
        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

--
-- XHTML
--

-- | Document type for XHTML 1.0 strict.
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\">"

-- | Document info for XHTML 1.0 strict.
xhtmlStrictDocInfo :: DocInfo
xhtmlStrictDocInfo :: DocInfo
xhtmlStrictDocInfo = DocInfo
defaultDocInfo { docInfo_docType :: Maybe String
docInfo_docType = String -> Maybe String
forall a. a -> Maybe a
Just String
xhtmlDoctypeStrict }

-- | Document type for XHTML 1.0 transitional.
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\">"

-- | Document info for XHTML 1.0 transitional.
xhtmlTransitionalDocInfo :: DocInfo
xhtmlTransitionalDocInfo :: DocInfo
xhtmlTransitionalDocInfo = DocInfo
defaultDocInfo { docInfo_docType :: Maybe String
docInfo_docType = String -> Maybe String
forall a. a -> Maybe a
Just String
xhtmlDoctypeTransitional }

-- | Document type for XHTML 1.0 frameset.
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\">"

-- | Document info for XHTML 1.0 frameset.
xhtmlFramesetDocInfo :: DocInfo
xhtmlFramesetDocInfo :: DocInfo
xhtmlFramesetDocInfo = DocInfo
defaultDocInfo { docInfo_docType :: Maybe String
docInfo_docType = String -> Maybe String
forall a. a -> Maybe a
Just String
xhtmlDoctypeFrameset }

-- | Constructs the root element of an XHTML document.
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)