{-# 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 :: Name -> Builder
nameBuilder = Name -> 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 :: 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

-- | 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 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

-- | 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 { 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

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

--
-- 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 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

--
-- Text content
--

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

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

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

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

--
-- Attributes
--

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

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

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

-- |  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 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))
    -- 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 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 '>'

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

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

-- | Construct an element with the given children.
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)

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

-- |  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 :: 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))
    -- 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 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)
    -- | Constructs an XML comment.
    -- /Note:/ No escaping is performed on the text of the comment.
    xcomment :: 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

--
-- 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)
<#> :: a -> b -> (a, b)
(<#>) x :: a
x y :: 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 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

-- | 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 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

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

--
-- Utilities
--

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

--
-- XHTML
--

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

-- | 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 =
    "<!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\">"

-- | 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 =
    "<!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\">"

-- | 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 :: 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)