WHNF tests for strict-checked-vars

cabal.project

@@ -12,7 +12,7 @@ repository cardano-haskell-packages
 -- The hackage index-state
 index-state: 2023-07-31T10:10:32Z
 -- The CHaP index-state
-index-state: cardano-haskell-packages 2023-07-31T10:10:32Z
+index-state: cardano-haskell-packages 2023-08-08T14:32:15Z
 
 packages:
   base-deriving-via
@@ -37,11 +37,3 @@ benchmarks: true
 
 program-options
   ghc-options: -Werror
-
-if impl(ghc >= 9.6)
-  allow-newer:
-    , *:base
-    , protolude:ghc-prim
-    , protolude:binary
-    , protolude:bytestring
-    , protolude:text

strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs

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

strict-checked-vars/strict-checked-vars.cabal

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

strict-checked-vars/test/Main.hs

@@ -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
     ]

strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs

@@ -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
@@ -23,6 +24,7 @@ tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [
             , testProperty "prop_invariantShouldNotFail" $
                 once                 $ monadicSim prop_invariantShouldNotFail
             ]
+        , Test.WHNF.tests
         ]
     ]
 

strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs

@@ -0,0 +1,303 @@
+{-# 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           Control.Monad.IOSim (runSimOrThrow)
+import           Data.Typeable (Typeable)
+import           NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks)
+import           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.QuickCheck (Fun, Property, applyFun, counterexample,
+                     ioProperty, property, testProperty, (.&&.))
+import           Test.Utils (Invariant (..), (..:))
+
+{-------------------------------------------------------------------------------
+  Main test tree
+-------------------------------------------------------------------------------}
+
+tests :: TestTree
+tests = testGroup "WHNF" [
+      testGroup "IO"    testIO
+    , testGroup "IOSim" testIOSim
+    ]
+  where
+    testIO = [
+          testProperty "prop_IO_newMVarWithInvariant"
+            prop_IO_newMVarWithInvariant
+        , testProperty "prop_IO_putMVar"
+            prop_IO_putMVar
+        , testProperty "prop_IO_swapMVar"
+            prop_IO_swapMVar
+        , testProperty "prop_IO_tryPutMVarJust"
+            prop_IO_tryPutMVarJust
+        , testProperty "prop_IO_tryPutMVarNothing"
+            prop_IO_tryPutMVarNothing
+        , testProperty "prop_IO_modifyMVar_"
+            prop_IO_modifyMVar_
+        , testProperty "prop_IO_modifyMVar"
+            prop_IO_modifyMVar
+        , testProperty "prop_IO_modifyMVarMasked_"
+            prop_IO_modifyMVarMasked_
+        , testProperty "prop_IO_modifyMVarMasked"
+            prop_IO_modifyMVarMasked
+        ]
+
+    testIOSim = [
+          testProperty "prop_IOSim_newMVarWithInvariant"
+            prop_IOSim_newMVarWithInvariant
+        , testProperty "prop_IOSim_putMVar"
+            prop_IOSim_putMVar
+        , testProperty "prop_IOSim_swapMVar"
+            prop_IOSim_swapMVar
+        , testProperty "prop_IOSim_tryPutMVarJust"
+            prop_IOSim_tryPutMVarJust
+        , testProperty "prop_IOSim_tryPutMVarNothing"
+            prop_IOSim_tryPutMVarNothing
+        , testProperty "prop_IOSim_modifyMVar_"
+            prop_IOSim_modifyMVar_
+        , testProperty "prop_IOSim_modifyMVar"
+            prop_IOSim_modifyMVar
+        , testProperty "prop_IOSim_modifyMVarMasked_"
+            prop_IOSim_modifyMVarMasked_
+        , testProperty "prop_IOSim_modifyMVarMasked"
+            prop_IOSim_modifyMVarMasked
+        ]
+
+{-------------------------------------------------------------------------------
+  Utilities
+-------------------------------------------------------------------------------}
+
+isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> m Property
+isInWHNF v = do
+    x <- readMVar v
+    pure $ case unsafeNoThunks (OnlyCheckWhnf x) of
+      Nothing    -> property True
+      Just tinfo -> counterexample ("Not in WHNF: " ++ show tinfo)
+                  $ property 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
+-------------------------------------------------------------------------------}
+
+--
+-- newMVarWithInvariant
+--
+
+-- | Test 'newMVarWithInvariant', not to be confused with
+-- 'Checked.newMVarWithInvariant'.
+prop_M_newMVarWithInvariant ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_newMVarWithInvariant inv x f = do
+    v <- newMVarWithInvariant inv (applyFun f x)
+    isInWHNF v
+
+prop_IO_newMVarWithInvariant :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_newMVarWithInvariant = ioProperty ..:
+    prop_M_newMVarWithInvariant
+
+prop_IOSim_newMVarWithInvariant :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IOSim_newMVarWithInvariant inv x f = runSimOrThrow $
+    prop_M_newMVarWithInvariant inv x f
+
+--
+-- putMVar
+--
+
+prop_M_putMVar ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_putMVar inv x f = do
+    v <- newEmptyMVarWithInvariant inv
+    putMVar v (applyFun f x)
+    isInWHNF v
+
+prop_IO_putMVar :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_putMVar = ioProperty ..:
+    prop_M_putMVar
+
+prop_IOSim_putMVar :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IOSim_putMVar inv x f = runSimOrThrow $
+    prop_M_putMVar inv x f
+
+--
+-- swapMVar
+--
+
+prop_M_swapMVar ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_swapMVar inv x f = do
+    v <- newMVarWithInvariant inv x
+    void $ swapMVar v (applyFun f x)
+    isInWHNF v
+
+prop_IO_swapMVar :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_swapMVar = ioProperty ..:
+    prop_M_swapMVar
+
+prop_IOSim_swapMVar :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IOSim_swapMVar inv x f = runSimOrThrow $
+    prop_M_swapMVar inv x f
+
+--
+-- tryPutMVar
+--
+
+prop_M_tryPutMVarJust ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_tryPutMVarJust inv x f = do
+    v <- newEmptyMVarWithInvariant inv
+    b <- tryPutMVar v (applyFun f x)
+    b' <- isInWHNF v
+    pure (property b .&&. b')
+
+prop_IO_tryPutMVarJust :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_tryPutMVarJust = ioProperty ..:
+    prop_M_tryPutMVarJust
+
+prop_IOSim_tryPutMVarJust :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IOSim_tryPutMVarJust inv x f = runSimOrThrow $
+    prop_M_tryPutMVarJust inv x f
+
+prop_M_tryPutMVarNothing ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_tryPutMVarNothing inv x f = do
+    v <- newMVarWithInvariant inv x
+    b <- tryPutMVar v (applyFun f x)
+    b' <- isInWHNF v
+    pure (property (not b) .&&. b')
+
+prop_IO_tryPutMVarNothing :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_tryPutMVarNothing = ioProperty ..:
+    prop_M_tryPutMVarNothing
+prop_IOSim_tryPutMVarNothing :: Invariant Int -> Int -> Fun Int Int -> Property
+
+prop_IOSim_tryPutMVarNothing inv x f = runSimOrThrow $
+    prop_M_tryPutMVarNothing inv x f
+
+--
+-- modifyMVar_
+--
+
+prop_M_modifyMVar_ ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_modifyMVar_ inv x f = do
+    v <-  newMVarWithInvariant inv x
+    modifyMVar_ v (pure . applyFun f)
+    isInWHNF v
+
+prop_IO_modifyMVar_ :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_modifyMVar_ = ioProperty ..:
+    prop_M_modifyMVar_
+
+prop_IOSim_modifyMVar_ :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IOSim_modifyMVar_ inv x f = runSimOrThrow $
+    prop_M_modifyMVar_ inv x f
+
+--
+-- modifyMVar_
+--
+
+prop_M_modifyMVar ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int (Int, Char)
+  -> m Property
+prop_M_modifyMVar inv x f =do
+    v <-  newMVarWithInvariant inv x
+    void $ modifyMVar v (pure . applyFun f)
+    isInWHNF v
+
+prop_IO_modifyMVar :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property
+prop_IO_modifyMVar = ioProperty ..:
+    prop_M_modifyMVar
+
+prop_IOSim_modifyMVar :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property
+prop_IOSim_modifyMVar inv x f = runSimOrThrow $
+    prop_M_modifyMVar inv x f
+
+--
+-- modifyMVarMasked_
+--
+
+prop_M_modifyMVarMasked_ ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int Int
+  -> m Property
+prop_M_modifyMVarMasked_ inv x f =do
+    v <- newMVarWithInvariant inv x
+    void $  modifyMVarMasked_ v (pure . applyFun f)
+    isInWHNF v
+
+prop_IO_modifyMVarMasked_ :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IO_modifyMVarMasked_ = ioProperty ..:
+    prop_M_modifyMVarMasked_
+
+prop_IOSim_modifyMVarMasked_ :: Invariant Int -> Int -> Fun Int Int -> Property
+prop_IOSim_modifyMVarMasked_ inv x f = runSimOrThrow $
+    prop_M_modifyMVarMasked_ inv x f
+
+--
+-- modifyMVarMasked
+--
+
+prop_M_modifyMVarMasked ::
+     MonadMVar m
+  => Invariant Int
+  -> Int
+  -> Fun Int (Int, Char)
+  -> m Property
+prop_M_modifyMVarMasked inv x f = do
+    v <-newMVarWithInvariant inv x
+    void $ modifyMVarMasked v (pure . applyFun f)
+    isInWHNF v
+
+prop_IO_modifyMVarMasked :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property
+prop_IO_modifyMVarMasked = ioProperty ..:
+    prop_M_modifyMVarMasked
+
+prop_IOSim_modifyMVarMasked :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property
+prop_IOSim_modifyMVarMasked inv x f = runSimOrThrow $
+    prop_M_modifyMVarMasked inv x f