-- | Functions for introducing QuickCheck tests into a Sandwich test tree. Modelled after Hspec's version.
--
-- Documentation can be found <https://codedownio.github.io/sandwich/docs/extensions/sandwich-quickcheck here>.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}

module Test.Sandwich.QuickCheck (
  -- * Introducing QuickCheck args
  -- Any tests that use QuickCheck should be wrapped in one of these.
  introduceQuickCheck
  , introduceQuickCheck'
  , introduceQuickCheck''

  -- * Prop
  , prop

  -- * Modifying QuickCheck args
  , modifyArgs
  , modifyMaxSuccess
  , modifyMaxDiscardRatio
  , modifyMaxSize
  , modifyMaxShrinks
  ) where

import Control.Exception.Safe
import Control.Monad.Free
import Control.Monad.IO.Class
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.Text as T
import GHC.Stack
import Test.QuickCheck as QC
import Test.Sandwich
import Test.Sandwich.Internal


data QuickCheckContext = QuickCheckContext Args
  deriving Int -> QuickCheckContext -> ShowS
[QuickCheckContext] -> ShowS
QuickCheckContext -> String
(Int -> QuickCheckContext -> ShowS)
-> (QuickCheckContext -> String)
-> ([QuickCheckContext] -> ShowS)
-> Show QuickCheckContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QuickCheckContext] -> ShowS
$cshowList :: [QuickCheckContext] -> ShowS
show :: QuickCheckContext -> String
$cshow :: QuickCheckContext -> String
showsPrec :: Int -> QuickCheckContext -> ShowS
$cshowsPrec :: Int -> QuickCheckContext -> ShowS
Show
quickCheckContext :: Label "quickCheckContext" QuickCheckContext
quickCheckContext = Label "quickCheckContext" QuickCheckContext
forall k (l :: Symbol) (a :: k). Label l a
Label :: Label "quickCheckContext" QuickCheckContext
type HasQuickCheckContext context = HasLabel context "quickCheckContext" QuickCheckContext

data QuickCheckException = QuickCheckException
  deriving (Int -> QuickCheckException -> ShowS
[QuickCheckException] -> ShowS
QuickCheckException -> String
(Int -> QuickCheckException -> ShowS)
-> (QuickCheckException -> String)
-> ([QuickCheckException] -> ShowS)
-> Show QuickCheckException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QuickCheckException] -> ShowS
$cshowList :: [QuickCheckException] -> ShowS
show :: QuickCheckException -> String
$cshow :: QuickCheckException -> String
showsPrec :: Int -> QuickCheckException -> ShowS
$cshowsPrec :: Int -> QuickCheckException -> ShowS
Show)
instance Exception QuickCheckException

-- | Same as 'introduceQuickCheck'' but with default args.
introduceQuickCheck :: (MonadIO m, MonadBaseControl IO m)
  => SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
introduceQuickCheck :: SpecFree
  (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
introduceQuickCheck = String
-> Args
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall (m :: * -> *) context.
(MonadIO m, MonadBaseControl IO m) =>
String
-> Args
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
introduceQuickCheck'' String
"Introduce QuickCheck context" Args
stdArgs

-- | Same as 'introduceQuickCheck''' but with a default message.
introduceQuickCheck' :: (MonadIO m, MonadBaseControl IO m)
  => Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
introduceQuickCheck' :: Args
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
introduceQuickCheck' = String
-> Args
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall (m :: * -> *) context.
(MonadIO m, MonadBaseControl IO m) =>
String
-> Args
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
introduceQuickCheck'' String
"Introduce QuickCheck context"

-- | Introduce QuickCheck args with configurable message.
introduceQuickCheck'' :: (MonadIO m, MonadBaseControl IO m)
  => String -> Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
introduceQuickCheck'' :: String
-> Args
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
introduceQuickCheck'' String
msg Args
args = String
-> Label "quickCheckContext" QuickCheckContext
-> ExampleT context m QuickCheckContext
-> (QuickCheckContext -> ExampleT context m ())
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
msg Label "quickCheckContext" QuickCheckContext
quickCheckContext (QuickCheckContext -> ExampleT context m QuickCheckContext
forall (m :: * -> *) a. Monad m => a -> m a
return (QuickCheckContext -> ExampleT context m QuickCheckContext)
-> QuickCheckContext -> ExampleT context m QuickCheckContext
forall a b. (a -> b) -> a -> b
$ Args -> QuickCheckContext
QuickCheckContext Args
args) (ExampleT context m () -> QuickCheckContext -> ExampleT context m ()
forall a b. a -> b -> a
const (ExampleT context m ()
 -> QuickCheckContext -> ExampleT context m ())
-> ExampleT context m ()
-> QuickCheckContext
-> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT context m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Similar to 'it'. Runs the given prop with QuickCheck using the currently introduced 'Args'. Throws an appropriate exception on failure.
prop :: (HasCallStack, HasQuickCheckContext context, MonadIO m, MonadThrow m, Testable prop) => String -> prop -> Free (SpecCommand context m) ()
prop :: String -> prop -> Free (SpecCommand context m) ()
prop String
msg prop
p = String -> ExampleT context m () -> Free (SpecCommand context m) ()
forall context (m :: * -> *).
HasCallStack =>
String -> ExampleT context m () -> Free (SpecCommand context m) ()
it String
msg (ExampleT context m () -> Free (SpecCommand context m) ())
-> ExampleT context m () -> Free (SpecCommand context m) ()
forall a b. (a -> b) -> a -> b
$ do
  QuickCheckContext Args
args <- Label "quickCheckContext" QuickCheckContext
-> ExampleT context m QuickCheckContext
forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
 MonadReader context m) =>
Label l a -> m a
getContext Label "quickCheckContext" QuickCheckContext
quickCheckContext
  IO Result -> ExampleT context m Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Args -> prop -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult (Args
args { chatty :: Bool
QC.chatty = Bool
False }) prop
p) ExampleT context m Result
-> (Result -> ExampleT context m ()) -> ExampleT context m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    QC.Success {Int
String
Map String Int
Map String (Map String Int)
Map [String] Int
numTests :: Result -> Int
numDiscarded :: Result -> Int
labels :: Result -> Map [String] Int
classes :: Result -> Map String Int
tables :: Result -> Map String (Map String Int)
output :: Result -> String
output :: String
tables :: Map String (Map String Int)
classes :: Map String Int
labels :: Map [String] Int
numDiscarded :: Int
numTests :: Int
..} -> Text -> ExampleT context m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info (String -> Text
T.pack String
output)
    Result
