#254, add a regression test

Author: ndmitchell

tests/Regressions.hs

@@ -1,10 +1,15 @@
 module Main where
 
 import Control.Applicative ((<$>))
+import Control.Exception (evaluate)
 import Control.Monad (replicateM)
+import Data.Hashable (Hashable(..))
 import qualified Data.HashMap.Strict as HM
+import qualified Data.HashMap.Lazy as HML
 import Data.List (delete)
 import Data.Maybe
+import System.Mem (performGC)
+import System.Mem.Weak (mkWeakPtr, deRefWeak)
 import Test.HUnit (Assertion, assert)
 import Test.Framework (Test, defaultMain)
 import Test.Framework.Providers.HUnit (testCase)
@@ -71,6 +76,48 @@ propEqAfterDelete (Keys keys) =
 mapFromKeys :: [Int] -> HM.HashMap Int ()
 mapFromKeys keys = HM.fromList (zip keys (repeat ()))
 
+------------------------------------------------------------------------
+-- Issue #254
+
+data KC = KC Int
+  deriving (Eq, Ord, Show)
+instance Hashable KC where
+  hashWithSalt salt _ = salt
+
+issue254Lazy :: Assertion
+issue254Lazy = issue254LazyLambda 2
+
+-- Important that oldV is not hoisted out by optimisation, so use NOINLINE
+{-# NOINLINE issue254LazyLambda #-}
+issue254LazyLambda :: Int -> Assertion
+issue254LazyLambda i = do
+  _ <- return ()
+  let oldV = show i
+  weakV <- mkWeakPtr oldV Nothing
+  let mp = HML.insert (KC 1) "3" $ HML.fromList [(KC 0, "1"), (KC 1, oldV)]
+  _ <- evaluate mp
+  performGC
+  res <- deRefWeak weakV
+  _ <- evaluate mp
+  assert $ isNothing res
+
+issue254Strict :: Assertion
+issue254Strict = issue254StrictLambda 2
+
+-- Important that oldV is not hoisted out by optimisation, so use NOINLINE
+{-# NOINLINE issue254StrictLambda #-}
+issue254StrictLambda :: Int -> Assertion
+issue254StrictLambda i = do
+  _ <- return ()
+  let oldV = show i
+  weakV <- mkWeakPtr oldV Nothing
+  let mp = HM.insert (KC 1) "3" $ HM.fromList [(KC 0, "1"), (KC 1, oldV)]
+  _ <- evaluate mp
+  performGC
+  res <- deRefWeak weakV
+  _ <- evaluate mp
+  assert $ isNothing res
+
 ------------------------------------------------------------------------
 -- * Test list
 
@@ -80,6 +127,8 @@ tests =
       testCase "issue32" issue32
     , testCase "issue39a" issue39
     , testProperty "issue39b" propEqAfterDelete
+    , testCase "issue254 lazy" issue254Lazy
+    , testCase "issue254 strict" issue254Strict
     ]
 
 ------------------------------------------------------------------------