Minimal Haskell Unit Testing Framework

Question

I'm trying to come up with a unit testing framework for Haskell that is

• small and self-contained
• produces TAP-compatible output
• exits abnormally on failure (instead of relying on the TAP consumer to validate all the output).
• has a simple API with easy to understand compile-time errors. (That's the motivation for committing to concrete types in the interface).

With that in mind, this is what I came up with:

I'm mainly looking for things that

• are not idiomatic Haskell
• would hamper usability in very small to small projects in The Real World.

---

module TestTrivial
    ( tests
    ) where

import System.Exit (exitSuccess, exitFailure)

testsImpl :: [(Bool, String)] -> Int -> Bool -> IO ()
testsImpl [] nextTest status =
    putStrLn ("1.." ++ show (nextTest - 1)) <> doExit where
        doExit = if status then exitSuccess else exitFailure
testsImpl ((cond, msg):xs) nextTest success =
    putStrLn msg' <> rest where
        ok = if cond then "ok" else "not ok"
        num = show nextTest
        f [] = unwords [ok, num]
        f m  = unwords [ok, num, "-", msg]
        msg' = f msg
        rest = testsImpl xs (nextTest + 1) (success && cond)


tests :: [(Bool, String)] -> IO ()
tests xs = testsImpl xs 1 True

And here's an example test suite using this library.

module TestAdd where

import TestTrivial

main = tests
    [ (1 + 4 == 5, "1 + 4 == 5")
    , (5 + 6 /= 7, "5 + 6 /= 7")
    ]

And what it produces. ... Despite the - sign separating the test number from the message and how strange that looks here, the output is formatted correctly.

ok 1 - 1 + 4 == 5
ok 2 - 5 + 6 /= 7
1..2

Answer 1

Replace explicit recursion with library combinators. Unduplicate and inline as much as possible.

testImpl :: Int -> (Bool, String) -> String 
testImpl i (cond, msg) = unwords $
  [ if cond then "ok" else "not ok"
  , show i
  ] ++ case msg of [] -> []; m -> ["-", m]

tests :: [(Bool, String)] -> IO ()
tests xs = do
  putStrLn $ unlines $ zipWith testImpl [1..] xs
  putStrLn $ "1.." ++ show (length xs)
  if all fst xs then exitSuccess else exitFailure