Initial benchmarks scaffolding
authorAlfredo Di Napoli <alfredo.dinapoli@gmail.com>
Wed, 3 May 2017 18:57:00 +0000 (20:57 +0200)
committerAlfredo Di Napoli <alfredo.dinapoli@gmail.com>
Wed, 3 May 2017 18:57:00 +0000 (20:57 +0200)
bench/Bench.hs [new file with mode: 0644]
pretty.cabal
tests/Bench1.hs [deleted file]

diff --git a/bench/Bench.hs b/bench/Bench.hs
new file mode 100644 (file)
index 0000000..af26059
--- /dev/null
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PackageImports #-}
+module Main where
+
+import Criterion.Main
+import Data.List
+import Text.PrettyPrint.HughesPJ
+
+--------------------------------------------------------------------------------
+f_left :: Int -> Doc
+f_left n = foldl' (<>) empty (map (text . show) [10001..10000+n])
+
+--------------------------------------------------------------------------------
+f_right :: Int -> Doc
+f_right n = foldr (<>) empty (map (text . show) [10001..10000+n])
+
+--------------------------------------------------------------------------------
+stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc
+stuff s1 s2 d1 r1 i1 i2 i3 =
+    let a = nest i1 $ text s1
+        b = double d1
+        c = rational r1
+        d = replicate i1 (text s2 <> b <> c <+> a)
+        e = cat d $+$ cat d $$ (c <> b <+> a)
+        f = parens e <> brackets c <> hcat d
+        g = lparen <> f <> rparen
+        h = text $ s2 ++ s1
+        i = map rational ([1..(toRational i2)]::[Rational])
+        j = punctuate comma i
+        k = nest i3 h <> (nest (i1 + i3) $ sep i) $+$ g <> cat j
+        l = cat $ punctuate (comma <> b <> comma) $ replicate i3 k
+    in l
+
+--------------------------------------------------------------------------------
+doc1 :: Doc
+doc1 = stuff "Adsas ads" "dassdab weeaa xxxxx" 123.231321 ((-1)/5) 30 300 20
+
+--------------------------------------------------------------------------------
+doc2 :: Doc
+doc2 = stuff "aDSAS ADS asdasdsa sdsda xx" "SDAB WEEAA" 1333.212 ((-4)/5) 31 301 30
+
+--------------------------------------------------------------------------------
+doc3 :: Doc
+doc3 = stuff "ADsAs --____ aDS" "DasSdAB weEAA" 2533.21299 ((-4)/999) 39 399 60
+
+--------------------------------------------------------------------------------
+processTxt :: TextDetails -> String -> String
+processTxt (Chr c)   s  = c:s
+processTxt (Str s1)  s2 = s1 ++ s2
+processTxt (PStr s1) s2 = s1 ++ s2
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = defaultMain $ [
+  bgroup "<> associativity" [ bench "left"     $ nf (length . render . f_left)  10000
+                            , bench "right"    $ nf (length . render . f_right) 10000
+                            , bench "left20k"  $ nf (length . render . f_left)  20000
+                            , bench "right20k" $ nf (length . render . f_right) 20000
+                            , bench "left30k"  $ nf (length . render . f_left)  30000
+                            , bench "right30k" $ nf (length . render . f_right) 30000
+                            ]
+
+  , bgroup "render" [ bench "doc1" $ nf render doc1
+                    , bench "doc2" $ nf render doc2
+                    , bench "doc3" $ nf render doc3
+                    ]
+
+  , bgroup "fullRender" [ bench "PageMode 1000" $ nf (fullRender PageMode 1000 4 processTxt "") doc2
+                        , bench "PageMode 100" $ nf (fullRender PageMode 100 1.5 processTxt "") doc2
+                        , bench "ZigZagMode" $ nf (fullRender ZigZagMode 1000 4 processTxt "") doc2
+                        , bench "LeftMode" $ nf (fullRender LeftMode 1000 4 processTxt "") doc2
+                        , bench "OneLineMode" $ nf (fullRender OneLineMode 1000 4 processTxt "") doc3
+                        ]
+  ]
index 2e25b6f..b2b5e76 100644 (file)
@@ -55,6 +55,8 @@ Test-Suite test-pretty
                    QuickCheck >= 2.5 && <3
     main-is: Test.hs
     other-modules:
+        Text.PrettyPrint.Annotated.HughesPJ
+        Text.PrettyPrint.HughesPJ
         PrettyTestVersion
         TestGenerators
         TestStructures
@@ -67,3 +69,11 @@ Test-Suite test-pretty
     include-dirs: src/Text/PrettyPrint/Annotated
     ghc-options: -rtsopts -with-rtsopts=-K2M
 
+benchmark pretty-bench
+  type: exitcode-stdio-1.0
+  main-is: Bench.hs
+  hs-source-dirs: bench
+  ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg
+  build-depends: base >= 4.5 && < 5
+               , criterion
+               , pretty
diff --git a/tests/Bench1.hs b/tests/Bench1.hs
deleted file mode 100644 (file)
index 017cdf7..0000000
+++ /dev/null
@@ -1,55 +0,0 @@
-module Main (main) where
-
-import Text.PrettyPrint.HughesPJ
-
-stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc
-stuff s1 s2 d1 r1 i1 i2 i3 =
-    let a = nest i1 $ text s1
-        b = double d1
-        c = rational r1
-        d = replicate i1 (text s2 <> b <> c <+> a)
-        e = cat d $+$ cat d $$ (c <> b <+> a)
-        f = parens e <> brackets c <> hcat d
-        g = lparen <> f <> rparen
-        h = text $ s2 ++ s1
-        i = map rational ([1..(toRational i2)]::[Rational])
-        j = punctuate comma i
-        k = nest i3 h <> (nest (i1 + i3) $ sep i) $+$ g <> cat j
-        l = cat $ punctuate (comma <> b <> comma) $ replicate i3 k
-    in l
-
-doc1 :: Doc
-doc1 = stuff "Adsas ads" "dassdab weeaa xxxxx" 123.231321 ((-1)/5) 30 300 20
-
-doc2 :: Doc
-doc2 = stuff "aDSAS ADS asdasdsa sdsda xx" "SDAB WEEAA" 1333.212 ((-4)/5) 31 301 30
-
-doc3 :: Doc
-doc3 = stuff "ADsAs --____ aDS" "DasSdAB weEAA" 2533.21299 ((-4)/999) 39 399 60
-
-{-
-txt :: TextDetails -> String -> String
-txt (Chr c)   s  = c:s
-txt (Str s1)  s2 = s1 ++ s2
--}
-
-main :: IO ()
-main = do
-    putStrLn "==================================================="
-    putStrLn $ render doc1
-{-
-    putStrLn "==================================================="
-    putStrLn $ fullRender PageMode 1000 4 txt "" doc2
-    putStrLn "==================================================="
-    putStrLn $ fullRender PageMode 100 1.5 txt "" doc2
-    putStrLn "==================================================="
-    putStrLn $ fullRender ZigZagMode 1000 4 txt "" doc2
-    putStrLn "==================================================="
-    putStrLn $ fullRender LeftMode 1000 4 txt "" doc2
-    putStrLn "==================================================="
-    putStrLn $ fullRender OneLineMode 1000 4 txt "" doc3
-    putStrLn "==================================================="
--}
-    putStrLn $ render doc3
-
-