diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index da29f5d07..9c094f18b 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 000000000..a7dda281e --- /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 735b181fa..6905c960b 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -3,13 +3,19 @@ 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 @@ -76,6 +82,79 @@ pInsertLookupWithKeyValueStrict f k v m not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m) | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m +------------------------------------------------------------------------ +-- test a corner case of fromAscList +-- +-- If the list contains duplicate keys, then (only) the first of the +-- given values is not evaluated. This may change in the future, see +-- also https://github.com/haskell/containers/issues/473 + +pFromAscListLazy :: [Int] -> Bool +pFromAscListLazy ks = not . isBottom $ M.fromAscList elems + where + elems = [(k, v) | k <- nubInt ks, v <- [undefined, ()]] + +pFromAscListStrict :: [Int] -> Bool +pFromAscListStrict ks + | null ks = not . isBottom $ M.fromAscList elems + | otherwise = isBottom $ M.fromAscList elems + 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 @@ -103,7 +182,11 @@ tests = pInsertLookupWithKeyKeyStrict , testProperty "insertLookupWithKey is value-strict" pInsertLookupWithKeyValueStrict + , 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 6bc317f47..e3605185b 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 ] ------------------------------------------------------------------------