{-# 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 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

-- | 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 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

-- | 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 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

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

-- $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!