Add a few synthetic benchmarks

This code benchmarks the "string" primitive and various non-primitive combinators.
The code coverage of these benchmarks is not 100%: new benchmarks should be added
as relevant performance questions are discovered.

benchmarks/Main.hs

@@ -27,12 +27,168 @@
 -- any way out of the use of this software, even if advised of the
 -- possibility of such damage.
 
+{-# LANGUAGE CPP #-}
+
 module Main (main) where
 
 import Criterion.Main
 
+import Text.Megaparsec
+
+-- Configuration parameters.
+
+-- To configure the benchmark, build the benchmarks e.g. like this:
+-- $ cabal build --ghc-options="-DBENCHMARK_TYPE=3 -DBENCHMARK_STEPS=10"
+
+-- BENCHMARK_TYPE options:
+-- 0:  Text.Megaparsec.String
+-- 1:  Text.Megaparsec.Text
+-- 2:  Text.Megaparsec.Text.Lazy
+-- 3:  Text.Megaparsec.ByteString
+-- 4:  Text.Megaparsec.ByteString.Lazy
+
+#ifndef BENCHMARK_TYPE
+#define BENCHMARK_TYPE 0
+#endif
+
+#if BENCHMARK_TYPE == 0
+import Text.Megaparsec.String (Parser)
+pack :: String -> String
+pack = id
+#endif
+#if BENCHMARK_TYPE == 1
+import Text.Megaparsec.Text (Parser)
+import Data.Text (pack)
+#endif
+#if BENCHMARK_TYPE == 2
+import Text.Megaparsec.Text.Lazy (Parser)
+import Data.Text.Lazy (pack)
+#endif
+#if BENCHMARK_TYPE == 3
+import Text.Megaparsec.ByteString (Parser)
+import Data.ByteString.Char8 (pack)
+#endif
+#if BENCHMARK_TYPE == 4
+import Text.Megaparsec.ByteString.Lazy (Parser)
+import Data.ByteString.Lazy.Char8 (pack)
+#endif
+
+-- benchSteps and benchSize control the benchmark test points
+benchSteps :: Int
+#if BENCHMARK_STEPS
+benchSteps    = BENCHMARK_STEPS
+#else
+benchSteps    = 5
+#endif
+benchSize :: Int
+#if BENCHMARK_SIZE
+benchSize = BENCHMARK_SIZE
+#else
+benchSize = 1000
+#endif
+
+-- End of configuration parameters
+
+
 main :: IO ()
 main = defaultMain benchmarks
 
 benchmarks :: [Benchmark]
-benchmarks = undefined -- TODO write some benchmarks
+benchmarks =
+  [
+  -- First the primitives
+    bgroup "string" $ benchBunch $ \size str ->
+      parse (string str :: Parser String) ""
+        (pack $ replicate size 'a')
+  , bgroup "try-string" $ benchBunch $ \size str ->
+      parse (try $ string str :: Parser String) ""
+        (pack $ replicate size 'a')
+  , bgroup "lookahead-string" $ benchBunch $ \size str ->
+      parse (lookAhead $ string str :: Parser String) ""
+        (pack $ replicate size 'a')
+  , bgroup "notfollowedby-string" $ benchBunch $ \size str ->
+      parse (notFollowedBy $ string str :: Parser ()) ""
+        (pack $ replicate size 'a')
+  , bgroup "manual-string" benchManual
+
+  -- Now for a few combinators
+  -- Major class instance operators: return, >>=, <|>, mzero
+  -- TODO
+  -- I'm not really sure how to test these operators since I can't imagine what
+  -- supraconstant complexity they might have.
+
+  -- A few non-primitive combinators follow below
+  , bgroup "choice"
+      [ bgroup "match" $ benchBunchMatch $ \size _ ->
+          parse
+            (choice (replicate (size-1) (char 'b') ++ [char 'a']) :: Parser Char)
+            ""
+            (pack $ replicate size 'a')
+      , bgroup "nomatch" $ benchBunchMatch $ \size _ ->
+          parse
+            (choice (replicate size (char 'b')) :: Parser Char)
+            ""
+            (pack $ replicate size 'a')
+      ]
+  , bgroup "count'" benchCount
+  , bgroup "sepBy1" benchSepBy1
+  , bgroup "manyTill" $ benchBunchNoMatchLate $ \size _ ->
+      parse
+        (manyTill (char 'a') (char 'b') :: Parser String)
+        ""
+        (pack $ replicate (size-1) 'a' ++ "b")
+  ]
+
+
+benchManual :: [Benchmark]
+benchManual =
+  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]
+  where
+    benchOne num = bench (show num) $ whnf
+      (parse (sequence $ fmap char (replicate num 'a') :: Parser String) "")
+      (pack $ replicate num 'a')
+
+benchCount :: [Benchmark]
+benchCount =
+  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]
+  where
+    benchOne num = bench (show num) $ whnf
+      (parse (count' size (size*2) (char 'a') :: Parser String) "")
+      (pack $ replicate (num-1) 'a' ++ "b")
+      where
+        size = round ((0.7 :: Double) * fromIntegral num)
+
+benchSepBy1 :: [Benchmark]
+benchSepBy1 =
+  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]
+  where
+    benchOne num = bench (show num) $ whnf
+      (parse (sepBy1 (char 'a') (char 'b') :: Parser String) "")
+      (pack $ genString num)
+    genString 0 = "ac"
+    genString i = 'a' : 'b' : genString (i-1)
+
+benchBunch :: (Int -> String -> b) -> [Benchmark]
+benchBunch f =
+  [ bgroup "match" $ benchBunchMatch f
+  , bgroup "nomatch_early" $ benchBunchNoMatchEarly f
+  , bgroup "nomatch_late" $ benchBunchNoMatchLate f
+  ]
+
+benchBunchMatch :: (Int -> String -> b) -> [Benchmark]
+benchBunchMatch f =
+  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]
+  where
+    benchOne num = bench (show num) $ whnf (f num) (replicate num 'a')
+
+benchBunchNoMatchEarly :: (Int -> String -> b) -> [Benchmark]
+benchBunchNoMatchEarly f =
+  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]
+  where
+    benchOne num = bench (show num) $ whnf (f num) (replicate num 'b')
+
+benchBunchNoMatchLate :: (Int -> String -> b) -> [Benchmark]
+benchBunchNoMatchLate f =
+  map benchOne [benchSize,benchSize*2..benchSize*benchSteps]
+  where
+    benchOne num = bench (show num) $ whnf (f num) (replicate (num-1) 'a' ++ "b")

megaparsec.cabal

@@ -152,6 +152,8 @@ benchmark benchmarks
   build-depends:     base                   >= 4.8 && < 5
                    , megaparsec             >= 4.0.0
                    , criterion              >= 0.6.2.1 && < 1.2
+                   , text                   >= 1.2 && < 2
+                   , bytestring             >= 0.10 && < 2
   default-language:  Haskell2010
 
 source-repository head