@@ -15,9 +15,8 @@ import qualified Data.List.NonEmpty as NE
1515import Data.Ord (Down (.. ), comparing )
1616import Data.Maybe (catMaybes , mapMaybe )
1717import Data.Semigroup (Arg (.. ))
18- import Test.ChasingBottoms.IsBottom
19- import Test.Tasty (TestTree , TestName , defaultMain , testGroup )
20- import Test.Tasty.HUnit
18+ import Test.ChasingBottoms.IsBottom (bottom , isBottom )
19+ import Test.Tasty (TestTree , defaultMain , testGroup )
2120import Test.Tasty.QuickCheck (testProperty )
2221import Test.QuickCheck
2322import Test.QuickCheck.Function
@@ -32,9 +31,9 @@ import qualified Data.Map.Merge.Lazy as LMerge
3231import Data.Set (Set )
3332import qualified Data.Set as Set
3433
35- import Utils.IsUnit
3634import Utils.Strictness
3735 (Bot (.. ), Func (.. ), Func2 (.. ), Func3 (.. ), applyFunc , applyFunc2 , applyFunc3 )
36+
3837#if __GLASGOW_HASKELL__ >= 806
3938import Utils.NoThunks
4039#endif
@@ -998,74 +997,6 @@ pStrictFoldlWithKey' :: Map Int Int -> Property
998997pStrictFoldlWithKey' m = whnfHasNoThunks (M. foldlWithKey' (\ as _ a -> a : as) [] m)
999998#endif
1000999
1001- #if __GLASGOW_HASKELL__ >= 806
1002- pStrictFromDistinctAscList :: [Int ] -> Property
1003- pStrictFromDistinctAscList = whnfHasNoThunks . evalSpine . M. elems . M. fromDistinctAscList . zip [0 :: Int .. ] . map (Just $! )
1004- where
1005- evalSpine xs = length xs `seq` xs
1006- #endif
1007-
1008- #if __GLASGOW_HASKELL__ >= 806
1009- pStrictFromDistinctDescList :: [Int ] -> Property
1010- pStrictFromDistinctDescList = whnfHasNoThunks . evalSpine . M. elems . M. fromDistinctDescList . zip [0 :: Int , - 1 .. ] . map (Just $! )
1011- where
1012- evalSpine xs = length xs `seq` xs
1013- #endif
1014-
1015- ------------------------------------------------------------------------
1016- -- check for extra thunks
1017- --
1018- -- These tests distinguish between `()`, a fully evaluated value, and
1019- -- things like `id ()` which are extra thunks that should be avoided
1020- -- in most cases. An exception is `L.fromListWith const`, which cannot
1021- -- evaluate the `const` calls.
1022-
1023- tExtraThunksM :: TestTree
1024- tExtraThunksM = testGroup " Map.Strict - extra thunks" $
1025- if not isUnitSupported then [] else
1026- -- for strict maps, all the values should be evaluated to ()
1027- [ check " singleton" $ m0
1028- , check " insert" $ M. insert 42 () m0
1029- , check " insertWith" $ M. insertWith const 42 () m0
1030- , check " fromList" $ M. fromList [(42 ,() ),(42 ,() )]
1031- , check " fromListWith" $ M. fromListWith const [(42 ,() ),(42 ,() )]
1032- , check " fromAscList" $ M. fromAscList [(42 ,() ),(42 ,() )]
1033- , check " fromAscListWith" $ M. fromAscListWith const [(42 ,() ),(42 ,() )]
1034- , check " fromDistinctAscList" $ M. fromAscList [(42 ,() )]
1035- ]
1036- where
1037- m0 = M. singleton 42 ()
1038- check :: TestName -> Map Int () -> TestTree
1039- check n m = testCase n $ case M. lookup 42 m of
1040- Just v -> assertBool msg (isUnit v)
1041- _ -> assertBool " key not found" False
1042- where
1043- msg = " too lazy -- expected fully evaluated ()"
1044-
1045- tExtraThunksL :: TestTree
1046- tExtraThunksL = testGroup " Map.Lazy - extra thunks" $
1047- if not isUnitSupported then [] else
1048- -- for lazy maps, the *With functions should leave `const () ()` thunks,
1049- -- but the other functions should produce fully evaluated ().
1050- [ check " singleton" True $ m0
1051- , check " insert" True $ L. insert 42 () m0
1052- , check " insertWith" False $ L. insertWith const 42 () m0
1053- , check " fromList" True $ L. fromList [(42 ,() ),(42 ,() )]
1054- , check " fromListWith" False $ L. fromListWith const [(42 ,() ),(42 ,() )]
1055- , check " fromAscList" True $ L. fromAscList [(42 ,() ),(42 ,() )]
1056- , check " fromAscListWith" False $ L. fromAscListWith const [(42 ,() ),(42 ,() )]
1057- , check " fromDistinctAscList" True $ L. fromAscList [(42 ,() )]
1058- ]
1059- where
1060- m0 = L. singleton 42 ()
1061- check :: TestName -> Bool -> L. Map Int () -> TestTree
1062- check n e m = testCase n $ case L. lookup 42 m of
1063- Just v -> assertBool msg (e == isUnit v)
1064- _ -> assertBool " key not found" False
1065- where
1066- msg | e = " too lazy -- expected fully evaluated ()"
1067- | otherwise = " too strict -- expected a thunk"
1068-
10691000------------------------------------------------------------------------
10701001-- * Test list
10711002
@@ -1097,12 +1028,8 @@ tests =
10971028 , testProperty " strict foldl'" pStrictFoldl'
10981029 , testProperty " strict foldrWithKey'" pStrictFoldrWithKey'
10991030 , testProperty " strict foldlWithKey'" pStrictFoldlWithKey'
1100- , testProperty " strict fromDistinctAscList" pStrictFromDistinctAscList
1101- , testProperty " strict fromDistinctDescList" pStrictFromDistinctDescList
11021031#endif
11031032 ]
1104- , tExtraThunksM
1105- , tExtraThunksL
11061033 , testGroup " Map.Strict construction"
11071034 [ testProperty " singleton" prop_strictSingleton
11081035 , testProperty " fromSet" prop_strictFromSet
0 commit comments