Add NoThunks instances for WithEarlyExit

IntersectMBO · Apr 16, 2024 · e0a4062 · e0a4062
1 parent 993baf5
commit e0a4062
Showing 1 changed file with 14 additions and 1 deletion.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE QuantifiedConstraints      #-}
@@ -38,7 +39,7 @@ import           Data.Proxy
 import           NoThunks.Class (NoThunks (..))
 import           Ouroboros.Consensus.Util ((.:))
 import           Ouroboros.Consensus.Util.IOLike (IOLike (..), PrimMonad (..),
-                     StrictSVar, StrictTVar)
+                     StrictSVar, StrictTVar, castStrictSVar, castStrictTVar)
 import           Ouroboros.Consensus.Util.NormalForm.StrictMVar (StrictMVar)
 
 {-------------------------------------------------------------------------------
@@ -56,6 +57,18 @@ newtype WithEarlyExit m a = WithEarlyExit {
            , MonadPlus
            )
 
+instance NoThunks (StrictTVar m a)
+      => NoThunks (StrictTVar (WithEarlyExit m) a) where
+  showTypeOf _ = "StrictTVar (WithEarlyExit m)"
+  wNoThunks ctxt tv = do
+      wNoThunks ctxt (castStrictTVar tv :: StrictTVar m a)
+
+instance NoThunks (StrictSVar m a)
+      => NoThunks (StrictSVar (WithEarlyExit m) a) where
+  showTypeOf _ = "StrictSVar (WithEarlyExit m)"
+  wNoThunks ctxt tv = do
+      wNoThunks ctxt (castStrictSVar tv :: StrictSVar m a)
+
 -- | Internal only
 earlyExit :: m (Maybe a) -> WithEarlyExit m a
 earlyExit = WithEarlyExit . MaybeT