{-# 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
    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 unsafeNoThunks (OnlyCheckWhnf 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
    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)
    isInWHNF 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
    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
    run $ putMVar v (applyFun f x)
    isInWHNF 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
    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
    void $ run $ swapMVar v (applyFun f x)
    isInWHNF 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
    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
    b <- run $ tryPutMVar v (applyFun f x)
    b' <- isInWHNF v
    pure (b && 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
    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
    run $ modifyMVar_ v (pure . applyFun f)
    isInWHNF 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
    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
    void $ run $ modifyMVar v (pure . applyFun f)
    isInWHNF 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
    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
    void $ run $ modifyMVarMasked_ v (pure . applyFun f)
    isInWHNF 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
    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
    void $ run $ modifyMVarMasked v (pure . applyFun f)
    isInWHNF v