module Test.QuickCheck.Simple
( Property (..)
, boolTest', boolTest
, eqTest', eqTest
, qcTest
, Test, TestError (..)
, runTest_, runTest
, defaultMain_, defaultMain, verboseMain
, defaultMain'
) where
import Control.Applicative ((<$>))
import Control.Monad (unless)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Test.QuickCheck
(Testable, Result (..), quickCheckResult, label)
import qualified Test.QuickCheck as QC
data Property
= Bool (Maybe String ) Bool
| QuickCheck QC.Property
type Test = (String , Property)
mkBoolTest :: String -> Maybe String -> Bool -> Test
mkBoolTest n m = ((,) n) . Bool m
boolTest' :: String
-> String
-> Bool
-> Test
boolTest' n m = mkBoolTest n (Just m)
boolTest :: String
-> Bool
-> Test
boolTest n = mkBoolTest n Nothing
eqTest' :: (a -> a -> Bool) -> (a -> String) -> String -> a -> a -> Test
eqTest' eq show' n x y = boolTest' n msg $ x `eq` y where
msg = unlines [show' x, "** NOT EQUALS **", show' y]
eqTest :: (Eq a, Show a) => String -> a -> a -> Test
eqTest = eqTest' (==) show
qcTest :: Testable prop
=> String
-> prop
-> Test
qcTest n = ((,) n) . QuickCheck . label n
data TestError
= BFalse (Maybe String )
| QCError Result
deriving Show
putErrorLn :: String -> IO ()
putErrorLn = putStrLn . ("*** " <>)
printVerbose :: String -> TestError -> IO ()
printVerbose lb te = case te of
BFalse m -> maybe (return ()) format m
QCError r -> format $ show r
where
format s =
mapM_ putErrorLn
$ ("label: " <> lb <> ":") : (map (" " <>) $ lines s)
runBool :: String
-> Maybe String
-> Bool
-> IO (Maybe TestError)
runBool lb vmsg = d where
d True = do
putStrLn $ "+++ OK, success (" <> lb <> ")"
return Nothing
d False = do
putErrorLn $ "Failed! (" <> lb <> ")"
let r = BFalse vmsg
printVerbose lb r
return $ Just r
runQcProp :: Bool
-> String
-> QC.Property
-> IO (Maybe TestError)
runQcProp verbose lb p = err =<< quickCheckResult p where
err (Success {}) =
return Nothing
err x = do
let r = QCError x
if verbose
then printVerbose lb r
else putErrorLn $ "label: " <> lb
return $ Just r
runProp :: Bool
-> String
-> Property
-> IO (Maybe TestError)
runProp verbose lb prop = case prop of
Bool m b -> runBool lb (if verbose then m else Nothing) b
QuickCheck p -> runQcProp verbose lb p
runTest_ :: Bool
-> Test
-> IO (Maybe TestError)
runTest_ verbose = uncurry $ runProp verbose
runTest :: Test
-> IO (Maybe TestError)
runTest = runTest_ False
defaultMain_ :: Bool -> [Test] -> IO ()
defaultMain_ verbose xs = do
es <- catMaybes <$> mapM (runTest_ verbose) xs
unless (null es) $ fail "Some failures are found."
defaultMain' :: Bool -> [Test] -> IO ()
defaultMain' = defaultMain_
{-# DEPRECATED defaultMain' "Use defaultMain_ instead of this." #-}
defaultMain :: [Test] -> IO ()
defaultMain = defaultMain_ False
verboseMain :: [Test] -> IO ()
verboseMain = defaultMain_ True