packages feed

criterion 0.6.2.1 → 0.8.0.0

raw patch · 14 files changed

+552/−339 lines, 14 filesdep +Globdep +binarydep +ghc-primdep ~deepseqdep ~statisticsPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, binary, ghc-prim

Dependency ranges changed: deepseq, statistics

API changes (from Hackage documentation)

- Criterion.IO: class CritHPrintfType a
- Criterion.IO: instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r)
- Criterion.IO: instance CritHPrintfType (Criterion a)
- Criterion.IO: instance CritHPrintfType (IO a)
- Criterion.IO: note :: CritHPrintfType r => String -> r
- Criterion.IO: printError :: CritHPrintfType r => String -> r
- Criterion.IO: prolix :: CritHPrintfType r => String -> r
- Criterion.IO: summary :: String -> Criterion ()
+ Criterion: bcompare :: [Benchmark] -> Benchmark
+ Criterion.Analysis.Types: instance Binary OutlierEffect
+ Criterion.Analysis.Types: instance Binary OutlierVariance
+ Criterion.Analysis.Types: instance Binary Outliers
+ Criterion.Analysis.Types: instance Binary SampleAnalysis
+ Criterion.Analysis.Types: instance Constructor C1_0OutlierEffect
+ Criterion.Analysis.Types: instance Constructor C1_0OutlierVariance
+ Criterion.Analysis.Types: instance Constructor C1_0Outliers
+ Criterion.Analysis.Types: instance Constructor C1_0SampleAnalysis
+ Criterion.Analysis.Types: instance Constructor C1_1OutlierEffect
+ Criterion.Analysis.Types: instance Constructor C1_2OutlierEffect
+ Criterion.Analysis.Types: instance Constructor C1_3OutlierEffect
+ Criterion.Analysis.Types: instance Datatype D1OutlierEffect
+ Criterion.Analysis.Types: instance Datatype D1OutlierVariance
+ Criterion.Analysis.Types: instance Datatype D1Outliers
+ Criterion.Analysis.Types: instance Datatype D1SampleAnalysis
+ Criterion.Analysis.Types: instance Generic OutlierEffect
+ Criterion.Analysis.Types: instance Generic OutlierVariance
+ Criterion.Analysis.Types: instance Generic Outliers
+ Criterion.Analysis.Types: instance Generic SampleAnalysis
+ Criterion.Analysis.Types: instance Read SampleAnalysis
+ Criterion.Analysis.Types: instance Selector S1_0_0OutlierVariance
+ Criterion.Analysis.Types: instance Selector S1_0_0Outliers
+ Criterion.Analysis.Types: instance Selector S1_0_0SampleAnalysis
+ Criterion.Analysis.Types: instance Selector S1_0_1OutlierVariance
+ Criterion.Analysis.Types: instance Selector S1_0_1Outliers
+ Criterion.Analysis.Types: instance Selector S1_0_1SampleAnalysis
+ Criterion.Analysis.Types: instance Selector S1_0_2OutlierVariance
+ Criterion.Analysis.Types: instance Selector S1_0_2Outliers
+ Criterion.Analysis.Types: instance Selector S1_0_2SampleAnalysis
+ Criterion.Analysis.Types: instance Selector S1_0_3Outliers
+ Criterion.Analysis.Types: instance Selector S1_0_4Outliers
+ Criterion.Config: Glob :: MatchType
+ Criterion.Config: Prefix :: MatchType
+ Criterion.Config: cfgMatchType :: Config -> Last MatchType
+ Criterion.Config: cfgResults :: Config -> Last FilePath
+ Criterion.Config: data MatchType
+ Criterion.Config: instance Bounded MatchType
+ Criterion.Config: instance Constructor C1_0Config
+ Criterion.Config: instance Constructor C1_0MatchType
+ Criterion.Config: instance Constructor C1_0PrintExit
+ Criterion.Config: instance Constructor C1_0Verbosity
+ Criterion.Config: instance Constructor C1_1MatchType
+ Criterion.Config: instance Constructor C1_1PrintExit
+ Criterion.Config: instance Constructor C1_1Verbosity
+ Criterion.Config: instance Constructor C1_2PrintExit
+ Criterion.Config: instance Constructor C1_2Verbosity
+ Criterion.Config: instance Constructor C1_3PrintExit
+ Criterion.Config: instance Data MatchType
+ Criterion.Config: instance Data Verbosity
+ Criterion.Config: instance Datatype D1Config
+ Criterion.Config: instance Datatype D1MatchType
+ Criterion.Config: instance Datatype D1PrintExit
+ Criterion.Config: instance Datatype D1Verbosity
+ Criterion.Config: instance Enum MatchType
+ Criterion.Config: instance Eq MatchType
+ Criterion.Config: instance Generic Config
+ Criterion.Config: instance Generic MatchType
+ Criterion.Config: instance Generic PrintExit
+ Criterion.Config: instance Generic Verbosity
+ Criterion.Config: instance Ord MatchType
+ Criterion.Config: instance Read MatchType
+ Criterion.Config: instance Selector S1_0_0Config
+ Criterion.Config: instance Selector S1_0_10Config
+ Criterion.Config: instance Selector S1_0_11Config
+ Criterion.Config: instance Selector S1_0_12Config
+ Criterion.Config: instance Selector S1_0_13Config
+ Criterion.Config: instance Selector S1_0_14Config
+ Criterion.Config: instance Selector S1_0_1Config
+ Criterion.Config: instance Selector S1_0_2Config
+ Criterion.Config: instance Selector S1_0_3Config
+ Criterion.Config: instance Selector S1_0_4Config
+ Criterion.Config: instance Selector S1_0_5Config
+ Criterion.Config: instance Selector S1_0_6Config
+ Criterion.Config: instance Selector S1_0_7Config
+ Criterion.Config: instance Selector S1_0_8Config
+ Criterion.Config: instance Selector S1_0_9Config
+ Criterion.Config: instance Show MatchType
+ Criterion.Config: instance Typeable MatchType
+ Criterion.Environment: instance Constructor C1_0Environment
+ Criterion.Environment: instance Data Environment
+ Criterion.Environment: instance Datatype D1Environment
+ Criterion.Environment: instance Generic Environment
+ Criterion.Environment: instance Selector S1_0_0Environment
+ Criterion.Environment: instance Selector S1_0_1Environment
+ Criterion.IO: hGetResults :: Handle -> IO (Either String ResultForest)
+ Criterion.IO: hPutResults :: Handle -> ResultForest -> IO ()
+ Criterion.IO: header :: ByteString
+ Criterion.IO: readResults :: FilePath -> IO (Either String ResultForest)
+ Criterion.IO: writeResults :: FilePath -> ResultForest -> IO ()
+ Criterion.IO.Printf: class CritHPrintfType a
+ Criterion.IO.Printf: instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r)
+ Criterion.IO.Printf: instance CritHPrintfType (Criterion a)
+ Criterion.IO.Printf: instance CritHPrintfType (IO a)
+ Criterion.IO.Printf: note :: CritHPrintfType r => String -> r
+ Criterion.IO.Printf: printError :: CritHPrintfType r => String -> r
+ Criterion.IO.Printf: prolix :: CritHPrintfType r => String -> r
+ Criterion.IO.Printf: summary :: String -> Criterion ()
+ Criterion.Main: makeMatcher :: MatchType -> [String] -> Either String (String -> Bool)
+ Criterion.Report: instance Constructor C1_0Report
+ Criterion.Report: instance Constructor C1_0TemplateException
+ Criterion.Report: instance Datatype D1Report
+ Criterion.Report: instance Datatype D1TemplateException
+ Criterion.Report: instance Generic Report
+ Criterion.Report: instance Generic TemplateException
+ Criterion.Report: instance Read Report
+ Criterion.Report: instance Read TemplateException
+ Criterion.Report: instance Selector S1_0_0Report
+ Criterion.Report: instance Selector S1_0_1Report
+ Criterion.Report: instance Selector S1_0_2Report
+ Criterion.Report: instance Selector S1_0_3Report
+ Criterion.Report: instance Selector S1_0_4Report
+ Criterion.Types: Compare :: !Int -> ResultForest -> ResultTree
+ Criterion.Types: Result :: String -> Sample -> SampleAnalysis -> Outliers -> Result
+ Criterion.Types: Single :: Result -> ResultTree
+ Criterion.Types: data Result
+ Criterion.Types: data ResultTree
+ Criterion.Types: description :: Result -> String
+ Criterion.Types: instance Binary Result
+ Criterion.Types: instance Binary ResultTree
+ Criterion.Types: instance Constructor C1_0Result
+ Criterion.Types: instance Constructor C1_0ResultTree
+ Criterion.Types: instance Constructor C1_1ResultTree
+ Criterion.Types: instance Data Result
+ Criterion.Types: instance Data ResultTree
+ Criterion.Types: instance Datatype D1Result
+ Criterion.Types: instance Datatype D1ResultTree
+ Criterion.Types: instance Eq Result
+ Criterion.Types: instance Eq ResultTree
+ Criterion.Types: instance Generic Result
+ Criterion.Types: instance Generic ResultTree
+ Criterion.Types: instance Read Result
+ Criterion.Types: instance Read ResultTree
+ Criterion.Types: instance Selector S1_0_0Result
+ Criterion.Types: instance Selector S1_0_1Result
+ Criterion.Types: instance Selector S1_0_2Result
+ Criterion.Types: instance Selector S1_0_3Result
+ Criterion.Types: instance Show Result
+ Criterion.Types: instance Show ResultTree
+ Criterion.Types: instance Typeable Result
+ Criterion.Types: instance Typeable ResultTree
+ Criterion.Types: outliers :: Result -> Outliers
+ Criterion.Types: sample :: Result -> Sample
+ Criterion.Types: sampleAnalysis :: Result -> SampleAnalysis
+ Criterion.Types: type ResultForest = [ResultTree]
- Criterion.Config: Config :: Last String -> Last Double -> Last Bool -> PrintExit -> Last Int -> Last FilePath -> Last Int -> Last FilePath -> Last FilePath -> Last FilePath -> Last Verbosity -> Last FilePath -> Last Bool -> Config
+ Criterion.Config: Config :: Last String -> Last Double -> Last MatchType -> Last Bool -> PrintExit -> Last Int -> Last FilePath -> Last FilePath -> Last Int -> Last FilePath -> Last FilePath -> Last FilePath -> Last Verbosity -> Last FilePath -> Last Bool -> Config

