Skip to content

Commit be721ad

Browse files
authored
Merge pull request #153 from treeowl/fromList-strict-fix
Fix strictness bug in Strict.fromListWith
2 parents 4126f2b + ed56bd1 commit be721ad

File tree

2 files changed

+72
-8
lines changed

2 files changed

+72
-8
lines changed

Data/HashMap/Strict.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -183,7 +183,7 @@ unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0)
183183
else do
184184
let l' = x `seq` (L k x)
185185
return $! collision h l l'
186-
| otherwise = two s h k x hy ky y
186+
| otherwise = x `seq` two s h k x hy ky y
187187
go h k x s t@(BitmapIndexed b ary)
188188
| b .&. m == 0 = do
189189
ary' <- A.insertM ary i $! leaf h k x

tests/Strictness.hs

Lines changed: 71 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
1+
{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-}
22
{-# OPTIONS_GHC -fno-warn-orphans #-}
33

44
module Main (main) where
@@ -7,7 +7,18 @@ import Data.Hashable (Hashable(hashWithSalt))
77
import Test.ChasingBottoms.IsBottom
88
import Test.Framework (Test, defaultMain, testGroup)
99
import Test.Framework.Providers.QuickCheck2 (testProperty)
10-
import Test.QuickCheck (Arbitrary(arbitrary))
10+
import Test.QuickCheck (Arbitrary(arbitrary), Property, (===), (.&&.))
11+
import Test.QuickCheck.Function
12+
import Test.QuickCheck.Poly (A)
13+
import Data.Maybe (fromMaybe, isJust)
14+
import Control.Arrow (second)
15+
import Control.Monad (guard)
16+
import Data.Foldable (foldl')
17+
#if !MIN_VERSION_base(4,8,0)
18+
import Data.Functor ((<$))
19+
import Data.Foldable (all)
20+
import Prelude hiding (all)
21+
#endif
1122

1223
import Data.HashMap.Strict (HashMap)
1324
import qualified Data.HashMap.Strict as HM
@@ -79,10 +90,63 @@ pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool
7990
pFromListWithKeyStrict f =
8091
isBottom $ HM.fromListWith f [(undefined :: Key, 1 :: Int)]
8192

82-
pFromListWithValueStrict :: [(Key, Int)] -> Bool
83-
pFromListWithValueStrict xs = case xs of
84-
[] -> True
85-
(x:_) -> isBottom $ HM.fromListWith (\ _ _ -> undefined) (x:xs)
93+
-- The strictness properties of 'fromListWith' are not entirely
94+
-- trivial.
95+
-- fromListWith f kvs is strict in the first value seen for each
96+
-- key, but potentially lazy in the rest: the combining function
97+
-- could be lazy in the "new" value. fromListWith must, however,
98+
-- be strict in whatever value is actually inserted into the map.
99+
-- Getting all these properties specified efficiently seems tricky.
100+
-- Since it's not hard, we verify that the converted HashMap has
101+
-- no unforced values. Rather than trying to go into detail for the
102+
-- rest, this test compares the strictness behavior of fromListWith
103+
-- to that of insertWith. The latter should be easier to specify
104+
-- and (if we choose to do so) test thoroughly.
105+
--
106+
-- We'll fake up a representation of things that are possibly
107+
-- bottom by using Nothing to represent bottom. The combining
108+
-- (partial) function is represented by a "lazy total" function
109+
-- Maybe a -> Maybe a -> Maybe a, along with a function determining
110+
-- whether the result should be non-bottom, Maybe a -> Maybe a -> Bool,
111+
-- indicating how the combining function should behave if neither
112+
-- argument, just the first argument, just the second argument,
113+
-- or both arguments are bottom. It would be quite tempting to
114+
-- just use Maybe A -> Maybe A -> Maybe A, but that would not
115+
-- necessarily be continous.
116+
pFromListWithValueResultStrict :: [(Key, Maybe A)]
117+
-> Fun (Maybe A, Maybe A) A
118+
-> Fun (Maybe A, Maybe A) Bool
119+
-> Property
120+
pFromListWithValueResultStrict lst comb_lazy calc_good_raw
121+
= all (all isJust) recovered .&&. (recovered === recover (fmap recover fake_map))
122+
where
123+
recovered :: Maybe (HashMap Key (Maybe A))
124+
recovered = recover (fmap recover real_map)
125+
-- What we get out of the conversion using insertWith
126+
fake_map = foldl' (\m (k,v) -> HM.insertWith real_comb k v m) HM.empty real_list
127+
128+
-- A continuous version of calc_good_raw
129+
calc_good Nothing Nothing = cgr Nothing Nothing
130+
calc_good Nothing y@(Just _) = cgr Nothing Nothing || cgr Nothing y
131+
calc_good x@(Just _) Nothing = cgr Nothing Nothing || cgr x Nothing
132+
calc_good x y = cgr Nothing Nothing || cgr Nothing y || cgr x Nothing || cgr x y
133+
cgr = curry $ apply calc_good_raw
134+
135+
-- The Maybe A -> Maybe A -> Maybe A that we're after, representing a
136+
-- potentially less total function than comb_lazy
137+
comb x y = apply comb_lazy (x, y) <$ guard (calc_good x y)
138+
139+
-- What we get out of the conversion using fromListWith
140+
real_map = HM.fromListWith real_comb real_list
141+
142+
-- A list that may have actual bottom values in it.
143+
real_list = map (second (fromMaybe bottom)) lst
144+
145+
-- A genuinely partial function mirroring comb
146+
real_comb x y = fromMaybe bottom $ comb (recover x) (recover y)
147+
148+
recover :: a -> Maybe a
149+
recover a = a <$ guard (not $ isBottom a)
86150

87151
------------------------------------------------------------------------
88152
-- * Test list
@@ -108,7 +172,7 @@ tests =
108172
, testProperty "fromList is key-strict" pFromListKeyStrict
109173
, testProperty "fromList is value-strict" pFromListValueStrict
110174
, testProperty "fromListWith is key-strict" pFromListWithKeyStrict
111-
, testProperty "fromListWith is value-strict" pFromListWithValueStrict
175+
, testProperty "fromListWith is value-strict" pFromListWithValueResultStrict
112176
]
113177
]
114178

0 commit comments

Comments
 (0)