criterion-cmp (empty) → 0.1.0.0
raw patch · 6 files changed
+388/−0 lines, 6 filesdep +ansi-terminaldep +basedep +boxes
Dependencies added: ansi-terminal, base, boxes, bytestring, cassava, containers, filepath, optparse-applicative, vector
Files
- LICENSE +30/−0
- criterion-cmp.cabal +56/−0
- src/CriterionCompare.hs +119/−0
- src/CsvParse.hs +37/−0
- src/Table.hs +115/−0
- src/Types.hs +31/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016-2020, Ben Gamari, 2020 Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ben Gamari nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ criterion-cmp.cabal view
@@ -0,0 +1,56 @@+cabal-version: 2.2+name: criterion-cmp+version: 0.1.0.0+synopsis: A simple tool for comparing in Criterion benchmark results+description:+ Output a table containing a comparison of results for the input files+ Based on https://github.com/bgamari/criterion-compare++license: BSD-3-Clause+license-file: LICENSE+author:+ Oleg Grenrus <oleg.grenrus@iki.fi>, Ben Gamari <ben@well-typed.com>++maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+copyright: (c) 2020-2021 Oleg Grenrus, 2016-2020 Ben Gamari+category: Development+build-type: Simple+tested-with:+ GHC ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1++source-repository head+ type: git+ location: https://github.com/phadej/criterion-cmp.git++executable criterion-cmp+ default-language: Haskell2010+ hs-source-dirs: src+ main-is: CriterionCompare.hs+ ghc-options: -Wall+ other-modules:+ CsvParse+ Table+ Types++ other-extensions:+ DeriveFunctor+ DeriveFoldable+ FlexibleContexts+ GeneralizedNewtypeDeriving+ OverloadedStrings+ RecordWildCards++ -- ghc boot libs+ build-depends:+ , base >=4.11 && <4.15+ , bytestring ^>=0.10.4.0+ , containers ^>=0.5.5.1 || ^>=0.6.0.1+ , filepath ^>=1.4++ -- other-deps+ build-depends:+ , ansi-terminal ^>=0.11+ , boxes ^>=0.1.5+ , cassava ^>=0.5+ , optparse-applicative ^>=0.16.1.0+ , vector ^>=0.12.2.0
+ src/CriterionCompare.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Applicative (many)+import Data.Bifunctor (first)+import Data.Foldable (foldl')+import Data.Map (Map)+import Data.Traversable (for)+import System.FilePath (dropExtension, takeFileName)++import qualified Data.Map.Strict as Map+import qualified Options.Applicative as O+import qualified Text.PrettyPrint.Boxes as B++import CsvParse+import Table+import Types++-------------------------------------------------------------------------------+-- Options+-------------------------------------------------------------------------------++data Options = Options+ { optRunNames :: [RunName]+ , optOutput :: FilePath+ , optRunPaths :: [FilePath]+ }++options :: O.Parser Options+options = Options+ <$> many (O.strOption $ O.short 'l' <> O.long "label" <> O.help "label")+ <*> O.strOption (O.short 'o' <> O.long "output" <> O.metavar "FILE" <> O.help "output file name" <> O.value "-")+ <*> many (O.strArgument $ O.metavar "FILE" <> O.help "CSV file name")++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++flipFiniteMap :: (Ord a, Ord b) => Map a (Map b v) -> Map b (Map a v)+flipFiniteMap abv = Map.unionsWith Map.union+ [ Map.singleton b $ Map.singleton a v+ | (a, bv) <- Map.toList abv+ , (b, v) <- Map.toList bv+ ]++-------------------------------------------------------------------------------+-- Geometric mean+-------------------------------------------------------------------------------++gmean :: Traversable f => f Stats -> Double+gmean = post . foldl' f (A 1.0 0 0) . fmap statsMean where+ f (A acc es n) d = A c (es + e) (n + 1) where+ (c, e) = split (acc * d)++ split :: Double -> (Double, Int)+ split d = (d / 2 ^^ e, e) where e = exponent d++ post :: A -> Double+ post (A acc es n) = acc ** (1 / fromIntegral n)+ * 2 ** (fromIntegral es / fromIntegral n)++-- | @A x e n@ is @n@ elements which product is @x * 2 ^^ e@+data A = A !Double !Int !Int++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = do+ Options{..} <- O.execParser $ O.info (O.helper <*> options) mempty++ let runs :: [(RunName, FilePath)]+ runs = zipWith f (map Just optRunNames ++ repeat Nothing) optRunPaths+ where+ f (Just n) fp = (n, fp)+ f Nothing fp = (RunName $ dropExtension $ takeFileName fp, fp)++ let names' :: [RunName]+ names' = map fst runs++ case names' of+ [] -> return () -- nothing to do+ fname : names -> do+ results0 <- fmap Map.fromList $ for runs $ \(name, fp) ->+ (,) name . Map.fromList . map (first RowBenchName) <$> readResults fp++ let results1 :: Map RunName (Map RowName Stats)+ results1 = fmap addGMean results0 where+ -- zzz will make the line appear last.+ addGMean m = Map.insert RowMean (Stats (gmean m) 0 0 0 0 0) m++ let results :: Map RowName (Map RunName Stats)+ results = flipFiniteMap results1++ let header :: Row V1 B.Box+ header = makeHeader fname names++ let table :: [Row V2 B.Box]+ table = makeTable fname names results++ let table1 :: Row V2 [B.Box]+ table1 = sequenceA table++ let table2 :: Row V2 B.Box+ table2 = case table1 of+ Row f n xs -> Row+ (B.vcat B.left f)+ (B.vcat B.right n)+ (fmap (fmap (B.vcat B.right)) xs)++ let table3 :: Row V1 B.Box+ table3 = hoistRow (\(V2 x y) -> V1 (x B.<+> y)) table2++ let table4 = pure (B.//) <*> header <*> table3++ B.printBox $ B.hsep 2 B.left table4
+ src/CsvParse.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module CsvParse (readResults) where++import qualified Data.ByteString.Lazy as BSL+import qualified Data.Csv as Csv+import qualified Data.Vector as V++import Types++data BenchResult = BenchResult+ { _benchName :: BenchName+ , _benchStats :: Stats+ }++instance Csv.FromNamedRecord BenchResult where+ parseNamedRecord m = bench+ <$> m Csv..: "Name"+ <*> m Csv..: "Mean"+ <*> m Csv..: "MeanLB"+ <*> m Csv..: "MeanUB"+ <*> m Csv..: "Stddev"+ <*> m Csv..: "StddevLB"+ <*> m Csv..: "StddevUB"+ where+ bench a b c d e f g = BenchResult a (Stats b c d e f g)++readResults :: FilePath -> IO [(BenchName, Stats)]+readResults fname = do+ mxs <- parseResults <$> BSL.readFile fname+ case mxs of+ Left err -> fail err+ Right xs -> return $ map (\(BenchResult a b) -> (a, b)) $ V.toList xs++parseResults :: BSL.ByteString -> Either String (V.Vector BenchResult)+parseResults = fmap snd . Csv.decodeByName
+ src/Table.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE RankNTypes #-}+module Table where++import Control.Monad (ap)+import Data.Foldable (for_)+import Data.Map (Map)+import Numeric (showFFloat)++import qualified Text.PrettyPrint.Boxes as B+import qualified Data.Map.Strict as Map++import Types++-- | Row of things.+--+-- Name, first column, and then pair of columns+data Row f a = Row a a [f a]+ deriving (Show, Functor, Foldable)++hoistRow :: (f a -> g a) -> Row f a -> Row g a+hoistRow f (Row x y zs) = Row x y (map f zs)++instance Applicative f => Applicative (Row f) where+ pure x = Row x x (repeat (pure x))++ Row f1 f2 fs <*> Row x1 x2 xs =+ Row (f1 x1) (f2 x2) (zipWith (<*>) fs xs)++newtype V1 a = V1 a+ deriving (Show, Functor, Foldable)++instance Applicative V1 where+ pure x = V1 x+ V1 f1 <*> V1 x1 = V1 (f1 x1)++data V2 a = V2 a a+ deriving (Show, Functor, Foldable)++instance Applicative V2 where+ pure x = V2 x x+ V2 f1 f2 <*> V2 x1 x2 = V2 (f1 x1) (f2 x2)++makeHeader+ :: RunName -- ^ first run+ -> [RunName] -- ^ other runs+ -> Row V1 B.Box+makeHeader fname names =+ fmap B.text $ Row "Benchmark" (getRunName fname) (map (V1 . getRunName) names)++makeTable+ :: RunName -- ^ first run+ -> [RunName] -- ^ other runs+ -> Map RowName (Map RunName Stats)+ -> [Row V2 B.Box]+makeTable fname names results = map (fmap B.text) $ buildList $ do+ -- rows+ for_ (Map.toList results) $ \(rn, mp) ->+ for_ (Map.lookup fname mp) $ \fstats -> do+ let fmean :: Double+ fmean = statsMean fstats++ precision :: Int+ precision = round $ logBase 10 fmean++ -- rest benchmarks+ rest :: [V2 String]+ rest = buildList $ do+ for_ names $ \name -> case Map.lookup name mp of+ Nothing -> do+ item (V2 "" "")+ Just stats -> do+ let mean = statsMean stats+ item $ V2 (showD precision mean) (showP fmean mean)++ -- name, first, rest+ item $ Row (getRowName rn) (showD precision fmean) rest+ where+ showD :: Int -> Double -> String+ showD p d = showFFloat (Just 3) (mul * d) . showChar 'e' . shows p $ ""+ where mul = 10 ^ negate p++ showP :: Double -> Double -> String+ showP orig curr+ | curr > orig = '+' : showFFloat (Just 2) (100 * (curr - orig) / orig) "%"+ | otherwise = '-' : showFFloat (Just 2) (100 * (orig - curr) / orig) "%"++-------------------------------------------------------------------------------+-- List Builder+-------------------------------------------------------------------------------++newtype ListBuilder x a = LB { unLB :: forall r. (([x] -> [x]) -> a -> r) -> r }++instance Functor (ListBuilder x) where+ fmap f (LB k) = LB $ k $ \endo a k' -> k' endo (f a)++instance Applicative (ListBuilder x) where+ pure x = LB $ \f -> f id x+ (<*>) = ap++instance Monad (ListBuilder x) where+ return = pure++ m >>= k =+ LB $ \r ->+ unLB m $ \endo1 a ->+ unLB (k a) $ \endo2 b ->+ r (endo1 . endo2) b++buildList :: ListBuilder x () -> [x]+buildList (LB f) = f $ \endo _ -> endo []++item :: x -> ListBuilder x ()+item x = LB $ \f -> f (x :) ()
+ src/Types.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Types where++import Data.Csv+import Data.String (IsString (..))++-- | The name of a set of benchmark results from a single run.+newtype RunName = RunName { getRunName :: String }+ deriving (Eq, Ord, Show, FromField)++instance IsString RunName where+ fromString = RunName++-- | The name of a benchmark+newtype BenchName = BenchName { getBenchName :: String }+ deriving (Eq, Ord, Show, FromField)++data RowName+ = RowBenchName BenchName+ | RowMean+ deriving (Eq, Ord, Show)++getRowName :: RowName -> String+getRowName (RowBenchName bn) = getBenchName bn+getRowName RowMean = "Geometric mean"++data Stats = Stats+ { statsMean, statsMeanLB, statsMeanUB :: Double+ , statsStd, statsStdLB, statsStdUB :: Double+ }+ deriving (Show)