Skip to content

Commit

Permalink
WHNF tests for strict-checked-vars
Browse files Browse the repository at this point in the history
  • Loading branch information
jorisdral committed Aug 7, 2023
1 parent f54cdd8 commit 565ee61
Show file tree
Hide file tree
Showing 7 changed files with 455 additions and 3 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -96,6 +96,10 @@ newEmptyMVarWithInvariant inv = StrictMVar inv <$> Strict.newEmptyMVar
newMVar :: MonadMVar m => a -> m (StrictMVar m a)
newMVar a = StrictMVar (const Nothing) <$> Strict.newMVar a

-- | Create a 'StrictMVar' with an invariant.
--
-- Contrary to functions that modify a 'StrictMVar', this function checks the
-- invariant /before/ putting the value in a new 'StrictMVar'.
newMVarWithInvariant :: (HasCallStack, MonadMVar m)
=> (a -> Maybe String)
-> a
Expand Down
4 changes: 4 additions & 0 deletions strict-checked-vars/strict-checked-vars.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -73,12 +73,16 @@ test-suite test
main-is: Main.hs
other-modules:
Test.Control.Concurrent.Class.MonadMVar.Strict.Checked
Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF
Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF
Test.Utils

default-language: Haskell2010
build-depends:
, base >=4.9 && <4.19
, io-classes
, io-sim
, nothunks
, QuickCheck
, strict-checked-vars
, tasty
Expand Down
8 changes: 5 additions & 3 deletions strict-checked-vars/test/Main.hs
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
module Main where

import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked
import Test.Tasty
import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Test.StrictMVar.Checked
import qualified Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF as Test.StrictTVar.Checked
import Test.Tasty (defaultMain, testGroup)

main :: IO ()
main = defaultMain $ testGroup "strict-checked-vars" [
Checked.tests
Test.StrictMVar.Checked.tests
, Test.StrictTVar.Checked.tests
]
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where

import Control.Concurrent.Class.MonadMVar.Strict.Checked
import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF as Test.WHNF
import Test.QuickCheck.Monadic
import Test.Tasty
import Test.Tasty.QuickCheck
Expand All @@ -23,6 +24,7 @@ tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [
, testProperty "prop_invariantShouldNotFail" $
once $ monadicSim prop_invariantShouldNotFail
]
, Test.WHNF.tests
]
]

Expand Down
Original file line number Diff line number Diff line change
@@ -0,0 +1,208 @@
{-# LANGUAGE LambdaCase #-}

module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF where

import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding
(newEmptyMVar, newEmptyMVarWithInvariant, newMVar,
newMVarWithInvariant)
import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked
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 (Invariant (..), monadicSim, noInvariant,
trivialInvariant, whnfInvariant, (.:))

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

tests :: TestTree
tests = testGroup "WHNF" [
testGroup "IO" [
testIO "No invariant" noInvariant
, testIO "Trivial invariant" trivialInvariant
, testIO "WHNF invariant" whnfInvariant
]
, testGroup "IOSim" [
testIOSim "No invariant" noInvariant
, testIOSim "Trivial invariant" trivialInvariant
, testIOSim "WHNF invariant" whnfInvariant
]
]
where
testIO name inv = testGroup name [
testProperty "prop_newMVarWithInvariant" $
monadicIO .: prop_newMVarWithInvariant inv
, testProperty "prop_putMVar" $
monadicIO .: prop_putMVar inv
, testProperty "prop_swapMVar" $
monadicIO .: prop_swapMVar inv
, testProperty "prop_tryPutMVarJust" $
monadicIO .: prop_tryPutMVarNothing inv
, testProperty "prop_tryPutMVarNothing" $
monadicIO .: prop_tryPutMVarNothing inv
, testProperty "prop_modifyMVar_" $
monadicIO .: prop_modifyMVar_ inv
, testProperty "prop_modifyMVar" $
monadicIO .: prop_modifyMVar inv
, testProperty "prop_modifyMVarMasked_" $
monadicIO .: prop_modifyMVarMasked_ inv
, testProperty "prop_modifyMVarMasked" $
monadicIO .: prop_modifyMVarMasked inv
]

testIOSim name inv = testGroup name [
testProperty "prop_newMVarWithInvariant" $ \x f ->
monadicSim $ prop_newMVarWithInvariant inv x f
, testProperty "prop_putMVar" $ \x f ->
monadicSim $ prop_putMVar inv x f
, testProperty "prop_swapMVar" $ \x f ->
monadicSim $ prop_swapMVar inv x f
, testProperty "prop_tryPutMVarJust" $ \x f ->
monadicSim $ prop_tryPutMVarJust inv x f
, testProperty "prop_tryPutMVarNothing" $ \x f ->
monadicSim $ prop_tryPutMVarNothing inv x f
, testProperty "prop_modifyMVar_" $ \x f ->
monadicSim $ prop_modifyMVar_ inv x f
, testProperty "prop_modifyMVar" $ \x f ->
monadicSim $ prop_modifyMVar inv x f
, testProperty "prop_modifyMVarMasked_" $ \x f ->
monadicSim $ prop_modifyMVarMasked_ inv x f
, testProperty "prop_modifyMVarMasked" $ \x f ->
monadicSim $ prop_modifyMVarMasked inv x f
]

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

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

-- | Wrapper around 'Checked.newMVar' and 'Checked.newMVarWithInvariant'.
newMVarWithInvariant :: MonadMVar m => Invariant a -> a -> m (StrictMVar m a)
newMVarWithInvariant = \case
NoInvariant -> Checked.newMVar
Invariant inv -> Checked.newMVarWithInvariant inv

-- | Wrapper around 'Checked.newEmptyMVar' and
-- 'Checked.newEmptyMVarWithInvariant'.
newEmptyMVarWithInvariant :: MonadMVar m => Invariant a -> m (StrictMVar m a)
newEmptyMVarWithInvariant = \case
NoInvariant -> Checked.newEmptyMVar
Invariant inv -> Checked.newEmptyMVarWithInvariant inv

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

-- | Test 'newMVarWithInvariant', not to be confused with
-- 'Checked.newMVarWithInvariant'.
prop_newMVarWithInvariant ::
MonadMVar m
=> Invariant Int
-> Int
-> Fun Int Int
-> PropertyM m Bool
prop_newMVarWithInvariant inv x f = do
v <- run $ newMVarWithInvariant inv (applyFun f x)
isInWHNF v

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

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

prop_tryPutMVarJust ::
MonadMVar m
=> Invariant Int
-> Int
-> Fun Int Int
-> PropertyM m Bool
prop_tryPutMVarJust inv x f = do
v <- run $ newEmptyMVarWithInvariant inv
b <- run $ tryPutMVar v (applyFun f x)
b' <- isInWHNF v
pure (b && b')

prop_tryPutMVarNothing ::
MonadMVar m
=> Invariant Int
-> Int
-> Fun Int Int
-> PropertyM m Bool
prop_tryPutMVarNothing inv x f = do
v <- run $ newMVarWithInvariant inv x
b <- run $ tryPutMVar v (applyFun f x)
b' <- isInWHNF v
pure (not b && b')

prop_modifyMVar_ ::
MonadMVar m
=> Invariant Int
-> Int
-> Fun Int Int
-> PropertyM m Bool
prop_modifyMVar_ inv x f = do
v <- run $ newMVarWithInvariant inv x
run $ modifyMVar_ v (pure . applyFun f)
isInWHNF v

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

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

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

0 comments on commit 565ee61

Please sign in to comment.