{-# LANGUAGE Trustworthy #-}
module Criterion.Main
(
Benchmarkable
, Benchmark
, env
, envWithCleanup
, perBatchEnv
, perBatchEnvWithCleanup
, perRunEnv
, perRunEnvWithCleanup
, toBenchmarkable
, bench
, bgroup
, nf
, whnf
, nfIO
, whnfIO
, nfAppIO
, whnfAppIO
, defaultMain
, defaultMainWith
, defaultConfig
, makeMatcher
, runMode
) where
import Control.Monad (unless)
import Control.Monad.Trans (liftIO)
import Criterion.IO.Printf (printError, writeCsv)
import Criterion.Internal (runAndAnalyse, runFixedIters)
import Criterion.Main.Options (MatchType(..), Mode(..), defaultConfig, describe,
versionInfo)
import Criterion.Measurement (initializeTime)
import Criterion.Monad (withConfig)
import Criterion.Types
import Data.Char (toLower)
import Data.List (isInfixOf, isPrefixOf, sort, stripPrefix)
import Data.Maybe (fromMaybe)
import Options.Applicative (execParser)
import System.Environment (getProgName)
import System.Exit (ExitCode(..), exitWith)
import System.FilePath.Glob
defaultMain :: [Benchmark] -> IO ()
defaultMain :: [Benchmark] -> IO ()
defaultMain = Config -> [Benchmark] -> IO ()
defaultMainWith Config
defaultConfig
makeMatcher :: MatchType
-> [String]
-> Either String (String -> Bool)
makeMatcher :: MatchType -> [String] -> Either String (String -> Bool)
makeMatcher matchKind :: MatchType
matchKind args :: [String]
args =
case MatchType
matchKind of
Prefix -> (String -> Bool) -> Either String (String -> Bool)
forall a b. b -> Either a b
Right ((String -> Bool) -> Either String (String -> Bool))
-> (String -> Bool) -> Either String (String -> Bool)
forall a b. (a -> b) -> a -> b
$ \b :: String
b -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
b) [String]
args
Glob ->
let compOptions :: CompOptions
compOptions = CompOptions
compDefault { errorRecovery :: Bool
errorRecovery = Bool
False }
in case (String -> Either String Pattern)
-> [String] -> Either String [Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CompOptions -> String -> Either String Pattern
tryCompileWith CompOptions
compOptions) [String]
args of
Left errMsg :: String
errMsg -> String -> Either String (String -> Bool)
forall a b. a -> Either a b
Left (String -> Either String (String -> Bool))
-> (String -> String) -> String -> Either String (String -> Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
errMsg (Maybe String -> String)
-> (String -> Maybe String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "compile :: " (String -> Either String (String -> Bool))
-> String -> Either String (String -> Bool)
forall a b. (a -> b) -> a -> b
$
String
errMsg
Right ps :: [Pattern]
ps -> (String -> Bool) -> Either String (String -> Bool)
forall a b. b -> Either a b
Right ((String -> Bool) -> Either String (String -> Bool))
-> (String -> Bool) -> Either String (String -> Bool)
forall a b. (a -> b) -> a -> b
$ \b :: String
b -> [Pattern] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern]
ps Bool -> Bool -> Bool
|| (Pattern -> Bool) -> [Pattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Pattern -> String -> Bool
`match` String
b) [Pattern]
ps
Pattern -> (String -> Bool) -> Either String (String -> Bool)
forall a b. b -> Either a b
Right ((String -> Bool) -> Either String (String -> Bool))
-> (String -> Bool) -> Either String (String -> Bool)
forall a b. (a -> b) -> a -> b
$ \b :: String
b -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
b) [String]
args
IPattern -> (String -> Bool) -> Either String (String -> Bool)
forall a b. b -> Either a b
Right ((String -> Bool) -> Either String (String -> Bool))
-> (String -> Bool) -> Either String (String -> Bool)
forall a b. (a -> b) -> a -> b
$ \b :: String
b -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
b) ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) [String]
args)
selectBenches :: MatchType -> [String] -> Benchmark -> IO (String -> Bool)
selectBenches :: MatchType -> [String] -> Benchmark -> IO (String -> Bool)
selectBenches matchType :: MatchType
matchType benches :: [String]
benches bsgroup :: Benchmark
bsgroup = do
String -> Bool
toRun <- (String -> IO (String -> Bool))
-> ((String -> Bool) -> IO (String -> Bool))
-> Either String (String -> Bool)
-> IO (String -> Bool)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (String -> Bool)
forall a. String -> IO a
parseError (String -> Bool) -> IO (String -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (String -> Bool) -> IO (String -> Bool))
-> ([String] -> Either String (String -> Bool))
-> [String]
-> IO (String -> Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchType -> [String] -> Either String (String -> Bool)
makeMatcher MatchType
matchType ([String] -> IO (String -> Bool))
-> [String] -> IO (String -> Bool)
forall a b. (a -> b) -> a -> b
$ [String]
benches
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
benches Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
toRun (Benchmark -> [String]
benchNames Benchmark
bsgroup)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. String -> IO a
parseError "none of the specified names matches a benchmark"
(String -> Bool) -> IO (String -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return String -> Bool
toRun
defaultMainWith :: Config
-> [Benchmark]
-> IO ()
defaultMainWith :: Config -> [Benchmark] -> IO ()
defaultMainWith defCfg :: Config
defCfg bs :: [Benchmark]
bs = do
Mode
wat <- ParserInfo Mode -> IO Mode
forall a. ParserInfo a -> IO a
execParser (Config -> ParserInfo Mode
describe Config
defCfg)
Mode -> [Benchmark] -> IO ()
runMode Mode
wat [Benchmark]
bs
runMode :: Mode -> [Benchmark] -> IO ()
runMode :: Mode -> [Benchmark] -> IO ()
runMode wat :: Mode
wat bs :: [Benchmark]
bs =
case Mode
wat of
List -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ([String] -> IO ())
-> ([Benchmark] -> [String]) -> [Benchmark] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([Benchmark] -> [String]) -> [Benchmark] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Benchmark -> [String]) -> [Benchmark] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Benchmark -> [String]
benchNames ([Benchmark] -> IO ()) -> [Benchmark] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Benchmark]
bs
Version -> String -> IO ()
putStrLn String
versionInfo
RunIters cfg :: Config
cfg iters :: Int64
iters matchType :: MatchType
matchType benches :: [String]
benches -> do
String -> Bool
shouldRun <- MatchType -> [String] -> Benchmark -> IO (String -> Bool)
selectBenches MatchType
matchType [String]
benches Benchmark
bsgroup
Config -> Criterion () -> IO ()
forall a. Config -> Criterion a -> IO a
withConfig Config
cfg (Criterion () -> IO ()) -> Criterion () -> IO ()
forall a b. (a -> b) -> a -> b
$
Int64 -> (String -> Bool) -> Benchmark -> Criterion ()
runFixedIters Int64
iters String -> Bool
shouldRun Benchmark
bsgroup
Run cfg :: Config
cfg matchType :: MatchType
matchType benches :: [String]
benches -> do
String -> Bool
shouldRun <- MatchType -> [String] -> Benchmark -> IO (String -> Bool)
selectBenches MatchType
matchType [String]
benches Benchmark
bsgroup
Config -> Criterion () -> IO ()
forall a. Config -> Criterion a -> IO a
withConfig Config
cfg (Criterion () -> IO ()) -> Criterion () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(String, String, String, String, String, String, String)
-> Criterion ()
forall a. ToRecord a => a -> Criterion ()
writeCsv ("Name","Mean","MeanLB","MeanUB","Stddev","StddevLB",
"StddevUB")
IO () -> Criterion ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
initializeTime
(String -> Bool) -> Benchmark -> Criterion ()
runAndAnalyse String -> Bool
shouldRun Benchmark
bsgroup
where bsgroup :: Benchmark
bsgroup = String -> [Benchmark] -> Benchmark
BenchGroup "" [Benchmark]
bs
parseError :: String -> IO a
parseError :: String -> IO a
parseError msg :: String
msg = do
Any
_ <- String -> String -> IO Any
forall r. CritHPrintfType r => String -> r
printError "Error: %s\n" String
msg
Any
_ <- String -> String -> IO Any
forall r. CritHPrintfType r => String -> r
printError "Run \"%s --help\" for usage information\n" (String -> IO Any) -> IO String -> IO Any
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
getProgName
ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 64)