Table.hs

{-|
Module      : Crypto.Lol.Utils.PrettyPrint.Table
Description : Pretty-printing for benchmark results within a single level of the Lol stack.
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 within a single level of the Lol stack.
-}

{-# LANGUAGE RecordWildCards #-}

module Crypto.Lol.Utils.PrettyPrint.Table
(prettyBenchesTable
,defaultTableOpts
,TableOpts(..)) where

import Control.Monad (forM_, when)

import Criterion.Measurement (secs)
import Criterion.Types

import Crypto.Lol.Utils.PrettyPrint

import Data.List   (groupBy, nub, transpose)
import System.IO
import Text.Printf

-- | Options for the simple benchmark format.
data TableOpts = TOpts
  {verb          :: Verb,     -- ^ Verbosity
   level         :: String,   -- ^ Which level of Lol to benchmark
   benches       :: [String], -- ^ Which operations to benchmark. The empty list means run all benchmarks.
   params        :: [String], -- ^ Which parameters to benchmark. The empty list means run all parameters.
   colWidth      :: Int,      -- ^ Character width of data columns
   testNameWidth :: Int}      -- ^ Character width of row labels

optsToInternal :: TableOpts -> Benchmark -> OptsInternal
optsToInternal TOpts{..} bnch =
  OptsInternal{params=if null params
                      then nub $ map getBenchParams $ benchNames bnch
                      else params,
               levels=if null level
                      then nub $ map getBenchLvl $ benchNames bnch
                      else [level],
               benches=if null benches
                       then nub $ map getBenchFunc $ benchNames bnch
                       else benches,
               redThreshold = 0,
               ..}

-- | Runs all benchmarks with verbosity 'Progress'.
defaultTableOpts :: Maybe String -> TableOpts
defaultTableOpts lvl =
  case lvl of
    Nothing  -> go ""
    (Just l) -> go l
  where go level =
          TOpts {verb = Progress,
                 benches = [],
                 params = [],
                 colWidth = 30,
                 testNameWidth=20, ..}

-- | Takes benchmark options an a benchmark group nested as params\/level\/op,
-- and prints a table comparing operations across all selected levels of Lol.
prettyBenchesTable :: TableOpts -> Benchmark-> IO ()
prettyBenchesTable o bnch = do
  hSetBuffering stdout NoBuffering -- for better printing of progress
  let o'@OptsInternal{..} = optsToInternal o bnch
  rpts <- getReports o' bnch
  when (verb == Progress) $ putStrLn ""
  printTable o' $ reverse rpts

printTable :: OptsInternal -> [Report] -> IO ()
printTable _ [] = return ()
printTable o rpts = do
  let colLbls = nub $ map (getBenchParams . reportName) rpts
      exName = reportName $ head rpts
  printf (testName o) $ getTableName exName ++ "/" ++ getBenchLvl exName
  mapM_ (printf (col o)) colLbls
  printf "\n"
  let rpts' = transpose $ groupBy (\a b -> getBenchParams (reportName a) == getBenchParams (reportName b)) rpts
  mapM_ (printRow o) rpts'
  putStrLn ""

printRow :: OptsInternal -> [Report] -> IO ()
printRow o@OptsInternal{..} xs@(rpt : _) = do
  printf (testName o) $ getBenchFunc $ reportName rpt
  let times = map (secs . getRuntime) xs
  forM_ times (printf (col o))
  putStrLn ""