Skip to content

Commit a0c3ee7

Browse files
MaximilianAlgehedMaximilianAlgehed
committed
Fix shrinking
1 parent 9cd1d2f commit a0c3ee7

File tree

10 files changed

+64
-18
lines changed

10 files changed

+64
-18
lines changed

‎examples/Constrained/Examples/BinTree.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,8 @@ instance HasSpec a => HasSpec (BinTree a) where
7676
: (BinNode left a <$> shrinkWithTypeSpec s right)
7777
++ ((\l -> BinNode l a right) <$> shrinkWithTypeSpec s left)
7878

79+
fixupWithTypeSpec _ _ = Nothing
80+
7981
cardinalTypeSpec _ = mempty
8082

8183
toPreds t (BinTreeSpec msz s) =

‎src/Constrained/Base.hs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -492,6 +492,9 @@ class
492492
-- | Shrink an `a` with the aide of a `TypeSpec`
493493
shrinkWithTypeSpec :: TypeSpec a -> a -> [a]
494494

495+
-- | Try to make an `a` conform to `TypeSpec` with minimal changes
496+
fixupWithTypeSpec :: TypeSpec a -> a -> Maybe a
497+
495498
-- | Convert a spec to predicates:
496499
-- The key property here is:
497500
-- ∀ a. a `conformsTo` spec == a `conformsTo` constrained (\t -> toPreds t spec)
@@ -608,6 +611,13 @@ class
608611
[a]
609612
shrinkWithTypeSpec spec a = map fromSimpleRep $ shrinkWithTypeSpec spec (toSimpleRep a)
610613

614+
default fixupWithTypeSpec ::
615+
GenericallyInstantiated a =>
616+
TypeSpec a ->
617+
a ->
618+
Maybe a
619+
fixupWithTypeSpec spec a = fromSimpleRep <$> fixupWithTypeSpec spec (toSimpleRep a)
620+
611621
default cardinalTypeSpec ::
612622
GenericallyInstantiated a =>
613623
TypeSpec a ->
@@ -628,6 +638,7 @@ instance HasSpec Bool where
628638
cardinalTypeSpec _ = equalSpec 2
629639
cardinalTrueSpec = equalSpec 2
630640
shrinkWithTypeSpec _ = shrink
641+
fixupWithTypeSpec _ = Just
631642
conformsTo _ _ = True
632643
toPreds _ _ = TruePred
633644

@@ -637,6 +648,7 @@ instance HasSpec () where
637648
combineSpec _ _ = typeSpec ()
638649
_ `conformsTo` _ = True
639650
shrinkWithTypeSpec _ _ = []
651+
fixupWithTypeSpec _ _ = pure ()
640652
genFromTypeSpec _ = pure ()
641653
toPreds _ _ = TruePred
642654
cardinalTypeSpec _ = MemberSpec (pure 1)

