Skip to content

Commit 53f6be5

Browse files
meooow25meooow25
committed
Add strictness tests for Map construction
This aims to reduce the possibility 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.
1 parent 9a9e210 commit 53f6be5

File tree

6 files changed

+1443
-166
lines changed

6 files changed

+1443
-166
lines changed

‎containers-tests/containers-tests.cabal‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -270,6 +270,9 @@ test-suite map-lazy-properties
270270
main-is: map-properties.hs
271271
type: exitcode-stdio-1.0
272272

273+
other-modules:
274+
Utils.ArbitrarySetMap
275+
273276
ghc-options: -O2
274277
other-extensions:
275278
BangPatterns
@@ -283,6 +286,9 @@ test-suite map-strict-properties
283286
type: exitcode-stdio-1.0
284287
cpp-options: -DSTRICT
285288

289+
other-modules:
290+
Utils.ArbitrarySetMap
291+
286292
ghc-options: -O2
287293
other-extensions:
288294
BangPatterns
@@ -306,6 +312,9 @@ test-suite set-properties
306312
main-is: set-properties.hs
307313
type: exitcode-stdio-1.0
308314

315+
other-modules:
316+
Utils.ArbitrarySetMap
317+
309318
ghc-options: -O2
310319
other-extensions:
311320
BangPatterns
@@ -404,7 +413,8 @@ test-suite map-strictness-properties
404413
CPP
405414

406415
other-modules:
407-
Utils.IsUnit
416+
Utils.ArbitrarySetMap
417+
Utils.Strictness
408418

409419
if impl(ghc >= 8.6)
410420
build-depends:

