module Text.XML.Generator (
Xml
, Doc, DocInfo(..), doc, defaultDocInfo
, Namespace, Prefix, Uri
, namespace, noNamespace, defaultNamespace
, Elem, MkElem(xelem), MkEmptyElem(xelemEmpty), AddChildren
, xelems, noElems, xelemWithText, (<>), (<#>)
, Attr, MkAttr(xattr, xattrRaw)
, xattrs, noAttrs
, RawTextContent, 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 Data.Monoid hiding (mconcat)
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
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 { unElem :: Builder }
newtype Attr = Attr { unAttr :: Builder }
newtype Doc = Doc { unDoc :: Builder }
type Prefix = String
type Uri = String
data Namespace
= NoNamespace
| DefaultNamespace
| QualifiedNamespace Prefix Uri
deriving (Show, Eq)
namespace :: Prefix -> Uri -> Namespace
namespace p u = if null u
then error "Text.XML.Generator.ns: namespace URI must not be empty"
else QualifiedNamespace p u
noNamespace :: Namespace
noNamespace = NoNamespace
defaultNamespace :: Namespace
defaultNamespace = DefaultNamespace
data NsEnv = NsEnv { ne_namespaceMap :: Map.Map Prefix Uri
, ne_noNamespaceInUse :: Bool }
emptyNsEnv :: NsEnv
emptyNsEnv = NsEnv Map.empty False
newtype Xml t = Xml { unXml :: Reader NsEnv (t, NsEnv) }
runXml :: NsEnv -> Xml t -> (t, NsEnv)
runXml nsEnv (Xml x) = runReader x nsEnv
xempty :: Renderable t => Xml t
xempty = Xml $
do env <- ask
return (mkRenderable mempty, env)
data DocInfo
= DocInfo
{ docInfo_standalone :: Bool
, docInfo_docType :: Maybe String
, docInfo_preMisc :: Xml Doc
, docInfo_postMisc :: Xml Doc
}
defaultDocInfo :: DocInfo
defaultDocInfo = DocInfo { docInfo_standalone = True
, docInfo_docType = Nothing
, docInfo_preMisc = xempty
, docInfo_postMisc = xempty }
doc :: DocInfo -> Xml Elem -> Xml Doc
doc di rootElem = Xml $
do let prologBuf = fromString "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"" <>
fromString (if standalone then "yes" else "no") <>
fromString "\"?>\n" <>
case mDocType of
Nothing -> mempty
Just s -> fromString s <> fromString "\n"
env <- ask
let Doc preBuf = fst $ runXml env preMisc
Elem elemBuf = fst $ runXml env rootElem
Doc postBuf = fst $ runXml env postMisc
return $ (Doc $ prologBuf `mappend` preBuf `mappend` elemBuf `mappend` postBuf, env)
where
standalone = docInfo_standalone di
mDocType = docInfo_docType di
preMisc = docInfo_preMisc di
postMisc = docInfo_postMisc di
class RawTextContent t where
rawTextBuilder :: t -> Builder
class RawTextContent t => TextContent t where
escape :: t -> t
textBuilder :: TextContent t => t -> Builder
textBuilder = rawTextBuilder . escape
instance RawTextContent String where
rawTextBuilder = fromString
instance TextContent String where
escape = genericEscape foldr showString showChar
instance RawTextContent T.Text where
rawTextBuilder = fromText
instance TextContent T.Text where
escape = genericEscape T.foldr T.append T.cons
instance RawTextContent TL.Text where
rawTextBuilder = fromLazyText
instance TextContent TL.Text where
escape = genericEscape TL.foldr TL.append TL.cons
instance RawTextContent BS.ByteString where
rawTextBuilder = fromByteString
instance RawTextContent BSL.ByteString where
rawTextBuilder = fromLazyByteString
class MkAttr n t where
type MkAttrRes n t
xattr :: TextContent t => n -> MkAttrRes n t
xattrRaw :: RawTextContent t => n -> MkAttrRes n t
instance MkAttr String t where
type MkAttrRes String t = t -> Xml Attr
xattr = xattrQ DefaultNamespace
xattrRaw = xattrQRaw DefaultNamespace
instance MkAttr Namespace t where
type MkAttrRes Namespace t = String -> t -> Xml Attr
xattr = xattrQ
xattrRaw = xattrQRaw
xattrQ :: TextContent t => Namespace -> String -> t -> Xml Attr
xattrQ ns key value = xattrQRaw' ns key (textBuilder value)
xattrQRaw :: RawTextContent t => Namespace -> String -> t -> Xml Attr
xattrQRaw ns key value = xattrQRaw' ns key (rawTextBuilder value)
xattrQRaw' :: Namespace -> String -> Builder -> Xml Attr
xattrQRaw' ns' key valueBuilder = Xml $
do uriMap' <- ask
let (mDecl, prefix, uriMap) = extendNsEnv True uriMap' ns'
nsDeclBuilder =
case mDecl of
Nothing -> mempty
Just (p, u) ->
let uriBuilder = fromString u
prefixBuilder =
if null p then mempty else colonBuilder `mappend` fromString p
in spaceBuilder `mappend` nsDeclStartBuilder
`mappend` prefixBuilder `mappend` startBuilder `mappend` uriBuilder
`mappend` endBuilder
prefixBuilder =
if null prefix
then spaceBuilder
else spaceBuilder `mappend` fromString prefix `mappend` colonBuilder
builder = nsDeclBuilder `mappend` prefixBuilder `mappend`
keyBuilder `mappend` startBuilder `mappend`
valueBuilder `mappend` endBuilder
return $ (Attr builder, uriMap)
where
spaceBuilder = fromString " "
keyBuilder = fromString key
startBuilder = fromString "=\""
endBuilder = fromString "\""
nsDeclStartBuilder = fromString "xmlns"
colonBuilder = fromString ":"
xattrs :: [Xml Attr] -> Xml Attr
xattrs = M.mconcat
noAttrs :: Xml Attr
noAttrs = xempty
instance Monoid (Xml Attr) where
mempty = noAttrs
mappend x1 x2 = Xml $
do env <- ask
let (Attr b1, env') = runXml env x1
let (Attr b2, env'') = runXml env' x2
return $ (Attr $ b1 `mappend` b2, env'')
class AddChildren c where
addChildren :: c -> NsEnv -> Builder
instance AddChildren (Xml Attr) where
addChildren attrs uriMap =
let (Attr builder', _) = runXml uriMap attrs
in builder' <> fromString "\n>"
instance AddChildren (Xml Elem) where
addChildren elems uriMap =
let (Elem builder', _) = runXml uriMap elems
in fromString "\n>" `mappend` builder'
instance AddChildren (Xml Attr, Xml Elem) where
addChildren (attrs, elems) uriMap =
let (Attr builder, uriMap') = runXml uriMap attrs
(Elem builder', _) = runXml uriMap' elems
in builder `mappend` fromString "\n>" `mappend` builder'
instance TextContent t => AddChildren t where
addChildren t _ = fromChar '>' <> textBuilder t
instance AddChildren () where
addChildren _ _ = fromChar '>'
class AddChildren c => MkElem n c where
type MkElemRes n c
xelem :: n -> MkElemRes n c
instance AddChildren c => MkElem String c where
type MkElemRes String c = c -> Xml Elem
xelem = xelemQ DefaultNamespace
instance AddChildren c => MkElem Namespace c where
type MkElemRes Namespace c = String -> c -> Xml Elem
xelem = xelemQ
class MkEmptyElem n where
type MkEmptyElemRes n
xelemEmpty :: n -> MkEmptyElemRes n
instance MkEmptyElem String where
type MkEmptyElemRes String = Xml Elem
xelemEmpty name = xelemQ DefaultNamespace name (mempty :: Xml Elem)
instance MkEmptyElem Namespace where
type MkEmptyElemRes Namespace = String -> Xml Elem
xelemEmpty ns name = xelemQ ns name (mempty :: Xml Elem)
xelemQ :: AddChildren c => Namespace -> String -> c -> Xml Elem
xelemQ ns' name children = Xml $
do oldUriMap <- ask
let (mDecl, prefix,!uriMap) = oldUriMap `seq` extendNsEnv False oldUriMap ns'
let elemNameBuilder =
if null prefix
then fromString name
else fromString prefix `mappend` fromString ":" `mappend` fromString name
let nsDeclBuilder =
case mDecl of
Nothing -> mempty
Just (p, u) ->
let prefixBuilder =
if null p then mempty else fromChar ':' `mappend` fromString p
in fromString " xmlns" `mappend` prefixBuilder `mappend` fromString "=\""
`mappend` fromString u `mappend` fromString "\""
let b1 = fromString "<"
let b2 = b1 `mappend` elemNameBuilder `mappend` nsDeclBuilder
let b3 = b2 `mappend` addChildren children uriMap
let builderOut = Elem (b3 `mappend` fromString "</" `mappend` elemNameBuilder `mappend` fromString "\n>")
return (builderOut, oldUriMap)
xelems :: [Xml Elem] -> Xml Elem
xelems = M.mconcat
noElems :: Xml Elem
noElems = xempty
xelemWithText :: (TextContent t) => String -> t -> Xml Elem
xelemWithText n t = xelem n (xtext t)
instance Monoid (Xml Elem) where
mempty = noElems
mappend x1 x2 = Xml $
do env <- ask
let (Elem b1, env') = runXml env x1
(Elem b2, env'') = runXml env' x2
return (Elem $ b1 `mappend` b2, env'')
xtext :: TextContent t => t -> Xml Elem
xtext content = Xml $
do env <- ask
return (Elem $ textBuilder content, env)
xtextRaw :: RawTextContent t => t -> Xml Elem
xtextRaw content = Xml $
do env <- ask
return (Elem $ rawTextBuilder content, env)
xentityRef :: String -> Xml Elem
xentityRef name = Xml $
do env <- ask
return (Elem $ fromChar '&' <> fromString name <> fromChar ';', env)
class Renderable t => Misc t where
xprocessingInstruction :: String -> String -> Xml t
xprocessingInstruction target content = Xml $
do env <- ask
return (mkRenderable $
fromString "<?" <>
fromString target <>
fromChar ' ' <>
fromString content <>
fromString "?>",
env)
xcomment :: String -> Xml t
xcomment content = Xml $
do env <- ask
return (mkRenderable $
fromString "<!--" <>
fromString content <>
fromString "-->",
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)
(<#>) x y = (x, y)
class XmlOutput t where
fromBuilder :: Builder -> t
instance XmlOutput Builder where
fromBuilder b = b
instance XmlOutput BS.ByteString where
fromBuilder = toByteString
instance XmlOutput BSL.ByteString where
fromBuilder = toLazyByteString
class Renderable t where
builder :: t -> Builder
mkRenderable :: Builder -> t
instance Renderable Elem where
builder (Elem b) = b
mkRenderable = Elem
instance Renderable Attr where
builder (Attr b) = b
mkRenderable = Attr
instance Renderable Doc where
builder (Doc b) = b
mkRenderable = Doc
xrender :: (Renderable r, XmlOutput t) => Xml r -> t
xrender r = fromBuilder $ builder r'
where
r' = fst $ runXml emptyNsEnv r
extendNsEnv :: Bool -> NsEnv -> Namespace -> (Maybe (Prefix, Uri), Prefix, NsEnv)
extendNsEnv isAttr env ns =
case ns of
NoNamespace
| isAttr -> (Nothing, "", env)
| otherwise ->
case Map.lookup "" (ne_namespaceMap env) of
Nothing ->
(Nothing, "", env { ne_noNamespaceInUse = True })
Just uri ->
(Just ("", ""), "", env { ne_namespaceMap = Map.delete "" (ne_namespaceMap env)
, ne_noNamespaceInUse = True })
DefaultNamespace ->
(Nothing, "", env)
QualifiedNamespace p' u ->
let p = if null p' && (isAttr || ne_noNamespaceInUse env) then "_" else p'
(mDecl, prefix, newMap) = genValidPrefix (ne_namespaceMap env) p u
in (mDecl, prefix, env { ne_namespaceMap = newMap })
where
genValidPrefix map prefix uri =
case Map.lookup prefix map of
Nothing -> (Just (prefix, uri), prefix, Map.insert prefix uri map)
Just foundUri ->
if foundUri == uri
then (Nothing, prefix, map)
else genValidPrefix map ('_':prefix) uri
genericEscape :: (S.IsString s)
=> ((Char -> s -> s) -> s -> s -> s)
-> (s -> s -> s)
-> (Char -> s -> s)
-> s
-> s
genericEscape foldr showString' showChar x = foldr escChar (S.fromString "") x
where
escChar c = case c of
'<' -> showString "<"
'>' -> showString ">"
'&' -> showString "&"
'"' -> showString """
'\'' -> showString "'"
_ | (oc <= 0x7f && isPrint c) || c == '\n' || c == '\r' -> showChar c
| otherwise -> showString "&#" . showString (show oc) . showChar ';'
where oc = ord c
showString = showString' . S.fromString
xhtmlDoctypeStrict :: String
xhtmlDoctypeStrict =
"<!DOCTYPE html\n" ++
" PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" ++
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
xhtmlStrictDocInfo :: DocInfo
xhtmlStrictDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeStrict }
xhtmlDoctypeTransitional :: String
xhtmlDoctypeTransitional =
"<!DOCTYPE html\n" ++
" PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"\n" ++
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
xhtmlTransitionalDocInfo :: DocInfo
xhtmlTransitionalDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeTransitional }
xhtmlDoctypeFrameset :: String
xhtmlDoctypeFrameset =
"<!DOCTYPE html\n" ++
" PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\"\n" ++
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
xhtmlFramesetDocInfo :: DocInfo
xhtmlFramesetDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeFrameset }
xhtmlRootElem :: String -> Xml Elem -> Xml Elem
xhtmlRootElem lang children =
xelem (namespace "" "http://www.w3.org/1999/xhtml") "html"
(xattr "xml:lang" lang <>
xattr "lang" lang <#>
children)