-- |
-- Module      : Test.QuickCheck.Simple
-- Copyright   : 2015-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module contains definitions of test properties and default-mains
-- using QuickCheck library.
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


-- | Property type. 'Bool' or 'Testable' of QuickCheck.
data Property
  = Bool (Maybe String {- verbose error message -}) Bool
  | QuickCheck QC.Property

-- | Property with label string
type Test = (String {- label -}, Property)

mkBoolTest :: String -> Maybe String -> Bool -> Test
mkBoolTest :: String -> Maybe String -> Bool -> Test
mkBoolTest n :: String
n m :: Maybe String
m = ((,) String
n) (Property -> Test) -> (Bool -> Property) -> Bool -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Bool -> Property
Bool Maybe String
m

-- | 'Bool' specialized property with message for False case
boolTest' :: String
          -> String
          -> Bool
          -> Test
boolTest' :: String -> String -> Bool -> Test
boolTest' n :: String
n m :: String
m = String -> Maybe String -> Bool -> Test
mkBoolTest String
n (String -> Maybe String
forall a. a -> Maybe a
Just String
m)

-- | 'Bool' specialized property
boolTest :: String
         -> Bool
         -> Test
boolTest :: String -> Bool -> Test
boolTest n :: String
n = String -> Maybe String -> Bool -> Test
mkBoolTest String
n Maybe String
forall a. Maybe a
Nothing

-- | 'Eq' specialized property with explicit passing
eqTest' :: (a -> a -> Bool) -> (a -> String) -> String -> a -> a -> Test
eqTest' :: (a -> a -> Bool) -> (a -> String) -> String -> a -> a -> Test
eqTest' eq :: a -> a -> Bool
eq show' :: a -> String
show' n :: String
n x :: a
x y :: a
y = String -> String -> Bool -> Test
boolTest' String
n String
msg (Bool -> Test) -> Bool -> Test
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> Bool
`eq` a
y where
  msg :: String
msg = [String] -> String
unlines [a -> String
show' a
x, "** NOT EQUALS **", a -> String
show' a
y]

-- | 'Eq' specialized property
eqTest :: (Eq a, Show a) => String -> a -> a -> Test
eqTest :: String -> a -> a -> Test
eqTest = (a -> a -> Bool) -> (a -> String) -> String -> a -> a -> Test
forall a.
(a -> a -> Bool) -> (a -> String) -> String -> a -> a -> Test
eqTest' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) a -> String
forall a. Show a => a -> String
show

-- | QuickCheck 'Testable' property
qcTest :: Testable prop
       => String
       -> prop
       -> Test
qcTest :: String -> prop -> Test
qcTest n :: String
n = ((,) String
n) (Property -> Test) -> (prop -> Property) -> prop -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Property
QuickCheck (Property -> Property) -> (prop -> Property) -> prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> prop -> Property
forall prop. Testable prop => String -> prop -> Property
label String
n

--------------------------------------------------------------------------------

-- | Test failure result.
data TestError
  = BFalse (Maybe String {- verbose error message -})
  | QCError Result
  deriving Int -> TestError -> ShowS
[TestError] -> ShowS
TestError -> String
(Int -> TestError -> ShowS)
-> (TestError -> String)
-> ([TestError] -> ShowS)
-> Show TestError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestError] -> ShowS
$cshowList :: [TestError] -> ShowS
show :: TestError -> String
$cshow :: TestError -> String
showsPrec :: Int -> TestError -> ShowS
$cshowsPrec :: Int -> TestError -> ShowS
Show

