{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

-- | Test whether functions on 'StrictMVar's correctly force values to WHNF
-- before they are put inside the 'StrictMVar'.
module Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF
  ( prop_newMVar
  , prop_putMVar
  , prop_swapMVar
  , prop_tryPutMVar
  , prop_modifyMVar_
  , prop_modifyMVar
  , prop_modifyMVarMasked_
  , prop_modifyMVarMasked
  , (.:)
  ) where

import Control.Concurrent.Class.MonadMVar.Strict
import Control.Monad (void)
import Data.Typeable (Typeable)
import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks)
import Test.QuickCheck
import Test.QuickCheck.Monadic (PropertyM, monitor, run)

{-------------------------------------------------------------------------------
  Utilities
-------------------------------------------------------------------------------}

infixr 9 .:

(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z)
.: :: forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
(.:) y -> z
g x0 -> x1 -> y
f x0
x0 x1
x1 = y -> z
g (x0 -> x1 -> y
f x0
x0 x1
x1)

isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool
isInWHNF :: forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m a
v = do
    a
x <- m a -> PropertyM m a
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m a -> PropertyM m a) -> m a -> PropertyM m a
forall a b. (a -> b) -> a -> b
$ StrictMVar m a -> m a
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
readMVar StrictMVar m a
v
    case OnlyCheckWhnf a -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks (a -> OnlyCheckWhnf a
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf a
x) of
      Maybe ThunkInfo
Nothing    -> Bool -> PropertyM m Bool
forall a. a -> PropertyM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Just ThunkInfo
tinfo -> (Property -> Property) -> PropertyM m ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Not in WHNF: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ThunkInfo -> String
forall a. Show a => a -> String
show ThunkInfo
tinfo)
                 PropertyM m () -> PropertyM m Bool -> PropertyM m Bool
forall a b. PropertyM m a -> PropertyM m b -> PropertyM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> PropertyM m Bool
forall a. a -> PropertyM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

{-------------------------------------------------------------------------------
  Properties
-------------------------------------------------------------------------------}

prop_newMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_newMVar :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int Int -> PropertyM m Bool
prop_newMVar Int
x Fun Int Int
f = do
    StrictMVar m Int
v <- m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int))
-> m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall a b. (a -> b) -> a -> b
$ Int -> m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar (Fun Int Int -> Int -> Int
forall a b. Fun a b -> a -> b
applyFun Fun Int Int
f Int
x)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v

prop_putMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_putMVar :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int Int -> PropertyM m Bool
prop_putMVar Int
x Fun Int Int
f = do
    StrictMVar m Int
v <- m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => m (StrictMVar m a)
newEmptyMVar
    m () -> PropertyM m ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m () -> PropertyM m ()) -> m () -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> Int -> m ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> a -> m ()
putMVar StrictMVar m Int
v (Fun Int Int -> Int -> Int
forall a b. Fun a b -> a -> b
applyFun Fun Int Int
f Int
x)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v

prop_swapMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_swapMVar :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int Int -> PropertyM m Bool
prop_swapMVar Int
x Fun Int Int
f = do
    StrictMVar m Int
v <- m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int))
-> m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall a b. (a -> b) -> a -> b
$ Int -> m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar Int
x
    PropertyM m Int -> PropertyM m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyM m Int -> PropertyM m ())
-> PropertyM m Int -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ m Int -> PropertyM m Int
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m Int -> PropertyM m Int) -> m Int -> PropertyM m Int
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> Int -> m Int
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> a -> m a
swapMVar StrictMVar m Int
v (Fun Int Int -> Int -> Int
forall a b. Fun a b -> a -> b
applyFun Fun Int Int
f Int
x)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v

prop_tryPutMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_tryPutMVar :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int Int -> PropertyM m Bool
prop_tryPutMVar Int
x Fun Int Int
f = do
    StrictMVar m Int
v <- m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => m (StrictMVar m a)
newEmptyMVar
    Bool
b <- m Bool -> PropertyM m Bool
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m Bool -> PropertyM m Bool) -> m Bool -> PropertyM m Bool
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> Int -> m Bool
forall (m :: * -> *) a.
MonadMVar m =>
StrictMVar m a -> a -> m Bool
tryPutMVar StrictMVar m Int
v (Fun Int Int -> Int -> Int
forall a b. Fun a b -> a -> b
applyFun Fun Int Int
f Int
x)
    Bool
b' <- StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v
    Bool -> PropertyM m Bool
forall a. a -> PropertyM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
b Bool -> Bool -> Bool
&& Bool
b')

