{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
import Test.Simple
import System.Environment (getArgs)
import System.Environment.Executable (getExecutablePath)
import System.Process (readProcessWithExitCode)
import Control.Monad.Trans (liftIO, lift)
import System.Exit (ExitCode(ExitSuccess))
import Control.Monad (guard)
import Test.QuickCheck (Gen, arbitrary, choose, stdArgs, quickCheckWithResult, Args(maxSuccess))
import Test.QuickCheck.Monadic
locTest :: TestSimpleT IO Bool
locTest = $loc >> ok False
testOk1 :: ExitCode -> String -> String -> TestSimpleT IO Bool
testOk1 ec out err = do
is ec ExitSuccess
is out "1..1\nok 1\n"
is err ""
testUnknown :: ExitCode -> String -> String -> TestSimpleT IO Bool
testUnknown ec out err = do
isnt ec ExitSuccess
is out ""
like err "Unknown"
testNOk1 :: ExitCode -> String -> String -> TestSimpleT IO Bool
testNOk1 ec out err = do
isnt ec ExitSuccess
like out "not ok 1"
like err "# Hello\n"
testMismatch :: ExitCode -> String -> String -> TestSimpleT IO Bool
testMismatch ec _ err = do
isnt ec ExitSuccess
is err "# Looks like you planned 2 tests but ran 1.\n"
testIsFailure :: ExitCode -> String -> String -> TestSimpleT IO Bool
testIsFailure ec _ err = do
isnt ec ExitSuccess
like err " got: 1\n"
like err "expected: 2\n"
testLikeFailure :: ExitCode -> String -> String -> TestSimpleT IO Bool
testLikeFailure ec _ err = do
isnt ec ExitSuccess
like err "# \"a\"\n"
like err "# doesn't match \"b\"\n"
testUnlikeFailure :: ExitCode -> String -> String -> TestSimpleT IO Bool
testUnlikeFailure ec _ err = do
isnt ec ExitSuccess
like err "# \"abc\""
like err "# matches \"b\"\n"
testLocationPrint :: ExitCode -> String -> String -> TestSimpleT IO Bool
testLocationPrint ec _ err = do
isnt ec ExitSuccess
like err " Failed test at tests/Main.hs line 14"
like err "# Looks like you failed 1 test of 1.\n"
testMPlus :: ExitCode -> String -> String -> TestSimpleT IO Bool
testMPlus ec out err = do
is ec ExitSuccess
is err ""
like out "1..2"
testMPlusFail :: ExitCode -> String -> String -> TestSimpleT IO Bool
testMPlusFail ec out err = do
isnt ec ExitSuccess
like err "failed 1 test of 2"
like out "1..2"
testGuard :: ExitCode -> String -> String -> TestSimpleT IO Bool
testGuard ec out err = do
isnt ec ExitSuccess
like out "1..1"
unlike err "DIAG"
like err "# got: 1\n"
like err "# expected: anything else\n"
testEither :: ExitCode -> String -> String -> TestSimpleT IO Bool
testEither ec out err = do
isnt ec ExitSuccess
like out "1..2"
like out "ok 1"
like err "got Left: \"badleft\""
testRunTS :: ExitCode -> String -> String -> TestSimpleT IO Bool
testRunTS ec out err = do
is ec ExitSuccess
is err ""
is out "True\n1..1\n# Bar\nok 1\n"
testQCOK :: Int -> ExitCode -> String -> String -> TestSimpleT IO Bool
testQCOK n ec out _ = do
is ec ExitSuccess
is out $ "+++ OK, passed " ++ show n ++ " tests.\n"
testQCFail :: ExitCode -> String -> String -> TestSimpleT IO Bool
testQCFail ec out _ = do
isnt ec ExitSuccess
like out "not ok 2"
like out "Failed! 1..2"
like out "# Foo: False at unknown location."
testPropFail :: ExitCode -> String -> String -> TestSimpleT IO Bool
testPropFail ec out _ = do
isnt ec ExitSuccess
like out "not ok 1"
like out "Failed! Assertion"
testAll :: IO ()
testAll = testSimpleMain $ do
plan 58
pn <- liftIO getExecutablePath
mapM_ (runMyself pn) [ ("bbbf", testUnknown), ("ok1", testOk1), ("nok1", testNOk1)
, ("mism", testMismatch), ("isf", testIsFailure)
, ("likef", testLikeFailure), ("qloc", testLocationPrint)
, ("unlike", testOk1), ("fail_unlike", testUnlikeFailure)
, ("guard", testOk1), ("mplus", testMPlus), ("fail_mplus", testMPlusFail)
, ("guardisnt", testGuard), ("either", testEither)
, ("runts", testRunTS), ("qcrunok", testQCOK 100), ("qcfail", testQCFail)
, ("qcmonok", testQCOK 5), ("qcmonfail", testPropFail) ]
where runMyself pn (arg, act) = do
(ec, out, err) <- liftIO $ readProcessWithExitCode pn [ arg ] ""
act ec out err
identTS :: TestSimpleT Gen ()
identTS = plan 1 >> ok True >> return ()
propMon :: TestSimpleT (PropertyM IO) ()
propMon = plan 1 >> ok True >> return ()
failQC :: TestSimpleT Gen Bool
failQC = do
plan 2
i <- lift $ choose (1 :: Int, 5)
ok (i > 0)
b <- diagen "Foo" arbitrary
ok b
propFail :: TestSimpleT (PropertyM IO) Bool
propFail = do
plan 1
ok False
main :: IO ()
main = do
as <- getArgs
case as of
[] -> testAll
[ "ok1" ] -> testSimpleMain $ plan 1 >> ok True
[ "nok1" ] -> testSimpleMain $ plan 1 >> diag "Hello" >> ok False
[ "mism" ] -> testSimpleMain $ ok True >> plan 2
[ "isf" ] -> testSimpleMain $ is 1 (2::Int) >> plan 1
[ "likef" ] -> testSimpleMain $ plan 1 >> like "a" "b"
[ "qloc" ] -> testSimpleMain $ plan 1 >> locTest
[ "unlike" ] -> testSimpleMain $ plan 1 >> unlike "abc" "d"
[ "fail_unlike" ] -> testSimpleMain $ unlike "abc" "b"
[ "guard" ] -> testSimpleMain $ plan 1 >> ok True >> guard False >> ok False
[ "mplus" ] -> testSimpleMain $ (plan 1 >> ok True) >> (plan 1 >> ok True)
[ "fail_mplus" ] -> testSimpleMain $ (plan 1 >> ok False) >> (plan 1 >> ok True)
[ "guardisnt" ] -> testSimpleMain $ plan 1 >> (isnt (1::Int) 1 >>= guard) >> diag "DIAG"
[ "either" ] -> testSimpleMain $ do
plan 2
isRight (Right "hhh" :: Either Int String)
isRight (Left "badleft" :: Either String Int)
[ "runts" ] -> do
(b, lg) <- runTestSimple $ plan 1 >> diag "Bar" >> ok True
putStrLn $ show b
mapM_ putStrLn lg
[ "qcrunok" ] -> qcTestSimpleMain identTS
[ "qcfail" ] -> qcTestSimpleMain failQC
[ "qcmonok" ] -> qcTestSimpleWith (quickCheckWithResult $ stdArgs { maxSuccess = 5 })
propMon
[ "qcmonfail" ] -> qcTestSimpleMain propFail
_ -> error $ "Unknown: " ++ show as