putErrorLn :: String -> IO ()
putErrorLn :: String -> IO ()
putErrorLn = String -> IO ()
putStrLn (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("*** " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)

printVerbose :: String -> TestError -> IO ()
printVerbose :: String -> TestError -> IO ()
printVerbose lb :: String
lb te :: TestError
te = case TestError
te of
    BFalse m :: Maybe String
m   ->  IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
format Maybe String
m
    QCError r :: Result
r  ->  String -> IO ()
format (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Result -> String
forall a. Show a => a -> String
show Result
r
  where
    format :: String -> IO ()
format s :: String
s =
      (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putErrorLn
      ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ ("label: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
lb String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ":") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s)

runBool :: String
        -> Maybe String -- ^ verbose error message. Nothing corresponds to not verbose.
        -> Bool
        -> IO (Maybe TestError)
runBool :: String -> Maybe String -> Bool -> IO (Maybe TestError)
runBool lb :: String
lb vmsg :: Maybe String
vmsg = Bool -> IO (Maybe TestError)
d  where
  d :: Bool -> IO (Maybe TestError)
d True  =  do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "+++ OK, success (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
lb String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ")"
    Maybe TestError -> IO (Maybe TestError)
forall (m :: * -> *) a. Monad m => a -> m a
return   Maybe TestError
forall a. Maybe a
Nothing
  d False =  do
    String -> IO ()
putErrorLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Failed! (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
lb String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ")"
    let r :: TestError
r = Maybe String -> TestError
BFalse Maybe String
vmsg
    String -> TestError -> IO ()
printVerbose String
lb TestError
r
    Maybe TestError -> IO (Maybe TestError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestError -> IO (Maybe TestError))
-> Maybe TestError -> IO (Maybe TestError)
forall a b. (a -> b) -> a -> b
$ TestError -> Maybe TestError
forall a. a -> Maybe a
Just TestError
r

runQcProp :: Bool -- ^ verbose flag
          -> String
          -> QC.Property
          -> IO (Maybe TestError)
runQcProp :: Bool -> String -> Property -> IO (Maybe TestError)
runQcProp verbose :: Bool
verbose lb :: String
lb p :: Property
p = Result -> IO (Maybe TestError)
err (Result -> IO (Maybe TestError))
-> IO Result -> IO (Maybe TestError)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Property -> IO Result
forall prop. Testable prop => prop -> IO Result
quickCheckResult Property
p  where
  err :: Result -> IO (Maybe TestError)
err (Success {})  =
    Maybe TestError -> IO (Maybe TestError)
forall (m :: * -> *) a. Monad m => a -> m a
return   Maybe TestError
forall a. Maybe a
Nothing
  err x :: Result
x             =  do
    let r :: TestError
r = Result -> TestError
QCError Result
x
    if Bool
verbose
      then String -> TestError -> IO ()
printVerbose String
lb TestError
r            -- this action show label
      else String -> IO ()
putErrorLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "label: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
lb -- quickcheck does not show label
    Maybe TestError -> IO (Maybe TestError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestError -> IO (Maybe TestError))
-> Maybe TestError -> IO (Maybe TestError)
forall a b. (a -> b) -> a -> b
$ TestError -> Maybe TestError
forall a. a -> Maybe a
Just TestError
r

runProp :: Bool
         -> String
         -> Property
         -> IO (Maybe TestError)
runProp :: Bool -> String -> Property -> IO (Maybe TestError)
runProp verbose :: Bool
verbose lb :: String
lb prop :: Property
prop = case Property
prop of
  Bool m :: Maybe String
m b :: Bool
b      ->  String -> Maybe String -> Bool -> IO (Maybe TestError)
runBool String
lb (if Bool
verbose then Maybe String
m else Maybe String
forall a. Maybe a
Nothing) Bool
b
  QuickCheck p :: Property
p  ->  Bool -> String -> Property -> IO (Maybe TestError)
runQcProp Bool
verbose String
lb Property
p

-- | Run a single test suite.
runTest_ :: Bool                 -- ^ verbose flag
         -> Test                 -- ^ property to test
         -> IO (Maybe TestError) -- ^ result action, and may be failure result
runTest_ :: Bool -> Test -> IO (Maybe TestError)
runTest_ verbose :: Bool
verbose = (String -> Property -> IO (Maybe TestError))
-> Test -> IO (Maybe TestError)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((String -> Property -> IO (Maybe TestError))
 -> Test -> IO (Maybe TestError))
-> (String -> Property -> IO (Maybe TestError))
-> Test
-> IO (Maybe TestError)
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Property -> IO (Maybe TestError)
runProp Bool
verbose

-- | Not verbose version of runTest_
runTest :: Test                 -- ^ property to test
        -> IO (Maybe TestError) -- ^ result action, and may be failure result
runTest :: Test -> IO (Maybe TestError)
runTest = Bool -> Test -> IO (Maybe TestError)
runTest_  Bool
False

-- | Default main to run test suites.
defaultMain_ :: Bool -> [Test] -> IO ()
defaultMain_ :: Bool -> [Test] -> IO ()
defaultMain_ verbose :: Bool
verbose xs :: [Test]
xs = do
  [TestError]
es <- [Maybe TestError] -> [TestError]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TestError] -> [TestError])
-> IO [Maybe TestError] -> IO [TestError]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Test -> IO (Maybe TestError)) -> [Test] -> IO [Maybe TestError]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Test -> IO (Maybe TestError)
runTest_ Bool
verbose) [Test]
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TestError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestError]
es) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Some failures are found."

defaultMain' :: Bool -> [Test] -> IO ()
defaultMain' :: Bool -> [Test] -> IO ()
defaultMain' = Bool -> [Test] -> IO ()
defaultMain_
{-# DEPRECATED defaultMain' "Use defaultMain_ instead of this." #-}

-- | Not verbose version of 'defaultMain''.
defaultMain :: [Test] -> IO ()
defaultMain :: [Test] -> IO ()
defaultMain = Bool -> [Test] -> IO ()
defaultMain_ Bool
False

-- | Verbose verison of defaultMain
verboseMain :: [Test] -> IO ()
verboseMain :: [Test] -> IO ()
verboseMain = Bool -> [Test] -> IO ()
defaultMain_ Bool
True