diff --git a/src/Text/XML/Generator.hs b/src/Text/XML/Generator.hs --- a/src/Text/XML/Generator.hs +++ b/src/Text/XML/Generator.hs @@ -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 "") 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 . - '\'' -> 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) diff --git a/src/Text/XML/GeneratorBenchmarks.hs b/src/Text/XML/GeneratorBenchmarks.hs deleted file mode 100644 --- a/src/Text/XML/GeneratorBenchmarks.hs +++ /dev/null @@ -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]) diff --git a/src/Text/XML/GeneratorTest.hs b/src/Text/XML/GeneratorTest.hs deleted file mode 100644 --- a/src/Text/XML/GeneratorTest.hs +++ /dev/null @@ -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 diff --git a/test/GeneratorBenchmarks.hs b/test/GeneratorBenchmarks.hs new file mode 100644 --- /dev/null +++ b/test/GeneratorBenchmarks.hs @@ -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]) diff --git a/test/GeneratorTest.hs b/test/GeneratorTest.hs new file mode 100644 --- /dev/null +++ b/test/GeneratorTest.hs @@ -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 diff --git a/xmlgen.cabal b/xmlgen.cabal --- a/xmlgen.cabal +++ b/xmlgen.cabal @@ -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 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