Merge pull request #105 from input-output-hk/jdral/strict-mvar-hascallstack

Propage `HasCallStack` constraint when using `checkInvariant`.

Author: coot

strict-mvar/CHANGELOG.md

@@ -15,6 +15,11 @@
   `Control.Concurrent.Class.MonadMVar.Strict` now has `newMVarWithInvariant` and
   `newEmptyMVarWithInvariant` functions that ignore the invariant argument.
 
+### Patch
+
+* Functions that use invariant checking now correctly propagate `HasCallStack`
+  constraints.
+
 ## 1.1.0.0
 
 ### Non breaking changes

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

@@ -99,7 +99,7 @@ newEmptyMVarWithInvariant inv = StrictMVar inv <$> Lazy.newEmptyMVar
 newMVar :: MonadMVar m => a -> m (StrictMVar m a)
 newMVar !a = fromLazyMVar <$> Lazy.newMVar a
 
-newMVarWithInvariant :: MonadMVar m
+newMVarWithInvariant :: (HasCallStack, MonadMVar m)
                      => (a -> Maybe String)
                      -> a
                      -> m (StrictMVar m a)
@@ -110,23 +110,23 @@ newMVarWithInvariant inv !a =
 takeMVar :: MonadMVar m => StrictMVar m a -> m a
 takeMVar = Lazy.takeMVar . mvar
 
-putMVar :: MonadMVar m => StrictMVar m a -> a -> m ()
+putMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m ()
 putMVar v !a = do
   Lazy.putMVar (mvar v) a
   checkInvariant (invariant v a) $ pure ()
 
 readMVar :: MonadMVar m => StrictMVar m a -> m a
 readMVar v = Lazy.readMVar (mvar v)
 
-swapMVar :: MonadMVar m => StrictMVar m a -> a -> m a
+swapMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m a
 swapMVar v !a = do
   oldValue <- Lazy.swapMVar (mvar v) a
   checkInvariant (invariant v a) $ pure oldValue
 
 tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a)
 tryTakeMVar v = Lazy.tryTakeMVar (mvar v)
 
-tryPutMVar :: MonadMVar m => StrictMVar m a -> a -> m Bool
+tryPutMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m Bool
 tryPutMVar v !a = do
   didPut <- Lazy.tryPutMVar (mvar v) a
   checkInvariant (invariant v a) $ pure didPut
@@ -141,11 +141,17 @@ withMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b
 withMVarMasked v = Lazy.withMVarMasked (mvar v)
 
 -- | 'modifyMVar_' is defined in terms of 'modifyMVar'.
-modifyMVar_ :: MonadMVar m => StrictMVar m a -> (a -> m a) -> m ()
+modifyMVar_ :: (HasCallStack, MonadMVar m)
+            => StrictMVar m a
+            -> (a -> m a)
+            -> m ()
 modifyMVar_ v io = modifyMVar v io'
   where io' a = (,()) <$> io a
 
-modifyMVar :: MonadMVar m => StrictMVar m a -> (a -> m (a,b)) -> m b
+modifyMVar :: (HasCallStack, MonadMVar m)
+           => StrictMVar m a
+           -> (a -> m (a,b))
+           -> m b
 modifyMVar v io = do
     (a', b) <- Lazy.modifyMVar (mvar v) io'
     checkInvariant (invariant v a') $ pure b
@@ -157,11 +163,17 @@ modifyMVar v io = do
       pure (a' , (a', b))
 
 -- | 'modifyMVarMasked_' is defined in terms of 'modifyMVarMasked'.
-modifyMVarMasked_ :: MonadMVar m => StrictMVar m a -> (a -> m a) -> m ()
+modifyMVarMasked_ :: (HasCallStack, MonadMVar m)
+                  => StrictMVar m a
+                  -> (a -> m a)
+                  -> m ()
 modifyMVarMasked_ v io = modifyMVar v io'
   where io' a = (,()) <$> io a
 
-modifyMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m (a,b)) -> m b
+modifyMVarMasked :: (HasCallStack, MonadMVar m)
+                 => StrictMVar m a
+                 -> (a -> m (a,b))
+                 -> m b
 modifyMVarMasked v io = do
     (a', b) <- Lazy.modifyMVar (mvar v) io'
     checkInvariant (invariant v a') $ pure b
@@ -185,4 +197,4 @@ tryReadMVar v = Lazy.tryReadMVar (mvar v)
 -- error @err@ if @mErr == Just err@.
 checkInvariant :: HasCallStack => Maybe String -> a -> a
 checkInvariant Nothing    k = k
-checkInvariant (Just err) _ = error $ "StrictMVar invariant violation: " ++ err
+checkInvariant (Just err) _ = error $ "StrictMVar invariant violation: " ++ err