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

@@ -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)