mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-16 00:37:33 +03:00
98 lines
2.8 KiB
Haskell
Executable File
98 lines
2.8 KiB
Haskell
Executable File
#!/usr/bin/env stack
|
|
{- stack script --resolver nightly-2021-12-16 --compile
|
|
-}
|
|
-- add this to see packages being installed instead of a long silence:
|
|
-- --verbosity=info
|
|
--package base-prelude
|
|
--package directory
|
|
--package extra
|
|
--package process
|
|
--package regex
|
|
--package safe
|
|
--package shake
|
|
--package time
|
|
|
|
{- |
|
|
Extract (shell) tests from haddock comments in Haskell code, run them and
|
|
verify expected output. Like https://hackage.haskell.org/package/doctest,
|
|
but tests shell commands instead of GHCI commands.
|
|
|
|
A docshelltest 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. The exit code is expected
|
|
to be zero.
|
|
|
|
Usage example: $ doctest.hs doctest.hs
|
|
|
|
@
|
|
$ echo This test shall pass
|
|
This test shall pass
|
|
@
|
|
|
|
@
|
|
$ echo This test shall fail
|
|
|
|
@
|
|
|
|
-}
|
|
|
|
module Main where
|
|
import Data.List (isPrefixOf)
|
|
import System.Environment (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
|
|
putStrLn ""
|
|
if all ok then exitSuccess else exitFailure
|
|
|
|
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")
|