{-# LANGUAGE Trustworthy #-}

-- |
-- Module      : Criterion.Main
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Wrappers for compiling and running benchmarks quickly and easily.
-- See 'defaultMain' below for an example.
--
-- All of the 'IO'-returning functions in this module initialize the timer
-- before measuring time (refer to the documentation for 'initializeTime'
-- for more details).

module Criterion.Main
    (
    -- * How to write benchmarks
    -- $bench

    -- ** Benchmarking IO actions
    -- $io

    -- ** Benchmarking pure code
    -- $pure

    -- ** Fully evaluating a result
    -- $rnf

    -- * Types
      Benchmarkable
    , Benchmark
    -- * Creating a benchmark suite
    , env
    , envWithCleanup
    , perBatchEnv
    , perBatchEnvWithCleanup
    , perRunEnv
    , perRunEnvWithCleanup
    , toBenchmarkable
    , bench
    , bgroup
    -- ** Running a benchmark
    , nf
    , whnf
    , nfIO
    , whnfIO
    , nfAppIO
    , whnfAppIO
    -- * Turning a suite of benchmarks into a program
    , defaultMain
    , defaultMainWith
    , defaultConfig
    -- * Other useful code
    , 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

-- | An entry point that can be used as a @main@ function.
--
-- > import Criterion.Main
-- >
-- > fib :: Int -> Int
-- > fib 0 = 0
-- > fib 1 = 1
-- > fib n = fib (n-1) + fib (n-2)
-- >
-- > main = defaultMain [
-- >        bgroup "fib" [ bench "10" $ whnf fib 10
-- >                     , bench "35" $ whnf fib 35
-- >                     , bench "37" $ whnf fib 37
-- >                     ]
-- >                    ]
defaultMain :: [Benchmark] -> IO ()
defaultMain :: [Benchmark] -> IO ()
defaultMain = Config -> [Benchmark] -> IO ()
defaultMainWith Config
defaultConfig

-- | Create a function that can tell if a name given on the command
-- line matches a benchmark.
makeMatcher :: MatchType
            -> [String]
            -- ^ Command line arguments.
            -> 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

-- | An entry point that can be used as a @main@ function, with
-- configurable defaults.
--
-- Example:
--
-- > import Criterion.Main.Options
-- > import Criterion.Main
-- >
-- > myConfig = defaultConfig {
-- >               -- Resample 10 times for bootstrapping
-- >               resamples = 10
-- >            }
-- >
-- > main = defaultMainWith myConfig [
-- >          bench "fib 30" $ whnf fib 30
-- >        ]
--
-- If you save the above example as @\"Fib.hs\"@, you should be able
-- to compile it as follows:
--
-- > ghc -O --make Fib
--
-- Run @\"Fib --help\"@ on the command line to get a list of command
-- line options.
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

-- | Run a set of 'Benchmark's with the given 'Mode'.
--
-- This can be useful if you have a 'Mode' from some other source (e.g. from a
-- one in your benchmark driver's command-line parser).
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

-- | Display an error message from a command line parsing failure, and
-- exit.
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)

-- $bench
--
-- The 'Benchmarkable' type is a container for code that can be
-- benchmarked.  The value inside must run a benchmark the given
-- number of times.  We are most interested in benchmarking two
-- things:
--
-- * 'IO' actions.  Most 'IO' actions can be benchmarked directly.
--
-- * Pure functions.  GHC optimises aggressively when compiling with
--   @-O@, so it is easy to write innocent-looking benchmark code that
--   doesn't measure the performance of a pure function at all.  We
--   work around this by benchmarking both a function and its final
--   argument together.

-- $io
--
-- Most 'IO' actions can be benchmarked easily using one of the following
-- two functions:
--
-- @
-- 'nfIO'   :: 'NFData' a => 'IO' a -> 'Benchmarkable'
-- 'whnfIO' ::               'IO' a -> 'Benchmarkable'
-- @
--
-- In certain corner cases, you may find it useful to use the following
-- variants, which take the input as a separate argument:
--
-- @
-- 'nfAppIO'   :: 'NFData' b => (a -> 'IO' b) -> a -> 'Benchmarkable'
-- 'whnfAppIO' ::               (a -> 'IO' b) -> a -> 'Benchmarkable'
-- @
--
-- This is useful when the bulk of the work performed by the function is
-- not bound by IO, but rather by pure computations that may optimize away if
-- the argument is known statically, as in 'nfIO'/'whnfIO'.

-- $pure
--
-- Because GHC optimises aggressively when compiling with @-O@, it is
-- potentially easy to write innocent-looking benchmark code that will
-- only be evaluated once, for which all but the first iteration of
-- the timing loop will be timing the cost of doing nothing.
--
-- To work around this, we provide two functions for benchmarking pure
-- code.
--
-- The first will cause results to be fully evaluated to normal form
-- (NF):
--
-- @
-- 'nf' :: 'NFData' b => (a -> b) -> a -> 'Benchmarkable'
-- @
--
-- The second will cause results to be evaluated to weak head normal
-- form (the Haskell default):
--
-- @
-- 'whnf' :: (a -> b) -> a -> 'Benchmarkable'
-- @
--
-- As both of these types suggest, when you want to benchmark a
-- function, you must supply two values:
--
-- * The first element is the function, saturated with all but its
--   last argument.
--
-- * The second element is the last argument to the function.
--
-- Here is an example that makes the use of these functions clearer.
-- Suppose we want to benchmark the following function:
--
-- @
-- firstN :: Int -> [Int]
-- firstN k = take k [(0::Int)..]
-- @
--
-- So in the easy case, we construct a benchmark as follows:
--
-- @
-- 'nf' firstN 1000
-- @

-- $rnf
--
-- The 'whnf' harness for evaluating a pure function only evaluates
-- the result to weak head normal form (WHNF).  If you need the result
-- evaluated all the way to normal form, use the 'nf' function to
-- force its complete evaluation.
--
-- Using the @firstN@ example from earlier, to naive eyes it might
-- /appear/ that the following code ought to benchmark the production
-- of the first 1000 list elements:
--
-- @
-- 'whnf' firstN 1000
-- @
--
-- Since we are using 'whnf', in this case the result will only be
-- forced until it reaches WHNF, so what this would /actually/
-- benchmark is merely how long it takes to produce the first list
-- element!