content: {-|
  Module      : Crypto.Lol.Utils.PrettyPrint.Diagnostic
  Description : Pretty-printing for benchmark results across levels 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 across levels of the Lol stack.
  -}
  
  {-# LANGUAGE RecordWildCards       #-}
  -- EAC: https://ghc.haskell.org/trac/ghc/ticket/13352
  {-# LANGUAGE DuplicateRecordFields #-}
  
  module Crypto.Lol.Utils.PrettyPrint.Diagnostic
  (prettyBenchesDiagnostic
  ,defaultDiagnosticOpts
  ,DiagnosticOpts(..)) 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.Console.ANSI
  import System.IO
  import Text.Printf
  
  -- | Options for the diagnostic benchmark printout.
  data DiagnosticOpts = DOpts
    {verb          :: Verb,     -- ^ Verbosity
     levels        :: [String], -- ^ Which levels of Lol to benchmark. The empty list means run all levels.
     benches       :: [String], -- ^ Which operations to benchmark. The empty list means run all benchmarks.
     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
  
  -- | Runs all benchmarks with verbosity 'Progress'.
  defaultDiagnosticOpts :: DiagnosticOpts
  defaultDiagnosticOpts =
    DOpts {verb = Progress,
           levels = [],
           benches = [],
           redThreshold = 1.2,
           colWidth = 15,
           testNameWidth=40}
  
  optsToInternal :: DiagnosticOpts -> Benchmark -> OptsInternal
  optsToInternal DOpts{..} bnch =
    OptsInternal{params=[getBenchParams $ head $ benchNames bnch],
                 levels=if null levels
                        then nub $ map getBenchLvl $ benchNames bnch
                        else levels,
                 benches=if null benches
                         then nub $ map getBenchFunc $ benchNames bnch
                         else benches,
                 ..}
  
  -- | Takes benchmark options an a benchmark group nested as params\/level\/op,
  -- and prints a table comparing operations across all selected levels of Lol.
  prettyBenchesDiagnostic :: DiagnosticOpts -> Benchmark-> IO ()
  prettyBenchesDiagnostic 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 (getBenchLvl . reportName) rpts
    printf (testName o) $ getBenchParams $ reportName $ head rpts
    mapM_ (printf (col o)) colLbls
    printf "\n"
    let rpts' = transpose $ groupBy (\a b -> getBenchLvl (reportName a) == getBenchLvl (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 getRuntime xs
        minTime = minimum times
        printCol t =
          if t > (redThreshold*minTime)
          then do
            setSGR [SetColor Foreground Vivid Red]
            printf (col o) $ secs t
            setSGR [Reset]
          else printf (col o) $ secs t
    forM_ times printCol
    putStrLn ""
  