prop_modifyMVar_ ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_modifyMVar_ :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int Int -> PropertyM m Bool
prop_modifyMVar_ Int
x Fun Int Int
f =do
    StrictMVar m Int
v <-  m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int))
-> m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall a b. (a -> b) -> a -> b
$ Int -> m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar Int
x
    m () -> PropertyM m ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m () -> PropertyM m ()) -> m () -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> (Int -> m Int) -> m ()
forall (m :: * -> *) a.
MonadMVar m =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVar_ StrictMVar m Int
v (Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> m Int) -> (Int -> Int) -> Int -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun Int Int -> Int -> Int
forall a b. Fun a b -> a -> b
applyFun Fun Int Int
f)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v

prop_modifyMVar ::
     MonadMVar m
  => Int
  -> Fun Int (Int, Char)
  -> PropertyM m Bool
prop_modifyMVar :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int (Int, Char) -> PropertyM m Bool
prop_modifyMVar Int
x Fun Int (Int, Char)
f =do
    StrictMVar m Int
v <-  m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int))
-> m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall a b. (a -> b) -> a -> b
$ Int -> m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar Int
x
    PropertyM m Char -> PropertyM m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyM m Char -> PropertyM m ())
-> PropertyM m Char -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ m Char -> PropertyM m Char
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m Char -> PropertyM m Char) -> m Char -> PropertyM m Char
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> (Int -> m (Int, Char)) -> m Char
forall (m :: * -> *) a b.
MonadMVar m =>
StrictMVar m a -> (a -> m (a, b)) -> m b
modifyMVar StrictMVar m Int
v ((Int, Char) -> m (Int, Char)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Char) -> m (Int, Char))
-> (Int -> (Int, Char)) -> Int -> m (Int, Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun Int (Int, Char) -> Int -> (Int, Char)
forall a b. Fun a b -> a -> b
applyFun Fun Int (Int, Char)
f)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v

prop_modifyMVarMasked_ ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_modifyMVarMasked_ :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int Int -> PropertyM m Bool
prop_modifyMVarMasked_ Int
x Fun Int Int
f =do
    StrictMVar m Int
v <-  m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int))
-> m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall a b. (a -> b) -> a -> b
$ Int -> m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar Int
x
    PropertyM m () -> PropertyM m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyM m () -> PropertyM m ())
-> PropertyM m () -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ m () -> PropertyM m ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m () -> PropertyM m ()) -> m () -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> (Int -> m Int) -> m ()
forall (m :: * -> *) a.
MonadMVar m =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVarMasked_ StrictMVar m Int
v (Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> m Int) -> (Int -> Int) -> Int -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun Int Int -> Int -> Int
forall a b. Fun a b -> a -> b
applyFun Fun Int Int
f)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v

prop_modifyMVarMasked ::
     MonadMVar m
  => Int
  -> Fun Int (Int, Char)
  -> PropertyM m Bool
prop_modifyMVarMasked :: forall (m :: * -> *).
MonadMVar m =>
Int -> Fun Int (Int, Char) -> PropertyM m Bool
prop_modifyMVarMasked Int
x Fun Int (Int, Char)
f =do
    StrictMVar m Int
v <-  m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int))
-> m (StrictMVar m Int) -> PropertyM m (StrictMVar m Int)
forall a b. (a -> b) -> a -> b
$ Int -> m (StrictMVar m Int)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar Int
x
    PropertyM m Char -> PropertyM m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyM m Char -> PropertyM m ())
-> PropertyM m Char -> PropertyM m ()
forall a b. (a -> b) -> a -> b
$ m Char -> PropertyM m Char
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m Char -> PropertyM m Char) -> m Char -> PropertyM m Char
forall a b. (a -> b) -> a -> b
$ StrictMVar m Int -> (Int -> m (Int, Char)) -> m Char
forall (m :: * -> *) a b.
MonadMVar m =>
StrictMVar m a -> (a -> m (a, b)) -> m b
modifyMVarMasked StrictMVar m Int
v ((Int, Char) -> m (Int, Char)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Char) -> m (Int, Char))
-> (Int -> (Int, Char)) -> Int -> m (Int, Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun Int (Int, Char) -> Int -> (Int, Char)
forall a b. Fun a b -> a -> b
applyFun Fun Int (Int, Char)
f)
    StrictMVar m Int -> PropertyM m Bool
forall (m :: * -> *) a.
(MonadMVar m, Typeable a) =>
StrictMVar m a -> PropertyM m Bool
isInWHNF StrictMVar m Int
v