Skip to content

Commit b64a103

Browse files
int-etreeowl
int-e
authored and
treeowl
committed
add tests for extra thunks in maps
- we check most functions that create or update entries, namely singleton, insert, insertWith, fromList, fromListWith, fromAscList, fromDistinctAscList, and fromAscListWith
1 parent 9765edd commit b64a103

File tree

4 files changed

+175
-2
lines changed

4 files changed

+175
-2
lines changed

‎containers-tests/containers-tests.cabal

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -460,15 +460,20 @@ test-suite map-strictness-properties
460460
, base >=4.6 && <5
461461
, ChasingBottoms
462462
, deepseq >=1.2 && <1.5
463+
, HUnit
463464
, QuickCheck >=2.7.1
464465
, test-framework >=0.3.3
465466
, test-framework-quickcheck2 >=0.2.9
467+
, test-framework-hunit
466468

467469
ghc-options: -Wall
468470
other-extensions:
469471
BangPatterns
470472
CPP
471473

474+
other-modules:
475+
Utils.IsUnit
476+
472477
test-suite intmap-strictness-properties
473478
default-language: Haskell2010
474479
hs-source-dirs: tests
@@ -484,12 +489,17 @@ test-suite intmap-strictness-properties
484489
, base >=4.6 && <5
485490
, ChasingBottoms
486491
, deepseq >=1.2 && <1.5
492+
, HUnit
487493
, QuickCheck >=2.7.1
488494
, test-framework >=0.3.3
489495
, test-framework-quickcheck2 >=0.2.9
496+
, test-framework-hunit
490497

491498
ghc-options: -Wall
492499

500+
other-modules:
501+
Utils.IsUnit
502+
493503
test-suite intset-strictness-properties
494504
default-language: Haskell2010
495505
hs-source-dirs: tests

