testbench 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+1238/−341 lines, 9 filesdep +cassavadep +dlistdep +optparse-applicativedep −boxesdep ~HUnitdep ~criteriondep ~deepseq
Dependencies added: cassava, dlist, optparse-applicative, process, resourcet, streaming, streaming-bytestring, streaming-cassava, temporary, weigh
Dependencies removed: boxes
Dependency ranges changed: HUnit, criterion, deepseq, statistics
Files
- Changelog.md +39/−0
- README.md +125/−0
- examples/Simple.hs +32/−11
- src/Criterion/Tree.hs +0/−153
- src/TestBench.hs +448/−162
- src/TestBench/Commands.hs +99/−0
- src/TestBench/Evaluate.hs +443/−0
- src/TestBench/LabelTree.hs +27/−7
- testbench.cabal +25/−8
+ Changelog.md view
@@ -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
+ README.md view
@@ -0,0 +1,125 @@+testbench+=========++[](https://hackage.haskell.org/package/testbench) [](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_.
examples/Simple.hs view
@@ -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)
− src/Criterion/Tree.hs
@@ -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
src/TestBench.hs view
@@ -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 --------------------------------------------------------------------------------
+ src/TestBench/Commands.hs view
@@ -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"
+ src/TestBench/Evaluate.hs view
@@ -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
src/TestBench/LabelTree.hs view
@@ -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])
testbench.cabal view
@@ -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