"make bench" runs some benchmark tests and saves results

Makefile

@@ -29,6 +29,10 @@ test:
 	@./hledger.hs test
 	@./regtest.py
 
+# run performance benchmarks and save results in profs
+bench:
+	tools/bench.hs bench.tests 2 hledger ledger "ledger --no-cache" | tee profs/`date +%Y%m%d%H%M%S`.bench
+
 VERSION=`grep 'versionno =' Options.hs | perl -pe 's/.*"(.*?)"/\1/'`
 release:
 	cabal sdist && darcs tag $(VERSION) && cabal upload dist/hledger-$(VERSION).tar.gz

NOTES

@@ -18,7 +18,6 @@ clever tricks like the plague." --Edsger Dijkstra
 *** ~/.hledgerrc, for setting defaults
 *** more ledger features from README (?)
 *** speed
-**** easy benchmarking
 **** speed regression tests
 **** easy profiling
 **** cache file ?

bench.tests

@@ -0,0 +1,6 @@
+# see tools/bench.hs
+
+-f sample.ledger register
+-f sample.ledger -s balance
+-f ~/.ledger register
+-f ~/.ledger -s balance

tools/bench.hs

@@ -0,0 +1,125 @@
+#!/usr/bin/env runhaskell
+{- 
+bench.hs (see usage string below). 
+
+For simple benchmarking. Similar to my darcs-benchmark/bench.hs script.
+Example:
+
+$ cat - >bench.tests
+-f sample.ledger -s balance
+-f ~/.ledger -s balance
+$ bench.hs bench.tests 2 hledger "ledger --no-cache" ledger
+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
+
+-}
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import Numeric
+import System.Environment
+import System.Directory
+import System.FilePath
+import System.Cmd
+import System.IO
+import Text.Tabular
+import qualified Text.Tabular.AsciiArt as TA
+import qualified Text.Tabular.Html     as TH
+import Text.Html ((+++), renderHtml)
+import System.Exit
+import Text.Printf
+import Data.Time.Clock
+import Data.Time.Format
+import System.Locale
+import Control.Monad
+import Debug.Trace
+
+
+
+usage = "bench.hs <testsfile> <num> [<executable> ...]\n" ++
+        "\n" ++
+        "Run some functional tests, defined as lines of arguments in\n" ++
+        "testsfile, num times with each of the specified executables,\n" ++
+        "printing the execution times and a summary.\n" ++
+        "Tips:\n" ++
+        "- comment out tests with #\n"
+
+precision = 2
+
+main = do
+  (testsfile,iterations,dir,exes) <- getArgs >>= return . parseargs
+  tests <- readFile testsfile >>= return . testlines
+  now <- getCurrentTime
+  putStrLn $ printf "Running %d tests %d times in %s with %d executables at %s:\n" 
+               (length tests) (iterations) dir (length exes) (show now)
+  let doexe t e = sequence $ map (doiteration t e dir) [1..iterations]
+  let dotest t = sequence $ map (doexe t) exes
+  hSetBuffering stdout NoBuffering
+  results <- mapM dotest tests
+  summarise tests exes results 
+    where 
+--       parseargs (t:n:d:[]) = parseargs (t:n:d:["darcs"])
+      parseargs (t:n:es) = (t,read n,".",es)
+      parseargs _ = error $ "\n" ++ usage
+      testlines s = filter istest $ map clean $ lines s
+      istest s = not (null s || ("#" `isPrefixOf` s))
+      clean = unwords . words
+
+doiteration :: String -> String -> String -> Int -> IO Float
+doiteration test exe dir iteration = do
+  let cmd = unwords [exe,test]
+  putStr $ show iteration ++ ": " ++ cmd
+  hFlush stdout
+  t <- time cmd
+  printf "\t[%ss]\n" (showtime 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 tests exes results = do
+  -- putStrLn ""; print results
+  putStrLn "\nSummary (best iteration):\n"
+  let t = maketable tests exes results
+  putStrLn $ TA.render id t
+  -- putStrLn $ "See " ++ prefix ++ "summary.*"
+  let outname = "summary"
+  writeFile (outname <.> "txt") $ TA.render id t
+  writeFile (outname <.> "html") $ renderHtml $ TH.css TH.defaultCss +++ TH.render id t
+
+maketable :: [String] -> [String] -> [[[Float]]] -> Table String
+maketable rownames colnames results = Table rowhdrs colhdrs rows
+ where
+  rowhdrs = Group NoLine $ map Header rownames
+  colhdrs = Group SingleLine $ map Header colnames
+  rows = map (map (showtime . minimum)) results
+
+showtime = printf $ "%."++(show precision)++"f"
+
+strace a = trace (show a) a