Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

performance and memory usage improvements

  • Loading branch information...
commit af6a4118223ce37507368f5935263ab615c1993d 1 parent e5face2
@skogsbaer authored
View
2  .gitignore
@@ -1 +1 @@
-(^|/)dist
+dist
View
147 src/Text/XML/Generator.hs
@@ -21,7 +21,6 @@ module Text.XML.Generator (
{-
TODO:
-- benchmarks
- documentation
-}
@@ -32,7 +31,7 @@ import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BSL
import Data.Monoid hiding (mconcat)
-import Blaze.ByteString.Builder hiding (empty, append)
+import Blaze.ByteString.Builder
import qualified Blaze.ByteString.Builder as Blaze
import Blaze.ByteString.Builder.Char.Utf8
@@ -44,6 +43,7 @@ import qualified Data.String as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
+
--
-- Basic definitions
--
@@ -68,15 +68,15 @@ type NsEnv = Map.Map Prefix Uri
emptyNsEnv :: NsEnv
emptyNsEnv = Map.empty
-newtype Xml t = Xml { unXml :: t -> Reader NsEnv (t, NsEnv) }
+newtype Xml t = Xml { unXml :: Reader NsEnv (t, NsEnv) }
-runXml :: NsEnv -> Xml t -> t -> (t, NsEnv)
-runXml nsEnv (Xml f) t = runReader (f t) nsEnv
+runXml :: NsEnv -> Xml t -> (t, NsEnv)
+runXml nsEnv (Xml x) = runReader x nsEnv
-xempty :: Xml t
-xempty = Xml $ \t->
+xempty :: Renderable t => Xml t
+xempty = Xml $
do env <- ask
- return (t, env)
+ return (mkRenderable mempty, env)
--
-- Document
@@ -96,7 +96,7 @@ defaultDocInfo = DocInfo { docInfo_standalone = True
, docInfo_postMisc = xempty }
doc :: DocInfo -> Xml Elem -> Xml Doc
-doc di rootElem = Xml $ \(Doc buffer) ->
+doc di rootElem = Xml $
do let prologBuf = fromString "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"" <>
fromString (if standalone then "yes" else "no") <>
fromString "\"?>\n" <>
@@ -104,9 +104,9 @@ doc di rootElem = Xml $ \(Doc buffer) ->
Nothing -> mempty
Just s -> fromString s <> fromString "\n"
env <- ask
- let Doc preBuf = fst $ runXml env preMisc (Doc prologBuf)
- Elem elemBuf = fst $ runXml env rootElem (Elem preBuf)
- postBuf = fst $ runXml env postMisc (Doc elemBuf)
+ let Doc preBuf = fst $ runXml env preMisc
+ Elem elemBuf = fst $ runXml env rootElem
+ postBuf = fst $ runXml env postMisc
return $ (postBuf, env)
where
standalone = docInfo_standalone di
@@ -180,7 +180,7 @@ xattrQRaw :: RawTextContent t => Namespace -> String -> t -> Xml Attr
xattrQRaw ns key value = xattrQRaw' ns key (rawTextBuilder value)
xattrQRaw' :: Namespace -> String -> Builder -> Xml Attr
-xattrQRaw' ns' key valueBuilder = Xml $ \(Attr buffer) ->
+xattrQRaw' ns' key valueBuilder = Xml $
do uriMap' <- ask
let (ns, uriMap, newNs) = genValidNsForDesiredPrefix uriMap' ns'
builder = case ns of
@@ -198,7 +198,7 @@ xattrQRaw' ns' key valueBuilder = Xml $ \(Attr buffer) ->
else spaceBuilder `mappend` prefixBuilder `mappend` colonBuilder
`mappend` keyBuilder `mappend` startBuilder
`mappend` valueBuilder `mappend` endBuilder
- return $ (Attr (buffer `mappend` builder), uriMap)
+ return $ (Attr builder, uriMap)
where
spaceBuilder = fromString " "
keyBuilder = fromString key
@@ -215,33 +215,34 @@ noAttrs = xempty
instance Monoid (Xml Attr) where
mempty = noAttrs
- mappend x1 x2 = Xml $ \t ->
- do nsEnv <- ask
- let (t2, nsEnv') = runXml nsEnv x1 t
- return $ runXml nsEnv' x2 t2
+ 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 AddChildren c where
- addChildren :: c -> Builder -> NsEnv -> Builder
+ addChildren :: c -> NsEnv -> Builder
instance AddChildren (Xml Attr) where
- addChildren attrs builder uriMap =
- let (Attr builder', _) = runXml uriMap attrs (Attr builder)
+ addChildren attrs uriMap =
+ let (Attr builder', _) = runXml uriMap attrs
in builder' <> fromString "\n>"
instance AddChildren (Xml Elem) where
- addChildren elems builder uriMap =
- let (Elem builder', _) = runXml uriMap elems (Elem $ builder <> (fromString "\n>"))
- in builder'
+ addChildren elems uriMap =
+ let (Elem builder', _) = runXml uriMap elems
+ in fromString "\n>" `mappend` builder'
instance AddChildren (Xml Attr, Xml Elem) where
- addChildren (attrs, elems) builder uriMap =
- let (Attr builder', uriMap') = runXml uriMap attrs (Attr builder)
- (Elem builder'', _) = runXml uriMap' elems (Elem $ builder' <> (fromString "\n>"))
- in builder''
+ addChildren (attrs, elems) uriMap =
+ let (Attr builder, uriMap') = runXml uriMap attrs
+ (Elem builder', _) = runXml uriMap' elems
+ in builder `mappend` fromString "\n>" `mappend` builder'
class AddChildren c => MkElem n c where
type MkElemRes n c
@@ -268,7 +269,7 @@ instance MkEmptyElem Namespace where
xelemEmpty ns name = xelemQ ns name (mempty :: Xml Elem)
xelemQ :: AddChildren c => Namespace -> String -> c -> Xml Elem
-xelemQ ns' name children = Xml $ \(Elem buffer) ->
+xelemQ ns' name children = Xml $
do oldUriMap <- ask
let (ns, uriMap, newNs) = genValidNsForDesiredPrefix oldUriMap ns'
let elemNameBuilder =
@@ -281,14 +282,14 @@ xelemQ ns' name children = Xml $ \(Elem buffer) ->
let nsDeclaration' = fromString " xmlns:" `mappend` fromString p `mappend` fromString "=\""
`mappend` fromString u `mappend` fromString "\""
in if newNs then nsDeclaration' else mempty
- let b1 = mappend buffer $ fromString "<"
+ let b1 = fromString "<"
let b2 = b1 `mappend` elemNameBuilder `mappend` nsDeclBuilder
- let b3 = addChildren children b2 uriMap
+ let b3 = b2 `mappend` addChildren children uriMap
let builderOut = Elem (b3 `mappend` fromString "</" `mappend` elemNameBuilder `mappend` fromString "\n>")
return (builderOut, oldUriMap)
xelems :: [Xml Elem] -> Xml Elem
-xelems = foldl mappend noElems
+xelems = foldr mappend noElems
noElems :: Xml Elem
noElems = xempty
@@ -298,11 +299,11 @@ xelemWithText n t = xelem n (xtext t)
instance Monoid (Xml Elem) where
mempty = noElems
- mappend x1 x2 = Xml $ \t ->
- do nsEnv <- ask
- let t2 = fst $ runXml nsEnv x1 t
- t3 = fst $ runXml nsEnv x2 t2
- return (t3, nsEnv)
+ 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
@@ -310,31 +311,43 @@ instance Monoid (Xml Elem) where
-- content is escaped
xtext :: TextContent t => t -> Xml Elem
-xtext content = append $ textBuilder content
+xtext content = Xml $
+ do env <- ask
+ return (Elem $ textBuilder content, env)
-- content is NOT escaped
xtextRaw :: RawTextContent t => t -> Xml Elem
-xtextRaw content = append $ rawTextBuilder content
+xtextRaw content = Xml $
+ do env <- ask
+ return (Elem $ rawTextBuilder content, env)
-- no escaping performed
xentityRef :: String -> Xml Elem
-xentityRef name = append $ fromChar '&' <> fromString name <> fromChar ';'
+xentityRef name = Xml $
+ do env <- ask
+ return (Elem $ fromChar '&' <> fromString name <> fromChar ';', env)
class Renderable t => Misc t where
-- no escaping performed
xprocessingInstruction :: String -> String -> Xml t
- xprocessingInstruction target content =
- append $ fromString "<?" <>
- fromString target <>
- fromChar ' ' <>
- fromString content <>
- fromString "?>"
+ xprocessingInstruction target content = Xml $
+ do env <- ask
+ return (mkRenderable $
+ fromString "<?" <>
+ fromString target <>
+ fromChar ' ' <>
+ fromString content <>
+ fromString "?>",
+ env)
-- no escaping performed
xcomment :: String -> Xml t
- xcomment content =
- append $ fromString "<!--" <>
- fromString content <>
- fromString "-->"
+ xcomment content = Xml $
+ do env <- ask
+ return (mkRenderable $
+ fromString "<!--" <>
+ fromString content <>
+ fromString "-->",
+ env)
instance Misc Elem
instance Misc Doc
@@ -357,6 +370,9 @@ infixl 5 <#>
class XmlOutput t where
fromBuilder :: Builder -> t
+instance XmlOutput Builder where
+ fromBuilder b = b
+
instance XmlOutput BS.ByteString where
fromBuilder = toByteString
@@ -382,7 +398,7 @@ instance Renderable Doc where
xrender :: (Renderable r, XmlOutput t) => Xml r -> t
xrender r = fromBuilder $ builder r'
where
- r' = fst $ runXml emptyNsEnv r (mkRenderable mempty)
+ r' = fst $ runXml emptyNsEnv r
--
-- Utilities
@@ -407,11 +423,30 @@ genValidNsForDesiredPrefix env ns =
then prefix
else genValidPrefix env ('_':prefix) uri
-append :: Renderable t => Builder -> Xml t
-append builder' = Xml $ \t ->
- do nsEnv <- ask
- return $ (mkRenderable (builder t <> builder'), nsEnv)
-
+{-# 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
where
-- copied from xml-light
View
5 src/Text/XML/GeneratorBenchmarks.hs
@@ -1,15 +1,16 @@
import Criterion.Main
import qualified Data.ByteString.Lazy as BSL
import System.Environment
+import qualified Data.Text as T
import Text.XML.Generator
gen :: Int -> IO ()
gen numberOfElems = BSL.writeFile "/tmp/test.xml" (xrender doc)
- where doc = xelem "root" $ xelems $ map (\s -> xelem "foo" (xattr "key" s, xtext s)) (map show [1..numberOfElems])
+ where doc = xelem "root" $ xelems $ map (\s -> xelem "foo" (xattr "key" s, xtext s)) (map (\i -> T.pack (show i) :: T.Text) [1..numberOfElems])
main =
do args <- getArgs
case args of
"--standalone":s:[] -> gen (read s)
- _ -> defaultMain (map (\i -> bench ("gen " ++ show i) (gen i)) [1000, 10000, 100000])
+ _ -> defaultMain (map (\i -> bench ("gen " ++ show i) (gen i)) [1000, 10000, 100000, 1000000])
View
7 src/Text/XML/GeneratorTest.hs
@@ -1,12 +1,11 @@
{-# OPTIONS_GHC -F -pgmF htfpp #-}
-module Text.XML.GeneratorTest where
-
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
@@ -127,3 +126,7 @@ instance Arbitrary ValidXmlString where
let l = map chr ([0x9, 0xA, 0xD] ++ [0x20..0xD7FF] ++
[0xE000..0xFFFD] ++ [0x10000..0x10FFFF])
in elements l
+
+main =
+ do args <- getArgs
+ runTestWithArgs args allHTFTests
View
7 xmlgen.cabal
@@ -14,7 +14,7 @@ Library
Hs-Source-Dirs: src
Build-Depends: blaze-builder >= 0.2 && < 0.3, base >= 4.2 && < 4.4,
bytestring >= 0.9 && < 0.10, containers >= 0.3 && < 0.5,
- monads-tf >= 0.1 && < 0.2, text == 0.10.*
+ monads-tf >= 0.1 && < 0.2, text == 0.11.*
Ghc-Prof-Options: -auto-all -caf-all
Flag tests
@@ -23,11 +23,12 @@ Flag tests
Executable tests
If flag(tests)
- Build-Depends: HTF == 0.6.*
+ Build-Depends: HTF == 0.6.*, MissingH == 1.1.*, hxt == 9.0.*,
+ filepath == 1.1.*, unix == 2.4.*, process == 1.0.*
Else
Buildable: False
Hs-Source-Dirs: src
- Main-Is: src/Text/XML/GeneratorTest.hs
+ Main-Is: Text/XML/GeneratorTest.hs
Flag benchmarks
description: Build benchmarks
Please sign in to comment.
Something went wrong with that request. Please try again.