‎containers-tests/tests/Utils/IsUnit.hs

Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
{-# LANGUAGE CPP #-}
2+
#ifdef __GLASGOW_HASKELL__
3+
{-# LANGUAGE MagicHash #-}
4+
#endif
5+
6+
module Utils.IsUnit (isUnit, isUnitSupported) where
7+
8+
#ifdef __GLASGOW_HASKELL__
9+
import GHC.Exts
10+
#endif
11+
12+
-- | Check whether the argument is a fully evaluated unit `()`.
13+
--
14+
-- Always returns `False` is `isUnitSupported` returns `False`.
15+
--
16+
-- Uses `reallyUnsafePtrEquality#`.
17+
isUnit :: () -> Bool
18+
19+
-- | Checks whether `isUnit` is supported by the Haskell implementation.
20+
--
21+
-- Currently returns `True` for ghc and `False` for all other implementations.
22+
isUnitSupported :: Bool
23+
24+
#ifdef __GLASGOW_HASKELL__
25+
26+
-- simplified from Utils.Containers.Internal.PtrEquality
27+
ptrEq :: a -> a -> Bool
28+
ptrEq x y = case reallyUnsafePtrEquality# x y of
29+
0# -> False
30+
_ -> True
31+
32+
isUnit = ptrEq ()
33+
34+
isUnitSupported = True
35+
36+
#else /* !__GLASGOW_HASKELL__ */
37+
38+
isUnit = False
39+
40+
isUnitSupported = False
41+
42+
#endif

‎containers-tests/tests/intmap-strictness.hs

Lines changed: 61 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,16 +3,20 @@
33
module Main (main) where
44

55
import Test.ChasingBottoms.IsBottom
6-
import Test.Framework (Test, defaultMain, testGroup)
6+
import Test.Framework (Test, TestName, defaultMain, testGroup)
77
import Test.Framework.Providers.QuickCheck2 (testProperty)
88
import Test.QuickCheck (Arbitrary(arbitrary))
99
import Test.QuickCheck.Function (Fun(..), apply)
10+
import Test.Framework.Providers.HUnit
11+
import Test.HUnit hiding (Test)
1012

1113
import Data.IntMap.Strict (IntMap)
1214
import qualified Data.IntMap.Strict as M
1315
import qualified Data.IntMap as L
1416
import Data.Containers.ListUtils
1517

18+
import Utils.IsUnit
19+
1620
instance Arbitrary v => Arbitrary (IntMap v) where
1721
arbitrary = M.fromList `fmap` arbitrary
1822

@@ -97,6 +101,60 @@ pFromAscListStrict ks
97101
where
98102
elems = [(k, v) | k <- nubInt ks, v <- [undefined, undefined, ()]]
99103

104+
------------------------------------------------------------------------
105+
-- check for extra thunks
106+
--
107+
-- These tests distinguish between `()`, a fully evaluated value, and
108+
-- things like `id ()` which are extra thunks that should be avoided
109+
-- in most cases. An exception is `L.fromListWith const`, which cannot
110+
-- evaluate the `const` calls.
111+
112+
tExtraThunksM :: Test
113+
tExtraThunksM = testGroup "IntMap.Strict - extra thunks" $
114+
if not isUnitSupported then [] else
115+
-- for strict maps, all the values should be evaluated to ()
116+
[ check "singleton" $ m0
117+
, check "insert" $ M.insert 42 () m0
118+
, check "insertWith" $ M.insertWith const 42 () m0
119+
, check "fromList" $ M.fromList [(42,()),(42,())]
120+
, check "fromListWith" $ M.fromListWith const [(42,()),(42,())]
121+
, check "fromAscList" $ M.fromAscList [(42,()),(42,())]
122+
, check "fromAscListWith" $ M.fromAscListWith const [(42,()),(42,())]
123+
, check "fromDistinctAscList" $ M.fromAscList [(42,())]
124+
]
125+
where
126+
m0 = M.singleton 42 ()
127+
check :: TestName -> IntMap () -> Test
128+
check n m = testCase n $ case M.lookup 42 m of
129+
Just v -> assertBool msg (isUnit v)
130+
_ -> assertString "key not found"
131+
where
132+
msg = "too lazy -- expected fully evaluated ()"
133+
134+
tExtraThunksL :: Test
135+
tExtraThunksL = testGroup "IntMap.Strict - extra thunks" $
136+
if not isUnitSupported then [] else
137+
-- for lazy maps, the *With functions should leave `const () ()` thunks,
138+
-- but the other functions should produce fully evaluated ().
139+
[ check "singleton" True $ m0
140+
, check "insert" True $ L.insert 42 () m0
141+
, check "insertWith" False $ L.insertWith const 42 () m0
142+
, check "fromList" True $ L.fromList [(42,()),(42,())]
143+
, check "fromListWith" False $ L.fromListWith const [(42,()),(42,())]
144+
, check "fromAscList" True $ L.fromAscList [(42,()),(42,())]
145+
, check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]
146+
, check "fromDistinctAscList" True $ L.fromAscList [(42,())]
147+
]
148+
where
149+
m0 = L.singleton 42 ()
150+
check :: TestName -> Bool -> IntMap () -> Test
151+
check n e m = testCase n $ case L.lookup 42 m of
152+
Just v -> assertBool msg (e == isUnit v)
153+
_ -> assertString "key not found"
154+
where
155+
msg | e = "too lazy -- expected fully evaluated ()"
156+
| otherwise = "too strict -- expected a thunk"
157+
100158
------------------------------------------------------------------------
101159
-- * Test list
102160

@@ -127,6 +185,8 @@ tests =
127185
, testProperty "fromAscList is somewhat value-lazy" pFromAscListLazy
128186
, testProperty "fromAscList is somewhat value-strict" pFromAscListStrict
129187
]
188+
, tExtraThunksM
189+
, tExtraThunksL
130190
]
131191

132192
------------------------------------------------------------------------

‎containers-tests/tests/map-strictness.hs

Lines changed: 62 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,13 +3,18 @@
33
module Main (main) where
44

