Remove Switch modules, release strict-checked-vars-0.2.0.0

strict-checked-vars/CHANGELOG.md

@@ -1,5 +1,13 @@
 # Revision history of strict-checked-vars
 
+## 0.2.0.0
+
+* Remove 'Switch' modules. From now on, instead of switching _imports_, this
+  package switches the _representations_ of checked variables depending on the
+  `checkmvarinvariants` and `checktvarinvariants` flags. This solves a problem
+  where compiling projects that depend on `strict-checked-vars` might succeed
+  with a flag turned on but fail when it is turned off (and vice versa).
+
 ## 0.1.0.4
 
 * Propagate HasCallStack constraints in the `Switch` module for checked strict

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

@@ -1,7 +1,10 @@
-{-# LANGUAGE BangPatterns  #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies  #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE BangPatterns             #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TupleSections            #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE TypeOperators            #-}
 
 -- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package.
 --
@@ -40,6 +43,7 @@ module Control.Concurrent.Class.MonadMVar.Strict.Checked (
 
 import           Control.Concurrent.Class.MonadMVar.Strict (LazyMVar, MonadMVar)
 import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict
+import           Data.Kind (Type)
 import           GHC.Stack (HasCallStack)
 
 {-------------------------------------------------------------------------------
@@ -55,15 +59,22 @@ import           GHC.Stack (HasCallStack)
 -- 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.
+type StrictMVar :: (Type -> Type) -> Type -> Type
+#if CHECK_MVAR_INVARIANTS
 data StrictMVar m a = StrictMVar {
     -- | The invariant that is checked whenever the 'StrictMVar' is updated.
     invariant :: !(a -> Maybe String)
   , mvar      :: !(Strict.StrictMVar m a)
   }
+#else
+newtype StrictMVar m a = StrictMVar {
+    mvar :: Strict.StrictMVar m a
+  }
+#endif
 
 castStrictMVar :: LazyMVar m ~ LazyMVar n
                => StrictMVar m a -> StrictMVar n a
-castStrictMVar v = StrictMVar (invariant v) (Strict.castStrictMVar $ mvar v)
+castStrictMVar v = mkStrictMVar (getInvariant v) (Strict.castStrictMVar $ mvar v)
 
 -- | Get the underlying @MVar@
 --
@@ -83,18 +94,18 @@ toLazyMVar = Strict.toLazyMVar . mvar
 --
 -- The resulting 'StrictMVar' has a trivial invariant.
 fromLazyMVar :: LazyMVar m a -> StrictMVar m a
-fromLazyMVar = StrictMVar (const Nothing) . Strict.fromLazyMVar
+fromLazyMVar = mkStrictMVar (const Nothing) . Strict.fromLazyMVar
 
 newEmptyMVar :: MonadMVar m => m (StrictMVar m a)
-newEmptyMVar = StrictMVar (const Nothing) <$> Strict.newEmptyMVar
+newEmptyMVar = mkStrictMVar (const Nothing) <$> Strict.newEmptyMVar
 
 newEmptyMVarWithInvariant :: MonadMVar m
                           => (a -> Maybe String)
                           -> m (StrictMVar m a)
-newEmptyMVarWithInvariant inv = StrictMVar inv <$> Strict.newEmptyMVar
+newEmptyMVarWithInvariant inv = mkStrictMVar inv <$> Strict.newEmptyMVar
 
 newMVar :: MonadMVar m => a -> m (StrictMVar m a)
-newMVar a = StrictMVar (const Nothing) <$> Strict.newMVar a
+newMVar a = mkStrictMVar (const Nothing) <$> Strict.newMVar a
 
 -- | Create a 'StrictMVar' with an invariant.
 --
@@ -106,31 +117,31 @@ newMVarWithInvariant :: (HasCallStack, MonadMVar m)
                      -> m (StrictMVar m a)
 newMVarWithInvariant inv !a =
   checkInvariant (inv a) $
-  StrictMVar inv <$> Strict.newMVar a
+  mkStrictMVar inv <$> Strict.newMVar a
 
 takeMVar :: MonadMVar m => StrictMVar m a -> m a
 takeMVar = Strict.takeMVar . mvar
 
 putMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m ()
 putMVar v a = do
   Strict.putMVar (mvar v) a
-  checkInvariant (invariant v a) $ pure ()
+  checkInvariant (getInvariant v a) $ pure ()
 
 readMVar :: MonadMVar m => StrictMVar m a -> m a
 readMVar v = Strict.readMVar (mvar v)
 
 swapMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m a
 swapMVar v a = do
   oldValue <- Strict.swapMVar (mvar v) a
-  checkInvariant (invariant v a) $ pure oldValue
+  checkInvariant (getInvariant v a) $ pure oldValue
 
 tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a)
 tryTakeMVar v = Strict.tryTakeMVar (mvar v)
 
 tryPutMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m Bool
 tryPutMVar v a = do
   didPut <- Strict.tryPutMVar (mvar v) a
-  checkInvariant (invariant v a) $ pure didPut
+  checkInvariant (getInvariant v a) $ pure didPut
 
 isEmptyMVar :: MonadMVar m => StrictMVar m a -> m Bool
 isEmptyMVar v = Strict.isEmptyMVar (mvar v)
@@ -155,7 +166,7 @@ modifyMVar :: (HasCallStack, MonadMVar m)
            -> m b
 modifyMVar v io = do
     (a', b) <- Strict.modifyMVar (mvar v) io'
-    checkInvariant (invariant v a') $ pure b
+    checkInvariant (getInvariant v a') $ pure b
   where
     io' a = do
       (a', b) <- io a
@@ -177,7 +188,7 @@ modifyMVarMasked :: (HasCallStack, MonadMVar m)
                  -> m b
 modifyMVarMasked v io = do
     (a', b) <- Strict.modifyMVarMasked (mvar v) io'
-    checkInvariant (invariant v a') $ pure b
+    checkInvariant (getInvariant v a') $ pure b
   where
     io' a = do
       (a', b) <- io a
@@ -192,10 +203,25 @@ tryReadMVar v = Strict.tryReadMVar (mvar v)
 -- Dealing with invariants
 --
 
--- | Check invariant
+-- | Check invariant (if enabled) before continuing
+--
+-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws
+-- an error @err@ if @mErr == Just err@.
 --
--- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an
--- error @err@ if @mErr == Just err@.
+-- This is exported so that other code that wants to conditionally check
+-- invariants can reuse the same logic, rather than having to introduce new
+-- per-package flags.
 checkInvariant :: HasCallStack => Maybe String -> a -> a
+getInvariant :: StrictMVar m a -> a -> Maybe String
+mkStrictMVar :: (a -> Maybe String) -> Strict.StrictMVar m a -> StrictMVar m a
+
+#if CHECK_MVAR_INVARIANTS
 checkInvariant Nothing    k = k
 checkInvariant (Just err) _ = error $ "StrictMVar invariant violation: " ++ err
+getInvariant StrictMVar {invariant} = invariant
+mkStrictMVar invariant  mvar        = StrictMVar {invariant, mvar}
+#else
+checkInvariant _err       k  = k
+getInvariant _               = const Nothing
+mkStrictMVar _invariant mvar = StrictMVar {mvar}
+#endif

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

@@ -1,6 +1,8 @@
-{-# LANGUAGE BangPatterns  #-}
-{-# LANGUAGE TypeFamilies  #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE BangPatterns   #-}
+{-# LANGUAGE CPP            #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies   #-}
+{-# LANGUAGE TypeOperators  #-}
 
 -- | This module corresponds to "Control.Concurrent.STM.TVar" in the @stm@ package.
 --
@@ -46,15 +48,21 @@ import           GHC.Stack (HasCallStack)
 
 type LazyTVar m = Strict.LazyTVar m
 
+#if CHECK_TVAR_INVARIANTS
 data StrictTVar m a = StrictTVar {
     -- | Invariant checked whenever updating the 'StrictTVar'.
     invariant :: !(a -> Maybe String)
   , tvar      :: !(Strict.StrictTVar m a)
   }
+#else
+newtype StrictTVar m a = StrictTVar {
+    tvar :: Strict.StrictTVar m a
+  }
+#endif
 
 castStrictTVar :: LazyTVar m ~ LazyTVar n
                => StrictTVar m a -> StrictTVar n a
-castStrictTVar v = StrictTVar (invariant v) (Strict.castStrictTVar $ tvar v)
+castStrictTVar v = mkStrictTVar (getInvariant v) (Strict.castStrictTVar $ tvar v)
 
 -- | Get the underlying @TVar@
 --
@@ -74,10 +82,10 @@ toLazyTVar = Strict.toLazyTVar . tvar
 --
 -- The resulting 'StrictTVar' has a trivial invariant.
 fromLazyTVar :: LazyTVar m a -> StrictTVar m a
-fromLazyTVar = StrictTVar (const Nothing) . Strict.fromLazyTVar
+fromLazyTVar = mkStrictTVar (const Nothing) . Strict.fromLazyTVar
 
 newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)
-newTVar a = StrictTVar (const Nothing) <$> Strict.newTVar a
+newTVar a = mkStrictTVar (const Nothing) <$> Strict.newTVar a
 
 newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)
 newTVarIO = newTVarWithInvariantIO (const Nothing)
@@ -88,15 +96,15 @@ newTVarWithInvariant :: (MonadSTM m, HasCallStack)
                      -> STM m (StrictTVar m a)
 newTVarWithInvariant inv !a =
     checkInvariant (inv a) $
-    StrictTVar inv <$> Strict.newTVar a
+    mkStrictTVar inv <$> Strict.newTVar a
 
 newTVarWithInvariantIO :: (MonadSTM m, HasCallStack)
                        => (a -> Maybe String)
                        -> a
                        -> m (StrictTVar m a)
 newTVarWithInvariantIO inv !a =
     checkInvariant (inv a) $
-    StrictTVar inv <$> Strict.newTVarIO a
+    mkStrictTVar inv <$> Strict.newTVarIO a
 
 readTVar :: MonadSTM m => StrictTVar m a -> STM m a
 readTVar = Strict.readTVar . tvar
@@ -106,7 +114,7 @@ readTVarIO = Strict.readTVarIO . tvar
 
 writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m ()
 writeTVar v !a =
-    checkInvariant (invariant v a) $
+    checkInvariant (getInvariant v a) $
     Strict.writeTVar (tvar v) a
 
 modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m ()
@@ -129,13 +137,29 @@ swapTVar v a' = do
 -- Dealing with invariants
 --
 
--- | Check invariant
+
+-- | Check invariant (if enabled) before continuing
 --
--- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an
--- error @err@ if @mErr == Just err@.
+-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws
+-- an error @err@ if @mErr == Just err@.
+--
+-- This is exported so that other code that wants to conditionally check
+-- invariants can reuse the same logic, rather than having to introduce new
+-- per-package flags.
 checkInvariant :: HasCallStack => Maybe String -> a -> a
+getInvariant :: StrictTVar m a -> a -> Maybe String
+mkStrictTVar :: (a -> Maybe String) -> Strict.StrictTVar m a -> StrictTVar m a
+
+#if CHECK_TVAR_INVARIANTS
 checkInvariant Nothing    k = k
 checkInvariant (Just err) _ = error $ "StrictTVar invariant violation: " ++ err
+getInvariant StrictTVar {invariant} = invariant
+mkStrictTVar invariant  tvar        = StrictTVar {invariant, tvar}
+#else
+checkInvariant _err       k  = k
+getInvariant _               = const Nothing
+mkStrictTVar _invariant tvar = StrictTVar {tvar}
+#endif
 
 {-------------------------------------------------------------------------------
   MonadLabelledSTM