Files

Criterion.hs view
@@ -20,232 +20,12 @@     , nfIO     , whnfIO     , bench+    , bcompare     , bgroup     , runBenchmark     , runAndAnalyse     , runNotAnalyse     ) where -import Control.Monad (replicateM_, when, mplus)-import Control.Monad.Trans (liftIO)-import Criterion.Analysis (Outliers(..), OutlierEffect(..), OutlierVariance(..),-                           SampleAnalysis(..), analyseSample,-                           classifyOutliers, noteOutliers)-import Criterion.Config (Config(..), Verbosity(..), fromLJ)-import Criterion.Environment (Environment(..))-import Criterion.IO (note, prolix, summary)-import Criterion.Measurement (getTime, runForAtLeast, secs, time_)-import Criterion.Monad (Criterion, getConfig, getConfigItem)-import Criterion.Report (Report(..), report)-import Criterion.Types (Benchmarkable(..), Benchmark(..), Pure,-                        bench, bgroup, nf, nfIO, whnf, whnfIO)-import qualified Data.Vector.Unboxed as U-import Data.Monoid (getLast)-import Statistics.Resampling.Bootstrap (Estimate(..))-import Statistics.Types (Sample)-import System.Mem (performGC)-import Text.Printf (printf)---- | Run a single benchmark, and return timings measured when--- executing it.-runBenchmark :: Benchmarkable b => Environment -> b -> Criterion Sample-runBenchmark env b = do-  _ <- liftIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime)-  let minTime = envClockResolution env * 1000-  (testTime, testIters, _) <- liftIO $ runForAtLeast (min minTime 0.1) 1 (run b)-  _ <- prolix "ran %d iterations in %s\n" testIters (secs testTime)-  cfg <- getConfig-  let newIters    = ceiling $ minTime * testItersD / testTime-      sampleCount = fromLJ cfgSamples cfg-      newItersD   = fromIntegral newIters-      testItersD  = fromIntegral testIters-      estTime     = (fromIntegral sampleCount * newItersD *-                     testTime / testItersD)-  when (fromLJ cfgVerbosity cfg > Normal || estTime > 5) $-    note "collecting %d samples, %d iterations each, in estimated %s\n"-       sampleCount newIters (secs estTime)-  -- Run the GC to make sure garabage created by previous benchmarks-  -- don't affect this benchmark.-  liftIO performGC-  times <- liftIO . fmap (U.map ((/ newItersD) . subtract (envClockCost env))) .-           U.replicateM sampleCount $ do-             when (fromLJ cfgPerformGC cfg) $ performGC-             time_ (run b newIters)-  return times---- | Run a single benchmark and analyse its performance.-runAndAnalyseOne :: Benchmarkable b => Environment -> String -> b-                 -> Criterion (Sample,SampleAnalysis,Outliers)-runAndAnalyseOne env _desc b = do-  times <- runBenchmark env b-  ci <- getConfigItem $ fromLJ cfgConfInterval-  numResamples <- getConfigItem $ fromLJ cfgResamples-  _ <- prolix "analysing with %d resamples\n" numResamples-  an@SampleAnalysis{..} <- liftIO $ analyseSample ci times numResamples-  let OutlierVariance{..} = anOutlierVar-  let wibble = case ovEffect of-                 Unaffected -> "unaffected" :: String-                 Slight -> "slightly inflated"-                 Moderate -> "moderately inflated"-                 Severe -> "severely inflated"-  bs "mean" anMean-  summary ","-  bs "std dev" anStdDev-  summary "\n"-  vrb <- getConfigItem $ fromLJ cfgVerbosity-  let out = classifyOutliers times-  when (vrb == Verbose || (ovEffect > Unaffected && vrb > Quiet)) $ do-    noteOutliers out-    _ <- note "variance introduced by outliers: %.3f%%\n" (ovFraction * 100)-    _ <- note "variance is %s by outliers\n" wibble-    return ()-  return (times,an,out)-  where bs :: String -> Estimate -> Criterion ()-        bs d e = do _ <- note "%s: %s, lb %s, ub %s, ci %.3f\n" d-                      (secs $ estPoint e)-                      (secs $ estLowerBound e) (secs $ estUpperBound e)-                      (estConfidenceLevel e)-                    summary $ printf "%g,%g,%g"-                      (estPoint e)-                      (estLowerBound e) (estUpperBound e)---plotAll :: [Result] -> Criterion ()-plotAll descTimes = do-  report (zipWith (\n (Result d t a o) -> Report n d t a o) [0..] descTimes)--data Result = Result { description    :: String-                     , _sample        :: Sample-                     , sampleAnalysis :: SampleAnalysis-                     , _outliers      :: Outliers-                     }--type ResultForest = [ResultTree]-data ResultTree = Single Result | Compare ResultForest---- | Run, and analyse, one or more benchmarks.-runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses-                                  -- whether to run a benchmark by its-                                  -- name.-              -> Environment-              -> Benchmark-              -> Criterion ()-runAndAnalyse p env bs' = do-  rts <- go "" bs'--  mbCompareFile <- getConfigItem $ getLast . cfgCompareFile-  case mbCompareFile of-    Nothing -> return ()-    Just compareFile -> do-      liftIO $ writeFile compareFile $ resultForestToCSV rts--  let rs = flatten rts-  plotAll rs-  junit rs--  where go :: String -> Benchmark -> Criterion ResultForest-        go pfx (Benchmark desc b)-            | p desc'   = do _ <- note "\nbenchmarking %s\n" desc'-                             summary (show desc' ++ ",") -- String will be quoted-                             (x,an,out) <- runAndAnalyseOne env desc' b-                             let result = Result desc' x an out-                             return [Single result]-            | otherwise = return []-            where desc' = prefix pfx desc-        go pfx (BenchGroup desc bs) =-            concat `fmap` mapM (go (prefix pfx desc)) bs-        go pfx (BenchCompare bs) = ((:[]) . Compare . concat) `fmap` mapM (go pfx) bs--runNotAnalyse :: (String -> Bool) -- ^ A predicate that chooses-                                  -- whether to run a benchmark by its-                                  -- name.-              -> Benchmark-              -> Criterion ()-runNotAnalyse p bs' = goQuickly "" bs'-  where goQuickly :: String -> Benchmark -> Criterion ()-        goQuickly pfx (Benchmark desc b)-            | p desc'   = do _ <- note "benchmarking %s\n" desc'-                             runOne b-            | otherwise = return ()-            where desc' = prefix pfx desc-        goQuickly pfx (BenchGroup desc bs) =-            mapM_ (goQuickly (prefix pfx desc)) bs-        goQuickly pfx (BenchCompare bs) = mapM_ (goQuickly pfx) bs--        runOne b = do-            samples <- getConfigItem $ fromLJ cfgSamples-            liftIO $ run b samples--prefix :: String -> String -> String-prefix ""  desc = desc-prefix pfx desc = pfx ++ '/' : desc--flatten :: ResultForest -> [Result]-flatten [] = []-flatten (Single r    : rs) = r : flatten rs-flatten (Compare crs : rs) = flatten crs ++ flatten rs--resultForestToCSV :: ResultForest -> String-resultForestToCSV = unlines-                  . ("Reference,Name,% faster than reference" :)-                  . map (\(ref, n, p) -> printf "%s,%s,%.0f" ref n p)-                  . top-        where-          top :: ResultForest -> [(String, String, Double)]-          top [] = []-          top (Single _     : rts) = top rts-          top (Compare rts' : rts) = cmpRT rts' ++ top rts--          cmpRT :: ResultForest -> [(String, String, Double)]-          cmpRT [] = []-          cmpRT (Single r     : rts) = cmpWith r rts-          cmpRT (Compare rts' : rts) = case getReference rts' of-                                         Nothing -> cmpRT rts-                                         Just r  -> cmpRT rts' ++ cmpWith r rts--          cmpWith :: Result -> ResultForest -> [(String, String, Double)]-          cmpWith _   [] = []-          cmpWith ref (Single r     : rts) = cmp ref r : cmpWith ref rts-          cmpWith ref (Compare rts' : rts) = cmpRT rts'       ++-                                             cmpWith ref rts' ++-                                             cmpWith ref rts--          getReference :: ResultForest -> Maybe Result-          getReference []                   = Nothing-          getReference (Single r     : _)   = Just r-          getReference (Compare rts' : rts) = getReference rts' `mplus`-                                              getReference rts--cmp :: Result -> Result -> (String, String, Double)-cmp ref r = (description ref, description r, percentFaster)-    where-      percentFaster = (meanRef - meanR) / meanRef * 100--      meanRef = mean ref-      meanR   = mean r--      mean = estPoint . anMean . sampleAnalysis---- | Write summary JUnit file (if applicable)-junit :: [Result] -> Criterion ()-junit rs-  = do junitOpt <- getConfigItem (getLast . cfgJUnitFile)-       case junitOpt of-         Just fn -> liftIO $ writeFile fn msg-         Nothing -> return ()-  where-    msg = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++-          printf "<testsuite name=\"Criterion benchmarks\" tests=\"%d\">\n"-          (length rs) ++-          concatMap single rs ++-          "</testsuite>\n"-    single r = printf "  <testcase name=\"%s\" time=\"%f\" />\n"-               (attrEsc $ description r) (estPoint $ anMean $ sampleAnalysis r)-    attrEsc = concatMap esc-      where-        esc '\'' = "&apos;"-        esc '"'  = "&quot;"-        esc '<'  = "&lt;"-        esc '>'  = "&gt;"-        esc '&'  = "&amp;"-        esc c    = [c]+import Criterion.Internal+import Criterion.Types
Criterion/Analysis.hs view
@@ -27,7 +27,7 @@  import Control.Monad (when) import Criterion.Analysis.Types-import Criterion.IO (note)+import Criterion.IO.Printf (note) import Criterion.Measurement (secs) import Criterion.Monad (Criterion) import Data.Int (Int64)
Criterion/Analysis/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings,+    RecordWildCards #-} -- | -- Module      : Criterion.Analysis.Types -- Copyright   : (c) 2011 Bryan O'Sullivan@@ -19,10 +20,11 @@     ) where  import Control.DeepSeq (NFData(rnf))-import Data.Data (Data)+import Data.Binary (Binary)+import Data.Data (Data, Typeable) import Data.Int (Int64) import Data.Monoid (Monoid(..))-import Data.Typeable (Typeable)+import GHC.Generics (Generic) import qualified Statistics.Resampling.Bootstrap as B  -- | Outliers from sample data, calculated using the boxplot@@ -38,8 +40,9 @@     -- ^ Between 1.5 and 3 times the IQR above the third quartile.     , highSevere  :: {-# UNPACK #-} !Int64     -- ^ More than 3 times the IQR above the third quartile.-    } deriving (Eq, Read, Show, Typeable, Data)+    } deriving (Eq, Read, Show, Typeable, Data, Generic) +instance Binary Outliers instance NFData Outliers  -- | A description of the extent to which outliers in the sample data@@ -49,8 +52,9 @@                    | Moderate   -- ^ Between 10% and 50%.                    | Severe     -- ^ Above 50% (i.e. measurements                                 -- are useless).-                     deriving (Eq, Ord, Read, Show, Typeable, Data)+                     deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +instance Binary OutlierEffect instance NFData OutlierEffect  instance Monoid Outliers where@@ -71,8 +75,10 @@     -- ^ Brief textual description of effect.     , ovFraction :: Double     -- ^ Quantitative description of effect (a fraction between 0 and 1).-    } deriving (Eq, Read, Show, Typeable, Data)+    } deriving (Eq, Read, Show, Typeable, Data, Generic) +instance Binary OutlierVariance+ instance NFData OutlierVariance where     rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction @@ -81,7 +87,9 @@       anMean :: B.Estimate     , anStdDev :: B.Estimate     , anOutlierVar :: OutlierVariance-    } deriving (Eq, Show, Typeable, Data)+    } deriving (Eq, Read, Show, Typeable, Data, Generic)++instance Binary SampleAnalysis  instance NFData SampleAnalysis where     rnf SampleAnalysis{..} =
Criterion/Config.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}  -- | -- Module      : Criterion.Config@@ -15,29 +15,36 @@     (       Config(..)     , PrintExit(..)+    , MatchType(..)     , Verbosity(..)     , defaultConfig     , fromLJ     , ljust     ) where -import Data.Data (Data)+import Data.Data (Data, Typeable) import Data.Function (on) import Data.Monoid (Monoid(..), Last(..))-import Data.Typeable (Typeable)+import GHC.Generics (Generic) +data MatchType = Prefix | Glob+               deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data,+                         Generic)+ -- | Control the amount of information displayed. data Verbosity = Quiet                | Normal                | Verbose-                 deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable)+                 deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data,+                           Generic)  -- | Print some information and exit, without running any benchmarks. data PrintExit = Nada           -- ^ Do not actually print-and-exit. (Default.)                | List           -- ^ Print a list of known benchmarks.                | Version        -- ^ Print version information (if known).                | Help           -- ^ Print a help\/usaage message.-                 deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data)+                 deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data,+                           Generic)  instance Monoid PrintExit where     mempty  = Nada@@ -47,9 +54,11 @@ data Config = Config {       cfgBanner       :: Last String -- ^ The \"version\" banner to print.     , cfgConfInterval :: Last Double -- ^ Confidence interval to use.+    , cfgMatchType    :: Last MatchType -- ^ Kind of matching to use for benchmark names.     , cfgPerformGC    :: Last Bool   -- ^ Whether to run the GC between passes.     , cfgPrintExit    :: PrintExit   -- ^ Whether to print information and exit.     , cfgResamples    :: Last Int    -- ^ Number of resamples to perform.+    , cfgResults      :: Last FilePath -- ^ File to write raw results to.     , cfgReport       :: Last FilePath -- ^ Filename of report.     , cfgSamples      :: Last Int    -- ^ Number of samples to collect.     , cfgSummaryFile  :: Last FilePath -- ^ Filename of summary CSV.@@ -58,7 +67,7 @@     , cfgVerbosity    :: Last Verbosity -- ^ Whether to run verbosely.     , cfgJUnitFile    :: Last FilePath -- ^ Filename of JUnit report.     , cfgMeasure      :: Last Bool   -- ^ Whether to do any measurement.-    } deriving (Eq, Read, Show, Typeable)+    } deriving (Eq, Read, Show, Typeable, Generic)  instance Monoid Config where     mempty  = emptyConfig@@ -69,9 +78,11 @@ defaultConfig = Config {                   cfgBanner       = ljust "I don't know what version I am."                 , cfgConfInterval = ljust 0.95-                , cfgPerformGC    = ljust False+                , cfgMatchType    = ljust Prefix+                , cfgPerformGC    = ljust True                 , cfgPrintExit    = Nada                 , cfgResamples    = ljust (100 * 1000)+                , cfgResults      = mempty                 , cfgReport       = mempty                 , cfgSamples      = ljust 100                 , cfgSummaryFile  = mempty@@ -98,10 +109,12 @@ emptyConfig = Config {                 cfgBanner       = mempty               , cfgConfInterval = mempty+              , cfgMatchType    = mempty               , cfgPerformGC    = mempty               , cfgPrintExit    = mempty               , cfgReport       = mempty               , cfgResamples    = mempty+              , cfgResults      = mempty               , cfgSamples      = mempty               , cfgSummaryFile  = mempty               , cfgCompareFile  = mempty@@ -116,10 +129,12 @@     Config {       cfgBanner       = app cfgBanner a b     , cfgConfInterval = app cfgConfInterval a b+    , cfgMatchType    = app cfgMatchType a b     , cfgPerformGC    = app cfgPerformGC a b     , cfgPrintExit    = app cfgPrintExit a b     , cfgReport       = app cfgReport a b     , cfgResamples    = app cfgResamples a b+    , cfgResults      = app cfgResults a b     , cfgSamples      = app cfgSamples a b     , cfgSummaryFile  = app cfgSummaryFile a b     , cfgCompareFile  = app cfgCompareFile a b
Criterion/Environment.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TypeOperators #-}  -- | -- Module      : Criterion.Environment@@ -20,11 +20,12 @@ import Control.Monad (replicateM_) import Control.Monad.Trans (liftIO) import Criterion.Analysis (analyseMean)-import Criterion.IO (note)+import Criterion.IO.Printf (note) import Criterion.Measurement (getTime, runForAtLeast, time_) import Criterion.Monad (Criterion) import qualified Data.Vector.Unboxed as U-import Data.Typeable (Typeable)+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)  -- | Measured aspects of the execution environment. data Environment = Environment {@@ -32,7 +33,7 @@     -- ^ Clock resolution (in seconds).     , envClockCost       :: {-# UNPACK #-} !Double     -- ^ The cost of a single clock call (in seconds).-    } deriving (Eq, Read, Show, Typeable)+    } deriving (Eq, Read, Show, Typeable, Data, Generic)  -- | Measure the execution environment. measureEnvironment :: Criterion Environment
Criterion/IO.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | -- Module      : Criterion.IO -- Copyright   : (c) 2009, 2010 Bryan O'Sullivan@@ -9,92 +10,57 @@ -- -- Input and output actions. -{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-} module Criterion.IO     (-      CritHPrintfType-    , note-    , printError-    , prolix-    , summary+      header+    , hGetResults+    , hPutResults+    , readResults+    , writeResults     ) where -import Control.Monad (when)-import Control.Monad.Trans (liftIO)-import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ)-import Criterion.Monad (Criterion, getConfig, getConfigItem)-import Data.Monoid (getLast)-import System.IO (Handle, stderr, stdout)-import qualified Text.Printf (HPrintfType, hPrintf)-import Text.Printf (PrintfArg)---- First item is the action to print now, given all the arguments--- gathered together so far.  The second item is the function that--- will take a further argument and give back a new PrintfCont.-data PrintfCont = PrintfCont (IO ()) (PrintfArg a => a -> PrintfCont)---- | An internal class that acts like Printf/HPrintf.------ The implementation is visible to the rest of the program, but the--- details of the class are not.-class CritHPrintfType a where-  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a---instance CritHPrintfType (Criterion a) where-  chPrintfImpl check (PrintfCont final _)-    = do x <- getConfig-         when (check x) (liftIO final)-         return undefined--instance CritHPrintfType (IO a) where-  chPrintfImpl _ (PrintfCont final _)-    = final >> return undefined--instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where-  chPrintfImpl check (PrintfCont _ anotherArg) x-    = chPrintfImpl check (anotherArg x)--chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r-chPrintf shouldPrint h s-  = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s)-                                   (Text.Printf.hPrintf h s))-  where-    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) =>-                      a -> r) -> PrintfCont-    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x)-                                                      (curCall' x))--{- A demonstration of how to write printf in this style, in case it is-ever needed-  in fututre:+import Criterion.Types (ResultForest, ResultTree(..))+import Data.Binary (Binary(..), encode)+import Data.Binary.Get (runGetOrFail)+import Data.Binary.Put (putByteString, putWord16be, runPut)+import Data.Version (Version(..))+import Paths_criterion (version)+import System.IO (Handle, IOMode(..), withFile)+import qualified Data.ByteString.Lazy as L -cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r-cPrintf shouldPrint s-  = chPrintfImpl shouldPrint (make (Text.Printf.printf s)-  (Text.Printf.printf s))-  where-    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont-    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))--}+header :: L.ByteString+header = runPut $ do+  putByteString "criterio"+  mapM_ (putWord16be . fromIntegral) (versionBranch version) --- | Print a \"normal\" note.-note :: (CritHPrintfType r) => String -> r-note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout+hGetResults :: Handle -> IO (Either String ResultForest)+hGetResults handle = do+  let fixup = reverse . nukem . reverse+      nukem (Compare k _ : rs) = let (cs, rs') = splitAt k rs+                                 in Compare k (fixup (reverse cs)) : nukem rs'+      nukem (r : rs)           = r : nukem rs+      nukem _                  = []+  bs <- L.hGet handle (fromIntegral (L.length header))+  if bs == header+    then (Right . fixup) `fmap` readAll handle+    else return $ Left "unexpected header" --- | Print verbose output.-prolix :: (CritHPrintfType r) => String -> r-prolix = chPrintf ((== Verbose) . fromLJ cfgVerbosity) stdout+hPutResults :: Handle -> ResultForest -> IO ()+hPutResults handle rs = do+  L.hPut handle header+  mapM_ (L.hPut handle . encode) rs --- | Print an error message.-printError :: (CritHPrintfType r) => String -> r-printError = chPrintf (const True) stderr+readResults :: FilePath -> IO (Either String ResultForest)+readResults path = withFile path ReadMode hGetResults --- | Add to summary CSV (if applicable)-summary :: String -> Criterion ()-summary msg-  = do sumOpt <- getConfigItem (getLast . cfgSummaryFile)-       case sumOpt of-         Just fn -> liftIO $ appendFile fn msg-         Nothing -> return ()+writeResults :: FilePath -> ResultForest -> IO ()+writeResults path rs = withFile path WriteMode (flip hPutResults rs) +readAll :: Binary a => Handle -> IO [a]+readAll handle = do+  let go bs+         | L.null bs = return []+         | otherwise = case runGetOrFail get bs of+                         Left (_, _, err) -> fail err+                         Right (bs', _, a) -> (a:) `fmap` go bs'+  go =<< L.hGetContents handle
+ Criterion/IO/Printf.hs view
@@ -0,0 +1,99 @@+-- |+-- Module      : Criterion.IO.Printf+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- Input and output actions.++{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-}+module Criterion.IO.Printf+    (+      CritHPrintfType+    , note+    , printError+    , prolix+    , summary+    ) where++import Control.Monad (when)+import Control.Monad.Trans (liftIO)+import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ)+import Criterion.Monad (Criterion, getConfig, getConfigItem)+import Data.Monoid (getLast)+import System.IO (Handle, stderr, stdout)+import qualified Text.Printf (HPrintfType, hPrintf)+import Text.Printf (PrintfArg)++-- First item is the action to print now, given all the arguments+-- gathered together so far.  The second item is the function that+-- will take a further argument and give back a new PrintfCont.+data PrintfCont = PrintfCont (IO ()) (PrintfArg a => a -> PrintfCont)++-- | An internal class that acts like Printf/HPrintf.+--+-- The implementation is visible to the rest of the program, but the+-- details of the class are not.+class CritHPrintfType a where+  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a+++instance CritHPrintfType (Criterion a) where+  chPrintfImpl check (PrintfCont final _)+    = do x <- getConfig+         when (check x) (liftIO final)+         return undefined++instance CritHPrintfType (IO a) where+  chPrintfImpl _ (PrintfCont final _)+    = final >> return undefined++instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where+  chPrintfImpl check (PrintfCont _ anotherArg) x+    = chPrintfImpl check (anotherArg x)++chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r+chPrintf shouldPrint h s+  = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s)+                                   (Text.Printf.hPrintf h s))+  where+    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) =>+                      a -> r) -> PrintfCont+    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x)+                                                      (curCall' x))++{- A demonstration of how to write printf in this style, in case it is+ever needed+  in fututre:++cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r+cPrintf shouldPrint s+  = chPrintfImpl shouldPrint (make (Text.Printf.printf s)+  (Text.Printf.printf s))+  where+    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont+    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))+-}++-- | Print a \"normal\" note.+note :: (CritHPrintfType r) => String -> r+note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout++-- | Print verbose output.+prolix :: (CritHPrintfType r) => String -> r+prolix = chPrintf ((== Verbose) . fromLJ cfgVerbosity) stdout++-- | Print an error message.+printError :: (CritHPrintfType r) => String -> r+printError = chPrintf (const True) stderr++-- | Add to summary CSV (if applicable)+summary :: String -> Criterion ()+summary msg+  = do sumOpt <- getConfigItem (getLast . cfgSummaryFile)+       case sumOpt of+         Just fn -> liftIO $ appendFile fn msg+         Nothing -> return ()
+ Criterion/Internal.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE BangPatterns, RecordWildCards #-}+-- |+-- Module      : Criterion+-- Copyright   : (c) 2009, 2010, 2011 Bryan O'Sullivan+--+-- License     : BSD-style+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : GHC+--+-- Core benchmarking code.++module Criterion.Internal+    (+      runBenchmark+    , runAndAnalyse+    , runNotAnalyse+    , prefix+    ) where++import Control.Monad (foldM, replicateM_, when, mplus)+import Control.Monad.Trans (liftIO)+import Data.Binary (encode)+import qualified Data.ByteString.Lazy as L+import Criterion.Analysis (Outliers(..), OutlierEffect(..), OutlierVariance(..),+                           SampleAnalysis(..), analyseSample,+                           classifyOutliers, noteOutliers)+import Criterion.Config (Config(..), Verbosity(..), fromLJ)+import Criterion.Environment (Environment(..))+import Criterion.IO (header, hGetResults)+import Criterion.IO.Printf (note, prolix, summary)+import Criterion.Measurement (getTime, runForAtLeast, secs, time_)+import Criterion.Monad (Criterion, getConfig, getConfigItem)+import Criterion.Report (Report(..), report)+import Criterion.Types (Benchmark(..), Benchmarkable(..),+                        Result(..), ResultForest, ResultTree(..))+import qualified Data.Vector.Unboxed as U+import Data.Monoid (getLast)+import Statistics.Resampling.Bootstrap (Estimate(..))+import Statistics.Types (Sample)+import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (IOMode(..), SeekMode(..), hClose, hSeek, openBinaryFile,+                  openBinaryTempFile)+import System.Mem (performGC)+import Text.Printf (printf)++-- | Run a single benchmark, and return timings measured when+-- executing it.+runBenchmark :: Benchmarkable b => Environment -> b -> Criterion Sample+runBenchmark env b = do+  _ <- liftIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime)+  let minTime = envClockResolution env * 1000+  (testTime, testIters, _) <- liftIO $ runForAtLeast (min minTime 0.1) 1 (run b)+  _ <- prolix "ran %d iterations in %s\n" testIters (secs testTime)+  cfg <- getConfig+  let newIters    = ceiling $ minTime * testItersD / testTime+      sampleCount = fromLJ cfgSamples cfg+      newItersD   = fromIntegral newIters+      testItersD  = fromIntegral testIters+      estTime     = (fromIntegral sampleCount * newItersD *+                     testTime / testItersD)+  when (fromLJ cfgVerbosity cfg > Normal || estTime > 5) $+    note "collecting %d samples, %d iterations each, in estimated %s\n"+       sampleCount newIters (secs estTime)+  -- Run the GC to make sure garabage created by previous benchmarks+  -- don't affect this benchmark.+  liftIO performGC+  times <- liftIO . fmap (U.map ((/ newItersD) . subtract (envClockCost env))) .+           U.replicateM sampleCount $ do+             when (fromLJ cfgPerformGC cfg) $ performGC+             time_ (run b newIters)+  return times++-- | Run a single benchmark and analyse its performance.+runAndAnalyseOne :: Benchmarkable b => Environment -> String -> b+                 -> Criterion (Sample,SampleAnalysis,Outliers)+runAndAnalyseOne env _desc b = do+  times <- runBenchmark env b+  ci <- getConfigItem $ fromLJ cfgConfInterval+  numResamples <- getConfigItem $ fromLJ cfgResamples+  _ <- prolix "analysing with %d resamples\n" numResamples+  an@SampleAnalysis{..} <- liftIO $ analyseSample ci times numResamples+  let OutlierVariance{..} = anOutlierVar+  let wibble = case ovEffect of+                 Unaffected -> "unaffected" :: String+                 Slight -> "slightly inflated"+                 Moderate -> "moderately inflated"+                 Severe -> "severely inflated"+  bs "mean" anMean+  summary ","+  bs "std dev" anStdDev+  summary "\n"+  vrb <- getConfigItem $ fromLJ cfgVerbosity+  let out = classifyOutliers times+  when (vrb == Verbose || (ovEffect > Unaffected && vrb > Quiet)) $ do+    noteOutliers out+    _ <- note "variance introduced by outliers: %.3f%%\n" (ovFraction * 100)+    _ <- note "variance is %s by outliers\n" wibble+    return ()+  return (times,an,out)+  where bs :: String -> Estimate -> Criterion ()+        bs d e = do _ <- note "%s: %s, lb %s, ub %s, ci %.3f\n" d+                      (secs $ estPoint e)+                      (secs $ estLowerBound e) (secs $ estUpperBound e)+                      (estConfidenceLevel e)+                    summary $ printf "%g,%g,%g"+                      (estPoint e)+                      (estLowerBound e) (estUpperBound e)+++plotAll :: [Result] -> Criterion ()+plotAll descTimes = do+  report (zipWith (\n (Result d t a o) -> Report n d t a o) [0..] descTimes)++-- | Run, and analyse, one or more benchmarks.+runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses+                                  -- whether to run a benchmark by its+                                  -- name.+              -> Environment+              -> Benchmark+              -> Criterion ()+runAndAnalyse p env bs' = do+  mbResultFile <- getConfigItem $ getLast . cfgResults+  (resultFile, handle) <- liftIO $+    case mbResultFile of+      Nothing -> do+        tmpDir <- getTemporaryDirectory+        openBinaryTempFile tmpDir "criterion.dat"+      Just file -> do+        handle <- openBinaryFile file ReadWriteMode+        return (file, handle)+  liftIO $ L.hPut handle header++  let go !k (pfx, Benchmark desc b)+          | p desc'   = do _ <- note "\nbenchmarking %s\n" desc'+                           summary (show desc' ++ ",") -- String will be quoted+                           (x,an,out) <- runAndAnalyseOne env desc' b+                           let result = Single $ Result desc' x an out+                           liftIO $ L.hPut handle (encode result)+                           return $! k + 1+          | otherwise = return (k :: Int)+          where desc' = prefix pfx desc+      go !k (pfx, BenchGroup desc bs) =+          foldM go k [(prefix pfx desc, b) | b <- bs]+      go !k (pfx, BenchCompare bs) = do+                          l <- foldM go 0 [(pfx, b) | b <- bs]+                          let result = Compare l []+                          liftIO $ L.hPut handle (encode result)+                          return $! l + k+  _ <- go 0 ("", bs')++  rts <- (either fail return =<<) . liftIO $ do+    hSeek handle AbsoluteSeek 0+    rs <- hGetResults handle+    hClose handle+    case mbResultFile of+      Just _ -> return rs+      _      -> removeFile resultFile >> return rs++  mbCompareFile <- getConfigItem $ getLast . cfgCompareFile+  case mbCompareFile of+    Nothing -> return ()+    Just compareFile -> do+      liftIO $ writeFile compareFile $ resultForestToCSV rts++  let rs = flatten rts+  plotAll rs+  junit rs++runNotAnalyse :: (String -> Bool) -- ^ A predicate that chooses+                                  -- whether to run a benchmark by its+                                  -- name.+              -> Benchmark+              -> Criterion ()+runNotAnalyse p bs' = goQuickly "" bs'+  where goQuickly :: String -> Benchmark -> Criterion ()+        goQuickly pfx (Benchmark desc b)+            | p desc'   = do _ <- note "benchmarking %s\n" desc'+                             runOne b+            | otherwise = return ()+            where desc' = prefix pfx desc+        goQuickly pfx (BenchGroup desc bs) =+            mapM_ (goQuickly (prefix pfx desc)) bs+        goQuickly pfx (BenchCompare bs) = mapM_ (goQuickly pfx) bs++        runOne b = do+            samples <- getConfigItem $ fromLJ cfgSamples+            liftIO $ run b samples++prefix :: String -> String -> String+prefix ""  desc = desc+prefix pfx desc = pfx ++ '/' : desc++flatten :: ResultForest -> [Result]+flatten [] = []+flatten (Single r    : rs) = r : flatten rs+flatten (Compare _ crs : rs) = flatten crs ++ flatten rs++resultForestToCSV :: ResultForest -> String+resultForestToCSV = unlines+                  . ("Reference,Name,% faster than reference" :)+                  . map (\(ref, n, p) -> printf "%s,%s,%.0f" ref n p)+                  . top+        where+          top :: ResultForest -> [(String, String, Double)]+          top [] = []+          top (Single _     : rts) = top rts+          top (Compare _ rts' : rts) = cmpRT rts' ++ top rts++          cmpRT :: ResultForest -> [(String, String, Double)]+          cmpRT [] = []+          cmpRT (Single r     : rts) = cmpWith r rts+          cmpRT (Compare _ rts' : rts) = case getReference rts' of+                                         Nothing -> cmpRT rts+                                         Just r  -> cmpRT rts' ++ cmpWith r rts++          cmpWith :: Result -> ResultForest -> [(String, String, Double)]+          cmpWith _   [] = []+          cmpWith ref (Single r     : rts) = cmp ref r : cmpWith ref rts+          cmpWith ref (Compare _ rts' : rts) = cmpRT rts'       +++                                             cmpWith ref rts' +++                                             cmpWith ref rts++          getReference :: ResultForest -> Maybe Result+          getReference []                   = Nothing+          getReference (Single r     : _)   = Just r+          getReference (Compare _ rts' : rts) = getReference rts' `mplus`+                                              getReference rts++cmp :: Result -> Result -> (String, String, Double)+cmp ref r = (description ref, description r, percentFaster)+    where+      percentFaster = (meanRef - meanR) / meanRef * 100++      meanRef = mean ref+      meanR   = mean r++      mean = estPoint . anMean . sampleAnalysis++-- | Write summary JUnit file (if applicable)+junit :: [Result] -> Criterion ()+junit rs+  = do junitOpt <- getConfigItem (getLast . cfgJUnitFile)+       case junitOpt of+         Just fn -> liftIO $ writeFile fn msg+         Nothing -> return ()+  where+    msg = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" +++          printf "<testsuite name=\"Criterion benchmarks\" tests=\"%d\">\n"+          (length rs) +++          concatMap single rs +++          "</testsuite>\n"+    single r = printf "  <testcase name=\"%s\" time=\"%f\" />\n"+               (attrEsc $ description r) (estPoint $ anMean $ sampleAnalysis r)+    attrEsc = concatMap esc+      where+        esc '\'' = "&apos;"+        esc '"'  = "&quot;"+        esc '<'  = "&lt;"+        esc '>'  = "&gt;"+        esc '&'  = "&amp;"+        esc c    = [c]
Criterion/Main.hs view
@@ -40,23 +40,28 @@     , defaultMain     , defaultMainWith     -- * Other useful code+    , makeMatcher     , defaultOptions     , parseArgs     ) where +import Control.Monad (unless) import Control.Monad.Trans (liftIO)-import Criterion (runAndAnalyse, runNotAnalyse)+import Criterion.Internal (runAndAnalyse, runNotAnalyse, prefix) import Criterion.Config import Criterion.Environment (measureEnvironment)-import Criterion.IO (note, printError)+import Criterion.IO.Printf (note, printError) import Criterion.Monad (Criterion, withConfig) import Criterion.Types (Benchmarkable(..), Benchmark(..), Pure, bench,                         benchNames, bgroup, bcompare, nf, nfIO, whnf, whnfIO)-import Data.List (isPrefixOf, sort)+import Data.Char (toLower)+import Data.List (isPrefixOf, sort, stripPrefix)+import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..), Last(..)) import System.Console.GetOpt import System.Environment (getArgs, getProgName) import System.Exit (ExitCode(..), exitWith)+import System.FilePath.Glob  -- | Parse a confidence interval. ci :: String -> IO Config@@ -71,6 +76,12 @@                 | d >= 1 = parseError "confidence interval is greater than 1"                 | otherwise = return mempty { cfgConfInterval = ljust d } +matchType :: String -> IO Config+matchType s = case map toLower s of+                "prefix" -> return mempty { cfgMatchType = ljust Prefix }+                "glob" -> return mempty { cfgMatchType = ljust Glob }+                _ -> parseError "match type is not 'glob' or 'prefix'"+ -- | Parse a positive number. pos :: (Num a, Ord a, Read a) =>        String -> (Last a -> Config) -> String -> IO Config@@ -91,11 +102,13 @@  , Option ['G'] ["no-gc"] (noArg mempty { cfgPerformGC = ljust False })           "do not collect garbage between iterations"  , Option ['g'] ["gc"] (noArg mempty { cfgPerformGC = ljust True })-          "collect garbage between iterations"+          "collect garbage between iterations (default)"  , Option ['I'] ["ci"] (ReqArg ci "CI")           "bootstrap confidence interval"  , Option ['l'] ["list"] (noArg mempty { cfgPrintExit = List })           "print only a list of benchmark names"+ , Option ['m'] ["match"] (ReqArg matchType "MATCH")+          "how to match benchmark names (prefix|glob)"  , Option ['o'] ["output"]           (ReqArg (\t -> return $ mempty { cfgReport = ljust t }) "FILENAME")           "report file to write to"@@ -104,6 +117,9 @@  , Option [] ["resamples"]           (ReqArg (pos "resample count"$ \n -> mempty { cfgResamples = n }) "N")           "number of bootstrap resamples to perform"+ , Option [] ["results"]+          (ReqArg (\n -> return $ mempty { cfgResults = ljust n }) "FILENAME")+          "file to write raw results to"  , Option ['s'] ["samples"]           (ReqArg (pos "sample count" $ \n -> mempty { cfgSamples = n }) "N")           "number of samples to collect"@@ -113,9 +129,10 @@  , Option ['u'] ["summary"] (ReqArg (\s -> return $ mempty { cfgSummaryFile = ljust s }) "FILENAME")           "produce a summary CSV file of all results"  , Option ['r'] ["compare"] (ReqArg (\s -> return $ mempty { cfgCompareFile = ljust s }) "FILENAME")-          "produce a CSV file of comparisons\nagainst reference benchmarks.\nSee the bcompare combinator"+          "produce a CSV file of comparisons\nagainst reference benchmarks\n\+          \(see the bcompare combinator)"  , Option ['n'] ["no-measurements"] (noArg mempty { cfgMeasure = ljust False })-          "Don't do any measurements"+          "don't do any measurements"  , Option ['V'] ["version"] (noArg mempty { cfgPrintExit = Version })           "display version, then exit"  , Option ['v'] ["verbose"] (noArg mempty { cfgVerbosity = ljust Verbose })@@ -135,7 +152,9 @@   p <- getProgName   putStr (usageInfo ("Usage: " ++ p ++ " [OPTIONS] [BENCHMARKS]") options)   putStrLn "If no benchmark names are given, all are run\n\-           \Otherwise, benchmarks are run by prefix match"+           \Otherwise, benchmarks are chosen by prefix or zsh-style pattern \+           \match\n\+           \(use --match to specify how to match the benchmarks to run)"   exitWith exitCode  -- | Parse command line options.@@ -169,6 +188,17 @@ defaultMain :: [Benchmark] -> IO () defaultMain = defaultMainWith defaultConfig (return ()) +makeMatcher :: MatchType -> [String] -> Either String (String -> Bool)+makeMatcher matchKind args =+  case matchKind of+    Prefix -> Right $ \b -> null args || any (`isPrefixOf` b) args+    Glob ->+      let compOptions = compDefault { errorRecovery = False }+      in case mapM (tryCompileWith compOptions) args of+           Left errMsg -> Left . fromMaybe errMsg . stripPrefix "compile :: " $+                          errMsg+           Right ps -> Right $ \b -> null ps || any (`match` b) ps+ -- | An entry point that can be used as a @main@ function, with -- configurable defaults. --@@ -199,7 +229,11 @@                 -> IO () defaultMainWith defCfg prep bs = do   (cfg, args) <- parseArgs defCfg defaultOptions =<< getArgs-  let shouldRun b = null args || any (`isPrefixOf` b) args+  shouldRun <- either parseError return .+               makeMatcher (fromMaybe Prefix . getLast . cfgMatchType $ cfg) $+               args+  unless (null args || any shouldRun (names bsgroup)) $+    parseError "none of the specified names matches a benchmark"   withConfig cfg $    if not $ fromLJ cfgMeasure cfg      then runNotAnalyse shouldRun bsgroup@@ -217,12 +251,16 @@           runAndAnalyse shouldRun env bsgroup   where   bsgroup = BenchGroup "" bs+  names = go ""+    where go pfx (BenchGroup pfx' bms) = concatMap (go (prefix pfx pfx')) bms+          go pfx (Benchmark desc _)    = [prefix pfx desc]+          go _   (BenchCompare _)      = []  -- | Display an error message from a command line parsing failure, and -- exit. parseError :: String -> IO a parseError msg = do-  _ <- printError "Error: %s" msg+  _ <- printError "Error: %s\n" msg   _ <- printError "Run \"%s --help\" for usage information\n" =<< getProgName   exitWith (ExitFailure 64) 
Criterion/Measurement.hs view
@@ -19,11 +19,11 @@     , time     , time_     ) where-    + import Control.Monad (when) import Data.Time.Clock.POSIX (getPOSIXTime) import Text.Printf (printf)-        + time :: IO a -> IO (Double, a) time act = do   start <- getTime
Criterion/Report.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,-    ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings,+    RecordWildCards, ScopedTypeVariables #-}  -- | -- Module      : Criterion.Report@@ -34,6 +34,7 @@ import Criterion.Monad (Criterion, getConfig) import Data.Data (Data, Typeable) import Data.Monoid (Last(..))+import GHC.Generics (Generic) import Paths_criterion (getDataFileName) import Statistics.Sample.KernelDensity (kde) import Statistics.Types (Sample)@@ -55,7 +56,7 @@     , reportTimes :: Sample     , reportAnalysis :: SampleAnalysis     , reportOutliers :: Outliers-    } deriving (Eq, Show, Typeable, Data)+    } deriving (Eq, Read, Show, Typeable, Data, Generic)  -- | The path to the template and other files used for generating -- reports.@@ -163,7 +164,7 @@ -- | A problem arose with a template. data TemplateException =     TemplateNotFound FilePath   -- ^ The template could not be found.-    deriving (Eq, Show, Typeable, Data)+    deriving (Eq, Read, Show, Typeable, Data, Generic)  instance Exception TemplateException 
Criterion/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GADTs #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ExistentialQuantification,+    FlexibleInstances, GADTs #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}  -- |@@ -26,6 +27,7 @@  module Criterion.Types     (+    -- * Benchmark descriptions       Benchmarkable(..)     , Benchmark(..)     , Pure@@ -37,10 +39,19 @@     , bgroup     , bcompare     , benchNames+    -- * Result types+    , Result(..)+    , ResultForest+    , ResultTree(..)     ) where  import Control.DeepSeq (NFData, rnf) import Control.Exception (evaluate)+import Criterion.Analysis.Types (Outliers(..), SampleAnalysis(..))+import Data.Binary (Binary)+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Statistics.Types (Sample)  -- | A benchmarkable function or action. class Benchmarkable a where@@ -142,3 +153,19 @@     show (Benchmark d _)  = ("Benchmark " ++ show d)     show (BenchGroup d _) = ("BenchGroup " ++ show d)     show (BenchCompare _) = ("BenchCompare")++data Result = Result {+      description    :: String+    , sample         :: Sample+    , sampleAnalysis :: SampleAnalysis+    , outliers       :: Outliers+    } deriving (Eq, Read, Show, Typeable, Data, Generic)++instance Binary Result++type ResultForest = [ResultTree]+data ResultTree = Single Result+                | Compare !Int ResultForest+                  deriving (Eq, Read, Show, Typeable, Data, Generic)++instance Binary ResultTree
criterion.cabal view
@@ -1,5 +1,5 @@ name:           criterion-version:        0.6.2.1+version:        0.8.0.0 synopsis:       Robust, reliable performance measurement and analysis license:        BSD3 license-file:   LICENSE@@ -44,6 +44,7 @@     Criterion.Config     Criterion.Environment     Criterion.IO+    Criterion.IO.Printf     Criterion.Main     Criterion.Measurement     Criterion.Monad@@ -51,25 +52,31 @@     Criterion.Types    other-modules:+    Criterion.Internal     Paths_criterion    build-depends:     aeson >= 0.3.2.12,     base < 5,+    binary >= 0.6.3.0,     bytestring >= 0.9 && < 1.0,     containers,     deepseq >= 1.1.0.0,     directory,     filepath,+    Glob >= 0.7.2,     hastache >= 0.5.0,     mtl >= 2,     mwc-random >= 0.8.0.3,     parsec >= 3.1.0,-    statistics >= 0.10.0.0,+    statistics >= 0.10.4.0,     time,     transformers,     vector >= 0.7.1,     vector-algorithms >= 0.4+  if impl(ghc < 7.6)+    build-depends:+      ghc-prim    ghc-options: -O2 -Wall -funbox-strict-fields   if impl(ghc >= 6.8)
+ examples/Comparison.hs view
@@ -0,0 +1,9 @@+import Criterion.Main++main = defaultMain [+   bcompare [+     bench "exp" $ whnf exp (2 :: Double)+   , bench "log" $ whnf log (2 :: Double)+   , bench "sqrt" $ whnf sqrt (2 :: Double)+   ]+ ]