Permalink
Browse files

resolved problems with overloaded string literals, fixed benchmarks a…

…nd tests, this change is NOT BACKWARD COMPATIBLE

bumped version to 0.5.0
  • Loading branch information...
1 parent 5167b6d commit 4825dc2ac391c92aeefe5bc5ec0324cbf99d255f @skogsbaer committed Sep 25, 2012
View
137 src/Text/XML/Generator.hs
@@ -30,10 +30,10 @@ module Text.XML.Generator (
, Namespace, Prefix, Uri
, 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, xattrRaw, xattrQ, xattrQRaw
, xattrs, noAttrs
-- * Text
, RawTextContent, TextContent
@@ -189,6 +189,22 @@ doc di rootElem = Xml $
postMisc = docInfo_postMisc di
--
+-- Names
+--
+
+class Name n where
+ nameBuilder :: n -> Builder
+
+instance Name String where
+ nameBuilder = fromString
+
+instance Name T.Text where
+ nameBuilder = fromText
+
+instance Name TL.Text where
+ nameBuilder = fromLazyText
+
+--
-- Text content
--
@@ -230,38 +246,25 @@ instance RawTextContent BSL.ByteString where
-- 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
+-- | Construct a simple-named attribute by escaping its value.
+xattr :: (Name n, TextContent t) => n -> t -> Xml Attr
+xattr = xattrQ DefaultNamespace
+
+-- | Construct a simple-named attribute without escaping its value.
+-- /Note:/ attribute values are quoted with double quotes.
+xattrRaw :: (Name n, RawTextContent t) => n -> t -> Xml Attr
+xattrRaw = xattrQRaw DefaultNamespace
+
+-- | Construct an attribute by escaping its value.
+xattrQ :: (Name n, TextContent t) => Namespace -> n -> t -> 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 :: (Name n, RawTextContent t) => Namespace -> n -> t -> Xml Attr
+xattrQRaw ns key value = xattrQRaw' ns (nameBuilder key) (rawTextBuilder value)
+
+xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr
xattrQRaw' ns' key valueBuilder = Xml $
do uriMap' <- ask
let (mDecl, prefix, uriMap) = extendNsEnv True uriMap' ns'
@@ -280,18 +283,17 @@ xattrQRaw' ns' key valueBuilder = Xml $
then spaceBuilder
else spaceBuilder `mappend` fromString 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
@@ -340,48 +342,23 @@ instance TextContent t => AddChildren t where
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
+-- | Construct a simple-named element with the given children.
+xelem :: (Name n, AddChildren c) => n -> c -> Xml Elem
+xelem = xelemQ DefaultNamespace
+
+-- | Construct a simple-named element without any children.
+xelemEmpty :: Name n => n -> Xml Elem
+xelemEmpty name = xelemQ DefaultNamespace name (mempty :: Xml Elem)
+
+-- | Construct an element with the given children.
+xelemQ :: (Name n, AddChildren c) => Namespace -> n -> 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
+ then nameBuilder name
+ else fromString prefix `mappend` fromString ":" `mappend` nameBuilder name
let nsDeclBuilder =
case mDecl of
Nothing -> mempty
@@ -396,6 +373,10 @@ xelemQ ns' name children = Xml $
let builderOut = Elem (b3 `mappend` fromString "</" `mappend` elemNameBuilder `mappend` fromString "\n>")
return (builderOut, oldUriMap)
+-- | Construct an element without any children.
+xelemQEmpty :: Name n => Namespace -> n -> 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
@@ -641,7 +622,7 @@ xhtmlFramesetDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeFrame
-- | 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)
+ xelemQ (namespace "" "http://www.w3.org/1999/xhtml") "html"
+ (xattr "xml:lang" lang <>
+ xattr "lang" lang <#>
+ children)
View
0 src/Text/XML/GeneratorBenchmarks.hs → test/GeneratorBenchmarks.hs
File renamed without changes.
View
39 src/Text/XML/GeneratorTest.hs → test/GeneratorTest.hs
@@ -1,8 +1,12 @@
{-# 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)
@@ -21,7 +25,6 @@ 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
@@ -43,12 +46,12 @@ 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!")))
+ 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
@@ -62,9 +65,9 @@ xsample2 = xelem "foo" $
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")
+ xelemQEmpty testNS "bar" <>
+ xelemQ testNS "spam" (xattrQ testNS "key" "value") <>
+ xelemQ testNS "egg" (xelemEmpty "ham")
test_2 =
do out <- runXmllint xsample2
@@ -82,12 +85,12 @@ test_3 =
xsample4 :: Xml Elem
xsample4 =
- xelem ns "x" (attrs <#>
- xelem noNamespace "y" (attrs <#> xelem ns "z" attrs))
+ xelemQ ns "x" (attrs <#>
+ xelemQ noNamespace "y" (attrs <#> xelemQ ns "z" attrs))
where
- attrs = xattr ns "a" "in URI" <>
- xattr noNamespace "b" "in no ns" <>
- xattr defaultNamespace "c" "in default ns"
+ attrs = xattrQ ns "a" "in URI" <>
+ xattrQ noNamespace "b" "in no ns" <>
+ xattrQ defaultNamespace "c" "in default ns"
ns = namespace "" "http://URI"
test_4 =
@@ -156,8 +159,8 @@ prop_quotingOk (ValidXmlString s) =
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"
+ normWsAttr = T.unpack . T.replace "\r" " " . T.replace "\n" " " . T.replace "\n\r" " " . T.pack
+ normWsElem = T.unpack . T.replace "\r" "\n" . T.replace "\n\r" "\b" . T.pack
childrenOfNTree (NTree _ l) = l
newtype ValidXmlString = ValidXmlString String
@@ -176,4 +179,4 @@ instance Arbitrary ValidXmlString where
main =
do args <- getArgs
- runTestWithArgs args allHTFTests
+ runTestWithArgs args htf_thisModulesTests
View
48 xmlgen.cabal
@@ -1,5 +1,5 @@
Name: xmlgen
-Version: 0.4.0.3
+Version: 0.5.0.0
Synopsis: Fast XML generation library
Description: Library for high-performance XML generation.
License: BSD3
@@ -8,8 +8,8 @@ Author: Stefan Wehr, Stefan Schmidt, Johannes Weiss, David Leuschne
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 @@ Library
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
+ Default-language: Haskell2010
-Flag tests
- description: Build test suite
- default: False
+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
-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
+ Default-language: Haskell2010
-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 -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

0 comments on commit 4825dc2

Please sign in to comment.