diff --git a/bench/Main.hs b/bench/Main.hs index 67c27a3eb..28a869120 100644 --- a/bench/Main.hs +++ b/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 = diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 97359d0fe..8d16734c6 100644 --- a/semantic-diff.cabal +++ b/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++