‎src/Constrained/Generation.hs‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ module Constrained.Generation (
2525
genFromSpecT,
2626
genFromSpecWithSeed,
2727
shrinkWithSpec,
28+
fixupWithSpec,
2829
simplifySpec,
2930

3031
-- ** Debugging
@@ -207,7 +208,7 @@ shrinkEnvFromPlan initialEnv SolverPlan {..} = go mempty solverPlan
207208
fixupPlan :: Env -> [SolverStage] -> Maybe Env
208209
fixupPlan env [] = pure env
209210
fixupPlan env ((unsafeSubstStage env -> SolverStage {..}) : plan) =
210-
case Env.lookup initialEnv stageVar >>= fixupWithSpec stageSpec of
211+
case Env.lookup (env <> initialEnv) stageVar >>= fixupWithSpec stageSpec of
211212
Nothing -> Nothing
212213
Just a -> fixupPlan (Env.extend stageVar a env) plan
213214

@@ -217,6 +218,7 @@ fixupWithSpec spec a
217218
| a `conformsToSpec` spec = Just a
218219
| otherwise = case spec of
219220
MemberSpec (a' :| _) -> Just a'
221+
TypeSpec ts _ -> fixupWithTypeSpec ts a >>= \ a' -> a' <$ guard (conformsToSpec a' spec)
220222
_ -> listToMaybe $ filter (`conformsToSpec` spec) (shrinkWithSpec TrueSpec a)
221223

222224
-- Debugging --------------------------------------------------------------
@@ -1164,6 +1166,9 @@ instance (HasSpec a, HasSpec b, KnownNat (CountCases b)) => HasSpec (Sum a b) wh
11641166
shrinkWithTypeSpec (SumSpec _ sa _) (SumLeft a) = SumLeft <$> shrinkWithSpec sa a
11651167
shrinkWithTypeSpec (SumSpec _ _ sb) (SumRight b) = SumRight <$> shrinkWithSpec sb b
11661168

1169+
fixupWithTypeSpec (SumSpec _ sa _) (SumLeft a) = SumLeft <$> fixupWithSpec sa a
1170+
fixupWithTypeSpec (SumSpec _ _ sb) (SumRight b) = SumRight <$> fixupWithSpec sb b
1171+
11671172
toPreds ct (SumSpec h sa sb) =
11681173
Case
11691174
ct

‎src/Constrained/NumOrd.hs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ module Constrained.NumOrd (
3939
combineNumSpec,
4040
genFromNumSpec,
4141
shrinkWithNumSpec,
42+
fixupWithTypeSpec,
4243
conformsToNumSpec,
4344
toPredsNumSpec,
4445
OrdLike (..),
@@ -320,6 +321,11 @@ genFromNumSpec (NumSpecInterval ml mu) = do
320321
shrinkWithNumSpec :: Arbitrary n => NumSpec n -> n -> [n]
321322
shrinkWithNumSpec _ = shrink
322323

324+
-- TODO: fixme
325+
326+
fixupWithNumSpec :: Arbitrary n => NumSpec n -> n -> Maybe n
327+
fixupWithNumSpec _ = listToMaybe . shrink
328+
323329
constrainInterval ::
324330
(MonadGenError m, Ord a, Num a, Show a) => Maybe a -> Maybe a -> Integer -> m (a, a)
325331
constrainInterval ml mu r =
@@ -1073,6 +1079,7 @@ instance HasSpec Integer where
10731079
combineSpec = combineNumSpec
10741080
genFromTypeSpec = genFromNumSpec
10751081
shrinkWithTypeSpec = shrinkWithNumSpec
1082+
fixupWithTypeSpec = fixupWithNumSpec
10761083
conformsTo = conformsToNumSpec
10771084
toPreds = toPredsNumSpec
10781085
cardinalTypeSpec = cardinalNumSpec
@@ -1084,6 +1091,7 @@ instance HasSpec Int where
10841091
combineSpec = combineNumSpec
10851092
genFromTypeSpec = genFromNumSpec
10861093
shrinkWithTypeSpec = shrinkWithNumSpec
1094+
fixupWithTypeSpec = fixupWithNumSpec
10871095
conformsTo = conformsToNumSpec
10881096
toPreds = toPredsNumSpec
10891097
cardinalTypeSpec = cardinalNumSpec
@@ -1095,6 +1103,7 @@ instance HasSpec (Ratio Integer) where
10951103
combineSpec = combineNumSpec
10961104
genFromTypeSpec = genFromNumSpec
10971105
shrinkWithTypeSpec = shrinkWithNumSpec
1106+
fixupWithTypeSpec = fixupWithNumSpec
10981107
conformsTo = conformsToNumSpec
10991108
toPreds = toPredsNumSpec
11001109
cardinalTypeSpec _ = TrueSpec
@@ -1106,6 +1115,7 @@ instance HasSpec Natural where
11061115
combineSpec = combineNumSpec
11071116
genFromTypeSpec = genFromNumSpec
11081117
shrinkWithTypeSpec = shrinkWithNumSpec
1118+
fixupWithTypeSpec = fixupWithNumSpec
11091119
conformsTo = conformsToNumSpec
11101120
toPreds = toPredsNumSpec
11111121
cardinalTypeSpec (NumSpecInterval (fromMaybe 0 -> lo) (Just hi)) =
@@ -1121,6 +1131,7 @@ instance HasSpec Word8 where
11211131
combineSpec = combineNumSpec
11221132
genFromTypeSpec = genFromNumSpec
11231133
shrinkWithTypeSpec = shrinkWithNumSpec
1134+
fixupWithTypeSpec = fixupWithNumSpec
11241135
conformsTo = conformsToNumSpec
11251136
toPreds = toPredsNumSpec
11261137
cardinalTypeSpec = cardinalNumSpec
@@ -1134,6 +1145,7 @@ instance HasSpec Word16 where
11341145
combineSpec = combineNumSpec
11351146
genFromTypeSpec = genFromNumSpec
11361147
shrinkWithTypeSpec = shrinkWithNumSpec
1148+
fixupWithTypeSpec = fixupWithNumSpec
11371149
conformsTo = conformsToNumSpec
11381150
toPreds = toPredsNumSpec
11391151
cardinalTypeSpec = cardinalNumSpec
@@ -1146,6 +1158,7 @@ instance HasSpec Word32 where
11461158
combineSpec = combineNumSpec
11471159
genFromTypeSpec = genFromNumSpec
11481160
shrinkWithTypeSpec = shrinkWithNumSpec
1161+
fixupWithTypeSpec = fixupWithNumSpec
11491162
conformsTo = conformsToNumSpec
11501163
toPreds = toPredsNumSpec
11511164
cardinalTypeSpec = cardinalNumSpec
@@ -1157,6 +1170,7 @@ instance HasSpec Word64 where
11571170
combineSpec = combineNumSpec
11581171
genFromTypeSpec = genFromNumSpec
11591172
shrinkWithTypeSpec = shrinkWithNumSpec
1173+
fixupWithTypeSpec = fixupWithNumSpec
11601174
conformsTo = conformsToNumSpec
11611175
toPreds = toPredsNumSpec
11621176
cardinalTypeSpec = cardinalNumSpec
@@ -1168,6 +1182,7 @@ instance HasSpec Int8 where
11681182
combineSpec = combineNumSpec
11691183
genFromTypeSpec = genFromNumSpec
11701184
shrinkWithTypeSpec = shrinkWithNumSpec
1185+
fixupWithTypeSpec = fixupWithNumSpec
11711186
conformsTo = conformsToNumSpec
11721187
toPreds = toPredsNumSpec
11731188
cardinalTrueSpec = equalSpec 256
@@ -1180,6 +1195,7 @@ instance HasSpec Int16 where
11801195
combineSpec = combineNumSpec
11811196
genFromTypeSpec = genFromNumSpec
11821197
shrinkWithTypeSpec = shrinkWithNumSpec
1198+
fixupWithTypeSpec = fixupWithNumSpec
11831199
conformsTo = conformsToNumSpec
11841200
toPreds = toPredsNumSpec
11851201
cardinalTypeSpec = cardinalNumSpec
@@ -1192,6 +1208,7 @@ instance HasSpec Int32 where
11921208
combineSpec = combineNumSpec
11931209
genFromTypeSpec = genFromNumSpec
11941210
shrinkWithTypeSpec = shrinkWithNumSpec
1211+
fixupWithTypeSpec = fixupWithNumSpec
11951212
conformsTo = conformsToNumSpec
11961213
toPreds = toPredsNumSpec
11971214
cardinalTypeSpec = cardinalNumSpec
@@ -1203,6 +1220,7 @@ instance HasSpec Int64 where
12031220
combineSpec = combineNumSpec
12041221
genFromTypeSpec = genFromNumSpec
12051222
shrinkWithTypeSpec = shrinkWithNumSpec
1223+
fixupWithTypeSpec = fixupWithNumSpec
12061224
conformsTo = conformsToNumSpec
12071225
toPreds = toPredsNumSpec
12081226
cardinalTypeSpec = cardinalNumSpec
@@ -1214,6 +1232,7 @@ instance HasSpec Float where
12141232
combineSpec = combineNumSpec
12151233
genFromTypeSpec = genFromNumSpec
12161234
shrinkWithTypeSpec = shrinkWithNumSpec
1235+
fixupWithTypeSpec = fixupWithNumSpec
12171236
conformsTo = conformsToNumSpec
12181237
toPreds = toPredsNumSpec
12191238
cardinalTypeSpec _ = TrueSpec
@@ -1225,6 +1244,7 @@ instance HasSpec Double where
12251244
combineSpec = combineNumSpec
12261245
genFromTypeSpec = genFromNumSpec
12271246
shrinkWithTypeSpec = shrinkWithNumSpec
1247+
fixupWithTypeSpec = fixupWithNumSpec
12281248
conformsTo = conformsToNumSpec
12291249
toPreds = toPredsNumSpec
12301250
cardinalTypeSpec _ = TrueSpec

‎src/Constrained/Spec/List.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -244,6 +244,9 @@ instance HasSpec a => HasSpec [a] where
244244
shrinkWithTypeSpec (ListSpec _ _ _ es _) as =
245245
shrinkList (shrinkWithSpec es) as
246246

247+
-- TODO: fixme
248+
fixupWithTypeSpec _ _ = Nothing
249+
247250
cardinalTypeSpec _ = TrueSpec
248251

249252
guardTypeSpec = guardListSpec

‎src/Constrained/Spec/Map.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -278,6 +278,8 @@ instance
278278

279279
shrinkWithTypeSpec (MapSpec _ _ _ _ kvs _) m = map Map.fromList $ shrinkList (shrinkWithSpec kvs) (Map.toList m)
280280

281+
fixupWithTypeSpec _ _ = Nothing
282+
281283
toPreds m (MapSpec mHint mustKeys mustVals size kvs foldSpec) =
282284
toPred
283285
[ Assert $ Lit mustKeys `subset_` dom_ m

‎src/Constrained/Spec/Set.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -204,6 +204,9 @@ instance (Ord a, HasSpec a) => HasSpec (Set a) where
204204

205205
shrinkWithTypeSpec (SetSpec _ es _) as = map Set.fromList $ shrinkList (shrinkWithSpec es) (Set.toList as)
206206

207+
-- TODO: fixme
208+
fixupWithTypeSpec _ _ = Nothing
209+
207210
toPreds s (SetSpec m es size) =
208211
fold $
209212
-- Don't include this if the must set is empty

‎src/Constrained/Spec/Tree.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -109,6 +109,9 @@ instance HasSpec a => HasSpec (Tree a) where
109109
| ts' <- shrinkList (shrinkWithTypeSpec (TreeSpec Nothing Nothing TrueSpec ctxSpec)) ts
110110
]
111111

112+
-- TODO: fixme
113+
fixupWithTypeSpec _ _ = Nothing
114+
112115
cardinalTypeSpec _ = mempty
113116

114117
toPreds t (TreeSpec mal msz rs s) =

‎src/Constrained/TheKnot.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -136,6 +136,9 @@ instance (HasSpec a, HasSpec b) => HasSpec (Prod a b) where
136136
[Prod a' b | a' <- shrinkWithSpec sa a]
137137
++ [Prod a b' | b' <- shrinkWithSpec sb b]
138138

139+
fixupWithTypeSpec (Cartesian sa sb) (Prod a b) =
140+
Prod <$> fixupWithSpec sa a <*> fixupWithSpec sb b
141+
139142
toPreds x (Cartesian sf ss) =
140143
satisfies (prodFst_ x) sf
141144
<> satisfies (prodSnd_ x) ss

‎test/Constrained/Tests.hs‎

Lines changed: 10 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -66,8 +66,7 @@ tests nightly =
6666
testSpec "mapElemSpec" mapElemSpec
6767
testSpec "complicatedEither" complicatedEither
6868
testSpec "pairCant" pairCant
69-
-- TODO: figure out why this doesn't shrink
70-
testSpecNoShrink "reifiesMultiple" reifiesMultiple
69+
testSpec "reifiesMultiple" reifiesMultiple
7170
testSpec "assertReal" assertReal
7271
testSpecNoShrink "chooseBackwards" chooseBackwards
7372
testSpecNoShrink "chooseBackwards'" chooseBackwards'
@@ -85,15 +84,13 @@ tests nightly =
8584
testSpecNoShrink "eitherSetSpec" eitherSetSpec
8685
testSpec "fooSpec" fooSpec
8786
testSpec "mapElemKeySpec" mapElemKeySpec
88-
-- TODO: figure out why this doesn't shrink
89-
testSpecNoShrink "mapIsJust" mapIsJust
87+
testSpec "mapIsJust" mapIsJust
88+
-- NOTE: very slow to check in shrinking
9089
testSpecNoShrink "eitherKeys" eitherKeys
91-
-- TODO: figure out why this doesn't shrink
92-
testSpecNoShrink "intSpec" intSpec
90+
testSpec "intSpec" intSpec
9391
testSpec "mapPairSpec" mapPairSpec
94-
-- TODO: figure out why this doesn't shrink
9592
testSpecNoShrink "mapEmptyDomainSpec" mapEmptyDomainSpec
96-
-- TODO: this _can_ be shrunk, but it's incredibly expensive to do
93+
-- NOTE: this _can_ be shrunk, but it's incredibly expensive to do
9794
-- so and it's not obvious if there is a faster way without implementing
9895
-- more detailed shrinking of `SuspendedSpec`s
9996
testSpecNoShrink "setPairSpec" setPairSpec
@@ -105,24 +102,21 @@ tests nightly =
105102
testSpec "eitherSimpleSetSpec" eitherSimpleSetSpec
106103
testSpecNoShrink "emptySetSpec" emptySetSpec
107104
testSpec "forAllAnySpec" forAllAnySpec
108-
testSpecNoShrink "notSubsetSpec" notSubsetSpec
105+
testSpec "notSubsetSpec" notSubsetSpec
109106
testSpec "maybeJustSetSpec" maybeJustSetSpec
110107
testSpec "weirdSetPairSpec" weirdSetPairSpec
111108
testSpec "knownDomainMap" knownDomainMap
112-
-- TODO: figure out why this doesn't shrink
113-
testSpecNoShrink "testRewriteSpec" testRewriteSpec
109+
testSpec "testRewriteSpec" testRewriteSpec
114110
testSpec "parallelLet" parallelLet
115111
testSpec "letExists" letExists
116112
testSpec "letExistsLet" letExistsLet
117113
testSpec "notSubset" notSubset
118114
testSpec "unionSized" unionSized
119-
-- TODO: figure out why this doesn't shrink
120-
testSpecNoShrink "dependencyWeirdness" dependencyWeirdness
115+
testSpec "dependencyWeirdness" dependencyWeirdness
121116
testSpec "foldTrueCases" foldTrueCases
122117
testSpec "foldSingleCase" foldSingleCase
123118
testSpec "listSumPair" (listSumPair @Int)
124-
-- TODO: figure out why this doesn't shrink
125-
testSpecNoShrink "parallelLetPair" parallelLetPair
119+
testSpec "parallelLetPair" parallelLetPair
126120
testSpec "mapSizeConstrained" mapSizeConstrained
127121
testSpec "isAllZeroTree" isAllZeroTree
128122
testSpec "noChildrenSameTree" noChildrenSameTree
@@ -144,8 +138,7 @@ tests nightly =
144138
testSpec "appendSize" appendSize
145139
testSpecNoShrink "appendSingleton" appendSingleton
146140
testSpec "singletonSubset" singletonSubset
147-
-- TODO: figure out why this doesn't shrink
148-
testSpecNoShrink "reifyYucky" reifyYucky
141+
testSpec "reifyYucky" reifyYucky
149142
testSpec "fixedRange" fixedRange
150143
testSpec "rangeHint" rangeHint
151144
testSpec "basicSpec" basicSpec

0 commit comments

Comments
 (0)