From fe30119b3d8d766bdbde33c4f64df60a27bb0c45 Mon Sep 17 00:00:00 2001
From: Javier Sagredo <javier.sagredo@iohk.io>
Date: Thu, 11 Apr 2024 13:45:47 +0200
Subject: [PATCH] Add `NoThunks` instances for `WithEarlyExit`

---
 .../Ouroboros/Consensus/Util/EarlyExit.hs         | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 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
index 6a7817cf5f..c9901b2e0b 100644
--- 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