x -> FailureReason -> ExampleT context m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailureReason -> ExampleT context m ())
-> FailureReason -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) (Result -> String
output Result
x)

-- | Modify the 'Args' for the given spec.
modifyArgs :: (HasQuickCheckContext context, Monad m) => (Args -> Args) -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
modifyArgs :: (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyArgs Args -> Args
f = String
-> Label "quickCheckContext" QuickCheckContext
-> ExampleT context m QuickCheckContext
-> (QuickCheckContext -> ExampleT context m ())
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
"Modified QuickCheck context" Label "quickCheckContext" QuickCheckContext
quickCheckContext ExampleT context m QuickCheckContext
acquire (ExampleT context m () -> QuickCheckContext -> ExampleT context m ()
forall a b. a -> b -> a
const (ExampleT context m ()
 -> QuickCheckContext -> ExampleT context m ())
-> ExampleT context m ()
-> QuickCheckContext
-> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT context m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  where
    acquire :: ExampleT context m QuickCheckContext
acquire = do
       QuickCheckContext Args
args <- Label "quickCheckContext" QuickCheckContext
-> ExampleT context m QuickCheckContext
forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
 MonadReader context m) =>
Label l a -> m a
getContext Label "quickCheckContext" QuickCheckContext
quickCheckContext
       QuickCheckContext -> ExampleT context m QuickCheckContext
forall (m :: * -> *) a. Monad m => a -> m a
return (QuickCheckContext -> ExampleT context m QuickCheckContext)
-> QuickCheckContext -> ExampleT context m QuickCheckContext
forall a b. (a -> b) -> a -> b
$ Args -> QuickCheckContext
QuickCheckContext (Args -> Args
f Args
args)

-- | Modify the 'maxSuccess' for the given spec.
modifyMaxSuccess :: (HasQuickCheckContext context, Monad m) => (Int -> Int) -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
modifyMaxSuccess :: (Int -> Int)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyMaxSuccess Int -> Int
f = (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasQuickCheckContext context, Monad m) =>
(Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((Args -> Args)
 -> SpecFree
      (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
 -> SpecFree context m ())
-> (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \Args
args -> Args
args { maxSuccess :: Int
maxSuccess = Int -> Int
f (Args -> Int
maxSuccess Args
args) }

-- | Modify the 'maxDiscardRatio' for the given spec.
modifyMaxDiscardRatio :: (HasQuickCheckContext context, Monad m) => (Int -> Int) -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
modifyMaxDiscardRatio :: (Int -> Int)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyMaxDiscardRatio Int -> Int
f = (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasQuickCheckContext context, Monad m) =>
(Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((Args -> Args)
 -> SpecFree
      (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
 -> SpecFree context m ())
-> (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \Args
args -> Args
args { maxDiscardRatio :: Int
maxDiscardRatio = Int -> Int
f (Args -> Int
maxDiscardRatio Args
args) }

-- | Modify the 'maxSize' for the given spec.
modifyMaxSize :: (HasQuickCheckContext context, Monad m) => (Int -> Int) -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
modifyMaxSize :: (Int -> Int)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyMaxSize Int -> Int
f = (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasQuickCheckContext context, Monad m) =>
(Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((Args -> Args)
 -> SpecFree
      (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
 -> SpecFree context m ())
-> (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \Args
args -> Args
args { maxSize :: Int
maxSize = Int -> Int
f (Args -> Int
maxSize Args
args) }

-- | Modify the 'maxShrinks' for the given spec.
modifyMaxShrinks :: (HasQuickCheckContext context, Monad m) => (Int -> Int) -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m ()
modifyMaxShrinks :: (Int -> Int)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyMaxShrinks Int -> Int
f = (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasQuickCheckContext context, Monad m) =>
(Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((Args -> Args)
 -> SpecFree
      (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
 -> SpecFree context m ())
-> (Args -> Args)
-> SpecFree
     (LabelValue "quickCheckContext" QuickCheckContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \Args
args -> Args
args { maxShrinks :: Int
maxShrinks = Int -> Int
f (Args -> Int
maxShrinks Args
args) }