module Test.QuickCheck.Simple
( Property (..)
, boolTest', boolTest
, eqTest', eqTest
, qcTest
, Test, TestError (..)
, runTest
, defaultMain', defaultMain
) where
import Control.Applicative ((<$>))
import Control.Monad (when, unless)
import Data.Maybe (fromMaybe, 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)
data TestError
= BFalse (Maybe String)
| QCError Result
deriving Show
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
putErrorLn :: String -> IO ()
putErrorLn = putStrLn . ("*** " <>)
runBool :: String -> Maybe String -> Bool -> IO (Maybe TestError)
runBool n m = d where
d True = do
putStrLn $ "+++ OK, success (" <> n <> ")"
return Nothing
d False = do
putErrorLn $ "Failed! (" <> n <> ")"
return . Just $ BFalse m
runQcProp :: String -> QC.Property -> IO (Maybe TestError)
runQcProp n p = err =<< quickCheckResult p where
err (Success {}) =
return Nothing
err x = do
putErrorLn $ " label: " <> n
return . Just $ QCError x
runProp :: String -> Property -> IO (Maybe TestError)
runProp n = d where
d (Bool m b) = runBool n m b
d (QuickCheck p) = runQcProp n p
runTest :: Test
-> IO (Maybe TestError)
runTest = uncurry runProp
runPropL :: String -> Property -> IO (Maybe (String, TestError))
runPropL n p = do
me <- runProp n p
return $ fmap ((,) n) me
showTestError :: TestError -> String
showTestError = d where
d (BFalse m) = fromMaybe "" m
d (QCError r) = show r
defaultMain' :: Bool -> [Test] -> IO ()
defaultMain' verbose xs = do
es <- catMaybes <$> mapM (uncurry runPropL) xs
let rlines m r = (m <> ":") : [ " " <> x | x <- lines $ showTestError r ]
when verbose $ mapM_ (\(m, r) -> mapM_ putStrLn $ rlines m r) es
unless (null es) $ fail "Some failures are found."
defaultMain :: [Test] -> IO ()
defaultMain = defaultMain' False