diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index d6857040d..2a13b3321 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -403,6 +403,7 @@ test-suite map-strictness-properties other-modules: Utils.IsUnit + Utils.Strictness if impl(ghc >= 8.6) build-depends: diff --git a/containers-tests/tests/Utils/Strictness.hs b/containers-tests/tests/Utils/Strictness.hs new file mode 100644 index 000000000..d36e05dd0 --- /dev/null +++ b/containers-tests/tests/Utils/Strictness.hs @@ -0,0 +1,103 @@ +module Utils.Strictness + ( Bot(..) + , Func(..) + , applyFunc + , Func2(..) + , applyFunc2 + , Func3(..) + , applyFunc3 + ) where + +import Test.ChasingBottoms.IsBottom (isBottom) +import Test.QuickCheck + +{-------------------------------------------------------------------- + Bottom stuff +--------------------------------------------------------------------} + +-- | Arbitrary (Bot a) values may be bottom +newtype Bot a = Bot a + +instance Show a => Show (Bot a) where + show (Bot x) = if isBottom x then "" else show x + +instance Arbitrary a => Arbitrary (Bot a) where + arbitrary = frequency + [ (1, pure (error "")) + , (4, Bot <$> arbitrary) + ] + +{-------------------------------------------------------------------- + Lazy functions +--------------------------------------------------------------------} + +-- | Function which may be lazy in its argument +data Func a b + = FuncLazy b + | FuncStrict (Fun a b) + +instance (Show a, Show b) => Show (Func a b) where + show (FuncLazy x) = "{_lazy->" ++ show x ++ "}" + show (FuncStrict fun) = show fun + +applyFunc :: Func a b -> a -> b +applyFunc fun x = case fun of + FuncLazy y -> y + FuncStrict f -> applyFun f x + +instance (CoArbitrary a, Function a, Arbitrary b) => Arbitrary (Func a b) where + arbitrary = frequency + [ (1, FuncLazy <$> arbitrary) + , (4, FuncStrict <$> arbitrary) + ] + + shrink fun = case fun of + FuncLazy x -> FuncLazy <$> shrink x + FuncStrict f -> FuncStrict <$> shrink f + +-- | Function which may be lazy in its arguments +data Func2 a b c + = F2A (Func a (Func b c)) + | F2B (Func b (Func a c)) + deriving Show + +instance + (CoArbitrary a, Function a, CoArbitrary b, Function b, Arbitrary c) + => Arbitrary (Func2 a b c) where + arbitrary = oneof [F2A <$> arbitrary, F2B <$> arbitrary] + + shrink fun2 = case fun2 of + F2A fun -> F2A <$> shrink fun + F2B fun -> F2B <$> shrink fun + +applyFunc2 :: Func2 a b c -> a -> b -> c +applyFunc2 fun2 x y = case fun2 of + F2A fun -> applyFunc (applyFunc fun x) y + F2B fun -> applyFunc (applyFunc fun y) x + +-- | Function which may be lazy in its arguments +data Func3 a b c d + = F3A (Func a (Func2 b c d)) + | F3B (Func b (Func2 a c d)) + | F3C (Func c (Func2 a b d)) + deriving Show + +instance + ( CoArbitrary a, Function a + , CoArbitrary b, Function b + , CoArbitrary c, Function c + , Arbitrary d + ) + => Arbitrary (Func3 a b c d) where + arbitrary = oneof [F3A <$> arbitrary, F3B <$> arbitrary, F3C <$> arbitrary] + + shrink fun3 = case fun3 of + F3A fun -> F3A <$> shrink fun + F3B fun -> F3B <$> shrink fun + F3C fun -> F3C <$> shrink fun + +applyFunc3 :: Func3 a b c d -> a -> b -> c -> d +applyFunc3 fun3 x y z = case fun3 of + F3A fun -> applyFunc2 (applyFunc fun x) y z + F3B fun -> applyFunc2 (applyFunc fun y) x z + F3C fun -> applyFunc2 (applyFunc fun z) x y diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index fa9a0f221..fbdc54cf7 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -4,20 +4,37 @@ module Main (main) where +import Data.Bifunctor (bimap) +import Data.Coerce (coerce) +import Data.Either (partitionEithers) +import Data.Foldable as F +import Data.Function (on) +import Data.Functor.Identity (Identity(..)) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import Data.Ord (Down(..), comparing) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Semigroup (Arg(..)) import Test.ChasingBottoms.IsBottom import Test.Tasty (TestTree, TestName, defaultMain, testGroup) import Test.Tasty.HUnit -import Test.Tasty.QuickCheck (testProperty, Arbitrary(arbitrary), Fun) -#if __GLASGOW_HASKELL__ >= 806 -import Test.Tasty.QuickCheck (Property) -#endif -import Test.QuickCheck.Function (apply) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Poly (A, B, C, OrdA, OrdB) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import qualified Data.Map.Merge.Strict as MMerge import qualified Data.Map as L +import Data.Map.Merge.Lazy (WhenMatched, WhenMissing) +import qualified Data.Map.Merge.Lazy as LMerge +import Data.Set (Set) +import qualified Data.Set as Set import Utils.IsUnit +import Utils.Strictness + (Bot(..), Func(..), Func2(..), Func3(..), applyFunc, applyFunc2, applyFunc3) #if __GLASGOW_HASKELL__ >= 806 import Utils.NoThunks #endif @@ -26,14 +43,876 @@ instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (Map k v) where arbitrary = M.fromList `fmap` arbitrary +instance (Arbitrary a, Ord a) => Arbitrary (Set a) where + arbitrary = Set.fromList <$> arbitrary + apply2 :: Fun (a, b) c -> a -> b -> c apply2 f a b = apply f (a, b) apply3 :: Fun (a, b, c) d -> a -> b -> c -> d apply3 f a b c = apply f (a, b, c) ------------------------------------------------------------------------- --- * Properties +{-------------------------------------------------------------------- + Construction property tests +--------------------------------------------------------------------} + +-- The primary purpose of these property tests is to ensure that +-- +-- 1. Functions in Data.Map.Strict always force the value (as in key-value) to +-- WHNF when inserting it into a Map. +-- 2. Functions is Data.Map.Lazy do not force the value when inserting it into +-- a Map. +-- +-- These are ensured by testing against bottom. If the function is strict in the +-- value, the attempt to create a Map with a bottom value will result in a Map +-- that is bottom. Otherwise, the Map will not be bottom. +-- +-- Every function defined in Data.Map.Strict.Internal should have a property +-- test defined here. The corresponding function from Data.Map.Lazy should +-- also be tested to ensure that it is as lazy as expected. +-- +-- Functions with implementations shared between Data.Map.Lazy and +-- Data.Map.Strict never insert values and only remove them or shuffle them +-- around. These functions do not need to be tested here. +-- +-- For strict Map functions, the strictness is tested in one of two ways: +-- +-- * Directly. For example, the result of `alter` is bottom if and only if the +-- key exists in the map and the alter function applied to the key's value +-- returns `Just bottom`. +-- * Indirectly against another equivalent function, which is also tested. For +-- instance, `adjust f` is expected to be equivalent to `alter (fmap f)`, and +-- is tested to be so in strictness. + +prop_strictSingleton :: OrdA -> Bot A -> Property +prop_strictSingleton k (Bot x) = isBottom (M.singleton k x) === isBottom x + +prop_lazySingleton :: OrdA -> Bot A -> Property +prop_lazySingleton k (Bot x) = isNotBottomP (L.singleton k x) + +prop_strictFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_strictFromSet fun set = + isBottom (M.fromSet f set) === any (isBottom . f) (Set.toList set) + where + f = coerce (applyFunc fun) :: OrdA -> A + +prop_lazyFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_lazyFromSet fun set = isNotBottomP (L.fromSet f set) + where + f = coerce (applyFunc fun) :: OrdA -> A + +prop_strictFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_strictFromArgSet fun set = + isBottom (M.fromArgSet set') === + any (\(Arg _ x) -> isBottom x) (Set.toList set') + where + f = coerce (applyFunc fun) :: OrdA -> A + -- Workaround for missing Arbitrary (Arg a b) + set' = Set.map (\x -> Arg x (f x)) set + +prop_lazyFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_lazyFromArgSet fun set = isNotBottomP (L.fromArgSet set') + where + f = coerce (applyFunc fun) :: OrdA -> A + -- Workaround for missing Arbitrary (Arg a b) + set' = Set.map (\x -> Arg x (f x)) set + +prop_strictFromList :: [(OrdA, Bot A)] -> Property +prop_strictFromList kvs = + isBottom (M.fromList kvs') === any (isBottom . snd) kvs' + where + kvs' = coerce kvs :: [(OrdA, A)] + +prop_lazyFromList :: [(OrdA, Bot A)] -> Property +prop_lazyFromList kvs = isNotBottomP $ isBottom (L.fromList kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + +prop_strictFromListWith :: Func2 A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_strictFromListWith fun kvs = + isBottom (M.fromListWith f kvs') === + isBottom (F.foldl' (\acc (k,x) -> M.insertWith f k x acc) M.empty kvs') + where + f = coerce (applyFunc2 fun) + kvs' = coerce kvs :: [(OrdA, A)] + +prop_lazyFromListWith :: Func2 A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_lazyFromListWith fun kvs = isNotBottomP (L.fromListWith f kvs') + where + f = coerce (applyFunc2 fun) + kvs' = coerce kvs :: [(OrdA, A)] + +prop_strictFromListWithKey + :: Func3 OrdA A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_strictFromListWithKey fun kvs = + isBottom (M.fromListWithKey f kvs') === + isBottom (F.foldl' (\acc (k,x) -> M.insertWithKey f k x acc) M.empty kvs') + where + f = coerce (applyFunc3 fun) + kvs' = coerce kvs :: [(OrdA, A)] + +prop_lazyFromListWithKey + :: Func3 OrdA A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_lazyFromListWithKey fun kvs = isNotBottomP (L.fromListWithKey f kvs') + where + f = coerce (applyFunc3 fun) + kvs' = coerce kvs :: [(OrdA, A)] + +prop_strictFromAscList :: [(OrdA, Bot A)] -> Property +prop_strictFromAscList kvs = + isBottom (M.fromAscList kvs') === isBottom (M.fromList kvs') + where + kvs' = List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromAscList :: [(OrdA, Bot A)] -> Property +prop_lazyFromAscList kvs = isNotBottomP (L.fromAscList kvs') + where + kvs' = List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromAscListWith :: Func2 A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_strictFromAscListWith fun kvs = + isBottom (M.fromAscListWith f kvs') === isBottom (M.fromListWith f kvs') + where + f = coerce (applyFunc2 fun) + kvs' = List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromAscListWith :: Func2 A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_lazyFromAscListWith fun kvs = isNotBottomP (L.fromAscListWith f kvs') + where + f = coerce (applyFunc2 fun) + kvs' = List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromAscListWithKey + :: Func3 OrdA A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_strictFromAscListWithKey fun kvs = + isBottom (M.fromAscListWithKey f kvs') === + isBottom (M.fromListWithKey f kvs') + where + f = coerce (applyFunc3 fun) + kvs' = List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromAscListWithKey + :: Func3 OrdA A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_lazyFromAscListWithKey fun kvs = isNotBottomP (L.fromAscListWithKey f kvs') + where + f = coerce (applyFunc3 fun) + kvs' = List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromDistinctAscList :: [(OrdA, Bot A)] -> Property +prop_strictFromDistinctAscList kvs = + isBottom (M.fromDistinctAscList kvs') === isBottom (M.fromList kvs') + where + kvs' = uniqOn fst $ List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromDistinctAscList :: [(OrdA, Bot A)] -> Property +prop_lazyFromDistinctAscList kvs = isNotBottomP (L.fromDistinctAscList kvs') + where + kvs' = uniqOn fst $ List.sortBy (comparing fst) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromDescList :: [(OrdA, Bot A)] -> Property +prop_strictFromDescList kvs = + isBottom (M.fromDescList kvs') === isBottom (M.fromList kvs') + where + kvs' = List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromDescList :: [(OrdA, Bot A)] -> Property +prop_lazyFromDescList kvs = isNotBottomP (L.fromDescList kvs') + where + kvs' = List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromDescListWith :: Func2 A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_strictFromDescListWith fun kvs = + isBottom (M.fromDescListWith f kvs') === isBottom (M.fromListWith f kvs') + where + f = coerce (applyFunc2 fun) + kvs' = List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromDescListWith :: Func2 A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_lazyFromDescListWith fun kvs = isNotBottomP (L.fromDescListWith f kvs') + where + f = coerce (applyFunc2 fun) + kvs' = List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromDescListWithKey + :: Func3 OrdA A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_strictFromDescListWithKey fun kvs = + isBottom (M.fromDescListWithKey f kvs') === + isBottom (M.fromListWithKey f kvs') + where + f = coerce (applyFunc3 fun) + kvs' = List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromDescListWithKey + :: Func3 OrdA A A (Bot A) -> [(OrdA, Bot A)] -> Property +prop_lazyFromDescListWithKey fun kvs = + isNotBottomP (L.fromDescListWithKey f kvs') + where + f = coerce (applyFunc3 fun) + kvs' = List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_strictFromDistinctDescList :: [(OrdA, Bot A)] -> Property +prop_strictFromDistinctDescList kvs = + isBottom (M.fromDistinctDescList kvs') === isBottom (M.fromList kvs') + where + kvs' = + uniqOn fst $ + List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_lazyFromDistinctDescList :: [(OrdA, Bot A)] -> Property +prop_lazyFromDistinctDescList kvs = isNotBottomP (L.fromDistinctDescList kvs') + where + kvs' = + uniqOn fst $ + List.sortBy (comparing (Down . fst)) (coerce kvs) :: [(OrdA, A)] + +prop_strictInsert :: OrdA -> Bot A -> Map OrdA A -> Property +prop_strictInsert k (Bot x) m = isBottom (M.insert k x m) === isBottom x + +prop_lazyInsert :: OrdA -> Bot A -> Map OrdA A -> Property +prop_lazyInsert k (Bot x) m = isNotBottomP (L.insert k x m) + +prop_strictInsertWith + :: Func2 A A (Bot A) + -> OrdA + -> Bot A + -> Map OrdA A + -> Property +prop_strictInsertWith fun k (Bot x) m = + isBottom (M.insertWith f k x m) === + isBottom (maybe x (f x) (M.lookup k m)) + where + f = coerce (applyFunc2 fun) + +prop_lazyInsertWith + :: Func2 A A (Bot A) + -> OrdA + -> Bot A + -> Map OrdA A + -> Property +prop_lazyInsertWith fun k (Bot x) m = isNotBottomP (L.insertWith f k x m) + where + f = coerce (applyFunc2 fun) + +prop_strictInsertWithKey + :: Func3 OrdA A A (Bot A) + -> OrdA + -> Bot A + -> Map OrdA A + -> Property +prop_strictInsertWithKey fun k (Bot x) m = + isBottom (M.insertWithKey f k x m) === + isBottom (maybe x (f k x) (M.lookup k m)) + where + f = coerce (applyFunc3 fun) + +prop_lazyInsertWithKey + :: Func3 OrdA A A (Bot A) + -> OrdA + -> Bot A + -> Map OrdA A + -> Property +prop_lazyInsertWithKey fun k (Bot x) m = isNotBottomP (L.insertWithKey f k x m) + where + f = coerce (applyFunc3 fun) + +prop_strictInsertLookupWithKey + :: Func3 OrdA A A (Bot A) + -> OrdA + -> Bot A + -> Map OrdA A + -> Property +prop_strictInsertLookupWithKey fun k (Bot x) m = + isBottom (M.insertLookupWithKey f k x m) === + isBottom (maybe x (f k x) (M.lookup k m)) + where + f = coerce (applyFunc3 fun) + +prop_lazyInsertLookupWithKey + :: Func3 OrdA A A (Bot A) + -> OrdA + -> Bot A + -> Map OrdA A + -> Property +prop_lazyInsertLookupWithKey fun k (Bot x) m = + isNotBottomP (L.insertLookupWithKey f k x m) + where + f = coerce (applyFunc3 fun) + +prop_strictAdjust :: Func A (Bot A) -> OrdA -> Map OrdA A -> Property +prop_strictAdjust fun k m = + isBottom (M.adjust f k m) === isBottom (M.alter (fmap f) k m) + where + f = coerce (applyFunc fun) + +prop_lazyAdjust :: Func A (Bot A) -> OrdA -> Map OrdA A -> Property +prop_lazyAdjust fun k m = isNotBottomP (L.adjust f k m) + where + f = coerce (applyFunc fun) + +prop_strictAdjustWithKey + :: Func2 OrdA A (Bot A) -> OrdA -> Map OrdA A -> Property +prop_strictAdjustWithKey fun k m = + isBottom (M.adjustWithKey f k m) === isBottom (M.alter (fmap (f k)) k m) + where + f = coerce (applyFunc2 fun) + +prop_lazyAdjustWithKey + :: Func2 OrdA A (Bot A) -> OrdA -> Map OrdA A -> Property +prop_lazyAdjustWithKey fun k m = isNotBottomP (L.adjustWithKey f k m) + where + f = coerce (applyFunc2 fun) + +prop_strictUpdate + :: Func A (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_strictUpdate fun k m = + isBottom (M.update f k m) === isBottom (M.alter (>>= f) k m) + where + f = coerce (applyFunc fun) + +prop_lazyUpdate + :: Func A (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_lazyUpdate fun k m = isNotBottomP (L.update f k m) + where + f = coerce (applyFunc fun) + +prop_strictUpdateWithKey + :: Func2 OrdA A (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_strictUpdateWithKey fun k m = + isBottom (M.updateWithKey f k m) === isBottom (M.alter (>>= f k) k m) + where + f = coerce (applyFunc2 fun) + +prop_lazyUpdateWithKey + :: Func2 OrdA A (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_lazyUpdateWithKey fun k m = isNotBottomP (L.updateWithKey f k m) + where + f = coerce (applyFunc2 fun) + +prop_strictUpdateLookupWithKey + :: Func2 OrdA A (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_strictUpdateLookupWithKey fun k m = + isBottom (M.updateLookupWithKey f k m) === isBottom (M.updateWithKey f k m) + where + f = coerce (applyFunc2 fun) + +prop_lazyUpdateLookupWithKey + :: Func2 OrdA A (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_lazyUpdateLookupWithKey fun k m = + isNotBottomP (L.updateLookupWithKey f k m) + where + f = coerce (applyFunc2 fun) + +prop_strictAlter + :: Func (Maybe A) (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_strictAlter fun k m = + isBottom (M.alter f k m) === + maybe False isBottom (f (M.lookup k m)) + where + f = coerce (applyFunc fun) + +prop_lazyAlter + :: Func (Maybe A) (Maybe (Bot A)) -> OrdA -> Map OrdA A -> Property +prop_lazyAlter fun k m = isNotBottomP (L.alter f k m) + where + f = coerce (applyFunc fun) + +prop_strictAlterF + :: Func (Maybe A) (Identity (Maybe (Bot A))) -> OrdA -> Map OrdA A -> Property +prop_strictAlterF fun k m = + isBottom (runIdentity (M.alterF f k m)) === + maybe False isBottom (runIdentity (f (M.lookup k m))) + where + f = coerce (applyFunc fun) + +prop_lazyAlterF + :: Func (Maybe A) (Identity (Maybe (Bot A))) -> OrdA -> Map OrdA A -> Property +prop_lazyAlterF fun k m = isNotBottomP (runIdentity (L.alterF f k m)) + where + f = coerce (applyFunc fun) + +prop_strictUnionWith + :: Func2 A A (Bot A) -> Map OrdA A -> Map OrdA A -> Property +prop_strictUnionWith fun m1 m2 = + isBottom (M.unionWith f m1 m2) === + isBottom (M.unionWithKey (const f) m1 m2) + where + f = coerce (applyFunc2 fun) + +prop_lazyUnionWith + :: Func2 A A (Bot A) -> Map OrdA A -> Map OrdA A -> Property +prop_lazyUnionWith fun m1 m2 = isNotBottomP (L.unionWith f m1 m2) + where + f = coerce (applyFunc2 fun) + +prop_strictUnionWithKey + :: Func3 OrdA A A (Bot A) -> Map OrdA A -> Map OrdA A -> Property +prop_strictUnionWithKey fun m1 m2 = + isBottom (M.unionWithKey f m1 m2) === + isBottom (M.foldlWithKey' (\acc k x -> M.insertWithKey f k x acc) m2 m1) + where + f = coerce (applyFunc3 fun) + +prop_lazyUnionWithKey + :: Func3 OrdA A A (Bot A) -> Map OrdA A -> Map OrdA A -> Property +prop_lazyUnionWithKey fun m1 m2 = isNotBottomP (L.unionWithKey f m1 m2) + where + f = coerce (applyFunc3 fun) + +prop_strictDifferenceWith + :: Func2 A B (Maybe (Bot A)) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictDifferenceWith fun m1 m2 = + isBottom (M.differenceWith f m1 m2) === + isBottom (M.differenceWithKey (const f) m1 m2) + where + f = coerce (applyFunc2 fun) + +prop_lazyDifferenceWith + :: Func2 A B (Maybe (Bot A)) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyDifferenceWith fun m1 m2 = isNotBottomP (L.differenceWith f m1 m2) + where + f = coerce (applyFunc2 fun) + +prop_strictDifferenceWithKey + :: Func3 OrdA A B (Maybe (Bot A)) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictDifferenceWithKey fun m1 m2 = + isBottom (M.differenceWithKey f m1 m2) === + isBottom + (M.foldlWithKey' + (\acc k x -> M.updateWithKey (\k' y -> f k' y x) k acc) + m1 + m2) + where + f = coerce (applyFunc3 fun) + +prop_lazyDifferenceWithKey + :: Func3 OrdA A B (Maybe (Bot A)) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyDifferenceWithKey fun m1 m2 = + isNotBottomP (L.differenceWithKey f m1 m2) + where + f = coerce (applyFunc3 fun) + +prop_strictIntersectionWith + :: Func2 A B (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictIntersectionWith fun m1 m2 = + isBottom (M.intersectionWith f m1 m2) === + isBottom (M.intersectionWithKey (const f) m1 m2) + where + f = coerce (applyFunc2 fun) :: A -> B -> C + +prop_lazyIntersectionWith + :: Func2 A B (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyIntersectionWith fun m1 m2 = isNotBottomP (L.intersectionWith f m1 m2) + where + f = coerce (applyFunc2 fun) :: A -> B -> C + +prop_strictIntersectionWithKey + :: Func3 OrdA A B (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictIntersectionWithKey fun m1 m2 = + isBottom (M.intersectionWithKey f m1 m2) === + isBottom + (M.foldlWithKey' + (\acc k x -> case M.lookup k m2 of + Nothing -> acc + Just y -> M.insert k (f k x y) acc) + M.empty + m1) + where + f = coerce (applyFunc3 fun) :: OrdA -> A -> B -> C + +prop_lazyIntersectionWithKey + :: Func3 OrdA A B (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyIntersectionWithKey fun m1 m2 = + isNotBottomP (L.intersectionWithKey f m1 m2) + where + f = coerce (applyFunc3 fun) :: OrdA -> A -> B -> C + +prop_strictMergeWithKey + :: Func3 OrdA A B (Maybe (Bot C)) + -> Fun A (Maybe C) + -> Fun B (Maybe C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictMergeWithKey fun12 fun1 fun2 m1 m2 = + isBottom (M.mergeWithKey f12 (M.mapMaybe f1) (M.mapMaybe f2) m1 m2) === + any isBottom + (mapMaybe (\(k, (x, y)) -> f12 k x y) $ + M.toList $ + M.intersectionWith (,) m1 m2) + where + f12 = coerce (applyFunc3 fun12) :: OrdA -> A -> B -> Maybe C + f1 = applyFun fun1 + f2 = applyFun fun2 + +prop_lazyMergeWithKey + :: Func3 OrdA A B (Maybe (Bot C)) + -> Fun A (Maybe C) + -> Fun B (Maybe C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyMergeWithKey fun12 fun1 fun2 m1 m2 = + isNotBottomP (L.mergeWithKey f12 (L.mapMaybe f1) (L.mapMaybe f2) m1 m2) + where + f12 = coerce (applyFunc3 fun12) :: OrdA -> A -> B -> Maybe C + f1 = applyFun fun1 + f2 = applyFun fun2 + +prop_strictMap :: Func A (Bot B) -> Map OrdA A -> Property +prop_strictMap fun m = + isBottom (M.map f m) === isBottom (M.mapWithKey (const f) m) + where + f = coerce (applyFunc fun) :: A -> B + +prop_lazyMap :: Func A (Bot B) -> Map OrdA A -> Property +prop_lazyMap fun m = isNotBottomP (L.map f m) + where + f = coerce (applyFunc fun) :: A -> B + +prop_strictMapWithKey :: Func2 OrdA A (Bot B) -> Map OrdA A -> Property +prop_strictMapWithKey fun m = + isBottom (M.mapWithKey f m) === + any (isBottom . uncurry f) (M.toList m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> B + +prop_lazyMapWithKey :: Func2 OrdA A (Bot B) -> Map OrdA A -> Property +prop_lazyMapWithKey fun m = isNotBottomP (L.mapWithKey f m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> B + +prop_strictTraverseWithKey + :: Func2 OrdA A (Identity (Bot B)) -> Map OrdA A -> Property +prop_strictTraverseWithKey fun m = + isBottom (runIdentity (M.traverseWithKey f m)) === + any (isBottom . runIdentity . uncurry f) (M.toList m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Identity B + +prop_lazyTraverseWithKey + :: Func2 OrdA A (Identity (Bot B)) -> Map OrdA A -> Property +prop_lazyTraverseWithKey fun m = + isNotBottomP (runIdentity (L.traverseWithKey f m)) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Identity B + +prop_strictTraverseMaybeWithKey + :: Func2 OrdA A (Identity (Maybe (Bot B))) -> Map OrdA A -> Property +prop_strictTraverseMaybeWithKey fun m = + isBottom (runIdentity (M.traverseMaybeWithKey f m)) === + any (maybe False isBottom . runIdentity . uncurry f) (M.toList m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Identity (Maybe B) + +prop_lazyTraverseMaybeWithKey + :: Func2 OrdA A (Identity (Maybe (Bot B))) -> Map OrdA A -> Property +prop_lazyTraverseMaybeWithKey fun m = + isNotBottomP (runIdentity (L.traverseMaybeWithKey f m)) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Identity (Maybe B) + +prop_strictMapAccum + :: Func2 A B (A, Bot C) -> A -> Map OrdA B -> Property +prop_strictMapAccum fun z m = + isBottom (snd (M.mapAccum f z m)) === + isBottom (M.fromList $ snd $ + List.mapAccumL (\z' (k, x) -> fmap ((,) k) (f z' x)) z (M.toList m)) + where + f = coerce (applyFunc2 fun) :: A -> B -> (A, C) + +prop_lazyMapAccum + :: Func2 A B (A, Bot C) -> A -> Map OrdA B -> Property +prop_lazyMapAccum fun z m = isNotBottomP (snd (L.mapAccum f z m)) + where + f = coerce (applyFunc2 fun) :: A -> B -> (A, C) + +prop_strictMapAccumWithKey + :: Func3 A OrdA B (A, Bot C) -> A -> Map OrdA B -> Property +prop_strictMapAccumWithKey fun z m = + isBottom (snd (M.mapAccumWithKey f z m)) === + isBottom (M.fromList $ snd $ + List.mapAccumL (\z' (k, x) -> fmap ((,) k) (f z' k x)) z (M.toList m)) + where + f = coerce (applyFunc3 fun) :: A -> OrdA -> B -> (A, C) + +prop_lazyMapAccumWithKey + :: Func3 A OrdA B (A, Bot C) -> A -> Map OrdA B -> Property +prop_lazyMapAccumWithKey fun z m = isNotBottomP (snd (L.mapAccumWithKey f z m)) + where + f = coerce (applyFunc3 fun) :: A -> OrdA -> B -> (A, C) + +prop_strictMapAccumRWithKey + :: Func3 A OrdA B (A, Bot C) -> A -> Map OrdA B -> Property +prop_strictMapAccumRWithKey fun z m = + isBottom (snd (M.mapAccumRWithKey f z m)) === + isBottom (M.fromList $ snd $ + List.mapAccumR (\z' (k, x) -> fmap ((,) k) (f z' k x)) z (M.toList m)) + where + f = coerce (applyFunc3 fun) :: A -> OrdA -> B -> (A, C) + +prop_lazyMapAccumRWithKey + :: Func3 A OrdA B (A, Bot C) -> A -> Map OrdA B -> Property +prop_lazyMapAccumRWithKey fun z m = + isNotBottomP (snd (L.mapAccumRWithKey f z m)) + where + f = coerce (applyFunc3 fun) :: A -> OrdA -> B -> (A, C) + +prop_strictMapKeysWith + :: Func2 A A (Bot A) -> Func OrdA OrdB -> Map OrdA A -> Property +prop_strictMapKeysWith fun kfun m = + isBottom (M.mapKeysWith f kf m) === + isBottom (M.fromListWith f $ map (\(k, x) -> (kf k, x)) $ M.toList m) + where + f = coerce (applyFunc2 fun) :: A -> A -> A + kf = applyFunc kfun + +prop_lazyMapKeysWith + :: Func2 A A (Bot A) -> Func OrdA OrdB -> Map OrdA A -> Property +prop_lazyMapKeysWith fun kfun m = isNotBottomP (L.mapKeysWith f kf m) + where + f = coerce (applyFunc2 fun) :: A -> A -> A + kf = applyFunc kfun + +prop_strictMapMaybe + :: Func A (Maybe (Bot B)) -> Map OrdA A -> Property +prop_strictMapMaybe fun m = + isBottom (M.mapMaybe f m) === isBottom (M.mapMaybeWithKey (const f) m) + where + f = coerce (applyFunc fun) :: A -> Maybe B + +prop_lazyMapMaybe + :: Func A (Maybe (Bot B)) -> Map OrdA A -> Property +prop_lazyMapMaybe fun m = isNotBottomP (L.mapMaybe f m) + where + f = coerce (applyFunc fun) :: A -> Maybe B + +prop_strictMapMaybeWithKey + :: Func2 OrdA A (Maybe (Bot B)) -> Map OrdA A -> Property +prop_strictMapMaybeWithKey fun m = + isBottom (M.mapMaybeWithKey f m) === + isBottom (M.fromList $ mapMaybe (\(k, x) -> ((,) k) <$> f k x) $ M.toList m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Maybe B + +prop_lazyMapMaybeWithKey + :: Func2 OrdA A (Maybe (Bot B)) -> Map OrdA A -> Property +prop_lazyMapMaybeWithKey fun m = isNotBottomP (L.mapMaybeWithKey f m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Maybe B + +prop_strictMapEither + :: Func A (Either (Bot B) (Bot C)) -> Map OrdA A -> Property +prop_strictMapEither fun m = + bimap isBottom isBottom (M.mapEither f m) === + bimap isBottom isBottom (M.mapEitherWithKey (const f) m) + where + f = coerce (applyFunc fun) :: A -> Either B C + +prop_lazyMapEither + :: Func A (Either (Bot B) (Bot C)) -> Map OrdA A -> Property +prop_lazyMapEither fun m = + property $ (\(m1, m2) -> not (isBottom m1 || isBottom m2)) $ L.mapEither f m + where + f = coerce (applyFunc fun) :: A -> Either B C + +prop_strictMapEitherWithKey + :: Func2 OrdA A (Either (Bot B) (Bot C)) -> Map OrdA A -> Property +prop_strictMapEitherWithKey fun m = + bimap isBottom isBottom (M.mapEitherWithKey f m) === + bimap isBottom isBottom + ((\(!a, !b) -> (a, b)) $ -- Note: strict in both + bimap M.fromList M.fromList $ + partitionEithers $ + map (\(k, x) -> bimap ((,) k) ((,) k) (f k x)) $ + M.toList m) + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Either B C + +prop_lazyMapEitherWithKey + :: Func2 OrdA A (Either (Bot B) (Bot C)) -> Map OrdA A -> Property +prop_lazyMapEitherWithKey fun m = + property $ + (\(m1, m2) -> not (isBottom m1 || isBottom m2)) $ + L.mapEitherWithKey f m + where + f = coerce (applyFunc2 fun) :: OrdA -> A -> Either B C + +prop_strictUpdateAt :: Func2 OrdA A (Bot A) -> Map OrdA A -> Property +prop_strictUpdateAt fun m = not (M.null m) ==> + forAll (choose (0, M.size m - 1)) $ \k -> + isBottom (M.updateAt (\k' x -> Just (f k' x)) k m) === + isBottom (uncurry f (M.elemAt k m)) + where + f = coerce (applyFunc2 fun) + +prop_lazyUpdateAt :: Func2 OrdA A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateAt fun m = not (L.null m) ==> + forAll (choose (0, L.size m - 1)) $ \k -> + isNotBottomP (L.updateAt (\k' x -> Just (f k' x)) k m) + where + f = coerce (applyFunc2 fun) + +prop_strictUpdateMin :: Func A (Bot A) -> Map OrdA A -> Property +prop_strictUpdateMin fun m = + isBottom (M.updateMin (Just . f) m) === + isBottom (M.updateMinWithKey (\_ x -> Just (f x)) m) + where + f = coerce (applyFunc fun) + +prop_lazyUpdateMin :: Func A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateMin fun m = isNotBottomP (L.updateMin (Just . f) m) + where + f = coerce (applyFunc fun) + +prop_strictUpdateMinWithKey + :: Func2 OrdA A (Bot A) -> Map OrdA A -> Property +prop_strictUpdateMinWithKey fun m = not (M.null m) ==> + isBottom (M.updateMinWithKey (\k x -> Just (f k x)) m) === + isBottom (uncurry f (M.findMin m)) + where + f = coerce (applyFunc2 fun) + +prop_lazyUpdateMinWithKey + :: Func2 OrdA A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateMinWithKey fun m = not (L.null m) ==> + isNotBottomP (L.updateMinWithKey (\k x -> Just (f k x)) m) + where + f = coerce (applyFunc2 fun) + +prop_strictUpdateMax :: Func A (Bot A) -> Map OrdA A -> Property +prop_strictUpdateMax fun m = + isBottom (M.updateMax (Just . f) m) === + isBottom (M.updateMaxWithKey (\_ x -> Just (f x)) m) + where + f = coerce (applyFunc fun) + +prop_lazyUpdateMax :: Func A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateMax fun m = isNotBottomP (L.updateMax (Just . f) m) + where + f = coerce (applyFunc fun) + +prop_strictUpdateMaxWithKey + :: Func2 OrdA A (Bot A) -> Map OrdA A -> Property +prop_strictUpdateMaxWithKey fun m = not (M.null m) ==> + isBottom (M.updateMaxWithKey (\k x -> Just (f k x)) m) === + isBottom (uncurry f (M.findMax m)) + where + f = coerce (applyFunc2 fun) + +prop_lazyUpdateMaxWithKey + :: Func2 OrdA A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateMaxWithKey fun m = not (M.null m) ==> + isNotBottomP (L.updateMaxWithKey (\k x -> Just (f k x)) m) + where + f = coerce (applyFunc2 fun) + +prop_strictMerge + :: WhenMissingFunc OrdA A (Bot C) C (Bot C) + -> WhenMissingFunc OrdA B (Bot C) C (Bot C) + -> WhenMatchedFunc OrdA A B (Bot C) C (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictMerge misfun1 misfun2 matfun m1 m2 = + isBottom (MMerge.merge mis1 mis2 mat m1 m2) === + any isBottom + (catMaybes $ concat + [ map (\(k, (x, y)) -> matf k x y) $ + M.toList $ + M.intersectionWith (,) m1 m2 + , map (uncurry misf1) $ M.toList $ M.difference m1 m2 + , map (uncurry misf2) $ M.toList $ M.difference m2 m1 + ]) + where + misfun1' = coerce misfun1 :: WhenMissingFunc OrdA A C C C + misfun2' = coerce misfun2 :: WhenMissingFunc OrdA B C C C + matfun' = coerce matfun :: WhenMatchedFunc OrdA A B C C C + mis1 = toStrictWhenMissing misfun1' + mis2 = toStrictWhenMissing misfun2' + mat = toStrictWhenMatched matfun' + misf1 = whenMissingApplyStrict misfun1' + misf2 = whenMissingApplyStrict misfun2' + matf = whenMatchedApplyStrict matfun' + +prop_lazyMerge + :: WhenMissingFunc OrdA A (Bot C) C (Bot C) + -> WhenMissingFunc OrdA B (Bot C) C (Bot C) + -> WhenMatchedFunc OrdA A B (Bot C) C (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyMerge misfun1 misfun2 matfun m1 m2 = + isNotBottomP (MMerge.merge mis1 mis2 mat m1 m2) + where + mis1 = toLazyWhenMissing (coerce misfun1 :: WhenMissingFunc OrdA A C C C) + mis2 = toLazyWhenMissing (coerce misfun2 :: WhenMissingFunc OrdA B C C C) + mat = toLazyWhenMatched (coerce matfun :: WhenMatchedFunc OrdA A B C C C) + +prop_strictMergeA + :: WhenMissingFunc OrdA A (Bot C) C (Bot C) + -> WhenMissingFunc OrdA B (Bot C) C (Bot C) + -> WhenMatchedFunc OrdA A B (Bot C) C (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_strictMergeA misfun1 misfun2 matfun m1 m2 = + isBottom (runIdentity (MMerge.mergeA mis1 mis2 mat m1 m2)) === + any isBottom + (catMaybes $ concat + [ map (\(k, (x, y)) -> matf k x y) $ + M.toList $ + M.intersectionWith (,) m1 m2 + , map (uncurry misf1) $ M.toList $ M.difference m1 m2 + , map (uncurry misf2) $ M.toList $ M.difference m2 m1 + ]) + where + misfun1' = coerce misfun1 :: WhenMissingFunc OrdA A C C C + misfun2' = coerce misfun2 :: WhenMissingFunc OrdA B C C C + matfun' = coerce matfun :: WhenMatchedFunc OrdA A B C C C + mis1 = toStrictWhenMissingA misfun1' + mis2 = toStrictWhenMissingA misfun2' + mat = toStrictWhenMatchedA matfun' + misf1 = whenMissingApplyStrict misfun1' + misf2 = whenMissingApplyStrict misfun2' + matf = whenMatchedApplyStrict matfun' + +prop_lazyMergeA + :: WhenMissingFunc OrdA A (Bot C) C (Bot C) + -> WhenMissingFunc OrdA B (Bot C) C (Bot C) + -> WhenMatchedFunc OrdA A B (Bot C) C (Bot C) + -> Map OrdA A + -> Map OrdA B + -> Property +prop_lazyMergeA misfun1 misfun2 matfun m1 m2 = + isNotBottomP (runIdentity (LMerge.mergeA mis1 mis2 mat m1 m2)) + where + mis1 = toLazyWhenMissingA (coerce misfun1 :: WhenMissingFunc OrdA A C C C) + mis2 = toLazyWhenMissingA (coerce misfun2 :: WhenMissingFunc OrdA B C C C) + mat = toLazyWhenMatchedA (coerce matfun :: WhenMatchedFunc OrdA A B C C C) ------------------------------------------------------------------------ -- ** Strict module @@ -145,7 +1024,7 @@ tExtraThunksM = testGroup "Map.Strict - extra thunks" $ ] where m0 = M.singleton 42 () - check :: TestName -> M.Map Int () -> TestTree + check :: TestName -> Map Int () -> TestTree check n m = testCase n $ case M.lookup 42 m of Just v -> assertBool msg (isUnit v) _ -> assertBool "key not found" False @@ -213,6 +1092,113 @@ tests = ] , tExtraThunksM , tExtraThunksL + + , testGroup "Map.Strict construction" + [ testProperty "singleton" prop_strictSingleton + , testProperty "fromSet" prop_strictFromSet + , testProperty "fromArgSet" prop_strictFromArgSet + , testProperty "fromList" prop_strictFromList + , testProperty "fromListWith" prop_strictFromListWith + , testProperty "fromListWithKey" prop_strictFromListWithKey + , testProperty "fromAscList" prop_strictFromAscList + , testProperty "fromAscListWith" prop_strictFromAscListWith + , testProperty "fromAscListWithKey" prop_strictFromAscListWithKey + , testProperty "fromDistinctAscList" prop_strictFromDistinctAscList + , testProperty "fromDescList" prop_strictFromDescList + , testProperty "fromDescListWith" prop_strictFromDescListWith + , testProperty "fromDescListWithKey" prop_strictFromDescListWithKey + , testProperty "fromDistinctDescList" prop_strictFromDistinctDescList + , testProperty "insert" prop_strictInsert + , testProperty "insertWith" prop_strictInsertWith + , testProperty "insertWithKey" prop_strictInsertWithKey + , testProperty "insertLookupWithKey" prop_strictInsertLookupWithKey + , testProperty "adjust" prop_strictAdjust + , testProperty "adjustWithKey" prop_strictAdjustWithKey + , testProperty "update" prop_strictUpdate + , testProperty "updateWithKey" prop_strictUpdateWithKey + , testProperty "updateLookupWithKey" prop_strictUpdateLookupWithKey + , testProperty "alter" prop_strictAlter + , testProperty "alterF" prop_strictAlterF + , testProperty "unionWith" prop_strictUnionWith + , testProperty "unionWithKey" prop_strictUnionWithKey + , testProperty "differenceWith" prop_strictDifferenceWith + , testProperty "differenceWithKey" prop_strictDifferenceWithKey + , testProperty "intersectionWith" prop_strictIntersectionWith + , testProperty "intersectionWithKey" prop_strictIntersectionWithKey + , testProperty "mergeWithKey" prop_strictMergeWithKey + , testProperty "map" prop_strictMap + , testProperty "mapWithKey" prop_strictMapWithKey + , testProperty "traverseWithKey" prop_strictTraverseWithKey + , testProperty "traverseMaybeWithKey" prop_strictTraverseMaybeWithKey + , testProperty "mapAccum" prop_strictMapAccum + , testProperty "mapAccumWithKey" prop_strictMapAccumWithKey + , testProperty "mapAccumRWithKey" prop_strictMapAccumRWithKey + , testProperty "mapKeysWith" prop_strictMapKeysWith + , testProperty "mapMaybe" prop_strictMapMaybe + , testProperty "mapMaybeWithKey" prop_strictMapMaybeWithKey + , testProperty "mapEither" prop_strictMapEither + , testProperty "mapEitherWithKey" prop_strictMapEitherWithKey + , testProperty "updateAt" prop_strictUpdateAt + , testProperty "updateMin" prop_strictUpdateMin + , testProperty "updateMinWithKey" prop_strictUpdateMinWithKey + , testProperty "updateMax" prop_strictUpdateMax + , testProperty "updateMaxWithKey" prop_strictUpdateMaxWithKey + , testProperty "merge" prop_strictMerge + , testProperty "mergeA" prop_strictMergeA + ] + , testGroup "Map.Lazy construction" + [ testProperty "singleton" prop_lazySingleton + , testProperty "fromSet" prop_lazyFromSet + , testProperty "fromArgSet" prop_lazyFromArgSet + , testProperty "fromList" prop_lazyFromList + , testProperty "fromListWith" prop_lazyFromListWith + , testProperty "fromListWithKey" prop_lazyFromListWithKey + , testProperty "fromAscList" prop_lazyFromAscList + , testProperty "fromAscListWith" prop_lazyFromAscListWith + , testProperty "fromAscListWithKey" prop_lazyFromAscListWithKey + , testProperty "fromDistinctAscList" prop_lazyFromDistinctAscList + , testProperty "fromDescList" prop_lazyFromDescList + , testProperty "fromDescListWith" prop_lazyFromDescListWith + , testProperty "fromDescListWithKey" prop_lazyFromDescListWithKey + , testProperty "fromDistinctDescList" prop_lazyFromDistinctDescList + , testProperty "insert" prop_lazyInsert + , testProperty "insertWith" prop_lazyInsertWith + , testProperty "insertWithKey" prop_lazyInsertWithKey + , testProperty "insertLookupWithKey" prop_lazyInsertLookupWithKey + , testProperty "adjust" prop_lazyAdjust + , testProperty "adjustWithKey" prop_lazyAdjustWithKey + , testProperty "update" prop_lazyUpdate + , testProperty "updateWithKey" prop_lazyUpdateWithKey + , testProperty "updateLookupWithKey" prop_lazyUpdateLookupWithKey + , testProperty "alter" prop_lazyAlter + , testProperty "alterF" prop_lazyAlterF + , testProperty "unionWith" prop_lazyUnionWith + , testProperty "unionWithKey" prop_lazyUnionWithKey + , testProperty "differenceWith" prop_lazyDifferenceWith + , testProperty "differenceWithKey" prop_lazyDifferenceWithKey + , testProperty "intersectionWith" prop_lazyIntersectionWith + , testProperty "intersectionWithKey" prop_lazyIntersectionWithKey + , testProperty "mergeWithKey" prop_lazyMergeWithKey + , testProperty "map" prop_lazyMap + , testProperty "mapWithKey" prop_lazyMapWithKey + , testProperty "traverseWithKey" prop_lazyTraverseWithKey + , testProperty "traverseMaybeWithKey" prop_lazyTraverseMaybeWithKey + , testProperty "mapAccum" prop_lazyMapAccum + , testProperty "mapAccumWithKey" prop_lazyMapAccumWithKey + , testProperty "mapAccumRWithKey" prop_lazyMapAccumRWithKey + , testProperty "mapKeysWith" prop_lazyMapKeysWith + , testProperty "mapMaybe" prop_lazyMapMaybe + , testProperty "mapMaybeWithKey" prop_lazyMapMaybeWithKey + , testProperty "mapEither" prop_lazyMapEither + , testProperty "mapEitherWithKey" prop_lazyMapEitherWithKey + , testProperty "updateAt" prop_lazyUpdateAt + , testProperty "updateMin" prop_lazyUpdateMin + , testProperty "updateMinWithKey" prop_lazyUpdateMinWithKey + , testProperty "updateMax" prop_lazyUpdateMax + , testProperty "updateMaxWithKey" prop_lazyUpdateMaxWithKey + , testProperty "merge" prop_lazyMerge + , testProperty "mergeA" prop_lazyMergeA + ] ] ------------------------------------------------------------------------ @@ -227,9 +1213,200 @@ main = defaultMain $ testGroup "map-strictness" tests keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool keyStrict f m = isBottom $ f bottom m +isNotBottomP :: a -> Property +isNotBottomP = property . not . isBottom + const2 :: a -> b -> c -> a const2 x _ _ = x const3 :: a -> b -> c -> d -> a const3 x _ _ _ = x +-- | Keep the first of adjacent equal elements. +uniqOn :: Eq b => (a -> b) -> [a] -> [a] +uniqOn f = map NE.head . NE.groupBy ((==) `on` f) + +{-------------------------------------------------------------------- + Merge stuff +--------------------------------------------------------------------} + +data WhenMatchedFunc k x y z a b + = MaybeMatchedFunc (Func3 k x y (Maybe b)) + | FmapMaybeMatchedFunc (Func a b) (Func3 k x y (Maybe z)) + | MatchedFunc (Func3 k x y b) + | FmapMatchedFunc (Func a b) (Func3 k x y z) + deriving Show + +instance + ( CoArbitrary k, Function k + , CoArbitrary x, Function x + , CoArbitrary y, Function y + , Arbitrary z + , CoArbitrary a, Function a, Arbitrary a + , Arbitrary b + ) + => Arbitrary (WhenMatchedFunc k x y z a b) where + arbitrary = oneof + [ MaybeMatchedFunc <$> arbitrary + , FmapMaybeMatchedFunc <$> arbitrary <*> arbitrary + , MatchedFunc <$> arbitrary + , FmapMatchedFunc <$> arbitrary <*> arbitrary + ] + shrink wmf = case wmf of + MaybeMatchedFunc fun -> MaybeMatchedFunc <$> shrink fun + FmapMaybeMatchedFunc fun2 fun1 -> + uncurry FmapMaybeMatchedFunc <$> shrink (fun2, fun1) + MatchedFunc fun -> MatchedFunc <$> shrink fun + FmapMatchedFunc fun2 fun1 -> + uncurry FmapMatchedFunc <$> shrink (fun2, fun1) + +toStrictWhenMatched + :: WhenMatchedFunc k x y z z z2 -> WhenMatched Identity k x y z2 +toStrictWhenMatched wmf = case wmf of + MaybeMatchedFunc fun -> MMerge.zipWithMaybeMatched (applyFunc3 fun) + FmapMaybeMatchedFunc fun2 fun1 -> + MMerge.mapWhenMatched (applyFunc fun2) $ + MMerge.zipWithMaybeMatched (applyFunc3 fun1) + MatchedFunc fun -> MMerge.zipWithMatched (applyFunc3 fun) + FmapMatchedFunc fun2 fun1 -> + MMerge.mapWhenMatched (applyFunc fun2) $ + MMerge.zipWithMatched (applyFunc3 fun1) + +toStrictWhenMatchedA + :: WhenMatchedFunc k x y z z z2 -> WhenMatched Identity k x y z2 +toStrictWhenMatchedA wmf = case wmf of + MaybeMatchedFunc fun -> MMerge.zipWithMaybeAMatched (coerce (applyFunc3 fun)) + FmapMaybeMatchedFunc fun2 fun1 -> + MMerge.mapWhenMatched (applyFunc fun2) $ + MMerge.zipWithMaybeAMatched (coerce (applyFunc3 fun1)) + MatchedFunc fun -> MMerge.zipWithAMatched (coerce (applyFunc3 fun)) + FmapMatchedFunc fun2 fun1 -> + MMerge.mapWhenMatched (applyFunc fun2) $ + MMerge.zipWithAMatched (coerce (applyFunc3 fun1)) + +toLazyWhenMatched + :: WhenMatchedFunc k x y z z z2 -> WhenMatched Identity k x y z2 +toLazyWhenMatched wmf = case wmf of + MaybeMatchedFunc fun -> LMerge.zipWithMaybeMatched (applyFunc3 fun) + FmapMaybeMatchedFunc fun2 fun1 -> + LMerge.mapWhenMatched (applyFunc fun2) $ + LMerge.zipWithMaybeMatched (applyFunc3 fun1) + MatchedFunc fun -> LMerge.zipWithMatched (applyFunc3 fun) + FmapMatchedFunc fun2 fun1 -> + LMerge.mapWhenMatched (applyFunc fun2) $ + LMerge.zipWithMatched (applyFunc3 fun1) + +toLazyWhenMatchedA + :: WhenMatchedFunc k x y z z z2 -> WhenMatched Identity k x y z2 +toLazyWhenMatchedA wmf = case wmf of + MaybeMatchedFunc fun -> LMerge.zipWithMaybeAMatched (coerce (applyFunc3 fun)) + FmapMaybeMatchedFunc fun2 fun1 -> + LMerge.mapWhenMatched (applyFunc fun2) $ + LMerge.zipWithMaybeAMatched (coerce (applyFunc3 fun1)) + MatchedFunc fun -> LMerge.zipWithAMatched (coerce (applyFunc3 fun)) + FmapMatchedFunc fun2 fun1 -> + LMerge.mapWhenMatched (applyFunc fun2) $ + LMerge.zipWithAMatched (coerce (applyFunc3 fun1)) + +whenMatchedApplyStrict + :: WhenMatchedFunc k x y z z z2 -> k -> x -> y -> Maybe z2 +whenMatchedApplyStrict wmf = case wmf of + MaybeMatchedFunc fun -> applyFunc3 fun + FmapMaybeMatchedFunc fun2 fun1 -> + \k x y -> + (applyFunc fun2 $!) <$> -- Strict in the intermediate result + applyFunc3 fun1 k x y + MatchedFunc fun -> \k x y -> Just (applyFunc3 fun k x y) + FmapMatchedFunc fun2 fun1 -> + \k x y -> Just $ + applyFunc fun2 $! -- Strict in the intermediate result + applyFunc3 fun1 k x y + +data WhenMissingFunc k x y a b + = MapMaybeMissingFunc (Func2 k x (Maybe b)) + | FmapMapMaybeMissingFunc (Func a b) (Func2 k x (Maybe a)) + | MapMissingFunc (Func2 k x b) + | FmapMapMissingFunc (Func a b) (Func2 k x a) + deriving Show + +instance + ( CoArbitrary k, Function k + , CoArbitrary x, Function x + , Arbitrary y + , CoArbitrary a, Function a, Arbitrary a + , Arbitrary b + ) + => Arbitrary (WhenMissingFunc k x y a b) where + arbitrary = oneof + [ MapMaybeMissingFunc <$> arbitrary + , FmapMapMaybeMissingFunc <$> arbitrary <*> arbitrary + , MapMissingFunc <$> arbitrary + , FmapMapMissingFunc <$> arbitrary <*> arbitrary + ] + shrink wmf = case wmf of + MapMaybeMissingFunc fun -> MapMaybeMissingFunc <$> shrink fun + FmapMapMaybeMissingFunc fun2 fun1 -> + uncurry FmapMapMaybeMissingFunc <$> shrink (fun2, fun1) + MapMissingFunc fun -> MapMissingFunc <$> shrink fun + FmapMapMissingFunc fun2 fun1 -> + uncurry FmapMapMissingFunc <$> shrink (fun2, fun1) + +toStrictWhenMissing :: WhenMissingFunc k x y y y2 -> WhenMissing Identity k x y2 +toStrictWhenMissing wmf = case wmf of + MapMaybeMissingFunc fun -> MMerge.mapMaybeMissing (applyFunc2 fun) + FmapMapMaybeMissingFunc fun2 fun1 -> + MMerge.mapWhenMissing (applyFunc fun2) $ + MMerge.mapMaybeMissing (applyFunc2 fun1) + MapMissingFunc fun -> MMerge.mapMissing (applyFunc2 fun) + FmapMapMissingFunc fun2 fun1 -> + MMerge.mapWhenMissing (applyFunc fun2) $ + MMerge.mapMissing (applyFunc2 fun1) + +toStrictWhenMissingA + :: WhenMissingFunc k x y y y2 -> WhenMissing Identity k x y2 +toStrictWhenMissingA wmf = case wmf of + MapMaybeMissingFunc fun -> + MMerge.traverseMaybeMissing (coerce (applyFunc2 fun)) + FmapMapMaybeMissingFunc fun2 fun1 -> + MMerge.mapWhenMissing (applyFunc fun2) $ + MMerge.traverseMaybeMissing (coerce (applyFunc2 fun1)) + MapMissingFunc fun -> MMerge.traverseMissing (coerce (applyFunc2 fun)) + FmapMapMissingFunc fun2 fun1 -> + MMerge.mapWhenMissing (applyFunc fun2) $ + MMerge.traverseMissing (coerce (applyFunc2 fun1)) + +toLazyWhenMissing :: WhenMissingFunc k x y y y2 -> WhenMissing Identity k x y2 +toLazyWhenMissing wmf = case wmf of + MapMaybeMissingFunc fun -> LMerge.mapMaybeMissing (applyFunc2 fun) + FmapMapMaybeMissingFunc fun2 fun1 -> + LMerge.mapWhenMissing (applyFunc fun2) $ + LMerge.mapMaybeMissing (applyFunc2 fun1) + MapMissingFunc fun -> LMerge.mapMissing (applyFunc2 fun) + FmapMapMissingFunc fun2 fun1 -> + LMerge.mapWhenMissing (applyFunc fun2) $ + LMerge.mapMissing (applyFunc2 fun1) + +toLazyWhenMissingA :: WhenMissingFunc k x y y y2 -> WhenMissing Identity k x y2 +toLazyWhenMissingA wmf = case wmf of + MapMaybeMissingFunc fun -> + LMerge.traverseMaybeMissing (coerce (applyFunc2 fun)) + FmapMapMaybeMissingFunc fun2 fun1 -> + LMerge.mapWhenMissing (applyFunc fun2) $ + LMerge.traverseMaybeMissing (coerce (applyFunc2 fun1)) + MapMissingFunc fun -> LMerge.traverseMissing (coerce (applyFunc2 fun)) + FmapMapMissingFunc fun2 fun1 -> + LMerge.mapWhenMissing (applyFunc fun2) $ + LMerge.traverseMissing (coerce (applyFunc2 fun1)) + +whenMissingApplyStrict :: WhenMissingFunc k x y y y2 -> k -> x -> Maybe y2 +whenMissingApplyStrict wmf = case wmf of + MapMaybeMissingFunc fun -> applyFunc2 fun + FmapMapMaybeMissingFunc fun2 fun1 -> + \k x -> + (applyFunc fun2 $!) <$> -- Strict in the intermediate result + applyFunc2 fun1 k x + MapMissingFunc fun -> \k x -> Just (applyFunc2 fun k x) + FmapMapMissingFunc fun2 fun1 -> + \k x -> Just $ + applyFunc fun2 $! -- Strict in the intermediate result + applyFunc2 fun1 k x