Merge pull request #153 from treeowl/fromList-strict-fix

Fix strictness bug in Strict.fromListWith

Author: tibbe

Data/HashMap/Strict.hs

@@ -183,7 +183,7 @@ unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0)
                     else do
                         let l' = x `seq` (L k x)
                         return $! collision h l l'
-        | otherwise = two s h k x hy ky y
+        | otherwise = x `seq` two s h k x hy ky y
     go h k x s t@(BitmapIndexed b ary)
         | b .&. m == 0 = do
             ary' <- A.insertM ary i $! leaf h k x

tests/Strictness.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Main (main) where
@@ -7,7 +7,18 @@ import Data.Hashable (Hashable(hashWithSalt))
 import Test.ChasingBottoms.IsBottom
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck (Arbitrary(arbitrary))
+import Test.QuickCheck (Arbitrary(arbitrary), Property, (===), (.&&.))
+import Test.QuickCheck.Function
+import Test.QuickCheck.Poly (A)
+import Data.Maybe (fromMaybe, isJust)
+import Control.Arrow (second)
+import Control.Monad (guard)
+import Data.Foldable (foldl')
+#if !MIN_VERSION_base(4,8,0)
+import Data.Functor ((<$))
+import Data.Foldable (all)
+import Prelude hiding (all)
+#endif
 
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HM
@@ -79,10 +90,63 @@ pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool
 pFromListWithKeyStrict f =
     isBottom $ HM.fromListWith f [(undefined :: Key, 1 :: Int)]
 
-pFromListWithValueStrict :: [(Key, Int)] -> Bool
-pFromListWithValueStrict xs = case xs of
-    [] -> True
-    (x:_) -> isBottom $ HM.fromListWith (\ _ _ -> undefined) (x:xs)
+-- The strictness properties of 'fromListWith' are not entirely
+-- trivial.
+-- fromListWith f kvs is strict in the first value seen for each
+-- key, but potentially lazy in the rest: the combining function
+-- could be lazy in the "new" value. fromListWith must, however,
+-- be strict in whatever value is actually inserted into the map.
+-- Getting all these properties specified efficiently seems tricky.
+-- Since it's not hard, we verify that the converted HashMap has
+-- no unforced values. Rather than trying to go into detail for the
+-- rest, this test compares the strictness behavior of fromListWith
+-- to that of insertWith. The latter should be easier to specify
+-- and (if we choose to do so) test thoroughly.
+--
+-- We'll fake up a representation of things that are possibly
+-- bottom by using Nothing to represent bottom. The combining
+-- (partial) function is represented by a "lazy total" function
+-- Maybe a -> Maybe a -> Maybe a, along with a function determining
+-- whether the result should be non-bottom, Maybe a -> Maybe a -> Bool,
+-- indicating how the combining function should behave if neither
+-- argument, just the first argument, just the second argument,
+-- or both arguments are bottom. It would be quite tempting to
+-- just use Maybe A -> Maybe A -> Maybe A, but that would not
+-- necessarily be continous.
+pFromListWithValueResultStrict :: [(Key, Maybe A)]
+                               -> Fun (Maybe A, Maybe A) A
+                               -> Fun (Maybe A, Maybe A) Bool
+                               -> Property
+pFromListWithValueResultStrict lst comb_lazy calc_good_raw
+         = all (all isJust) recovered .&&. (recovered === recover (fmap recover fake_map))
+  where
+    recovered :: Maybe (HashMap Key (Maybe A))
+    recovered = recover (fmap recover real_map)
+    -- What we get out of the conversion using insertWith
+    fake_map = foldl' (\m (k,v) -> HM.insertWith real_comb k v m) HM.empty real_list
+
+    -- A continuous version of calc_good_raw
+    calc_good Nothing Nothing = cgr Nothing Nothing
+    calc_good Nothing y@(Just _) = cgr Nothing Nothing || cgr Nothing y
+    calc_good x@(Just _) Nothing = cgr Nothing Nothing || cgr x Nothing
+    calc_good x y = cgr Nothing Nothing || cgr Nothing y || cgr x Nothing || cgr x y
+    cgr = curry $ apply calc_good_raw
+
+    -- The Maybe A -> Maybe A -> Maybe A that we're after, representing a
+    -- potentially less total function than comb_lazy
+    comb x y = apply comb_lazy (x, y) <$ guard (calc_good x y)
+
+    -- What we get out of the conversion using fromListWith
+    real_map = HM.fromListWith real_comb real_list
+
+    -- A list that may have actual bottom values in it.
+    real_list = map (second (fromMaybe bottom)) lst
+
+    -- A genuinely partial function mirroring comb
+    real_comb x y = fromMaybe bottom $ comb (recover x) (recover y)
+
+    recover :: a -> Maybe a
+    recover a = a <$ guard (not $ isBottom a)
 
 ------------------------------------------------------------------------
 -- * Test list
@@ -108,7 +172,7 @@ tests =
       , testProperty "fromList is key-strict" pFromListKeyStrict
       , testProperty "fromList is value-strict" pFromListValueStrict
       , testProperty "fromListWith is key-strict" pFromListWithKeyStrict
-      , testProperty "fromListWith is value-strict" pFromListWithValueStrict
+      , testProperty "fromListWith is value-strict" pFromListWithValueResultStrict
       ]
     ]