@@ -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
@@ -987,74 +986,6 @@ pStrictFoldlWithKey' :: Map Int Int -> Property
987986pStrictFoldlWithKey' m = whnfHasNoThunks (M. foldlWithKey' (\ as _ a -> a : as) [] m)
988987#endif
989988
990- #if __GLASGOW_HASKELL__ >= 806
991- pStrictFromDistinctAscList :: [Int ] -> Property
992- pStrictFromDistinctAscList = whnfHasNoThunks . evalSpine . M. elems . M. fromDistinctAscList . zip [0 :: Int .. ] . map (Just $! )
993- where
994- evalSpine xs = length xs `seq` xs
995- #endif
996-
997- #if __GLASGOW_HASKELL__ >= 806
998- pStrictFromDistinctDescList :: [Int ] -> Property
999- pStrictFromDistinctDescList = whnfHasNoThunks . evalSpine . M. elems . M. fromDistinctDescList . zip [0 :: Int , - 1 .. ] . map (Just $! )
1000- where
1001- evalSpine xs = length xs `seq` xs
1002- #endif
1003-
1004- ------------------------------------------------------------------------
1005- -- check for extra thunks
1006- --
1007- -- These tests distinguish between `()`, a fully evaluated value, and
1008- -- things like `id ()` which are extra thunks that should be avoided
1009- -- in most cases. An exception is `L.fromListWith const`, which cannot
1010- -- evaluate the `const` calls.
1011-
1012- tExtraThunksM :: TestTree
1013- tExtraThunksM = testGroup " Map.Strict - extra thunks" $
1014- if not isUnitSupported then [] else
1015- -- for strict maps, all the values should be evaluated to ()
1016- [ check " singleton" $ m0
1017- , check " insert" $ M. insert 42 () m0
1018- , check " insertWith" $ M. insertWith const 42 () m0
1019- , check " fromList" $ M. fromList [(42 ,() ),(42 ,() )]
1020- , check " fromListWith" $ M. fromListWith const [(42 ,() ),(42 ,() )]
1021- , check " fromAscList" $ M. fromAscList [(42 ,() ),(42 ,() )]
1022- , check " fromAscListWith" $ M. fromAscListWith const [(42 ,() ),(42 ,() )]
1023- , check " fromDistinctAscList" $ M. fromAscList [(42 ,() )]
1024- ]
1025- where
1026- m0 = M. singleton 42 ()
1027- check :: TestName -> Map Int () -> TestTree
1028- check n m = testCase n $ case M. lookup 42 m of
1029- Just v -> assertBool msg (isUnit v)
1030- _ -> assertBool " key not found" False
1031- where
1032- msg = " too lazy -- expected fully evaluated ()"
1033-
1034- tExtraThunksL :: TestTree
1035- tExtraThunksL = testGroup " Map.Lazy - extra thunks" $
1036- if not isUnitSupported then [] else
1037- -- for lazy maps, the *With functions should leave `const () ()` thunks,
1038- -- but the other functions should produce fully evaluated ().
1039- [ check " singleton" True $ m0
1040- , check " insert" True $ L. insert 42 () m0
1041- , check " insertWith" False $ L. insertWith const 42 () m0
1042- , check " fromList" True $ L. fromList [(42 ,() ),(42 ,() )]
1043- , check " fromListWith" False $ L. fromListWith const [(42 ,() ),(42 ,() )]
1044- , check " fromAscList" True $ L. fromAscList [(42 ,() ),(42 ,() )]
1045- , check " fromAscListWith" False $ L. fromAscListWith const [(42 ,() ),(42 ,() )]
1046- , check " fromDistinctAscList" True $ L. fromAscList [(42 ,() )]
1047- ]
1048- where
1049- m0 = L. singleton 42 ()
1050- check :: TestName -> Bool -> L. Map Int () -> TestTree
1051- check n e m = testCase n $ case L. lookup 42 m of
1052- Just v -> assertBool msg (e == isUnit v)
1053- _ -> assertBool " key not found" False
1054- where
1055- msg | e = " too lazy -- expected fully evaluated ()"
1056- | otherwise = " too strict -- expected a thunk"
1057-
1058989------------------------------------------------------------------------
1059990-- * Test list
1060991
@@ -1086,12 +1017,8 @@ tests =
10861017 , testProperty " strict foldl'" pStrictFoldl'
10871018 , testProperty " strict foldrWithKey'" pStrictFoldrWithKey'
10881019 , testProperty " strict foldlWithKey'" pStrictFoldlWithKey'
1089- , testProperty " strict fromDistinctAscList" pStrictFromDistinctAscList
1090- , testProperty " strict fromDistinctDescList" pStrictFromDistinctDescList
10911020#endif
10921021 ]
1093- , tExtraThunksM
1094- , tExtraThunksL
10951022
10961023 , testGroup " Map.Strict construction"
10971024 [ testProperty " singleton" prop_strictSingleton
0 commit comments