From 9cd1d2fe0173a157f3e7bed0d0db8dab721ff516 Mon Sep 17 00:00:00 2001 From: Maximilian Algehed Date: Tue, 21 Oct 2025 13:42:54 +0200 Subject: [PATCH 1/5] Find and save some shrinking code that got lost --- src/Constrained/Generation.hs | 65 +++++++++++++++++++++++++++++++++-- 1 file changed, 62 insertions(+), 3 deletions(-) diff --git a/src/Constrained/Generation.hs b/src/Constrained/Generation.hs index ddae694..5dc6f70 100644 --- a/src/Constrained/Generation.hs +++ b/src/Constrained/Generation.hs @@ -155,15 +155,70 @@ shrinkWithSpec (simplifySpec -> spec) a = filter (`conformsToSpec` spec) $ case ExplainSpec _ s -> shrinkWithSpec s a -- TODO: filter on can't if we have a known to be sound shrinker TypeSpec s _ -> shrinkWithTypeSpec s a - -- TODO: The better way of doing this is to compute the dependency graph, - -- shrink one variable at a time, and fixup the rest of the variables - SuspendedSpec {} -> shr a + SuspendedSpec x p -> shrinkFromPreds p x a MemberSpec {} -> shr a TrueSpec -> shr a ErrorSpec {} -> [] where shr = shrinkWithTypeSpec (emptySpec @a) +shrinkFromPreds :: HasSpec a => Pred -> Var a -> a -> [a] +shrinkFromPreds p + | Result plan <- prepareLinearization p = \x a -> listFromGE $ do + -- NOTE: we do this to e.g. guard against bad construction functions in Exists + xaGood <- checkPred (Env.singleton x a) p + unless xaGood $ + fatalError "Trying to shrink a bad value, don't do that!" + -- Get an `env` for the original value + initialEnv <- envFromPred (Env.singleton x a) p + return + [ a' + | -- Shrink the initialEnv + env' <- shrinkEnvFromPlan initialEnv plan + , -- Get the value of the constrained variable `x` in the shrunk env + Just a' <- [Env.lookup env' x] + , -- NOTE: this is necessary because it's possible that changing + -- a particular value in the env during shrinking might not result + -- in the value of `x` changing and there is no better way to know than + -- to do this. + a' /= a + ] + | otherwise = error "Bad pred" + +-- Start with a valid Env for the plan and try to shrink it +shrinkEnvFromPlan :: Env -> SolverPlan -> [Env] +shrinkEnvFromPlan initialEnv SolverPlan {..} = go mempty solverPlan + where + go :: Env -> [SolverStage] -> [Env] + go _ [] = [] -- In this case we decided to keep every variable the same so nothing to return + go env ((unsafeSubstStage env -> SolverStage {..}) : plan) = do + Just a <- [Env.lookup initialEnv stageVar] + -- Two cases: + -- - either we shrink this value and try to fixup every value later on in the plan or + [ fixedEnv + | a' <- shrinkWithSpec stageSpec a + , let env' = Env.extend stageVar a' env + , Just fixedEnv <- [fixupPlan env' plan] + ] + -- - we keep this value the way it is and try to shrink some later value + ++ go (Env.extend stageVar a env) plan + + -- Fix the rest of the plan given an environment `env` for the plan so far + fixupPlan :: Env -> [SolverStage] -> Maybe Env + fixupPlan env [] = pure env + fixupPlan env ((unsafeSubstStage env -> SolverStage {..}) : plan) = + case Env.lookup initialEnv stageVar >>= fixupWithSpec stageSpec of + Nothing -> Nothing + Just a -> fixupPlan (Env.extend stageVar a env) plan + +-- Try to fix a value w.r.t a specification +fixupWithSpec :: forall a. HasSpec a => Specification a -> a -> Maybe a +fixupWithSpec spec a + | a `conformsToSpec` spec = Just a + | otherwise = case spec of + MemberSpec (a' :| _) -> Just a' + _ -> listToMaybe $ filter (`conformsToSpec` spec) (shrinkWithSpec TrueSpec a) + -- Debugging -------------------------------------------------------------- -- | A version of `genFromSpecT` that runs in the IO monad. Good for debugging. @@ -197,6 +252,10 @@ prettyPlan (simplifySpec -> spec) -- ---------------------- Building a plan ----------------------------------- +unsafeSubstStage :: Env -> SolverStage -> SolverStage +unsafeSubstStage env (SolverStage y ps spec relevant) = + normalizeSolverStage $ SolverStage y (substPred env <$> ps) spec relevant + substStage :: HasSpec a => Set Name -> Var a -> a -> SolverStage -> SolverStage substStage rel' x val (SolverStage y ps spec relevant) = normalizeSolverStage $ SolverStage y (substPred env <$> ps) spec relevant' From a0c3ee743933ffe488bd236fb81226aaca36417a Mon Sep 17 00:00:00 2001 From: Maximilian Algehed Date: Tue, 21 Oct 2025 14:27:11 +0200 Subject: [PATCH 2/5] Fix shrinking --- examples/Constrained/Examples/BinTree.hs | 2 ++ src/Constrained/Base.hs | 12 +++++++++++ src/Constrained/Generation.hs | 7 +++++- src/Constrained/NumOrd.hs | 20 ++++++++++++++++++ src/Constrained/Spec/List.hs | 3 +++ src/Constrained/Spec/Map.hs | 2 ++ src/Constrained/Spec/Set.hs | 3 +++ src/Constrained/Spec/Tree.hs | 3 +++ src/Constrained/TheKnot.hs | 3 +++ test/Constrained/Tests.hs | 27 +++++++++--------------- 10 files changed, 64 insertions(+), 18 deletions(-) diff --git a/examples/Constrained/Examples/BinTree.hs b/examples/Constrained/Examples/BinTree.hs index dd1bf05..cba6a7b 100644 --- a/examples/Constrained/Examples/BinTree.hs +++ b/examples/Constrained/Examples/BinTree.hs @@ -76,6 +76,8 @@ instance HasSpec a => HasSpec (BinTree a) where : (BinNode left a <$> shrinkWithTypeSpec s right) ++ ((\l -> BinNode l a right) <$> shrinkWithTypeSpec s left) + fixupWithTypeSpec _ _ = Nothing + cardinalTypeSpec _ = mempty toPreds t (BinTreeSpec msz s) = diff --git a/src/Constrained/Base.hs b/src/Constrained/Base.hs index f3fac96..737ec14 100644 --- a/src/Constrained/Base.hs +++ b/src/Constrained/Base.hs @@ -492,6 +492,9 @@ class -- | Shrink an `a` with the aide of a `TypeSpec` shrinkWithTypeSpec :: TypeSpec a -> a -> [a] + -- | Try to make an `a` conform to `TypeSpec` with minimal changes + fixupWithTypeSpec :: TypeSpec a -> a -> Maybe a + -- | Convert a spec to predicates: -- The key property here is: -- ∀ a. a `conformsTo` spec == a `conformsTo` constrained (\t -> toPreds t spec) @@ -608,6 +611,13 @@ class [a] shrinkWithTypeSpec spec a = map fromSimpleRep $ shrinkWithTypeSpec spec (toSimpleRep a) + default fixupWithTypeSpec :: + GenericallyInstantiated a => + TypeSpec a -> + a -> + Maybe a + fixupWithTypeSpec spec a = fromSimpleRep <$> fixupWithTypeSpec spec (toSimpleRep a) + default cardinalTypeSpec :: GenericallyInstantiated a => TypeSpec a -> @@ -628,6 +638,7 @@ instance HasSpec Bool where cardinalTypeSpec _ = equalSpec 2 cardinalTrueSpec = equalSpec 2 shrinkWithTypeSpec _ = shrink + fixupWithTypeSpec _ = Just conformsTo _ _ = True toPreds _ _ = TruePred @@ -637,6 +648,7 @@ instance HasSpec () where combineSpec _ _ = typeSpec () _ `conformsTo` _ = True shrinkWithTypeSpec _ _ = [] + fixupWithTypeSpec _ _ = pure () genFromTypeSpec _ = pure () toPreds _ _ = TruePred cardinalTypeSpec _ = MemberSpec (pure 1) diff --git a/src/Constrained/Generation.hs b/src/Constrained/Generation.hs index 5dc6f70..df0a72d 100644 --- a/src/Constrained/Generation.hs +++ b/src/Constrained/Generation.hs @@ -25,6 +25,7 @@ module Constrained.Generation ( genFromSpecT, genFromSpecWithSeed, shrinkWithSpec, + fixupWithSpec, simplifySpec, -- ** Debugging @@ -207,7 +208,7 @@ shrinkEnvFromPlan initialEnv SolverPlan {..} = go mempty solverPlan fixupPlan :: Env -> [SolverStage] -> Maybe Env fixupPlan env [] = pure env fixupPlan env ((unsafeSubstStage env -> SolverStage {..}) : plan) = - case Env.lookup initialEnv stageVar >>= fixupWithSpec stageSpec of + case Env.lookup (env <> initialEnv) stageVar >>= fixupWithSpec stageSpec of Nothing -> Nothing Just a -> fixupPlan (Env.extend stageVar a env) plan @@ -217,6 +218,7 @@ fixupWithSpec spec a | a `conformsToSpec` spec = Just a | otherwise = case spec of MemberSpec (a' :| _) -> Just a' + TypeSpec ts _ -> fixupWithTypeSpec ts a >>= \ a' -> a' <$ guard (conformsToSpec a' spec) _ -> listToMaybe $ filter (`conformsToSpec` spec) (shrinkWithSpec TrueSpec a) -- Debugging -------------------------------------------------------------- @@ -1164,6 +1166,9 @@ instance (HasSpec a, HasSpec b, KnownNat (CountCases b)) => HasSpec (Sum a b) wh shrinkWithTypeSpec (SumSpec _ sa _) (SumLeft a) = SumLeft <$> shrinkWithSpec sa a shrinkWithTypeSpec (SumSpec _ _ sb) (SumRight b) = SumRight <$> shrinkWithSpec sb b + fixupWithTypeSpec (SumSpec _ sa _) (SumLeft a) = SumLeft <$> fixupWithSpec sa a + fixupWithTypeSpec (SumSpec _ _ sb) (SumRight b) = SumRight <$> fixupWithSpec sb b + toPreds ct (SumSpec h sa sb) = Case ct diff --git a/src/Constrained/NumOrd.hs b/src/Constrained/NumOrd.hs index 021f809..4f61174 100644 --- a/src/Constrained/NumOrd.hs +++ b/src/Constrained/NumOrd.hs @@ -39,6 +39,7 @@ module Constrained.NumOrd ( combineNumSpec, genFromNumSpec, shrinkWithNumSpec, + fixupWithTypeSpec, conformsToNumSpec, toPredsNumSpec, OrdLike (..), @@ -320,6 +321,11 @@ genFromNumSpec (NumSpecInterval ml mu) = do shrinkWithNumSpec :: Arbitrary n => NumSpec n -> n -> [n] shrinkWithNumSpec _ = shrink +-- TODO: fixme + +fixupWithNumSpec :: Arbitrary n => NumSpec n -> n -> Maybe n +fixupWithNumSpec _ = listToMaybe . shrink + constrainInterval :: (MonadGenError m, Ord a, Num a, Show a) => Maybe a -> Maybe a -> Integer -> m (a, a) constrainInterval ml mu r = @@ -1073,6 +1079,7 @@ instance HasSpec Integer where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1084,6 +1091,7 @@ instance HasSpec Int where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1095,6 +1103,7 @@ instance HasSpec (Ratio Integer) where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec _ = TrueSpec @@ -1106,6 +1115,7 @@ instance HasSpec Natural where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec (NumSpecInterval (fromMaybe 0 -> lo) (Just hi)) = @@ -1121,6 +1131,7 @@ instance HasSpec Word8 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1134,6 +1145,7 @@ instance HasSpec Word16 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1146,6 +1158,7 @@ instance HasSpec Word32 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1157,6 +1170,7 @@ instance HasSpec Word64 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1168,6 +1182,7 @@ instance HasSpec Int8 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTrueSpec = equalSpec 256 @@ -1180,6 +1195,7 @@ instance HasSpec Int16 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1192,6 +1208,7 @@ instance HasSpec Int32 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1203,6 +1220,7 @@ instance HasSpec Int64 where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec = cardinalNumSpec @@ -1214,6 +1232,7 @@ instance HasSpec Float where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec _ = TrueSpec @@ -1225,6 +1244,7 @@ instance HasSpec Double where combineSpec = combineNumSpec genFromTypeSpec = genFromNumSpec shrinkWithTypeSpec = shrinkWithNumSpec + fixupWithTypeSpec = fixupWithNumSpec conformsTo = conformsToNumSpec toPreds = toPredsNumSpec cardinalTypeSpec _ = TrueSpec diff --git a/src/Constrained/Spec/List.hs b/src/Constrained/Spec/List.hs index 381a24f..6d246c3 100644 --- a/src/Constrained/Spec/List.hs +++ b/src/Constrained/Spec/List.hs @@ -244,6 +244,9 @@ instance HasSpec a => HasSpec [a] where shrinkWithTypeSpec (ListSpec _ _ _ es _) as = shrinkList (shrinkWithSpec es) as + -- TODO: fixme + fixupWithTypeSpec _ _ = Nothing + cardinalTypeSpec _ = TrueSpec guardTypeSpec = guardListSpec diff --git a/src/Constrained/Spec/Map.hs b/src/Constrained/Spec/Map.hs index 5edbc24..266a880 100644 --- a/src/Constrained/Spec/Map.hs +++ b/src/Constrained/Spec/Map.hs @@ -278,6 +278,8 @@ instance shrinkWithTypeSpec (MapSpec _ _ _ _ kvs _) m = map Map.fromList $ shrinkList (shrinkWithSpec kvs) (Map.toList m) + fixupWithTypeSpec _ _ = Nothing + toPreds m (MapSpec mHint mustKeys mustVals size kvs foldSpec) = toPred [ Assert $ Lit mustKeys `subset_` dom_ m diff --git a/src/Constrained/Spec/Set.hs b/src/Constrained/Spec/Set.hs index 28dfc84..8073a4e 100644 --- a/src/Constrained/Spec/Set.hs +++ b/src/Constrained/Spec/Set.hs @@ -204,6 +204,9 @@ instance (Ord a, HasSpec a) => HasSpec (Set a) where shrinkWithTypeSpec (SetSpec _ es _) as = map Set.fromList $ shrinkList (shrinkWithSpec es) (Set.toList as) + -- TODO: fixme + fixupWithTypeSpec _ _ = Nothing + toPreds s (SetSpec m es size) = fold $ -- Don't include this if the must set is empty diff --git a/src/Constrained/Spec/Tree.hs b/src/Constrained/Spec/Tree.hs index 09edd1a..494e883 100644 --- a/src/Constrained/Spec/Tree.hs +++ b/src/Constrained/Spec/Tree.hs @@ -109,6 +109,9 @@ instance HasSpec a => HasSpec (Tree a) where | ts' <- shrinkList (shrinkWithTypeSpec (TreeSpec Nothing Nothing TrueSpec ctxSpec)) ts ] + -- TODO: fixme + fixupWithTypeSpec _ _ = Nothing + cardinalTypeSpec _ = mempty toPreds t (TreeSpec mal msz rs s) = diff --git a/src/Constrained/TheKnot.hs b/src/Constrained/TheKnot.hs index e8a6c4f..b4d88d7 100644 --- a/src/Constrained/TheKnot.hs +++ b/src/Constrained/TheKnot.hs @@ -136,6 +136,9 @@ instance (HasSpec a, HasSpec b) => HasSpec (Prod a b) where [Prod a' b | a' <- shrinkWithSpec sa a] ++ [Prod a b' | b' <- shrinkWithSpec sb b] + fixupWithTypeSpec (Cartesian sa sb) (Prod a b) = + Prod <$> fixupWithSpec sa a <*> fixupWithSpec sb b + toPreds x (Cartesian sf ss) = satisfies (prodFst_ x) sf <> satisfies (prodSnd_ x) ss diff --git a/test/Constrained/Tests.hs b/test/Constrained/Tests.hs index 52f9217..87a6bc1 100644 --- a/test/Constrained/Tests.hs +++ b/test/Constrained/Tests.hs @@ -66,8 +66,7 @@ tests nightly = testSpec "mapElemSpec" mapElemSpec testSpec "complicatedEither" complicatedEither testSpec "pairCant" pairCant - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "reifiesMultiple" reifiesMultiple + testSpec "reifiesMultiple" reifiesMultiple testSpec "assertReal" assertReal testSpecNoShrink "chooseBackwards" chooseBackwards testSpecNoShrink "chooseBackwards'" chooseBackwards' @@ -85,15 +84,13 @@ tests nightly = testSpecNoShrink "eitherSetSpec" eitherSetSpec testSpec "fooSpec" fooSpec testSpec "mapElemKeySpec" mapElemKeySpec - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "mapIsJust" mapIsJust + testSpec "mapIsJust" mapIsJust + -- NOTE: very slow to check in shrinking testSpecNoShrink "eitherKeys" eitherKeys - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "intSpec" intSpec + testSpec "intSpec" intSpec testSpec "mapPairSpec" mapPairSpec - -- TODO: figure out why this doesn't shrink testSpecNoShrink "mapEmptyDomainSpec" mapEmptyDomainSpec - -- TODO: this _can_ be shrunk, but it's incredibly expensive to do + -- NOTE: this _can_ be shrunk, but it's incredibly expensive to do -- so and it's not obvious if there is a faster way without implementing -- more detailed shrinking of `SuspendedSpec`s testSpecNoShrink "setPairSpec" setPairSpec @@ -105,24 +102,21 @@ tests nightly = testSpec "eitherSimpleSetSpec" eitherSimpleSetSpec testSpecNoShrink "emptySetSpec" emptySetSpec testSpec "forAllAnySpec" forAllAnySpec - testSpecNoShrink "notSubsetSpec" notSubsetSpec + testSpec "notSubsetSpec" notSubsetSpec testSpec "maybeJustSetSpec" maybeJustSetSpec testSpec "weirdSetPairSpec" weirdSetPairSpec testSpec "knownDomainMap" knownDomainMap - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "testRewriteSpec" testRewriteSpec + testSpec "testRewriteSpec" testRewriteSpec testSpec "parallelLet" parallelLet testSpec "letExists" letExists testSpec "letExistsLet" letExistsLet testSpec "notSubset" notSubset testSpec "unionSized" unionSized - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "dependencyWeirdness" dependencyWeirdness + testSpec "dependencyWeirdness" dependencyWeirdness testSpec "foldTrueCases" foldTrueCases testSpec "foldSingleCase" foldSingleCase testSpec "listSumPair" (listSumPair @Int) - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "parallelLetPair" parallelLetPair + testSpec "parallelLetPair" parallelLetPair testSpec "mapSizeConstrained" mapSizeConstrained testSpec "isAllZeroTree" isAllZeroTree testSpec "noChildrenSameTree" noChildrenSameTree @@ -144,8 +138,7 @@ tests nightly = testSpec "appendSize" appendSize testSpecNoShrink "appendSingleton" appendSingleton testSpec "singletonSubset" singletonSubset - -- TODO: figure out why this doesn't shrink - testSpecNoShrink "reifyYucky" reifyYucky + testSpec "reifyYucky" reifyYucky testSpec "fixedRange" fixedRange testSpec "rangeHint" rangeHint testSpec "basicSpec" basicSpec From 6305f29f457bcea5978645e13758345ffe6e3e55 Mon Sep 17 00:00:00 2001 From: Maximilian Algehed Date: Tue, 21 Oct 2025 14:39:32 +0200 Subject: [PATCH 3/5] even more shrinking --- src/Constrained/Generation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Constrained/Generation.hs b/src/Constrained/Generation.hs index df0a72d..7fafe50 100644 --- a/src/Constrained/Generation.hs +++ b/src/Constrained/Generation.hs @@ -156,7 +156,7 @@ shrinkWithSpec (simplifySpec -> spec) a = filter (`conformsToSpec` spec) $ case ExplainSpec _ s -> shrinkWithSpec s a -- TODO: filter on can't if we have a known to be sound shrinker TypeSpec s _ -> shrinkWithTypeSpec s a - SuspendedSpec x p -> shrinkFromPreds p x a + SuspendedSpec x p -> shrinkFromPreds p x a ++ shr a MemberSpec {} -> shr a TrueSpec -> shr a ErrorSpec {} -> [] From 622818366d8db52999e228c116043555de2ed9b8 Mon Sep 17 00:00:00 2001 From: Maximilian Algehed Date: Wed, 22 Oct 2025 10:54:10 +0200 Subject: [PATCH 4/5] fix --- src/Constrained/Conformance.hs | 1 + src/Constrained/Generation.hs | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Constrained/Conformance.hs b/src/Constrained/Conformance.hs index 5e53baa..3c38578 100644 --- a/src/Constrained/Conformance.hs +++ b/src/Constrained/Conformance.hs @@ -14,6 +14,7 @@ module Constrained.Conformance ( conformsToSpec, conformsToSpecE, satisfies, + checkPredE, checkPredsE, ) where diff --git a/src/Constrained/Generation.hs b/src/Constrained/Generation.hs index 7fafe50..75b54dd 100644 --- a/src/Constrained/Generation.hs +++ b/src/Constrained/Generation.hs @@ -167,9 +167,9 @@ shrinkFromPreds :: HasSpec a => Pred -> Var a -> a -> [a] shrinkFromPreds p | Result plan <- prepareLinearization p = \x a -> listFromGE $ do -- NOTE: we do this to e.g. guard against bad construction functions in Exists - xaGood <- checkPred (Env.singleton x a) p - unless xaGood $ - fatalError "Trying to shrink a bad value, don't do that!" + case checkPredE (Env.singleton x a) (NE.fromList []) p of + Nothing -> pure () + Just err -> explainNE err $ fatalError "Trying to shrink a bad value, don't do that!" -- Get an `env` for the original value initialEnv <- envFromPred (Env.singleton x a) p return From 7e6acbfbddb66aa421f70ef02bbb6db74433cbb8 Mon Sep 17 00:00:00 2001 From: Maximilian Algehed Date: Wed, 22 Oct 2025 12:24:19 +0200 Subject: [PATCH 5/5] Improve docs --- src/Constrained/Base.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Constrained/Base.hs b/src/Constrained/Base.hs index e7dbafb..74db146 100644 --- a/src/Constrained/Base.hs +++ b/src/Constrained/Base.hs @@ -488,7 +488,10 @@ class -- | Shrink an `a` with the aide of a `TypeSpec` shrinkWithTypeSpec :: TypeSpec a -> a -> [a] - -- | Try to make an `a` conform to `TypeSpec` with minimal changes + -- | Try to make an `a` conform to `TypeSpec` with minimal changes. When + -- `fixupWithSpec ts a` returns `Just a'`, it should be the case that + -- `conformsTo a' ts`. There are no constraints in the `Nothing` case. A + -- non-trivial implementation of this function is important for shrinking. fixupWithTypeSpec :: TypeSpec a -> a -> Maybe a -- | Convert a spec to predicates: