Strict.alterFEager: Fix strictness (#384)

Fixes #383.

Author: sjakobi

Data/HashMap/Internal/Strict.hs

@@ -401,13 +401,13 @@ alterFEager f !k !m = (<$> f mv) $ \fres ->
 
     ------------------------------
     -- Update value
-    Just v' -> case lookupRes of
+    Just !v' -> case lookupRes of
 
       -- Key did not exist before, insert v' under a new key
       Absent -> insertNewKey h k v' m
 
       -- Key existed before, no hash collision
-      Present v collPos -> v' `seq`
+      Present v collPos ->
         if v `ptrEq` v'
         -- If the value is identical, no-op
         then m

tests/Regressions.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE MagicHash           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE UnboxedTuples       #-}
 module Regressions (tests) where
 
@@ -11,6 +12,7 @@ import Data.List             (delete)
 import Data.Maybe            (isJust, isNothing)
 import GHC.Exts              (touch#)
 import GHC.IO                (IO (..))
+import Numeric.Natural       (Natural)
 import System.Mem            (performGC)
 import System.Mem.Weak       (deRefWeak, mkWeakPtr)
 import System.Random         (randomIO)
@@ -225,6 +227,27 @@ issue382 = do
   touch v -- makes sure that we didn't GC away the combined value
   assert $ isNothing res
 
+------------------------------------------------------------------------
+-- Issue #383
+
+#ifdef HAVE_NOTHUNKS
+
+-- Custom Functor to prevent interference from alterF rules
+newtype MyIdentity a = MyIdentity a
+instance Functor MyIdentity where
+  fmap f (MyIdentity x) = MyIdentity (f x)
+
+issue383 :: Assertion
+issue383 = do
+  i :: Int <- randomIO
+  let f Nothing = MyIdentity (Just (fromIntegral @Int @Natural (abs i)))
+      f Just{}  = MyIdentity (error "Impossible")
+  let (MyIdentity m) = HMS.alterF f () mempty
+  mThunkInfo <- noThunksInValues mempty (Foldable.toList m)
+  assert $ isNothing mThunkInfo
+
+#endif
+
 ------------------------------------------------------------------------
 -- * Test list
 
@@ -251,4 +274,7 @@ tests = testGroup "Regression tests"
           ]
 #endif
     , testCase "issue382" issue382
+#ifdef HAVE_NOTHUNKS
+    , testCase "issue383" issue383
+#endif
     ]