PrettyPrint.hs

{-|
Module      : Crypto.Lol.Utils.PrettyPrint
Description : Pretty-printing for benchmark results.
Copyright   : (c) Eric Crockett, 2011-2017
                  Chris Peikert, 2011-2017
License     : GPL-3
Maintainer  : ecrockett0@email.com
Stability   : experimental
Portability : POSIX

Pretty-printing for benchmark results.
-}

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}

module Crypto.Lol.Utils.PrettyPrint
( getTableName
, getBenchParams
, getBenchLvl
, getBenchFunc
, getReports
, getRuntime
, col
, testName
, OptsInternal(..)
, Verb(..)
) where

import Control.Monad          (foldM, when)
import Control.Monad.IO.Class (liftIO)

import Criterion.Internal     (runAndAnalyseOne)
import Criterion.Main.Options (defaultConfig)
import Criterion.Measurement  (initializeTime, secs)
import Criterion.Monad        (Criterion, withConfig)
import Criterion.Types

import qualified Data.Map as Map

import Statistics.Types (Estimate (..))

-- | Verbosity of benchmark output.
data Verb = Progress  -- ^ prints a \'.\' when each benchmark completes
          | Abridged  -- ^ prints a one-line summary for each benchmark
          | Full      -- ^ prints full criterion output for each benchmark
          deriving (Eq)

-- | Options for printing benchmark summary.
data OptsInternal = OptsInternal
  {verb          :: Verb,     -- ^ Verbosity
   levels        :: [String], -- ^ Which levels of Lol to benchmark
   benches       :: [String], -- ^ Which operations to benchmark
   params        :: [String], -- ^ Which parameters to benchmark
   redThreshold  :: Double,   -- ^ How many times larger a benchmark
                              --   must be (compared to the minimum
                              --   benchmark for that parameter,
                              --   across all levels), to be printed in red
   colWidth      :: Int,      -- ^ Character width of data columns
   testNameWidth :: Int}      -- ^ Character width of row labels

col, testName :: OptsInternal -> String
testName OptsInternal{..} = "%-" ++ show testNameWidth ++ "s "
col OptsInternal{..} = "%-" ++ show colWidth ++ "s "

-- get the ith 'word' where words are separated by '/'
wordBy :: Int -> String -> String
wordBy 0 = takeWhile (/= '/')
wordBy i = wordBy (i-1) . tail . dropWhile (/= '/')

getTableName :: String -> String
getTableName   = wordBy 0

getBenchParams :: String -> String
getBenchParams = wordBy 1

getBenchLvl :: String -> String
getBenchLvl    = wordBy 2

getBenchFunc :: String -> String
getBenchFunc   = wordBy 3

getReports :: OptsInternal -> Benchmark -> IO [Report]
getReports o = withConfig (config o) . summarizeBenchReports o

config :: OptsInternal -> Config
config OptsInternal{..} = defaultConfig {verbosity = if verb == Full then Normal else Quiet}

-- collect reports from all selected benchmarks, printing a summary along the way
summarizeBenchReports :: OptsInternal -> Benchmark -> Criterion [Report]
summarizeBenchReports OptsInternal{..} b = do
  liftIO initializeTime -- Workaround for criterion issue #195
  snd <$> go (0, []) ("", b)
  where
    select name =
      let param = getBenchParams name
          lvl   = getBenchLvl    name
          func  = getBenchFunc   name
      in (lvl `elem` levels) && (func `elem` benches) && (param `elem` params)
    -- if we find a Benchmark that we want to run (as determined by `select`)
    go r@(rptIdx, reports) (benchPrefix, Benchmark desc b') |
      select benchName = do
          -- get a single report
          when (verb == Abridged || verb == Full) $ liftIO $ putStr $ "benchmark " ++ benchName
          when (verb == Full) $ liftIO $ putStrLn ""
          dr <- runAndAnalyseOne rptIdx benchName b'
          case dr of
            Measurement{} -> error "PrettyPrint Measurement" -- for Wmissing-monadfail-instances
            (Analysed rpt) -> do
              when (verb == Progress) $ liftIO $ putStr "."
              when (verb == Abridged) $ liftIO $ putStrLn $ "..." ++ secs (getRuntime rpt)
              -- return the report
              return (rptIdx, rpt:reports)
                                                            |
      otherwise = do
        -- if we don't want to run this benchmark, print the name anyway.
        liftIO $ putStrLn benchName
        -- and return the input
        return r
          where benchName = addPrefix benchPrefix desc
    go r (benchPrefix, BenchGroup desc bs) =
      let lvlName = addPrefix benchPrefix desc -- append the description to the prefix
          bs' = map (lvlName,) bs
      in foldM go r bs'

-- | The report runtime, in seconds.
getRuntime :: Report -> Double
getRuntime Report{..} =
  let SampleAnalysis{..} = reportAnalysis
      Regression{..} = head anRegress
      Estimate{..} = regCoeffs Map.! "iters"
  in estPoint