Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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...
commit 4825dc2ac391c92aeefe5bc5ec0324cbf99d255f 1 parent 5167b6d
Stefan Wehr authored September 25, 2012
137  src/Text/XML/Generator.hs
@@ -30,10 +30,10 @@ module Text.XML.Generator (
30 30
   , Namespace, Prefix, Uri
31 31
   , namespace, noNamespace, defaultNamespace
32 32
   -- * Elements
33  
-  , Elem, MkElem(xelem), MkEmptyElem(xelemEmpty), AddChildren
  33
+  , Elem, xelem, xelemQ, xelemEmpty, xelemQEmpty, AddChildren
34 34
   , xelems, noElems, xelemWithText, (<>), (<#>)
35 35
   -- * Attributes
36  
-  , Attr, MkAttr(xattr, xattrRaw)
  36
+  , Attr, xattr, xattrRaw, xattrQ, xattrQRaw
37 37
   , xattrs, noAttrs
38 38
   -- * Text
39 39
   , RawTextContent, TextContent
@@ -189,6 +189,22 @@ doc di rootElem = Xml $
189 189
        postMisc = docInfo_postMisc di
190 190
 
191 191
 --
  192
+-- Names
  193
+--
  194
+
  195
+class Name n where
  196
+    nameBuilder :: n -> Builder
  197
+
  198
+instance Name String where
  199
+    nameBuilder = fromString
  200
+
  201
+instance Name T.Text where
  202
+    nameBuilder = fromText
  203
+
  204
+instance Name TL.Text where
  205
+    nameBuilder = fromLazyText
  206
+
  207
+--
192 208
 -- Text content
193 209
 --
194 210
 
@@ -230,38 +246,25 @@ instance RawTextContent BSL.ByteString where
230 246
 -- Attributes
231 247
 --
232 248
 
233  
--- | Class providing methods for constructing XML attributes.
234  
---
235  
--- The 'String' instance of this class constructs an attribute with a name
236  
--- in the default namespace, the 'Namespace' instance allows customization
237  
--- of namespaces.
238  
-class MkAttr n t where
239  
-    type MkAttrRes n t
240  
-    -- | Construct an attribute by escaping its value
241  
-    xattr :: TextContent t => n -> MkAttrRes n t
242  
-    -- | Construct an attribute without escaping its value.
243  
-    -- /Note:/ attribute values are quoted with double quotes.
244  
-    xattrRaw :: RawTextContent t => n -> MkAttrRes n t
245  
-
246  
-instance MkAttr String t where
247  
-    type MkAttrRes String t = t -> Xml Attr
248  
-    xattr = xattrQ DefaultNamespace
249  
-    xattrRaw = xattrQRaw DefaultNamespace
250  
-
251  
-instance MkAttr Namespace t where
252  
-    type MkAttrRes Namespace t = String -> t -> Xml Attr
253  
-    xattr = xattrQ
254  
-    xattrRaw = xattrQRaw
255  
-
256  
--- value is escaped
257  
-xattrQ :: TextContent t => Namespace -> String -> t -> Xml Attr
258  
-xattrQ ns key value = xattrQRaw' ns key (textBuilder value)
259  
-
260  
--- value is NOT escaped
261  
-xattrQRaw :: RawTextContent t => Namespace -> String -> t -> Xml Attr
262  
-xattrQRaw ns key value = xattrQRaw' ns key (rawTextBuilder value)
263  
-
264  
-xattrQRaw' :: Namespace -> String -> Builder -> Xml Attr
  249
+-- | Construct a simple-named attribute by escaping its value.
  250
+xattr :: (Name n, TextContent t) => n -> t -> Xml Attr
  251
+xattr = xattrQ DefaultNamespace
  252
+
  253
+-- | Construct a simple-named attribute without escaping its value.
  254
+-- /Note:/ attribute values are quoted with double quotes.
  255
+xattrRaw :: (Name n, RawTextContent t) => n -> t -> Xml Attr
  256
+xattrRaw = xattrQRaw DefaultNamespace
  257
+
  258
+-- | Construct an attribute by escaping its value.
  259
+xattrQ :: (Name n, TextContent t) => Namespace -> n -> t -> Xml Attr
  260
+xattrQ ns key value = xattrQRaw' ns (nameBuilder key) (textBuilder value)
  261
+
  262
+-- | Construct an attribute without escaping its value.
  263
+-- /Note:/ attribute values are quoted with double quotes.
  264
+xattrQRaw :: (Name n, RawTextContent t) => Namespace -> n -> t -> Xml Attr
  265
+xattrQRaw ns key value = xattrQRaw' ns (nameBuilder key) (rawTextBuilder value)
  266
+
  267
+xattrQRaw' :: Namespace -> Builder -> Builder -> Xml Attr
265 268
 xattrQRaw' ns' key valueBuilder = Xml $
266 269
     do uriMap' <- ask
267 270
        let (mDecl, prefix, uriMap) = extendNsEnv True uriMap' ns'
@@ -280,18 +283,17 @@ xattrQRaw' ns' key valueBuilder = Xml $
280 283
                   then spaceBuilder
281 284
                   else spaceBuilder `mappend` fromString prefix `mappend` colonBuilder
282 285
            builder = nsDeclBuilder `mappend` prefixBuilder `mappend`
283  
-                     keyBuilder `mappend` startBuilder `mappend`
  286
+                     key `mappend` startBuilder `mappend`
284 287
                      valueBuilder `mappend` endBuilder
285 288
        return $ (Attr builder, uriMap)
286 289
     where
287 290
       spaceBuilder = fromString " "
288  
-      keyBuilder = fromString key
289 291
       startBuilder = fromString "=\""
290 292
       endBuilder = fromString "\""
291 293
       nsDeclStartBuilder = fromString "xmlns"
292 294
       colonBuilder = fromString ":"
293 295
 
294  
--- |  Merges a list of attributes into a single piece of XML at the attribute level.
  296
+-- |  Merge a list of attributes into a single piece of XML at the attribute level.
295 297
 xattrs :: [Xml Attr] -> Xml Attr
296 298
 xattrs = M.mconcat
297 299
 
@@ -340,48 +342,23 @@ instance TextContent t => AddChildren t where
340 342
 instance AddChildren () where
341 343
     addChildren _ _ = fromChar '>'
342 344
 
343  
--- | Class providing methods for constructing XML elements.
344  
---
345  
--- The 'String' instance of this class constructs an element in the
346  
--- default namespace, the 'Namespace' instance allows customization of
347  
--- namespaces.
348  
-class AddChildren c => MkElem n c where
349  
-    type MkElemRes n c
350  
-    xelem :: n -> MkElemRes n c
351  
-
352  
-instance AddChildren c => MkElem String c where
353  
-    type MkElemRes String c = c -> Xml Elem
354  
-    xelem = xelemQ DefaultNamespace
355  
-
356  
-instance AddChildren c => MkElem Namespace c where
357  
-    type MkElemRes Namespace c = String -> c -> Xml Elem
358  
-    xelem = xelemQ
359  
-
360  
--- | Class providing a method for constructing XML elements without children.
361  
---
362  
--- The 'String' instance of this class constructs an element in the
363  
--- default namespace, the 'Namespace' instance allows customization of
364  
--- namespaces.
365  
-class MkEmptyElem n where
366  
-    type MkEmptyElemRes n
367  
-    xelemEmpty :: n -> MkEmptyElemRes n
368  
-
369  
-instance MkEmptyElem String where
370  
-    type MkEmptyElemRes String = Xml Elem
371  
-    xelemEmpty name = xelemQ DefaultNamespace name (mempty :: Xml Elem)
372  
-
373  
-instance MkEmptyElem Namespace where
374  
-    type MkEmptyElemRes Namespace = String -> Xml Elem
375  
-    xelemEmpty ns name = xelemQ ns name (mempty :: Xml Elem)
376  
-
377  
-xelemQ :: AddChildren c => Namespace -> String -> c -> Xml Elem
  345
+-- | Construct a simple-named element with the given children.
  346
+xelem :: (Name n, AddChildren c) => n -> c -> Xml Elem
  347
+xelem = xelemQ DefaultNamespace
  348
+
  349
+-- | Construct a simple-named element without any children.
  350
+xelemEmpty :: Name n => n -> Xml Elem
  351
+xelemEmpty name = xelemQ DefaultNamespace name (mempty :: Xml Elem)
  352
+
  353
+-- | Construct an element with the given children.
  354
+xelemQ :: (Name n, AddChildren c) => Namespace -> n -> c -> Xml Elem
378 355
 xelemQ ns' name children = Xml $
379 356
     do oldUriMap <- ask
380 357
        let (mDecl, prefix,!uriMap) = oldUriMap `seq` extendNsEnv False oldUriMap ns'
381 358
        let elemNameBuilder =
382 359
                if null prefix
383  
-                  then fromString name
384  
-                  else fromString prefix `mappend` fromString ":" `mappend` fromString name
  360
+                  then nameBuilder name
  361
+                  else fromString prefix `mappend` fromString ":" `mappend` nameBuilder name
385 362
        let nsDeclBuilder =
386 363
                case mDecl of
387 364
                  Nothing -> mempty
@@ -396,6 +373,10 @@ xelemQ ns' name children = Xml $
396 373
        let builderOut = Elem (b3 `mappend` fromString "</" `mappend` elemNameBuilder `mappend` fromString "\n>")
397 374
        return (builderOut, oldUriMap)
398 375
 
  376
+-- | Construct an element without any children.
  377
+xelemQEmpty :: Name n => Namespace -> n -> Xml Elem
  378
+xelemQEmpty ns name = xelemQ ns name (mempty :: Xml Elem)
  379
+
399 380
 -- |  Merges a list of elements into a single piece of XML at the element level.
400 381
 xelems :: [Xml Elem] -> Xml Elem
401 382
 xelems = M.mconcat
@@ -641,7 +622,7 @@ xhtmlFramesetDocInfo = defaultDocInfo { docInfo_docType = Just xhtmlDoctypeFrame
641 622
 -- | Constructs the root element of an XHTML document.
642 623
 xhtmlRootElem :: String -> Xml Elem -> Xml Elem
643 624
 xhtmlRootElem lang children =
644  
-    xelem (namespace "" "http://www.w3.org/1999/xhtml") "html"
645  
-          (xattr "xml:lang" lang <>
646  
-           xattr "lang" lang <#>
647  
-           children)
  625
+    xelemQ (namespace "" "http://www.w3.org/1999/xhtml") "html"
  626
+           (xattr "xml:lang" lang <>
  627
+            xattr "lang" lang <#>
  628
+            children)
0  src/Text/XML/GeneratorBenchmarks.hs → test/GeneratorBenchmarks.hs
File renamed without changes
39  src/Text/XML/GeneratorTest.hs → test/GeneratorTest.hs
... ...
@@ -1,8 +1,12 @@
1 1
 {-# LANGUAGE ScopedTypeVariables #-}
  2
+{-# LANGUAGE OverloadedStrings #-}
  3
+{-# LANGUAGE ExtendedDefaultRules #-}
2 4
 {-# OPTIONS_GHC -F -pgmF htfpp #-}
3 5
 {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
4 6
 
  7
+#if !MIN_VERSION_base(4,6,0)
5 8
 import Prelude hiding (catch)
  9
+#endif
6 10
 
7 11
 import Control.Exception (catch, SomeException)
8 12
 
@@ -21,7 +25,6 @@ import Text.XML.HXT.Core hiding (xshow)
21 25
 import Text.XML.HXT.DOM.ShowXml (xshow)
22 26
 import Data.Tree.NTree.TypeDefs
23 27
 
24  
-import Data.String.Utils
25 28
 import Data.String
26 29
 import qualified Data.Text as T
27 30
 
@@ -43,12 +46,12 @@ testNS = namespace "foo" "http://www.example.com"
43 46
 
44 47
 xsample1 :: Xml Elem
45 48
 xsample1 =
46  
-  xelem _NS_PR3_NS3_ "foo"
47  
-       (xattr _NS_PR2_NS2_ "key" "value" <>
48  
-        xattr _NS_PR2_NS2_ "key2" "value",
49  
-        xelem _NS_PR1_NS1_ "bar" (xattr _NS_PR2_NS2_ "key" "value" <#> xtext "BAR") <>
50  
-        xelem _NS_PR1_NS1_ "bar"
51  
-            (xelem _NS_PR1_NS3_ "spam" (xelemEmpty "egg" <> xtext "this is spam!")))
  49
+  xelemQ _NS_PR3_NS3_ "foo"
  50
+        (xattrQ _NS_PR2_NS2_ "key" "value" <>
  51
+         xattrQ _NS_PR2_NS2_ "key2" "value",
  52
+         xelemQ _NS_PR1_NS1_ "bar" (xattrQ _NS_PR2_NS2_ "key" "value" <#> xtext "BAR") <>
  53
+         xelemQ _NS_PR1_NS1_ "bar"
  54
+             (xelemQ _NS_PR1_NS3_ "spam" (xelemEmpty "egg" <> xtext "this is spam!")))
52 55
 
53 56
 test_1 =
54 57
     do out <- runXmllint xsample1
@@ -62,9 +65,9 @@ xsample2 = xelem "foo" $
62 65
                 xelemEmpty "bar" <>
63 66
                 xelem "spam" (xattr "key" "value") <>
64 67
                 xelem "egg" (xtext "ham") <>
65  
-                xelemEmpty testNS "bar" <>
66  
-                xelem testNS "spam" (xattr testNS "key" "value") <>
67  
-                xelem testNS "egg" (xelemEmpty "ham")
  68
+                xelemQEmpty testNS "bar" <>
  69
+                xelemQ testNS "spam" (xattrQ testNS "key" "value") <>
  70
+                xelemQ testNS "egg" (xelemEmpty "ham")
68 71
 
69 72
 test_2 =
70 73
     do out <- runXmllint xsample2
@@ -82,12 +85,12 @@ test_3 =
82 85
 
83 86
 xsample4 :: Xml Elem
84 87
 xsample4 =
85  
-    xelem ns "x" (attrs <#>
86  
-                  xelem noNamespace "y" (attrs <#> xelem ns "z" attrs))
  88
+    xelemQ ns "x" (attrs <#>
  89
+                   xelemQ noNamespace "y" (attrs <#> xelemQ ns "z" attrs))
87 90
     where
88  
-      attrs = xattr ns "a" "in URI" <>
89  
-              xattr noNamespace "b" "in no ns" <>
90  
-              xattr defaultNamespace "c" "in default ns"
  91
+      attrs = xattrQ ns "a" "in URI" <>
  92
+              xattrQ noNamespace "b" "in no ns" <>
  93
+              xattrQ defaultNamespace "c" "in default ns"
91 94
       ns = namespace "" "http://URI"
92 95
 
93 96
 test_4 =
@@ -156,8 +159,8 @@ prop_quotingOk (ValidXmlString s) =
156 159
              in normWsAttr s == attrValue && normWsElem s == textValue
157 160
          l -> error (show root ++ "\n" ++ show l)
158 161
     where
159  
-      normWsAttr = replace "\r" " " . replace "\n" " " . replace "\n\r" " "
160  
-      normWsElem = replace "\r" "\n" . replace "\n\r" "\b"
  162
+      normWsAttr = T.unpack . T.replace "\r" " " . T.replace "\n" " " . T.replace "\n\r" " " . T.pack
  163
+      normWsElem = T.unpack . T.replace "\r" "\n" . T.replace "\n\r" "\b" . T.pack
161 164
       childrenOfNTree (NTree _ l) = l
162 165
 
163 166
 newtype ValidXmlString = ValidXmlString String
@@ -176,4 +179,4 @@ instance Arbitrary ValidXmlString where
176 179
 
177 180
 main =
178 181
     do args <- getArgs
179  
-       runTestWithArgs args allHTFTests
  182
+       runTestWithArgs args htf_thisModulesTests
48  xmlgen.cabal
... ...
@@ -1,5 +1,5 @@
1 1
 Name:                xmlgen
2  
-Version:             0.4.0.3
  2
+Version:             0.5.0.0
3 3
 Synopsis:            Fast XML generation library
4 4
 Description:         Library for high-performance XML generation.
5 5
 License:             BSD3
@@ -8,8 +8,8 @@ Author:              Stefan Wehr, Stefan Schmidt, Johannes Weiss, David Leuschne
8 8
 Maintainer:          Stefan Wehr <wehr@factisresearch.com>
9 9
 Category:            Text, XML
10 10
 Build-type:          Simple
11  
-Cabal-version:       >=1.6
12  
-Tested-With:        GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1
  11
+Cabal-version:       >= 1.10
  12
+Tested-With:         GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1
13 13
 
14 14
 Source-Repository head
15 15
   type:     git
@@ -22,30 +22,26 @@ Library
22 22
                      bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.6,
23 23
                      mtl >= 2.0 && < 2.2, text >= 0.10 && < 0.12
24 24
   Ghc-Prof-Options: -auto-all -caf-all
  25
+  Default-language:  Haskell2010
25 26
 
26  
-Flag tests
27  
-  description: Build test suite
28  
-  default:     False
  27
+test-suite xmlgen-tests
  28
+  Type:              exitcode-stdio-1.0
  29
+  Hs-Source-Dirs:    test
  30
+  Main-Is:           GeneratorTest.hs
  31
+  Build-depends:     base >= 4.2 && < 4.7, HTF == 0.9.*, xmlgen, text >= 0.10 && < 0.12,
  32
+                     containers >= 0.3 && < 0.6, hxt == 9.2.*, bytestring >= 0.9 && < 0.11,
  33
+                     filepath == 1.3.*, process == 1.1.*
  34
+  if !os(windows)
  35
+    Build-depends:   unix >= 2.4 && < 2.7
29 36
 
30  
-Executable tests
31  
-  If flag(tests)
32  
-    Build-Depends: HTF == 0.7.*, MissingH == 1.1.*, hxt == 9.1.*,
33  
-                   filepath == 1.2.*, unix == 2.4.*, process == 1.0.*
34  
-  Else
35  
-    Buildable: False
36  
-  Hs-Source-Dirs: src
37  
-  Main-Is:        Text/XML/GeneratorTest.hs
  37
+  Default-language:  Haskell2010
38 38
 
39  
-Flag benchmarks
40  
-  description: Build benchmarks
41  
-  default:     False
42  
-
43  
-Executable benchmarks
44  
-  If flag(benchmarks)
45  
-    Build-Depends: criterion == 0.5.*
46  
-  Else
47  
-    Buildable: False
48  
-  Hs-Source-Dirs: src
49  
-  Ghc-Options: -O2 -rtsopts
  39
+Benchmark xmlgen-bench
  40
+  Type:             exitcode-stdio-1.0
  41
+  Build-Depends:    base >= 4.2 && < 4.7, text >= 0.10 && < 0.12, criterion == 0.6.*,
  42
+                    bytestring >= 0.9 && < 0.11, xmlgen
  43
+  Hs-Source-Dirs:   test
  44
+  Ghc-Options:      -O2 -rtsopts
50 45
   Ghc-Prof-Options: -auto-all -caf-all
51  
-  Main-Is:        Text/XML/GeneratorBenchmarks.hs
  46
+  Main-Is:          GeneratorBenchmarks.hs
  47
+  Default-language: Haskell2010

0 notes on commit 4825dc2

Please sign in to comment.
Something went wrong with that request. Please try again.