‎containers-tests/tests/Utils/ArbitrarySetMap.hs‎

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,117 @@
1+
module Utils.ArbitrarySetMap
2+
(
3+
-- MonadGen
4+
MonadGen(..)
5+
6+
-- Set
7+
, mkArbSet
8+
, setFromList
9+
10+
-- Map
11+
, mkArbMap
12+
, mapFromKeysList
13+
) where
14+
15+
import Control.Monad (liftM, liftM3, liftM4)
16+
import Control.Monad.Trans.State.Strict
17+
import Control.Monad.Trans.Class
18+
import qualified Data.List as List
19+
import Data.Maybe (fromMaybe)
20+
import Test.QuickCheck
21+
22+
import Data.Set (Set)
23+
import qualified Data.Set.Internal as S
24+
import Data.Map (Map)
25+
import qualified Data.Map.Internal as M
26+
27+
{--------------------------------------------------------------------
28+
MonadGen
29+
--------------------------------------------------------------------}
30+
31+
class Monad m => MonadGen m where
32+
liftGen :: Gen a -> m a
33+
instance MonadGen Gen where
34+
liftGen = id
35+
instance MonadGen m => MonadGen (StateT s m) where
36+
liftGen = lift . liftGen
37+
38+
{--------------------------------------------------------------------
39+
Set
40+
--------------------------------------------------------------------}
41+
42+
-- | Given an action that produces successively larger elements and
43+
-- a size, produce a set of arbitrary shape with exactly that size.
44+
mkArbSet :: MonadGen m => m a -> Int -> m (Set a)
45+
mkArbSet step n
46+
| n <= 0 = return S.Tip
47+
| n == 1 = S.singleton `liftM` step
48+
| n == 2 = do
49+
dir <- liftGen arbitrary
50+
p <- step
51+
q <- step
52+
if dir
53+
then return (S.Bin 2 q (S.singleton p) S.Tip)
54+
else return (S.Bin 2 p S.Tip (S.singleton q))
55+
| otherwise = do
56+
-- This assumes a balance factor of delta = 3
57+
let upper = (3*(n - 1)) `quot` 4
58+
let lower = (n + 2) `quot` 4
59+
ln <- liftGen $ choose (lower, upper)
60+
let rn = n - ln - 1
61+
liftM3
62+
(\lt x rt -> S.Bin n x lt rt)
63+
(mkArbSet step ln)
64+
step
65+
(mkArbSet step rn)
66+
{-# INLINABLE mkArbSet #-}
67+
68+
-- | Given a strictly increasing list of elements, produce an arbitrarily
69+
-- shaped set with exactly those elements.
70+
setFromList :: [a] -> Gen (Set a)
71+
setFromList xs = flip evalStateT xs $ mkArbSet step (length xs)
72+
where
73+
step = state $ fromMaybe (error "setFromList") . List.uncons
74+
75+
{--------------------------------------------------------------------
76+
Map
77+
--------------------------------------------------------------------}
78+
79+
-- | Given an action that produces successively larger keys and
80+
-- a size, produce a map of arbitrary shape with exactly that size.
81+
mkArbMap :: (MonadGen m, Arbitrary v) => m k -> Int -> m (Map k v)
82+
mkArbMap step n
83+
| n <= 0 = return M.Tip
84+
| n == 1 = do
85+
k <- step
86+
v <- liftGen arbitrary
87+
return (M.singleton k v)
88+
| n == 2 = do
89+
dir <- liftGen arbitrary
90+
p <- step
91+
q <- step
92+
vOuter <- liftGen arbitrary
93+
vInner <- liftGen arbitrary
94+
if dir
95+
then return (M.Bin 2 q vOuter (M.singleton p vInner) M.Tip)
96+
else return (M.Bin 2 p vOuter M.Tip (M.singleton q vInner))
97+
| otherwise = do
98+
-- This assumes a balance factor of delta = 3
99+
let upper = (3*(n - 1)) `quot` 4
100+
let lower = (n + 2) `quot` 4
101+
ln <- liftGen $ choose (lower, upper)
102+
let rn = n - ln - 1
103+
liftM4
104+
(\lt x v rt -> M.Bin n x v lt rt)
105+
(mkArbMap step ln)
106+
step
107+
(liftGen arbitrary)
108+
(mkArbMap step rn)
109+
{-# INLINABLE mkArbMap #-}
110+
111+
-- | Given a strictly increasing list of keys, produce an arbitrarily
112+
-- shaped map with exactly those keys.
113+
mapFromKeysList :: Arbitrary a => [k] -> Gen (Map k a)
114+
mapFromKeysList xs = flip evalStateT xs $ mkArbMap step (length xs)
115+
where
116+
step = state $ fromMaybe (error "mapFromKeysList") . List.uncons
117+
{-# INLINABLE mapFromKeysList #-}

‎containers-tests/tests/Utils/Strictness.hs‎

Lines changed: 116 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,116 @@
1+
module Utils.Strictness
2+
( Bot(..)
3+
, Func
4+
, applyFunc
5+
, Func2
6+
, applyFunc2
7+
, Func3
8+
, applyFunc3
9+
) where
10+
11+
import Test.ChasingBottoms.IsBottom (isBottom)
12+
import Test.QuickCheck
13+
14+
{--------------------------------------------------------------------
15+
Bottom stuff
16+
--------------------------------------------------------------------}
17+
18+
-- | Arbitrary (Bot a) values may be bottom.
19+
newtype Bot a = Bot a
20+
21+
instance Show a => Show (Bot a) where
22+
show (Bot x) = if isBottom x then "<bottom>" else show x
23+
24+
instance Arbitrary a => Arbitrary (Bot a) where
25+
arbitrary = frequency
26+
[ (1, pure (error "<bottom>"))
27+
, (4, Bot <$> arbitrary)
28+
]
29+
30+
{--------------------------------------------------------------------
31+
Lazy functions
32+
--------------------------------------------------------------------}
33+
34+
-- | A function which may be lazy in its argument.
35+
--
36+
-- Either ignores its argument, or uses a QuickCheck Fun (which is always a
37+
-- strict function).
38+
data Func a b
39+
= FuncLazy b
40+
| FuncStrict (Fun a b)
41+
42+
instance (Show a, Show b) => Show (Func a b) where
43+
show (FuncLazy x) = "{_lazy->" ++ show x ++ "}"
44+
show (FuncStrict fun) = show fun
45+
46+
applyFunc :: Func a b -> a -> b
47+
applyFunc fun x = case fun of
48+
FuncLazy y -> y
49+
FuncStrict f -> applyFun f x
50+
51+
instance (CoArbitrary a, Function a, Arbitrary b) => Arbitrary (Func a b) where
52+
arbitrary = frequency
53+
[ (1, FuncLazy <$> arbitrary)
54+
, (4, FuncStrict <$> arbitrary)
55+
]
56+
57+
shrink fun = case fun of
58+
FuncLazy x -> FuncLazy <$> shrink x
59+
FuncStrict f -> FuncStrict <$> shrink f
60+
61+
-- | A function which may be lazy in its arguments.
62+
63+
-- Note: We have two separate cases here because we want to generate functions
64+
-- of type `a -> b -> c` with all possible strictness configurations.
65+
-- `Func a (Func b c)` is not enough for this, since it cannot generate
66+
-- functions that are conditionally lazy in the first argument, for instance:
67+
--
68+
-- leftLazyOr :: Bool -> Bool -> Bool
69+
-- leftLazyOr a b = if b then True else a
70+
71+
data Func2 a b c
72+
= F2A (Func a (Func b c))
73+
| F2B (Func b (Func a c))
74+
deriving Show
75+
76+
instance
77+
(CoArbitrary a, Function a, CoArbitrary b, Function b, Arbitrary c)
78+
=> Arbitrary (Func2 a b c) where
79+
arbitrary = oneof [F2A <$> arbitrary, F2B <$> arbitrary]
80+
81+
shrink fun2 = case fun2 of
82+
F2A fun -> F2A <$> shrink fun
83+
F2B fun -> F2B <$> shrink fun
84+
85+
applyFunc2 :: Func2 a b c -> a -> b -> c
86+
applyFunc2 fun2 x y = case fun2 of
87+
F2A fun -> applyFunc (applyFunc fun x) y
88+
F2B fun -> applyFunc (applyFunc fun y) x
89+
90+
-- | A function which may be lazy in its arguments.
91+
92+
-- See Note on Func2.
93+
data Func3 a b c d
94+
= F3A (Func a (Func2 b c d))
95+
| F3B (Func b (Func2 a c d))
96+
| F3C (Func c (Func2 a b d))
97+
deriving Show
98+
99+
instance
100+
( CoArbitrary a, Function a
101+
, CoArbitrary b, Function b
102+
, CoArbitrary c, Function c
103+
, Arbitrary d
104+
) => Arbitrary (Func3 a b c d) where
105+
arbitrary = oneof [F3A <$> arbitrary, F3B <$> arbitrary, F3C <$> arbitrary]
106+
107+
shrink fun3 = case fun3 of
108+
F3A fun -> F3A <$> shrink fun
109+
F3B fun -> F3B <$> shrink fun
110+
F3C fun -> F3C <$> shrink fun
111+
112+
applyFunc3 :: Func3 a b c d -> a -> b -> c -> d
113+
applyFunc3 fun3 x y z = case fun3 of
114+
F3A fun -> applyFunc2 (applyFunc fun x) y z
115+
F3B fun -> applyFunc2 (applyFunc fun y) x z
116+
F3C fun -> applyFunc2 (applyFunc fun z) x y

‎containers-tests/tests/map-properties.hs‎

Lines changed: 5 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -7,13 +7,13 @@ import Data.Map.Merge.Strict
77
import Data.Map.Lazy as Data.Map
88
import Data.Map.Merge.Lazy
99
#endif
10-
import Data.Map.Internal (Map (..), link2, link, bin)
10+
import Data.Map.Internal (Map, link2, link)
1111
import Data.Map.Internal.Debug (showTree, showTreeWith, balanced)
1212

1313
import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>))
1414
import Control.Monad.Trans.State.Strict
1515
import Control.Monad.Trans.Class
16-
import Control.Monad (liftM4, (<=<))
16+
import Control.Monad ((<=<))
1717
import Data.Functor.Identity (Identity(Identity, runIdentity))
1818
import Data.Monoid
1919
import Data.Maybe hiding (mapMaybe)
@@ -36,7 +36,8 @@ import Test.Tasty.HUnit
3636
import Test.Tasty.QuickCheck
3737
import Test.QuickCheck.Function (apply)
3838
import Test.QuickCheck.Poly (A, B, OrdA)
39-
import Control.Arrow (first)
39+
40+
import Utils.ArbitrarySetMap (mkArbMap)
4041

4142
default (Int)
4243

@@ -305,7 +306,7 @@ instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where
305306
middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))
306307
let shift = (sz * (gapRange) + 1) `quot` 2
307308
start = middle - shift
308-
t <- evalStateT (mkArb step sz) start
309+
t <- evalStateT (mkArbMap step sz) start
309310
if valid t then pure t else error "Test generated invalid tree!")
310311
where
311312
step = do
@@ -315,39 +316,6 @@ instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where
315316
put i'
316317
pure (fromInt i')
317318

318-
class Monad m => MonadGen m where
319-
liftGen :: Gen a -> m a
320-
instance MonadGen Gen where
321-
liftGen = id
322-
instance MonadGen m => MonadGen (StateT s m) where
323-
liftGen = lift . liftGen
324-
325-
-- | Given an action that produces successively larger keys and
326-
-- a size, produce a map of arbitrary shape with exactly that size.
327-
mkArb :: (MonadGen m, Arbitrary v) => m k -> Int -> m (Map k v)
328-
mkArb step n
329-
| n <= 0 = return Tip
330-
| n == 1 = do
331-
k <- step
332-
v <- liftGen arbitrary
333-
return (singleton k v)
334-
| n == 2 = do
335-
dir <- liftGen arbitrary
336-
p <- step
337-
q <- step
338-
vOuter <- liftGen arbitrary
339-
vInner <- liftGen arbitrary
340-
if dir
341-
then return (Bin 2 q vOuter (singleton p vInner) Tip)
342-
else return (Bin 2 p vOuter Tip (singleton q vInner))
343-
| otherwise = do
344-
-- This assumes a balance factor of delta = 3
345-
let upper = (3*(n - 1)) `quot` 4
346-
let lower = (n + 2) `quot` 4
347-
ln <- liftGen $ choose (lower, upper)
348-
let rn = n - ln - 1
349-
liftM4 (\lt x v rt -> Bin n x v lt rt) (mkArb step ln) step (liftGen arbitrary) (mkArb step rn)
350-
351319
-- A type with a peculiar Eq instance designed to make sure keys
352320
-- come from where they're supposed to.
353321
data OddEq a = OddEq a Bool deriving (Show)

0 commit comments

Comments
 (0)