xmlgen (empty) → 0.4.0.0
raw patch · 6 files changed
+926/−0 lines, 6 filesdep +HTFdep +MissingHdep +basesetup-changed
Dependencies added: HTF, MissingH, base, blaze-builder, bytestring, containers, criterion, filepath, hxt, monads-tf, process, text, unix, xml-types
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- src/Text/XML/Generator.hs +635/−0
- src/Text/XML/GeneratorBenchmarks.hs +28/−0
- src/Text/XML/GeneratorTest.hs +179/−0
- xmlgen.cabal +51/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c)2010, Stefan Schmidt, Stefan Wehr, Johannes Weiss, David Leuschner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Stefan Schmidt, Stefan Wehr, Johannes Weiss,+ David Leuschner nor the names of other contributors may be used to+ endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/XML/Generator.hs view
@@ -0,0 +1,635 @@+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses, BangPatterns,+ UndecidableInstances, OverlappingInstances #-}+-- | 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+ , namespace, noNamespace, defaultNamespace+ -- * Elements+ , Elem, MkElem(xelem), MkEmptyElem(xelemEmpty), AddChildren+ , xelems, noElems, xelemWithText, (<>), (<#>)+ -- * Attributes+ , Attr, MkAttr(xattr, xattrRaw)+ , xattrs, noAttrs+ -- * Text+ , RawTextContent, TextContent+ , xtext, xtextRaw, xentityRef+ -- * Other+ , xempty , Misc(xprocessingInstruction, xcomment)+ -- * Rendering+ , xrender+ , XmlOutput(fromBuilder), Renderable+ -- * XHTML documents+ , xhtmlFramesetDocInfo, xhtmlStrictDocInfo, xhtmlTransitionalDocInfo+ , xhtmlRootElem++) where++{-+TODO:++- documentation++-}++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 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++--+-- Basic definitions+--++-- | A piece of XML at the element level.+newtype Elem = Elem { unElem :: Builder }++-- | A piece of XML at the attribute level.+newtype Attr = Attr { unAttr :: Builder }++-- | A piece of XML at the document level.+newtype Doc = Doc { unDoc :: Builder }++-- | Namespace prefix.+type Prefix = String++-- | Namespace URI.+type Uri = String -- must not be empty++-- | Type for representing presence or absence of an XML namespace.+data Namespace+ = NoNamespace+ | DefaultNamespace+ | QualifiedNamespace Prefix Uri+ deriving (Show, Eq)++-- | Constructs a qualified XML namespace.+-- The given URI must not be the empty string.+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++-- | A 'Namespace' value denoting the absence of any XML namespace information.+noNamespace :: Namespace+noNamespace = 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 = DefaultNamespace++data NsEnv = NsEnv { ne_namespaceMap :: Map.Map Prefix Uri+ , ne_noNamespaceInUse :: Bool }++emptyNsEnv :: NsEnv+emptyNsEnv = NsEnv Map.empty 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 { unXml :: Reader NsEnv (t, NsEnv) }++runXml :: NsEnv -> Xml t -> (t, NsEnv)+runXml nsEnv (Xml x) = runReader x nsEnv++-- | An empty, polymorphic piece of XML.+xempty :: Renderable t => Xml t+xempty = Xml $+ do env <- ask+ return (mkRenderable mempty, env)++--+-- Document+--++-- | The 'DocInfo' type contains all information of an XML document except the root element.+data DocInfo+ = DocInfo+ { docInfo_standalone :: Bool -- ^ Value of the @standalone@ attribute in the @\<?xml ... ?\>@ header+ , docInfo_docType :: Maybe String -- ^ Document type (N.B.: rendering does not escape this value)+ , docInfo_preMisc :: Xml Doc -- ^ Content before the root element+ , 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 { docInfo_standalone = True+ , docInfo_docType = Nothing+ , docInfo_preMisc = xempty+ , docInfo_postMisc = xempty }++-- | Constructs an XML document from a 'DocInfo' value and the root element.+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++--+-- Text content+--++-- | Construction of text content not subject to escaping.+class RawTextContent t where+ rawTextBuilder :: t -> Builder++-- | Construction of text content subject to escaping.+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++--+-- Attributes+--++-- | Class providing methods for constructing XML attributes.+--+-- The 'String' instance of this class constructs an attribute with a name+-- in the default namespace, the 'Namespace' instance allows customization+-- of namespaces.+class MkAttr n t where+ type MkAttrRes n t+ -- | Construct an attribute by escaping its value+ xattr :: TextContent t => n -> MkAttrRes n t+ -- | Construct an attribute without escaping its value.+ -- /Note:/ attribute values are quoted with double quotes.+ 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++-- value is escaped+xattrQ :: TextContent t => Namespace -> String -> t -> Xml Attr+xattrQ ns key value = xattrQRaw' ns key (textBuilder value)++-- value is NOT escaped+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 ":"++-- | Merges a list of attributes into a single piece of XML at the attribute level.+xattrs :: [Xml Attr] -> Xml Attr+xattrs = foldr mappend noAttrs++-- | The empty attribute list.+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'')++--+-- 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 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 providing methods for constructing XML elements.+--+-- The 'String' instance of this class constructs an element in the+-- default namespace, the 'Namespace' instance allows customization of+-- namespaces.+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 providing a method for constructing XML elements without children.+--+-- The 'String' instance of this class constructs an element in the+-- default namespace, the 'Namespace' instance allows customization of+-- namespaces.+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)++-- | Merges a list of elements into a single piece of XML at the element level.+xelems :: [Xml Elem] -> Xml Elem+xelems = foldr mappend noElems++-- | No elements at all.+noElems :: Xml Elem+noElems = xempty++-- | The expression @xelemWithText n t@ constructs an XML element with name @n@ and text content @t@.+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'')++--+-- Other XML constructs+--++-- | Constructs a text node by escaping the given argument.+xtext :: TextContent t => t -> Xml Elem+xtext content = Xml $+ do env <- ask+ return (Elem $ textBuilder content, env)++-- | Constructs a text node /without/ escaping the given argument.+xtextRaw :: RawTextContent t => t -> Xml Elem+xtextRaw content = Xml $+ do env <- ask+ return (Elem $ rawTextBuilder content, env)++-- | Constructs a reference to the named entity.+-- /Note:/ no escaping is performed on the name of the entity+xentityRef :: String -> Xml Elem+xentityRef name = Xml $+ do env <- ask+ return (Elem $ fromChar '&' <> fromString name <> fromChar ';', env)++-- | 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 content = Xml $+ do env <- ask+ return (mkRenderable $+ fromString "<?" <>+ fromString target <>+ fromChar ' ' <>+ fromString content <>+ fromString "?>",+ env)+ -- | Constructs an XML comment.+ -- /Note:/ No escaping is performed on the text of the comment.+ xcomment :: String -> Xml t+ xcomment content = Xml $+ do env <- ask+ return (mkRenderable $+ fromString "<!--" <>+ fromString content <>+ fromString "-->",+ env)++instance Misc Elem+instance Misc Doc++--+-- Operators+--++infixl 6 <>+-- | Shortcut for the 'mappend' functions of monoids. Used to concatenate elements, attributes+-- and text nodes.+(<>) :: Monoid t => t -> t -> t+(<>) = mappend++infixl 5 <#>+-- | Shortcut for coonstructing pairs. Used in combination with 'xelem' for separating child-attributes+-- from child-elements.+(<#>) :: a -> b -> (a, b)+(<#>) x y = (x, 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 b = b++instance XmlOutput BS.ByteString where+ fromBuilder = toByteString++instance XmlOutput BSL.ByteString where+ fromBuilder = 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 b) = b+ mkRenderable = Elem++instance Renderable Attr where+ builder (Attr b) = b+ mkRenderable = Attr++instance Renderable Doc where+ builder (Doc b) = b+ mkRenderable = Doc++-- | Renders a given piece of XML.+xrender :: (Renderable r, XmlOutput t) => Xml r -> t+xrender r = fromBuilder $ builder r'+ where+ r' = fst $ runXml emptyNsEnv r++--+-- Utilities+--++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 -> -- empty prefix not in use+ (Nothing, "", env { ne_noNamespaceInUse = True })+ Just uri -> -- empty prefix mapped to 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++{-# SPECIALIZE INLINE genericEscape ::+ ((Char -> String -> String) -> String -> String -> String)+ -> (String -> String -> String)+ -> (Char -> String -> String)+ -> String+ -> String #-}+{-# SPECIALIZE INLINE genericEscape ::+ ((Char -> T.Text -> T.Text) -> T.Text -> T.Text -> T.Text)+ -> (T.Text -> T.Text -> T.Text)+ -> (Char -> T.Text -> T.Text)+ -> T.Text+ -> T.Text #-}+{-# SPECIALIZE INLINE genericEscape ::+ ((Char -> TL.Text -> TL.Text) -> TL.Text -> TL.Text -> TL.Text)+ -> (TL.Text -> TL.Text -> TL.Text)+ -> (Char -> TL.Text -> TL.Text)+ -> TL.Text+ -> TL.Text #-}+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+ -- copied from xml-light+ escChar c = case c of+ '<' -> showString "<"+ '>' -> showString ">"+ '&' -> showString "&"+ '"' -> showString """+ -- we use ' instead of ' because IE apparently has difficulties+ -- rendering ' in xhtml.+ -- Reported by Rohan Drape <rohan.drape@gmail.com>.+ '\'' -> showString "'"+ -- XXX: Is this really wortherd?+ -- We could deal with these issues when we convert characters to bytes.+ _ | (oc <= 0x7f && isPrint c) || c == '\n' || c == '\r' -> showChar c+ | otherwise -> showString "&#" . showString (show oc) . showChar ';'+ where oc = ord c+ showString = showString' . S.fromString++--+-- XHTML+--++-- | Document type for XHTML 1.0 strict.+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\">"++-- | Document info for XHTML 1.0 strict.+xhtmlStrictDocInfo :: DocInfo+xhtmlStrictDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeStrict }++-- | Document type for XHTML 1.0 transitional.+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\">"++-- | Document info for XHTML 1.0 transitional.+xhtmlTransitionalDocInfo :: DocInfo+xhtmlTransitionalDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeTransitional }++-- | Document type for XHTML 1.0 frameset.+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\">"++-- | Document info for XHTML 1.0 frameset.+xhtmlFramesetDocInfo :: DocInfo+xhtmlFramesetDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeFrameset }++-- | Constructs the root element of an XHTML document.+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)
+ src/Text/XML/GeneratorBenchmarks.hs view
@@ -0,0 +1,28 @@+import Criterion.Main+import qualified Data.ByteString.Lazy as BSL+import System.Environment+import qualified Data.Text as T++import Text.XML.Generator++gen1 :: Int -> IO ()+gen1 numberOfElems = BSL.writeFile "/tmp/test.xml" (xrender doc)+ where doc = xelem "root" $ xelems $ map (\s -> xelem "foo" (xattr "key" s, xtext s)) (map (\i -> T.pack (show i) :: T.Text) [1..numberOfElems])++gen2 :: Int -> IO ()+gen2 numberOfElems = BSL.writeFile "/tmp/test.xml" (xrender doc)+ where doc = xelem "root" $ foldr (<>) xempty $ map (\s -> xelem "foo" (xattr "key" s, xtext s)) (map (\i -> T.pack (show i) :: T.Text) [1..numberOfElems])++gen3 :: Int -> IO ()+gen3 numberOfElems = BSL.writeFile "/tmp/test.xml" (xrender doc)+ where doc = xelem "root" $ xattrs $ map (\s -> xattr "key" s) (map (\i -> T.pack (show i) :: T.Text) [1..numberOfElems])++main =+ do args <- getArgs+ case args of+ "--standalone-1":s:[] -> gen1 (read s)+ "--standalone-2":s:[] -> gen2 (read s)+ "--standalone-3":s:[] -> gen3 (read s)+ _ -> defaultMain (concatMap (\i -> [bench ("gen1 " ++ show i) (gen1 i),+ bench ("gen2 " ++ show i) (gen2 i),+ bench ("gen3 " ++ show i) (gen3 i)]) [1000, 10000, 100000, 1000000])
+ src/Text/XML/GeneratorTest.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}++import Prelude hiding (catch)++import Control.Exception (catch, SomeException)++import System.Process+import System.Posix.Temp+import System.FilePath+import System.IO+import System.IO.Unsafe+import System.Environment++import Data.Char (ord, chr)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC++import Text.XML.HXT.Core hiding (xshow)+import Text.XML.HXT.DOM.ShowXml (xshow)+import Data.Tree.NTree.TypeDefs++import Data.String.Utils+import Data.String+import qualified Data.Text as T++import Test.Framework++import Text.XML.Generator++test :: Renderable r => FilePath -> Xml r -> IO ()+test f x = BSL.writeFile f (xrender x)++_NS_PR1_NS1_ = namespace "foo" "urn:foo"+_NS_PR4_NS1_ = namespace "___foo" "urn:foo"+_NS_PR2_NS2_ = namespace "_foo" "urn:_foo"+_NS_PR3_NS3_ = namespace "__foo" "urn:__foo"+_NS_PR1_NS3_ = namespace "foo" "urn:bar"++testNS :: Namespace+testNS = namespace "foo" "http://www.example.com"++xsample1 :: Xml Elem+xsample1 =+ xelem _NS_PR3_NS3_ "foo"+ (xattr _NS_PR2_NS2_ "key" "value" <>+ xattr _NS_PR2_NS2_ "key2" "value",+ xelem _NS_PR1_NS1_ "bar" (xattr _NS_PR2_NS2_ "key" "value" <#> xtext "BAR") <>+ xelem _NS_PR1_NS1_ "bar"+ (xelem _NS_PR1_NS3_ "spam" (xelemEmpty "egg" <> xtext "this is spam!")))++test_1 =+ do out <- runXmllint xsample1+ exp <- readExpected "1.xml"+ assertEqual exp out++xsample2 :: Xml Elem+xsample2 = xelem "foo" $+ xattr "key" "value" <>+ xattr "key2" "value2" <#>+ xelemEmpty "bar" <>+ xelem "spam" (xattr "key" "value") <>+ xelem "egg" (xtext "ham") <>+ xelemEmpty testNS "bar" <>+ xelem testNS "spam" (xattr testNS "key" "value") <>+ xelem testNS "egg" (xelemEmpty "ham")++test_2 =+ do out <- runXmllint xsample2+ exp <- readExpected "2.xml"+ assertEqual exp out++xsample3 :: Xml Doc+xsample3 =+ doc defaultDocInfo $ xelem "foo" $ xattr "key" "val\"'&<>ue" <#> xtext "<&;'"++test_3 =+ do out <- runXmllint xsample3+ exp <- readExpected "3.xml"+ assertEqual exp out++xsample4 :: Xml Elem+xsample4 =+ xelem ns "x" (attrs <#>+ xelem noNamespace "y" (attrs <#> xelem ns "z" attrs))+ where+ attrs = xattr ns "a" "in URI" <>+ xattr noNamespace "b" "in no ns" <>+ xattr defaultNamespace "c" "in default ns"+ ns = namespace "" "http://URI"++test_4 =+ do out <- runXmllint xsample4+ exp <- readExpected "4.xml"+ assertEqual exp out++xsample5 :: Xml Doc+xsample5 =+ doc defaultDocInfo $+ xelem "people" $+ xelems $ map (\(name, age) -> xelem "person" (xattr "age" age <#> xtext name)) people+ where+ people = [("Stefan", "32"), ("Judith", "4")]++test_5 =+ do out <- runXmllint xsample5+ exp <- readExpected "5.xml"+ assertEqual exp out++xhtmlSample :: Xml Elem+xhtmlSample =+ xhtmlRootElem "de" (xelem "head" (xelem "title" "Test") <> xelem "body" (xattr "foo" "1"))++test_xhtml =+ do out <- runXmllint xhtmlSample+ exp <- readExpected "xhtml.xml"+ assertEqual exp out++readExpected name =+ readFile ("test" </> name)+ `catch` (\(e::SomeException) -> do hPutStrLn stderr (show e)+ return "")++runXmllint :: Renderable r => Xml r -> IO String+runXmllint x =+ do (name, handle) <- mkstemp "/tmp/xmlgen-test-XXXXXX"+ let rx = xrender x+ BSL.hPut handle rx+ hClose handle+ readProcess "xmllint" ["--format", name] ""++prop_textOk (ValidXmlString s) =+ let docStr = xelem "root" (xattr "attr" s, xtext s)+ docText = xelem "root" (xattr "attr" t, xtext t)+ treeListStr = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender docStr))+ treeListText = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender docText))+ in treeListStr == treeListText+ where+ t = fromString s :: T.Text++prop_quotingOk (ValidXmlString s) =+ let doc = xelem "root" (xattr "attr" s, xtext s)+ treeList = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender doc))+ root = head treeList+ in case childrenOfNTree root of+ [NTree root children] ->+ let attrValue = case root of+ XTag _ [NTree _ attrs] -> xshow attrs+ XTag _ [NTree _ [NTree (XText attrValue) _]] -> attrValue+ XTag _ [NTree _ []] -> ""+ textValue = case children of+ elems -> xshow elems+ [NTree (XText textValue) _] -> textValue+ [] -> ""+ in normWsAttr s == attrValue && normWsElem s == textValue+ l -> error (show root ++ "\n" ++ show l)+ where+ normWsAttr = replace "\r" " " . replace "\n" " " . replace "\n\r" " "+ normWsElem = replace "\r" "\n" . replace "\n\r" "\b"+ childrenOfNTree (NTree _ l) = l++newtype ValidXmlString = ValidXmlString String+ deriving (Eq, Show)++instance Arbitrary ValidXmlString where+ arbitrary = sized $ \n ->+ do k <- choose (0, n)+ s <- sequence [validXmlChar | _ <- [1..k] ]+ return $ ValidXmlString s+ where+ validXmlChar =+ let l = map chr ([0x9, 0xA, 0xD] ++ [0x20..0xD7FF] +++ [0xE000..0xFFFD] ++ [0x10000..0x10FFFF])+ in elements l++main =+ do args <- getArgs+ runTestWithArgs args allHTFTests
+ xmlgen.cabal view
@@ -0,0 +1,51 @@+Name: xmlgen+Version: 0.4.0.0+Synopsis: Fast XML generation library+Description: Library for high-performance XML generation.+License: BSD3+License-file: LICENSE+Author: Stefan Wehr, Stefan Schmidt, Johannes Weiss, David Leuschner+Maintainer: Stefan Wehr <wehr@factisresearch.com>+Category: Text+Build-type: Simple+Cabal-version: >=1.6++Source-Repository head+ type: git+ location: https://github.com/skogsbaer/xmlgen++Library+ Exposed-modules: Text.XML.Generator+ Hs-Source-Dirs: src+ Build-Depends: base >= 4.2 && < 4.4, blaze-builder == 0.3.*,+ bytestring == 0.9.*, containers >= 0.3 && < 0.5,+ monads-tf == 0.1.*, text >= 0.10 && < 0.12,+ xml-types == 0.3.*+ Ghc-Prof-Options: -auto-all -caf-all++Flag tests+ description: Build test suite+ default: False++Executable tests+ If flag(tests)+ Build-Depends: HTF == 0.7.*, MissingH == 1.1.*, hxt == 9.0.*,+ filepath == 1.2.*, unix == 2.4.*, process == 1.0.*+ Else+ Buildable: False+ Hs-Source-Dirs: src+ Main-Is: Text/XML/GeneratorTest.hs++Flag benchmarks+ description: Build benchmarks+ default: False++Executable benchmarks+ If flag(benchmarks)+ Build-Depends: criterion == 0.5.*+ Else+ Buildable: False+ Hs-Source-Dirs: src+ Ghc-Options: -O2+ Ghc-Prof-Options: -auto-all -caf-all+ Main-Is: Text/XML/GeneratorBenchmarks.hs