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

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

containers-tests/tests/Utils/IsUnit.hs

+{-# 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

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
     ]
 
 ------------------------------------------------------------------------

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
     ]
 
 ------------------------------------------------------------------------