55
import Test.ChasingBottoms.IsBottom
6-
import Test.Framework (Test, defaultMain, testGroup)
6+
import Test.Framework (Test, TestName, defaultMain, testGroup)
77
import Test.Framework.Providers.QuickCheck2 (testProperty)
88
import Test.QuickCheck (Arbitrary(arbitrary))
99
import Test.QuickCheck.Function (Fun(..), apply)
10+
import Test.Framework.Providers.HUnit
11+
import Test.HUnit hiding (Test)
1012

1113
import Data.Map.Strict (Map)
1214
import qualified Data.Map.Strict as M
15+
import qualified Data.Map as L
16+
17+
import Utils.IsUnit
1318

1419
instance (Arbitrary k, Arbitrary v, Ord k) =>
1520
Arbitrary (Map k v) where
@@ -77,6 +82,60 @@ pInsertLookupWithKeyValueStrict f k v m
7782
not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
7883
| otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
7984

85+
------------------------------------------------------------------------
86+
-- check for extra thunks
87+
--
88+
-- These tests distinguish between `()`, a fully evaluated value, and
89+
-- things like `id ()` which are extra thunks that should be avoided
90+
-- in most cases. An exception is `L.fromListWith const`, which cannot
91+
-- evaluate the `const` calls.
92+
93+
tExtraThunksM :: Test
94+
tExtraThunksM = testGroup "Map.Strict - extra thunks" $
95+
if not isUnitSupported then [] else
96+
-- for strict maps, all the values should be evaluated to ()
97+
[ check "singleton" $ m0
98+
, check "insert" $ M.insert 42 () m0
99+
, check "insertWith" $ M.insertWith const 42 () m0
100+
, check "fromList" $ M.fromList [(42,()),(42,())]
101+
, check "fromListWith" $ M.fromListWith const [(42,()),(42,())]
102+
, check "fromAscList" $ M.fromAscList [(42,()),(42,())]
103+
, check "fromAscListWith" $ M.fromAscListWith const [(42,()),(42,())]
104+
, check "fromDistinctAscList" $ M.fromAscList [(42,())]
105+
]
106+
where
107+
m0 = M.singleton 42 ()
108+
check :: TestName -> M.Map Int () -> Test
109+
check n m = testCase n $ case M.lookup 42 m of
110+
Just v -> assertBool msg (isUnit v)
111+
_ -> assertString "key not found"
112+
where
113+
msg = "too lazy -- expected fully evaluated ()"
114+
115+
tExtraThunksL :: Test
116+
tExtraThunksL = testGroup "Map.Lazy - extra thunks" $
117+
if not isUnitSupported then [] else
118+
-- for lazy maps, the *With functions should leave `const () ()` thunks,
119+
-- but the other functions should produce fully evaluated ().
120+
[ check "singleton" True $ m0
121+
, check "insert" True $ L.insert 42 () m0
122+
, check "insertWith" False $ L.insertWith const 42 () m0
123+
, check "fromList" True $ L.fromList [(42,()),(42,())]
124+
, check "fromListWith" False $ L.fromListWith const [(42,()),(42,())]
125+
, check "fromAscList" True $ L.fromAscList [(42,()),(42,())]
126+
, check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]
127+
, check "fromDistinctAscList" True $ L.fromAscList [(42,())]
128+
]
129+
where
130+
m0 = L.singleton 42 ()
131+
check :: TestName -> Bool -> L.Map Int () -> Test
132+
check n e m = testCase n $ case L.lookup 42 m of
133+
Just v -> assertBool msg (e == isUnit v)
134+
_ -> assertString "key not found"
135+
where
136+
msg | e = "too lazy -- expected fully evaluated ()"
137+
| otherwise = "too strict -- expected a thunk"
138+
80139
------------------------------------------------------------------------
81140
-- * Test list
82141

@@ -104,6 +163,8 @@ tests =
104163
, testProperty "insertLookupWithKey is value-strict"
105164
pInsertLookupWithKeyValueStrict
106165
]
166+
, tExtraThunksM
167+
, tExtraThunksL
107168
]
108169

109170
------------------------------------------------------------------------

0 commit comments

Comments
 (0)