First pass at generative testing using leancheck.

bench/Main.hs

@@ -1,49 +1,47 @@
-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleInstances, StandaloneDeriving #-}
+{-# LANGUAGE DeriveAnyClass, FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Main where
 
+import Arguments
 import Criterion.Main
 import Data.Function
+import Data.Functor.Listable
 import Data.List (genericLength)
 import Data.String
 import Patch
 import Prologue
-import SES
-import Test.QuickCheck hiding (Fixed)
-import Arguments
-import SemanticDiff (fetchDiffs)
 import qualified Renderer as R
+import SemanticDiff (fetchDiffs)
 import qualified SemanticDiffPar
+import SES
 import System.Directory (makeAbsolute)
+import Test.LeanCheck
 
 main :: IO ()
 main = do
-  benchmarks <- sequenceA [ generativeBenchmarkWith "ses" 10 arbitrarySESInputs (uncurry ((*) `on` length)) (nf (uncurry benchmarkSES)) ]
-  defaultMain (syncAsyncBenchmark : benchmarks)
-  where arbitrarySESInputs = (,) <$> sized (`vectorOf` arbitrary) <*> sized (`vectorOf` arbitrary)
+  benchmarks <- sequenceA [ generativeBenchmarkWith "ses" 10 sesInputsOfLength (uncurry ((,) `on` length)) (nf (uncurry benchmarkSES)) ]
+  defaultMain benchmarks
+  -- defaultMain (syncAsyncBenchmark : benchmarks)
+  where sesInputsOfLength n = listsOfLength n tiers >< listsOfLength n tiers
 
 benchmarkSES :: [String] -> [String] -> [Either String (Patch String)]
-benchmarkSES as bs = ses compare cost as bs
+benchmarkSES = ses compare cost
   where compare a b = if a == b then Just (Left a) else Nothing
         cost = either (const 0) (sum . fmap genericLength)
 
 instance NFData a => NFData (Patch a)
 
--- | Defines a named group of n benchmarks over inputs generated by an `Arbitrary` instance.
--- |
--- | The inputs’ sizes at each iteration are measured by a metric function, which gives the name of the benchmark. This makes it convenient to correlate a benchmark of some function over lists with e.g. input `length`.
-generativeBenchmark :: (Arbitrary a, Show m, Ord m) => String -> Int -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
-generativeBenchmark name n metric benchmark = generativeBenchmarkWith name n arbitrary metric benchmark
+-- | Defines a named group of n benchmarks over inputs generated by a 'Listable' instance.
+--
+--   The inputs’ sizes at each iteration are measured by a metric function, which gives the name of the benchmark. This makes it convenient to correlate a benchmark of some function over e.g. lists with e.g. metric 'length'.
+generativeBenchmark :: (Listable a, Show m, Ord m) => String -> Int -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
+generativeBenchmark name n = generativeBenchmarkWith name n (const tiers)
 
-generativeBenchmarkWith :: (Show m, Ord m) => String -> Int -> Gen a -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
-generativeBenchmarkWith name n generator metric benchmark = do
-  benchmarks <- traverse measure (take n [0,(defaultSize `div` n)..defaultSize])
-  pure $! bgroup name (snd <$> (sortOn fst benchmarks))
-  where measure n = do
-          input <- generate (resize n generator)
-          let measurement = metric input
-          pure $! (measurement, bench (show measurement) (benchmark input))
-        defaultSize = 100
+generativeBenchmarkWith :: (Show m, Ord m) => String -> Int -> (Int -> [Tier a]) -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
+generativeBenchmarkWith name n generate metric benchmark = do
+  benchmarks <- traverse measure (take 2 (concat (generate n)))
+  pure $! bgroup name (snd <$> sortOn fst benchmarks)
+  where measure input = let measurement = metric input in pure $! (measurement, bench (show measurement) (benchmark input))
 
 syncAsyncBenchmark :: Benchmark
 syncAsyncBenchmark =

semantic-diff.cabal

@@ -141,9 +141,9 @@ benchmark semantic-diff-bench
   build-depends:       base
                      , criterion
                      , directory
+                     , leancheck
                      , monad-par
                      , mtl
-                     , QuickCheck >= 2.8.1
                      , semantic-diff
                      , text >= 1.2.1.3
   ghc-options:       -threaded -rtsopts -with-rtsopts=-N -j -O2 -static -pgml=script/g++