Merge #3207

3207: Use newtype for StrictTVar if checktvarinvariant cabal flag is not set r=coot a=coot

- renamed cabal.project.ci.windows file
- io-sim-classes: StrictTVar representation
- Updated cabal.project.local.ci


Co-authored-by: Marcin Szamotulski <[email protected]>

Author: iohk-bors[bot]

io-sim-classes/src/Control/Monad/Class/MonadSTM/Strict.hs

@@ -76,11 +76,17 @@ type LazyTMVar m = Lazy.TMVar m
   Strict TVar
 -------------------------------------------------------------------------------}
 
+#if CHECK_TVAR_INVARIANT
 data StrictTVar m a = StrictTVar
    { invariant :: !(a -> Maybe String)
      -- ^ Invariant checked whenever updating the 'StrictTVar'.
    , tvar      :: !(LazyTVar m a)
    }
+#else
+newtype StrictTVar m a = StrictTVar
+   { tvar      :: LazyTVar m a
+   }
+#endif
 
 labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m ()
 labelTVar StrictTVar { tvar } = Lazy.labelTVar tvar
@@ -90,7 +96,8 @@ labelTVarIO v = atomically . labelTVar v
 
 castStrictTVar :: LazyTVar m ~ LazyTVar n
                => StrictTVar m a -> StrictTVar n a
-castStrictTVar StrictTVar{invariant, tvar} = StrictTVar{invariant, tvar}
+castStrictTVar v@StrictTVar {tvar} =
+    mkStrictTVar (getInvariant v) tvar
 
 -- | Get the underlying @TVar@
 --
@@ -100,7 +107,8 @@ toLazyTVar :: StrictTVar m a -> LazyTVar m a
 toLazyTVar StrictTVar { tvar } = tvar
 
 newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)
-newTVar !a = StrictTVar (const Nothing) <$> Lazy.newTVar a
+newTVar !a = (\tvar -> mkStrictTVar (const Nothing) tvar)
+         <$> Lazy.newTVar a
 
 newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)
 newTVarIO = newTVarWithInvariantIO (const Nothing)
@@ -113,9 +121,10 @@ newTVarWithInvariantIO :: (MonadSTM m, HasCallStack)
                        => (a -> Maybe String) -- ^ Invariant (expect 'Nothing')
                        -> a
                        -> m (StrictTVar m a)
-newTVarWithInvariantIO invariant !a =
-    checkInvariant (invariant a) $
-    StrictTVar invariant <$> Lazy.newTVarIO a
+newTVarWithInvariantIO  invariant !a =
+        checkInvariant (invariant a) $
+        (\tvar -> mkStrictTVar invariant tvar)
+    <$> Lazy.newTVarIO a
 
 newTVarWithInvariantM :: (MonadSTM m, HasCallStack)
                       => (a -> Maybe String) -- ^ Invariant (expect 'Nothing')
@@ -131,9 +140,9 @@ readTVarIO :: MonadSTM m => StrictTVar m a -> m a
 readTVarIO StrictTVar { tvar } = Lazy.readTVarIO tvar
 
 writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m ()
-writeTVar StrictTVar { tvar, invariant } !a =
-    checkInvariant (invariant a) $
-    Lazy.writeTVar tvar a
+writeTVar v !a =
+    checkInvariant (getInvariant v a) $
+    Lazy.writeTVar (tvar v) a
 
 modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m ()
 modifyTVar v f = readTVar v >>= writeTVar v . f
@@ -225,6 +234,9 @@ isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar
   Dealing with invariants
 -------------------------------------------------------------------------------}
 
+getInvariant :: StrictTVar m a -> a -> Maybe String
+mkStrictTVar :: (a -> Maybe String) -> Lazy.TVar m a -> StrictTVar m a
+
 -- | Check invariant (if enabled) before continuing
 --
 -- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws
@@ -234,9 +246,16 @@ isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar
 -- invariants can reuse the same logic, rather than having to introduce new
 -- per-package flags.
 checkInvariant :: HasCallStack => Maybe String -> a -> a
+
 #if CHECK_TVAR_INVARIANT
-checkInvariant Nothing    k = k
-checkInvariant (Just err) _ = error $ "Invariant violation: " ++ err
+getInvariant StrictTVar {invariant} = invariant
+mkStrictTVar invariant  tvar = StrictTVar {invariant, tvar}
+
+checkInvariant Nothing    k  = k
+checkInvariant (Just err) _  = error $ "Invariant violation: " ++ err
 #else
-checkInvariant _err k       = k
+getInvariant _               = \_ -> Nothing
+mkStrictTVar _invariant tvar = StrictTVar {tvar}
+
+checkInvariant _err       k  = k
 #endif