From b6fee414c3d87b5c2d48850774fd443f1035b525 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sat, 10 Aug 2024 17:25:44 +0530 Subject: [PATCH] Add strictness tests for Map construction This aims to reduce the chance of introducing strictness bugs. Since we use the same Map type for lazy and strict maps, it is not possible to ensure appropriate strictness at the type level. So we turn to property tests. Arbitrary Set and Map generation is moved from set-properties.hs and map-properties.hs to ArbitrarySetMap.hs to be shared with the new strictness tests. --- containers-tests/containers-tests.cabal | 12 +- .../tests/Utils/ArbitrarySetMap.hs | 117 ++ containers-tests/tests/Utils/Strictness.hs | 116 ++ containers-tests/tests/map-properties.hs | 42 +- containers-tests/tests/map-strictness.hs | 1274 +++++++++++++++-- containers-tests/tests/set-properties.hs | 46 +- 6 files changed, 1441 insertions(+), 166 deletions(-) create mode 100644 containers-tests/tests/Utils/ArbitrarySetMap.hs create mode 100644 containers-tests/tests/Utils/Strictness.hs diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index da7c76a0f..d4adb38cb 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -270,6 +270,9 @@ test-suite map-lazy-properties main-is: map-properties.hs type: exitcode-stdio-1.0 + other-modules: + Utils.ArbitrarySetMap + ghc-options: -O2 other-extensions: BangPatterns @@ -283,6 +286,9 @@ test-suite map-strict-properties type: exitcode-stdio-1.0 cpp-options: -DSTRICT + other-modules: + Utils.ArbitrarySetMap + ghc-options: -O2 other-extensions: BangPatterns @@ -306,6 +312,9 @@ test-suite set-properties main-is: set-properties.hs type: exitcode-stdio-1.0 + other-modules: + Utils.ArbitrarySetMap + ghc-options: -O2 other-extensions: BangPatterns @@ -404,7 +413,8 @@ test-suite map-strictness-properties CPP other-modules: - Utils.IsUnit + Utils.ArbitrarySetMap + Utils.Strictness if impl(ghc >= 8.6) build-depends: diff --git a/containers-tests/tests/Utils/ArbitrarySetMap.hs b/containers-tests/tests/Utils/ArbitrarySetMap.hs new file mode 100644 index 000000000..4a0409ec6 --- /dev/null +++ b/containers-tests/tests/Utils/ArbitrarySetMap.hs @@ -0,0 +1,117 @@ +module Utils.ArbitrarySetMap + ( + -- MonadGen + MonadGen(..) + + -- Set + , mkArbSet + , setFromList + + -- Map + , mkArbMap + , mapFromKeysList + ) where + +import Control.Monad (liftM, liftM3, liftM4) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Class +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import Test.QuickCheck + +import Data.Set (Set) +import qualified Data.Set.Internal as S +import Data.Map (Map) +import qualified Data.Map.Internal as M + +{-------------------------------------------------------------------- + MonadGen +--------------------------------------------------------------------} + +class Monad m => MonadGen m where + liftGen :: Gen a -> m a +instance MonadGen Gen where + liftGen = id +instance MonadGen m => MonadGen (StateT s m) where + liftGen = lift . liftGen + +{-------------------------------------------------------------------- + Set +--------------------------------------------------------------------} + +-- | Given an action that produces successively larger elements and +-- a size, produce a set of arbitrary shape with exactly that size. +mkArbSet :: MonadGen m => m a -> Int -> m (Set a) +mkArbSet step n + | n <= 0 = return S.Tip + | n == 1 = S.singleton `liftM` step + | n == 2 = do + dir <- liftGen arbitrary + p <- step + q <- step + if dir + then return (S.Bin 2 q (S.singleton p) S.Tip) + else return (S.Bin 2 p S.Tip (S.singleton q)) + | otherwise = do + -- This assumes a balance factor of delta = 3 + let upper = (3*(n - 1)) `quot` 4 + let lower = (n + 2) `quot` 4 + ln <- liftGen $ choose (lower, upper) + let rn = n - ln - 1 + liftM3 + (\lt x rt -> S.Bin n x lt rt) + (mkArbSet step ln) + step + (mkArbSet step rn) +{-# INLINABLE mkArbSet #-} + +-- | Given a strictly increasing list of elements, produce an arbitrarily +-- shaped set with exactly those elements. +setFromList :: [a] -> Gen (Set a) +setFromList xs = flip evalStateT xs $ mkArbSet step (length xs) + where + step = state $ fromMaybe (error "setFromList") . List.uncons + +{-------------------------------------------------------------------- + Map +--------------------------------------------------------------------} + +-- | Given an action that produces successively larger keys and +-- a size, produce a map of arbitrary shape with exactly that size. +mkArbMap :: (MonadGen m, Arbitrary v) => m k -> Int -> m (Map k v) +mkArbMap step n + | n <= 0 = return M.Tip + | n == 1 = do + k <- step + v <- liftGen arbitrary + return (M.singleton k v) + | n == 2 = do + dir <- liftGen arbitrary + p <- step + q <- step + vOuter <- liftGen arbitrary + vInner <- liftGen arbitrary + if dir + then return (M.Bin 2 q vOuter (M.singleton p vInner) M.Tip) + else return (M.Bin 2 p vOuter M.Tip (M.singleton q vInner)) + | otherwise = do + -- This assumes a balance factor of delta = 3 + let upper = (3*(n - 1)) `quot` 4 + let lower = (n + 2) `quot` 4 + ln <- liftGen $ choose (lower, upper) + let rn = n - ln - 1 + liftM4 + (\lt x v rt -> M.Bin n x v lt rt) + (mkArbMap step ln) + step + (liftGen arbitrary) + (mkArbMap step rn) +{-# INLINABLE mkArbMap #-} + +-- | Given a strictly increasing list of keys, produce an arbitrarily +-- shaped map with exactly those keys. +mapFromKeysList :: Arbitrary a => [k] -> Gen (Map k a) +mapFromKeysList xs = flip evalStateT xs $ mkArbMap step (length xs) + where + step = state $ fromMaybe (error "mapFromKeysList") . List.uncons +{-# INLINABLE mapFromKeysList #-} diff --git a/containers-tests/tests/Utils/Strictness.hs b/containers-tests/tests/Utils/Strictness.hs new file mode 100644 index 000000000..755745170 --- /dev/null +++ b/containers-tests/tests/Utils/Strictness.hs @@ -0,0 +1,116 @@ +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 +--------------------------------------------------------------------} + +-- | A function which may be lazy in its argument. +-- +-- Either ignores its argument, or uses a QuickCheck Fun (which is always a +-- strict function). +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 + +-- | A function which may be lazy in its arguments. + +-- Note: We have two separate cases here because we want to generate functions +-- of type `a -> b -> c` with all possible strictness configurations. +-- `Func a (Func b c)` is not enough for this, since it cannot generate +-- functions that are conditionally lazy in the first argument, for instance: +-- +-- leftLazyOr :: Bool -> Bool -> Bool +-- leftLazyOr a b = if b then True else a + +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 + +-- | A function which may be lazy in its arguments. + +-- See Note on Func2. +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-properties.hs b/containers-tests/tests/map-properties.hs index 1a6d4d58b..f265b432a 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -7,13 +7,13 @@ import Data.Map.Merge.Strict import Data.Map.Lazy as Data.Map import Data.Map.Merge.Lazy #endif -import Data.Map.Internal (Map (..), link2, link, bin) +import Data.Map.Internal (Map, link2, link) import Data.Map.Internal.Debug (showTree, showTreeWith, balanced) import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>)) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class -import Control.Monad (liftM4, (<=<)) +import Control.Monad ((<=<)) import Data.Functor.Identity (Identity(Identity, runIdentity)) import Data.Monoid import Data.Maybe hiding (mapMaybe) @@ -36,7 +36,8 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.QuickCheck.Function (apply) import Test.QuickCheck.Poly (A, B, OrdA) -import Control.Arrow (first) + +import Utils.ArbitrarySetMap (mkArbMap) default (Int) @@ -305,7 +306,7 @@ instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1)) let shift = (sz * (gapRange) + 1) `quot` 2 start = middle - shift - t <- evalStateT (mkArb step sz) start + t <- evalStateT (mkArbMap step sz) start if valid t then pure t else error "Test generated invalid tree!") where step = do @@ -315,39 +316,6 @@ instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where put i' pure (fromInt i') -class Monad m => MonadGen m where - liftGen :: Gen a -> m a -instance MonadGen Gen where - liftGen = id -instance MonadGen m => MonadGen (StateT s m) where - liftGen = lift . liftGen - --- | Given an action that produces successively larger keys and --- a size, produce a map of arbitrary shape with exactly that size. -mkArb :: (MonadGen m, Arbitrary v) => m k -> Int -> m (Map k v) -mkArb step n - | n <= 0 = return Tip - | n == 1 = do - k <- step - v <- liftGen arbitrary - return (singleton k v) - | n == 2 = do - dir <- liftGen arbitrary - p <- step - q <- step - vOuter <- liftGen arbitrary - vInner <- liftGen arbitrary - if dir - then return (Bin 2 q vOuter (singleton p vInner) Tip) - else return (Bin 2 p vOuter Tip (singleton q vInner)) - | otherwise = do - -- This assumes a balance factor of delta = 3 - let upper = (3*(n - 1)) `quot` 4 - let lower = (n + 2) `quot` 4 - ln <- liftGen $ choose (lower, upper) - let rn = n - ln - 1 - liftM4 (\lt x v rt -> Bin n x v lt rt) (mkArb step ln) step (liftGen arbitrary) (mkArb step rn) - -- A type with a peculiar Eq instance designed to make sure keys -- come from where they're supposed to. data OddEq a = OddEq a Bool deriving (Show) diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index fa9a0f221..697720e69 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -4,27 +4,57 @@ module Main (main) where -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 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 (bottom, isBottom) +import Test.Tasty (TestTree, defaultMain, testGroup) +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 Data.Containers.ListUtils (nubOrd) + +import Utils.ArbitrarySetMap (setFromList, mapFromKeysList) +import Utils.Strictness + (Bot(..), Func, Func2, Func3, applyFunc, applyFunc2, applyFunc3) -import Utils.IsUnit #if __GLASGOW_HASKELL__ >= 806 import Utils.NoThunks #endif instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (Map k v) where - arbitrary = M.fromList `fmap` arbitrary + arbitrary = do + Sorted xs <- arbitrary + m <- mapFromKeysList (nubOrd xs) + + -- Force the values to WHNF. Should use liftRnf2 when that's available. + let !_ = foldr seq () m + + pure m + +instance (Arbitrary a, Ord a) => Arbitrary (Set a) where + arbitrary = do + Sorted xs <- arbitrary + setFromList (nubOrd xs) apply2 :: Fun (a, b) c -> a -> b -> c apply2 f a b = apply f (a, b) @@ -32,8 +62,900 @@ 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 +--------------------------------------------------------------------} + +-- Note [Test overview] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- The purpose of these property tests is to ensure that +-- +-- 1. Functions in Data.Map.Strict force values (as in key-value) to WHNF when +-- inserting into a Map. +-- 2. Functions is Data.Map.Lazy do not force values when inserting into a Map. +-- +-- These are ensured by testing against bottom. If a function is strict in the +-- value, an attempt to create a Map with a bottom value will result in a Map +-- that is bottom. If a function is lazy and the bottom value is not forced, the +-- result will be a non-bottom Map. +-- +-- Every function defined in Data.Map.Strict.Internal and the corresponding +-- functions in Data.Map.Lazy should be tested here for their expected +-- strictness properties. +-- +-- 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 `. +-- * Indirectly against another equivalent function, which must also be tested. +-- For instance, `adjust f` is expected to be equivalent to `alter (fmap f)`, +-- and is tested to be so in strictness. + +-- Note [Testing with lazy functions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- To generate arbitrary functions, the obvious choice is QuickCheck's Fun. +-- However, these functions are always strict, and using only strict functions +-- in tests can fail to catch bugs. +-- +-- For example, consider that +-- `Data.Map.Strict.fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a` +-- starts to force every `a` in the list to WHNF. This is a bug. +-- +-- We have a strictness test which checks that for arbitrary `f` and `kvs`, +-- isBottom (fromListWith f kvs) === +-- isBottom (foldl' (\acc (k,x) -> insertWith f k x acc) empty kvs) +-- +-- If `f` is strict in both arguments, the test will not be able to detect the +-- bug. We need a lazy function to observe the difference, such as +-- +-- fromListWith (\_ c -> c) [(1,'a'), (1,undefined)] +-- +-- which would result in `undefined` instead of the correct +-- `fromList [(1,'a')]`. +-- +-- This is why we use potentially lazy functions Func, Func2, Func3 from +-- Utils.Strictness. Note that this measure may be unnecessary depending on the +-- test (if there is no possibility of the function being called with bottom), +-- but it is easy and harmless to just use the lazy functions everywhere. + +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) = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = + isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 = isNotBottomProp (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 (M.insertWithKey (const f) k x 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 = isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = + isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (L.unionWithKey f m1 m2) + where + f = coerce (applyFunc3 fun) + +prop_strictUnionsWith :: Func2 A A (Bot A) -> [Map OrdA A] -> Property +prop_strictUnionsWith fun ms = + isBottom (M.unionsWith f ms) === + isBottom (F.foldl' (M.unionWith f) M.empty ms) + where + f = coerce (applyFunc2 fun) + +prop_lazyUnionsWith :: Func2 A A (Bot A) -> [Map OrdA A] -> Property +prop_lazyUnionsWith fun ms = isNotBottomProp (L.unionsWith f ms) + where + f = coerce (applyFunc2 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 = isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 (snd (M.mapAccumWithKey (\acc _ -> f acc) z 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 = isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = isNotBottomProp (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 = + isBottom (M.mapEither f m) === + 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 $ case L.mapEither f m of + (m1, m2) -> not (isBottom m1 || isBottom m2) + 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 = + isBottom (M.mapEitherWithKey f m) === + isBottom + ((\(!_, !_) -> ()) $ -- 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 $ case L.mapEitherWithKey f m of + (m1, m2) -> not (isBottom m1 || isBottom m2) + 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 -> + isNotBottomProp (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 (const (Just . f)) m) + where + f = coerce (applyFunc fun) + +prop_lazyUpdateMin :: Func A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateMin fun m = isNotBottomProp (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) ==> + isNotBottomProp (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 (const (Just . f)) m) + where + f = coerce (applyFunc fun) + +prop_lazyUpdateMax :: Func A (Bot A) -> Map OrdA A -> Property +prop_lazyUpdateMax fun m = isNotBottomProp (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) ==> + isNotBottomProp (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 = + isNotBottomProp (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 = + isNotBottomProp (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 @@ -108,74 +1030,6 @@ pStrictFoldlWithKey' :: Map Int Int -> Property pStrictFoldlWithKey' m = whnfHasNoThunks (M.foldlWithKey' (\as _ a -> a : as) [] m) #endif -#if __GLASGOW_HASKELL__ >= 806 -pStrictFromDistinctAscList :: [Int] -> Property -pStrictFromDistinctAscList = whnfHasNoThunks . evalSpine . M.elems . M.fromDistinctAscList . zip [0::Int ..] . map (Just $!) - where - evalSpine xs = length xs `seq` xs -#endif - -#if __GLASGOW_HASKELL__ >= 806 -pStrictFromDistinctDescList :: [Int] -> Property -pStrictFromDistinctDescList = whnfHasNoThunks . evalSpine . M.elems . M.fromDistinctDescList . zip [0::Int, -1 ..] . map (Just $!) - where - evalSpine xs = length xs `seq` xs -#endif - ------------------------------------------------------------------------- --- 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 :: TestTree -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 () -> TestTree - check n m = testCase n $ case M.lookup 42 m of - Just v -> assertBool msg (isUnit v) - _ -> assertBool "key not found" False - where - msg = "too lazy -- expected fully evaluated ()" - -tExtraThunksL :: TestTree -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 () -> TestTree - check n e m = testCase n $ case L.lookup 42 m of - Just v -> assertBool msg (e == isUnit v) - _ -> assertBool "key not found" False - where - msg | e = "too lazy -- expected fully evaluated ()" - | otherwise = "too strict -- expected a thunk" - ------------------------------------------------------------------------ -- * Test list @@ -207,14 +1061,71 @@ tests = , testProperty "strict foldl'" pStrictFoldl' , testProperty "strict foldrWithKey'" pStrictFoldrWithKey' , testProperty "strict foldlWithKey'" pStrictFoldlWithKey' - , testProperty "strict fromDistinctAscList" pStrictFromDistinctAscList - , testProperty "strict fromDistinctDescList" pStrictFromDistinctDescList #endif ] - , tExtraThunksM - , tExtraThunksL + , testGroup "Construction" + [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton + , testPropStrictLazy "fromSet" prop_strictFromSet prop_lazyFromSet + , testPropStrictLazy "fromArgSet" prop_strictFromArgSet prop_lazyFromArgSet + , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList + , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith + , testPropStrictLazy "fromListWithKey" prop_strictFromListWithKey prop_lazyFromListWithKey + , testPropStrictLazy "fromAscList" prop_strictFromAscList prop_lazyFromAscList + , testPropStrictLazy "fromAscListWith" prop_strictFromAscListWith prop_lazyFromAscListWith + , testPropStrictLazy "fromAscListWithKey" prop_strictFromAscListWithKey prop_lazyFromAscListWithKey + , testPropStrictLazy "fromDistinctAscList" prop_strictFromDistinctAscList prop_lazyFromDistinctAscList + , testPropStrictLazy "fromDescList" prop_strictFromDescList prop_lazyFromDescList + , testPropStrictLazy "fromDescListWith" prop_strictFromDescListWith prop_lazyFromDescListWith + , testPropStrictLazy "fromDescListWithKey" prop_strictFromDescListWithKey prop_lazyFromDescListWithKey + , testPropStrictLazy "fromDistinctDescList" prop_strictFromDistinctDescList prop_lazyFromDistinctDescList + , testPropStrictLazy "insert" prop_strictInsert prop_lazyInsert + , testPropStrictLazy "insertWith" prop_strictInsertWith prop_lazyInsertWith + , testPropStrictLazy "insertWithKey" prop_strictInsertWithKey prop_lazyInsertWithKey + , testPropStrictLazy "insertLookupWithKey" prop_strictInsertLookupWithKey prop_lazyInsertLookupWithKey + , testPropStrictLazy "adjust" prop_strictAdjust prop_lazyAdjust + , testPropStrictLazy "adjustWithKey" prop_strictAdjustWithKey prop_lazyAdjustWithKey + , testPropStrictLazy "update" prop_strictUpdate prop_lazyUpdate + , testPropStrictLazy "updateWithKey" prop_strictUpdateWithKey prop_lazyUpdateWithKey + , testPropStrictLazy "updateLookupWithKey" prop_strictUpdateLookupWithKey prop_lazyUpdateLookupWithKey + , testPropStrictLazy "alter" prop_strictAlter prop_lazyAlter + , testPropStrictLazy "alterF" prop_strictAlterF prop_lazyAlterF + , testPropStrictLazy "unionWith" prop_strictUnionWith prop_lazyUnionWith + , testPropStrictLazy "unionWithKey" prop_strictUnionWithKey prop_lazyUnionWithKey + , testPropStrictLazy "unionsWith" prop_strictUnionsWith prop_lazyUnionsWith + , testPropStrictLazy "differenceWith" prop_strictDifferenceWith prop_lazyDifferenceWith + , testPropStrictLazy "differenceWithKey" prop_strictDifferenceWithKey prop_lazyDifferenceWithKey + , testPropStrictLazy "intersectionWith" prop_strictIntersectionWith prop_lazyIntersectionWith + , testPropStrictLazy "intersectionWithKey" prop_strictIntersectionWithKey prop_lazyIntersectionWithKey + , testPropStrictLazy "mergeWithKey" prop_strictMergeWithKey prop_lazyMergeWithKey + , testPropStrictLazy "map" prop_strictMap prop_lazyMap + , testPropStrictLazy "mapWithKey" prop_strictMapWithKey prop_lazyMapWithKey + , testPropStrictLazy "traverseWithKey" prop_strictTraverseWithKey prop_lazyTraverseWithKey + , testPropStrictLazy "traverseMaybeWithKey" prop_strictTraverseMaybeWithKey prop_lazyTraverseMaybeWithKey + , testPropStrictLazy "mapAccum" prop_strictMapAccum prop_lazyMapAccum + , testPropStrictLazy "mapAccumWithKey" prop_strictMapAccumWithKey prop_lazyMapAccumWithKey + , testPropStrictLazy "mapAccumRWithKey" prop_strictMapAccumRWithKey prop_lazyMapAccumRWithKey + , testPropStrictLazy "mapKeysWith" prop_strictMapKeysWith prop_lazyMapKeysWith + , testPropStrictLazy "mapMaybe" prop_strictMapMaybe prop_lazyMapMaybe + , testPropStrictLazy "mapMaybeWithKey" prop_strictMapMaybeWithKey prop_lazyMapMaybeWithKey + , testPropStrictLazy "mapEither" prop_strictMapEither prop_lazyMapEither + , testPropStrictLazy "mapEitherWithKey" prop_strictMapEitherWithKey prop_lazyMapEitherWithKey + , testPropStrictLazy "updateAt" prop_strictUpdateAt prop_lazyUpdateAt + , testPropStrictLazy "updateMin" prop_strictUpdateMin prop_lazyUpdateMin + , testPropStrictLazy "updateMinWithKey" prop_strictUpdateMinWithKey prop_lazyUpdateMinWithKey + , testPropStrictLazy "updateMax" prop_strictUpdateMax prop_lazyUpdateMax + , testPropStrictLazy "updateMaxWithKey" prop_strictUpdateMaxWithKey prop_lazyUpdateMaxWithKey + , testPropStrictLazy "merge" prop_strictMerge prop_lazyMerge + , testPropStrictLazy "mergeA" prop_strictMergeA prop_lazyMergeA + ] ] +testPropStrictLazy :: Testable a => String -> a -> a -> TestTree +testPropStrictLazy name strictTest lazyTest = + testGroup name + [ testProperty "strict" strictTest + , testProperty "lazy" lazyTest + ] + ------------------------------------------------------------------------ -- * Test harness @@ -227,9 +1138,204 @@ main = defaultMain $ testGroup "map-strictness" tests keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool keyStrict f m = isBottom $ f bottom m +isNotBottomProp :: a -> Property +isNotBottomProp = 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 +--------------------------------------------------------------------} + +-- k: key, x: left map value, y: right map value, z: result map value, +-- a,b: fmaps over the result value. a and b are independent variables to allow +-- for coercions involving Bot. See prop_strictMerge for an example. +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 + +-- k: key, x: map value, y: result map value, a,b: fmaps over the result value. +-- a and b are independent variables to allow for coercions involving Bot. See +-- prop_strictMerge for an example. +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 diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs index 83b7ba4c7..07b5bfc39 100644 --- a/containers-tests/tests/set-properties.hs +++ b/containers-tests/tests/set-properties.hs @@ -2,7 +2,6 @@ import qualified Data.IntSet as IntSet import Data.List (nub, sort, sortBy) import qualified Data.List as List -import Data.Monoid (mempty) import Data.Maybe import Data.Set import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl', all, take, drop, splitAt) @@ -12,7 +11,6 @@ import Test.Tasty.QuickCheck import Test.QuickCheck.Function (apply) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class -import Control.Monad (liftM, liftM3) import Data.Functor.Identity import Data.Foldable (all) import Data.Ord (Down(..), comparing) @@ -20,6 +18,7 @@ import Control.Applicative (liftA2) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE +import Utils.ArbitrarySetMap (mkArbSet, setFromList) #if __GLASGOW_HASKELL__ >= 806 import Utils.NoThunks (whnfHasNoThunks) #endif @@ -230,7 +229,7 @@ instance IsInt a => Arbitrary (Set a) where middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1)) let shift = (sz * (gapRange) + 1) `quot` 2 start = middle - shift - t <- evalStateT (mkArb step sz) start + t <- evalStateT (mkArbSet step sz) start if valid t then pure t else error "Test generated invalid tree!") where step = do @@ -240,47 +239,6 @@ instance IsInt a => Arbitrary (Set a) where put i' pure (fromInt i') -class Monad m => MonadGen m where - liftGen :: Gen a -> m a -instance MonadGen Gen where - liftGen = id -instance MonadGen m => MonadGen (StateT s m) where - liftGen = lift . liftGen - --- | Given an action that produces successively larger elements and --- a size, produce a set of arbitrary shape with exactly that size. -mkArb :: MonadGen m => m a -> Int -> m (Set a) -mkArb step n - | n <= 0 = return Tip - | n == 1 = singleton `liftM` step - | n == 2 = do - dir <- liftGen arbitrary - p <- step - q <- step - if dir - then return (Bin 2 q (singleton p) Tip) - else return (Bin 2 p Tip (singleton q)) - | otherwise = do - -- This assumes a balance factor of delta = 3 - let upper = (3*(n - 1)) `quot` 4 - let lower = (n + 2) `quot` 4 - ln <- liftGen $ choose (lower, upper) - let rn = n - ln - 1 - liftM3 (\lt x rt -> Bin n x lt rt) (mkArb step ln) step (mkArb step rn) - --- | Given a strictly increasing list of elements, produce an arbitrarily --- shaped set with exactly those elements. -setFromList :: [a] -> Gen (Set a) -setFromList xs = flip evalStateT xs $ mkArb step (length xs) - where - step = do - xxs <- get - case xxs of - x : xs -> do - put xs - pure x - [] -> error "setFromList" - data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show) data TwoLists a = TwoLists [a] [a]