123 lines
3.8 KiB
Haskell
123 lines
3.8 KiB
Haskell
#!/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")
|