mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 18:29:36 +03:00
96 lines
2.8 KiB
Haskell
Executable File
96 lines
2.8 KiB
Haskell
Executable File
#!/usr/bin/env runhaskell
|
|
{- |
|
|
Extract (shell) tests from haddock comments in Haskell code, run them and
|
|
verify expected output, like Python's doctest system.
|
|
|
|
Here, a doctest is a haddock literal block whose first line begins with a
|
|
$ (leading whitespace ignored). The rest of the line is a shell command
|
|
and the remaining lines are the expected output.
|
|
|
|
Usage example: $ doctest.hs doctest.hs
|
|
|
|
Doctest examples:
|
|
|
|
@
|
|
$ ls doctest.hs
|
|
This doctest will fail.
|
|
@
|
|
|
|
@
|
|
$ ls doctest.hs
|
|
doctest.hs
|
|
@
|
|
|
|
Issues:
|
|
|
|
After writing this I found the doctest on hackage; that one runs haskell
|
|
expressions in comments, converting them to hunit tests. We might add this
|
|
to that, and/or add this to hledger's built-in test runner.
|
|
|
|
Error output seems to vary depending on whether things are compiled, eg:
|
|
hledger: parse error at (line 1, column 4)
|
|
vs:
|
|
"-" (line 2, column 1)
|
|
ledger-style functional tests may be more useful for this, see functest.hs.
|
|
|
|
-}
|
|
|
|
module Main where
|
|
import Data.List (isPrefixOf)
|
|
import System (getArgs)
|
|
import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible
|
|
import System.IO (hGetContents, hPutStr, hPutStrLn, stderr)
|
|
import System.Process (runInteractiveCommand, waitForProcess)
|
|
import Text.Printf (printf)
|
|
|
|
main = do
|
|
f <- head `fmap` getArgs
|
|
s <- readFile f
|
|
let tests = doctests s
|
|
putStrLn $ printf "Running %d doctests from %s" (length tests) f
|
|
ok <- mapM runShellDocTest $ doctests s
|
|
if any not ok then exitFailure else exitWith ExitSuccess
|
|
|
|
runShellDocTest :: String -> IO Bool
|
|
runShellDocTest s = do
|
|
let (cmd, expected) = splitDocTest s
|
|
putStr $ printf "Testing: %s .. " cmd
|
|
(_, out, _, h) <- runInteractiveCommand cmd
|
|
exit <- waitForProcess h
|
|
output <- hGetContents out
|
|
if exit == ExitSuccess
|
|
then
|
|
if output == expected
|
|
then do
|
|
putStrLn "ok"
|
|
return True
|
|
else do
|
|
hPutStr stderr $ printf "FAILED\nExpected:\n%sGot:\n%s" expected output
|
|
return False
|
|
else do
|
|
hPutStrLn stderr $ printf "ERROR: %s" (show exit)
|
|
return False
|
|
|
|
splitDocTest s = (strip $ drop 1 $ strip $ head ls, unlines $ tail ls)
|
|
where ls = lines s
|
|
|
|
-- extract doctests from haskell source code
|
|
doctests :: String -> [String]
|
|
doctests s = filter isDocTest $ haddockLiterals s
|
|
where
|
|
isDocTest = (("$" `isPrefixOf`) . dropws) . head . lines
|
|
|
|
-- extract haddock literal blocks from haskell source code
|
|
haddockLiterals :: String -> [String]
|
|
haddockLiterals "" = []
|
|
haddockLiterals s | null lit = []
|
|
| otherwise = lit : haddockLiterals rest
|
|
where
|
|
ls = drop 1 $ dropWhile (not . isLiteralBoundary) $ lines s
|
|
lit = unlines $ takeWhile (not . isLiteralBoundary) ls
|
|
rest = unlines $ drop 1 $ dropWhile (not . isLiteralBoundary) ls
|
|
isLiteralBoundary = (== "@") . strip
|
|
|
|
strip = dropws . reverse . dropws . reverse
|
|
dropws = dropWhile (`elem` " \t")
|