diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,39 @@ +0.2.0.0 +======= + +* Benchmarking results are now printed out incrementally rather than + requiring all of them to be completed first. + +* Support for using the [weigh] library to measure memory usage. + + [weigh]: http://hackage.haskell.org/package/weigh + +* Can now optionally provide a list of `CompParam` values to + `compareFunc` and related functions rather than needing to use + `mappend` or `<>` to manually combine them all. + +* Some of Criterion's command-line options are now available, + including the ability to output a CSV file (albeit with a different + format). + +* Can now evaluate `IO`-based benchmarks. + +* Add `compareFuncList`, `compareFuncAll` (as well as primed and + `IO`-based variants) and `normalForm` (and `normalFormIO`). + +* Remove `compareFuncConstraint` as it was found to not be very + helpful and complicated the code base. The same functionality can + be achieved using `compareFuncList` and related functions. + + - This includes removing `SameAs` and `CUnion` as they are now no + longer needed. + + - The type of `compareFunc` is now different, but existing code + shouldn't needed to change. + +* The `LabelTree` data structure now includes the depth of each node. + +0.1.0.0 (22 May, 2016) +====================== + +* Initial release diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,125 @@ +testbench +========= + +[![Hackage](https://img.shields.io/hackage/v/testbench.svg)](https://hackage.haskell.org/package/testbench) [![Build Status](https://travis-ci.org/ivan-m/testbench.svg)](https://travis-ci.org/ivan-m/testbench) + +> Test your benchmarks! + +> Benchmark your tests! + +It's too easy to accidentally try and benchmark apples and oranges +together. Wouldn't it be nice if you could somehow guarantee that +your benchmarks satisfy some simple tests (e.g. a group of comparisons +all return the same value)? + +Furthermore, trying to compare multiple inputs/functions against each +other requires a lot of boilerplate, making it even easier to +accidentally compare the wrong things (e.g. using `whnf` instead of +`nf`). + +_testbench_ aims to help solve these problems and more by making it +easier to write unit tests and benchmarks together by stating up-front +what requirements are needed and then using simple functions to state +the next parameter to be tested/benchmarked. + +This uses [HUnit] and [criterion] to create the tests and benchmarks +respectively, and it's possible to obtain these explicitly to embed +them within existing test- or benchmark-suites. Alternatively, you +can use the provided `testBench` function directly to first run the +tests and then -- if the tests all succeeded -- run the benchmarks. + +[HUnit]: https://hackage.haskell.org/package/HUnit +[criterion]: https://hackage.haskell.org/package/criterion + +Examples +-------- + +Please see the provided `examples/` directory. + +Limitations +----------- + +* No availability of specifying an environment to run benchmarks in. + +* To be able to display the tree-like structure more readily for + comparisons, the following limitations (currently) have to be made: + + - No detailed output, including no reports. In practice however, + the detailed outputs produced by _criterion_ don't lend + themselves well to comparisons. + +Fortuitously Anticipated Queries +-------------------------------- + +### Why write this library? + +The idea behind _testbench_ came about because of two related +dissatisfactions with _criterion_ that I found: + +1. Even when the `bcompare` function was still available, it still + seemed very difficult/clumsy to write comparison benchmarks since + so much needed to be duplicated for each comparison. + +2. When trying to find examples of benchmarks that performed + comparisons between different implementations, I came across some + that seemingly did the same calculation on different + inputs/implementations, but upon closer analysis the implementation + that "won" was actually doing less work than the others (not by a + large amount, but the difference was non-negligible in my opinion). + This would have been easy to pick up if even a simple test was + performed (e.g. using `==` would have led rise to a type mis-match, + making it obvious they did different things). + +_testbench_ aims to solve these problems by making it easier to write +comparisons up-front: by using the `compareFunc` function to specify +what you are benchmarking and how, then using `comp` just to specify +the input (without needing to also re-specify the function, +evaluationg type, etc.). + +### Do I need to know HUnit or criterion to be able to use this? + +No, for basic/default usage this library handles all that for you. + +There are two overall hints for good benchmarks though: + +* Use the `NFData` variants (e.g. `normalForm`) where possible: this + ensures the calculation is actually completed rather than laziness + biting you. + +* If the variance is high, make the benchmark do more work to decrease + it. + +### Why not use hspec/tasty/some-other-testing-framework? + +Hopefully by the nature of this question it is obvious why I did not +pick one over the others. HUnit is low-level enough that it can be +utilised by any of the others if so required whilst keeping the +dependencies required minimal. + +Not to mention that these tests are more aimed at checking that the +_benchmarks_ are valid and are thus typically equality/predicate-based +tests on the result from a simple function; as such it is more +intended that they are quickly run as a verification stage rather than +the basis for a large test-suite. + +### Why not use criterion directly for running benchmarks? + +_criterion_ currently does not lend itself well to visualising the +results from comparison-style benchmarks: + +* A very limited internal tree-like structure which is not really + apparent when results are displayed. + +* No easy way to actually _compare_ benchmark values: there used to be + a `bcompare` function but it hasn't been available since version + 1.0.0.0 came out in August 2014. As such, comparisons must be done + by hand by comparing the results visually. + +* Having more than a few benchmarks together produces a lot of output + (either to the terminal or a resulting report): combined with the + previous point, having more than a few benchmarks is discouraged. + +Note that if however you wish to use _criterion_ more directly (either +for configurability or to be able to have reports), a combination of +`getTestBenches` and `flattenBenchForest` will provide you with a +`Benchmark` value that is accepted by _criterion_. diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, FlexibleInstances, MultiParamTypeClasses, - TypeFamilies, UndecidableInstances #-} + RankNTypes, TypeFamilies, UndecidableInstances #-} {- | Module : Main @@ -18,7 +18,7 @@ import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import Data.Monoid ((<>)) -import Data.Proxy (Proxy (..)) +import Data.Proxy (Proxy(..)) import qualified Data.Sequence as Seq import Data.Word (Word8) import Test.HUnit.Base ((@=?), (@?)) @@ -39,36 +39,57 @@ (testWith (@? "Not as long as specified") <> benchNormalForm) (mapM_ (\n -> comp ("len == " ++ show n) n) [1..5]) - compareFuncConstraint (Proxy :: Proxy Sequential) - "Length of different linear types" - len - (baseline "Lists" sampleList <> benchNormalForm) - $ do comp "sequence" (Seq.fromList sampleList) - comp "strict bytestring" (SB.pack sampleList) - comp "lazy bytestring" (LB.pack sampleList) + compareFuncAll "Packing and length" + (`chooseType` listLength) + normalForm +data SequenceType = List + | Sequence + | StrictBS + | LazyBS + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +listLength :: (Sequential l) => Proxy l -> Int +listLength st = len (st `pack` sampleList) + +chooseType :: SequenceType -> (forall s. (Sequential s) => Proxy s -> k) -> k +chooseType List k = k (Proxy :: Proxy [Word8]) +chooseType Sequence k = k (Proxy :: Proxy (Seq.Seq Word8)) +chooseType StrictBS k = k (Proxy :: Proxy SB.ByteString) +chooseType LazyBS k = k (Proxy :: Proxy LB.ByteString) + sampleList :: [Word8] -sampleList = [1..10] +sampleList = replicate 1000000 0 class Sequential xs where len :: xs -> Int + pack :: Proxy xs -> [Word8] -> xs + instance Sequential [Word8] where len = length + pack _ = id + instance Sequential (Seq.Seq Word8) where len = length + pack _ = Seq.fromList + instance Sequential SB.ByteString where len = SB.length + pack _ = SB.pack + instance Sequential LB.ByteString where len = fromIntegral . LB.length + pack _ = LB.pack + -------------------------------------------------------------------------------- testOnly :: (Show b, Eq b) => b -> (a -> b) -> String -> a -> TestBench -testOnly = mkTestBench (\_ _ -> Nothing) . (Just .: (@=?)) +testOnly = mkTestBench (\_ _ -> Nothing) (\_ _ -> Nothing) . (Just .: (@=?)) (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (f .: g) x y = f (g x y) diff --git a/src/Criterion/Tree.hs b/src/Criterion/Tree.hs deleted file mode 100644 --- a/src/Criterion/Tree.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} - -{- | - Module : Criterion.Tree - Description : Tree-based representation for Criterion - Copyright : (c) Ivan Lazar Miljenovic - License : MIT - Maintainer : Ivan.Miljenovic@gmail.com - -An extremely simple rose tree-based representation of criterion -benchmarks. - - -} -module Criterion.Tree - ( -- * Types - BenchTree - , BenchForest - -- * Conversion - , flattenBenchTree - , flattenBenchForest - -- * Running benchmarks - , benchmarkForest - ) where - -import TestBench.LabelTree - -import Criterion.Analysis (OutlierVariance (ovFraction), - SampleAnalysis (..)) -import Criterion.Internal (runAndAnalyseOne) -import Criterion.Measurement (initializeTime, secs) -import Criterion.Monad (withConfig) -import Criterion.Types (Benchmark, Benchmarkable, Config (..), - DataRecord (..), Report (..), - Verbosity (..), bench, bgroup) -import Statistics.Resampling.Bootstrap (Estimate (..)) - -import Data.List (transpose) -import Text.PrettyPrint.Boxes - --------------------------------------------------------------------------------- - --- | A more explicit tree-like structure for benchmarks than using --- Criterion's 'Benchmark' type. -type BenchTree = LabelTree (String, Benchmarkable) - -type BenchForest = [BenchTree] - -flattenBenchTree :: BenchTree -> Benchmark -flattenBenchTree = toCustomTree (uncurry bench) bgroup - --- | Remove the explicit tree-like structure into the implicit one --- used by Criterion. --- --- Useful for embedding the results into an existing benchmark --- suite. -flattenBenchForest :: BenchForest -> [Benchmark] -flattenBenchForest = map flattenBenchTree - --- | Run the specified benchmarks, printing the results (once they're --- all complete) to stdout in a tabular format for easier --- comparisons. -benchmarkForest :: Config -> BenchForest -> IO () -benchmarkForest cfg bf = do initializeTime - rs <- toRows cfg bf - printBox (rowsToBox rs) - --------------------------------------------------------------------------------- - -data Row = Row { rowLabel :: !String - , rowDepth :: !Int - , rowResult :: !(Maybe Results) - } - deriving (Eq, Show, Read) - -toRows :: Config -> BenchForest -> IO [Row] -toRows cfg = f2r 0 - where - f2r :: Int -> BenchForest -> IO [Row] - f2r !d = fmap concat . mapM (t2r d) - - t2r :: Int -> BenchTree -> IO [Row] - t2r !d bt = case bt of - Leaf (lbl,b) -> (:[]) <$> makeRow cfg lbl d b - Branch lbl ts -> (Row lbl d Nothing :) - <$> f2r (d+1) ts - -makeRow :: Config -> String -> Int -> Benchmarkable -> IO Row -makeRow cfg lbl d b = Row lbl d <$> getResults cfg lbl b - -data Results = Results { resMean :: !Estimate - , resStdDev :: !Estimate - , resOutVar :: !OutlierVariance - } - deriving (Eq, Show, Read) - -getResults :: Config -> String -> Benchmarkable -> IO (Maybe Results) -getResults cfg lbl b = do dr <- withConfig cfg' (runAndAnalyseOne i lbl b) - return $ case dr of - Measurement{} -> Nothing - Analysed rpt -> Just $ - let sa = reportAnalysis rpt - in Results { resMean = anMean sa - , resStdDev = anStdDev sa - , resOutVar = anOutlierVar sa - } - - where - cfg' = cfg { verbosity = Quiet } - - i = 0 -- We're ignoring this value anyway, so it should be OK to - -- just set it. - --------------------------------------------------------------------------------- - -rowsToBox :: [Row] -> Box -rowsToBox = hsep columnGap center1 - . withHead (vcat left) (vcat right) - . transpose - . ((empty11:resHeaders):) -- Add header row - . map rowToBoxes - -rowToBoxes :: Row -> [Box] -rowToBoxes r = moveRight (indentPerLevel * rowDepth r) (text (rowLabel r)) - : maybe blankRes resToBoxes (rowResult r) - where - blankRes = map (const empty11) resHeaders - -empty11 :: Box -empty11 = emptyBox 1 1 -- Can't use nullBox, as /some/ size is needed. - -indentPerLevel :: Int -indentPerLevel = 2 - -columnGap :: Int -columnGap = 2 - -resHeaders :: [Box] -resHeaders = ["Mean", "MeanLB", "MeanUB", "Stddev", "StddevLB", "StddevUB", "OutlierVariance"] - -resToBoxes :: Results -> [Box] -resToBoxes r = e2b (resMean r) (e2b (resStdDev r) [ov]) - where - e2b e bs = toB estPoint : toB estLowerBound : toB estUpperBound : bs - where - toB f = text (secs (f e)) - - ov = text (show (round (ovFraction (resOutVar r) * 100) :: Int)) <> "%" - --------------------------------------------------------------------------------- - -withHead :: (a -> b) -> (a -> b) -> [a] -> [b] -withHead _ _ [] = [] -withHead fh fr (h:r) = fh h : map fr r diff --git a/src/TestBench.hs b/src/TestBench.hs --- a/src/TestBench.hs +++ b/src/TestBench.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE CPP, ConstraintKinds, FlexibleInstances, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, - ScopedTypeVariables, UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE UndecidableSuperClasses #-} -#endif +{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards + #-} {- | Module : TestBench @@ -17,7 +13,7 @@ indeed valid. At the top level you will probably run the 'testBench' function, and -create comparisons using 'compareFunc' or 'compareFuncConstraint'. +create comparisons using 'compareFunc' or the list-based variants. For example: @@ -26,20 +22,8 @@ > -- Compare how long it takes to make a list of the specified length. > compareFunc "List length" > (\n -> length (replicate n ()) == n) -> (testWith (@? "Not as long as specified") `mappend` benchNormalForm) +> [testWith (@? "Not as long as specified"), benchNormalForm] > (mapM_ (\n -> comp ("len == " ++ show n) n) [1..5]) -> -> -- Polymorphic comparisons. -> -- -> -- Currently it isn't possible to use a Proxy as the argument to -> -- the function (this will probably require Injective Type Families -> -- in GHC 8.0), so we're using 'undefined' to specify the type. -> compareFuncConstraint (Proxy :: Proxy (CUnion Eq Num)) -> "Number type equality" -> (join (==) . (0`asTypeOf`)) -> (baseline "Integer" (undefined :: Integer) `mappend` benchNormalForm) -> $ do comp "Int" (undefined :: Int) -> comp "Double" (undefined :: Double) When run, the output will look something like: @@ -51,55 +35,57 @@ > len == 3 372.4 ns 358.4 ns 393.8 ns 62.50 ns 39.83 ns 90.85 ns 96% > len == 4 396.3 ns 378.4 ns 419.2 ns 67.83 ns 46.71 ns 94.74 ns 96% > len == 5 426.0 ns 407.0 ns 459.5 ns 82.23 ns 53.37 ns 110.2 ns 97% -> Number type equality -> Integer 75.43 ns 74.48 ns 76.71 ns 3.615 ns 2.748 ns 5.524 ns 69% -> Int 74.39 ns 73.48 ns 76.24 ns 3.964 ns 2.500 ns 7.235 ns 74% -> Double 78.05 ns 75.84 ns 82.50 ns 9.790 ns 6.133 ns 16.99 ns 94% -} module TestBench ( -- * Specification and running TestBench , testBench - -- ** Running manually - , getTestBenches - , BenchTree - , BenchForest - , flattenBenchForest - , benchmarkForest - -- ** Lower-level types - , TestBenchM - , OpTree - , Operation - , LabelTree(..) + , testBenchWith + , testBenchConfig -- * Grouping , collection - -- * Direct benchmarks\/tests - , nfEq - , whnfEq - , mkTestBench - -- * Comparisons , compareFunc - , compareFuncConstraint - -- ** Specifying constraints - , CUnion + -- ** List of input values + -- $listbased + , compareFuncList + , compareFuncListIO + , compareFuncListWith + , compareFuncList' + , compareFuncAll + , compareFuncAllIO + , compareFuncAll' -- ** Comparison parameters , CompParams + , ProvideParams(..) + , normalForm + , normalFormIO -- *** Control benchmarking , benchNormalForm + , benchIO + , benchNormalFormIO , withBenchMode , noBenchmarks -- *** Control testing , baseline + , baselineIO + , baselineWith , testWith , noTests + -- *** Control function weighing + , weigh + , weighIO + , GetWeight + , getWeight + , getWeightIO + -- ** Specify comparisons , Comparison , comp @@ -108,127 +94,184 @@ -- ** Lower-level types , ComparisonM - , SameAs + + -- * Manual construction of a TestBench + , getTestBenches + , Eval(..) + , EvalTree + , EvalForest + , flattenBenchForest + , evalForest + + -- ** Direct benchmarks\/tests + , nfEq + , whnfEq + , mkTestBench + + -- ** Lower-level types + , TestBenchM + , OpTree + , Operation + , LabelTree(..) + , Depth + ) where -import Criterion.Tree +import TestBench.Commands +import TestBench.Evaluate import TestBench.LabelTree -import Criterion (Benchmarkable, nf, whnf) -import Criterion.Main.Options (defaultConfig) -import Test.HUnit.Base (Assertion, Counts (..), Test (..), (@=?), (~:)) -import Test.HUnit.Text (runTestTT) +import Criterion (Benchmarkable, nf, nfIO, whnf, whnfIO) +import Criterion.Types (Config) +import Test.HUnit.Base (Assertion, Counts(errors, failures), Test(TestList), + (@=?), (~:)) +import Test.HUnit.Text (runTestTT) -import Control.Applicative (liftA2) import Control.Arrow ((&&&)) -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData(..)) import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, tell) import Data.Maybe (mapMaybe) -import Data.Monoid (Endo (..)) -import Data.Proxy (Proxy (..)) +import Data.Monoid (Endo(..)) +import Options.Applicative (execParser) +import System.Exit (exitSuccess) -- ----------------------------------------------------------------------------- -- | An individual operation potentially consisting of a benchmark -- and/or test. -data Operation = Op { opName :: String - , opBench :: Maybe Benchmarkable - , opTest :: Maybe Assertion +data Operation = Op { opName :: !String + , opBench :: !(Maybe Benchmarkable) + , opWeigh :: !(Maybe GetWeight) + , opTest :: !(Maybe Assertion) } -- | A tree of operations. type OpTree = LabelTree Operation -opTreeTo :: (Operation -> Maybe a) -> OpTree -> Maybe (LabelTree (String, a)) -opTreeTo f = go +toBenchmarks :: [OpTree] -> EvalForest +toBenchmarks = mapMaybe (mapMaybeTree (withName (uncurry . Eval) toEval)) where - go tr = case tr of - Leaf op -> Leaf <$> liftA2 (fmap . (,)) opName f op - Branch lb trs -> case mapMaybe go trs of - [] -> Nothing - trs' -> Just (Branch lb trs') - -opForestTo :: (Operation -> Maybe a) -> (String -> a -> b) -> (String -> [b] -> b) - -> [OpTree] -> [b] -opForestTo f lf br = mapMaybe (fmap (toCustomTree (uncurry lf) br) . opTreeTo f) - -toBenchmarks :: [OpTree] -> BenchForest -toBenchmarks = mapMaybe (opTreeTo opBench) + toEval op = case (opBench op, opWeigh op) of + (Nothing, Nothing) -> Nothing + ops -> Just ops toTests :: [OpTree] -> Test -toTests = TestList . opForestTo opTest (~:) (~:) +toTests = TestList . mapMaybeForest (withName (~:) opTest) (const (~:)) +withName :: (String -> a -> b) -> (Operation -> Maybe a) -> Operation -> Maybe b +withName jn mf op = jn (opName op) <$> mf op + -- ----------------------------------------------------------------------------- -- TODO: does this /really/ need to be in IO? -newtype TestBenchM r = TestBenchM { getOpTrees :: WriterT [OpTree] IO r} - deriving (Functor, Applicative, Monad, MonadIO) +newtype TestBenchM r + = TestBenchM { getOpTrees :: ReaderT Depth (WriterT [OpTree] IO) r } + deriving (Functor, Applicative, Monad, MonadIO) -- | An environment for combining testing and benchmarking. type TestBench = TestBenchM () -makeOpTree :: String -> TestBench -> IO OpTree -makeOpTree nm = fmap (Branch nm) . execWriterT . getOpTrees +runTestBenchDepth :: Depth -> TestBench -> IO [OpTree] +runTestBenchDepth d = execWriterT . (`runReaderT` d) . getOpTrees -- | Label a sub-part of a @TestBench@. collection :: String -> TestBench -> TestBench -collection nm ops = liftIO (makeOpTree nm ops) >>= singleTree +collection nm ops = do d <- getDepth + sub <- liftIO (runTestBenchDepth (d+1) ops) + singleTree (Branch d nm sub) treeList :: [OpTree] -> TestBench -treeList = TestBenchM . tell +treeList = TestBenchM . lift . tell singleTree :: OpTree -> TestBench singleTree = treeList . (:[]) +getDepth :: TestBenchM Depth +getDepth = TestBenchM ask + runTestBench :: TestBench -> IO [OpTree] -runTestBench = execWriterT . getOpTrees +runTestBench = runTestBenchDepth 0 -- | Obtain the resulting tests and benchmarks from the specified -- @TestBench@. -getTestBenches :: TestBench -> IO (Test, BenchForest) +getTestBenches :: TestBench -> IO (Test, EvalForest) getTestBenches = fmap (toTests &&& toBenchmarks) . runTestBench -- | Run the specified benchmarks if and only if all tests pass, using -- a comparison-based format for benchmarking output. -- --- Please note that this is currently very simplistic: no --- parameters, configuration, etc. Also, benchmark results will not --- be shown until all benchmarks are complete. --- -- For more control, use 'getTestBenches'. testBench :: TestBench -> IO () -testBench tb = do (tst,bf) <- getTestBenches tb - tcnts <- runTestTT tst - when (errors tcnts == 0 && failures tcnts == 0) - (benchmarkForest defaultConfig bf) -- TODO: make this configurable +testBench = testBenchWith testBenchConfig +-- | As with 'testBench' but allow specifying a custom default +-- 'Config' parameter rather than 'testBenchConfig'. +-- +-- @since 0.2.0.0 +testBenchWith :: Config -> TestBench -> IO () +testBenchWith cfg tb = do + (tst, bf) <- getTestBenches tb + args <- execParser (optionParser cfg) + case args of + Version -> putStrLn versionInfo >> exitSuccess + List -> evalForest testBenchConfig (stripEval bf) >> exitSuccess + -- Can't use the provided config in case it + -- dictates CSV output. + Weigh ind fp -> weighIndex bf ind >>= writeFile fp . show + Run {..} -> do + testSucc <- if runTests + then do tcnts <- runTestTT tst + return (errors tcnts == 0 && failures tcnts == 0) + else return True + when (runBench && testSucc) (evalForest benchCfg bf) + where + -- To print out the list of benchmarks, we abuse the current + -- tabular setup for printing results by just disabling all + -- benchmarks, etc. + stripEval :: EvalForest -> EvalForest + stripEval = map (fmap (\e -> Eval (eName e) Nothing Nothing)) + -- Create a new value so that if Eval is expanded we don't + -- accidentally run something. + -- ----------------------------------------------------------------------------- -- | Create a single benchmark evaluated to normal form, where the -- results should equal the value specified. +-- +-- Will also weigh the function. nfEq :: (NFData b, Show b, Eq b) => b -> (a -> b) -> String -> a -> TestBench -nfEq = mkTestBench (Just .: nf) . (Just .: (@=?)) +nfEq = mkTestBench (Just .: nf) (Just .: getWeight) . (Just .: (@=?)) -- | Create a single benchmark evaluated to weak head normal form, -- where the results should equal the value specified. whnfEq :: (Show b, Eq b) => b -> (a -> b) -> String -> a -> TestBench -whnfEq = mkTestBench (Just .: whnf) . (Just .: (@=?)) +whnfEq = mkTestBench (Just .: whnf) (const (const Nothing)) . (Just .: (@=?)) -- | A way of writing custom testing/benchmarking statements. You -- will probably want to use one of the pre-defined versions -- instead. -mkTestBench :: ((a -> b) -> a -> Maybe Benchmarkable) -> (b -> Maybe Assertion) +mkTestBench :: ((a -> b) -> a -> Maybe Benchmarkable) + -- ^ Define the benchmark to be performed, if any. + -> ((a -> b) -> a -> Maybe GetWeight) + -- ^ If a benchmark is performed, should its memory + -- usage also be calculated? See the + -- documentation for 'weigh' on how to get this + -- work. + -> (b -> Maybe Assertion) + -- ^ Should the result be checked? -> (a -> b) -> String -> a -> TestBench -mkTestBench toB checkRes fn nm arg = singleTree - . Leaf - $ Op { opName = nm - , opBench = toB fn arg - , opTest = checkRes (fn arg) - } +mkTestBench toB w checkRes fn nm arg = do d <- getDepth + singleTree + . Leaf d + $ Op { opName = nm + , opBench = toB fn arg + , opWeigh = w fn arg + , opTest = checkRes (fn arg) + } -------------------------------------------------------------------------------- @@ -242,65 +285,272 @@ -- -- * No tests are performed by default; use either 'baseline' or -- 'testWith' to specify one. -compareFunc :: forall a b. String -> (a -> b) -> CompParams (SameAs a) b - -> Comparison (SameAs a) b -> TestBench -compareFunc = compareFuncConstraint (Proxy :: Proxy (SameAs a)) - --- | An alias for readability. -type SameAs a = (~) a - --- | As with 'compareFunc' but allow for polymorphic inputs by --- specifying the constraint to be used. -compareFuncConstraint :: forall ca b. Proxy ca -> String -> (forall a. (ca a) => a -> b) - -> CompParams ca b -> Comparison ca b -> TestBench -compareFuncConstraint _ lbl f params cmpM = do ops <- liftIO (runComparison ci cmpM) - let opTr = map Leaf (withOps' ops) - singleTree (Branch lbl opTr) +compareFunc :: (ProvideParams params a b) + => String -> (a -> b) -> params + -> Comparison a b -> TestBench +compareFunc lbl f params cmpM = do ops <- liftIO (runComparison ci cmpM) + d <- getDepth + let opTr = map (Leaf (d+1)) (withOps' ops) + singleTree (Branch d lbl opTr) where - ci0 :: CompInfo ca b ci0 = CI { func = f , toBench = Just .: whnf + , toWeigh = const (const Nothing) , toTest = const Nothing } - (withOps , Endo mkCI) = unCP params - ci = mkCI ci0 + params' = toParams params - withOps' = appEndo (withOps ci) + ci = appEndo (mkOps params') ci0 + withOps' = appEndo (withOps params' ci) + +{- $listbased + +Rather than manually stating all the arguments - especially if you're +either a) dealing with a few different types or b) repeating all the +possible targets a few times - it can be helpful to instead use an +enum type to indicate all the possible options with a helper type +class to generate all the possible benchmarks. + +For example, consider a case where you wish to compare data structures +of @Word8@ values: + +> import qualified Data.ByteString as SB +> import qualified Data.ByteString.Lazy as LB +> import Data.Monoid ((<>)) +> import Data.Proxy (Proxy(..)) +> import qualified Data.Sequence as Seq +> +> -- | All the types we care about. +> data SequenceType = List +> | Sequence +> | StrictBS +> | LazyBS +> deriving (Eq, Ord, Show, Read, Enum, Bounded) +> +> -- | The function we actually want to benchmark. +> listLength :: (Sequential l) => Proxy l -> Int +> listLength st = len (st `pack` sampleList) +> +> -- | How to run a function on our chosen type. +> chooseType :: SequenceType -> (forall s. (Sequential s) => Proxy s -> k) -> k +> chooseType List k = k (Proxy :: Proxy [Word8]) +> chooseType Sequence k = k (Proxy :: Proxy (Seq.Seq Word8)) +> chooseType StrictBS k = k (Proxy :: Proxy SB.ByteString) +> chooseType LazyBS k = k (Proxy :: Proxy LB.ByteString) +> +> sampleList :: [Word8] +> sampleList = replicate 1000000 0 +> +> -- | A common type class containing all the functions we want to test. +> class Sequential xs where +> len :: xs -> Int +> +> pack :: Proxy xs -> [Word8] -> xs +> +> instance Sequential [Word8] where +> len = length +> +> pack _ = id +> +> instance Sequential (Seq.Seq Word8) where +> len = length +> +> pack _ = Seq.fromList +> +> instance Sequential SB.ByteString where +> len = SB.length +> +> pack _ = SB.pack +> +> instance Sequential LB.ByteString where +> len = fromIntegral . LB.length +> +> pack _ = LB.pack + +We can then write as our benchmark: + +@ +'compareFuncAll' "Packing and length" + (flip chooseType listLength) + 'normalForm' +@ + +This may seem like a lot of up-front work just to avoid having to +write out all the cases manually, but if you write a lot of similar +benchmarks comparing different aspects of these sequential structures +then the @chooseType@ function ends up being rather trivial to write +(but alas, barring Template Haskell, not possible to easily automate). + +Furthermore, you can now be sure that you won't forget a case! + +-} + +-- | As with 'compareFunc' but use the provided list of values to base +-- the benchmarking off of. +-- +-- This is useful in situations where you create an enumeration type +-- to describe everything you're benchmarking and a function that +-- takes one of these values and evaluates it. +-- +-- 'baseline' is used on the first value (if non-empty); the 'Show' +-- instance is used to provide labels. +-- +-- @since 0.2.0.0 +compareFuncList :: (ProvideParams params a b, Show a, Eq b, Show b) + => String -> (a -> b) -> params + -> [a] -> TestBench +compareFuncList = compareFuncListWith baseline + +-- | A variant of 'compareFuncList' that allows for the function to +-- return an 'IO' value. +-- +-- @since 0.2.0.0 +compareFuncListIO :: (ProvideParams params a (IO b), Show a, Eq b, Show b) + => String -> (a -> IO b) -> params + -> [a] -> TestBench +compareFuncListIO = compareFuncListWith baselineIO + +-- | A variant of 'compareFuncList' where you provide your own +-- equivalent to 'baseline'. +-- +-- Most useful with 'baselineWith'. +-- +-- @since 0.2.0.0 +compareFuncListWith :: (ProvideParams params a b, Show a) + => (String -> a -> CompParams a b) + -> String -> (a -> b) -> params -> [a] -> TestBench +compareFuncListWith bline lbl f params lst = + case lst of + [] -> getDepth >>= \d -> singleTree (Branch d lbl []) + (a:as) -> compareFunc lbl f (bline (show a) a `mappend` toParams params) + (mapM_ (comp =<< show) as) + +-- | A variant of 'compareFuncList' that doesn't use 'baseline' +-- (allowing you to specify your own test). +-- +-- @since 0.2.0.0 +compareFuncList' :: (ProvideParams params a b, Show a) + => String -> (a -> b) -> params + -> [a] -> TestBench +compareFuncList' lbl f params = compareFunc lbl f params . mapM_ (comp =<< show) + +-- | An extension to 'compareFuncList' that uses the 'Bounded' and +-- 'Enum' instances to generate the list of all values. +-- +-- @since 0.2.0.0 +compareFuncAll :: (ProvideParams params a b, Show a, Enum a, Bounded a + , Eq b, Show b) => String -> (a -> b) -> params -> TestBench +compareFuncAll lbl f params = compareFuncList lbl f params [minBound..maxBound] + +-- | An extension to 'compareFuncListIO' that uses the 'Bounded' and +-- 'Enum' instances to generate the list of all values. +-- +-- @since 0.2.0.0 +compareFuncAllIO :: (ProvideParams params a (IO b), Show a, Enum a, Bounded a + , Eq b, Show b) => String -> (a -> IO b) -> params -> TestBench +compareFuncAllIO lbl f params = compareFuncListIO lbl f params [minBound..maxBound] + +-- | A variant of 'comapreFuncAll' that doesn't use 'baseline' +-- (allowing you to specify your own test). +-- +-- @since 0.2.0.0 +compareFuncAll' :: (ProvideParams params a b, Show a, Enum a, Bounded a) + => String -> (a -> b) -> params -> TestBench +compareFuncAll' lbl f params = compareFuncList' lbl f params [minBound..maxBound] + -- TODO: work out how to fix it if multiple test setting functions are called; might need a Last in here. -- | Monoidally build up the parameters used to control a 'Comparison' -- environment. -- -- This will typically be a combination of 'benchNormalForm' with -- either 'baseline' or 'testWith'. -newtype CompParams ca b = CP { unCP :: ( CompInfo ca b -> Endo [Operation] - , Endo (CompInfo ca b) - ) - } - deriving (Monoid) +data CompParams a b = CP { withOps :: CompInfo a b -> Endo [Operation] + , mkOps :: Endo (CompInfo a b) + } +instance Monoid (CompParams a b) where + mempty = CP { withOps = mempty + , mkOps = mempty + } + + mappend cp1 cp2 = CP { withOps = mappendBy withOps + , mkOps = mappendBy mkOps + } + where + mappendBy f = mappend (f cp1) (f cp2) + +-- | A convenience class to make it easier to provide 'CompParams' +-- values. +-- +-- You can either: +-- +-- * Provide no parameters with @mempty@ +-- +-- * Provide values chained together using @'mappend'@ or @<>@ +-- +-- * Use the list instance and provide a list of 'CompParams' +-- values. +-- +-- @since 0.2.0.0 +class ProvideParams cp a b | cp -> a b where + toParams :: cp -> CompParams a b + +instance ProvideParams (CompParams a b) a b where + toParams = id + +instance ProvideParams [CompParams a b] a b where + toParams = mconcat + +mkOpsFrom :: (CompInfo a b -> CompInfo a b) -> CompParams a b +mkOpsFrom f = mempty { mkOps = Endo f } + -- | Evaluate all benchmarks to normal form. -benchNormalForm :: (NFData b) => CompParams ca b +benchNormalForm :: (NFData b) => CompParams a b benchNormalForm = withBenchMode nf +-- | A combination of 'benchNormalForm' and 'weigh', taking into +-- account the common case that you want to consider a value that +-- can - and should - be evaluated to normal form. +-- +-- @since 0.2.0.0 normalForm :: (NFData b) => CompParams a b +normalForm = benchNormalForm `mappend` weigh + +-- | A variant of 'normalForm' where the results are within @IO@. +-- +-- @since 0.2.0.0 normalFormIO :: (NFData b) => CompParams a (IO b) +normalFormIO = benchNormalFormIO `mappend` weighIO + +-- | Evaluate all IO-based benchmarks to weak head normal form. +-- +-- @since 0.2.0.0 +benchIO :: CompParams a (IO b) +benchIO = withBenchMode (whnfIO .) + +-- | Evaluate all IO-based benchmarks to normal form. +-- +-- @since 0.2.0.0 +benchNormalFormIO :: (NFData b) => CompParams a (IO b) +benchNormalFormIO = withBenchMode (nfIO .) + -- | Allow specifying how benchmarks should be evaluated. This may -- allow usage of methods such as @nfIO@, but this has not been -- tested as yet. -withBenchMode :: (forall a. (ca a) => (a -> b) -> a -> Benchmarkable) -> CompParams ca b -withBenchMode toB = CP (mempty, Endo (\ci -> ci { toBench = Just .: toB })) +withBenchMode :: ((a -> b) -> a -> Benchmarkable) -> CompParams a b +withBenchMode toB = mkOpsFrom (\ci -> ci { toBench = Just .: toB }) -- | Don't run any benchmarks. I'm not sure why you'd want to do this -- as there's surely easier\/better testing environments available, -- but this way it's possible. -noBenchmarks :: CompParams ca b -noBenchmarks = CP (mempty, Endo (\ci -> ci { toBench = \_ _ -> Nothing })) +noBenchmarks :: CompParams a b +noBenchmarks = mkOpsFrom (\ci -> ci { toBench = \_ _ -> Nothing }) -- | Don't run any tests. This isn't recommended, but could be useful -- if all you want to do is run comparisons (potentially because no -- meaningful tests are possible). -noTests :: CompParams ca b -noTests = CP (mempty, Endo (\ci -> ci { toTest = const Nothing })) +noTests :: CompParams a b +noTests = mkOpsFrom (\ci -> ci { toTest = const Nothing }) -- | Specify a sample baseline value to benchmark and test against -- (such that the result of applying the function to this @a@ is @@ -308,79 +558,115 @@ -- -- You shouldn't specify this more than once, nor mix it with -- 'noTests' or 'testWith'. -baseline :: (ca a, Eq b, Show b) => String -> a -> CompParams ca b -baseline nm arg = CP (addOp, Endo setTest) +-- +-- @since 0.2.0.0 +baseline :: (Eq b, Show b) => String -> a -> CompParams a b +baseline = baselineWith (@=?) + +-- | A variant of 'baseline' where the function returns an 'IO' value. +-- +-- @since 0.2.0.0 +baselineIO :: (Eq b, Show b) => String -> a -> CompParams a (IO b) +baselineIO = baselineWith (liftA2' (@=?)) where + liftA2' f ma mb = do a <- ma + b <- mb + f a b + +-- | A variant of 'baseline' that lets you specify how to test for +-- equality. +-- +-- @since 0.2.0.0 +baselineWith :: (b -> b -> Assertion) -> String -> a -> CompParams a b +baselineWith mkAssert nm arg = mempty { withOps = addOp + , mkOps = Endo setTest + } + where opFrom ci = Op { opName = nm , opBench = toBench ci (func ci) arg + , opWeigh = toWeigh ci (func ci) arg , opTest = Nothing } addOp ci = Endo (opFrom ci:) - setTest ci = ci { toTest = Just . (func ci arg @=?) } + setTest ci = ci { toTest = Just . mkAssert (func ci arg) } -- | Specify a predicate that all results should satisfy. -- -- Note that the last statement between 'testWith', 'baseline' and -- 'noTests' \"wins\" in specifying which testing (if any) to do. -testWith :: (b -> Assertion) -> CompParams ca b -testWith f = CP (mempty, Endo (\ci -> ci { toTest = Just . f })) +testWith :: (b -> Assertion) -> CompParams a b +testWith f = mkOpsFrom (\ci -> ci { toTest = Just . f }) -data CompInfo ca b = CI { func :: (forall a. (ca a) => a -> b) - , toBench :: (forall a. (ca a) => (a -> b) -> a -> Maybe Benchmarkable) - , toTest :: (b -> Maybe Assertion) - } +-- | Calculate memory usage of the various parameters. +-- +-- This requires running your executable with the @-T@ RTS flag. To +-- do so, you can either do: +-- +-- * @my-program +RTS -T -RTS@ (may need to add @-rtsopts@ to your +-- @ghc-options@ in your .cabal file) +-- +-- * Add @-rtsopts -with-rtsopts=-T@ to your `ghc-options` field in +-- your .cabal file. +-- +-- If this flag is not provided, then this is equivalent to a no-op. +-- +-- @since 0.2.0.0 +weigh :: (NFData b) => CompParams a b +weigh = mkOpsFrom (\ci -> ci { toWeigh = Just .: getWeight }) -type Comper ca b = ReaderT (CompInfo ca b) (WriterT [Operation] IO) +-- | An IO-based equivalent to 'weigh' +-- +-- @since 0.2.0.0 +weighIO :: (NFData b) => CompParams a (IO b) +weighIO = mkOpsFrom (\ci -> ci { toWeigh = Just .: getWeightIO }) -newtype ComparisonM ca b r = ComparisonM { runComparisonM :: Comper ca b r } +data CompInfo a b = CI { func :: a -> b + , toBench :: (a -> b) -> a -> Maybe Benchmarkable + , toWeigh :: (a -> b) -> a -> Maybe GetWeight + , toTest :: b -> Maybe Assertion + } + +type Comper a b = ReaderT (CompInfo a b) (WriterT [Operation] IO) + +newtype ComparisonM a b r = ComparisonM { runComparisonM :: Comper a b r } deriving (Functor, Applicative, Monad, MonadIO) -- | A specialised monad used solely for running comparisons. -- -- No lifting is permitted; the only operations permitted are -- 'comp', 'compBench' and 'compTest'. -type Comparison ca b = ComparisonM ca b () +type Comparison a b = ComparisonM a b () -runComparison :: CompInfo ca b -> Comparison ca b -> IO [Operation] +runComparison :: CompInfo a b -> Comparison a b -> IO [Operation] runComparison cmpr cmpM = execWriterT . runReaderT (runComparisonM cmpM) $ cmpr -- | Benchmark and test (if specified) this value against the -- specified function. -comp :: (ca a) => String -> a -> Comparison ca b +comp :: String -> a -> Comparison a b comp = compWith id --- | Only benchmark (but do not test) this value against the specified --- function. -compBench :: (ca a) => String -> a -> Comparison ca b +-- | Only benchmark and possibly weigh (but do not test) this value +-- against the specified function. +compBench :: String -> a -> Comparison a b compBench = compWith (\op -> op { opTest = Nothing }) --- | Only test (but do not benchmark) this value against the specified --- function. -compTest :: (ca a) => String -> a -> Comparison ca b -compTest = compWith (\op -> op { opBench = Nothing }) +-- | Only test (but do not benchmark or weigh) this value against the +-- specified function. +compTest :: String -> a -> Comparison a b +compTest = compWith (\op -> op { opBench = Nothing, opWeigh = Nothing }) -compWith :: (ca a) => (Operation -> Operation) -> String -> a -> Comparison ca b +compWith :: (Operation -> Operation) -> String -> a -> Comparison a b compWith f nm arg = ComparisonM $ do ci <- ask lift $ tell [f (compOp nm arg ci)] -compOp :: (ca a) => String -> a -> CompInfo ca b -> Operation +compOp :: String -> a -> CompInfo a b -> Operation compOp nm arg ci = Op { opName = nm , opBench = toBench ci (func ci) arg + , opWeigh = toWeigh ci (func ci) arg , opTest = toTest ci $ func ci arg } - --- | The union of two @(* -> 'Constraint')@ values. --- --- Whilst @type EqNum a = ('Eq' a, 'Num' a)@ is a valid --- specification of a 'Constraint' when using the @ConstraintKinds@ --- extension, it cannot be used with 'compareFuncConstraint' as type --- aliases cannot be partially applied. --- --- As such, you can use @type EqNum = CUnion Eq Num@ instead. -class (c1 a, c2 a) => CUnion c1 c2 a -instance (c1 a, c2 a) => CUnion c1 c2 a -------------------------------------------------------------------------------- diff --git a/src/TestBench/Commands.hs b/src/TestBench/Commands.hs new file mode 100644 --- /dev/null +++ b/src/TestBench/Commands.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RecordWildCards #-} + +{- | + Module : TestBench.Commands + Description : Command-line parsing + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + You only need to use this module if you want to consider custom + running\/extensions of this library. + + -} +module TestBench.Commands + ( RunTestBench(..) + , optionParser + , testBenchConfig + , resetUnusedConfig + , versionInfo + , parseWith + , configParser + , weighIndexArg + , weighFileArg + ) where + +import Criterion.Main.Options (config, defaultConfig) +import Criterion.Types (Config(..), Verbosity(Quiet)) + +import Options.Applicative.Builder (auto, footer, fullDesc, header, help, info, + internal, long, option, short, strOption, + switch) +import Options.Applicative.Extra (helper) +import Options.Applicative.Types (Parser, ParserInfo) + +import Control.Applicative ((<|>)) +import Data.Monoid ((<>)) +import Data.Version (showVersion) +import Paths_testbench (version) + +-------------------------------------------------------------------------------- + +data RunTestBench = Version + | List + | Weigh !Int !FilePath + | Run { runTests :: !Bool + , runBench :: !Bool + , benchCfg :: !Config + } + deriving (Eq, Show, Read) + +optionParser :: Config -> ParserInfo RunTestBench +optionParser cfg = info (helper <*> parseWith cfg) $ + header versionInfo + <> fullDesc + <> footer (unwords [ "Most of these options are for Criterion; see it for more information." + , "However, not all are used: CSV is the only allowed output file, and" + , "verbosity is always set to Quiet." + ]) + +parseWith :: Config -> Parser RunTestBench +parseWith cfg = + runParse + <|> Version <$ switch (long "version" <> short 'V' <> help "Show version information") + <|> List <$ switch (long "list" <> short 'l' <> help "List all benchmarks") + <|> Weigh <$> option auto (long weighIndexArg <> internal) -- Hidden options! + <*> strOption (long weighFileArg <> internal) + where + runParse = Run <$> (not <$> switch (long "no-tests" <> help "Don't run tests")) + <*> (not <$> switch (long "no-bench" <> help "Don't run benchmarks")) + <*> configParser cfg + +versionInfo :: String +versionInfo = "TestBench - " ++ showVersion version + +-- | This is the same as 'defaultConfig' from criterion but with the +-- verbosity set to 'Quiet' to avoid unnecessary noise on stdout. +-- +-- @since 0.2.0.0 +testBenchConfig :: Config +testBenchConfig = resetUnusedConfig defaultConfig + +resetUnusedConfig :: Config -> Config +resetUnusedConfig cfg = cfg { rawDataFile = Nothing + , reportFile = Nothing + , jsonFile = Nothing + , junitFile = Nothing + , verbosity = Quiet + } + +-- This is based upon Criterion.Main.Options + +configParser :: Config -> Parser Config +configParser = config . resetUnusedConfig + +weighIndexArg :: String +weighIndexArg = "only-weigh-this-index" + +weighFileArg :: String +weighFileArg = "write-weigh-results-to" diff --git a/src/TestBench/Evaluate.hs b/src/TestBench/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/TestBench/Evaluate.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, GADTs, OverloadedStrings, + RankNTypes #-} + +{- | + Module : TestBench.Evaluate + Description : Tree-based representation for Criterion and Weigh + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + +An extremely simple rose tree-based representation of criterion +benchmarks and weigh measurements. + + -} +module TestBench.Evaluate + ( -- * Types + EvalTree + , EvalForest + , Eval(..) + -- ** Weights + , GetWeight + , getWeight + , getWeightIO + -- * Conversion + , flattenBenchTree + , flattenBenchForest + -- * Running benchmarks + , evalForest + -- ** Weighing individual functions + , weighIndex + ) where + +import TestBench.Commands (resetUnusedConfig, weighFileArg, weighIndexArg) +import TestBench.LabelTree + +import Criterion.Analysis (OutlierVariance(ovFraction), SampleAnalysis(..)) +import Criterion.Internal (runAndAnalyseOne) +import Criterion.Measurement (initializeTime, secs) +import Criterion.Monad (withConfig) +import Criterion.Types (Benchmark, Benchmarkable, Config(..), + DataRecord(..), Report(..), bench, bgroup) +import Statistics.Types (ConfInt(..), Estimate(..)) +import Weigh (weighAction, weighFunc) + +import Data.Csv (DefaultOrdered(..), Field, Name, ToField, ToNamedRecord(..), + ToRecord(..), header, namedRecord, record, toField) + +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.ByteString.Streaming as B +import qualified Data.DList as DL +import Streaming (Of, Stream, hoist) +import Streaming.Cassava (encodeByNameDefault) +import qualified Streaming.Prelude as S + +import Control.Applicative (liftA2) +import Control.DeepSeq (NFData) +import Control.Monad (join, when, zipWithM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put) +import Data.Int (Int64) +import Data.List (intercalate) +import Data.Maybe (isJust, listToMaybe, mapMaybe) +import Data.String (IsString) +import System.Environment (getExecutablePath) +import System.Exit (ExitCode(..)) +import System.IO (hClose) +import System.IO.Temp (withSystemTempFile) +import System.Process (rawSystem) +import Text.Printf (printf) + +-------------------------------------------------------------------------------- + +-- | A more explicit tree-like structure for benchmarks than using +-- Criterion's 'Benchmark' type. +type EvalTree = LabelTree Eval + +type EvalForest = [EvalTree] + +data Eval = Eval { eName :: !String + , eBench :: !(Maybe Benchmarkable) + , eWeigh :: !(Maybe GetWeight) + } + +-- | The results from measuring memory usage. +-- +-- @since 0.2.0.0 +data GetWeight where + GetWeight :: forall a b. (NFData b) => (a -> b) -> a -> GetWeight + GetWeightIO :: forall a b. (NFData b) => (a -> IO b) -> a -> GetWeight + +runGetWeight :: GetWeight -> IO Weight +runGetWeight gw = mkWeight <$> case gw of + GetWeight f a -> weighFunc f a + GetWeightIO f a -> weighAction f a + where + mkWeight (b,gc,_,_) = Weight b gc + +data Weight = Weight { bytesAlloc :: !Int64 + , numGC :: !Int64 + } + deriving (Eq, Ord, Show, Read) + +-- | How to weigh a function. +-- +-- @since 0.2.0.0 +getWeight :: (NFData b) => (a -> b) -> a -> GetWeight +getWeight = GetWeight + +-- | An IO-based variant of 'getWeight'. +-- +-- @since 0.2.0.0 +getWeightIO :: (NFData b) => (a -> IO b) -> a -> GetWeight +getWeightIO = GetWeightIO + +flattenBenchTree :: EvalTree -> Maybe Benchmark +flattenBenchTree = fmap (foldLTree (const bgroup) (flip const)) + . mapMaybeTree (liftA2 fmap (bench . eName) eBench) + +-- | Remove the explicit tree-like structure into the implicit one +-- used by Criterion. +-- +-- Useful for embedding the results into an existing benchmark +-- suite. +flattenBenchForest :: EvalForest -> [Benchmark] +flattenBenchForest = mapMaybe flattenBenchTree + +-- | Run the specified benchmarks, printing the results (once they're +-- all complete) to stdout in a tabular format for easier +-- comparisons. +evalForest :: Config -> EvalForest -> IO () +evalForest cfg ef = do when (hasBench ep) initializeTime + let ec = EC cfg ep + printHeaders ep + (`evalStateT` zeroIndex) . maybeCSV . S.mapM printReturn $ toRows ec ef + where + ep = checkForest ef + + printReturn r = liftIO (printRow ep r) *> return r + + maybeCSV = maybe S.effects streamCSV (csvFile cfg) + + -- In reality, this type signature contains StateT, but that + -- over-complicates understanding what it does, and to specify it + -- generically requires bringing in MonadBaseControl and + -- MonadThrow. + + -- streamCSV :: FilePath -> Stream (Of Row) IO () -> IO () + streamCSV fp = runResourceT + . B.writeFile fp + . hoist lift + . encodeByNameDefault + . S.filter isLeaf + +data EvalParams = EP { hasBench :: !Bool + , hasWeigh :: !Bool + , nameWidth :: !Width + } + deriving (Eq, Ord, Show, Read) + +instance Monoid EvalParams where + mempty = EP { hasBench = False + , hasWeigh = False + , nameWidth = 0 + } + + mappend ec1 ec2 = EP { hasBench = mappendBy hasBench + , hasWeigh = mappendBy hasWeigh + , nameWidth = nameWidth ec1 `max` nameWidth ec2 + } + where + mappendBy f = f ec1 || f ec2 + +checkForest :: EvalForest -> EvalParams +checkForest = mconcat . map (foldLTree mergeNode calcConfig) + where + mergeNode d lbl ls = mempty { nameWidth = width d lbl } + `mappend` mconcat ls + + calcConfig d e = EP { hasBench = isJust (eBench e) + , hasWeigh = isJust (eWeigh e) + , nameWidth = width d (eName e) + } + + width d nm = indentPerLevel * d + length nm + +data EvalConfig = EC { benchConfig :: {-# UNPACK #-}!Config + , evalParam :: {-# UNPACK #-}!EvalParams + } + deriving (Eq, Show, Read) + +-------------------------------------------------------------------------------- + +type PathList = DL.DList String + +data Row = Row { rowLabel :: !String + , rowPath :: !PathList -- ^ Invariant: length == rowDepth + , rowDepth :: {-# UNPACK #-} !Depth + , isLeaf :: !Bool + , rowBench :: !(Maybe BenchResults) + , rowWeight :: !(Maybe Weight) + } + deriving (Eq, Show, Read) + +pathLabel :: Row -> String +pathLabel row = intercalate "/" (DL.toList (DL.snoc (rowPath row) (rowLabel row))) + +-- | Unlike terminal output, this instance creates columns for benchmarks, weighing, etc. even if they're not used. +instance ToRecord Row where + toRecord row = + record (toField fmtLabel : benchRecord ++ weightRecord) + where + fmtLabel = pathLabel row + + benchRecord = timed resMean ++ timed resStdDev ++ [bField (ovFraction . resOutVar)] + where + bField = mField . (. rowBench) . fmap + timed f = map (bField . (. f)) [estPoint, estLowerBound, estUpperBound] + + weightRecord = [wField bytesAlloc, wField numGC] + where + wField = mField . (. rowWeight) . fmap + + mField :: (ToField a) => (Row -> Maybe a) -> Field + mField f = maybe mempty toField (f row) + +-- | Unlike terminal output, this instance creates columns for benchmarks, weighing, etc. even if they're not used. +instance ToNamedRecord Row where + toNamedRecord row = + namedRecord (fmtLabel : benchRecord ++ weightRecord) + where + fmtLabel = (labelName, toField (pathLabel row)) + + benchRecord = zip benchNames + (timed resMean ++ timed resStdDev ++ [bField (ovFraction . resOutVar)]) + where + bField = mField . (. rowBench) . fmap + timed f = map (bField . (. f)) [estPoint, estLowerBound, estUpperBound] + + weightRecord = zip weighNames + [wField bytesAlloc, wField numGC] + where + wField = mField . (. rowWeight) . fmap + + mField :: (ToField a) => (Row -> Maybe a) -> Field + mField f = maybe mempty toField (f row) + +instance DefaultOrdered Row where + headerOrder _ = header (labelName : benchNames ++ weighNames) + +toRows :: EvalConfig -> EvalForest -> Stream (Of Row) (StateT Index IO) () +toRows cfg = f2r DL.empty + where + f2r :: PathList -> EvalForest -> Stream (Of Row) (StateT Index IO) () + f2r pl = mapM_ (t2r pl) + + t2r :: PathList -> EvalTree -> Stream (Of Row) (StateT Index IO) () + t2r pl bt = case bt of + Leaf d e -> do i <- lift get + lift (put (i+1)) + r <- liftIO (makeRow cfg pl i d e) + S.yield r + Branch d lbl ts -> S.cons (Row lbl pl d False Nothing Nothing) + (f2r (pl `DL.snoc` lbl) ts) + +makeRow :: EvalConfig -> PathList -> Index -> Depth -> Eval -> IO Row +makeRow cfg pl idx d e = Row lbl pl d True + <$> tryRun hasBench eBench (getBenchResults (benchConfig cfg) lbl) + <*> tryRun hasWeigh eWeigh (const (tryGetWeight idx)) + where + lbl = eName e + ep = evalParam cfg + + tryRun :: (EvalParams -> Bool) -> (Eval -> Maybe a) -> (a -> IO (Maybe b)) -> IO (Maybe b) + tryRun p f r = + if p ep + then maybe (return Nothing) r (f e) + else return Nothing + +data BenchResults = BenchResults { resMean :: !(Estimate ConfInt Double) + , resStdDev :: !(Estimate ConfInt Double) + , resOutVar :: !OutlierVariance + } + deriving (Eq, Show, Read) + +getBenchResults :: Config -> String -> Benchmarkable -> IO (Maybe BenchResults) +getBenchResults cfg lbl b = do dr <- withConfig cfg' (runAndAnalyseOne i lbl b) + return $ case dr of + Measurement{} -> Nothing + Analysed rpt -> Just $ + let sa = reportAnalysis rpt + in BenchResults { resMean = anMean sa + , resStdDev = anStdDev sa + , resOutVar = anOutlierVar sa + } + + where + -- Set this here just in case someone didn't use the top-level + -- 'testBench' function. + -- + -- Also, just in case a CSV file is being outputted, don't try and + -- write to it. + cfg' = resetUnusedConfig cfg { csvFile = Nothing } + + i = 0 -- We're ignoring this value anyway, so it should be OK to + -- just set it. + +-------------------------------------------------------------------------------- + +type Index = Int + +zeroIndex :: Index +zeroIndex = 0 + +tryGetWeight :: Index -> IO (Maybe Weight) +tryGetWeight idx = withSystemTempFile "testBench.weigh" $ \fp h -> do + -- We use a temporary file in case the program prints something else + -- out to stdout. + hClose h -- We're not writing to it, just need the file + exe <- getExecutablePath + ec <- rawSystem exe ["--" ++ weighIndexArg, show idx, "--" ++ weighFileArg, fp, "+RTS", "-T", "-RTS"] + case ec of + ExitFailure{} -> return Nothing + ExitSuccess -> do + out <- readFile fp + case reads out of + [(!mw,_)] -> return mw + _ -> return Nothing + +weighIndex :: EvalForest -> Index -> IO (Maybe Weight) +weighIndex ef = fmap join . mapM (mapM runGetWeight . eWeigh) . index es + where + es = concatMap leaves ef + +index :: [a] -> Index -> Maybe a +index as n = listToMaybe . drop (n-1) $ as + +-------------------------------------------------------------------------------- + +printHeaders :: EvalParams -> IO () +printHeaders ep = do putStr (replicate (nameWidth ep) ' ') + when (hasBench ep) (mapM_ toPrintf benchHeaders) + when (hasWeigh ep) (mapM_ toPrintf weighHeaders) + putStr "\n" + where + toPrintf (w,hdr) = printf "%s%*s" columnSpace w hdr + +printRow :: EvalParams -> Row -> IO () +printRow ep r = do printf "%-*s" (nameWidth ep) label + when (hasBench ep) (printBench (rowBench r)) + when (hasWeigh ep) (printWeigh (rowWeight r)) + putStr "\n" + where + label :: String + label = printf "%s%s" (replicate (rowDepth r * indentPerLevel) ' ') (rowLabel r) + +type Width = Int + +indentPerLevel :: Width +indentPerLevel = 2 + +columnGap :: Width +columnGap = 2 + +columnSpace :: String +columnSpace = replicate columnGap ' ' + +labelName :: Name +labelName = "Label" + +benchNames :: (IsString str) => [str] +benchNames = ["Mean", "MeanLB", "MeanUB", "Stddev", "StddevLB", "StddevUB", "OutlierVariance"] + +benchHeaders :: [(Width, String)] +benchHeaders = map addWidth benchNames + +weighNames :: (IsString str) => [str] +weighNames = ["AllocBytes", "NumGC"] + +weighHeaders :: [(Width, String)] +weighHeaders = map addWidth weighNames + +-- Maximum width a numeric field can take. Might as well make them +-- all the same width. All other formatters have been manually +-- adjusted to produce nothing longer than this. +secsWidth :: Width +secsWidth = length (secs ((-pi) / 000)) + +addWidth :: String -> (Width, String) +addWidth nm = (max (length nm) secsWidth, nm) + +printBench :: Maybe BenchResults -> IO () +printBench mr = zipWithM_ (printf "%s%*s" columnSpace) wdths cols + where + cols = maybe (repeat "") + (\r -> timed (resMean r) ++ timed (resStdDev r) ++ [ov r]) + mr + + timed bs = [secIt estPoint, secIt estLowerBound, secIt estUpperBound] + where + secIt f = secs (f bs) + + ov r = percent (ovFraction (resOutVar r)) + + wdths = map fst benchHeaders + +estLowerBound :: (Num a) => Estimate ConfInt a -> a +estLowerBound e = estPoint e - confIntLDX (estError e) + +estUpperBound :: (Num a) => Estimate ConfInt a -> a +estUpperBound e = estPoint e + confIntUDX (estError e) + +printWeigh :: Maybe Weight -> IO () +printWeigh mr = zipWithM_ (printf "%s%*s" columnSpace) wdths cols + where + cols = maybe (repeat "") + (\r -> [bytes (bytesAlloc r), count (numGC r)]) + mr + + wdths = map fst weighHeaders + +percent :: Double -> String +percent p = printf "%.3f%%" (p * 100) + +-- | Human-readable description of the number of bytes used. Assumed +-- non-negative. +bytes :: Int64 -> String +bytes b = printf "%.3f %sB" val p + where + prefixes = [" ", "K", "M", "G", "T", "P", "E"] :: [String] + + base = 1024 :: Num a => a + + mult + | b == 0 = 0 + | otherwise = floor (logBase (base :: Double) (fromIntegral b)) + + val = fromIntegral b / (base ^ mult) + + p = prefixes !! mult + +count :: Int64 -> String +count = printf "%.3e" . (`asTypeOf` (0::Double)) . fromIntegral diff --git a/src/TestBench/LabelTree.hs b/src/TestBench/LabelTree.hs --- a/src/TestBench/LabelTree.hs +++ b/src/TestBench/LabelTree.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} + {- | Module : TestBench.LabelTree Description : Labelled rose-tree structure @@ -11,16 +12,35 @@ -} module TestBench.LabelTree where +import Data.Maybe (mapMaybe) + -------------------------------------------------------------------------------- --- | A simple labelled rose-tree data structure. -data LabelTree a = Leaf a - | Branch String [LabelTree a] +type Depth = Int + +-- | A simple labelled rose-tree data structure also containing the depth. +data LabelTree a = Leaf !Depth a + | Branch !Depth String [LabelTree a] deriving (Eq, Ord, Show, Read, Functor) -toCustomTree :: (a -> b) -> (String -> [b] -> b) -> LabelTree a -> b -toCustomTree lf br = go +foldLTree :: (Depth -> String -> [a] -> a) -> (Depth -> b -> a) -> LabelTree b -> a +foldLTree br lf = go where go tr = case tr of - Leaf a -> lf a - Branch str trs -> br str (map go trs) + Leaf d b -> lf d b + Branch d str trs -> br d str (map go trs) + +mapMaybeTree :: (a -> Maybe b) -> LabelTree a -> Maybe (LabelTree b) +mapMaybeTree f = go + where + go tr = case tr of + Leaf d a -> Leaf d <$> f a + Branch d l trs -> case mapMaybe go trs of + [] -> Nothing + trs' -> Just (Branch d l trs') + +mapMaybeForest :: (a -> Maybe b) -> (Depth -> String -> [b] -> b) -> [LabelTree a] -> [b] +mapMaybeForest f br = mapMaybe (fmap (foldLTree br (flip const)) . mapMaybeTree f) + +leaves :: LabelTree a -> [a] +leaves = foldLTree (\_ _ lss -> concat lss) (\_ l -> [l]) diff --git a/testbench.cabal b/testbench.cabal --- a/testbench.cabal +++ b/testbench.cabal @@ -1,5 +1,5 @@ name: testbench -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Create tests and benchmarks together description: { Test your benchmarks! Benchmark your tests! @@ -26,7 +26,8 @@ -- copyright: category: Testing build-type: Simple --- extra-source-files: +extra-source-files: README.md + , Changelog.md cabal-version: >=1.10 tested-with: GHC == 7.10.2, GHC == 8.0.1, GHC == 8.1.* @@ -41,18 +42,32 @@ library exposed-modules: TestBench - other-modules: Criterion.Tree + other-modules: TestBench.Commands + , TestBench.Evaluate , TestBench.LabelTree + , Paths_testbench build-depends: base >=4.7 && <4.11 - , boxes == 0.1.* - , criterion == 1.1.* - , deepseq - , HUnit - , statistics + , bytestring + , cassava == 0.5.* + , criterion >= 1.2.1.0 && < 1.3 + , dlist == 0.8.* + , deepseq >= 1.1.0.0 && < 1.5 + , HUnit >= 1.1 && < 1.7 + , optparse-applicative >= 0.11.0.0 && < 0.15 + , process >= 1.1.0.0 && < 1.7 + , resourcet + , statistics == 0.14.* + , streaming == 0.1.* + , streaming-bytestring == 0.1.* + , streaming-cassava == 0.1.* + , temporary >= 1.1 && < 1.3 , transformers + , weigh >= 0.0.4 && < 0.1 hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall + executable examples if flag(examples) buildable: True @@ -71,3 +86,5 @@ , containers , criterion , HUnit + + ghc-options: -Wall