Move out arbitrary Set and Map construction

containers-tests/containers-tests.cabal

@@ -268,6 +268,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
@@ -281,6 +284,9 @@ test-suite map-strict-properties
   type:             exitcode-stdio-1.0
   cpp-options:      -DSTRICT
 
+  other-modules:
+    Utils.ArbitrarySetMap
+
   ghc-options:      -O2
   other-extensions:
     BangPatterns
@@ -304,6 +310,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
@@ -402,6 +411,7 @@ test-suite map-strictness-properties
     CPP
 
   other-modules:
+    Utils.ArbitrarySetMap
     Utils.Strictness
 
   if impl(ghc >= 8.6)

containers-tests/tests/Utils/ArbitrarySetMap.hs

@@ -0,0 +1,127 @@
+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 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 = do
+      xxs <- get
+      case xxs of
+        x : xs -> do
+          put xs
+          pure x
+        [] -> error "setFromList"
+
+{--------------------------------------------------------------------
+  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 = do
+      xxs <- get
+      case xxs of
+        x : xs -> do
+          put xs
+          pure x
+        [] -> error "mapFromKeysList"
+{-# INLINABLE mapFromKeysList #-}

containers-tests/tests/map-properties.hs

@@ -7,13 +7,13 @@ import Data.Map.Merge.Strict
 import Data.Map.Lazy as Data.Map hiding (showTree, showTreeWith)
 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)
@@ -34,7 +34,8 @@ import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 import Test.QuickCheck.Function (apply)
 import Test.QuickCheck.Poly (A, B)
-import Control.Arrow (first)
+
+import Utils.ArbitrarySetMap (mkArbMap)
 
 default (Int)
 
@@ -297,7 +298,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
@@ -307,39 +308,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)

containers-tests/tests/map-strictness.hs

@@ -30,7 +30,9 @@ 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)
 
@@ -40,10 +42,19 @@ import Utils.NoThunks
 
 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 = Set.fromList <$> arbitrary
+  arbitrary = do
+    Sorted xs <- arbitrary
+    setFromList $ nubOrd xs
 
 apply2 :: Fun (a, b) c -> a -> b -> c
 apply2 f a b = apply f (a, b)

containers-tests/tests/set-properties.hs

@@ -2,7 +2,6 @@
 import qualified Data.IntSet as IntSet
 import Data.List (nub,sort)
 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,11 +11,11 @@ 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 Control.Applicative (liftA2)
 
+import Utils.ArbitrarySetMap (mkArbSet, setFromList)
 #if __GLASGOW_HASKELL__ >= 806
 import Utils.NoThunks (whnfHasNoThunks)
 #endif
@@ -222,7 +221,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
@@ -232,47 +231,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]