add a shell test runner like ledger's, and "make functest" rule

Makefile

@@ -87,6 +87,10 @@ tools/bench: tools/bench.hs
 tools/doctest: tools/doctest.hs
 	ghc --make tools/doctest.hs
 
+# build the shell test runner
+tools/shelltest: tools/shelltest.hs
+	ghc --make -threaded tools/shelltest.hs
+
 # build the generateledger tool
 tools/generateledger: tools/generateledger.hs
 	ghc --make tools/generateledger.hs
@@ -112,6 +116,11 @@ unittest:
 	@(runghc hledger.hs test \
 		&& echo $@ passed) || echo $@ FAILED
 
+# run functional tests
+functest: tools/shelltest
+	@(tools/shelltest tests/*.test \
+		&& echo $@ passed) || echo $@ FAILED
+
 # run doc tests
 doctest: tools/doctest
 	@(tools/doctest Commands/Add.hs >/dev/null \

tools/shelltest.hs

@@ -0,0 +1,122 @@
+#!/usr/bin/env runhaskell
+{-
+
+Run one or more hledger command-line tests, specified by .test files like
+those used in the ledger project. A ledger-style .test file contains a
+partial command line, input, expected output, expected error output, and
+expected exit code separated by delimiters.
+
+Usage: $ shelltest *.test
+
+Here is the .test file format:
+@
+--option1 arg1 arg2
+<<<
+lines of
+input
+>>>
+expected
+output
+>>>2
+expected
+error output
+===0
+;
+; Lines whose first non-whitespace character is ; are ignored.
+; The first line is the command line. "hledger" is prepended, and "-f-" is
+; appended unless there is a -f or <... argument (in which case the
+; provided input is ignored.)
+; Then there is a line containing <<< and 0 or more lines of input.
+; Then a line containing >>> (or >>>1 for ledger testrunner compatibility)
+; and 0 or more lines of expected output.
+; Then a line containing >>>2 and 0 or more lines of expected stderr output.
+; Then === and the expected exit code (on the same line).
+@
+-}
+
+module Main where
+import System (getArgs)
+import System.Exit (exitFailure, exitWith, ExitCode(..))
+import System.IO (hGetContents, hPutStr, hFlush, stderr, stdout)
+import System.Process (runInteractiveCommand, waitForProcess)
+import Text.Printf (printf)
+import Text.ParserCombinators.Parsec
+import Control.Monad (liftM,when)
+
+exe :: String
+exe = "hledger"
+
+data ShellTest = ShellTest {
+     command          :: String
+    ,stdin            :: String
+    ,stdoutExpected   :: String
+    ,stderrExpected   :: String
+    ,exitCodeExpected :: ExitCode
+    } deriving (Show)
+
+main :: IO ()
+main = do
+  files <- getArgs
+  ok <-  mapM (\f -> parseShellTest f >>= runShellTest) files
+  if any not ok then exitFailure else exitWith ExitSuccess
+
+parseShellTest :: FilePath -> IO ShellTest
+parseShellTest = liftM (either (error.show) id) . parseFromFile shelltest
+
+shelltest :: Parser ShellTest
+shelltest = do
+  c <- line; string "<<<\n"
+  i <- line `manyTill` (string ">>>" >> optional (char '1') >> char '\n')
+  o <- line `manyTill` (string ">>>2\n")
+  e <- line `manyTill` (string "===")
+  x <- line
+  let x' = read x -- `catch` (\e -> fail (show e))
+  eof
+  return ShellTest{command=c,stdin=unlines i,stdoutExpected=unlines o,stderrExpected=unlines e,exitCodeExpected=toExitCode x'}
+
+line :: Parser String
+line = do
+  l <- anyChar `manyTill` newline
+  if take 1 (strip l) == ";"
+   then line
+   else return l
+
+runShellTest :: ShellTest -> IO Bool
+runShellTest ShellTest{
+    command=c,stdin=i,stdoutExpected=o,stderrExpected=e,exitCodeExpected=x} = do
+  let cmd = unwords [exe,c,if (any isinputarg $ words c) then "" else "-f-"]
+            where isinputarg a = take 2 a == "-f" || (take 1 a == "<")
+  printf "Testing: %s" cmd; hFlush stdout
+  (ih,oh,eh,ph) <- runInteractiveCommand cmd
+  hPutStr ih i
+  out <- hGetContents oh
+  err <- hGetContents eh
+  exit <- waitForProcess ph
+  let (outputok, errorok, exitok) = (out==o, err==e, exit==x)
+  if outputok && errorok && exitok 
+   then do
+     putStrLn " .. ok"
+     return True 
+   else do
+     hPutStr stderr $ printf " .. FAIL\n"
+     when (not outputok) $ printExpectedActual "stdout" o out
+     when (not errorok)  $ printExpectedActual "stderr" e err
+     when (not exitok)   $ printExpectedActual "exit code" (show (fromExitCode x)++"\n") (show (fromExitCode exit)++"\n")
+     return False
+
+printExpectedActual :: String -> String -> String -> IO ()
+printExpectedActual f e a = hPutStr stderr $ printf "**Expected %s:\n%s**Got:\n%s" f e a
+
+toExitCode :: Int -> ExitCode
+toExitCode 0 = ExitSuccess
+toExitCode n = ExitFailure n
+
+fromExitCode :: ExitCode -> Int
+fromExitCode ExitSuccess     = 0
+fromExitCode (ExitFailure n) = n
+
+strip,lstrip,rstrip,dropws :: String -> String
+strip = lstrip . rstrip
+lstrip = dropws
+rstrip = reverse . dropws . reverse
+dropws = dropWhile (`elem` " \t")