mirror of
https://github.com/github/semantic.git
synced 2024-12-24 15:35:14 +03:00
First pass at generative testing using leancheck.
This commit is contained in:
parent
89e1893462
commit
d2709f6cab
@ -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 =
|
||||
|
@ -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++
|
||||
|
Loading…
Reference in New Issue
Block a user