{-# 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 MatchType
matchKind [String]
args =
case MatchType
matchKind of
MatchType
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
$ \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
MatchType
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 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 String
"compile :: " (String -> Either String (String -> Bool))
-> String -> Either String (String -> Bool)
forall a b. (a -> b) -> a -> b
$
String
errMsg
Right [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
$ \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
MatchType
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
$ \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
MatchType
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
$ \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 [String]
benches 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 String
"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 Config
defCfg [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 Mode
wat [Benchmark]
bs =
case Mode
wat of
Mode
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
Mode
Version -> String -> IO ()
putStrLn String
versionInfo
RunIters Config
cfg Int64
iters MatchType
matchType [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 Config
cfg MatchType
matchType [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 (String
"Name",String
"Mean",String
"MeanLB",String
"MeanUB",String
"Stddev",String
"StddevLB",
String
"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 String
"" [Benchmark]
bs
parseError :: String -> IO a
parseError :: String -> IO a
parseError String
msg = do
Any
_ <- String -> String -> IO Any
forall r. CritHPrintfType r => String -> r
printError String
"Error: %s\n" String
msg
Any
_ <- String -> String -> IO Any
forall r. CritHPrintfType r => String -> r
printError String
"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 Int
64)