semantic/bench/Main.hs

{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleInstances, StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

import Criterion.Main
import Data.Function
import Data.List (genericLength)
import Data.String
import Patch
import Prologue
import SES
import Test.QuickCheck hiding (Fixed)

main :: IO ()
main = do
  benchmarks <- sequenceA [ generativeBenchmarkWith "ses" 10 arbitrarySESInputs (uncurry ((*) `on` length)) (nf (uncurry benchmarkSES)) ]
  defaultMain benchmarks
  where arbitrarySESInputs = (,) <$> sized (`vectorOf` arbitrary) <*> sized (`vectorOf` arbitrary)

benchmarkSES :: [String] -> [String] -> [Either String (Patch String)]
benchmarkSES as bs = ses compare cost as bs
  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

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