resolved problems with overloaded string literals, fixed benchmarks a…

…nd tests, this change is NOT BACKWARD COMPATIBLE

bumped version to 0.5.0

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
@@ -188,6 +188,22 @@ doc di rootElem = Xml $
        preMisc = docInfo_preMisc di
        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)

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

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