Resolve PR comments

Author: jorisdral

.github/workflows/cabal.project.local

@@ -8,7 +8,6 @@ package io-classes
 
 package strict-mvar
   ghc-options: -Werror
-  flags: +asserts +checkmvarinvariant
 
 package strict-stm
   ghc-options: -Werror

cabal.project

@@ -31,8 +31,5 @@ package io-sim
 package io-classes
   flags: +asserts
 
-package strict-mvar
-  flags: +asserts
-
 package strict-stm
   flags: +asserts

strict-mvar/README.md

@@ -5,3 +5,46 @@ The `strict-mvar` package provides a strict interface to mutable variables
 for `MVar`s implementations from both
 [base](https://hackage.haskell.org/package/base-4.17.0.0/docs/Control-Concurrent-MVar.html)
 and [io-sim](https://github.com/input-output-hk/io-sim).
+
+## Checked and unchecked `StrictMVar`s
+
+There are currently two variant implementations of `StrictMVar`s in this package:
+* `Control.Concurrent.Class.MonadMVar.Strict`
+* `Control.Concurrent.Class.MonadMVar.Strict.Checked`
+
+The _unchecked_ module provides the simplest implementation of a `StrictMVar`: a
+light wrapper around lazy MVars that forces values to WHNF before they are put
+into the MVar. The _checked_ module does the exact same thing, but it has the
+additional feature that the user can provide an invariant that is checked each
+time a new value is placed inside the MVar. The two modules are drop-in
+replacements for one another: switching from `*.Strict` to `*.Strict.Checked`
+will enable invariant checking, while the converse will disable invariant
+checking. To facilitate drop-in replacement, both modules share the same
+interface, though in case of the `*.Strict` module, everything related to
+invariants will be ignored. This will be explicitly mentioned in the Haddock
+documentation of said definitions. For example:
+
+```haskell
+-- | The given invariant will never be checked. 'newMVarWithInvariant' is a
+-- light wrapper around 'newMVar', and is only included here to ensure that the
+-- current module and "Control.Concurrent.Class.MonadMVar.Strict.Checked" are
+-- drop-in replacements for one another.
+newMVarWithInvariant :: MonadMVar m
+                     => (a -> Maybe String)
+                     -> a
+                     -> m (StrictMVar m a)
+```
+
+**Note:** though the two modules are drop-in replacements for one another, the
+`StrictMVar` type from `*.Strict` and the `StrictMVar` type from
+`*.Strict.Checked` do not share the same internal representation, and so they
+are distinct types.
+
+## Guarantees for invariant checking
+
+Although all functions that modify a checked `StrictMVar` will check the
+invariant, we do *not* guarantee that the value inside the `StrictMVar` always
+satisfies the invariant. Instead, we *do* guarantee that if the `StrictMVar` is
+updated with a value that does not satisfy the invariant, an exception is
+thrown. The reason for this weaker guarantee is that leaving an `MVar` empty can
+lead to very hard to debug "blocked indefinitely" problems.

strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs

@@ -2,16 +2,22 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
--- | This module corresponds to 'Control.Concurrent.MVar' in "base" package
+-- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package.
 --
+-- Use "Control.Concurrent.Class.MonadMVar.Strict.Checked" as a drop-in
+-- replacement for the current module in case you want to check invariants on
+-- the values inside 'StrictMVar's.
 module Control.Concurrent.Class.MonadMVar.Strict
   ( -- * StrictMVar
     StrictMVar
+  , LazyMVar
   , castStrictMVar
   , toLazyMVar
   , fromLazyMVar
   , newEmptyMVar
+  , newEmptyMVarWithInvariant
   , newMVar
+  , newMVarWithInvariant
   , takeMVar
   , putMVar
   , readMVar
@@ -65,9 +71,28 @@ fromLazyMVar = StrictMVar
 newEmptyMVar :: MonadMVar m => m (StrictMVar m a)
 newEmptyMVar = fromLazyMVar <$> Lazy.newEmptyMVar
 
+-- | The given invariant will never be checked. 'newEmptyMVarWithInvariant' is a
+-- light wrapper around 'newEmptyMVar', and is only included here to ensure that
+-- the current module and "Control.Concurrent.Class.MonadMVar.Strict.Checked"
+-- are drop-in replacements for one another.
+newEmptyMVarWithInvariant :: MonadMVar m
+                          => (a -> Maybe String)
+                          -> m (StrictMVar m a)
+newEmptyMVarWithInvariant _inv = StrictMVar <$> Lazy.newEmptyMVar
+
 newMVar :: MonadMVar m => a -> m (StrictMVar m a)
 newMVar !a = fromLazyMVar <$> Lazy.newMVar a
 
+-- | The given invariant will never be checked. 'newMVarWithInvariant' is a
+-- light wrapper around 'newMVar', and is only included here to ensure that the
+-- current module and "Control.Concurrent.Class.MonadMVar.Strict.Checked" are
+-- drop-in replacements for one another.
+newMVarWithInvariant :: MonadMVar m
+                     => (a -> Maybe String)
+                     -> a
+                     -> m (StrictMVar m a)
+newMVarWithInvariant _inv !a = StrictMVar <$> Lazy.newMVar a
+
 takeMVar :: MonadMVar m => StrictMVar m a -> m a
 takeMVar = Lazy.takeMVar . mvar
 

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

@@ -4,11 +4,15 @@
 {-# LANGUAGE TypeFamilies  #-}
 {-# LANGUAGE TypeOperators #-}
 
--- | This module corresponds to 'Control.Concurrent.MVar' in "base" package
+-- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package.
 --
+-- Use "Control.Concurrent.Class.MonadMVar.Strict" as a drop-in replacement for
+-- the current module in case you do /not/ want to check invariants on the
+-- values inside 'StrictMVar's.
 module Control.Concurrent.Class.MonadMVar.Strict.Checked
   ( -- * StrictMVar
     StrictMVar
+  , LazyMVar
   , castStrictMVar
   , toLazyMVar
   , fromLazyMVar
@@ -87,17 +91,18 @@ fromLazyMVar = StrictMVar (const Nothing)
 newEmptyMVar :: MonadMVar m => m (StrictMVar m a)
 newEmptyMVar = fromLazyMVar <$> Lazy.newEmptyMVar
 
-newEmptyMVarWithInvariant ::
-     MonadMVar m
-  => (a -> Maybe String) -> m (StrictMVar m a)
+newEmptyMVarWithInvariant :: MonadMVar m
+                          => (a -> Maybe String)
+                          -> m (StrictMVar m a)
 newEmptyMVarWithInvariant inv = StrictMVar inv <$> Lazy.newEmptyMVar
 
 newMVar :: MonadMVar m => a -> m (StrictMVar m a)
 newMVar !a = fromLazyMVar <$> Lazy.newMVar a
 
-newMVarWithInvariant ::
-     MonadMVar m
-  => (a -> Maybe String) -> a -> m (StrictMVar m a)
+newMVarWithInvariant :: MonadMVar m
+                     => (a -> Maybe String)
+                     -> a
+                     -> m (StrictMVar m a)
 newMVarWithInvariant inv !a =
   checkInvariant (inv a) $
   StrictMVar inv <$> Lazy.newMVar a
@@ -174,15 +179,10 @@ tryReadMVar v = Lazy.tryReadMVar (mvar v)
 -- Dealing with invariants
 --
 
--- | Check invariant (if enabled)
+-- | Check invariant
 --
 -- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an
 -- error @err@ if @mErr == Just err@.
 checkInvariant :: HasCallStack => Maybe String -> a -> a
-
-#if CHECK_MVAR_INVARIANT
 checkInvariant Nothing    k = k
-checkInvariant (Just err) _ = error $ "Invariant violation: " ++ err
-#else
-checkInvariant _err       k = k
-#endif
+checkInvariant (Just err) _ = error $ "StrictMVar invariant violation: " ++ err

strict-mvar/strict-mvar.cabal

@@ -24,16 +24,6 @@ source-repository head
   location: https://github.com/input-output-hk/io-sim
   subdir:   strict-mvar
 
-flag checkmvarinvariant
-  Description: Enable runtime invariant checks on StrictMVar
-  Manual: True
-  Default: False
-
-flag asserts
-  description: Enable assertions
-  manual:      False
-  default:     False
-
 library
   hs-source-dirs:      src
 
@@ -50,12 +40,6 @@ library
                        -Wpartial-fields
                        -Widentities
 
-  if flag(asserts)
-    ghc-options: -fno-ignore-asserts
-
-  if flag(checkmvarinvariant)
-    cpp-options: -DCHECK_MVAR_INVARIANT
-
 test-suite test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test

strict-mvar/test/Main.hs

@@ -4,19 +4,4 @@ import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Check
 import           Test.Tasty
 
 main :: IO ()
-main = defaultMain $
-    testGroup "Test" [
-        testGroup "Control" [
-            testGroup "Concurrent" [
-                testGroup "Class" [
-                    testGroup "MonadMVar" [
-                        testGroup "Strict" [
-                            testGroup "Checked" [
-                                Checked.tests
-                              ]
-                          ]
-                      ]
-                  ]
-              ]
-          ]
-      ]
+main = defaultMain Checked.tests

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

@@ -1,5 +1,3 @@
--- | Tests in this module depend on the @+checkmvarinvariant@ flag being
--- enabled.
 module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where
 
 import           Control.Concurrent.Class.MonadMVar.Strict.Checked
@@ -8,10 +6,12 @@ import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
 tests :: TestTree
-tests = testGroup "Checked" [
-    testProperty "prop_invariantShouldFail" prop_invariantShouldFail
-  , testProperty "prop_invariantShouldNotFail" prop_invariantShouldNotFail
-  ]
+tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [
+      testGroup "Checked" [
+          testProperty "prop_invariantShouldFail" prop_invariantShouldFail
+        , testProperty "prop_invariantShouldNotFail" prop_invariantShouldNotFail
+        ]
+    ]
 
 -- | Invariant that checks whether an @Int@ is positive.
 invPositiveInt :: Int -> Maybe String
@@ -23,10 +23,8 @@ prop_invariantShouldFail :: Property
 prop_invariantShouldFail = once $ expectFailure $ monadicIO $ run $ do
     v <- newMVarWithInvariant invPositiveInt 0
     modifyMVar_ v (\x -> pure $ x - 1)
-    pure ()
 
 prop_invariantShouldNotFail :: Property
 prop_invariantShouldNotFail = monadicIO $ run $ do
     v <- newMVarWithInvariant invPositiveInt 0
     modifyMVar_ v (\x -> pure $ x + 1)
-    pure ()