diff --git a/Gauge/Benchmark.hs b/Gauge/Benchmark.hs --- a/Gauge/Benchmark.hs +++ b/Gauge/Benchmark.hs @@ -70,7 +70,10 @@ import Data.List (unfoldr) import Gauge.IO.Printf (note, prolix) import Gauge.Main.Options (Config(..), Verbosity(..)) -import Gauge.Measurement (measure, getTime, secs, Measured(..)) +import Gauge.Measurement + (measure, getTime, secs, Measured(..), defaultMinSamplesNormal, + defaultMinSamplesQuick, defaultTimeLimitNormal, + defaultTimeLimitQuick) import Gauge.Monad (Gauge, finallyGauge, askConfig, gaugeIO) import Gauge.Time (MilliSeconds(..), milliSecondsToDouble, microSecondsToDouble) import qualified Gauge.CSV as CSV @@ -552,8 +555,7 @@ let loop [] !_ _ = error "unpossible!" loop (iters:niters) iTotal acc = do endTime <- getTime - if length acc >= minSamples && - endTime - start >= timeLimit + if length acc >= minSamples && endTime - start >= timeLimit then do let !v = V.reverse (V.fromList acc) return (v, endTime - start, iTotal) @@ -579,10 +581,18 @@ ignoringIOErrors act = act `catch` (\e -> const (return ()) (e :: IOError)) bmTimeLimit :: Config -> Double -bmTimeLimit Config {..} = maybe (if quickMode then 0 else 5) id timeLimit +bmTimeLimit Config {..} = + let def = if quickMode + then defaultTimeLimitQuick + else defaultTimeLimitNormal + in maybe def id timeLimit bmMinSamples :: Config -> Int -bmMinSamples Config {..} = maybe (if quickMode then 1 else 10) id minSamples +bmMinSamples Config {..} = + let def = if quickMode + then defaultMinSamplesQuick + else defaultMinSamplesNormal + in maybe def id minSamples -- | Run a single benchmark measurement in a separate process. runBenchmarkIsolated :: Config -> String -> String -> IO (V.Vector Measured) diff --git a/Gauge/Main.hs b/Gauge/Main.hs --- a/Gauge/Main.hs +++ b/Gauge/Main.hs @@ -26,26 +26,26 @@ , module Gauge.Benchmark ) where -import Control.Applicative -import Control.Monad (unless, when) -#ifdef HAVE_ANALYSIS -import Gauge.Analysis (analyseBenchmark) +import Control.Applicative +import Control.Monad (unless, when) import qualified Gauge.CSV as CSV +#ifdef HAVE_ANALYSIS +import Gauge.Analysis (analyseBenchmark) #endif -import Gauge.IO.Printf (note, printError, rewindClearLine) -import Gauge.Benchmark -import Gauge.Main.Options -import Gauge.Measurement (Measured, measureAccessors_, rescale) -import Gauge.Monad (Gauge, askConfig, withConfig, gaugeIO) -import Data.List (sort) -import Data.Traversable -import System.Environment (getProgName, getArgs) -import System.Exit (ExitCode(..), exitWith) +import Gauge.IO.Printf (note, printError, rewindClearLine) +import Gauge.Benchmark +import Gauge.Main.Options +import Gauge.Measurement (Measured, measureAccessors_, rescale) +import Gauge.Monad (Gauge, askConfig, withConfig, gaugeIO) +import Data.List (sort) +import Data.Traversable +import System.Environment (getProgName, getArgs) +import System.Exit (ExitCode(..), exitWith) -- import System.FilePath.Glob -import System.IO (BufferMode(..), hSetBuffering, stdout) -import Basement.Terminal (initialize) +import System.IO (BufferMode(..), hSetBuffering, stdout) +import Basement.Terminal (initialize) import qualified Data.Vector as V -import Prelude -- Silence redundant import warnings +import Prelude -- Silence redundant import warnings -- | An entry point that can be used as a @main@ function. -- @@ -85,10 +85,11 @@ quickAnalyse :: String -> V.Vector Measured -> Gauge () quickAnalyse desc meas = do Config{..} <- askConfig - let accessors = + let timeAccessor = filter (("time" ==) . fst) measureAccessors_ + accessors = if verbosity == Verbose then measureAccessors_ - else filter (("time" ==) . fst) measureAccessors_ + else timeAccessor _ <- note "%s%-40s " rewindClearLine desc if verbosity == Verbose then gaugeIO (putStrLn "") else return () @@ -96,6 +97,10 @@ (\(k, (a, s, _)) -> reportStat a s k) accessors _ <- note "\n" + + _ <- traverse + (\(_, (a, _, _)) -> writeToCSV csvFile a) + timeAccessor pure () where @@ -105,6 +110,17 @@ let val = (accessor . rescale) $ V.last meas in maybe (return ()) (\x -> note "%-20s %-10s\n" msg (sh x)) val + writeToCSV file accessor = + when (not $ V.null meas) $ do + let val = (accessor . rescale) $ V.last meas + case val of + Nothing -> pure () + Just v -> + gaugeIO $ CSV.write file $ CSV.Row + [ CSV.string desc + , CSV.float v + ] + -- | Run a benchmark interactively with supplied config, and analyse its -- performance. benchmarkWith :: Config -> Benchmarkable -> IO () @@ -171,9 +187,17 @@ DefaultMode -> runDefault where runDefault = do - CSV.write (csvRawFile cfg) $ CSV.Row $ map (CSV.string . fst) measureAccessors_ - CSV.write (csvFile cfg) $ CSV.Row $ map CSV.string - ["Name", "Mean","MeanLB","MeanUB","Stddev","StddevLB","StddevUB"] + -- write the raw csv file header + CSV.write (csvRawFile cfg) $ CSV.Row $ map CSV.string $ + ["name"] ++ map fst measureAccessors_ + + -- write the csv file header + CSV.write (csvFile cfg) $ CSV.Row $ map CSV.string $ ["Name"] ++ + if quickMode cfg + then ["Time"] + -- This requires statistical analysis support. This must + -- remain compatible with criterion. + else ["Mean","MeanLB","MeanUB","Stddev","StddevLB","StddevUB"] hSetBuffering stdout NoBuffering selector <- selectBenches (match cfg) benches bsgroup diff --git a/Gauge/Main/Options.hs b/Gauge/Main/Options.hs --- a/Gauge/Main/Options.hs +++ b/Gauge/Main/Options.hs @@ -26,8 +26,10 @@ -- Temporary: to support pre-AMP GHC 7.8.4: import Data.Monoid - -import Gauge.Measurement (validateAccessors) +import Gauge.Measurement + (validateAccessors, defaultMinSamplesNormal, + defaultMinSamplesQuick, defaultTimeLimitNormal, + defaultTimeLimitQuick) import Gauge.Time (MilliSeconds(..)) import Data.Char (isSpace, toLower) import Data.List (foldl') @@ -138,6 +140,9 @@ , displayMode :: DisplayMode } deriving (Eq, Read, Show, Typeable, Data, Generic) +defaultMinDuration :: MilliSeconds +defaultMinDuration = MilliSeconds 30 + -- | Default benchmarking configuration. defaultConfig :: Config defaultConfig = Config @@ -145,7 +150,7 @@ , forceGC = True , timeLimit = Nothing , minSamples = Nothing - , minDuration = MilliSeconds 30 + , minDuration = defaultMinDuration , includeFirstIter = False , quickMode = False , measureOnly = Nothing @@ -192,9 +197,17 @@ opts = [ Option "I" ["ci"] (ReqArg setCI "CI") "Confidence interval" , Option "G" ["no-gc"] (NoArg setNoGC) "Do not collect garbage between iterations" - , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") "Time limit to run a benchmark, use 0 to force min-samples per benchmark" - , Option "" ["min-samples"] (ReqArg setMinSamples "COUNT") "Minimum number of samples to be taken" - , Option "" ["min-duration"] (ReqArg setMinDuration "MILLISECS") "Minimum duration of each sample, use 0 to force one iteration per sample" + , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") $ + "Min seconds for each benchmark run, default is " + ++ show defaultTimeLimitNormal ++ " in normal mode, " + ++ show defaultTimeLimitQuick ++ " in quick mode" + , Option "" ["min-samples"] (ReqArg setMinSamples "COUNT") $ + "Min no. of samples for each benchmark, default is " + ++ show defaultMinSamplesNormal ++ " in normal mode, " + ++ show defaultMinSamplesQuick ++ " in quick mode" + , Option "" ["min-duration"] (ReqArg setMinDuration "MILLISECS") $ + "Min duration for each sample, default is " + ++ show defaultMinDuration ++ ", when 0 stops after first iteration" , Option "" ["include-first-iter"] (NoArg setIncludeFirst) "Do not discard the measurement of the first iteration" , Option "q" ["quick"] (NoArg setQuickMode) "Perform a quick measurement and report results without statistical analysis" , Option "" ["measure-only"] (fileArg setMeasureOnly) "Just measure the benchmark and place the raw data in the given file" @@ -210,7 +223,9 @@ , Option "v" ["verbosity"] (ReqArg setVerbosity "LEVEL") "Verbosity level" , Option "t" ["template"] (fileArg setTemplate) "Template to use for report" , Option "n" ["iters"] (ReqArg setIters "ITERS") "Run benchmarks, don't analyse" - , Option "m" ["match"] (ReqArg setMatch "MATCH") "How to match benchmark names: prefix, glob, pattern, or ipattern" + , Option "m" ["match"] (ReqArg setMatch "MATCH") $ + "Benchmark match style: prefix, pattern (substring), " + ++ "or ipattern (case insensitive)" , Option "l" ["list"] (NoArg $ setMode List) "List benchmarks" , Option "" ["version"] (NoArg $ setMode Version) "Show version info" , Option "s" ["small"] (NoArg $ setDisplayMode Condensed) "Set benchmark display to the minimum useful information" diff --git a/Gauge/Measurement.hs b/Gauge/Measurement.hs --- a/Gauge/Measurement.hs +++ b/Gauge/Measurement.hs @@ -22,8 +22,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} module Gauge.Measurement - ( - initializeTime + ( defaultMinSamplesNormal + , defaultMinSamplesQuick + , defaultTimeLimitNormal + , defaultTimeLimitQuick + , initializeTime , Time.getTime , Time.getCPUTime , Time.ClockTime(..) @@ -64,6 +67,14 @@ import qualified Gauge.Source.GC as GC import Prelude -- Silence redundant import warnings +defaultMinSamplesNormal, defaultMinSamplesQuick :: Int +defaultMinSamplesNormal = 10 +defaultMinSamplesQuick = 1 + +defaultTimeLimitNormal, defaultTimeLimitQuick :: Double +defaultTimeLimitNormal = 5 +defaultTimeLimitQuick = 0 + -- | A collection of measurements made while benchmarking. -- -- Measurements related to garbage collection are tagged with __GC__. @@ -438,13 +449,13 @@ -> Measured -> Measured applyGCStatistics (Just stats) m = m - { measAllocated = Optional.toOptional $ GC.allocated stats - , measNumGcs = Optional.toOptional $ GC.numGCs stats - , measBytesCopied = Optional.toOptional $ GC.copied stats - , measMutatorWallSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.mutWallSeconds stats - , measMutatorCpuSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.mutCpuSeconds stats - , measGcWallSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.gcWallSeconds stats - , measGcCpuSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.gcCpuSeconds stats + { measAllocated = GC.allocated stats + , measNumGcs = Optional.toOptional "num-gcs" $ GC.numGCs stats + , measBytesCopied = GC.copied stats + , measMutatorWallSeconds = Optional.toOptional "mut-wall-secs" $ nanoSecondsToDouble $ GC.mutWallSeconds stats + , measMutatorCpuSeconds = Optional.toOptional "mut-cpu-secs" $ nanoSecondsToDouble $ GC.mutCpuSeconds stats + , measGcWallSeconds = Optional.toOptional "gc-wall-secs" $ nanoSecondsToDouble $ GC.gcWallSeconds stats + , measGcCpuSeconds = Optional.toOptional "gc-cpu-secs" $ nanoSecondsToDouble $ GC.gcCpuSeconds stats } applyGCStatistics Nothing m = m @@ -458,13 +469,13 @@ -- ^ Value to \"modify\". -> Measured applyRUStatistics end start m - | RUsage.supported = m { measUtime = Optional.toOptional $ diffTV RUsage.userCpuTime - , measStime = Optional.toOptional $ diffTV RUsage.systemCpuTime - , measMaxrss = Optional.toOptional $ RUsage.maxResidentSetSize end - , measMinflt = Optional.toOptional $ diff RUsage.minorFault - , measMajflt = Optional.toOptional $ diff RUsage.majorFault - , measNvcsw = Optional.toOptional $ diff RUsage.nVoluntaryContextSwitch - , measNivcsw = Optional.toOptional $ diff RUsage.nInvoluntaryContextSwitch + | RUsage.supported = m { measUtime = Optional.toOptional "user-cpu-time" $ diffTV RUsage.userCpuTime + , measStime = Optional.toOptional "system-cpu-time" $ diffTV RUsage.systemCpuTime + , measMaxrss = Optional.toOptional "max-rss" $ RUsage.maxResidentSetSize end + , measMinflt = Optional.toOptional "min-flt" $ diff RUsage.minorFault + , measMajflt = Optional.toOptional "maj-flt" $ diff RUsage.majorFault + , measNvcsw = Optional.toOptional "volontary-context-switch" $ diff RUsage.nVoluntaryContextSwitch + , measNivcsw = Optional.toOptional "involontary-context-switch" $ diff RUsage.nInvoluntaryContextSwitch } | otherwise = m where diff f = f end - f start diff --git a/Gauge/Optional.hs b/Gauge/Optional.hs --- a/Gauge/Optional.hs +++ b/Gauge/Optional.hs @@ -53,9 +53,9 @@ isOptionalTag d = isInfinite d || isNaN d -- | Create an optional value from a -toOptional :: (HasCallStack, OptionalTag a) => a -> Optional a -toOptional v - | isOptionalTag v = error "Creating an optional valid value using the optional tag" +toOptional :: (HasCallStack, OptionalTag a) => String -> a -> Optional a +toOptional ty v + | isOptionalTag v = error ("Creating an optional valid value for " ++ ty ++ " using the optional tag") | otherwise = Optional v {-# INLINE toOptional #-} diff --git a/Gauge/Source/GC.hs b/Gauge/Source/GC.hs --- a/Gauge/Source/GC.hs +++ b/Gauge/Source/GC.hs @@ -18,6 +18,7 @@ import Data.IORef (readIORef, newIORef, IORef) import Gauge.Time import System.IO.Unsafe (unsafePerformIO) +import Gauge.Optional (omitted, toOptional, Optional, OptionalTag) #if MIN_VERSION_base(4,10,0) import qualified GHC.Stats as GHC (RTSStats(..), getRTSStatsEnabled, getRTSStats) @@ -60,9 +61,9 @@ -- | Differential metrics related the RTS/GC data Metrics = Metrics - { allocated :: {-# UNPACK #-} !Word64 -- ^ number of bytes allocated + { allocated :: {-# UNPACK #-} !(Optional Word64) -- ^ number of bytes allocated , numGCs :: {-# UNPACK #-} !Word64 -- ^ number of GCs - , copied :: {-# UNPACK #-} !Word64 -- ^ number of bytes copied + , copied :: {-# UNPACK #-} !(Optional Word64) -- ^ number of bytes copied , mutWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator wall time measurement , mutCpuSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator cpu time measurement , gcWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ gc wall time measurement @@ -72,13 +73,13 @@ diffMetrics :: AbsMetrics -> AbsMetrics -> Metrics diffMetrics (AbsMetrics end) (AbsMetrics start) = #if MIN_VERSION_base(4,10,0) - Metrics { allocated = diff (-*) GHC.allocated_bytes + Metrics { allocated = diff (-*?) GHC.allocated_bytes , numGCs = diff (-*) (fromIntegral . GHC.gcs) - , copied = diff (-*) GHC.copied_bytes - , mutWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns) + , copied = diff (-*?) GHC.copied_bytes + , mutWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_elapsed_ns) , mutCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns) - , gcWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_cpu_ns) - , gcCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_elapsed_ns) + , gcWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_elapsed_ns) + , gcCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_cpu_ns) } where diff op f = f end `op` f start @@ -86,10 +87,15 @@ (-*) a b | a >= b = a - b | otherwise = (-1) + + (-*?) :: (OptionalTag a, Ord a, Num a) => a -> a -> Optional a + (-*?) a b + | a >= b = toOptional "gc metric" (a - b) + | otherwise = omitted #else - Metrics { allocated = diff (-*) GHC.bytesAllocated + Metrics { allocated = diff (-*?) GHC.bytesAllocated , numGCs = diff (-*) GHC.numGcs - , copied = diff (-*) GHC.bytesCopied + , copied = diff (-*?) GHC.bytesCopied , mutWallSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorWallSeconds , mutCpuSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorCpuSeconds , gcWallSeconds = doubleToNanoSeconds $ diff (-) GHC.gcWallSeconds @@ -102,6 +108,11 @@ (-*) a b | a >= b = fromIntegral (a - b) | otherwise = (-1) + + (-*?) :: Int64 -> Int64 -> Optional Word64 + (-*?) a b + | a >= b = toOptional "gc metrics" $ fromIntegral (a - b) + | otherwise = omitted #endif -- | Return RTS/GC metrics differential between a call to `f` diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +# 0.2.2 + +* Write data to CSV file in quick mode too. +* Fix the CSV file header to match with the data rows for the `--csvraw` case. +* Fix issue with GC metrics in 32 bits that would silently wrap and failure in optional machinery. +* Simplify dependencies in tests using foudation checks. + # 0.2.1 * Inline math-functions & mwc-random: diff --git a/gauge.cabal b/gauge.cabal --- a/gauge.cabal +++ b/gauge.cabal @@ -1,5 +1,5 @@ name: gauge -version: 0.2.1 +version: 0.2.2 synopsis: small framework for performance measurement and analysis license: BSD3 license-file: LICENSE @@ -19,7 +19,8 @@ GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, - GHC==8.2.2 + GHC==8.2.2, + GHC==8.4.3 description: This library provides a powerful but simple way to measure software @@ -51,6 +52,7 @@ Gauge.Source.RUsage Gauge.Source.GC Gauge.Source.Time + System.Random.MWC if flag(analysis) exposed-modules: @@ -76,7 +78,6 @@ Statistics.Transform Statistics.Types Statistics.Types.Internal - System.Random.MWC Numeric.MathFunctions.Comparison Numeric.MathFunctions.Constants Numeric.SpecFunctions @@ -121,60 +122,10 @@ ghc-options: -O2 -Wall -rtsopts build-depends: - HUnit, base, bytestring, gauge, - tasty, - tasty-hunit - -test-suite verbose - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Sanity.hs - default-language: Haskell2010 - ghc-options: -O2 -Wall -with-rtsopts "-T" - cpp-options: -DVERBOSE - - build-depends: - HUnit, - base, - bytestring, - gauge, - tasty, - tasty-hunit - -test-suite quick - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Sanity.hs - default-language: Haskell2010 - ghc-options: -O2 -Wall -with-rtsopts "-T" - cpp-options: -DQUICK - - build-depends: - HUnit, - base, - bytestring, - gauge, - tasty, - tasty-hunit - -test-suite quick-verbose - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Sanity.hs - default-language: Haskell2010 - ghc-options: -O2 -Wall -with-rtsopts "-T" - cpp-options: -DQUICK -DVERBOSE - - build-depends: - HUnit, - base, - bytestring, - gauge, - tasty, - tasty-hunit + foundation test-suite cleanup type: exitcode-stdio-1.0 @@ -186,14 +137,12 @@ -Wall -threaded -O0 -rtsopts build-depends: - HUnit, base, bytestring, gauge, deepseq, directory, - tasty, - tasty-hunit + foundation benchmark self type: exitcode-stdio-1.0 diff --git a/tests/Cleanup.hs b/tests/Cleanup.hs --- a/tests/Cleanup.hs +++ b/tests/Cleanup.hs @@ -12,12 +12,11 @@ import Control.Monad (when) import Data.Typeable (Typeable) import System.Directory (doesFileExist, removeFile) -import System.Environment (withArgs) import System.IO ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) , hClose, hFileSize, hSeek, openFile) -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (testCase) -import Test.HUnit (assertFailure) +import GHC.Exts (IsList(..)) +import Foundation.Check +import Foundation.Check.Main import qualified Gauge as C import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -26,7 +25,7 @@ instance NFData Handle where rnf !_ = () -data CheckResult = ShouldThrow | WrongData deriving (Show, Typeable) +data CheckResult = ShouldThrow | WrongData deriving (Show, Typeable, Eq) instance Exception CheckResult @@ -35,37 +34,40 @@ perRun :: BenchmarkWithFile perRun name alloc clean work = - bench name $ C.perRunEnvWithCleanup alloc clean work + bench name $ C.perRunEnvWithCleanup alloc clean work perBatch :: BenchmarkWithFile perBatch name alloc clean work = - bench name $ C.perBatchEnvWithCleanup (const alloc) (const clean) work + bench name $ C.perBatchEnvWithCleanup (const alloc) (const clean) work envWithCleanup :: BenchmarkWithFile envWithCleanup name alloc clean work = - C.envWithCleanup alloc clean $ bench name . nfIO . work + C.envWithCleanup alloc clean $ bench name . nfIO . work -testCleanup :: Bool -> String -> BenchmarkWithFile -> TestTree -testCleanup shouldFail name withEnvClean = testCase name $ do - existsBefore <- doesFileExist testFile - when existsBefore $ failTest "Input file already exists" +testCleanup :: Bool -> String -> BenchmarkWithFile -> Test +testCleanup shouldFail name withEnvClean = CheckPlan (fromList name) $ do + existsBefore <- pick "file-exists" $ doesFileExist testFile + validate "Temporary file not exists" $ existsBefore === False + result <- runTest . withEnvClean name alloc clean $ \hnd -> do result <- hFileSize hnd >>= BS.hGet hnd . fromIntegral resetHandle hnd when (result /= testData) $ throwIO WrongData when shouldFail $ throwIO ShouldThrow - case result of - Left WrongData -> failTest "Incorrect result read from file" - Left ShouldThrow -> return () - Right _ | shouldFail -> failTest "Failed to throw exception" - | otherwise -> return () + validate "is-right" $ case result of + Left WrongData -> False -- failTest "Incorrect result read from file" + Left ShouldThrow -> True + Right _ | shouldFail -> False -- failTest "Failed to throw exception" + | otherwise -> True - existsAfter <- doesFileExist testFile - when existsAfter $ do - removeFile testFile - failTest "Failed to delete file" + failure <- pick "cleanup" $ do + existsAfter <- doesFileExist testFile + if existsAfter + then removeFile testFile >> pure True + else pure False + validate "Suceed to delete temporary file" $ failure === False where testFile :: String testFile = "tmp" @@ -73,13 +75,10 @@ testData :: ByteString testData = "blah" - runTest :: Benchmark -> IO (Either CheckResult ()) - runTest = withArgs (["-n","1"]) . try . C.defaultMainWith config . pure + runTest :: Benchmark -> Check (Either CheckResult ()) + runTest = pick "run-test" . try . C.defaultMainWith config . pure where - config = C.defaultConfig { verbosity = Quiet , timeLimit = Just 1 } - - failTest :: String -> IO () - failTest s = assertFailure $ s ++ " in test: " ++ name ++ "!" + config = C.defaultConfig { verbosity = Quiet , timeLimit = Just 1, iters = Just 1 } resetHandle :: Handle -> IO () resetHandle hnd = hSeek hnd AbsoluteSeek 0 @@ -96,14 +95,14 @@ hClose hnd removeFile testFile -testSuccess :: String -> BenchmarkWithFile -> TestTree +testSuccess :: String -> BenchmarkWithFile -> Test testSuccess = testCleanup False -testFailure :: String -> BenchmarkWithFile -> TestTree +testFailure :: String -> BenchmarkWithFile -> Test testFailure = testCleanup True main :: IO () -main = defaultMain $ testGroup "cleanup" +main = defaultMain $ Group "cleanup" [ testSuccess "perRun Success" perRun , testFailure "perRun Failure" perRun , testSuccess "perBatch Success" perBatch diff --git a/tests/Sanity.hs b/tests/Sanity.hs --- a/tests/Sanity.hs +++ b/tests/Sanity.hs @@ -1,19 +1,17 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} -import Gauge.Benchmark (bench, bgroup, env, whnf) -import System.Environment (getEnv, withArgs) -import System.Timeout (timeout) -import Test.Tasty (defaultMain) -import Test.Tasty.HUnit (testCase) -import Test.HUnit (Assertion, assertFailure) +import System.Timeout (timeout) +import Data.Monoid +import Data.Word +import GHC.Exts (IsList(..)) + import qualified Gauge as C -import qualified Control.Exception as E -import qualified Data.ByteString as B +import Gauge.Main.Options +import Gauge.Benchmark (bench, bgroup, env, whnf) -#if !MIN_VERSION_bytestring(0,10,0) -import Control.DeepSeq (NFData (..)) -#endif +import Foundation.Check +import Foundation.Check.Main fib :: Int -> Int fib = sum . go @@ -21,52 +19,41 @@ go 1 = [1] go n = go (n-1) ++ go (n-2) --- Additional arguments to include along with the ARGS environment variable. -extraArgs :: [String] -extraArgs = [ "--raw=sanity.dat", "--json=sanity.json", "--csv=sanity.csv" - , "--output=sanity.html", "--junit=sanity.junit" -#ifdef VERBOSE - , "-v 2" -#endif -#ifdef QUICK - , "--quick" -#endif - ] +withSpecialMain :: Bool -> Bool -> [C.Benchmark] -> IO () +withSpecialMain useVerbose useQuick = C.defaultMainWith cfg + where + cfg = defaultConfig + { rawDataFile = Just "sanity.dat" + , jsonFile = Just "sanity.json" + , csvFile = Just "sanity.csv" + , reportFile = Just "sanity.html" + , junitFile = Just "sanity.junit" + , verbosity = if useVerbose then Verbose else verbosity defaultConfig + , quickMode = useQuick + } -sanity :: Assertion -sanity = do - args <- getArgEnv - withArgs (extraArgs ++ args) $ do +sanity :: Bool -> Bool -> Check () +sanity useVerbose useQuick = do let tooLong = 30 - wat <- timeout (tooLong * 1000000) $ - C.defaultMain [ - bgroup "fib" [ - bench "fib 10" $ whnf fib 10 - , bench "fib 22" $ whnf fib 22 - ] - , env (return (replicate 1024 0)) $ \xs -> - bgroup "length . filter" [ - bench "string" $ whnf (length . filter (==0)) xs - , env (return (B.pack xs)) $ \bs -> - bench "bytestring" $ whnf (B.length . B.filter (==0)) bs - ] - ] - case wat of - Just () -> return () - Nothing -> assertFailure $ "killed for running longer than " ++ - show tooLong ++ " seconds!" - -main :: IO () -main = defaultMain $ testCase "sanity" sanity + wat <- pick "run-program" $ timeout (tooLong * 1000000) $ withSpecialMain useVerbose useQuick + [ bgroup "fib" + [ bench "fib 10" $ whnf fib 10 + , bench "fib 22" $ whnf fib 22 + ] + , env (return (replicate 1024 0 :: [Word8])) $ \xs -> + bgroup "length . filter" + [ bench "string" $ whnf (length . filter (==0)) xs + -- , env (return (B.pack xs)) $ \bs -> bench "uarray" $ whnf (B.length . B.filter (==0)) bs + ] + ] --- This is a workaround to in pass arguments that sneak past --- test-framework to get to criterion. -getArgEnv :: IO [String] -getArgEnv = - fmap words (getEnv "ARGS") `E.catch` - \(_ :: E.SomeException) -> return [] + validate ("not killed for running longer than " <> fromList (show tooLong) <> " seconds") $ + wat === Just () -#if !MIN_VERSION_bytestring(0,10,0) -instance NFData B.ByteString where - rnf bs = bs `seq` () -#endif +main :: IO () +main = defaultMain $ Group "gauge-sanity" + [ CheckPlan "normal" $ sanity False False + , CheckPlan "verbose" $ sanity True False + , CheckPlan "quick" $ sanity False True + , CheckPlan "verbose-quick" $ sanity True True + ]