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)
import Arguments
import SemanticDiff (fetchDiffs)
import qualified Renderer as R
import qualified SemanticDiffPar
import System.Directory (makeAbsolute)

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)

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

syncAsyncBenchmark :: Benchmark
syncAsyncBenchmark =
  bgroup "async vs par" [
      bench "async" . whnfIO $ SemanticDiff.fetchDiffs =<< theArgs,
      bench "par" . whnfIO $ SemanticDiffPar.fetchDiffs =<< theArgs
    ]

theArgs :: IO Arguments
theArgs = do
  jqueryPath <- makeAbsolute "test/repos/jquery"
  pure $ args jqueryPath sha1 sha2 files R.Patch
  where
    sha1 = "70526981916945dc4093e116a3de61b1777d4718"
    sha2 = "e5ffcb0838c894e26f4ff32dfec162cf624d8d7d"
    files = [
            "src/manipulation/getAll.js",
            "src/manipulation/support.js",
            "src/manipulation/wrapMap.js",
            "src/offset.js",
            "test/unit/css.js",
            "test/unit/deferred.js",
            "test/unit/deprecated.js",
            "test/unit/effects.js",
            "test/unit/event.js",
            "test/unit/offset.js",
            "test/unit/wrap.js"
            ]