{-# LANGUAGE BangPatterns #-}

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

module Control.Monad.IOSimPOR.QuickCheckUtils where

import           Control.Monad.ST.Lazy
import           Test.QuickCheck.Gen
import           Test.QuickCheck.Property

-- 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.

conjoinNoCatchST :: TestableNoCatch prop => [ST s prop] -> ST s Property
conjoinNoCatchST :: forall prop s. TestableNoCatch prop => [ST s prop] -> ST s Property
conjoinNoCatchST [ST s prop]
sts = do
    [prop]
ps <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ST s prop]
sts
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall prop. TestableNoCatch prop => [prop] -> Property
conjoinNoCatch [prop]
ps

conjoinNoCatch :: TestableNoCatch prop => [prop] -> Property
conjoinNoCatch :: forall prop. TestableNoCatch prop => [prop] -> Property
conjoinNoCatch = forall prop.
TestableNoCatch prop =>
([Rose Result] -> [Rose Result]) -> [prop] -> Property
conjoinSpeculate 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 forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty forall a b. (a -> b) -> a -> b
$
  do [Rose Result]
roses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch) [prop]
ps
     forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> Prop
MkProp forall a b. (a -> b) -> a -> b
$ (Result -> Result) -> [Rose Result] -> Rose Result
conj 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 [] =
    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) ->
        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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result -> Result
addCallbacksAndCoverage 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 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  -> forall a. a -> [Rose a] -> Rose a
MkRose (Result
result2 { ok :: Maybe Bool
ok = 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 forall a. [a] -> [a] -> [a]
++ Result -> [Callback]
callbacks Result
r,
        requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = Result -> [(Maybe String, String, Double)]
requiredCoverage Result
result 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 forall a. [a] -> [a] -> [a]
++ Result -> [String]
labels Result
r,
        classes :: [String]
classes = Result -> [String]
classes Result
result forall a. [a] -> [a] -> [a]
++ Result -> [String]
classes Result
r,
        tables :: [(String, String)]
tables = Result -> [(String, String)]
tables Result
result forall a. [a] -> [a] -> [a]
++ Result -> [(String, String)]
tables Result
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 = 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
_ = forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch Result
rejected

instance TestableNoCatch Bool where
  propertyNoCatch :: Bool -> Property
propertyNoCatch = forall prop. TestableNoCatch prop => prop -> Property
propertyNoCatch 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Prop
MkProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

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

instance TestableNoCatch prop => TestableNoCatch (Gen prop) where
  propertyNoCatch :: Gen prop -> Property
propertyNoCatch Gen prop
mp = Gen Prop -> Property
MkProperty forall a b. (a -> b) -> a -> b
$ do prop
p <- Gen prop
mp; Property -> Gen Prop
unProperty (Property -> Property
againNoCatch forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ do
  MkProp Rose Result
rose <- Gen Prop
gen
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Prop
MkProp forall a b. (a -> b) -> a -> b
$ 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