{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Test.Tasty.Bench
(
defaultMain
, Benchmark
, bench
, bgroup
, env
, envWithCleanup
, Benchmarkable
, nf
, whnf
, nfIO
, whnfIO
, nfAppIO
, whnfAppIO
, benchIngredients
, consoleBenchReporter
, csvReporter
, RelStDev(..)
, FailIfSlower(..)
, FailIfFaster(..)
) where
import Prelude hiding (Int, Integer)
import Control.Applicative
import Control.DeepSeq
import Control.Exception
import Control.Monad (void, unless, guard, (>=>))
import Data.Data (Typeable)
import Data.Foldable (foldMap, traverse_)
import Data.Int (Int64)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.List (intercalate, stripPrefix, isPrefixOf)
import Data.Monoid (All(..), Any(..))
import Data.Proxy
#if MIN_VERSION_containers(0,5,0)
import Data.Set (lookupGE)
#endif
import qualified Data.Set as S
import Data.Traversable (forM)
import Data.Word (Word64)
import GHC.Conc
#if MIN_VERSION_base(4,6,0)
import GHC.Stats
#endif
import System.CPUTime
import System.Mem
import Test.Tasty hiding (defaultMain)
import qualified Test.Tasty
import Test.Tasty.Ingredients
import Test.Tasty.Ingredients.ConsoleReporter
import Test.Tasty.Options
import Test.Tasty.Providers
import Test.Tasty.Runners
import Text.Printf
import System.IO
import System.IO.Unsafe
newtype RelStDev = RelStDev Double
deriving (Int -> RelStDev -> ShowS
[RelStDev] -> ShowS
RelStDev -> String
(Int -> RelStDev -> ShowS)
-> (RelStDev -> String) -> ([RelStDev] -> ShowS) -> Show RelStDev
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelStDev] -> ShowS
$cshowList :: [RelStDev] -> ShowS
show :: RelStDev -> String
$cshow :: RelStDev -> String
showsPrec :: Int -> RelStDev -> ShowS
$cshowsPrec :: Int -> RelStDev -> ShowS
Show, ReadPrec [RelStDev]
ReadPrec RelStDev
Int -> ReadS RelStDev
ReadS [RelStDev]
(Int -> ReadS RelStDev)
-> ReadS [RelStDev]
-> ReadPrec RelStDev
-> ReadPrec [RelStDev]
-> Read RelStDev
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelStDev]
$creadListPrec :: ReadPrec [RelStDev]
readPrec :: ReadPrec RelStDev
$creadPrec :: ReadPrec RelStDev
readList :: ReadS [RelStDev]
$creadList :: ReadS [RelStDev]
readsPrec :: Int -> ReadS RelStDev
$creadsPrec :: Int -> ReadS RelStDev
Read, Typeable)
instance IsOption RelStDev where
defaultValue :: RelStDev
defaultValue = Double -> RelStDev
RelStDev Double
0.01
parseValue :: String -> Maybe RelStDev
parseValue = (Double -> RelStDev) -> Maybe Double -> Maybe RelStDev
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> RelStDev
RelStDev (Maybe Double -> Maybe RelStDev)
-> (String -> Maybe Double) -> String -> Maybe RelStDev
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Double
parsePositivePercents
optionName :: Tagged RelStDev String
optionName = String -> Tagged RelStDev String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"stdev"
optionHelp :: Tagged RelStDev String
optionHelp = String -> Tagged RelStDev String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Target relative standard deviation of measurements in percents (1 by default). Large values correspond to fast and loose benchmarks, and small ones to long and precise. If it takes far too long, consider setting --timeout, which will interrupt benchmarks, potentially before reaching the target deviation."
newtype FailIfSlower = FailIfSlower Double
deriving (Int -> FailIfSlower -> ShowS
[FailIfSlower] -> ShowS
FailIfSlower -> String
(Int -> FailIfSlower -> ShowS)
-> (FailIfSlower -> String)
-> ([FailIfSlower] -> ShowS)
-> Show FailIfSlower
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailIfSlower] -> ShowS
$cshowList :: [FailIfSlower] -> ShowS
show :: FailIfSlower -> String
$cshow :: FailIfSlower -> String
showsPrec :: Int -> FailIfSlower -> ShowS
$cshowsPrec :: Int -> FailIfSlower -> ShowS
Show, ReadPrec [FailIfSlower]
ReadPrec FailIfSlower
Int -> ReadS FailIfSlower
ReadS [FailIfSlower]
(Int -> ReadS FailIfSlower)
-> ReadS [FailIfSlower]
-> ReadPrec FailIfSlower
-> ReadPrec [FailIfSlower]
-> Read FailIfSlower
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FailIfSlower]
$creadListPrec :: ReadPrec [FailIfSlower]
readPrec :: ReadPrec FailIfSlower
$creadPrec :: ReadPrec FailIfSlower
readList :: ReadS [FailIfSlower]
$creadList :: ReadS [FailIfSlower]
readsPrec :: Int -> ReadS FailIfSlower
$creadsPrec :: Int -> ReadS FailIfSlower
Read, Typeable)
instance IsOption FailIfSlower where
defaultValue :: FailIfSlower
defaultValue = Double -> FailIfSlower
FailIfSlower (Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.0)
parseValue :: String -> Maybe FailIfSlower
parseValue = (Double -> FailIfSlower) -> Maybe Double -> Maybe FailIfSlower
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> FailIfSlower
FailIfSlower (Maybe Double -> Maybe FailIfSlower)
-> (String -> Maybe Double) -> String -> Maybe FailIfSlower
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Double
parsePositivePercents
optionName :: Tagged FailIfSlower String
optionName = String -> Tagged FailIfSlower String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"fail-if-slower"
optionHelp :: Tagged FailIfSlower String
optionHelp = String -> Tagged FailIfSlower String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Upper bound of acceptable slow down in percents. If a benchmark is unacceptably slower than baseline (see --baseline), it will be reported as failed."
newtype FailIfFaster = FailIfFaster Double
deriving (Int -> FailIfFaster -> ShowS
[FailIfFaster] -> ShowS
FailIfFaster -> String
(Int -> FailIfFaster -> ShowS)
-> (FailIfFaster -> String)
-> ([FailIfFaster] -> ShowS)
-> Show FailIfFaster
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailIfFaster] -> ShowS
$cshowList :: [FailIfFaster] -> ShowS
show :: FailIfFaster -> String
$cshow :: FailIfFaster -> String
showsPrec :: Int -> FailIfFaster -> ShowS
$cshowsPrec :: Int -> FailIfFaster -> ShowS
Show, ReadPrec [FailIfFaster]
ReadPrec FailIfFaster
Int -> ReadS FailIfFaster
ReadS [FailIfFaster]
(Int -> ReadS FailIfFaster)
-> ReadS [FailIfFaster]
-> ReadPrec FailIfFaster
-> ReadPrec [FailIfFaster]
-> Read FailIfFaster
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FailIfFaster]
$creadListPrec :: ReadPrec [FailIfFaster]
readPrec :: ReadPrec FailIfFaster
$creadPrec :: ReadPrec FailIfFaster
readList :: ReadS [FailIfFaster]
$creadList :: ReadS [FailIfFaster]
readsPrec :: Int -> ReadS FailIfFaster
$creadsPrec :: Int -> ReadS FailIfFaster
Read, Typeable)
instance IsOption FailIfFaster where
defaultValue :: FailIfFaster
defaultValue = Double -> FailIfFaster
FailIfFaster (Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.0)
parseValue :: String -> Maybe FailIfFaster
parseValue = (Double -> FailIfFaster) -> Maybe Double -> Maybe FailIfFaster
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> FailIfFaster
FailIfFaster (Maybe Double -> Maybe FailIfFaster)
-> (String -> Maybe Double) -> String -> Maybe FailIfFaster
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Double
parsePositivePercents
optionName :: Tagged FailIfFaster String
optionName = String -> Tagged FailIfFaster String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"fail-if-faster"
optionHelp :: Tagged FailIfFaster String
optionHelp = String -> Tagged FailIfFaster String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Upper bound of acceptable speed up in percents. If a benchmark is unacceptably faster than baseline (see --baseline), it will be reported as failed."
parsePositivePercents :: String -> Maybe Double
parsePositivePercents :: String -> Maybe Double
parsePositivePercents String
xs = do
Double
x <- String -> Maybe Double
forall a. Read a => String -> Maybe a
safeRead String
xs
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)
Double -> Maybe Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)
newtype Benchmarkable = Benchmarkable { Benchmarkable -> Int64 -> IO ()
_unBenchmarkable :: Int64 -> IO () }
deriving (Typeable)
showPicos :: Word64 -> String
showPicos :: Word64 -> String
showPicos Word64
i
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f ps" Double
t
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e1 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f ns" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e3)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e3 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f ns" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e3)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e4 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f μs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e6 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f μs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e7 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f ms" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e9)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e9 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f ms" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e9)
| Bool
otherwise = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f s" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e12)
where
t :: Double
t :: Double
t = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i
showBytes :: Word64 -> String
showBytes :: Word64 -> String
showBytes Word64
i
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1000 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f B " Double
t
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10189 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f KB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1023488 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f KB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10433332 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f MB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1048576)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1048051712 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f MB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1048576)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10683731149 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f GB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1073741824)
| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1073204953088 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f GB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1073741824)
| Bool
otherwise = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f TB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1099511627776)
where
t :: Double
t :: Double
t = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i
data Measurement = Measurement
{ Measurement -> Word64
measTime :: !Word64
, Measurement -> Word64
measAllocs :: !Word64
, Measurement -> Word64
measCopied :: !Word64
} deriving (Int -> Measurement -> ShowS
[Measurement] -> ShowS
Measurement -> String
(Int -> Measurement -> ShowS)
-> (Measurement -> String)
-> ([Measurement] -> ShowS)
-> Show Measurement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Measurement] -> ShowS
$cshowList :: [Measurement] -> ShowS
show :: Measurement -> String
$cshow :: Measurement -> String
showsPrec :: Int -> Measurement -> ShowS
$cshowsPrec :: Int -> Measurement -> ShowS
Show, ReadPrec [Measurement]
ReadPrec Measurement
Int -> ReadS Measurement
ReadS [Measurement]
(Int -> ReadS Measurement)
-> ReadS [Measurement]
-> ReadPrec Measurement
-> ReadPrec [Measurement]
-> Read Measurement
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Measurement]
$creadListPrec :: ReadPrec [Measurement]
readPrec :: ReadPrec Measurement
$creadPrec :: ReadPrec Measurement
readList :: ReadS [Measurement]
$creadList :: ReadS [Measurement]
readsPrec :: Int -> ReadS Measurement
$creadsPrec :: Int -> ReadS Measurement
Read)
data Estimate = Estimate
{ Estimate -> Measurement
estMean :: !Measurement
, Estimate -> Word64
estSigma :: !Word64
} deriving (Int -> Estimate -> ShowS
[Estimate] -> ShowS
Estimate -> String
(Int -> Estimate -> ShowS)
-> (Estimate -> String) -> ([Estimate] -> ShowS) -> Show Estimate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Estimate] -> ShowS
$cshowList :: [Estimate] -> ShowS
show :: Estimate -> String
$cshow :: Estimate -> String
showsPrec :: Int -> Estimate -> ShowS
$cshowsPrec :: Int -> Estimate -> ShowS
Show, ReadPrec [Estimate]
ReadPrec Estimate
Int -> ReadS Estimate
ReadS [Estimate]
(Int -> ReadS Estimate)
-> ReadS [Estimate]
-> ReadPrec Estimate
-> ReadPrec [Estimate]
-> Read Estimate
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Estimate]
$creadListPrec :: ReadPrec [Estimate]
readPrec :: ReadPrec Estimate
$creadPrec :: ReadPrec Estimate
readList :: ReadS [Estimate]
$creadList :: ReadS [Estimate]
readsPrec :: Int -> ReadS Estimate
$creadsPrec :: Int -> ReadS Estimate
Read)
data Response = Response
{ Response -> Estimate
respEstimate :: !Estimate
, Response -> FailIfSlower
respIfSlower :: !FailIfSlower
, Response -> FailIfFaster
respIfFaster :: !FailIfFaster
} deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, ReadPrec [Response]
ReadPrec Response
Int -> ReadS Response
ReadS [Response]
(Int -> ReadS Response)
-> ReadS [Response]
-> ReadPrec Response
-> ReadPrec [Response]
-> Read Response
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Response]
$creadListPrec :: ReadPrec [Response]
readPrec :: ReadPrec Response
$creadPrec :: ReadPrec Response
readList :: ReadS [Response]
$creadList :: ReadS [Response]
readsPrec :: Int -> ReadS Response
$creadsPrec :: Int -> ReadS Response
Read)
prettyEstimate :: Estimate -> String
prettyEstimate :: Estimate -> String
prettyEstimate (Estimate Measurement
m Word64
sigma) =
Word64 -> String
showPicos (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ± " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showPicos (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)
prettyEstimateWithGC :: Estimate -> String
prettyEstimateWithGC :: Estimate -> String
prettyEstimateWithGC (Estimate Measurement
m Word64
sigma) =
Word64 -> String
showPicos (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ± " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showPicos (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showBytes (Measurement -> Word64
measAllocs Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" allocated, "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showBytes (Measurement -> Word64
measCopied Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" copied"
csvEstimate :: Estimate -> String
csvEstimate :: Estimate -> String
csvEstimate (Estimate Measurement
m Word64
sigma) = Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)
csvEstimateWithGC :: Estimate -> String
csvEstimateWithGC :: Estimate -> String
csvEstimateWithGC (Estimate Measurement
m Word64
sigma) = Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measAllocs Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measCopied Measurement
m)
predict
:: Measurement
-> Measurement
-> Estimate
predict :: Measurement -> Measurement -> Estimate
predict (Measurement Word64
t1 Word64
a1 Word64
c1) (Measurement Word64
t2 Word64
a2 Word64
c2) = Estimate :: Measurement -> Word64 -> Estimate
Estimate
{ estMean :: Measurement
estMean = Word64 -> Word64 -> Word64 -> Measurement
Measurement Word64
t Word64
a Word64
c
, estSigma :: Word64
estSigma = Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double
forall a. Floating a => a -> a
sqrt (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
d) :: Double)
}
where
sqr :: a -> a
sqr a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x
d :: Word64
d = Word64 -> Word64
forall a. Num a => a -> a
sqr (Word64
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64 -> Word64
forall a. Num a => a -> a
sqr (Word64
t2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
t)
t :: Word64
t = (Word64
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
t2) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
5
a :: Word64
a = (Word64
a1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
a2) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
5
c :: Word64
c = (Word64
c1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
c2) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
5
predictPerturbed :: Measurement -> Measurement -> Estimate
predictPerturbed :: Measurement -> Measurement -> Estimate
predictPerturbed Measurement
t1 Measurement
t2 = Estimate :: Measurement -> Word64 -> Estimate
Estimate
{ estMean :: Measurement
estMean = Estimate -> Measurement
estMean (Measurement -> Measurement -> Estimate
predict Measurement
t1 Measurement
t2)
, estSigma :: Word64
estSigma = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max
(Estimate -> Word64
estSigma (Measurement -> Measurement -> Estimate
predict (Measurement -> Measurement
lo Measurement
t1) (Measurement -> Measurement
hi Measurement
t2)))
(Estimate -> Word64
estSigma (Measurement -> Measurement -> Estimate
predict (Measurement -> Measurement
hi Measurement
t1) (Measurement -> Measurement
lo Measurement
t2)))
}
where
prec :: Word64
prec = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
cpuTimePrecision) Word64
1000000000
hi :: Measurement -> Measurement
hi Measurement
meas = Measurement
meas { measTime :: Word64
measTime = Measurement -> Word64
measTime Measurement
meas Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
prec }
lo :: Measurement -> Measurement
lo Measurement
meas = Measurement
meas { measTime :: Word64
measTime = Measurement -> Word64
measTime Measurement
meas Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
prec }
#if !MIN_VERSION_base(4,10,0)
getRTSStatsEnabled :: IO Bool
#if MIN_VERSION_base(4,6,0)
getRTSStatsEnabled = getGCStatsEnabled
#else
getRTSStatsEnabled = pure False
#endif
#endif
getAllocsAndCopied :: IO (Word64, Word64)
getAllocsAndCopied :: IO (Word64, Word64)
getAllocsAndCopied = do
Bool
enabled <- IO Bool
getRTSStatsEnabled
if Bool -> Bool
not Bool
enabled then (Word64, Word64) -> IO (Word64, Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64
0, Word64
0) else
#if MIN_VERSION_base(4,10,0)
(\RTSStats
s -> (RTSStats -> Word64
allocated_bytes RTSStats
s, RTSStats -> Word64
copied_bytes RTSStats
s)) (RTSStats -> (Word64, Word64))
-> IO RTSStats -> IO (Word64, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
#elif MIN_VERSION_base(4,6,0)
(\s -> (fromIntegral $ bytesAllocated s, fromIntegral $ bytesCopied s)) <$> getGCStats
#else
pure (0, 0)
#endif
measureTime :: Int64 -> Benchmarkable -> IO Measurement
measureTime :: Int64 -> Benchmarkable -> IO Measurement
measureTime Int64
n (Benchmarkable Int64 -> IO ()
act) = do
IO ()
performGC
Word64
startTime <- Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> IO Integer -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
getCPUTime
(Word64
startAllocs, Word64
startCopied) <- IO (Word64, Word64)
getAllocsAndCopied
Int64 -> IO ()
act Int64
n
Word64
endTime <- Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> IO Integer -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
getCPUTime
(Word64
endAllocs, Word64
endCopied) <- IO (Word64, Word64)
getAllocsAndCopied
Measurement -> IO Measurement
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Measurement -> IO Measurement) -> Measurement -> IO Measurement
forall a b. (a -> b) -> a -> b
$ Measurement :: Word64 -> Word64 -> Word64 -> Measurement
Measurement
{ measTime :: Word64
measTime = Word64
endTime Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
startTime
, measAllocs :: Word64
measAllocs = Word64
endAllocs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
startAllocs
, measCopied :: Word64
measCopied = Word64
endCopied Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
startCopied
}
measureTimeUntil :: Timeout -> RelStDev -> Benchmarkable -> IO Estimate
measureTimeUntil :: Timeout -> RelStDev -> Benchmarkable -> IO Estimate
measureTimeUntil Timeout
timeout (RelStDev Double
targetRelStDev) Benchmarkable
b = do
Measurement
t1 <- Int64 -> Benchmarkable -> IO Measurement
measureTime Int64
1 Benchmarkable
b
Int64 -> Measurement -> Word64 -> IO Estimate
go Int64
1 Measurement
t1 Word64
0
where
go :: Int64 -> Measurement -> Word64 -> IO Estimate
go :: Int64 -> Measurement -> Word64 -> IO Estimate
go Int64
n Measurement
t1 Word64
sumOfTs = do
Measurement
t2 <- Int64 -> Benchmarkable -> IO Measurement
measureTime (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
n) Benchmarkable
b
let Estimate (Measurement Word64
meanN Word64
allocN Word64
copiedN) Word64
sigmaN = Measurement -> Measurement -> Estimate
predictPerturbed Measurement
t1 Measurement
t2
isTimeoutSoon :: Bool
isTimeoutSoon = case Timeout
timeout of
Timeout
NoTimeout -> Bool
False
Timeout Integer
micros String
_ -> (Word64
sumOfTs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Measurement -> Word64
measTime Measurement
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Measurement -> Word64
measTime Measurement
t2) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
12 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
micros Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10
isStDevInTargetRange :: Bool
isStDevInTargetRange = Word64
sigmaN Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 Double
targetRelStDev Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
meanN)
scale :: Word64 -> Word64
scale = (Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
if Bool
isStDevInTargetRange Bool -> Bool -> Bool
|| Bool
isTimeoutSoon
then Estimate -> IO Estimate
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Estimate -> IO Estimate) -> Estimate -> IO Estimate
forall a b. (a -> b) -> a -> b
$ Measurement -> Word64 -> Estimate
Estimate (Word64 -> Word64 -> Word64 -> Measurement
Measurement (Word64 -> Word64
scale Word64
meanN) (Word64 -> Word64
scale Word64
allocN) (Word64 -> Word64
scale Word64
copiedN)) (Word64 -> Word64
scale Word64
sigmaN)
else Int64 -> Measurement -> Word64 -> IO Estimate
go (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
n) Measurement
t2 (Word64
sumOfTs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Measurement -> Word64
measTime Measurement
t1)
instance IsTest Benchmarkable where
testOptions :: Tagged Benchmarkable [OptionDescription]
testOptions = [OptionDescription] -> Tagged Benchmarkable [OptionDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Proxy RelStDev -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy RelStDev
forall k (t :: k). Proxy t
Proxy :: Proxy RelStDev)
, Proxy FailIfSlower -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy FailIfSlower
forall k (t :: k). Proxy t
Proxy :: Proxy FailIfSlower)
, Proxy FailIfFaster -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy FailIfFaster
forall k (t :: k). Proxy t
Proxy :: Proxy FailIfFaster)
]
run :: OptionSet -> Benchmarkable -> (Progress -> IO ()) -> IO Result
run OptionSet
opts Benchmarkable
b = IO Result -> (Progress -> IO ()) -> IO Result
forall a b. a -> b -> a
const (IO Result -> (Progress -> IO ()) -> IO Result)
-> IO Result -> (Progress -> IO ()) -> IO Result
forall a b. (a -> b) -> a -> b
$ case NumThreads -> Int
getNumThreads (OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) of
Int
1 -> do
Estimate
est <- Timeout -> RelStDev -> Benchmarkable -> IO Estimate
measureTimeUntil (OptionSet -> Timeout
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) (OptionSet -> RelStDev
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) Benchmarkable
b
Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ Response -> String
forall a. Show a => a -> String
show (Estimate -> FailIfSlower -> FailIfFaster -> Response
Response Estimate
est (OptionSet -> FailIfSlower
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) (OptionSet -> FailIfFaster
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts))
Int
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed String
"Benchmarks should be run in a single-threaded mode (--jobs 1)"
bench :: String -> Benchmarkable -> Benchmark
bench :: String -> Benchmarkable -> Benchmark
bench = String -> Benchmarkable -> Benchmark
forall t. IsTest t => String -> t -> Benchmark
singleTest
bgroup :: String -> [Benchmark] -> Benchmark
bgroup :: String -> [Benchmark] -> Benchmark
bgroup = String -> [Benchmark] -> Benchmark
testGroup
type Benchmark = TestTree
defaultMain :: [Benchmark] -> IO ()
defaultMain :: [Benchmark] -> IO ()
defaultMain = [Ingredient] -> Benchmark -> IO ()
Test.Tasty.defaultMainWithIngredients [Ingredient]
benchIngredients (Benchmark -> IO ())
-> ([Benchmark] -> Benchmark) -> [Benchmark] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Benchmark] -> Benchmark
testGroup String
"All"
benchIngredients :: [Ingredient]
benchIngredients :: [Ingredient]
benchIngredients = [Ingredient
listingTests, Ingredient -> Ingredient -> Ingredient
composeReporters Ingredient
consoleBenchReporter Ingredient
csvReporter]
funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench b -> c
frc = ((Int64 -> IO ()) -> Benchmarkable
Benchmarkable ((Int64 -> IO ()) -> Benchmarkable)
-> (a -> Int64 -> IO ()) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> Int64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> b) -> a -> Int64 -> IO ())
-> (a -> b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> a -> Int64 -> IO ()
forall t t. (Ord t, Num t) => (t -> b) -> t -> t -> IO ()
go
where
go :: (t -> b) -> t -> t -> IO ()
go t -> b
f t
x t
n
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = do
c
_ <- c -> IO c
forall a. a -> IO a
evaluate (b -> c
frc (t -> b
f t
x))
(t -> b) -> t -> t -> IO ()
go t -> b
f t
x (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# INLINE funcToBench #-}
nf :: NFData b => (a -> b) -> a -> Benchmarkable
nf :: (a -> b) -> a -> Benchmarkable
nf = (b -> ()) -> (a -> b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench b -> ()
forall a. NFData a => a -> ()
rnf
{-# INLINE nf #-}
whnf :: (a -> b) -> a -> Benchmarkable
whnf :: (a -> b) -> a -> Benchmarkable
whnf = (b -> b) -> (a -> b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench b -> b
forall a. a -> a
id
{-# INLINE whnf #-}
ioToBench :: (b -> c) -> IO b -> Benchmarkable
ioToBench :: (b -> c) -> IO b -> Benchmarkable
ioToBench b -> c
frc IO b
act = (Int64 -> IO ()) -> Benchmarkable
Benchmarkable Int64 -> IO ()
forall t. (Ord t, Num t) => t -> IO ()
go
where
go :: t -> IO ()
go t
n
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = do
b
val <- IO b
act
c
_ <- c -> IO c
forall a. a -> IO a
evaluate (b -> c
frc b
val)
t -> IO ()
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# INLINE ioToBench #-}
nfIO :: NFData a => IO a -> Benchmarkable
nfIO :: IO a -> Benchmarkable
nfIO = (a -> ()) -> IO a -> Benchmarkable
forall b c. (b -> c) -> IO b -> Benchmarkable
ioToBench a -> ()
forall a. NFData a => a -> ()
rnf
{-# INLINE nfIO #-}
whnfIO :: NFData a => IO a -> Benchmarkable
whnfIO :: IO a -> Benchmarkable
whnfIO = (a -> a) -> IO a -> Benchmarkable
forall b c. (b -> c) -> IO b -> Benchmarkable
ioToBench a -> a
forall a. a -> a
id
{-# INLINE whnfIO #-}
ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench b -> c
frc = ((Int64 -> IO ()) -> Benchmarkable
Benchmarkable ((Int64 -> IO ()) -> Benchmarkable)
-> (a -> Int64 -> IO ()) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> Int64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> IO b) -> a -> Int64 -> IO ())
-> (a -> IO b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IO b) -> a -> Int64 -> IO ()
forall t t. (Ord t, Num t) => (t -> IO b) -> t -> t -> IO ()
go
where
go :: (t -> IO b) -> t -> t -> IO ()
go t -> IO b
f t
x t
n
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = do
b
val <- t -> IO b
f t
x
c
_ <- c -> IO c
forall a. a -> IO a
evaluate (b -> c
frc b
val)
(t -> IO b) -> t -> t -> IO ()
go t -> IO b
f t
x (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# INLINE ioFuncToBench #-}
nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable
nfAppIO :: (a -> IO b) -> a -> Benchmarkable
nfAppIO = (b -> ()) -> (a -> IO b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench b -> ()
forall a. NFData a => a -> ()
rnf
{-# INLINE nfAppIO #-}
whnfAppIO :: (a -> IO b) -> a -> Benchmarkable
whnfAppIO :: (a -> IO b) -> a -> Benchmarkable
whnfAppIO = (b -> b) -> (a -> IO b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench b -> b
forall a. a -> a
id
{-# INLINE whnfAppIO #-}
env :: NFData env => IO env -> (env -> Benchmark) -> Benchmark
env :: IO env -> (env -> Benchmark) -> Benchmark
env IO env
res = IO env -> (env -> IO ()) -> (env -> Benchmark) -> Benchmark
forall env a.
NFData env =>
IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
res (IO () -> env -> IO ()
forall a b. a -> b -> a
const (IO () -> env -> IO ()) -> IO () -> env -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
envWithCleanup :: NFData env => IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup :: IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
res env -> IO a
fin env -> Benchmark
f = IO env -> (env -> IO ()) -> (IO env -> Benchmark) -> Benchmark
forall a. IO a -> (a -> IO ()) -> (IO a -> Benchmark) -> Benchmark
withResource
(IO env
res IO env -> (env -> IO env) -> IO env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= env -> IO env
forall a. a -> IO a
evaluate (env -> IO env) -> (env -> env) -> env -> IO env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> env
forall a. NFData a => a -> a
force)
(IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> (env -> IO a) -> env -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> IO a
fin)
(env -> Benchmark
f (env -> Benchmark) -> (IO env -> env) -> IO env -> Benchmark
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO env -> env
forall a. IO a -> a
unsafePerformIO)
newtype CsvPath = CsvPath { CsvPath -> String
_unCsvPath :: FilePath }
deriving (Typeable)
instance IsOption (Maybe CsvPath) where
defaultValue :: Maybe CsvPath
defaultValue = Maybe CsvPath
forall a. Maybe a
Nothing
parseValue :: String -> Maybe (Maybe CsvPath)
parseValue = Maybe CsvPath -> Maybe (Maybe CsvPath)
forall a. a -> Maybe a
Just (Maybe CsvPath -> Maybe (Maybe CsvPath))
-> (String -> Maybe CsvPath) -> String -> Maybe (Maybe CsvPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CsvPath -> Maybe CsvPath
forall a. a -> Maybe a
Just (CsvPath -> Maybe CsvPath)
-> (String -> CsvPath) -> String -> Maybe CsvPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CsvPath
CsvPath
optionName :: Tagged (Maybe CsvPath) String
optionName = String -> Tagged (Maybe CsvPath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"csv"
optionHelp :: Tagged (Maybe CsvPath) String
optionHelp = String -> Tagged (Maybe CsvPath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"File to write results in CSV format"
csvReporter :: Ingredient
csvReporter :: Ingredient
csvReporter = [OptionDescription]
-> (OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
TestReporter [Proxy (Maybe CsvPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy (Maybe CsvPath)
forall k (t :: k). Proxy t
Proxy :: Proxy (Maybe CsvPath))] ((OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient)
-> (OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$
\OptionSet
opts Benchmark
tree -> do
CsvPath String
path <- OptionSet -> Maybe CsvPath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
let names :: IntMap String
names = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IM.fromDistinctAscList ([(Int, String)] -> IntMap String)
-> [(Int, String)] -> IntMap String
forall a b. (a -> b) -> a -> b
$ [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (OptionSet -> Benchmark -> [String]
testsNames OptionSet
opts Benchmark
tree)
(StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \StatusMap
smap -> do
let augmented :: IntMap (String, TVar Status)
augmented = (String -> TVar Status -> (String, TVar Status))
-> IntMap String -> StatusMap -> IntMap (String, TVar Status)
forall a b c. (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
IM.intersectionWith (,) IntMap String
names StatusMap
smap
Bool
hasGCStats <- IO Bool
getRTSStatsEnabled
IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(do
Handle
h <- String -> IOMode -> IO Handle
openFile String
path IOMode
WriteMode
Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Name,Mean (ps),2*Stdev (ps)" String -> ShowS
forall a. [a] -> [a] -> [a]
++
(if Bool
hasGCStats then String
",Allocated,Copied" else String
"")
Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
)
Handle -> IO ()
hClose
(Handle -> IntMap (String, TVar Status) -> IO ()
`csvOutput` IntMap (String, TVar Status)
augmented)
(Double -> IO Bool) -> IO (Double -> IO Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Double -> IO Bool) -> IO (Double -> IO Bool))
-> (Double -> IO Bool) -> IO (Double -> IO Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> Double -> IO Bool
forall a b. a -> b -> a
const ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Int -> Bool) -> (Statistics -> Int) -> Statistics -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statistics -> Int
statFailures (Statistics -> Bool) -> IO Statistics -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatusMap -> IO Statistics
computeStatistics StatusMap
smap)
csvOutput :: Handle -> IntMap (TestName, TVar Status) -> IO ()
csvOutput :: Handle -> IntMap (String, TVar Status) -> IO ()
csvOutput Handle
h = ((String, TVar Status) -> IO ())
-> IntMap (String, TVar Status) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((String, TVar Status) -> IO ())
-> IntMap (String, TVar Status) -> IO ())
-> ((String, TVar Status) -> IO ())
-> IntMap (String, TVar Status)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name, TVar Status
tv) -> do
Bool
hasGCStats <- IO Bool
getRTSStatsEnabled
let csv :: Estimate -> String
csv = if Bool
hasGCStats then Estimate -> String
csvEstimateWithGC else Estimate -> String
csvEstimate
Result
r <- STM Result -> IO Result
forall a. STM a -> IO a
atomically (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
tv STM Status -> (Status -> STM Result) -> STM Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Status
s -> case Status
s of Done Result
r -> Result -> STM Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r; Status
_ -> STM Result
forall a. STM a
retry
case String -> Maybe Response
forall a. Read a => String -> Maybe a
safeRead (Result -> String
resultDescription Result
r) of
Maybe Response
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (Response Estimate
est FailIfSlower
_ FailIfFaster
_) -> do
String
msg <- String -> IO String
formatMessage (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Estimate -> String
csv Estimate
est
Handle -> String -> IO ()
hPutStrLn Handle
h (ShowS
encodeCsv String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
',' Char -> ShowS
forall a. a -> [a] -> [a]
: String
msg)
encodeCsv :: String -> String
encodeCsv :: ShowS
encodeCsv String
xs
| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
xs) String
",\"\n\r"
= Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
x -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' then String
"\"\"" else [Char
x]) String
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
| Bool
otherwise = String
xs
newtype BaselinePath = BaselinePath { BaselinePath -> String
_unBaselinePath :: FilePath }
deriving (Typeable)
instance IsOption (Maybe BaselinePath) where
defaultValue :: Maybe BaselinePath
defaultValue = Maybe BaselinePath
forall a. Maybe a
Nothing
parseValue :: String -> Maybe (Maybe BaselinePath)
parseValue = Maybe BaselinePath -> Maybe (Maybe BaselinePath)
forall a. a -> Maybe a
Just (Maybe BaselinePath -> Maybe (Maybe BaselinePath))
-> (String -> Maybe BaselinePath)
-> String
-> Maybe (Maybe BaselinePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaselinePath -> Maybe BaselinePath
forall a. a -> Maybe a
Just (BaselinePath -> Maybe BaselinePath)
-> (String -> BaselinePath) -> String -> Maybe BaselinePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BaselinePath
BaselinePath
optionName :: Tagged (Maybe BaselinePath) String
optionName = String -> Tagged (Maybe BaselinePath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"baseline"
optionHelp :: Tagged (Maybe BaselinePath) String
optionHelp = String -> Tagged (Maybe BaselinePath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"File with baseline results in CSV format to compare against"
consoleBenchReporter :: Ingredient
consoleBenchReporter :: Ingredient
consoleBenchReporter = [OptionDescription]
-> (OptionSet -> IO (String -> Result -> Result)) -> Ingredient
modifyConsoleReporter [Proxy (Maybe BaselinePath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy (Maybe BaselinePath)
forall k (t :: k). Proxy t
Proxy :: Proxy (Maybe BaselinePath))] ((OptionSet -> IO (String -> Result -> Result)) -> Ingredient)
-> (OptionSet -> IO (String -> Result -> Result)) -> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts -> do
Set String
baseline <- case OptionSet -> Maybe BaselinePath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
Maybe BaselinePath
Nothing -> Set String -> IO (Set String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set String
forall a. Set a
S.empty
Just (BaselinePath String
path) -> [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> (String -> [String]) -> String -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> Set String) -> IO String -> IO (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO String
readFile String
path IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
forall a. a -> IO a
evaluate (String -> IO String) -> ShowS -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. NFData a => a -> a
force)
Bool
hasGCStats <- IO Bool
getRTSStatsEnabled
let pretty :: Estimate -> String
pretty = if Bool
hasGCStats then Estimate -> String
prettyEstimateWithGC else Estimate -> String
prettyEstimate
(String -> Result -> Result) -> IO (String -> Result -> Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Result -> Result) -> IO (String -> Result -> Result))
-> (String -> Result -> Result) -> IO (String -> Result -> Result)
forall a b. (a -> b) -> a -> b
$ \String
name Result
r -> case String -> Maybe Response
forall a. Read a => String -> Maybe a
safeRead (Result -> String
resultDescription Result
r) of
Maybe Response
Nothing -> Result
r
Just (Response Estimate
est (FailIfSlower Double
ifSlow) (FailIfFaster Double
ifFast)) ->
(if Bool
isAcceptable then Result -> Result
forall a. a -> a
id else Result -> Result
forceFail)
Result
r { resultDescription :: String
resultDescription = Estimate -> String
pretty Estimate
est String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
formatSlowDown Int64
slowDown }
where
slowDown :: Int64
slowDown = Set String -> String -> Estimate -> Int64
compareVsBaseline Set String
baseline String
name Estimate
est
isAcceptable :: Bool
isAcceptable
= Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
slowDown Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ifSlow
Bool -> Bool -> Bool
&& Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
slowDown Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= -Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ifFast
compareVsBaseline :: S.Set TestName -> TestName -> Estimate -> Int64
compareVsBaseline :: Set String -> String -> Estimate -> Int64
compareVsBaseline Set String
baseline String
name (Estimate Measurement
m Word64
sigma) = case Maybe (Int64, Int64)
mOld of
Maybe (Int64, Int64)
Nothing -> Int64
0
Just (Int64
oldTime, Int64
oldDoubleSigma)
| Int64 -> Int64
forall a. Num a => a -> a
abs (Int64
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
oldTime) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sigma) Int64
oldDoubleSigma -> Int64
0
| Bool
otherwise -> Int64
100 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* (Int64
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
oldTime) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`quot` Int64
oldTime
where
time :: Int64
time = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Measurement -> Word64
measTime Measurement
m
mOld :: Maybe (Int64, Int64)
mOld = do
let prefix :: String
prefix = ShowS
encodeCsv String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
","
String
line <- String -> Set String -> Maybe String
forall a. Ord a => a -> Set a -> Maybe a
lookupGE String
prefix Set String
baseline
(String
timeCell, Char
',' : String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') (String -> (String, String))
-> Maybe String -> Maybe (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
line
let doubleSigmaCell :: String
doubleSigmaCell = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
rest
(,) (Int64 -> Int64 -> (Int64, Int64))
-> Maybe Int64 -> Maybe (Int64 -> (Int64, Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Int64
forall a. Read a => String -> Maybe a
safeRead String
timeCell Maybe (Int64 -> (Int64, Int64))
-> Maybe Int64 -> Maybe (Int64, Int64)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Int64
forall a. Read a => String -> Maybe a
safeRead String
doubleSigmaCell
formatSlowDown :: Int64 -> String
formatSlowDown :: Int64 -> String
formatSlowDown Int64
n = case Int64
n Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int64
0 of
Ordering
LT -> String -> Int64 -> String
forall r. PrintfType r => String -> r
printf String
", %2i%% faster than baseline" (-Int64
n)
Ordering
EQ -> String
""
Ordering
GT -> String -> Int64 -> String
forall r. PrintfType r => String -> r
printf String
", %2i%% slower than baseline" Int64
n
forceFail :: Result -> Result
forceFail :: Result -> Result
forceFail Result
r = Result
r { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestFailed, resultShortDescription :: String
resultShortDescription = String
"FAIL" }
#if !MIN_VERSION_containers(0,5,0)
lookupGE :: TestName -> S.Set TestName -> Maybe TestName
lookupGE x = fmap fst . S.minView . S.filter (x `isPrefixOf`)
#endif
modifyConsoleReporter :: [OptionDescription] -> (OptionSet -> IO (TestName -> Result -> Result)) -> Ingredient
modifyConsoleReporter :: [OptionDescription]
-> (OptionSet -> IO (String -> Result -> Result)) -> Ingredient
modifyConsoleReporter [OptionDescription]
desc' OptionSet -> IO (String -> Result -> Result)
iof = [OptionDescription]
-> (OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
TestReporter ([OptionDescription]
desc [OptionDescription] -> [OptionDescription] -> [OptionDescription]
forall a. [a] -> [a] -> [a]
++ [OptionDescription]
desc') ((OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient)
-> (OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts Benchmark
tree ->
let names :: IntMap String
names = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IM.fromDistinctAscList ([(Int, String)] -> IntMap String)
-> [(Int, String)] -> IntMap String
forall a b. (a -> b) -> a -> b
$ [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (OptionSet -> Benchmark -> [String]
testsNames OptionSet
opts Benchmark
tree)
modifySMap :: StatusMap -> IO StatusMap
modifySMap = (OptionSet -> IO (String -> Result -> Result)
iof OptionSet
opts IO (String -> Result -> Result)
-> ((String -> Result -> Result) -> IO StatusMap) -> IO StatusMap
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) (((String -> Result -> Result) -> IO StatusMap) -> IO StatusMap)
-> (StatusMap -> (String -> Result -> Result) -> IO StatusMap)
-> StatusMap
-> IO StatusMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> Result -> Result)
-> IntMap (String, TVar Status) -> IO StatusMap)
-> IntMap (String, TVar Status)
-> (String -> Result -> Result)
-> IO StatusMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Result -> Result)
-> IntMap (String, TVar Status) -> IO StatusMap
postprocessResult (IntMap (String, TVar Status)
-> (String -> Result -> Result) -> IO StatusMap)
-> (StatusMap -> IntMap (String, TVar Status))
-> StatusMap
-> (String -> Result -> Result)
-> IO StatusMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> TVar Status -> (String, TVar Status))
-> IntMap String -> StatusMap -> IntMap (String, TVar Status)
forall a b c. (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
IM.intersectionWith (,) IntMap String
names
in (StatusMap -> IO StatusMap
modifySMap (StatusMap -> IO StatusMap)
-> (StatusMap -> IO (Double -> IO Bool))
-> StatusMap
-> IO (Double -> IO Bool)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>) ((StatusMap -> IO (Double -> IO Bool))
-> StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool))
cb OptionSet
opts Benchmark
tree
where
TestReporter [OptionDescription]
desc OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool))
cb = Ingredient
consoleTestReporter
postprocessResult :: (TestName -> Result -> Result) -> IntMap (TestName, TVar Status) -> IO StatusMap
postprocessResult :: (String -> Result -> Result)
-> IntMap (String, TVar Status) -> IO StatusMap
postprocessResult String -> Result -> Result
f IntMap (String, TVar Status)
src = do
IntMap (String, TVar Status, TVar Status)
paired <- IntMap (String, TVar Status)
-> ((String, TVar Status) -> IO (String, TVar Status, TVar Status))
-> IO (IntMap (String, TVar Status, TVar Status))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM IntMap (String, TVar Status)
src (((String, TVar Status) -> IO (String, TVar Status, TVar Status))
-> IO (IntMap (String, TVar Status, TVar Status)))
-> ((String, TVar Status) -> IO (String, TVar Status, TVar Status))
-> IO (IntMap (String, TVar Status, TVar Status))
forall a b. (a -> b) -> a -> b
$ \(String
name, TVar Status
tv) -> (String
name, TVar Status
tv,) (TVar Status -> (String, TVar Status, TVar Status))
-> IO (TVar Status) -> IO (String, TVar Status, TVar Status)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Status -> IO (TVar Status)
forall a. a -> IO (TVar a)
newTVarIO Status
NotStarted
let doUpdate :: IO Bool
doUpdate = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
(Any Bool
anyUpdated, All Bool
allDone) <-
Ap STM (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap STM (Any, All) -> STM (Any, All))
-> Ap STM (Any, All) -> STM (Any, All)
forall a b. (a -> b) -> a -> b
$ (((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> IntMap (String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> IntMap (String, TVar Status, TVar Status)
-> ((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> Ap STM (Any, All)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> IntMap (String, TVar Status, TVar Status) -> Ap STM (Any, All)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap IntMap (String, TVar Status, TVar Status)
paired (((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> Ap STM (Any, All))
-> ((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> Ap STM (Any, All)
forall a b. (a -> b) -> a -> b
$ \(String
name, TVar Status
newTV, TVar Status
oldTV) -> STM (Any, All) -> Ap STM (Any, All)
forall (f :: * -> *) a. f a -> Ap f a
Ap (STM (Any, All) -> Ap STM (Any, All))
-> STM (Any, All) -> Ap STM (Any, All)
forall a b. (a -> b) -> a -> b
$ do
Status
old <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
oldTV
case Status
old of
Done{} -> (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
False, Bool -> All
All Bool
True)
Status
_ -> do
Status
new <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
newTV
case Status
new of
Done Result
res -> do
TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
oldTV (Result -> Status
Done (String -> Result -> Result
f String
name Result
res))
(Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, Bool -> All
All Bool
True)
Status
_ -> (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
False, Bool -> All
All Bool
False)
if Bool
anyUpdated Bool -> Bool -> Bool
|| Bool
allDone then Bool -> STM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
allDone else STM Bool
forall a. STM a
retry
adNauseam :: IO ()
adNauseam = IO Bool
doUpdate IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` IO ()
adNauseam)
ThreadId
_ <- IO () -> IO ThreadId
forkIO IO ()
adNauseam
StatusMap -> IO StatusMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StatusMap -> IO StatusMap) -> StatusMap -> IO StatusMap
forall a b. (a -> b) -> a -> b
$ ((String, TVar Status, TVar Status) -> TVar Status)
-> IntMap (String, TVar Status, TVar Status) -> StatusMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
_, TVar Status
_, TVar Status
a) -> TVar Status
a) IntMap (String, TVar Status, TVar Status)
paired