From 4e2998f5fc3aec2d07e638123b68351cd9417a22 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@well-typed.com>
Date: Fri, 29 Nov 2024 11:55:22 +0000
Subject: [PATCH] Add more strictness to resolve NoThunks test failures

---
 src-control/Control/RefCount.hs                | 4 ++--
 src-control/Control/TempRegistry.hs            | 6 ++++--
 src/Database/LSMTree/Internal.hs               | 6 +++---
 src/Database/LSMTree/Internal/MergeSchedule.hs | 6 +++---
 4 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/src-control/Control/RefCount.hs b/src-control/Control/RefCount.hs
index ef320e97f..fd7be5e8d 100644
--- a/src-control/Control/RefCount.hs
+++ b/src-control/Control/RefCount.hs
@@ -318,12 +318,12 @@ deRefWeak (WeakRef obj) = do
 #ifndef NO_IGNORE_ASSERTS
 newRefWithTracker :: PrimMonad m => obj -> m (Ref obj)
 newRefWithTracker obj =
-    return (Ref obj)
+    return $! Ref obj
 #else
 newRefWithTracker :: (PrimMonad m, HasCallStack) => obj -> m (Ref obj)
 newRefWithTracker obj = do
     reftracker' <- newRefTracker callStack
-    return (Ref obj reftracker')
+    return $! Ref obj reftracker'
 #endif
 
 data RefException =
diff --git a/src-control/Control/TempRegistry.hs b/src-control/Control/TempRegistry.hs
index 6d0ca04b1..a70012eb0 100644
--- a/src-control/Control/TempRegistry.hs
+++ b/src-control/Control/TempRegistry.hs
@@ -114,7 +114,8 @@ allocateTemp :: (MonadMask m, MonadMVar m) =>
   -> m a
   -> (a -> m ())
   -> m a
-allocateTemp reg acquire free = mustBeRight <$> allocateEitherTemp reg (fmap Right acquire) free
+allocateTemp reg acquire free =
+    mustBeRight <$!> allocateEitherTemp reg (fmap Right acquire) free
   where
     mustBeRight :: Either Void a -> a
     mustBeRight (Left  v) = absurd v
@@ -128,7 +129,8 @@ allocateMaybeTemp ::
   -> m (Maybe a)
   -> (a -> m ())
   -> m (Maybe a)
-allocateMaybeTemp reg acquire free = fromEither <$!> allocateEitherTemp reg (toEither <$> acquire) free
+allocateMaybeTemp reg acquire free =
+    fromEither <$!> allocateEitherTemp reg (toEither <$> acquire) free
   where
     toEither :: Maybe a -> Either () a
     toEither Nothing  = Left ()
diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs
index baaea1a63..2b67638ea 100644
--- a/src/Database/LSMTree/Internal.hs
+++ b/src/Database/LSMTree/Internal.hs
@@ -908,7 +908,7 @@ data CursorEnv m h = CursorEnv {
 
     -- | The write buffer blobs, which like the runs, we have to keep open
     -- untile the cursor is closed.
-  , cursorWBB        :: Ref (WBB.WriteBufferBlobs m h)
+  , cursorWBB        :: !(Ref (WBB.WriteBufferBlobs m h))
   }
 
 {-# SPECIALISE withCursor ::
@@ -969,8 +969,8 @@ newCursor !offsetKey t = withOpenTable t $ \thEnv -> do
     -- references to each run, so it is safe.
     dupTableContent reg contentVar = do
         RW.withReadAccess contentVar $ \content -> do
-          let wb      = tableWriteBuffer content
-              wbblobs = tableWriteBufferBlobs content
+          let !wb      = tableWriteBuffer content
+              !wbblobs = tableWriteBufferBlobs content
           wbblobs' <- allocateTemp reg (dupRef wbblobs) releaseRef
           let runs = cachedRuns (tableCache content)
           runs' <- V.forM runs $ \r ->
diff --git a/src/Database/LSMTree/Internal/MergeSchedule.hs b/src/Database/LSMTree/Internal/MergeSchedule.hs
index fc0de7924..a6bf2058b 100644
--- a/src/Database/LSMTree/Internal/MergeSchedule.hs
+++ b/src/Database/LSMTree/Internal/MergeSchedule.hs
@@ -145,7 +145,7 @@ duplicateTableContent reg (TableContent wb wbb levels cache) = do
     wbb'    <- allocateTemp reg (dupRef wbb) releaseRef
     levels' <- duplicateLevels reg levels
     cache'  <- duplicateLevelsCache reg cache
-    return $ TableContent wb wbb' levels' cache'
+    return $! TableContent wb wbb' levels' cache'
 
 {-# SPECIALISE releaseTableContent :: TempRegistry IO -> TableContent IO h -> IO () #-}
 releaseTableContent ::
@@ -441,7 +441,7 @@ duplicateLevels reg levels =
       incomingRun'  <- duplicateIncomingRun reg incomingRun
       residentRuns' <- V.forM residentRuns $ \r ->
                          allocateTemp reg (dupRef r) releaseRef
-      return Level {
+      return $! Level {
         incomingRun  = incomingRun',
         residentRuns = residentRuns'
       }
@@ -787,7 +787,7 @@ addRunToLevels tr conf@TableConfig{..} resolve hfs hbio root uc r0 reg levels =
         -- Make a new level
         let policyForLevel = mergePolicyForLevel confMergePolicy ln V.empty
         ir <- newMerge policyForLevel Merge.LastLevel ln rs
-        return $ V.singleton $ Level ir V.empty
+        return $! V.singleton $ Level ir V.empty
     go !ln rs' (V.uncons -> Just (Level ir rs, ls)) = do
         r <- expectCompletedMergeTraced ln ir
         case mergePolicyForLevel confMergePolicy ln ls of