{-# LANGUAGE BangPatterns #-}

{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Control.Monad.IOSimPOR.QuickCheckUtils where

import Control.Parallel
import Test.QuickCheck.Gen
import Test.QuickCheck.Property

-- Take the conjunction of several properties, in parallel This is a
-- modification of code from Test.QuickCheck.Property, to run non-IO
-- properties in parallel. It also takes care NOT to label its result
-- as an IO property (using IORose), unless one of its arguments is
-- itself an IO property. This is needed to permit parallel testing.
conjoinPar :: TestableNoCatch prop => [prop] -> Property
conjoinPar :: forall prop. TestableNoCatch prop => [prop] -> Property
conjoinPar = ([Rose Result] -> [Rose Result]) -> [prop] -> Property
forall prop.
TestableNoCatch prop =>
([Rose Result] -> [Rose Result]) -> [prop] -> Property
conjoinSpeculate [Rose Result] -> [Rose Result]
speculate
  where
  -- speculation tries to evaluate each Rose tree in parallel, to WHNF
  -- This will not perform any IO, but should evaluate non-IO properties
  -- completely.
  speculate :: [Rose Result] -> [Rose Result]
speculate [] = []
  speculate (Rose Result
rose:[Rose Result]
roses) = [Rose Result]
roses' [Rose Result] -> [Rose Result] -> [Rose Result]
forall a b. a -> b -> b
`par` Rose Result
rose' Rose Result -> [Rose Result] -> [Rose Result]
forall a b. a -> b -> b
`pseq` (Rose Result
rose'Rose Result -> [Rose Result] -> [Rose Result]
forall a. a -> [a] -> [a]
:[Rose Result]
roses')
    where rose' :: Rose Result
rose' = case Rose Result
rose of
                    MkRose Result
result [Rose Result]
_ -> (case Result -> Maybe Bool
ok Result
result of { Maybe Bool
Nothing -> (); Just !Bool
_ -> (); })
                                () -> Rose Result -> Rose Result
forall a b. a -> b -> b
`pseq` Rose Result
rose
                    IORose IO (Rose Result)
_        -> Rose Result
rose
          roses' :: [Rose Result]
roses' = [Rose Result] -> [Rose Result]
speculate [Rose Result]
roses

-- We also need a version of conjoin that is sequential, but does not
-- label its result as an IO property unless one of its arguments
-- is. Consequently it does not catch exceptions in its arguments.
conjoinNoCatch :: TestableNoCatch prop => [prop] -> Property
conjoinNoCatch :: forall prop. TestableNoCatch prop => [prop] -> Property
conjoinNoCatch = ([Rose Result] -> [Rose Result]) -> [prop] -> Property
forall prop.
TestableNoCatch prop =>
([Rose Result] -> [Rose Result]) -> [prop] -> Property
conjoinSpeculate [Rose Result] -> [Rose Result]
forall a. a -> a
id

conjoinSpeculate :: TestableNoCatch prop => ([Rose Result] -> [Rose Result]) -> [prop] -> Property
conjoinSpeculate :: forall prop.
TestableNoCatch prop =>
([Rose Result] -> [Rose Result]) -> [prop] -> Property
conjoinSpeculate [Rose Result] -> [Rose Result]
spec [prop]
ps =
  Property -> Property
againNoCatch (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$
  do [Rose Result]
roses <- (prop -> Gen (Rose Result)) -> [prop] -> Gen [Rose Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Prop -> Rose Result) -> Gen Prop -> Gen (Rose Result)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp (Gen Prop -> Gen (Rose Result))
-> (prop -> Gen Prop) -> prop -> Gen (Rose Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty (Property -> Gen Prop) -> (prop -> Property) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. prop -> Property
forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch) [prop]
ps
     Prop -> Gen Prop
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> Prop
MkProp (Rose Result -> Prop) -> Rose Result -> Prop
forall a b. (a -> b) -> a -> b
$ (Result -> Result) -> [Rose Result] -> Rose Result
conj Result -> Result
forall a. a -> a
id ([Rose Result] -> [Rose Result]
spec [Rose Result]
roses))
 where

  conj :: (Result -> Result) -> [Rose Result] -> Rose Result
conj Result -> Result
k [] =
    Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose (Result -> Result
k Result
succeeded) []

  conj Result -> Result
k (Rose Result
p : [Rose Result]
ps) = do
    Result
result <- Rose Result
p
    case Result -> Maybe Bool
ok Result
result of
      Maybe Bool
_ | Bool -> Bool
not (Result -> Bool
expect Result
result) ->
        Result -> Rose Result
forall a. a -> Rose a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
failed { reason = "expectFailure may not occur inside a conjunction" }
      Just Bool
True -> (Result -> Result) -> [Rose Result] -> Rose Result
conj (Result -> Result -> Result
addLabels Result
result (Result -> Result) -> (Result -> Result) -> Result -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result -> Result
addCallbacksAndCoverage Result
result (Result -> Result) -> (Result -> Result) -> Result -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result
k) [Rose Result]
ps
      Just Bool
False -> Rose Result
p
      Maybe Bool
Nothing -> do
        let rest :: Rose Result
rest = (Result -> Result) -> [Rose Result] -> Rose Result
conj (Result -> Result -> Result
addCallbacksAndCoverage Result
result (Result -> Result) -> (Result -> Result) -> Result -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result
k) [Rose Result]
ps
        Result
result2 <- Rose Result
rest
        -- Nasty work to make sure we use the right callbacks
        case Result -> Maybe Bool
ok Result
result2 of
          Just Bool
True  -> Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose (Result
result2 { ok = Nothing }) []
          Just Bool
False -> Rose Result
rest
          Maybe Bool
Nothing    -> Rose Result
rest

  addCallbacksAndCoverage :: Result -> Result -> Result
addCallbacksAndCoverage Result
result Result
r =
    Result
r { callbacks = callbacks result ++ callbacks r,
        requiredCoverage = requiredCoverage result ++ requiredCoverage r }
  addLabels :: Result -> Result -> Result
addLabels Result
result Result
r =
    Result
r { labels = labels result ++ labels r,
        classes = classes result ++ classes r,
        tables = tables result ++ tables r }


-- .&&| is a sequential, but parallelism-friendly version of .&&., that
-- tests its arguments in sequence, but does not label its result as
-- an IO property unless one of its arguments is.

infixr 1 .&&|
(.&&|) :: TestableNoCatch prop => prop -> prop -> Property
prop
p .&&| :: forall prop. TestableNoCatch prop => prop -> prop -> Property
.&&| prop
q = [prop] -> Property
forall prop. TestableNoCatch prop => [prop] -> Property
conjoinNoCatch [prop
p, prop
q]


-- property catches exceptions in its argument, turning everything
-- Testable into an IORose property, which cannot be paralellized. We
-- need an alternative that permits parallelism by allowing exceptions
-- to propagate. This is a modified clone of code from
-- Test.QuickCheck.Property.

class TestableNoCatch prop where
  propertyNoCatch :: prop -> Property

instance TestableNoCatch Discard where
  propertyNoCatch :: Discard -> Property
propertyNoCatch Discard
_ = Result -> Property
forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch Result
rejected

instance TestableNoCatch Bool where
  propertyNoCatch :: Bool -> Property
propertyNoCatch = Result -> Property
forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch (Result -> Property) -> (Bool -> Result) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Result
liftBool

instance TestableNoCatch Result where
  propertyNoCatch :: Result -> Property
propertyNoCatch = Gen Prop -> Property
MkProperty (Gen Prop -> Property)
-> (Result -> Gen Prop) -> Result -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Gen Prop
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prop -> Gen Prop) -> (Result -> Prop) -> Result -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Prop
MkProp (Rose Result -> Prop) -> (Result -> Rose Result) -> Result -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Rose Result
forall a. a -> Rose a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance TestableNoCatch Prop where
  propertyNoCatch :: Prop -> Property
propertyNoCatch Prop
p = Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> (Prop -> Gen Prop) -> Prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Gen Prop
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prop -> Property) -> Prop -> Property
forall a b. (a -> b) -> a -> b
$ Prop
p

instance TestableNoCatch prop => TestableNoCatch (Gen prop) where
  propertyNoCatch :: Gen prop -> Property
propertyNoCatch Gen prop
mp = Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$ do prop
p <- Gen prop
mp; Property -> Gen Prop
unProperty (Property -> Property
againNoCatch (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ prop -> Property
forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch prop
p)

instance TestableNoCatch Property where
  propertyNoCatch :: Property -> Property
propertyNoCatch Property
p = Property
p

againNoCatch :: Property -> Property
againNoCatch :: Property -> Property
againNoCatch (MkProperty Gen Prop
gen) = Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$ do
  MkProp Rose Result
rose <- Gen Prop
gen
  Prop -> Gen Prop
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prop -> Gen Prop)
-> (Rose Result -> Prop) -> Rose Result -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Prop
MkProp (Rose Result -> Gen Prop) -> Rose Result -> Gen Prop
forall a b. (a -> b) -> a -> b
$ (Result -> Result) -> Rose Result -> Rose Result
forall a b. (a -> b) -> Rose a -> Rose b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Result
res -> Result
res{ abort = False }) Rose Result
rose