diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal
index da29f5d077757a9ab6db960c788308b6c86601e8..9c094f18b5dd266f257436b086e72838b7477092 100644
--- a/containers-tests/containers-tests.cabal
+++ b/containers-tests/containers-tests.cabal
@@ -460,15 +460,20 @@ test-suite map-strictness-properties
, base >=4.6 && <5
, ChasingBottoms
, deepseq >=1.2 && <1.5
+ , HUnit
, QuickCheck >=2.7.1
, test-framework >=0.3.3
, test-framework-quickcheck2 >=0.2.9
+ , test-framework-hunit
ghc-options: -Wall
other-extensions:
BangPatterns
CPP
+ other-modules:
+ Utils.IsUnit
+
test-suite intmap-strictness-properties
default-language: Haskell2010
hs-source-dirs: tests
@@ -484,12 +489,17 @@ test-suite intmap-strictness-properties
, base >=4.6 && <5
, ChasingBottoms
, deepseq >=1.2 && <1.5
+ , HUnit
, QuickCheck >=2.7.1
, test-framework >=0.3.3
, test-framework-quickcheck2 >=0.2.9
+ , test-framework-hunit
ghc-options: -Wall
+ other-modules:
+ Utils.IsUnit
+
test-suite intset-strictness-properties
default-language: Haskell2010
hs-source-dirs: tests
diff --git a/containers-tests/tests/Utils/IsUnit.hs b/containers-tests/tests/Utils/IsUnit.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a7dda281e2e906c66551ddac8e79816836ed7d71
--- /dev/null
+++ b/containers-tests/tests/Utils/IsUnit.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE MagicHash #-}
+#endif
+
+module Utils.IsUnit (isUnit, isUnitSupported) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts
+#endif
+
+-- | Check whether the argument is a fully evaluated unit `()`.
+--
+-- Always returns `False` is `isUnitSupported` returns `False`.
+--
+-- Uses `reallyUnsafePtrEquality#`.
+isUnit :: () -> Bool
+
+-- | Checks whether `isUnit` is supported by the Haskell implementation.
+--
+-- Currently returns `True` for ghc and `False` for all other implementations.
+isUnitSupported :: Bool
+
+#ifdef __GLASGOW_HASKELL__
+
+-- simplified from Utils.Containers.Internal.PtrEquality
+ptrEq :: a -> a -> Bool
+ptrEq x y = case reallyUnsafePtrEquality# x y of
+ 0# -> False
+ _ -> True
+
+isUnit = ptrEq ()
+
+isUnitSupported = True
+
+#else /* !__GLASGOW_HASKELL__ */
+
+isUnit = False
+
+isUnitSupported = False
+
+#endif
diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs
index 22e3e12997f6b688d28e9d951cac45630fe9b581..6905c960b8e0c0046940749f753fdae8342c9ca7 100644
--- a/containers-tests/tests/intmap-strictness.hs
+++ b/containers-tests/tests/intmap-strictness.hs
@@ -3,16 +3,20 @@
module Main (main) where
import Test.ChasingBottoms.IsBottom
-import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework (Test, TestName, defaultMain, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck (Arbitrary(arbitrary))
import Test.QuickCheck.Function (Fun(..), apply)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as M
import qualified Data.IntMap as L
import Data.Containers.ListUtils
+import Utils.IsUnit
+
instance Arbitrary v => Arbitrary (IntMap v) where
arbitrary = M.fromList `fmap` arbitrary
@@ -97,6 +101,60 @@ pFromAscListStrict ks
where
elems = [(k, v) | k <- nubInt ks, v <- [undefined, undefined, ()]]
+------------------------------------------------------------------------
+-- check for extra thunks
+--
+-- These tests distinguish between `()`, a fully evaluated value, and
+-- things like `id ()` which are extra thunks that should be avoided
+-- in most cases. An exception is `L.fromListWith const`, which cannot
+-- evaluate the `const` calls.
+
+tExtraThunksM :: Test
+tExtraThunksM = testGroup "IntMap.Strict - extra thunks" $
+ if not isUnitSupported then [] else
+ -- for strict maps, all the values should be evaluated to ()
+ [ check "singleton" $ m0
+ , check "insert" $ M.insert 42 () m0
+ , check "insertWith" $ M.insertWith const 42 () m0
+ , check "fromList" $ M.fromList [(42,()),(42,())]
+ , check "fromListWith" $ M.fromListWith const [(42,()),(42,())]
+ , check "fromAscList" $ M.fromAscList [(42,()),(42,())]
+ , check "fromAscListWith" $ M.fromAscListWith const [(42,()),(42,())]
+ , check "fromDistinctAscList" $ M.fromAscList [(42,())]
+ ]
+ where
+ m0 = M.singleton 42 ()
+ check :: TestName -> IntMap () -> Test
+ check n m = testCase n $ case M.lookup 42 m of
+ Just v -> assertBool msg (isUnit v)
+ _ -> assertString "key not found"
+ where
+ msg = "too lazy -- expected fully evaluated ()"
+
+tExtraThunksL :: Test
+tExtraThunksL = testGroup "IntMap.Strict - extra thunks" $
+ if not isUnitSupported then [] else
+ -- for lazy maps, the *With functions should leave `const () ()` thunks,
+ -- but the other functions should produce fully evaluated ().
+ [ check "singleton" True $ m0
+ , check "insert" True $ L.insert 42 () m0
+ , check "insertWith" False $ L.insertWith const 42 () m0
+ , check "fromList" True $ L.fromList [(42,()),(42,())]
+ , check "fromListWith" False $ L.fromListWith const [(42,()),(42,())]
+ , check "fromAscList" True $ L.fromAscList [(42,()),(42,())]
+ , check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]
+ , check "fromDistinctAscList" True $ L.fromAscList [(42,())]
+ ]
+ where
+ m0 = L.singleton 42 ()
+ check :: TestName -> Bool -> IntMap () -> Test
+ check n e m = testCase n $ case L.lookup 42 m of
+ Just v -> assertBool msg (e == isUnit v)
+ _ -> assertString "key not found"
+ where
+ msg | e = "too lazy -- expected fully evaluated ()"
+ | otherwise = "too strict -- expected a thunk"
+
------------------------------------------------------------------------
-- * Test list
@@ -127,6 +185,8 @@ tests =
, testProperty "fromAscList is somewhat value-lazy" pFromAscListLazy
, testProperty "fromAscList is somewhat value-strict" pFromAscListStrict
]
+ , tExtraThunksM
+ , tExtraThunksL
]
------------------------------------------------------------------------
diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs
index 6bc317f47858168fbecaa824299be720c9ed695d..e3605185b240669d0a23fcaff3a2b43f99ad3a53 100644
--- a/containers-tests/tests/map-strictness.hs
+++ b/containers-tests/tests/map-strictness.hs
@@ -3,13 +3,18 @@
module Main (main) where
import Test.ChasingBottoms.IsBottom
-import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework (Test, TestName, defaultMain, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck (Arbitrary(arbitrary))
import Test.QuickCheck.Function (Fun(..), apply)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
+import qualified Data.Map as L
+
+import Utils.IsUnit
instance (Arbitrary k, Arbitrary v, Ord k) =>
Arbitrary (Map k v) where
@@ -77,6 +82,60 @@ pInsertLookupWithKeyValueStrict f k v m
not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
| otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
+------------------------------------------------------------------------
+-- check for extra thunks
+--
+-- These tests distinguish between `()`, a fully evaluated value, and
+-- things like `id ()` which are extra thunks that should be avoided
+-- in most cases. An exception is `L.fromListWith const`, which cannot
+-- evaluate the `const` calls.
+
+tExtraThunksM :: Test
+tExtraThunksM = testGroup "Map.Strict - extra thunks" $
+ if not isUnitSupported then [] else
+ -- for strict maps, all the values should be evaluated to ()
+ [ check "singleton" $ m0
+ , check "insert" $ M.insert 42 () m0
+ , check "insertWith" $ M.insertWith const 42 () m0
+ , check "fromList" $ M.fromList [(42,()),(42,())]
+ , check "fromListWith" $ M.fromListWith const [(42,()),(42,())]
+ , check "fromAscList" $ M.fromAscList [(42,()),(42,())]
+ , check "fromAscListWith" $ M.fromAscListWith const [(42,()),(42,())]
+ , check "fromDistinctAscList" $ M.fromAscList [(42,())]
+ ]
+ where
+ m0 = M.singleton 42 ()
+ check :: TestName -> M.Map Int () -> Test
+ check n m = testCase n $ case M.lookup 42 m of
+ Just v -> assertBool msg (isUnit v)
+ _ -> assertString "key not found"
+ where
+ msg = "too lazy -- expected fully evaluated ()"
+
+tExtraThunksL :: Test
+tExtraThunksL = testGroup "Map.Lazy - extra thunks" $
+ if not isUnitSupported then [] else
+ -- for lazy maps, the *With functions should leave `const () ()` thunks,
+ -- but the other functions should produce fully evaluated ().
+ [ check "singleton" True $ m0
+ , check "insert" True $ L.insert 42 () m0
+ , check "insertWith" False $ L.insertWith const 42 () m0
+ , check "fromList" True $ L.fromList [(42,()),(42,())]
+ , check "fromListWith" False $ L.fromListWith const [(42,()),(42,())]
+ , check "fromAscList" True $ L.fromAscList [(42,()),(42,())]
+ , check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]
+ , check "fromDistinctAscList" True $ L.fromAscList [(42,())]
+ ]
+ where
+ m0 = L.singleton 42 ()
+ check :: TestName -> Bool -> L.Map Int () -> Test
+ check n e m = testCase n $ case L.lookup 42 m of
+ Just v -> assertBool msg (e == isUnit v)
+ _ -> assertString "key not found"
+ where
+ msg | e = "too lazy -- expected fully evaluated ()"
+ | otherwise = "too strict -- expected a thunk"
+
------------------------------------------------------------------------
-- * Test list
@@ -104,6 +163,8 @@ tests =
, testProperty "insertLookupWithKey is value-strict"
pInsertLookupWithKeyValueStrict
]
+ , tExtraThunksM
+ , tExtraThunksL
]
------------------------------------------------------------------------