xmlgen 0.4.0.3 → 0.6.0.0
raw patch · 6 files changed
+327/−407 lines, 6 filesdep +xmlgendep −MissingHdep ~HTFdep ~basedep ~criterion
Dependencies added: xmlgen
Dependencies removed: MissingH
Dependency ranges changed: HTF, base, criterion, filepath, hxt, process, unix
Files
- src/Text/XML/Generator.hs +101/−180
- src/Text/XML/GeneratorBenchmarks.hs +0/−22
- src/Text/XML/GeneratorTest.hs +0/−179
- test/GeneratorBenchmarks.hs +22/−0
- test/GeneratorTest.hs +182/−0
- xmlgen.cabal +22/−26
src/Text/XML/Generator.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses, BangPatterns,- UndecidableInstances, OverlappingInstances, CPP #-}+{-# 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:@@ -27,16 +28,16 @@ -- * Documents , Doc, DocInfo(..), doc, defaultDocInfo -- * Namespaces- , Namespace, Prefix, Uri+ , Namespace, Prefix, Uri, Name , namespace, noNamespace, defaultNamespace -- * Elements- , Elem, MkElem(xelem), MkEmptyElem(xelemEmpty), AddChildren+ , Elem, xelem, xelemQ, xelemEmpty, xelemQEmpty, AddChildren , xelems, noElems, xelemWithText, (<>), (<#>) -- * Attributes- , Attr, MkAttr(xattr, xattrRaw)+ , Attr, xattr, xattrQ, xattrQRaw , xattrs, noAttrs -- * Text- , RawTextContent, TextContent+ , TextContent , xtext, xtextRaw, xentityRef -- * Other , xempty , Misc(xprocessingInstruction, xcomment)@@ -98,11 +99,17 @@ newtype Doc = Doc { unDoc :: Builder } -- | Namespace prefix.-type Prefix = String+type Prefix = T.Text -- | Namespace URI.-type Uri = String -- must not be empty+type Uri = T.Text -- must not be empty +-- | A type for names+type Name = T.Text++nameBuilder :: Name -> Builder+nameBuilder = fromText+ -- | Type for representing presence or absence of an XML namespace. data Namespace = NoNamespace@@ -113,9 +120,9 @@ -- | 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+namespace p u = if T.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@@ -192,76 +199,49 @@ -- 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+-- | Text content subject to escaping.+type TextContent = T.Text -instance RawTextContent TL.Text where- rawTextBuilder = fromLazyText+textBuilder :: TextContent -> Builder+textBuilder = fromText . escapeText -instance TextContent TL.Text where- escape = genericEscape TL.foldr TL.append TL.cons+-- | Constructs a text node by escaping the given argument.+xtext :: TextContent -> Xml Elem+xtext content = Xml $+ do env <- ask+ return (Elem $ textBuilder content, env) -instance RawTextContent BS.ByteString where- rawTextBuilder = fromByteString+-- | Constructs a text node /without/ escaping the given argument.+xtextRaw :: Builder -> Xml Elem+xtextRaw content = Xml $+ do env <- ask+ return (Elem content, env) -instance RawTextContent BSL.ByteString where- rawTextBuilder = fromLazyByteString+-- | 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 $+ do env <- ask+ return (Elem $ fromChar '&' <> fromText name <> fromChar ';', env) -- -- 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+-- | Construct a simple-named attribute by escaping its value.+xattr :: Name -> TextContent -> Xml Attr+xattr = xattrQ DefaultNamespace --- value is escaped-xattrQ :: TextContent t => Namespace -> String -> t -> Xml Attr-xattrQ ns key value = xattrQRaw' ns key (textBuilder value)+-- | Construct an attribute by escaping its value.+xattrQ :: Namespace -> Name -> TextContent -> Xml Attr+xattrQ ns key value = xattrQRaw' ns (nameBuilder key) (textBuilder value) --- value is NOT escaped-xattrQRaw :: RawTextContent t => Namespace -> String -> t -> Xml Attr-xattrQRaw ns key value = xattrQRaw' ns key (rawTextBuilder value)+-- | Construct an attribute without escaping its value.+-- /Note:/ attribute values are quoted with double quotes.+xattrQRaw :: Namespace -> Name -> Builder -> Xml Attr+xattrQRaw ns key value = xattrQRaw' ns (nameBuilder key) value -xattrQRaw' :: Namespace -> String -> Builder -> Xml Attr+xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr xattrQRaw' ns' key valueBuilder = Xml $ do uriMap' <- ask let (mDecl, prefix, uriMap) = extendNsEnv True uriMap' ns'@@ -269,29 +249,28 @@ case mDecl of Nothing -> mempty Just (p, u) ->- let uriBuilder = fromString u+ let uriBuilder = fromText u prefixBuilder =- if null p then mempty else colonBuilder `mappend` fromString p+ if T.null p then mempty else colonBuilder `mappend` fromText p in spaceBuilder `mappend` nsDeclStartBuilder `mappend` prefixBuilder `mappend` startBuilder `mappend` uriBuilder `mappend` endBuilder prefixBuilder =- if null prefix+ if T.null prefix then spaceBuilder- else spaceBuilder `mappend` fromString prefix `mappend` colonBuilder+ else spaceBuilder `mappend` fromText prefix `mappend` colonBuilder builder = nsDeclBuilder `mappend` prefixBuilder `mappend`- keyBuilder `mappend` startBuilder `mappend`+ key `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.+-- | Merge a list of attributes into a single piece of XML at the attribute level. xattrs :: [Xml Attr] -> Xml Attr xattrs = M.mconcat @@ -334,68 +313,53 @@ (Elem builder', _) = runXml uriMap' elems in builder `mappend` fromString "\n>" `mappend` builder' -instance TextContent t => AddChildren t where+instance AddChildren (Xml Attr, [Xml Elem]) where+ addChildren (attrs, elems) uriMap = addChildren (attrs, xelems elems) uriMap++instance AddChildren TextContent where addChildren t _ = fromChar '>' <> textBuilder t +instance AddChildren String where+ addChildren t _ = fromChar '>' <> fromString 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)+-- | Construct a simple-named element with the given children.+xelem :: (AddChildren c) => Name -> c -> Xml Elem+xelem = xelemQ DefaultNamespace -instance MkEmptyElem Namespace where- type MkEmptyElemRes Namespace = String -> Xml Elem- xelemEmpty ns name = xelemQ ns name (mempty :: Xml Elem)+-- | Construct a simple-named element without any children.+xelemEmpty :: Name -> Xml Elem+xelemEmpty name = xelemQ DefaultNamespace name (mempty :: Xml Elem) -xelemQ :: AddChildren c => Namespace -> String -> c -> Xml Elem+-- | Construct an element with the given children.+xelemQ :: (AddChildren c) => Namespace -> Name -> 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+ if T.null prefix+ then nameBuilder name+ else fromText prefix `mappend` fromString ":" `mappend` nameBuilder name let nsDeclBuilder = case mDecl of Nothing -> mempty Just (p, u) -> let prefixBuilder =- if null p then mempty else fromChar ':' `mappend` fromString p+ if T.null p then mempty else fromChar ':' `mappend` fromText p in fromString " xmlns" `mappend` prefixBuilder `mappend` fromString "=\""- `mappend` fromString u `mappend` fromString "\""+ `mappend` fromText 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) +-- | Construct an element without any children.+xelemQEmpty :: Namespace -> Name -> Xml Elem+xelemQEmpty ns name = xelemQ ns name (mempty :: Xml Elem)+ -- | Merges a list of elements into a single piece of XML at the element level. xelems :: [Xml Elem] -> Xml Elem xelems = M.mconcat@@ -405,7 +369,7 @@ 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 :: Name -> TextContent -> Xml Elem xelemWithText n t = xelem n (xtext t) instance Monoid (Xml Elem) where@@ -420,25 +384,6 @@ -- 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.@@ -535,18 +480,18 @@ extendNsEnv isAttr env ns = case ns of NoNamespace- | isAttr -> (Nothing, "", env)+ | isAttr -> (Nothing, T.empty, env) | otherwise ->- case Map.lookup "" (ne_namespaceMap env) of+ case Map.lookup T.empty (ne_namespaceMap env) of Nothing -> -- empty prefix not in use- (Nothing, "", env { ne_noNamespaceInUse = True })+ (Nothing, T.empty, env { ne_noNamespaceInUse = True }) Just uri -> -- empty prefix mapped to uri- (Just ("", ""), "", env { ne_namespaceMap = Map.delete "" (ne_namespaceMap env)+ (Just (T.empty, T.empty), T.empty, env { ne_namespaceMap = Map.delete T.empty (ne_namespaceMap env) , ne_noNamespaceInUse = True }) DefaultNamespace ->- (Nothing, "", env)+ (Nothing, T.empty, env) QualifiedNamespace p' u ->- let p = if null p' && (isAttr || ne_noNamespaceInUse env) then "_" else p'+ let p = if T.null p' && (isAttr || ne_noNamespaceInUse env) then T.pack "_" else p' (mDecl, prefix, newMap) = genValidPrefix (ne_namespaceMap env) p u in (mDecl, prefix, env { ne_namespaceMap = newMap }) where@@ -556,50 +501,26 @@ Just foundUri -> if foundUri == uri then (Nothing, prefix, map)- else genValidPrefix map ('_':prefix) uri+ else genValidPrefix map (T.cons '_' 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+escapeText :: T.Text -> T.Text+escapeText = T.foldr escChar T.empty where -- copied from xml-light escChar c = case c of- '<' -> showString "<"- '>' -> showString ">"- '&' -> showString "&"- '"' -> showString """+ '<' -> T.append (T.pack "<")+ '>' -> T.append (T.pack ">")+ '&' -> T.append (T.pack "&")+ '"' -> T.append (T.pack """) -- we use ' instead of ' because IE apparently has difficulties -- rendering ' in xhtml. -- Reported by Rohan Drape <rohan.drape@gmail.com>.- '\'' -> showString "'"+ '\'' -> T.append (T.pack "'") -- 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 ';'+ _ | (oc <= 0x7f && isPrint c) || c == '\n' || c == '\r' -> T.cons c+ | otherwise -> T.append (T.pack "&#") . T.append (T.pack (show oc)) . T.cons ';' where oc = ord c- showString = showString' . S.fromString -- -- XHTML@@ -639,9 +560,9 @@ xhtmlFramesetDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeFrameset } -- | Constructs the root element of an XHTML document.-xhtmlRootElem :: String -> Xml Elem -> Xml Elem+xhtmlRootElem :: T.Text -> Xml Elem -> Xml Elem xhtmlRootElem lang children =- xelem (namespace "" "http://www.w3.org/1999/xhtml") "html"- (xattr "xml:lang" lang <>- xattr "lang" lang <#>- children)+ xelemQ (namespace (T.pack "") (T.pack "http://www.w3.org/1999/xhtml")) (T.pack "html")+ (xattr (T.pack "xml:lang") lang <>+ xattr (T.pack "lang") lang <#>+ children)
− src/Text/XML/GeneratorBenchmarks.hs
@@ -1,22 +0,0 @@-import Criterion.Main-import qualified Data.ByteString.Lazy as BSL-import System.Environment-import qualified Data.Text as T--import Text.XML.Generator--benchElems :: Int -> IO ()-benchElems 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)) [1..numberOfElems])--benchAttrs :: Int -> IO ()-benchAttrs numberOfElems = BSL.writeFile "/tmp/test.xml" (xrender doc)- where doc = xelem "root" $ xattrs $ map (\s -> xattr ("key-" ++ s) (T.pack s)) (map (\i -> show i) [1..numberOfElems])--main =- do args <- getArgs- case args of- "--elems":s:[] -> benchElems (read s)- "--attrs":s:[] -> benchAttrs (read s)- _ -> defaultMain (concatMap (\i -> [bench (show i ++ " elems") (benchElems i),- bench (show i ++ " attrs") (benchAttrs i)]) [1000, 10000, 100000, 1000000])
− src/Text/XML/GeneratorTest.hs
@@ -1,179 +0,0 @@-{-# 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
+ test/GeneratorBenchmarks.hs view
@@ -0,0 +1,22 @@+import Criterion.Main+import qualified Data.ByteString.Lazy as BSL+import System.Environment+import qualified Data.Text as T++import Text.XML.Generator++benchElems :: Int -> IO ()+benchElems 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)) [1..numberOfElems])++benchAttrs :: Int -> IO ()+benchAttrs numberOfElems = BSL.writeFile "/tmp/test.xml" (xrender doc)+ where doc = xelem "root" $ xattrs $ map (\s -> xattr ("key-" ++ s) (T.pack s)) (map (\i -> show i) [1..numberOfElems])++main =+ do args <- getArgs+ case args of+ "--elems":s:[] -> benchElems (read s)+ "--attrs":s:[] -> benchAttrs (read s)+ _ -> defaultMain (concatMap (\i -> [bench (show i ++ " elems") (benchElems i),+ bench (show i ++ " attrs") (benchAttrs i)]) [1000, 10000, 100000, 1000000])
+ test/GeneratorTest.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++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+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 =+ xelemQ _NS_PR3_NS3_ "foo"+ (xattrQ _NS_PR2_NS2_ "key" "value" <>+ xattrQ _NS_PR2_NS2_ "key2" "value",+ xelemQ _NS_PR1_NS1_ "bar" (xattrQ _NS_PR2_NS2_ "key" "value" <#> xtext "BAR") <>+ xelemQ _NS_PR1_NS1_ "bar"+ (xelemQ _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") <>+ xelemQEmpty testNS "bar" <>+ xelemQ testNS "spam" (xattrQ testNS "key" "value") <>+ xelemQ 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 =+ xelemQ ns "x" (attrs <#>+ xelemQ noNamespace "y" (attrs <#> xelemQ ns "z" attrs))+ where+ attrs = xattrQ ns "a" "in URI" <>+ xattrQ noNamespace "b" "in no ns" <>+ xattrQ 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 = s++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 == T.pack attrValue && normWsElem s == T.pack textValue+ l -> error (show root ++ "\n" ++ show l)+ where+ normWsAttr = T.replace "\r" " " . T.replace "\n" " " . T.replace "\n\r" " "+ normWsElem = T.replace "\r" "\n" . T.replace "\n\r" "\b"+ childrenOfNTree (NTree _ l) = l++newtype ValidXmlString = ValidXmlString T.Text+ deriving (Eq, Show)++instance Arbitrary ValidXmlString where+ arbitrary = sized $ \n ->+ do k <- choose (0, n)+ s <- sequence [validXmlChar | _ <- [1..k] ]+ return $ ValidXmlString (T.pack 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 htf_thisModulesTests
xmlgen.cabal view
@@ -1,5 +1,5 @@ Name: xmlgen-Version: 0.4.0.3+Version: 0.6.0.0 Synopsis: Fast XML generation library Description: Library for high-performance XML generation. License: BSD3@@ -8,8 +8,8 @@ Maintainer: Stefan Wehr <wehr@factisresearch.com> Category: Text, XML Build-type: Simple-Cabal-version: >=1.6-Tested-With: GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1+Cabal-version: >= 1.10+Tested-With: GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1 Source-Repository head type: git@@ -22,30 +22,26 @@ bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.6, mtl >= 2.0 && < 2.2, text >= 0.10 && < 0.12 Ghc-Prof-Options: -auto-all -caf-all--Flag tests- description: Build test suite- default: False+ Default-language: Haskell2010 -Executable tests- If flag(tests)- Build-Depends: HTF == 0.7.*, MissingH == 1.1.*, hxt == 9.1.*,- filepath == 1.2.*, unix == 2.4.*, process == 1.0.*- Else- Buildable: False- Hs-Source-Dirs: src- Main-Is: Text/XML/GeneratorTest.hs+test-suite xmlgen-tests+ Type: exitcode-stdio-1.0+ Hs-Source-Dirs: test+ Main-Is: GeneratorTest.hs+ Build-depends: base >= 4.2 && < 4.7, HTF == 0.9.*, xmlgen, text >= 0.10 && < 0.12,+ containers >= 0.3 && < 0.6, hxt == 9.2.*, bytestring >= 0.9 && < 0.11,+ filepath == 1.3.*, process == 1.1.*+ if !os(windows)+ Build-depends: unix >= 2.4 && < 2.7 -Flag benchmarks- description: Build benchmarks- default: False+ Default-language: Haskell2010 -Executable benchmarks- If flag(benchmarks)- Build-Depends: criterion == 0.5.*- Else- Buildable: False- Hs-Source-Dirs: src- Ghc-Options: -O2 -rtsopts+Benchmark xmlgen-bench+ Type: exitcode-stdio-1.0+ Build-Depends: base >= 4.2 && < 4.7, text >= 0.10 && < 0.12, criterion == 0.6.*,+ bytestring >= 0.9 && < 0.11, xmlgen+ Hs-Source-Dirs: test+ Ghc-Options: -O2 -rtsopts Ghc-Prof-Options: -auto-all -caf-all- Main-Is: Text/XML/GeneratorBenchmarks.hs+ Main-Is: GeneratorBenchmarks.hs+ Default-language: Haskell2010