Skip to content

Commit ce9ef8b

Browse files
committed
fix: renable some slim check tests and make them pass (leanprover-community#9021)
Previously `addDecorations` was creating ill-typed expressions that in the presence of function types placed a `Type` where a `Prop` was expected. A few of the tests needed some minor fixes to make them pass.
1 parent b92d742 commit ce9ef8b

3 files changed

Lines changed: 191 additions & 175 deletions

File tree

Mathlib/Tactic/SlimCheck.lean

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -168,7 +168,7 @@ elab_rules : tactic | `(tactic| slim_check $[$cfg]?) => withMainContext do
168168
let cfg ← elabConfig (mkOptionalNode cfg)
169169
let (_, g) ← (← getMainGoal).revert ((← getLocalHyps).map (Expr.fvarId!))
170170
let tgt ← g.getType
171-
let tgt' := addDecorations tgt
171+
let tgt' addDecorations tgt
172172
let cfg := { cfg with
173173
traceDiscarded := cfg.traceDiscarded || (← isTracingEnabledFor `slim_check.discarded),
174174
traceSuccesses := cfg.traceSuccesses || (← isTracingEnabledFor `slim_check.success),

Mathlib/Testing/SlimCheck/Testable.lean

Lines changed: 25 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -388,6 +388,20 @@ where
388388
let finalR := addInfo s!"{var} is irrelevant (unused)" id r
389389
pure $ imp (· $ Classical.ofNonempty) finalR (PSum.inr $ λ x _ => x)
390390

391+
instance (priority := 2000) subtypeVarTestable {p : α → Prop} {β : α → Prop}
392+
[∀ x, PrintableProp (p x)]
393+
[∀ x, Testable (β x)]
394+
[SampleableExt (Subtype p)] {var'} :
395+
Testable (NamedBinder var $ Π x : α, NamedBinder var' $ p x → β x) where
396+
run cfg min :=
397+
letI (x : Subtype p) : Testable (β x) :=
398+
{ run := fun cfg min => do
399+
let r ← Testable.runProp (β x.val) cfg min
400+
pure $ addInfo s!"guard: {printProp (p x)} (by construction)" id r (PSum.inr id) }
401+
do
402+
let r ← @Testable.run (∀ x : Subtype p, β x.val) (@varTestable var _ _ _ _) cfg min
403+
pure $ iff Subtype.forall' r
404+
391405
instance (priority := low) decidableTestable {p : Prop} [PrintableProp p] [Decidable p] :
392406
Testable p where
393407
run := λ _ _ =>
@@ -493,16 +507,18 @@ open Lean
493507

494508
/-- Traverse the syntax of a proposition to find universal quantifiers
495509
quantifiers and add `NamedBinder` annotations next to them. -/
496-
partial def addDecorations (e : Expr) : Expr :=
497-
e.replace $ λ expr =>
498-
match expr with
499-
| Expr.forallE name type body data =>
510+
partial def addDecorations (e : Expr) : MetaM Expr :=
511+
Meta.transform e $ fun expr => do
512+
if not (← Meta.inferType e).isProp then
513+
return .continue
514+
else if let Expr.forallE name type body data := expr then
500515
let n := name.toString
501-
let newType := addDecorations type
502-
let newBody := addDecorations body
516+
let newType addDecorations type
517+
let newBody addDecorations body
503518
let rest := Expr.forallE name newType newBody data
504-
some $ mkApp2 (mkConst `SlimCheck.NamedBinder) (mkStrLit n) rest
505-
| _ => none
519+
return .done $ (← Meta.mkAppM `SlimCheck.NamedBinder #[mkStrLit n, rest])
520+
else
521+
return .continue
506522

507523
/-- `DecorationsOf p` is used as a hint to `mk_decorations` to specify
508524
that the goal should be satisfied with a proposition equivalent to `p`
@@ -527,7 +543,7 @@ scoped elab "mk_decorations" : tactic => do
527543
let goal ← getMainGoal
528544
let goalType ← goal.getType
529545
if let .app (.const ``Decorations.DecorationsOf _) body := goalType then
530-
closeMainGoal (addDecorations body)
546+
closeMainGoal (addDecorations body)
531547

532548
end Decorations
533549

0 commit comments

Comments
 (0)