WHNF.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use camelCase" #-}

-- | 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 (tests) where

import           Control.Concurrent.Class.MonadMVar.Strict
import           Control.Monad (void)
import           Data.Typeable (Typeable)
import           NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks)
import           Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run)
import           Test.Tasty (TestTree, testGroup)
import           Test.Tasty.QuickCheck (Fun, applyFun, counterexample,
                     testProperty)
import           Test.Utils (monadicSim)

{-------------------------------------------------------------------------------
  Main test tree
-------------------------------------------------------------------------------}

tests :: TestTree
tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [
      testGroup "WHNF" [
          testGroup "IO" [
              testProperty "prop_newMVar" $
                monadicIO .: prop_newMVar
            , testProperty "prop_putMVar" $
                monadicIO .: prop_putMVar
            , testProperty "prop_swapMVar" $
                monadicIO .: prop_swapMVar
            , testProperty "prop_tryPutMVar" $
                monadicIO .: prop_tryPutMVar
            , testProperty "prop_modifyMVar_" $
                monadicIO .: prop_modifyMVar_
            , testProperty "prop_modifyMVar" $
                monadicIO .: prop_modifyMVar
            , testProperty "prop_modifyMVarMasked_" $
                monadicIO .: prop_modifyMVarMasked_
            , testProperty "prop_modifyMVarMasked" $
                monadicIO .: prop_modifyMVarMasked
            ]
        , testGroup "IOSim" [
              testProperty "prop_newMVar" $ \x f ->
                monadicSim $ prop_newMVar x f
            , testProperty "prop_putMVar" $ \x f ->
                monadicSim $ prop_putMVar x f
            , testProperty "prop_swapMVar" $ \x f ->
                monadicSim $ prop_swapMVar x f
            , testProperty "prop_tryPutMVar" $ \x f ->
                monadicSim $ prop_tryPutMVar x f
            , testProperty "prop_modifyMVar_" $ \x f ->
                monadicSim $ prop_modifyMVar_ x f
            , testProperty "prop_modifyMVar" $ \x f ->
                monadicSim $ prop_modifyMVar x f
            , testProperty "prop_modifyMVarMasked_" $ \x f ->
                monadicSim $ prop_modifyMVarMasked_ x f
            , testProperty "prop_modifyMVarMasked" $ \x f ->
                monadicSim $ prop_modifyMVarMasked x f
            ]
        ]
    ]

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

infixr 9 .:

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

isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool
isInWHNF v = do
    x <- run $ readMVar v
    case unsafeNoThunks (OnlyCheckWhnf x) of
      Nothing    -> pure True
      Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo)
                 >> pure False

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

prop_newMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_newMVar x f = do
    v <- run $ newMVar (applyFun f x)
    isInWHNF v

prop_putMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_putMVar x f = do
    v <- run newEmptyMVar
    run $ putMVar v (applyFun f x)
    isInWHNF v

prop_swapMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_swapMVar x f = do
    v <- run $ newMVar x
    void $ run $ swapMVar v (applyFun f x)
    isInWHNF v

prop_tryPutMVar ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_tryPutMVar x f = do
    v <- run 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_ x f =do
    v <-  run $ newMVar x
    run $ modifyMVar_ v (pure . applyFun f)
    isInWHNF v

prop_modifyMVar ::
     MonadMVar m
  => Int
  -> Fun Int (Int, Char)
  -> PropertyM m Bool
prop_modifyMVar x f =do
    v <-  run $ newMVar x
    void $ run $ modifyMVar v (pure . applyFun f)
    isInWHNF v

prop_modifyMVarMasked_ ::
     MonadMVar m
  => Int
  -> Fun Int Int
  -> PropertyM m Bool
prop_modifyMVarMasked_ x f =do
    v <-  run $ newMVar x
    void $ run $ modifyMVarMasked_ v (pure . applyFun f)
    isInWHNF v

prop_modifyMVarMasked ::
     MonadMVar m
  => Int
  -> Fun Int (Int, Char)
  -> PropertyM m Bool
prop_modifyMVarMasked x f =do
    v <-  run $ newMVar x
    void $ run $ modifyMVarMasked v (pure . applyFun f)
    isInWHNF v