Strictness tests for Map construction

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:

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 #-}

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 "<bottom>" else show x
+
+instance Arbitrary a => Arbitrary (Bot a) where
+  arbitrary = frequency
+    [ (1, pure (error "<bottom>"))
+    , (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

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)