tasty-bench 0.5 → 0.5.1
raw patch · 3 files changed
+111/−42 lines, 3 filesdep +transformersdep ~tasty
Dependencies added: transformers
Dependency ranges changed: tasty
Files
- changelog.md +7/−0
- src/Test/Tasty/Bench.hs +100/−39
- tasty-bench.cabal +4/−3
changelog.md view
@@ -1,3 +1,10 @@+# 0.5.1++* Add `benchCont` combinator.+* Set default timeout to 100 seconds.+* Use CAPI for foreign calls on Windows.+* Workaround `+cpuTimePrecision` on NetBSD.+ # 0.5 * Extend `TimeMode` with `MutatorCpuTime`, `MutatorWallTime` and `CustomTime`.
src/Test/Tasty/Bench.hs view
@@ -650,6 +650,7 @@ -} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}@@ -670,6 +671,7 @@ , Benchmark , bench , bgroup+ , benchCont , bcompare , bcompareWithin , env@@ -714,7 +716,8 @@ import Control.Arrow (first, second) import Control.DeepSeq (NFData, force, rnf) import Control.Exception (bracket, bracket_, evaluate)-import Control.Monad (void, unless, guard, (>=>), when)+import Control.Monad (void, unless, guard, join, (>=>), when)+import Control.Monad.Trans.Cont import Data.Data (Data) import Data.Foldable (foldMap, traverse_) import Data.Int (Int64)@@ -1115,10 +1118,19 @@ (estStdev (predict (hi t1) (lo t2))) } where- prec = max (fromInteger cpuTimePrecision) 1000000000 -- 1 ms+ prec = max (fromInteger cpuTimePrecision') 1000000000 -- 1 ms hi meas = meas { measTime = measTime meas + prec } lo meas = meas { measTime = if measTime meas > prec then measTime meas - prec else 0 } +#ifdef netbsd_HOST_OS+-- cpuTimePrecision seems to fail on NetBSD+cpuTimePrecision' :: Prelude.Integer+cpuTimePrecision' = 0+#else+cpuTimePrecision' :: Prelude.Integer+cpuTimePrecision' = cpuTimePrecision+#endif+ hasGCStats :: Bool #if MIN_VERSION_base(4,10,0) hasGCStats = unsafePerformIO getRTSStatsEnabled@@ -1260,14 +1272,7 @@ #ifdef MIN_VERSION_tasty instance IsTest Benchmarkable where- testOptions = pure- [ Option (Proxy :: Proxy RelStDev)- -- FailIfSlower and FailIfFaster must be options of a test provider rather- -- than options of an ingredient to allow setting them on per-test level.- , Option (Proxy :: Proxy FailIfSlower)- , Option (Proxy :: Proxy FailIfFaster)- , Option (Proxy :: Proxy TimeMode)- ]+ testOptions = pure benchOptions run opts b yieldProgress = case getNumThreads (lookupOption opts) of 1 -> do let timeMode = lookupOption opts@@ -1277,6 +1282,16 @@ pure $ testPassed $ show (WithLoHi est (1 - ifFaster) (1 + ifSlower)) _ -> pure $ testFailed "Benchmarks must not be run concurrently. Please pass -j1 and/or avoid +RTS -N." +benchOptions :: [OptionDescription]+benchOptions =+ [ Option (Proxy :: Proxy RelStDev)+ -- FailIfSlower and FailIfFaster must be options of a test provider rather+ -- than options of an ingredient to allow setting them on per-test level.+ , Option (Proxy :: Proxy FailIfSlower)+ , Option (Proxy :: Proxy FailIfFaster)+ , Option (Proxy :: Proxy TimeMode)+ ]+ -- | Attach a name to t'Benchmarkable'. -- -- This is actually a synonym of 'Test.Tasty.Providers.singleTest' to@@ -1297,6 +1312,63 @@ bgroup :: String -> [Benchmark] -> Benchmark bgroup = testGroup +-- | Run a t'Benchmarkable' inside some larger action.+--+-- Prefer using 'env' or 'withResource' to avoid benchmarking setup/teardown code.+-- But this isn't always possible, like when using a library that only+-- exposes resources through `bracket`-style continuation passing.+-- Imagine an alternate reality where 'withBinaryFile' can not be+-- split into 'openFile' and 'hClose':+--+-- > -- Broken:+-- > withResource+-- > (withBinaryFile "NO.txt" WriteMode $ pure)+-- > (pure . const ())+-- > benchmarkWrites+--+-- This benchmark writes to a closed file handle, which will not go well.+-- Instead, @benchCont@ allows you to embed a t'Benchmarkable'+-- in a continuation. As a trivial example,+--+-- > main :: IO ()+-- > main = defaultMain+-- > [ benchCont "write syscall" $ ContT benchmarkWrites ]+-- >+-- > benchmarkWrites :: (Benchmarkable -> IO ()) -> IO ()+-- > benchmarkWrites runBenchmark = withBinaryFile "/dev/null" WriteMode $ \fh -> do+-- > hSetBuffering fh NoBuffering+-- > runBenchmark $ whnfAppIO putHello fh+-- > -- equivalently,+-- > -- runBenchmark $ whnfIO (putHello fh)+-- >+-- > putHello :: Handle -> IO ()+-- > putHello h = hPutStrLn h "hi"+--+-- Calling the runner more than once is unspecified behavior.+-- Create a separate 'Benchmark' instead.+--+-- @since 0.5.1+benchCont :: String -> ContT () IO Benchmarkable -> Benchmark+benchCont = singleTest++#if !MIN_VERSION_tasty(1,5,4)+instance IsTest (ContT () IO Benchmarkable) where+ testOptions = pure benchOptions+ run opts (ContT bracketedBenchmark) yieldProgress = do+ rr <- newIORef Nothing+ let run' :: Benchmarkable -> IO ()+ run' b = do+ r <- run opts b yieldProgress+ join . atomicModifyIORef' rr $ \prev -> case prev of+ Nothing -> (Just r, pure ())+ p -> (p, error "Benchmarkable called multiple times")+ bracketedBenchmark run'+ maybeRes <- readIORef rr+ pure $ case maybeRes of+ Nothing -> testFailed "Provided ContT didn't run the passed Benchmarkable"+ Just r -> r+#endif+ -- | Compare benchmarks, reporting relative speed up or slow down. -- -- This function is a vague reminiscence of @bcompare@, which existed in pre-1.0@@ -1353,11 +1425,17 @@ -- -- @since 0.3.1 bcompareWithin- :: Double -- ^ Lower bound of relative speed up.- -> Double -- ^ Upper bound of relative speed up.- -> String -- ^ @tasty@ pattern to locate a baseline benchmark.- -> Benchmark -- ^ Benchmark to compare against baseline.+ :: Double+ -- ^ Lower bound of relative speed up.+ -> Double+ -- ^ Upper bound of relative speed up.+ -> String+ -- ^ @tasty@ pattern, which must unambiguously+ -- match a unique baseline benchmark. Consider using 'locateBenchmark' to construct it. -> Benchmark+ -- ^ Benchmark+ -- to be compared against the baseline benchmark by dividing measured mean times.+ -> Benchmark bcompareWithin lo hi s = case parseExpr s of Nothing -> error $ "Could not parse bcompare pattern " ++ s Just e -> after_ AllSucceed (And (StringLit (bcomparePrefix ++ show (lo, hi))) e)@@ -1387,6 +1465,11 @@ let act = defaultMain' bs bracketUtf8 act +withDefaultTimeout :: TestTree -> TestTree+withDefaultTimeout = adjustOption $ \opt -> case opt of+ Timeout{} -> opt+ NoTimeout -> mkTimeout 100000000+ bracketUtf8 :: IO a -> IO a bracketUtf8 act = do prevStdoutEnc <- hGetEncoding stdout@@ -1408,14 +1491,10 @@ defaultMain' :: [Benchmark] -> IO () defaultMain' bs = do installSignalHandlers- let b = testGroup "All" bs+ let b = withDefaultTimeout $ testGroup "All" bs opts <- parseOptions benchIngredients b let opts' = setOption (NumThreads 1) opts-#if MIN_VERSION_tasty(1,5,0) opts'' = setOption (MinDurationToReport 1000000000000) opts'-#else- opts'' = opts'-#endif case tryIngredients benchIngredients opts'' b of Nothing -> exitFailure Just act -> act >>= \x -> if x then exitSuccess else exitFailure@@ -2176,21 +2255,13 @@ testNameSeqs :: OptionSet -> TestTree -> [Seq TestName] testNameSeqs = foldTestTree trivialFold { foldSingle = const $ const . (:[]) . Seq.singleton-#if MIN_VERSION_tasty(1,5,0) , foldGroup = const $ (. concat) . map . (<|)-#else- , foldGroup = const $ map . (<|)-#endif } testNamesAndDeps :: IntMap (Seq TestName) -> OptionSet -> TestTree -> [(TestName, Unique (WithLoHi IM.Key))] testNamesAndDeps im = foldTestTree trivialFold { foldSingle = const $ const . (: []) . (, mempty)-#if MIN_VERSION_tasty(1,5,0) , foldGroup = const $ (. concat) . map . first . (++) . (++ ".")-#else- , foldGroup = const $ map . first . (++) . (++ ".")-#endif , foldAfter = const foldDeps } where@@ -2236,7 +2307,6 @@ writeTVar oldTV (Done (f name depRes res)) pure (Any True, All True)-#if MIN_VERSION_tasty(1,5,0) Executing newProgr -> do let updated = case old of Executing oldProgr -> oldProgr /= newProgr@@ -2244,9 +2314,6 @@ when updated $ writeTVar oldTV (Executing newProgr) pure (Any updated, All False)-#else- Executing{} -> pure (Any False, All False)-#endif NotStarted -> pure (Any False, All False) if anyUpdated || allDone then pure allDone else retry adNauseam = doUpdate >>= (`unless` adNauseam)@@ -2272,14 +2339,8 @@ #if defined(mingw32_HOST_OS) -#if defined(i386_HOST_ARCH)-#define CCONV stdcall-#else-#define CCONV ccall-#endif--foreign import CCONV unsafe "windows.h GetConsoleOutputCP" getConsoleOutputCP :: IO Word32-foreign import CCONV unsafe "windows.h SetConsoleOutputCP" setConsoleOutputCP :: Word32 -> IO ()+foreign import capi unsafe "windows.h GetConsoleOutputCP" getConsoleOutputCP :: IO Word32+foreign import capi unsafe "windows.h SetConsoleOutputCP" setConsoleOutputCP :: Word32 -> IO () #endif
tasty-bench.cabal view
@@ -1,5 +1,5 @@ name: tasty-bench-version: 0.5+version: 0.5.1 cabal-version: 1.18 build-type: Simple license: MIT@@ -46,14 +46,15 @@ build-depends: base >= 4.9 && < 5,- deepseq >= 1.1 && < 1.6+ deepseq >= 1.1 && < 1.6,+ transformers >= 0.4 && < 0.7 if impl(ghc < 9.0) build-depends: ghc-prim < 0.14 if flag(tasty) build-depends: containers >= 0.5 && < 0.9,- tasty >= 1.4 && < 1.6+ tasty >= 1.5 && < 1.6 if impl(ghc < 8.4) build-depends: time >= 1.2 && < 2