-- a quick librarification of tools/simplebench.hs for cabal benchmarking

-- #!/usr/bin/env runhaskell
{- 
bench.hs - simple benchmarking of command-line programs.
Requires html and tabular.
Simon Michael 2008-2015

Example:

$ simplebench.hs --help
...
$ cat - >bench.tests
-f sample.ledger -s balance
-f ~/.ledger -s balance
$ simplebench.hs -v hledger "ledger --no-cache" ledger
Using bench.tests
Running 2 tests 2 times in . with 3 executables at 2008-11-26 18:52:15.776357 UTC:
1: hledger -f sample.ledger -s balance	[0.02s]
2: hledger -f sample.ledger -s balance	[0.01s]
1: ledger --no-cache -f sample.ledger -s balance	[0.02s]
2: ledger --no-cache -f sample.ledger -s balance	[0.02s]
1: ledger -f sample.ledger -s balance	[0.02s]
2: ledger -f sample.ledger -s balance	[0.02s]
1: hledger -f ~/.ledger -s balance	[3.56s]
2: hledger -f ~/.ledger -s balance	[3.56s]
1: ledger --no-cache -f ~/.ledger -s balance	[0.10s]
2: ledger --no-cache -f ~/.ledger -s balance	[0.10s]
1: ledger -f ~/.ledger -s balance	[0.10s]
2: ledger -f ~/.ledger -s balance	[0.10s]

Summary (best iteration):

                            || hledger | ledger --no-cache | ledger
============================++=========+===================+=======
-f sample.ledger -s balance ||    0.01 |              0.02 |   0.02
    -f ~/.ledger -s balance ||    3.56 |              0.10 |   0.10

-}

module SimpleBench
where

import Data.List
import System.Environment
-- import System.FilePath
import System.Process
import System.IO
import Text.Tabular
import qualified Text.Tabular.AsciiArt as TA
-- import qualified Text.Tabular.Html     as TH
-- import Text.Html ((+++), renderHtml, stringToHtml)
import System.Exit
import Text.Printf
import Data.Time.Clock
import Data.Time.Format ()
import Control.Monad
import System.Console.GetOpt

usagehdr = "bench [-f testsfile] [-n iterations] [-p precision] executable1 [executable2 ...]\n" ++
           "\n" ++
           "Run some functional tests with each of the specified executables,\n" ++
           "where a test is \"zero or more arguments supported by all executables\",\n" ++
           "and report the best execution times.\n"
           
options = [
  Option "f" ["testsfile"] (ReqArg File "testsfile") "file containing tests, one per line, default: bench.tests"
 ,Option "n" ["iterations"] (ReqArg Num "iterations") "number of test iterations to run, default: 1"
 ,Option "p" ["precision"] (ReqArg Prec "precision") "show times with this precision, default: 2"
 ,Option "v" ["verbose"] (NoArg Verbose) "show intermediate results"
 ,Option "h" ["help"] (NoArg Help) "show this help"
 ]             

usageftr = "\n" ++
           "Tips:\n" ++
           "- executables may have arguments if enclosed in quotes\n" ++
           "- tests can be commented out with #\n" ++
           "- results are saved in benchresults.{html,txt}\n"

usage = usageInfo usagehdr options ++ usageftr

-- an option value
data Opt = File {value::String} 
         | Num  {value::String} 
         | Prec {value::String} 
-- I don't know how optValuesForConstructor etc. can have that 
-- type signature with these, but it works..
--       | Some Int
         | Verbose
         | Help
           deriving (Eq,Show)

-- option value getters.
fileopt :: [Opt] -> String
fileopt = optValueWithDefault File "bench.tests"

precisionopt :: [Opt] -> Int
precisionopt = read . optValueWithDefault Prec "2"

numopt :: [Opt] -> Int
numopt = read . optValueWithDefault Num "1"

verboseopt :: [Opt] -> Bool
verboseopt = (Verbose `elem`)

-- options utilities
parseargs :: [String] -> ([Opt],[String])
parseargs as =
  case (getOpt Permute options as) of
    (opts,args,[]) -> (opts,args)
    (_,_,errs)     -> error (concat errs ++ usage)

optValueWithDefault :: (String -> Opt) -> String -> [Opt] -> String
optValueWithDefault optcons def opts = 
    last $ def : optValuesForConstructor optcons opts

optValuesForConstructor :: (String -> Opt) -> [Opt] -> [String]
optValuesForConstructor optcons opts = concatMap get opts
    where get o = [v | optcons v == o] where v = value o

defaultMain = do
  args <- getArgs
  let (opts,exes) = parseargs args
  when (null exes) $ error $ "at least one executable needed\n" ++ usage
  let (file, num) = (fileopt opts, numopt opts)
  tests <- liftM (filter istest . lines) (readFile file)
  now <- getCurrentTime
  putStrLn $ printf "Using %s" file
  putStrLn $ printf "Running %d tests %d times with %d executables at %s:" 
               (length tests) num (length exes) (show now)
  let doexe t e = mapM (doiteration opts t e) [1..num]
  let dotest t = mapM (doexe t) exes
  hSetBuffering stdout NoBuffering
  results <- mapM dotest tests
  summarise opts tests exes results 

istest s = not (null s' || ("#" `isPrefixOf` s')) where s' = clean s
clean = unwords . words

doiteration :: [Opt] -> String -> String -> Int -> IO Float
doiteration opts test exe iteration = do
  let cmd = unwords [exe,clean test]
  when (verboseopt opts) $ putStr $ show iteration ++ ": " ++ cmd
  hFlush stdout
  t <- time cmd
  when (verboseopt opts) $ printf "\t[%ss]\n" (showtime opts t)
  return t

time :: String -> IO Float
time cmd = do
  t1 <- getCurrentTime
  ret <- system $ cmd ++ " >/dev/null 2>&1"
  case ret of
    ExitSuccess -> return ()
    ExitFailure f -> putStr $ printf " (error %d)" f
  t2 <- getCurrentTime
  return $ realToFrac $ diffUTCTime t2 t1

summarise :: [Opt] -> [String] -> [String] -> [[[Float]]] -> IO ()
summarise opts tests exes results = do
  putStrLn "\nSummary (best iteration):\n"
  let t = maketable opts tests exes results
  putStrLn $ TA.render id id id t
  -- let outname = "benchresults"
  -- writeFile (outname <.> "txt") $ TA.render id id id t
  -- writeFile (outname <.> "html") $ renderHtml $ TH.css TH.defaultCss +++ TH.render stringToHtml stringToHtml stringToHtml t

maketable :: [Opt] -> [String] -> [String] -> [[[Float]]] -> Table String String String
maketable opts rownames colnames results = Table rowhdrs colhdrs rows
 where
  rowhdrs = Group NoLine $ map Header $ padright rownames
  colhdrs = Group SingleLine $ map Header colnames
  rows = map (map (showtime opts . minimum)) results
  padright ss = map (printf (printf "%%-%ds" w)) ss
      where w = maximum $ map length ss

showtime :: [Opt] -> (Float -> String)
showtime opts = printf $ "%." ++ show (precisionopt opts) ++ "f"