xmlgen-0.6.2.1/0000755000000000000000000000000012267710243011342 5ustar0000000000000000xmlgen-0.6.2.1/LICENSE0000644000000000000000000000312712267710243012352 0ustar0000000000000000Copyright (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. xmlgen-0.6.2.1/Setup.hs0000644000000000000000000000005612267710243012777 0ustar0000000000000000import Distribution.Simple main = defaultMain xmlgen-0.6.2.1/xmlgen.cabal0000644000000000000000000000327712267710243013631 0ustar0000000000000000Name: xmlgen Version: 0.6.2.1 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 Category: Text, XML Build-type: Simple 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 location: https://github.com/skogsbaer/xmlgen Library Exposed-modules: Text.XML.Generator Hs-Source-Dirs: src Build-Depends: base >= 4.2 && < 5, blaze-builder >= 0.3, bytestring >= 0.9, containers >= 0.3, mtl >= 2.0, text >= 0.10 Ghc-Prof-Options: -auto-all -caf-all Default-language: Haskell2010 test-suite xmlgen-tests Type: exitcode-stdio-1.0 Hs-Source-Dirs: test Main-Is: GeneratorTest.hs Build-depends: base >= 4.2 && < 5, xmlgen, text >= 0.10, containers >= 0.3, hxt == 9.3.*, bytestring >= 0.9, filepath >= 1.3, process >= 1.1, HUnit >= 1.2, QuickCheck >= 2.5 if !os(windows) Build-depends: unix >= 2.4 Default-language: Haskell2010 Benchmark xmlgen-bench Type: exitcode-stdio-1.0 Build-Depends: base >= 4.2 && < 5, text >= 0.10, criterion >= 0.6, bytestring >= 0.9, xmlgen Hs-Source-Dirs: test Ghc-Options: -O2 -rtsopts Ghc-Prof-Options: -auto-all -caf-all Main-Is: GeneratorBenchmarks.hs Default-language: Haskell2010 xmlgen-0.6.2.1/src/0000755000000000000000000000000012267710243012131 5ustar0000000000000000xmlgen-0.6.2.1/src/Text/0000755000000000000000000000000012267710243013055 5ustar0000000000000000xmlgen-0.6.2.1/src/Text/XML/0000755000000000000000000000000012267710243013515 5ustar0000000000000000xmlgen-0.6.2.1/src/Text/XML/Generator.hs0000644000000000000000000004472612267710243016014 0ustar0000000000000000{-# 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: -- -- > -- > -- > Stefan -- > Judith -- > -- -- Then you could use the following Haskell code: -- -- -- @ -- let people = [(\"Stefan\", \"32\"), (\"Judith\", \"4\")] -- in 'doc' 'defaultDocInfo' $ -- 'xelem' \"people\" $ -- 'xelems' $ map (\(name, age) -> 'xelem' \"person\" ('xattr' \"age\" age '<#>' 'xtext' name)) people -- @ module Text.XML.Generator ( -- * General Xml -- * Documents , Doc, DocInfo(..), doc, defaultDocInfo -- * Namespaces , Namespace, Prefix, Uri, Name , namespace, noNamespace, defaultNamespace -- * Elements , Elem, xelem, xelemQ, xelemEmpty, xelemQEmpty, AddChildren , xelems, noElems, xelemWithText, (<>), (<#>) -- * Attributes , Attr, xattr, xattrQ, xattrQRaw , xattrs, noAttrs -- * Text , TextContent , xtext, xtextRaw, xentityRef -- * Other , xempty , Misc(xprocessingInstruction, xcomment) -- * Rendering , xrender , XmlOutput(fromBuilder), Renderable -- * XHTML documents , xhtmlFramesetDocInfo, xhtmlStrictDocInfo, xhtmlTransitionalDocInfo , xhtmlRootElem ) where import Prelude hiding (elem) import Control.Monad.Reader (Reader(..), ask, asks, runReader) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BSL import 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 -- Fallback for ghci #if __GLASGOW_HASKELL__ >= 704 #define BASE_AT_LEAST_4_5_0_0 #endif #endif -- -- Basic definitions -- -- | A piece of XML at the element level. newtype Elem = Elem { 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 = T.Text -- | Namespace URI. 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 | 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 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 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 @\@ 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 " 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 -- -- | Text content subject to escaping. type TextContent = T.Text textBuilder :: TextContent -> Builder textBuilder = fromText . escapeText -- | Constructs a text node by escaping the given argument. xtext :: TextContent -> Xml Elem xtext content = Xml $ do env <- ask return (Elem $ textBuilder content, env) -- | Constructs a text node /without/ escaping the given argument. xtextRaw :: Builder -> Xml Elem xtextRaw content = Xml $ do env <- ask return (Elem content, env) -- | Constructs a reference to the named entity. -- /Note:/ no escaping is performed on the name of the entity xentityRef :: Name -> Xml Elem xentityRef name = Xml $ do env <- ask return (Elem $ fromChar '&' <> fromText name <> fromChar ';', env) -- -- Attributes -- -- | Construct a simple-named attribute by escaping its value. xattr :: Name -> TextContent -> Xml Attr xattr = xattrQ DefaultNamespace -- | Construct an attribute by escaping its value. xattrQ :: Namespace -> Name -> TextContent -> Xml Attr xattrQ ns key value = xattrQRaw' ns (nameBuilder key) (textBuilder 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 -> Builder -> 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 = fromText u prefixBuilder = 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 T.null prefix then spaceBuilder else spaceBuilder `mappend` fromText prefix `mappend` colonBuilder builder = nsDeclBuilder `mappend` prefixBuilder `mappend` key `mappend` startBuilder `mappend` valueBuilder `mappend` endBuilder return $ (Attr builder, uriMap) where spaceBuilder = fromString " " startBuilder = fromString "=\"" endBuilder = fromString "\"" nsDeclStartBuilder = fromString "xmlns" colonBuilder = fromString ":" -- | Merge a list of attributes into a single piece of XML at the attribute level. xattrs :: [Xml Attr] -> Xml Attr xattrs = M.mconcat -- | 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 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 '>' -- | Construct a simple-named element with the given children. xelem :: (AddChildren c) => Name -> c -> Xml Elem xelem = xelemQ DefaultNamespace -- | Construct a simple-named element without any children. xelemEmpty :: Name -> Xml Elem xelemEmpty name = xelemQ DefaultNamespace name (mempty :: 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 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 T.null p then mempty else fromChar ':' `mappend` fromText p in fromString " xmlns" `mappend` prefixBuilder `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 -- | 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 :: Name -> TextContent -> 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 -- -- | 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 "", env) instance Misc Elem instance Misc Doc -- -- Operators -- -- Note: (<>) is defined in Data.Monoid starting with base 4.5.0.0 #ifndef BASE_AT_LEAST_4_5_0_0 infixl 6 <> -- | Shortcut for the 'mappend' functions of monoids. Used to concatenate elements, attributes -- and text nodes. (<>) :: Monoid t => t -> t -> t (<>) = mappend #endif infixl 5 <#> -- | Shortcut for constructing pairs. Used in combination with 'xelem' for separating child-attributes -- from child-elements. (<#>) :: a -> b -> (a, b) (<#>) 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, T.empty, env) | otherwise -> case Map.lookup T.empty (ne_namespaceMap env) of Nothing -> -- empty prefix not in use (Nothing, T.empty, env { ne_noNamespaceInUse = True }) Just uri -> -- empty prefix mapped to uri (Just (T.empty, T.empty), T.empty, env { ne_namespaceMap = Map.delete T.empty (ne_namespaceMap env) , ne_noNamespaceInUse = True }) DefaultNamespace -> (Nothing, T.empty, env) QualifiedNamespace p' u -> 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 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 (T.cons '_' prefix) uri escapeText :: T.Text -> T.Text escapeText = T.foldr escChar T.empty where -- copied from xml-light escChar c = case c of '<' -> 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 . '\'' -> 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' -> T.cons c | otherwise -> T.append (T.pack "&#") . T.append (T.pack (show oc)) . T.cons ';' where oc = ord c -- -- XHTML -- -- | Document type for XHTML 1.0 strict. xhtmlDoctypeStrict :: String xhtmlDoctypeStrict = "" -- | 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 = "" -- | 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 = "" -- | Document info for XHTML 1.0 frameset. xhtmlFramesetDocInfo :: DocInfo xhtmlFramesetDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeFrameset } -- | Constructs the root element of an XHTML document. xhtmlRootElem :: T.Text -> Xml Elem -> Xml Elem xhtmlRootElem 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) xmlgen-0.6.2.1/test/0000755000000000000000000000000012267710243012321 5ustar0000000000000000xmlgen-0.6.2.1/test/GeneratorBenchmarks.hs0000644000000000000000000000171112267710243016601 0ustar0000000000000000import 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]) xmlgen-0.6.2.1/test/GeneratorTest.hs0000644000000000000000000001623412267710243015451 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE CPP #-} {-# 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 System.Exit 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 qualified Test.HUnit as H import qualified Test.QuickCheck as Q import Text.XML.Generator assertEqual_ :: (Eq a, Show a) => FilePath -> Int -> a -> a -> IO () assertEqual_ file line x y = H.assertEqual (file ++ ":" ++ show line ++ ": Expected " ++ show x ++ ", given: " ++ show y) x y #define assertEqual assertEqual_ __FILE__ __LINE__ 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 Q.Arbitrary ValidXmlString where arbitrary = Q.sized $ \n -> do k <- Q.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 Q.elements l qcAsTest :: Q.Testable prop => String -> prop -> H.Test qcAsTest name prop = H.TestLabel name (H.TestCase checkProp) where checkProp = do res <- Q.quickCheckResult prop case res of Q.Success _ _ _ -> return () _ -> H.assertFailure ("QC property " ++ name ++ " failed: " ++ show res) allTests :: H.Test allTests = H.TestList [H.TestLabel "test_1" (H.TestCase test_1) ,H.TestLabel "test_2" (H.TestCase test_2) ,H.TestLabel "test_3" (H.TestCase test_3) ,H.TestLabel "test_4" (H.TestCase test_4) ,H.TestLabel "test_5" (H.TestCase test_5) ,H.TestLabel "test_xhtml" (H.TestCase test_xhtml) ,qcAsTest "prop_textOk" prop_textOk ,qcAsTest "prop_quotingOk" prop_quotingOk] main = do counts <- H.runTestTT allTests if H.errors counts > 0 || H.failures counts > 0 then exitWith (ExitFailure 1) else exitWith ExitSuccess