refactor: some Meta.Match.Match refactorings (#11011)

This PR extracts some refactorings from #10763, including dropping dead
code and not failing in `inaccessibleAsCtor`, which leadas to (slightly)
better error messages, and also on the grounds that the failing
alternative may actually be unreachable.
This commit is contained in:
Joachim Breitner 2025-10-29 19:24:57 -04:00 committed by GitHub
parent d3c9056d2b
commit e2f5938e74
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
8 changed files with 651 additions and 468 deletions

View file

@ -195,59 +195,6 @@ def replaceFVarId (fvarId : FVarId) (v : Expr) (alt : Alt) : Alt :=
def isLocalDecl (fvarId : FVarId) (alt : Alt) : Bool :=
alt.fvarDecls.any fun d => d.fvarId == fvarId
/--
Similar to `checkAndReplaceFVarId`, but ensures type of `v` is definitionally equal to type of `fvarId`.
This extra check is necessary when performing dependent elimination and inaccessible terms have been used.
For example, consider the following code fragment:
```
inductive Vec (α : Type u) : Nat → Type u where
| nil : Vec α 0
| cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)
inductive VecPred {α : Type u} (P : α → Prop) : {n : Nat} → Vec α n → Prop where
| nil : VecPred P Vec.nil
| cons {n : Nat} {head : α} {tail : Vec α n} : P head → VecPred P tail → VecPred P (Vec.cons head tail)
theorem ex {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
| _, Vec.cons head _, VecPred.cons h (w : VecPred P Vec.nil) => ⟨head, h⟩
```
Recall that `_` in a pattern can be elaborated into pattern variable or an inaccessible term.
The elaborator uses an inaccessible term when typing constraints restrict its value.
Thus, in the example above, the `_` at `Vec.cons head _` becomes the inaccessible pattern `.(Vec.nil)`
because the type ascription `(w : VecPred P Vec.nil)` propagates typing constraints that restrict its value to be `Vec.nil`.
After elaboration the alternative becomes:
```
| .(0), @Vec.cons .(α) .(0) head .(Vec.nil), @VecPred.cons .(α) .(P) .(0) .(head) .(Vec.nil) h w => ⟨head, h⟩
```
where
```
(head : α), (h: P head), (w : VecPred P Vec.nil)
```
Then, when we process this alternative in this module, the following check will detect that
`w` has type `VecPred P Vec.nil`, when it is supposed to have type `VecPred P tail`.
Note that if we had written
```
theorem ex {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
| _, Vec.cons head Vec.nil, VecPred.cons h (w : VecPred P Vec.nil) => ⟨head, h⟩
```
we would get the easier to digest error message
```
missing cases:
_, (Vec.cons _ _ (Vec.cons _ _ _)), _
```
-/
def checkAndReplaceFVarId (fvarId : FVarId) (v : Expr) (alt : Alt) : MetaM Alt := do
match alt.fvarDecls.find? fun (fvarDecl : LocalDecl) => fvarDecl.fvarId == fvarId with
| none => throwErrorAt alt.ref "Unknown free pattern variable"
| some fvarDecl => do
let vType ← inferType v
unless (← isDefEqGuarded fvarDecl.type vType) do
withExistingLocalDecls alt.fvarDecls do
let (expectedType, givenType) ← addPPExplicitToExposeDiff vType fvarDecl.type
throwErrorAt alt.ref "Type mismatch during dependent match-elimination at pattern variable `{mkFVar fvarDecl.fvarId}` with type{indentExpr givenType}\nExpected type{indentExpr expectedType}"
return replaceFVarId fvarId v alt
end Alt
inductive Example where

View file

@ -159,13 +159,32 @@ private def isVariableTransition (p : Problem) : Bool :=
| .var _ :: _ => true
| _ => false
private def isConstructorTransition (p : Problem) : Bool :=
(hasCtorPattern p || p.alts.isEmpty)
&& p.alts.all fun alt => match alt.patterns with
| .ctor .. :: _ => true
| .var _ :: _ => true
| .inaccessible _ :: _ => true
| _ => false
private def getInductiveVal? (x : Expr) : MetaM (Option InductiveVal) := do
let xType ← inferType x
let xType ← whnfD xType
match xType.getAppFn with
| Expr.const constName _ =>
let cinfo ← getConstInfo constName
match cinfo with
| ConstantInfo.inductInfo val => return some val
| _ => return none
| _ => return none
def isCurrVarInductive (p : Problem) : MetaM Bool := do
match p.vars with
| [] => return false
| x::_ => withGoalOf p do
let val? ← getInductiveVal? x
return val?.isSome
private def isConstructorTransition (p : Problem) : MetaM Bool := do
return (← isCurrVarInductive p)
&& (hasCtorPattern p || p.alts.isEmpty)
&& p.alts.all fun alt => match alt.patterns with
| .ctor .. :: _ => true
| .var _ :: _ => true
| .inaccessible _ :: _ => true
| _ => false
private def isValueTransition (p : Problem) : Bool :=
hasVarPattern p && hasValPattern p
@ -204,8 +223,7 @@ private def hasCtorOrInaccessible (p : Problem) : Bool :=
| _ => false
private def isNatValueTransition (p : Problem) : MetaM Bool := do
unless (← hasNatValPattern p) do return false
return hasCtorOrInaccessible p
return (← hasNatValPattern p) && hasCtorOrInaccessible p
/--
Predicate for testing whether we need to expand `Int` value patterns into constructors.
@ -249,6 +267,10 @@ private def reorientCnstrs (alt : Alt) : Alt :=
/--
Remove constraints of the form `lhs ≋ rhs` where `lhs` and `rhs` are definitionally equal,
or `lhs` is a free variable.
Dropping unsolved constraints where `lhs` is a free variable seems unsound, but simply leads to later
errors about the type of the alternative not matching the goal type, which is arguably a bit more
user-friendly than showing possibly match-compilation-internal variable names.
-/
private def filterTrivialCnstrs (alt : Alt) : MetaM Alt := do
let cnstrs ← withExistingLocalDecls alt.fvarDecls do
@ -334,8 +356,9 @@ private def processAsPattern (p : Problem) : MetaM Problem := withGoalOf p do
let alts ← p.alts.mapM fun alt => do
match alt.patterns with
| .as fvarId p h :: ps =>
/- We used to use `checkAndReplaceFVarId` here, but `x` and `fvarId` may have different types
when dependent types are being used. Let's consider the repro for issue #471
/- We used to use eagerly check the types here (using what was called `checkAndReplaceFVarId`),
but `x` and `fvarId` can have different types when dependent types are being used.
Let's consider the repro for issue #471
```
inductive vec : Nat → Type
| nil : vec 0
@ -409,11 +432,11 @@ alternative `cnstrs` field.
private def inLocalDecls (localDecls : List LocalDecl) (fvarId : FVarId) : Bool :=
localDecls.any fun d => d.fvarId == fvarId
private def expandVarIntoCtor? (alt : Alt) (ctorName : Name) : MetaM Alt := do
private def expandVarIntoCtor (alt : Alt) (ctorName : Name) : MetaM Alt := do
let .var fvarId :: ps := alt.patterns | unreachable!
let alt := { alt with patterns := ps}
withExistingLocalDecls alt.fvarDecls do
trace[Meta.Match.unify] "expandVarIntoCtor? fvarId: {mkFVar fvarId}, ctorName: {ctorName}, alt:\n{← alt.toMessageData}"
trace[Meta.Match.unify] "expandVarIntoCtor fvarId: {mkFVar fvarId}, ctorName: {ctorName}, alt:\n{← alt.toMessageData}"
let expectedType ← inferType (mkFVar fvarId)
let expectedType ← whnfD expectedType
let (ctorLevels, ctorParams) ← getInductiveUniverseAndParams expectedType
@ -427,7 +450,7 @@ private def expandVarIntoCtor? (alt : Alt) (ctorName : Name) : MetaM Alt := do
let mut cnstrs := alt.cnstrs
unless (← isDefEqGuarded resultType expectedType) do
cnstrs := (resultType, expectedType) :: cnstrs
trace[Meta.Match.unify] "expandVarIntoCtor? {mkFVar fvarId} : {expectedType}, ctor: {ctor}"
trace[Meta.Match.unify] "expandVarIntoCtor {mkFVar fvarId} : {expectedType}, ctor: {ctor}"
let ctorFieldPatterns := ctorFieldDecls.toList.map fun decl => Pattern.var decl.fvarId
return { alt with fvarDecls := newAltDecls, patterns := ctorFieldPatterns ++ alt.patterns, cnstrs }
@ -443,17 +466,6 @@ private def expandInaccessibleIntoVar (alt : Alt) : MetaM Alt := do
cnstrs := (x, e) :: alt.cnstrs
}
private def getInductiveVal? (x : Expr) : MetaM (Option InductiveVal) := do
let xType ← inferType x
let xType ← whnfD xType
match xType.getAppFn with
| Expr.const constName _ =>
let cinfo ← getConstInfo constName
match cinfo with
| ConstantInfo.inductInfo val => return some val
| _ => return none
| _ => return none
private def hasRecursiveType (x : Expr) : MetaM Bool := do
match (← getInductiveVal? x) with
| some val => return val.isRec
@ -461,28 +473,24 @@ private def hasRecursiveType (x : Expr) : MetaM Bool := do
/-- Given `alt` s.t. the next pattern is an inaccessible pattern `e`,
try to normalize `e` into a constructor application.
If it is not a constructor, throw an error.
Otherwise, if it is a constructor application of `ctorName`,
If it is a constructor application of `ctorName`,
update the next patterns with the fields of the constructor.
Otherwise, move it to contraints, so that we fail unless some later step
eliminates this alternative.
-/
def processInaccessibleAsCtor (alt : Alt) (ctorName : Name) : MetaM Alt := do
let p@(.inaccessible e) :: ps := alt.patterns | unreachable!
trace[Meta.Match.match] "inaccessible in ctor step {e}"
let .inaccessible e :: ps := alt.patterns | unreachable!
trace[Meta.Match.match] "inaccessible step {e} as ctor {ctorName}"
withExistingLocalDecls alt.fvarDecls do
-- Try to push inaccessible annotations.
let e ← whnfD e
match (← constructorApp? e) with
| some (ctorVal, ctorArgs) =>
if let some (ctorVal, ctorArgs) ← constructorApp? e then
if ctorVal.name == ctorName then
let fields := ctorArgs.extract ctorVal.numParams ctorArgs.size
let fields := fields.toList.map .inaccessible
return { alt with patterns := fields ++ ps }
else
let alt' ← expandInaccessibleIntoVar alt
expandVarIntoCtor? alt' ctorName
| _ => throwErrorAt alt.ref "Dependent match elimination failed: Expected a constructor, but found the inaccessible pattern{indentD p.toMessageData}"
let alt' ← expandInaccessibleIntoVar alt
expandVarIntoCtor alt' ctorName
private def hasNonTrivialExample (p : Problem) : Bool :=
p.examples.any fun | Example.underscore => false | _ => true
@ -546,7 +554,7 @@ private def processConstructor (p : Problem) : MetaM (Array Problem) := do
let newAlts ← newAlts.mapM fun alt => do
match alt.patterns with
| .ctor _ _ _ fields :: ps => return { alt with patterns := fields ++ ps }
| .var _ :: _ => expandVarIntoCtor? alt subgoal.ctorName
| .var _ :: _ => expandVarIntoCtor alt subgoal.ctorName
| .inaccessible _ :: _ => processInaccessibleAsCtor alt subgoal.ctorName
| _ => unreachable!
return { mvarId := subgoal.mvarId, vars := newVars, alts := newAlts, examples := examples }
@ -563,7 +571,7 @@ private def processNonVariable (p : Problem) : MetaM Problem := withGoalOf p do
else
return some { alt with patterns := fields ++ ps }
| .inaccessible _ :: _ => processInaccessibleAsCtor alt ctorVal.name
| .var _ :: _ => expandVarIntoCtor? alt ctorVal.name
| .var _ :: _ => expandVarIntoCtor alt ctorVal.name
| _ => unreachable!
let xFields := xArgs.extract ctorVal.numParams xArgs.size
return { p with alts := alts, vars := xFields.toList ++ xs }
@ -724,13 +732,6 @@ private def throwNonSupported (p : Problem) : MetaM Unit :=
let msg ← p.toMessageData
throwError "Failed to compile pattern matching: Stuck at{indentD msg}"
def isCurrVarInductive (p : Problem) : MetaM Bool := do
match p.vars with
| [] => return false
| x::_ => withGoalOf p do
let val? ← getInductiveVal? x
return val?.isSome
private def checkNextPatternTypes (p : Problem) : MetaM Unit := do
match p.vars with
| [] => return ()
@ -760,55 +761,79 @@ def processExFalso (p : Problem) : MetaM Problem := do
private partial def process (p : Problem) : StateRefT State MetaM Unit := do
traceState p
let isInductive ← isCurrVarInductive p
if isDone p then
traceStep ("leaf")
processLeaf p
else if (← isExFalsoTransition p) then
return
if (← isExFalsoTransition p) then
traceStep ("ex falso")
let p ← processExFalso p
process p
else if hasAsPattern p then
return
if hasAsPattern p then
traceStep ("as-pattern")
let p ← processAsPattern p
process p
else if (← isNatValueTransition p) then
return
if (← isNatValueTransition p) then
traceStep ("nat value to constructor")
process (← expandNatValuePattern p)
else if (← isIntValueTransition p) then
return
if (← isIntValueTransition p) then
traceStep ("int value to constructor")
process (← expandIntValuePattern p)
else if (← isFinValueTransition p) then
return
if (← isFinValueTransition p) then
traceStep ("fin value to constructor")
process (← expandFinValuePattern p)
else if (← isBitVecValueTransition p) then
return
if (← isBitVecValueTransition p) then
traceStep ("bitvec value to constructor")
process (← expandBitVecValuePattern p)
else if !isNextVar p then
return
if !isNextVar p then
traceStep ("non variable")
let p ← processNonVariable p
process p
else if isInductive && isConstructorTransition p then
return
if (← isConstructorTransition p) then
let ps ← processConstructor p
ps.forM process
else if isVariableTransition p then
return
if isVariableTransition p then
traceStep ("variable")
let p ← processVariable p
process p
else if isValueTransition p then
return
if isValueTransition p then
let ps ← processValue p
ps.forM process
else if isArrayLitTransition p then
return
if isArrayLitTransition p then
let ps ← processArrayLit p
ps.forM process
else if (← hasNatValPattern p) then
return
if (← hasNatValPattern p) then
-- This branch is reachable when `p`, for example, is just values without an else-alternative.
-- We added it just to get better error messages.
traceStep ("nat value to constructor")
process (← expandNatValuePattern p)
else
checkNextPatternTypes p
throwNonSupported p
return
checkNextPatternTypes p
throwNonSupported p
private def getUElimPos? (matcherLevels : List Level) (uElim : Level) : MetaM (Option Nat) :=
if uElim == levelZero then

View file

@ -1,164 +0,0 @@
--
#print "---- h1"
def h1 (b : Bool) : Nat :=
match b with
| true => 0
| false => 10
#eval h1 false
#print "---- h2"
def h2 (x : List Nat) : Nat :=
match x with
| [x1, x2] => x1 + x2
| x::xs => x
| _ => 0
#eval h2 [1, 2]
#eval h2 [10, 4, 5]
#eval h2 []
#print "---- h3"
def h3 (x : Array Nat) : Nat :=
match x with
| #[x] => x
| #[x, y] => x + y
| xs => xs.size
#eval h3 #[10]
#eval h3 #[10, 20]
#eval h3 #[10, 20, 30, 40]
#print "---- inv"
inductive Image {α β : Type} (f : α → β) : β → Type
| mk (a : α) : Image f (f a)
def mkImage {α β : Type} (f : α → β) (a : α) : Image f (f a) :=
Image.mk a
def inv {α β : Type} {f : α → β} {b : β} (t : Image f b) : α :=
match b, t with
| _, Image.mk a => a
#eval inv (mkImage Nat.succ 10)
theorem foo {p q} (h : p q) : q p :=
match h with
| Or.inl h => Or.inr h
| Or.inr h => Or.inl h
def f (x : Nat × Nat) : Bool × Bool × Bool → Nat :=
match x with
| (a, b) => fun _ => a
structure S :=
(x y z : Nat := 0)
def f1 : S → S :=
fun { x := x, ..} => { y := x }
theorem ex2 : f1 { x := 10 } = { y := 10 } :=
rfl
universe u
inductive Vec (α : Type u) : Nat → Type u
| nil : Vec α 0
| cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)
inductive VecPred {α : Type u} (P : α → Prop) : {n : Nat} → Vec α n → Prop
| nil : VecPred P Vec.nil
| cons {n : Nat} {head : α} {tail : Vec α n} : P head → VecPred P tail → VecPred P (Vec.cons head tail)
theorem ex3 {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
| _, Vec.cons head _, VecPred.cons h _ => ⟨head, h⟩
theorem ex4 {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
| _, Vec.cons head _, VecPred.cons h (w : VecPred P Vec.nil) => ⟨head, h⟩ -- ERROR
axiom someNat : Nat
noncomputable def f2 (x : Nat) := -- must mark as noncomputable since it uses axiom `someNat`
x + someNat
inductive Parity : Nat -> Type
| even (n) : Parity (n + n)
| odd (n) : Parity (Nat.succ (n + n))
axiom nDiv2 (n : Nat) : n % 2 = 0 → n = n/2 + n/2
axiom nDiv2Succ (n : Nat) : n % 2 ≠ 0 → n = Nat.succ (n/2 + n/2)
def parity (n : Nat) : Parity n :=
if h : n % 2 = 0 then
Eq.ndrec (Parity.even (n/2)) (nDiv2 n h).symm
else
Eq.ndrec (Parity.odd (n/2)) (nDiv2Succ n h).symm
partial def natToBin : (n : Nat) → List Bool
| 0 => []
| n => match n, parity n with
| _, Parity.even j => false :: natToBin j
| _, Parity.odd j => true :: natToBin j
#eval natToBin 6
partial def natToBin' : (n : Nat) → List Bool
| 0 => []
| n => match parity n with
| Parity.even j => false :: natToBin j
| Parity.odd j => true :: natToBin j
partial def natToBinBad (n : Nat) : List Bool :=
match n, parity n with
| 0, _ => []
| _, Parity.even j => false :: natToBin j
| _, Parity.odd j => true :: natToBin j
partial def natToBin2 (n : Nat) : List Bool :=
match n, parity n with
| _, Parity.even 0 => []
| _, Parity.even j => false :: natToBin j
| _, Parity.odd j => true :: natToBin j
#eval natToBin2 6
partial def natToBin2' (n : Nat) : List Bool :=
match parity n with
| Parity.even 0 => []
| Parity.even j => false :: natToBin j
| Parity.odd j => true :: natToBin j
#check fun (a, b) => a -- Error type of pattern variable contains metavariables
#check fun (a, b) => (a:Nat) + b
#check fun (a, b) => a && b
#check fun ((a : Nat), (b : Nat)) => a + b
#check fun
| some a, some b => some (a + b : Nat)
| _, _ => none
-- overapplied matcher
#check fun x => (match x with | 0 => id | x+1 => id) x
#check fun
| #[1, 2] => 2
| #[] => 0
| #[3, 4, 5] => 3
| _ => 4
-- underapplied matcher
def g {α} : List α → Nat
| [a] => 1
| _ => 0
#check g.match_1
#check fun (e : Empty) => (nomatch e : False)

View file

@ -1,50 +0,0 @@
---- h1
10
---- h2
3
10
0
---- h3
10
30
4
---- inv
10
match1.lean:82:2-82:60: error: Dependent elimination failed: Type mismatch when solving this alternative: it has type
motive 0 (Vec.cons head✝ Vec.nil) ⋯
but is expected to have type
motive x✝ (Vec.cons head✝ tail✝) ⋯
[false, true, true]
match1.lean:119:2-119:18: error: Dependent match elimination failed: Expected a constructor, but found the inaccessible pattern
.(j + j)
[false, true, true]
match1.lean:136:7-136:22: error: Invalid match expression: The type of pattern variable 'a' contains metavariables:
?m
fun x => ?m : ?m × ?m → ?m
fun x =>
match x with
| (a, b) => a + b : Nat × Nat → Nat
fun x =>
match x with
| (a, b) => a && b : Bool × Bool → Bool
fun x =>
match x with
| (a, b) => a + b : Nat × Nat → Nat
fun x x_1 =>
match x, x_1 with
| some a, some b => some (a + b)
| x, x_2 => none : Option Nat → Option Nat → Option Nat
fun x =>
(match (motive := Nat → Nat → Nat) x with
| 0 => id
| x.succ => id)
x : Nat → Nat
fun x =>
match x with
| #[1, 2] => 2
| #[] => 0
| #[3, 4, 5] => 3
| x => 4 : Array Nat → Nat
g.match_1.{u_1, u_2} {α : Type u_1} (motive : List α → Sort u_2) (x✝ : List α) (h_1 : (a : α) → motive [a])
(h_2 : (x : List α) → motive x) : motive x✝
fun e => nomatch e : ∀ (e : Empty), False

View file

@ -0,0 +1,107 @@
-- set_option trace.Meta.Match.debug true
-- set_option trace.Meta.Match.match true
set_option match.ignoreUnusedAlts true in
def test (a : List Nat) : Nat :=
match a with
| _ => 3
| [] => 4
-- Should have no `casesOn`
/--
info: def test.match_1.{u_1} : (motive : List Nat → Sort u_1) →
(a : List Nat) → ((x : List Nat) → motive x) → (Unit → motive []) → motive a :=
fun motive a h_1 h_2 => List.casesOn a (h_1 []) fun head tail => h_1 (head :: tail)
-/
#guard_msgs in #print test.match_1
def test2 (a b : List Nat) : Nat :=
match a, b with
| [], _ => 3
| _, [] => 4
| _ :: _, _ :: _ => 5
/--
info: def test2.match_1.{u_1} : (motive : List Nat → List Nat → Sort u_1) →
(a b : List Nat) →
((x : List Nat) → motive [] x) →
((x : List Nat) → motive x []) →
((head : Nat) →
(tail : List Nat) → (head_1 : Nat) → (tail_1 : List Nat) → motive (head :: tail) (head_1 :: tail_1)) →
motive a b :=
fun motive a b h_1 h_2 h_3 =>
List.casesOn a (List.casesOn b (h_1 []) fun head tail => h_1 (head :: tail)) fun head tail =>
List.casesOn b (h_2 (head :: tail)) fun head_1 tail_1 => h_3 head tail head_1 tail_1
-/
#guard_msgs in #print test2.match_1
def test3 (a : List Nat) (b : Bool) : Nat :=
match a, b with
| _, true => 0
| [], _ => 1
| _, _ => 2
-- Should have exactly two `casesOn`
/--
info: def test3.match_1.{u_1} : (motive : List Nat → Bool → Sort u_1) →
(a : List Nat) →
(b : Bool) →
((x : List Nat) → motive x true) →
((x : Bool) → motive [] x) → ((x : List Nat) → (x_1 : Bool) → motive x x_1) → motive a b :=
fun motive a b h_1 h_2 h_3 =>
List.casesOn a (Bool.casesOn b (h_2 false) (h_1 [])) fun head tail =>
Bool.casesOn b (h_3 (head :: tail) false) (h_1 (head :: tail))
-/
#guard_msgs in #print test3.match_1
set_option maxHeartbeats 100 in
example (P : Nat → Prop) (x : Nat) (h : x = 12345) (hP : P 12345) : P x :=
match x, h with | _, rfl => hP
def test4 : Bool → Bool → Bool → Bool → Bool → Bool
| _, _ , _ , _ , true => true
| _, _ , _ , true , _ => true
| _, _ , true , _ , _ => true
| _, true , _ , _ , _ => true
| true , _ , _ , _ , _ => true
| _ , _ , _ , _ , _ => false
/--
info: def test4.match_1.{u_1} : (motive : Bool → Bool → Bool → Bool → Bool → Sort u_1) →
(x x_1 x_2 x_3 x_4 : Bool) →
((x x_5 x_6 x_7 : Bool) → motive x x_5 x_6 x_7 true) →
((x x_5 x_6 x_7 : Bool) → motive x x_5 x_6 true x_7) →
((x x_5 x_6 x_7 : Bool) → motive x x_5 true x_6 x_7) →
((x x_5 x_6 x_7 : Bool) → motive x true x_5 x_6 x_7) →
((x x_5 x_6 x_7 : Bool) → motive true x x_5 x_6 x_7) →
((x x_5 x_6 x_7 x_8 : Bool) → motive x x_5 x_6 x_7 x_8) → motive x x_1 x_2 x_3 x_4 :=
fun motive x x_1 x_2 x_3 x_4 h_1 h_2 h_3 h_4 h_5 h_6 =>
Bool.casesOn x
(Bool.casesOn x_1
(Bool.casesOn x_2
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_6 false false false false false) (h_1 false false false false))
(Bool.casesOn x_4 (h_2 false false false false) (h_1 false false false true)))
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_3 false false false false) (h_1 false false true false))
(Bool.casesOn x_4 (h_2 false false true false) (h_1 false false true true))))
(Bool.casesOn x_2
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_4 false false false false) (h_1 false true false false))
(Bool.casesOn x_4 (h_2 false true false false) (h_1 false true false true)))
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_3 false true false false) (h_1 false true true false))
(Bool.casesOn x_4 (h_2 false true true false) (h_1 false true true true)))))
(Bool.casesOn x_1
(Bool.casesOn x_2
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_5 false false false false) (h_1 true false false false))
(Bool.casesOn x_4 (h_2 true false false false) (h_1 true false false true)))
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_3 true false false false) (h_1 true false true false))
(Bool.casesOn x_4 (h_2 true false true false) (h_1 true false true true))))
(Bool.casesOn x_2
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_4 true false false false) (h_1 true true false false))
(Bool.casesOn x_4 (h_2 true true false false) (h_1 true true false true)))
(Bool.casesOn x_3 (Bool.casesOn x_4 (h_3 true true false false) (h_1 true true true false))
(Bool.casesOn x_4 (h_2 true true true false) (h_1 true true true true)))))
-/
#guard_msgs in
#print test4.match_1

View file

@ -1,172 +1,246 @@
import Lean
set_option linter.unusedVariables false
--
def checkWithMkMatcherInput (matcher : Lean.Name) : Lean.MetaM Unit :=
Lean.Meta.Match.withMkMatcherInput matcher fun input => do
let res ← Lean.Meta.Match.mkMatcher input
let origMatcher ← Lean.getConstInfo matcher
if not <| input.matcherName == matcher then
throwError "matcher name not reconstructed correctly: {matcher} ≟ {input.matcherName}"
let lCtx ← Lean.getLCtx
let fvars := Lean.collectFVars {} res.matcher
let closure := Lean.Meta.Closure.mkLambda (fvars.fvarSet.toList.toArray.map lCtx.get!) res.matcher
let origTy := origMatcher.value!
let newTy := closure
if not <| ←Lean.Meta.isDefEq origTy newTy then
throwError "matcher {matcher} does not round-trip correctly:\n{origTy} ≟ {newTy}"
set_option smartUnfolding false
def f (xs : List Nat) : List Bool :=
xs.map fun
| 0 => true
| _ => false
def h1 (b : Bool) : Nat :=
match b with
| true => 0
| false => 10
/-- info: 10 -/
#guard_msgs in
#eval checkWithMkMatcherInput ``f.match_1
#eval h1 false
#guard f [1, 2, 0, 2] == [false, false, true, false]
def h2 (x : List Nat) : Nat :=
match x with
| [x1, x2] => x1 + x2
| x::xs => x
| _ => 0
theorem ex1 : f [1, 0, 2] = [false, true, false] :=
/-- info: 10 -/
#guard_msgs in
#eval h1 false
/-- info: 3 -/
#guard_msgs in
#eval h2 [1, 2]
/-- info: 10 -/
#guard_msgs in
#eval h2 [10, 4, 5]
/-- info: 0 -/
#guard_msgs in
#eval h2 []
def h3 (x : Array Nat) : Nat :=
match x with
| #[x] => x
| #[x, y] => x + y
| xs => xs.size
/-- info: 10 -/
#guard_msgs in
#eval h3 #[10]
/-- info: 30 -/
#guard_msgs in
#eval h3 #[10, 20]
/-- info: 4 -/
#guard_msgs in
#eval h3 #[10, 20, 30, 40]
inductive Image {α β : Type} (f : α → β) : β → Type
| mk (a : α) : Image f (f a)
def mkImage {α β : Type} (f : α → β) (a : α) : Image f (f a) :=
Image.mk a
def inv {α β : Type} {f : α → β} {b : β} (t : Image f b) : α :=
match b, t with
| _, Image.mk a => a
/-- info: 10 -/
#guard_msgs in
#eval inv (mkImage Nat.succ 10)
theorem foo {p q} (h : p q) : q p :=
match h with
| Or.inl h => Or.inr h
| Or.inr h => Or.inl h
def f (x : Nat × Nat) : Bool × Bool × Bool → Nat :=
match x with
| (a, b) => fun _ => a
structure S where
(x y z : Nat := 0)
def f1 : S → S :=
fun { x := x, ..} => { y := x }
theorem ex2 : f1 { x := 10 } = { y := 10 } :=
rfl
#check f
universe u
set_option pp.raw true
set_option pp.raw.maxDepth 10
set_option trace.Elab.step true in
def g (xs : List Nat) : List Bool :=
xs.map <| by {
intro
| 0 => exact true
| _ => exact false
}
theorem ex2 : g [1, 0, 2] = [false, true, false] :=
rfl
theorem ex3 {p q r : Prop} : p q → r → (q ∧ r) (p ∧ r) :=
by intro
| Or.inl hp, h => { apply Or.inr; apply And.intro; assumption; assumption }
| Or.inr hq, h => { apply Or.inl; exact ⟨hq, h⟩ }
inductive C
| mk₁ : Nat → C
| mk₂ : Nat → Nat → C
def C.x : C → Nat
| C.mk₁ x => x
| C.mk₂ x _ => x
#eval checkWithMkMatcherInput ``C.x.match_1
def head : {α : Type} → List α → Option α
| _, a::as => some a
| _, _ => none
#eval checkWithMkMatcherInput ``head.match_1
theorem ex4 : head [1, 2] = some 1 :=
rfl
def head2 : {α : Type} → List α → Option α :=
@fun
| _, a::as => some a
| _, _ => none
theorem ex5 : head2 [1, 2] = some 1 :=
rfl
def head3 {α : Type} (xs : List α) : Option α :=
let rec aux {α : Type} : List α → Option α
| a::_ => some a
| _ => none;
aux xs
theorem ex6 : head3 [1, 2] = some 1 :=
rfl
inductive Vec.{u} (α : Type u) : Nat → Type u
inductive Vec (α : Type u) : Nat → Type u
| nil : Vec α 0
| cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)
def Vec.mapHead1 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil, nil, f => none
| _, cons a as, cons b bs, f => some (f a b)
inductive VecPred {α : Type u} (P : α → Prop) : {n : Nat} → Vec α n → Prop
| nil : VecPred P Vec.nil
| cons {n : Nat} {head : α} {tail : Vec α n} : P head → VecPred P tail → VecPred P (Vec.cons head tail)
theorem ex3 {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
| _, Vec.cons head _, VecPred.cons h _ => ⟨head, h⟩
def Vec.mapHead2 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil, nil, f => none
| _, @cons _ n a as, cons b bs, f => some (f a b)
set_option pp.match false in
#print Vec.mapHead2 -- reused Vec.mapHead1.match_1
/--
error: Dependent elimination failed: Type mismatch when solving this alternative: it has type
motive 0 (Vec.cons head✝ Vec.nil) ⋯
but is expected to have type
motive x✝ (Vec.cons head✝ tail✝) ⋯
-/
#guard_msgs in
theorem ex4 {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
| _, Vec.cons head _, VecPred.cons h (w : VecPred P Vec.nil) => ⟨head, h⟩ -- ERROR
def Vec.mapHead3 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil, nil, f => none
| _, cons (tail := as) (head := a), cons b bs, f => some (f a b)
axiom someNat : Nat
inductive Foo
| mk₁ (x y z w : Nat)
| mk₂ (x y z w : Nat)
noncomputable def f2 (x : Nat) := -- must mark as noncomputable since it uses axiom `someNat`
x + someNat
def Foo.z : Foo → Nat
| mk₁ (z := z) .. => z
| mk₂ (z := z) .. => z
inductive Parity : Nat -> Type
| even (n) : Parity (n + n)
| odd (n) : Parity (Nat.succ (n + n))
#eval checkWithMkMatcherInput ``Foo.z.match_1
axiom nDiv2 (n : Nat) : n % 2 = 0 → n = n/2 + n/2
axiom nDiv2Succ (n : Nat) : n % 2 ≠ 0 → n = Nat.succ (n/2 + n/2)
#guard (Foo.mk₁ 10 20 30 40).z == 30
def parity (n : Nat) : Parity n :=
if h : n % 2 = 0 then
Eq.ndrec (Parity.even (n/2)) (nDiv2 n h).symm
else
Eq.ndrec (Parity.odd (n/2)) (nDiv2Succ n h).symm
theorem ex7 : (Foo.mk₁ 10 20 30 40).z = 30 :=
rfl
partial def natToBin : (n : Nat) → List Bool
| 0 => []
| n => match n, parity n with
| _, Parity.even j => false :: natToBin j
| _, Parity.odd j => true :: natToBin j
def Foo.addY? : Foo × Foo → Option Nat
| (mk₁ (y := y₁) .., mk₁ (y := y₂) ..) => some (y₁ + y₂)
| _ => none
/-- info: [false, true, true] -/
#guard_msgs in
#eval natToBin 6
#eval checkWithMkMatcherInput ``Foo.addY?.match_1
partial def natToBin' : (n : Nat) → List Bool
| 0 => []
| n => match parity n with
| Parity.even j => false :: natToBin j
| Parity.odd j => true :: natToBin j
#guard Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40) == some 22
/--
error: Tactic `cases` failed with a nested error:
Dependent elimination failed: Failed to solve equation
Nat.zero = n✝.add n✝
at case `Parity.even` after processing
Nat.zero, _
the dependent pattern matcher can solve the following kinds of equations
- <var> = <term> and <term> = <var>
- <term> = <term> where the terms are definitionally equal
- <constructor> = <constructor>, examples: List.cons x xs = List.cons y ys, and List.cons x xs = List.nil
-/
#guard_msgs in
partial def natToBinBad (n : Nat) : List Bool :=
match n, parity n with
| 0, _ => []
| _, Parity.even j => false :: natToBin j
| _, Parity.odd j => true :: natToBin j
theorem ex8 : Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40) = some 22 :=
rfl
partial def natToBin2 (n : Nat) : List Bool :=
match n, parity n with
| _, Parity.even 0 => []
| _, Parity.even j => false :: natToBin j
| _, Parity.odd j => true :: natToBin j
instance {α} : Inhabited (Sigma fun m => Vec α m) :=
⟨⟨0, Vec.nil⟩⟩
/-- info: [false, true, true] -/
#guard_msgs in
#eval natToBin2 6
partial def filter {α} (p : α → Bool) : {n : Nat} → Vec α n → Sigma fun m => Vec α m
| _, Vec.nil => ⟨0, Vec.nil⟩
| _, Vec.cons x xs => match p x, filter p xs with
| true, ⟨_, ys⟩ => ⟨_, Vec.cons x ys⟩
| false, ys => ys
#eval checkWithMkMatcherInput ``filter.match_1
partial def natToBin2' (n : Nat) : List Bool :=
match parity n with
| Parity.even 0 => []
| Parity.even j => false :: natToBin j
| Parity.odd j => true :: natToBin j
inductive Bla
| ofNat (x : Nat)
| ofBool (x : Bool)
/--
error: Invalid match expression: The type of pattern variable 'a' contains metavariables:
?m.12
---
info: fun x => ?m.3 : ?m.12 × ?m.13 → ?m.12
-/
#guard_msgs in
#check fun (a, b) => a -- Error type of pattern variable contains metavariables
def Bla.optional? : Bla → Option Nat
| ofNat x => some x
| ofBool _ => none
#eval checkWithMkMatcherInput ``Bla.optional?.match_1
/--
info: fun x =>
match x with
| (a, b) => a + b : Nat × Nat → Nat
-/
#guard_msgs in
#check fun (a, b) => (a:Nat) + b
def Bla.isNat? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match b.optional? with
| some y => some ⟨y, rfl⟩
| none => none
#eval checkWithMkMatcherInput ``Bla.isNat?.match_1
/--
info: fun x =>
match x with
| (a, b) => a && b : Bool × Bool → Bool
-/
#guard_msgs in
#check fun (a, b) => a && b
def foo (b : Bla) : Option Nat := b.optional?
theorem fooEq (b : Bla) : foo b = b.optional? :=
rfl
/--
info: fun x =>
match x with
| (a, b) => a + b : Nat × Nat → Nat
-/
#guard_msgs in
#check fun ((a : Nat), (b : Nat)) => a + b
def Bla.isNat2? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match h : foo b with
| some y => some ⟨y, Eq.trans (fooEq b).symm h⟩
| none => none
#eval checkWithMkMatcherInput ``Bla.isNat2?.match_1
/--
info: fun x x_1 =>
match x, x_1 with
| some a, some b => some (a + b)
| x, x_2 => none : Option Nat → Option Nat → Option Nat
-/
#guard_msgs in
#check fun
| some a, some b => some (a + b : Nat)
| _, _ => none
def foo2 (x : Nat) : Nat :=
match (motive := (y : Nat) → x = y → Nat) x, rfl with
| 0, h => 0
| x+1, h => 1
#eval checkWithMkMatcherInput ``foo2.match_1
-- overapplied matcher
/--
info: fun x =>
(match (motive := Nat → Nat → Nat) x with
| 0 => id
| x.succ => id)
x : Nat → Nat
-/
#guard_msgs in
#check fun x => (match x with | 0 => id | x+1 => id) x
#guard_msgs(drop info) in
#check fun
| #[1, 2] => 2
| #[] => 0
| #[3, 4, 5] => 3
| _ => 4
-- underapplied matcher
def g {α} : List α → Nat
| [a] => 1
| _ => 0
/--
info: g.match_1.{u_1, u_2} {α : Type u_1} (motive : List α → Sort u_2) (x✝ : List α) (h_1 : (a : α) → motive [a])
(h_2 : (x : List α) → motive x) : motive x✝
-/
#guard_msgs in
#check g.match_1
#guard_msgs(drop info) in
#check fun (e : Empty) => (nomatch e : False)

172
tests/lean/run/match2.lean Normal file
View file

@ -0,0 +1,172 @@
import Lean
def checkWithMkMatcherInput (matcher : Lean.Name) : Lean.MetaM Unit :=
Lean.Meta.Match.withMkMatcherInput matcher fun input => do
let res ← Lean.Meta.Match.mkMatcher input
let origMatcher ← Lean.getConstInfo matcher
if not <| input.matcherName == matcher then
throwError "matcher name not reconstructed correctly: {matcher} ≟ {input.matcherName}"
let lCtx ← Lean.getLCtx
let fvars := Lean.collectFVars {} res.matcher
let closure := Lean.Meta.Closure.mkLambda (fvars.fvarSet.toList.toArray.map lCtx.get!) res.matcher
let origTy := origMatcher.value!
let newTy := closure
if not <| ←Lean.Meta.isDefEq origTy newTy then
throwError "matcher {matcher} does not round-trip correctly:\n{origTy} ≟ {newTy}"
set_option smartUnfolding false
def f (xs : List Nat) : List Bool :=
xs.map fun
| 0 => true
| _ => false
#guard_msgs in
#eval checkWithMkMatcherInput ``f.match_1
#guard f [1, 2, 0, 2] == [false, false, true, false]
theorem ex1 : f [1, 0, 2] = [false, true, false] :=
rfl
#check f
set_option pp.raw true
set_option pp.raw.maxDepth 10
set_option trace.Elab.step true in
def g (xs : List Nat) : List Bool :=
xs.map <| by {
intro
| 0 => exact true
| _ => exact false
}
theorem ex2 : g [1, 0, 2] = [false, true, false] :=
rfl
theorem ex3 {p q r : Prop} : p q → r → (q ∧ r) (p ∧ r) :=
by intro
| Or.inl hp, h => { apply Or.inr; apply And.intro; assumption; assumption }
| Or.inr hq, h => { apply Or.inl; exact ⟨hq, h⟩ }
inductive C
| mk₁ : Nat → C
| mk₂ : Nat → Nat → C
def C.x : C → Nat
| C.mk₁ x => x
| C.mk₂ x _ => x
#eval checkWithMkMatcherInput ``C.x.match_1
def head : {α : Type} → List α → Option α
| _, a::as => some a
| _, _ => none
#eval checkWithMkMatcherInput ``head.match_1
theorem ex4 : head [1, 2] = some 1 :=
rfl
def head2 : {α : Type} → List α → Option α :=
@fun
| _, a::as => some a
| _, _ => none
theorem ex5 : head2 [1, 2] = some 1 :=
rfl
def head3 {α : Type} (xs : List α) : Option α :=
let rec aux {α : Type} : List α → Option α
| a::_ => some a
| _ => none;
aux xs
theorem ex6 : head3 [1, 2] = some 1 :=
rfl
inductive Vec.{u} (α : Type u) : Nat → Type u
| nil : Vec α 0
| cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)
def Vec.mapHead1 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil, nil, f => none
| _, cons a as, cons b bs, f => some (f a b)
def Vec.mapHead2 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil, nil, f => none
| _, @cons _ n a as, cons b bs, f => some (f a b)
set_option pp.match false in
#print Vec.mapHead2 -- reused Vec.mapHead1.match_1
def Vec.mapHead3 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil, nil, f => none
| _, cons (tail := as) (head := a), cons b bs, f => some (f a b)
inductive Foo
| mk₁ (x y z w : Nat)
| mk₂ (x y z w : Nat)
def Foo.z : Foo → Nat
| mk₁ (z := z) .. => z
| mk₂ (z := z) .. => z
#eval checkWithMkMatcherInput ``Foo.z.match_1
#guard (Foo.mk₁ 10 20 30 40).z == 30
theorem ex7 : (Foo.mk₁ 10 20 30 40).z = 30 :=
rfl
def Foo.addY? : Foo × Foo → Option Nat
| (mk₁ (y := y₁) .., mk₁ (y := y₂) ..) => some (y₁ + y₂)
| _ => none
#eval checkWithMkMatcherInput ``Foo.addY?.match_1
#guard Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40) == some 22
theorem ex8 : Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40) = some 22 :=
rfl
instance {α} : Inhabited (Sigma fun m => Vec α m) :=
⟨⟨0, Vec.nil⟩⟩
partial def filter {α} (p : α → Bool) : {n : Nat} → Vec α n → Sigma fun m => Vec α m
| _, Vec.nil => ⟨0, Vec.nil⟩
| _, Vec.cons x xs => match p x, filter p xs with
| true, ⟨_, ys⟩ => ⟨_, Vec.cons x ys⟩
| false, ys => ys
#eval checkWithMkMatcherInput ``filter.match_1
inductive Bla
| ofNat (x : Nat)
| ofBool (x : Bool)
def Bla.optional? : Bla → Option Nat
| ofNat x => some x
| ofBool _ => none
#eval checkWithMkMatcherInput ``Bla.optional?.match_1
def Bla.isNat? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match b.optional? with
| some y => some ⟨y, rfl⟩
| none => none
#eval checkWithMkMatcherInput ``Bla.isNat?.match_1
def foo (b : Bla) : Option Nat := b.optional?
theorem fooEq (b : Bla) : foo b = b.optional? :=
rfl
def Bla.isNat2? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match h : foo b with
| some y => some ⟨y, Eq.trans (fooEq b).symm h⟩
| none => none
#eval checkWithMkMatcherInput ``Bla.isNat2?.match_1
def foo2 (x : Nat) : Nat :=
match (motive := (y : Nat) → x = y → Nat) x, rfl with
| 0, h => 0
| x+1, h => 1
#eval checkWithMkMatcherInput ``foo2.match_1

View file

@ -0,0 +1,72 @@
set_option warn.sorry false
inductive Parity : Nat -> Type
| even (n) : Parity (n + n)
| odd (n) : Parity (Nat.succ (n + n))
axiom nDiv2 (n : Nat) : n % 2 = 0 → n = n/2 + n/2
axiom nDiv2Succ (n : Nat) : n % 2 ≠ 0 → n = Nat.succ (n/2 + n/2)
def parity (n : Nat) : Parity n :=
if h : n % 2 = 0 then
Eq.ndrec (Parity.even (n/2)) (nDiv2 n h).symm
else
Eq.ndrec (Parity.odd (n/2)) (nDiv2Succ n h).symm
/--
error: Tactic `cases` failed with a nested error:
Dependent elimination failed: Failed to solve equation
Nat.zero = n✝.add n✝
at case `Parity.even` after processing
Nat.zero, _
the dependent pattern matcher can solve the following kinds of equations
- <var> = <term> and <term> = <var>
- <term> = <term> where the terms are definitionally equal
- <constructor> = <constructor>, examples: List.cons x xs = List.cons y ys, and List.cons x xs = List.nil
-/
#guard_msgs in
partial def natToBinBad (n : Nat) : List Bool :=
match n, parity n with
| 0, _ => []
| _, Parity.even j => false :: natToBinBad j
| _, Parity.odd j => true :: natToBinBad j
inductive MyNat : Type where
| zero : MyNat
| succ : MyNat -> MyNat
def MyNat.add : MyNat -> MyNat -> MyNat
| zero, n => n
| succ m, n => succ (add m n)
instance : Add MyNat where
add := MyNat.add
namespace MyNat
inductive Parity : MyNat -> Type
| even (n) : Parity (n + n)
| odd (n) : Parity (MyNat.succ (n + n))
def parity (n : MyNat) : Parity n := sorry
-- set_option trace.Meta.Match.match true
/--
error: Tactic `cases` failed with a nested error:
Dependent elimination failed: Failed to solve equation
zero = n✝.add n✝
at case `Parity.even` after processing
zero, _
the dependent pattern matcher can solve the following kinds of equations
- <var> = <term> and <term> = <var>
- <term> = <term> where the terms are definitionally equal
- <constructor> = <constructor>, examples: List.cons x xs = List.cons y ys, and List.cons x xs = List.nil
-/
#guard_msgs(pass trace, all) in
partial def myNatToBinBad (n : MyNat) : List Bool :=
match n, parity n with
| zero, _ => []
| _, Parity.even j => false :: myNatToBinBad j
| _, Parity.odd j => true :: myNatToBinBad j