Criterion.Dev

Dev.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}

-- | Enable --dev flag for Criterion.

module Criterion.Dev where

import Control.Exception
import Data.Function
import Data.List
import Data.Maybe
import Data.Ord
import System.Environment
import Text.CSV

-- | Enable --dev in the benchmarks.
withDevMode :: IO () -> IO ()
withDevMode m = do
    args <- getArgs
    if elem "--dev-report-only" args
        then do
            rows <- readRows 0 csvfp
            printReport rows
        else case break (== "--dev") args of
                 (before,("--dev":xs))
                   | (l:after) <- xs -> doDevMode l (before ++ after)
                   | otherwise -> error "Expect descriptive argument to --dev"
                 _ -> m
  where
    doDevMode l args = do
        writeFile tmpfp ""
        withArgs (args ++ ["--csv", tmpfp]) m
        newRows <- readRows 1 tmpfp
        oldRows <- readRows 0 csvfp
        let allRows = (oldRows ++ map (l :) newRows)
        printReport allRows
        writeFile csvfp (printCSV allRows)
    csvfp = "criterion-dev-log.csv"
    tmpfp = "criterion-dev-tmp.csv"
    readRows n fp = do
        result <-
            catch
                (parseCSVFromFile fp)
                (\(_ :: IOException) ->
                      (return (Right [])))
        case result of
            Left{} -> return []
            Right (drop n -> rows) -> return rows
    printReport allRows =
        mapM_
            (\xs@((_,groupName,_,_):_) ->
                  do putStrLn groupName
                     putStrLn
                         (indent 2 (tablize
                                        (["Run", "Mean", "Stddev"] :
                                         map
                                             (\(label,_,mean,stddev) ->
                                                   [label, mean, stddev])
                                             xs)))
                     putStrLn "")
            grouped
      where
        simplified =
            mapMaybe
                (\case
                     [label,name,mean,_,_,stddev,_,_] ->
                         Just (label, name, mean, stddev)
                     _ -> Nothing)
                allRows
        grouped = groupBy (on (==) snd') (sortBy (comparing snd') simplified)
          where
            snd' =
                (\(_,n,_,_) ->
                      n)
        tablize xs =
            intercalate "\n" (map (intercalate "  " . map fill . zip [0 ..]) xs)
          where
            fill (x,text) = take width (text ++ repeat ' ')
              where
                width = maximum (map (length . (!! x)) xs)
        indent n = intercalate "\n" . map (replicate n ' ' ++) . lines