cli: a cabal bench test that works

hledger/bench/SimpleBench.hs

@@ -0,0 +1,178 @@
+-- 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"

hledger/bench/bench.hs

@@ -0,0 +1,15 @@
+import Control.Concurrent (threadDelay)
+import SimpleBench        (defaultMain)
+import System.Environment (withArgs)
+
+main = do
+  -- expects to be run from the parent directory, as by cabal
+  withArgs [
+    "-fbench/default.bench"
+   ,"dist/build/hledger/hledger"
+   -- ,"-v"
+   ] defaultMain
+
+  -- a little delay to avoid truncation of final output by stack
+  -- in a slow-rendering terminal, such as an emacs shell
+  threadDelay 500000

hledger/bench/default.bench

@@ -0,0 +1,6 @@
+# commands to be run by simplebench (executable is specified separately)
+
+-f bench/10000x1000x10.journal print
+-f bench/10000x1000x10.journal register
+-f bench/10000x1000x10.journal balance
+-f bench/10000x1000x10.journal stats

hledger/hledger.cabal

@@ -201,11 +201,10 @@ test-suite test
     build-depends: time >= 1.5
 
 
--- not a standard cabal bench test, I think
 benchmark bench
   type:             exitcode-stdio-1.0
-  -- hs-source-dirs:   
+  hs-source-dirs:   bench
-  main-is:          ../tools/simplebench.hs
+  main-is:          bench.hs
   ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures
   ghc-options: -fno-warn-type-defaults -fno-warn-orphans
   default-language: Haskell2010

tests/bench.tests

@@ -1,34 +0,0 @@
-# tests for "make bench"
-# one command per line, without the executable
-
--f data/100x100x10.journal     balance
--f data/1000x1000x10.journal   balance
-# -f data/1000x10000x10.journal  balance
--f data/10000x1000x10.journal  balance
--f data/10000x1000x10.journal  balance aa
-# -f data/10000x10000x10.journal balance
-# -f data/100000x1000x10.journal balance
-
--f data/100x100x10.journal     register
--f data/1000x1000x10.journal   register
-# -f data/1000x10000x10.journal  register
--f data/10000x1000x10.journal  register
--f data/10000x1000x10.journal  register aa
-# -f data/10000x10000x10.journal register
-# -f data/100000x1000x10.journal register
-
--f data/100x100x10.journal     print
--f data/1000x1000x10.journal   print
-# -f data/1000x10000x10.journal  print
--f data/10000x1000x10.journal  print
--f data/10000x1000x10.journal  print aa
-# -f data/10000x10000x10.journal print
-# -f data/100000x1000x10.journal print
-
--f data/100x100x10.journal     stat
--f data/1000x1000x10.journal   stat
-# -f data/1000x10000x10.journal  stat
--f data/10000x1000x10.journal  stat
--f data/10000x1000x10.journal  stat aa
-# -f data/10000x10000x10.journal stat
-# -f data/100000x1000x10.journal stat