{-# 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 :: [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 _ -> let ans :: Bool
ans = Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Bool -> Bool
forall a. a -> a
id (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Result -> Maybe Bool
ok Result
result in Bool
ans Bool -> Rose Result -> Rose Result
forall a b. a -> b -> b
`pseq` Rose Result
rose
                    IORose _        -> 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 :: [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 :: ([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)
mapM ((Prop -> Rose Result) -> Gen Prop -> Gen (Rose Result)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Result
failed { reason :: String
reason = String
"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 :: Maybe Bool
ok = Maybe Bool
forall a. Maybe a
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 :: [Callback]
callbacks = Result -> [Callback]
callbacks Result
result [Callback] -> [Callback] -> [Callback]
forall a. [a] -> [a] -> [a]
++ Result -> [Callback]
callbacks Result
r,
        requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = Result -> [(Maybe String, String, Double)]
requiredCoverage Result
result [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
forall a. [a] -> [a] -> [a]
++ Result -> [(Maybe String, String, Double)]
requiredCoverage Result
r }
  addLabels :: Result -> Result -> Result
addLabels Result
result Result
r =
    Result
r { labels :: [String]
labels = Result -> [String]
labels Result
result [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Result -> [String]
labels Result
r,
        classes :: [String]
classes = Result -> [String]
classes Result
result [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Result -> [String]
classes Result
r,
        tables :: [(String, String)]
tables = Result -> [(String, String)]
tables Result
result [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ Result -> [(String, String)]
tables Result
r }

-- |&&| is a replacement for .&&. that evaluates its arguments in
-- parallel. |&&| does NOT label its result as an IO property, unless
-- one of its arguments is--which .&&. does. This means that using
-- .&&. inside an argument to conjoinPar limits parallelism, while
-- |&&| does not.

infixr 1 |&&|

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

-- .&&| 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 .&&| :: 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 (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 (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 (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Result
res -> Result
res{ abort :: Bool
abort = Bool
False }) Rose Result
rose