max/lean4-htt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 2

chore: update stage0

Browse source
This commit is contained in:
Leonardo de Moura 2020-08-12 20:24:19 -07:00
parent bd7a7ed623
commit 02b81e263e
46 changed files with 112838 additions and 98459 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

214
stage0/src/Lean/Elab/App.lean
View file

@ -36,26 +36,26 @@ instance NamedArg.inhabited : Inhabited NamedArg := ⟨{ name := arbitrary _, va
/--
Add a new named argument to `namedArgs`, and throw an error if it already contains a named argument
with the same name. -/
def addNamedArg (ref : Syntax) (namedArgs : Array NamedArg) (namedArg : NamedArg) : TermElabM (Array NamedArg) := do
def addNamedArg (namedArgs : Array NamedArg) (namedArg : NamedArg) : TermElabM (Array NamedArg) := do
when (namedArgs.any $ fun namedArg' => namedArg.name == namedArg'.name) $
throwError ref ("argument '" ++ toString namedArg.name ++ "' was already set");
throwError ("argument '" ++ toString namedArg.name ++ "' was already set");
pure $ namedArgs.push namedArg
def synthesizeAppInstMVars (ref : Syntax) (instMVars : Array MVarId) : TermElabM Unit :=
def synthesizeAppInstMVars (instMVars : Array MVarId) : TermElabM Unit :=
instMVars.forM $ fun mvarId =>
unlessM (synthesizeInstMVarCore ref mvarId) $
registerSyntheticMVar ref mvarId SyntheticMVarKind.typeClass
unlessM (synthesizeInstMVarCore mvarId) $
registerSyntheticMVar mvarId SyntheticMVarKind.typeClass
private def ensureArgType (ref : Syntax) (f : Expr) (arg : Expr) (expectedType : Expr) : TermElabM Expr := do
argType ← inferType ref arg;
ensureHasTypeAux ref expectedType argType arg f
private def ensureArgType (f : Expr) (arg : Expr) (expectedType : Expr) : TermElabM Expr := do
argType ← inferType arg;
ensureHasTypeAux expectedType argType arg f
private def elabArg (ref : Syntax) (f : Expr) (arg : Arg) (expectedType : Expr) : TermElabM Expr :=
private def elabArg (f : Expr) (arg : Arg) (expectedType : Expr) : TermElabM Expr :=
match arg with
| Arg.expr val => ensureArgType ref f val expectedType
| Arg.expr val => ensureArgType f val expectedType
| Arg.stx val => do
val ← elabTerm val expectedType;
ensureArgType ref f val expectedType
ensureArgType f val expectedType
private def mkArrow (d b : Expr) : TermElabM Expr := do
n ← mkFreshAnonymousName;
@ -67,24 +67,24 @@ pure $ Lean.mkForall n BinderInfo.default d b
class CoeFun (α : Sort u) (γ : α → outParam (Sort v))
abbrev coeFun {α : Sort u} {γ : α → Sort v} (a : α) [CoeFun α γ] : γ a
``` -/
private def tryCoeFun (ref : Syntax) (α : Expr) (a : Expr) : TermElabM Expr := do
v ← mkFreshLevelMVar ref;
private def tryCoeFun (α : Expr) (a : Expr) : TermElabM Expr := do
v ← mkFreshLevelMVar;
type ← mkArrow α (mkSort v);
γ ← mkFreshExprMVar ref type;
u ← getLevel ref α;
γ ← mkFreshExprMVar type;
u ← getLevel α;
let coeFunInstType := mkAppN (Lean.mkConst `CoeFun [u, v]) #[α, γ];
mvar ← mkFreshExprMVar ref coeFunInstType MetavarKind.synthetic;
mvar ← mkFreshExprMVar coeFunInstType MetavarKind.synthetic;
let mvarId := mvar.mvarId!;
synthesized ←
catch (withoutMacroStackAtErr $ synthesizeInstMVarCore ref mvarId)
catch (withoutMacroStackAtErr $ synthesizeInstMVarCore mvarId)
(fun ex =>
match ex with
| Exception.ex (Elab.Exception.error errMsg) => throwError ref ("function expected" ++ Format.line ++ errMsg.data)
| _ => throwError ref "function expected");
| Exception.ex (Elab.Exception.error errMsg) => throwError ("function expected" ++ Format.line ++ errMsg.data)
| _ => throwError "function expected");
if synthesized then
pure $ mkAppN (Lean.mkConst `coeFun [u, v]) #[α, γ, a, mvar]
else
throwError ref "function expected"
throwError "function expected"
/-- Auxiliary structure used to elaborate function application arguments. -/
structure ElabAppArgsCtx :=
@ -169,6 +169,7 @@ private def hasOnlyTypeMVar (ctx : ElabAppArgsCtx) (type : Expr) : Bool :=
`bv 64` is **not** definitionally equal to `bv 32`.
-/
private def propagateExpectedType (ctx : ElabAppArgsCtx) (eType : Expr) : TermElabM Unit :=
withRef ctx.ref $
unless (ctx.explicit || ctx.foundExplicit || ctx.typeMVars.isEmpty) $ do
match ctx.expectedType? with
| none => pure ()
@ -179,7 +180,7 @@ unless (ctx.explicit || ctx.foundExplicit || ctx.typeMVars.isEmpty) $ do
| some eTypeBody =>
unless eTypeBody.hasLooseBVars $
when (hasTypeMVar ctx eTypeBody && hasOnlyTypeMVar ctx eTypeBody) $ do
_ ← isDefEq ctx.ref expectedType eTypeBody;
_ ← isDefEq expectedType eTypeBody;
pure ()
private def nextArgIsHole (ctx : ElabAppArgsCtx) : Bool :=
@ -192,28 +193,28 @@ else
/- Elaborate function application arguments. -/
private partial def elabAppArgsAux : ElabAppArgsCtx → Expr → Expr → TermElabM Expr
| ctx, e, eType => do
| ctx, e, eType => withRef ctx.ref do
let finalize : Unit → TermElabM Expr := fun _ => do {
-- all user explicit arguments have been consumed
trace `Elab.app.finalize ctx.ref $ fun _ => e;
trace `Elab.app.finalize $ fun _ => e;
match ctx.expectedType? with
| none => pure ()
| some expectedType => do {
-- Try to propagate expected type. Ignore if types are not definitionally equal, caller must handle it.
_ ← isDefEq ctx.ref expectedType eType;
_ ← isDefEq expectedType eType;
pure ()
};
synthesizeAppInstMVars ctx.ref ctx.instMVars;
synthesizeAppInstMVars ctx.instMVars;
pure e
};
eType ← whnfForall ctx.ref eType;
eType ← whnfForall eType;
match eType with
| Expr.forallE n d b c =>
match ctx.namedArgs.findIdx? (fun namedArg => namedArg.name == n) with
| some idx => do
let arg := ctx.namedArgs.get! idx;
let namedArgs := ctx.namedArgs.eraseIdx idx;
argElab ← elabArg ctx.ref e arg.val d;
argElab ← elabArg e arg.val d;
propagateExpectedType ctx eType;
elabAppArgsAux { ctx with foundExplicit := true, namedArgs := namedArgs } (mkApp e argElab) (b.instantiate1 argElab)
| none =>
@ -221,14 +222,14 @@ private partial def elabAppArgsAux : ElabAppArgsCtx → Expr → Expr → TermEl
propagateExpectedType ctx eType;
let ctx := { ctx with foundExplicit := true };
if h : ctx.argIdx < ctx.args.size then do
argElab ← elabArg ctx.ref e (ctx.args.get ⟨ctx.argIdx, h⟩) d;
argElab ← elabArg e (ctx.args.get ⟨ctx.argIdx, h⟩) d;
elabAppArgsAux { ctx with argIdx := ctx.argIdx + 1 } (mkApp e argElab) (b.instantiate1 argElab)
else match ctx.explicit, d.getOptParamDefault?, d.getAutoParamTactic? with
| false, some defVal, _ => elabAppArgsAux ctx (mkApp e defVal) (b.instantiate1 defVal)
| false, _, some (Expr.const tacticDecl _ _) => do
env ← getEnv;
match evalSyntaxConstant env tacticDecl with
| Except.error err => throwError ctx.ref err
| Except.error err => throwError err
| Except.ok tacticSyntax => do
tacticBlock ← `(begin $(tacticSyntax.getArgs)* end);
-- tacticBlock does not have any position information
@ -237,35 +238,35 @@ private partial def elabAppArgsAux : ElabAppArgsCtx → Expr → Expr → TermEl
| some info => tacticBlock.replaceInfo info
| _ => tacticBlock;
let d := d.getArg! 0; -- `autoParam type := by tactic` ==> `type`
argElab ← elabArg ctx.ref e (Arg.stx tacticBlock) d;
argElab ← elabArg e (Arg.stx tacticBlock) d;
elabAppArgsAux ctx (mkApp e argElab) (b.instantiate1 argElab)
| false, _, some _ =>
throwError ctx.ref "invalid autoParam, argument must be a constant"
throwError "invalid autoParam, argument must be a constant"
| _, _, _ =>
if ctx.namedArgs.isEmpty then
finalize ()
else
throwError ctx.ref ("explicit parameter '" ++ n ++ "' is missing, unused named arguments " ++ toString (ctx.namedArgs.map $ fun narg => narg.name))
throwError ("explicit parameter '" ++ n ++ "' is missing, unused named arguments " ++ toString (ctx.namedArgs.map $ fun narg => narg.name))
};
match c.binderInfo with
| BinderInfo.implicit =>
if ctx.explicit then
processExplictArg ()
else do
a ← mkFreshExprMVar ctx.ref d;
typeMVars ← condM (isTypeFormer ctx.ref a) (pure $ ctx.typeMVars.push a.mvarId!) (pure ctx.typeMVars);
a ← mkFreshExprMVar d;
typeMVars ← condM (isTypeFormer a) (pure $ ctx.typeMVars.push a.mvarId!) (pure ctx.typeMVars);
elabAppArgsAux { ctx with typeMVars := typeMVars } (mkApp e a) (b.instantiate1 a)
| BinderInfo.instImplicit =>
if ctx.explicit && nextArgIsHole ctx then do
/- Recall that if '@' has been used, and the argument is '_', then we still use
type class resolution -/
a ← mkFreshExprMVar ctx.ref d MetavarKind.synthetic;
a ← mkFreshExprMVar d MetavarKind.synthetic;
elabAppArgsAux { ctx with argIdx := ctx.argIdx + 1, instMVars := ctx.instMVars.push a.mvarId! } (mkApp e a) (b.instantiate1 a)
else if ctx.explicit then
processExplictArg ()
else do
a ← mkFreshExprMVar ctx.ref d MetavarKind.synthetic;
a ← mkFreshExprMVar d MetavarKind.synthetic;
elabAppArgsAux { ctx with instMVars := ctx.instMVars.push a.mvarId! } (mkApp e a) (b.instantiate1 a)
| _ =>
processExplictArg ()
@ -273,17 +274,18 @@ private partial def elabAppArgsAux : ElabAppArgsCtx → Expr → Expr → TermEl
if ctx.namedArgs.isEmpty && ctx.argIdx == ctx.args.size then
finalize ()
else do
e ← tryCoeFun ctx.ref eType e;
eType ← inferType ctx.ref e;
e ← tryCoeFun eType e;
eType ← inferType e;
elabAppArgsAux ctx e eType
private def elabAppArgs (ref : Syntax) (f : Expr) (namedArgs : Array NamedArg) (args : Array Arg)
private def elabAppArgs (f : Expr) (namedArgs : Array NamedArg) (args : Array Arg)
(expectedType? : Option Expr) (explicit : Bool) : TermElabM Expr := do
fType ← inferType ref f;
fType ← instantiateMVars ref fType;
trace `Elab.app.args ref $ fun _ => "explicit: " ++ toString explicit ++ ", " ++ f ++ " : " ++ fType;
fType ← inferType f;
fType ← instantiateMVars fType;
trace `Elab.app.args $ fun _ => "explicit: " ++ toString explicit ++ ", " ++ f ++ " : " ++ fType;
unless (namedArgs.isEmpty && args.isEmpty) $
tryPostponeIfMVar fType;
ref ← getCurrRef;
elabAppArgsAux {ref := ref, args := args, expectedType? := expectedType?, explicit := explicit, namedArgs := namedArgs } f fType
/-- Auxiliary inductive datatype that represents the resolution of an `LVal`. -/
@ -294,17 +296,17 @@ inductive LValResolution
| localRec (baseName : Name) (fullName : Name) (fvar : Expr)
| getOp (fullName : Name) (idx : Syntax)
private def throwLValError {α} (ref : Syntax) (e : Expr) (eType : Expr) (msg : MessageData) : TermElabM α :=
throwError ref $ msg ++ indentExpr e ++ Format.line ++ "has type" ++ indentExpr eType
private def throwLValError {α} (e : Expr) (eType : Expr) (msg : MessageData) : TermElabM α :=
throwError $ msg ++ indentExpr e ++ Format.line ++ "has type" ++ indentExpr eType
private def resolveLValAux (ref : Syntax) (e : Expr) (eType : Expr) (lval : LVal) : TermElabM LValResolution :=
private def resolveLValAux (e : Expr) (eType : Expr) (lval : LVal) : TermElabM LValResolution :=
match eType.getAppFn, lval with
| Expr.const structName _ _, LVal.fieldIdx idx => do
when (idx == 0) $
throwError ref "invalid projection, index must be greater than 0";
throwError "invalid projection, index must be greater than 0";
env ← getEnv;
unless (isStructureLike env structName) $
throwLValError ref e eType "invalid projection, structure expected";
throwLValError e eType "invalid projection, structure expected";
let fieldNames := getStructureFields env structName;
if h : idx - 1 < fieldNames.size then
if isStructure env structName then
@ -314,7 +316,7 @@ match eType.getAppFn, lval with
So, we don't projection functions for it. Thus, we use `Expr.proj` -/
pure $ LValResolution.projIdx structName (idx - 1)
else
throwLValError ref e eType ("invalid projection, structure has only " ++ toString fieldNames.size ++ " field(s)")
throwLValError e eType ("invalid projection, structure has only " ++ toString fieldNames.size ++ " field(s)")
| Expr.const structName _ _, LVal.fieldName fieldName => do
env ← getEnv;
let searchEnv (fullName : Name) : TermElabM LValResolution := do {
@ -325,7 +327,7 @@ match eType.getAppFn, lval with
match env.find? fullNamePrv with
| some _ => pure $ LValResolution.const structName fullNamePrv
| none =>
throwLValError ref e eType $
throwLValError e eType $
"invalid field notation, '" ++ fieldName ++ "' is not a valid \"field\" because environment does not contain '" ++ fullName ++ "'"
};
-- search local context first, then environment
@ -354,23 +356,23 @@ match eType.getAppFn, lval with
let fullName := mkNameStr structName "getOp";
match env.find? fullName with
| some _ => pure $ LValResolution.getOp fullName idx
| none => throwLValError ref e eType $ "invalid [..] notation because environment does not contain '" ++ fullName ++ "'"
| none => throwLValError e eType $ "invalid [..] notation because environment does not contain '" ++ fullName ++ "'"
| _, LVal.getOp idx =>
throwLValError ref e eType "invalid [..] notation, type is not of the form (C ...) where C is a constant"
throwLValError e eType "invalid [..] notation, type is not of the form (C ...) where C is a constant"
| _, _ =>
throwLValError ref e eType "invalid field notation, type is not of the form (C ...) where C is a constant"
throwLValError e eType "invalid field notation, type is not of the form (C ...) where C is a constant"
private partial def resolveLValLoop (ref : Syntax) (e : Expr) (lval : LVal) : Expr → Array Message → TermElabM LValResolution
private partial def resolveLValLoop (e : Expr) (lval : LVal) : Expr → Array Message → TermElabM LValResolution
| eType, previousExceptions => do
eType ← whnfCore ref eType;
eType ← whnfCore eType;
tryPostponeIfMVar eType;
catch (resolveLValAux ref e eType lval)
catch (resolveLValAux e eType lval)
(fun ex =>
match ex with
| Exception.postpone => throw ex
| Exception.ex Elab.Exception.unsupportedSyntax => throw ex
| Exception.ex (Elab.Exception.error errMsg) => do
eType? ← unfoldDefinition? ref eType;
eType? ← unfoldDefinition? eType;
match eType? with
| some eType => resolveLValLoop eType (previousExceptions.push errMsg)
| none => do
@ -378,25 +380,25 @@ private partial def resolveLValLoop (ref : Syntax) (e : Expr) (lval : LVal) : Ex
logMessage errMsg;
throw (Exception.ex (Elab.Exception.error errMsg)))
private def resolveLVal (ref : Syntax) (e : Expr) (lval : LVal) : TermElabM LValResolution := do
eType ← inferType ref e;
resolveLValLoop ref e lval eType #[]
private def resolveLVal (e : Expr) (lval : LVal) : TermElabM LValResolution := do
eType ← inferType e;
resolveLValLoop e lval eType #[]
private partial def mkBaseProjections (ref : Syntax) (baseStructName : Name) (structName : Name) (e : Expr) : TermElabM Expr := do
private partial def mkBaseProjections (baseStructName : Name) (structName : Name) (e : Expr) : TermElabM Expr := do
env ← getEnv;
match getPathToBaseStructure? env baseStructName structName with
| none => throwError ref "failed to access field in parent structure"
| none => throwError "failed to access field in parent structure"
| some path =>
path.foldlM
(fun e projFunName => do
projFn ← mkConst ref projFunName;
elabAppArgs ref projFn #[{ name := `self, val := Arg.expr e }] #[] none false)
projFn ← mkConst projFunName;
elabAppArgs projFn #[{ name := `self, val := Arg.expr e }] #[] none false)
e
/- Auxiliary method for field notation. It tries to add `e` to `args` as the first explicit parameter
which takes an element of type `(C ...)` where `C` is `baseName`.
`fullName` is the name of the resolved "field" access function. It is used for reporting errors -/
private def addLValArg (ref : Syntax) (baseName : Name) (fullName : Name) (e : Expr) (args : Array Arg) : Nat → Array NamedArg → Expr → TermElabM (Array Arg)
private def addLValArg (baseName : Name) (fullName : Name) (e : Expr) (args : Array Arg) : Nat → Array NamedArg → Expr → TermElabM (Array Arg)
| i, namedArgs, Expr.forallE n d b c =>
if !c.binderInfo.isExplicit then
addLValArg i namedArgs b
@ -412,60 +414,60 @@ private def addLValArg (ref : Syntax) (baseName : Name) (fullName : Name) (e : E
else if i < args.size then
addLValArg (i+1) namedArgs b
else
throwError ref $ "invalid field notation, insufficient number of arguments for '" ++ fullName ++ "'"
throwError $ "invalid field notation, insufficient number of arguments for '" ++ fullName ++ "'"
| _, _, fType =>
throwError ref $
throwError $
"invalid field notation, function '" ++ fullName ++ "' does not have explicit argument with type (" ++ baseName ++ " ...)"
private def elabAppLValsAux (ref : Syntax) (namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) (explicit : Bool)
private def elabAppLValsAux (namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) (explicit : Bool)
: Expr → List LVal → TermElabM Expr
| f, [] => elabAppArgs ref f namedArgs args expectedType? explicit
| f, [] => elabAppArgs f namedArgs args expectedType? explicit
| f, lval::lvals => do
lvalRes ← resolveLVal ref f lval;
lvalRes ← resolveLVal f lval;
match lvalRes with
| LValResolution.projIdx structName idx =>
let f := mkProj structName idx f;
elabAppLValsAux f lvals
| LValResolution.projFn baseStructName structName fieldName => do
f ← mkBaseProjections ref baseStructName structName f;
projFn ← mkConst ref (baseStructName ++ fieldName);
f ← mkBaseProjections baseStructName structName f;
projFn ← mkConst (baseStructName ++ fieldName);
if lvals.isEmpty then do
namedArgs ← addNamedArg ref namedArgs { name := `self, val := Arg.expr f };
elabAppArgs ref projFn namedArgs args expectedType? explicit
namedArgs ← addNamedArg namedArgs { name := `self, val := Arg.expr f };
elabAppArgs projFn namedArgs args expectedType? explicit
else do
f ← elabAppArgs ref projFn #[{ name := `self, val := Arg.expr f }] #[] none false;
f ← elabAppArgs projFn #[{ name := `self, val := Arg.expr f }] #[] none false;
elabAppLValsAux f lvals
| LValResolution.const baseName constName => do
projFn ← mkConst ref constName;
projFn ← mkConst constName;
if lvals.isEmpty then do
projFnType ← inferType ref projFn;
args ← addLValArg ref baseName constName f args 0 namedArgs projFnType;
elabAppArgs ref projFn namedArgs args expectedType? explicit
projFnType ← inferType projFn;
args ← addLValArg baseName constName f args 0 namedArgs projFnType;
elabAppArgs projFn namedArgs args expectedType? explicit
else do
f ← elabAppArgs ref projFn #[] #[Arg.expr f] none false;
f ← elabAppArgs projFn #[] #[Arg.expr f] none false;
elabAppLValsAux f lvals
| LValResolution.localRec baseName fullName fvar =>
if lvals.isEmpty then do
fvarType ← inferType ref fvar;
args ← addLValArg ref baseName fullName f args 0 namedArgs fvarType;
elabAppArgs ref fvar namedArgs args expectedType? explicit
fvarType ← inferType fvar;
args ← addLValArg baseName fullName f args 0 namedArgs fvarType;
elabAppArgs fvar namedArgs args expectedType? explicit
else do
f ← elabAppArgs ref fvar #[] #[Arg.expr f] none false;
f ← elabAppArgs fvar #[] #[Arg.expr f] none false;
elabAppLValsAux f lvals
| LValResolution.getOp fullName idx => do
getOpFn ← mkConst ref fullName;
getOpFn ← mkConst fullName;
if lvals.isEmpty then do
namedArgs ← addNamedArg ref namedArgs { name := `self, val := Arg.expr f };
namedArgs ← addNamedArg ref namedArgs { name := `idx, val := Arg.stx idx };
elabAppArgs ref getOpFn namedArgs args expectedType? explicit
namedArgs ← addNamedArg namedArgs { name := `self, val := Arg.expr f };
namedArgs ← addNamedArg namedArgs { name := `idx, val := Arg.stx idx };
elabAppArgs getOpFn namedArgs args expectedType? explicit
else do
f ← elabAppArgs ref getOpFn #[{ name := `self, val := Arg.expr f }, { name := `idx, val := Arg.stx idx }] #[] none false;
f ← elabAppArgs getOpFn #[{ name := `self, val := Arg.expr f }, { name := `idx, val := Arg.stx idx }] #[] none false;
elabAppLValsAux f lvals
private def elabAppLVals (ref : Syntax) (f : Expr) (lvals : List LVal) (namedArgs : Array NamedArg) (args : Array Arg)
private def elabAppLVals (f : Expr) (lvals : List LVal) (namedArgs : Array NamedArg) (args : Array Arg)
(expectedType? : Option Expr) (explicit : Bool) : TermElabM Expr := do
when (!lvals.isEmpty && explicit) $ throwError ref "invalid use of field notation with `@` modifier";
elabAppLValsAux ref namedArgs args expectedType? explicit f lvals
when (!lvals.isEmpty && explicit) $ throwError "invalid use of field notation with `@` modifier";
elabAppLValsAux namedArgs args expectedType? explicit f lvals
def elabExplicitUniv (stx : Syntax) : TermElabM (List Level) := do
let lvls := stx.getArg 1;
@ -496,28 +498,28 @@ false, no elaboration function executed by `x` will reset it to
`true`.
-/
private partial def elabAppFnId (ref : Syntax) (fIdent : Syntax) (fExplicitUnivs : List Level) (lvals : List LVal)
private partial def elabAppFnId (fIdent : Syntax) (fExplicitUnivs : List Level) (lvals : List LVal)
(namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) (explicit : Bool) (acc : Array TermElabResult)
: TermElabM (Array TermElabResult) :=
match fIdent with
| Syntax.ident _ _ n preresolved => do
funLVals ← resolveName fIdent n preresolved fExplicitUnivs;
funLVals ← withRef fIdent $ resolveName n preresolved fExplicitUnivs;
-- Set `errToSorry` to `false` if `funLVals` > 1. See comment above about the interaction between `errToSorry` and `observing`.
adaptReader (fun (ctx : Context) => { ctx with errToSorry := funLVals.length == 1 && ctx.errToSorry }) $
funLVals.foldlM
(fun acc ⟨f, fields⟩ => do
let lvals' := fields.map LVal.fieldName;
s ← observing $ elabAppLVals ref f (lvals' ++ lvals) namedArgs args expectedType? explicit;
s ← observing $ elabAppLVals f (lvals' ++ lvals) namedArgs args expectedType? explicit;
pure $ acc.push s)
acc
| _ => throwUnsupportedSyntax
private partial def elabAppFn (ref : Syntax) : Syntax → List LVal → Array NamedArg → Array Arg → Option Expr → Bool → Array TermElabResult → TermElabM (Array TermElabResult)
private partial def elabAppFn : Syntax → List LVal → Array NamedArg → Array Arg → Option Expr → Bool → Array TermElabResult → TermElabM (Array TermElabResult)
| f, lvals, namedArgs, args, expectedType?, explicit, acc =>
if f.isIdent then
-- A raw identifier is not a valid Term. Recall that `Term.id` is defined as `parser! ident >> optional (explicitUniv <|> namedPattern)`
-- We handle it here to make macro development more comfortable.
elabAppFnId ref f [] lvals namedArgs args expectedType? explicit acc
elabAppFnId f [] lvals namedArgs args expectedType? explicit acc
else if f.getKind == choiceKind then
-- Set `errToSorry` to `false` when processing choice nodes. See comment above about the interaction between `errToSorry` and `observing`.
adaptReader (fun (ctx : Context) => { ctx with errToSorry := false }) $
@ -532,18 +534,18 @@ private partial def elabAppFn (ref : Syntax) : Syntax → List LVal → Array Na
| `($e[$idx]) =>
elabAppFn e (LVal.getOp idx :: lvals) namedArgs args expectedType? explicit acc
| `($id:ident@$t:term) =>
throwError ref "unexpected occurrence of named pattern"
throwError "unexpected occurrence of named pattern"
| `($id:ident$us:explicitUniv*) => do
-- Remark: `id.<namedPattern>` should already have been expanded
us ← if us.isEmpty then pure [] else elabExplicitUniv (us.get! 0);
elabAppFnId ref id us lvals namedArgs args expectedType? explicit acc
elabAppFnId id us lvals namedArgs args expectedType? explicit acc
| `(@$id:id) =>
elabAppFn id lvals namedArgs args expectedType? true acc
| `(@$t) => throwUnsupportedSyntax -- invalid occurrence of `@`
| _ => do
s ← observing $ do {
f ← elabTerm f none;
elabAppLVals ref f lvals namedArgs args expectedType? explicit
elabAppLVals f lvals namedArgs args expectedType? explicit
};
pure $ acc.push s
@ -565,15 +567,15 @@ msgs ← failures.mapM $ fun failure =>
match failure with
| EStateM.Result.ok _ _ => unreachable!
| EStateM.Result.error errMsg s => toMessageData errMsg stx;
throwError stx ("overloaded, errors " ++ MessageData.ofArray msgs)
throwErrorAt stx ("overloaded, errors " ++ MessageData.ofArray msgs)
private def elabAppAux (ref : Syntax) (f : Syntax) (namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) : TermElabM Expr := do
private def elabAppAux (f : Syntax) (namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) : TermElabM Expr := do
/- TODO: if `f` contains `choice` or overloaded symbols, `mayPostpone == true`, and `expectedType? == some ?m` where `?m` is not assigned,
then we should postpone until `?m` is assigned.
Another (more expensive) option is: execute, and if successes > 1, `mayPostpone == true`, and `expectedType? == some ?m` where `?m` is not assigned,
then we postpone `elabAppAux`. It is more expensive because we would have to re-elaborate the whole thing after we assign `?m`.
We **can't** continue from `TermElabResult` since they contain a snapshot of the state, and state has changed. -/
candidates ← elabAppFn ref f [] namedArgs args expectedType? false #[];
candidates ← elabAppFn f [] namedArgs args expectedType? false #[];
if candidates.size == 1 then
applyResult $ candidates.get! 0
else
@ -586,7 +588,7 @@ else
let msgs : Array MessageData := successes.map $ fun success => match success with
| EStateM.Result.ok e s => MessageData.withContext { env := s.env, mctx := s.mctx, lctx := lctx, opts := opts } e
| _ => unreachable!;
throwError f ("ambiguous, possible interpretations " ++ MessageData.ofArray msgs)
throwErrorAt f ("ambiguous, possible interpretations " ++ MessageData.ofArray msgs)
else
mergeFailures candidates f
@ -599,7 +601,7 @@ let f := stx.getArg 0;
-- tparser! try ("(" >> ident >> " := ") >> termParser >> ")"
let name := (stx.getArg 1).getId.eraseMacroScopes;
let val := stx.getArg 3;
namedArgs ← addNamedArg stx namedArgs { name := name, val := Arg.stx val };
namedArgs ← addNamedArg namedArgs { name := name, val := Arg.stx val };
pure (namedArgs, args)
else
pure (namedArgs, args.push $ Arg.stx stx))
@ -609,10 +611,10 @@ pure (f, namedArgs, args)
@[builtinTermElab app] def elabApp : TermElab :=
fun stx expectedType? => do
(f, namedArgs, args) ← expandApp stx;
elabAppAux stx f namedArgs args expectedType?
elabAppAux f namedArgs args expectedType?
def elabAtom : TermElab :=
fun stx expectedType? => elabAppAux stx stx #[] #[] expectedType?
fun stx expectedType? => elabAppAux stx #[] #[] expectedType?
@[builtinTermElab «id»] def elabId : TermElab := elabAtom

82
stage0/src/Lean/Elab/Binders.lean
View file

@ -38,15 +38,15 @@ structure BinderView :=
(id : Syntax) (type : Syntax) (bi : BinderInfo)
partial def quoteAutoTactic : Syntax → TermElabM Syntax
| stx@(Syntax.ident _ _ _ _) => throwError stx "invalic auto tactic, identifier is not allowed"
| stx@(Syntax.ident _ _ _ _) => throwErrorAt stx "invalic auto tactic, identifier is not allowed"
| stx@(Syntax.node k args) =>
if Quotation.isAntiquot stx then
throwError stx "invalic auto tactic, antiquotation is not allowed"
throwErrorAt stx "invalic auto tactic, antiquotation is not allowed"
else do
empty ← `(Array.empty);
args ← args.foldlM (fun args arg =>
if k == nullKind && Quotation.isAntiquotSplice arg then
throwError arg "invalic auto tactic, antiquotation is not allowed"
throwErrorAt arg "invalic auto tactic, antiquotation is not allowed"
else do
arg ← quoteAutoTactic arg;
`(Array.push $args $arg)) empty;
@ -60,11 +60,11 @@ withFreshMacroScope $ do
let type := Lean.mkConst `Lean.Syntax;
tactic ← quoteAutoTactic tactic;
val ← elabTerm tactic type;
val ← instantiateMVars tactic val;
trace `Elab.autoParam tactic $ fun _ => val;
val ← instantiateMVars val;
trace `Elab.autoParam $ fun _ => val;
let decl := Declaration.defnDecl { name := name, lparams := [], type := type, value := val, hints := ReducibilityHints.opaque, isUnsafe := false };
addDecl tactic decl;
compileDecl tactic decl;
addDecl decl;
compileDecl decl;
pure name
/-
@ -96,7 +96,7 @@ ids.getArgs.mapM $ fun id =>
-- The parser never generates this case, but it is convenient when writting macros.
pure (id.getArg 0)
else
throwError id "identifier or `_` expected"
throwErrorAt id "identifier or `_` expected"
private def matchBinder (stx : Syntax) : TermElabM (Array BinderView) :=
match stx with
@ -132,14 +132,14 @@ private partial def elabBinderViews (binderViews : Array BinderView)
| i, fvars, lctx, localInsts =>
if h : i < binderViews.size then
let binderView := binderViews.get ⟨i, h⟩;
withLCtx lctx localInsts $ do
withRef binderView.type $ withLCtx lctx localInsts $ do
type ← elabType binderView.type;
fvarId ← mkFreshFVarId;
let fvar := mkFVar fvarId;
let fvars := fvars.push fvar;
-- dbgTrace (toString binderView.id.getId ++ " : " ++ toString type);
let lctx := lctx.mkLocalDecl fvarId binderView.id.getId type binderView.bi;
className? ← isClass binderView.type type;
className? ← isClass type;
match className? with
| none => elabBinderViews (i+1) fvars lctx localInsts
| some className => do
@ -180,7 +180,7 @@ fun stx _ => match_syntax stx with
| `(forall $binders*, $term) =>
elabBinders binders $ fun xs => do
e ← elabType term;
mkForall stx xs e
mkForall xs e
| _ => throwUnsupportedSyntax
@[builtinTermElab arrow] def elabArrow : TermElab :=
@ -195,7 +195,7 @@ fun stx _ =>
let term := stx.getArg 2;
elabBinders #[binder] $ fun xs => do
e ← elabType term;
mkForall stx xs e
mkForall xs e
/-- Main loop `getFunBinderIds?` -/
private partial def getFunBinderIdsAux? : Bool → Syntax → Array Syntax → TermElabM (Option (Array Syntax))
@ -257,7 +257,7 @@ private partial def expandFunBindersAux (binders : Array Syntax) : Syntax → Na
| binder =>
match binder.isTermId? true with
| some (ident, extra) => do
unless extra.isNone $ throwError binder "invalid binder, simple identifier expected";
unless extra.isNone $ throwErrorAt binder "invalid binder, simple identifier expected";
let type := mkHole binder;
expandFunBindersAux body (i+1) (newBinders.push $ mkExplicitBinder ident type)
| none => processAsPattern ()
@ -290,22 +290,22 @@ structure State :=
(localInsts : LocalInstances)
(expectedType? : Option Expr := none)
private def checkNoOptAutoParam (ref : Syntax) (type : Expr) : TermElabM Unit := do
type ← instantiateMVars ref type;
private def checkNoOptAutoParam (type : Expr) : TermElabM Unit := do
type ← instantiateMVars type;
when type.isOptParam $
throwError ref "optParam is not allowed at 'fun/λ' binders";
throwError "optParam is not allowed at 'fun/λ' binders";
when type.isAutoParam $
throwError ref "autoParam is not allowed at 'fun/λ' binders"
throwError "autoParam is not allowed at 'fun/λ' binders"
private def propagateExpectedType (ref : Syntax) (fvar : Expr) (fvarType : Expr) (s : State) : TermElabM State := do
private def propagateExpectedType (fvar : Expr) (fvarType : Expr) (s : State) : TermElabM State := do
match s.expectedType? with
| none => pure s
| some expectedType => do
expectedType ← whnfForall ref expectedType;
expectedType ← whnfForall expectedType;
match expectedType with
| Expr.forallE _ d b _ => do
_ ← isDefEq ref fvarType d;
checkNoOptAutoParam ref fvarType;
_ ← isDefEq fvarType d;
checkNoOptAutoParam fvarType;
let b := b.instantiate1 fvar;
pure { s with expectedType? := some b }
| _ => pure { s with expectedType? := none }
@ -314,9 +314,9 @@ private partial def elabFunBinderViews (binderViews : Array BinderView) : Nat
| i, s =>
if h : i < binderViews.size then
let binderView := binderViews.get ⟨i, h⟩;
withLCtx s.lctx s.localInsts $ do
withRef binderView.type $ withLCtx s.lctx s.localInsts $ do
type ← elabType binderView.type;
checkNoOptAutoParam binderView.type type;
checkNoOptAutoParam type;
fvarId ← mkFreshFVarId;
let fvar := mkFVar fvarId;
let s := { s with fvars := s.fvars.push fvar };
@ -327,9 +327,9 @@ private partial def elabFunBinderViews (binderViews : Array BinderView) : Nat
We do not believe this is an useful feature, and it would complicate the logic here.
-/
let lctx := s.lctx.mkLocalDecl fvarId binderView.id.getId type binderView.bi;
s ← propagateExpectedType binderView.id fvar type s;
s ← withRef binderView.id $ propagateExpectedType fvar type s;
let s := { s with lctx := lctx };
className? ← isClass binderView.type type;
className? ← isClass type;
match className? with
| none => elabFunBinderViews (i+1) s
| some className => do
@ -367,7 +367,7 @@ let body := stx.getArg 3;
(binders, body) ← expandFunBinders binders body;
elabFunBinders binders expectedType? $ fun xs expectedType? => do {
e ← elabTerm body expectedType?;
mkLambda stx xs e
mkLambda xs e
}
/-
@ -384,36 +384,36 @@ else
/- If `useLetExpr` is true, then a kernel let-expression `let x : type := val; body` is created.
Otherwise, we create a term of the form `(fun (x : type) => body) val` -/
def elabLetDeclAux (ref : Syntax) (n : Name) (binders : Array Syntax) (typeStx : Syntax) (valStx : Syntax) (body : Syntax)
def elabLetDeclAux (n : Name) (binders : Array Syntax) (typeStx : Syntax) (valStx : Syntax) (body : Syntax)
(expectedType? : Option Expr) (useLetExpr : Bool) : TermElabM Expr := do
(type, val) ← elabBinders binders $ fun xs => do {
type ← elabType typeStx;
val ← elabTerm valStx type;
val ← ensureHasType valStx type val;
type ← mkForall ref xs type;
val ← mkLambda ref xs val;
val ← withRef valStx $ ensureHasType type val;
type ← mkForall xs type;
val ← mkLambda xs val;
pure (type, val)
};
trace `Elab.let.decl ref $ fun _ => n ++ " : " ++ type ++ " := " ++ val;
trace `Elab.let.decl $ fun _ => n ++ " : " ++ type ++ " := " ++ val;
if useLetExpr then
withLetDecl ref n type val $ fun x => do
withLetDecl n type val $ fun x => do
body ← elabTerm body expectedType?;
body ← instantiateMVars ref body;
mkLet ref x body
body ← instantiateMVars body;
mkLet x body
else do
f ← withLocalDecl ref n BinderInfo.default type $ fun x => do {
f ← withLocalDecl n BinderInfo.default type $ fun x => do {
body ← elabTerm body expectedType?;
body ← instantiateMVars ref body;
mkLambda ref #[x] body
body ← instantiateMVars body;
mkLambda #[x] body
};
pure $ mkApp f val
@[builtinTermElab «let»] def elabLetDecl : TermElab :=
fun stx expectedType? => match_syntax stx with
| `(let $id:ident $args* := $val; $body) =>
elabLetDeclAux stx id.getId args (mkHole stx) val body expectedType? true
elabLetDeclAux id.getId args (mkHole stx) val body expectedType? true
| `(let $id:ident $args* : $type := $val; $body) =>
elabLetDeclAux stx id.getId args type val body expectedType? true
elabLetDeclAux id.getId args type val body expectedType? true
| `(let $pat:term := $val; $body) => do
stxNew ← `(let x := $val; match x with $pat => $body);
withMacroExpansion stx stxNew $ elabTerm stxNew expectedType?
@ -425,9 +425,9 @@ fun stx expectedType? => match_syntax stx with
@[builtinTermElab «let!»] def elabLetBangDecl : TermElab :=
fun stx expectedType? => match_syntax stx with
| `(let! $id:ident $args* := $val; $body) =>
elabLetDeclAux stx id.getId args (mkHole stx) val body expectedType? false
elabLetDeclAux id.getId args (mkHole stx) val body expectedType? false
| `(let! $id:ident $args* : $type := $val; $body) =>
elabLetDeclAux stx id.getId args type val body expectedType? false
elabLetDeclAux id.getId args type val body expectedType? false
| `(let! $pat:term := $val; $body) => do
stxNew ← `(let! x := $val; match x with $pat => $body);
withMacroExpansion stx stxNew $ elabTerm stxNew expectedType?

89
stage0/src/Lean/Elab/BuiltinNotation.lean
View file

@ -37,11 +37,10 @@ fun stx => match_syntax stx with
@[builtinTermElab anonymousCtor] def elabAnonymousCtor : TermElab :=
fun stx expectedType? => match_syntax stx with
| `(⟨$args*⟩) => do
let ref := stx;
tryPostponeIfNoneOrMVar expectedType?;
match expectedType? with
| some expectedType => do
expectedType ← instantiateMVars ref expectedType;
expectedType ← instantiateMVars expectedType;
let expectedType := expectedType.consumeMData;
match expectedType.getAppFn with
| Expr.const constName _ _ => do
@ -50,12 +49,12 @@ fun stx expectedType? => match_syntax stx with
| some (ConstantInfo.inductInfo val) =>
match val.ctors with
| [ctor] => do
stx ← `($(mkCTermIdFrom ref ctor) $(args.getSepElems)*);
withMacroExpansion ref stx $ elabTerm stx expectedType?
| _ => throwError ref ("invalid constructor ⟨...⟩, '" ++ constName ++ "' must have only one constructor")
| _ => throwError ref ("invalid constructor ⟨...⟩, '" ++ constName ++ "' is not an inductive type")
| _ => throwError ref ("invalid constructor ⟨...⟩, expected type is not an inductive type " ++ indentExpr expectedType)
| none => throwError ref "invalid constructor ⟨...⟩, expected type must be known"
newStx ← `($(mkCTermIdFrom stx ctor) $(args.getSepElems)*);
withMacroExpansion stx newStx $ elabTerm newStx expectedType?
| _ => throwError ("invalid constructor ⟨...⟩, '" ++ constName ++ "' must have only one constructor")
| _ => throwError ("invalid constructor ⟨...⟩, '" ++ constName ++ "' is not an inductive type")
| _ => throwError ("invalid constructor ⟨...⟩, expected type is not an inductive type " ++ indentExpr expectedType)
| none => throwError "invalid constructor ⟨...⟩, expected type must be known"
| _ => throwUnsupportedSyntax
@[builtinMacro Lean.Parser.Term.show] def expandShow : Macro :=
@ -80,9 +79,9 @@ fun stx => match_syntax stx with
body
| _ => Macro.throwUnsupported
private def elabParserMacroAux (ref : Syntax) (prec : Syntax) (e : Syntax) : TermElabM Syntax := do
private def elabParserMacroAux (prec : Syntax) (e : Syntax) : TermElabM Syntax := do
some declName ← getDeclName?
| throwError ref "invalid `parser!` macro, it must be used in definitions";
| throwError "invalid `parser!` macro, it must be used in definitions";
match extractMacroScopes declName with
| { name := Name.str _ s _, scopes := scps, .. } => do
let kind := quote declName;
@ -94,76 +93,76 @@ match extractMacroScopes declName with
else
-- if the parser decl is hidden by hygiene, it doesn't make sense to provide an antiquotation kind
`(HasOrelse.orelse (Lean.Parser.mkAntiquot $s none) $p)
| _ => throwError ref "invalid `parser!` macro, unexpected declaration name"
| _ => throwError "invalid `parser!` macro, unexpected declaration name"
@[builtinTermElab «parser!»] def elabParserMacro : TermElab :=
adaptExpander $ fun stx => match_syntax stx with
| `(parser! $e) => elabParserMacroAux stx (quote Parser.maxPrec) e
| `(parser! : $prec $e) => elabParserMacroAux stx prec e
| `(parser! $e) => elabParserMacroAux (quote Parser.maxPrec) e
| `(parser! : $prec $e) => elabParserMacroAux prec e
| _ => throwUnsupportedSyntax
private def elabTParserMacroAux (ref : Syntax) (prec : Syntax) (e : Syntax) : TermElabM Syntax := do
private def elabTParserMacroAux (prec : Syntax) (e : Syntax) : TermElabM Syntax := do
declName? ← getDeclName?;
match declName? with
| some declName => let kind := quote declName; `(Lean.Parser.trailingNode $kind $prec $e)
| none => throwError ref "invalid `tparser!` macro, it must be used in definitions"
| none => throwError "invalid `tparser!` macro, it must be used in definitions"
@[builtinTermElab «tparser!»] def elabTParserMacro : TermElab :=
adaptExpander $ fun stx => match_syntax stx with
| `(tparser! $e) => elabTParserMacroAux stx (quote Parser.maxPrec) e
| `(tparser! : $prec $e) => elabTParserMacroAux stx prec e
| `(tparser! $e) => elabTParserMacroAux (quote Parser.maxPrec) e
| `(tparser! : $prec $e) => elabTParserMacroAux prec e
| _ => throwUnsupportedSyntax
private def mkNativeReflAuxDecl (ref : Syntax) (type val : Expr) : TermElabM Name := do
auxName ← mkAuxName ref `_nativeRefl;
private def mkNativeReflAuxDecl (type val : Expr) : TermElabM Name := do
auxName ← mkAuxName `_nativeRefl;
let decl := Declaration.defnDecl {
name := auxName, lparams := [], type := type, value := val,
hints := ReducibilityHints.abbrev,
isUnsafe := false };
addDecl ref decl;
compileDecl ref decl;
addDecl decl;
compileDecl decl;
pure auxName
private def elabClosedTerm (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
e ← elabTermAndSynthesize stx expectedType?;
when e.hasMVar $
throwError stx ("invalid macro application, term contains metavariables" ++ indentExpr e);
throwError ("invalid macro application, term contains metavariables" ++ indentExpr e);
when e.hasFVar $
throwError stx ("invalid macro application, term contains free variables" ++ indentExpr e);
throwError ("invalid macro application, term contains free variables" ++ indentExpr e);
pure e
@[builtinTermElab «nativeRefl»] def elabNativeRefl : TermElab :=
fun stx _ => do
let arg := stx.getArg 1;
e ← elabClosedTerm arg none;
type ← inferType stx e;
type ← whnf stx type;
type ← inferType e;
type ← whnf type;
unless (type.isConstOf `Bool || type.isConstOf `Nat) $
throwError stx ("invalid `nativeRefl!` macro application, term must have type `Nat` or `Bool`" ++ indentExpr type);
auxDeclName ← mkNativeReflAuxDecl stx type e;
throwError ("invalid `nativeRefl!` macro application, term must have type `Nat` or `Bool`" ++ indentExpr type);
auxDeclName ← mkNativeReflAuxDecl type e;
let isBool := type.isConstOf `Bool;
let reduceValFn := if isBool then `Lean.reduceBool else `Lean.reduceNat;
let reduceThm := if isBool then `Lean.ofReduceBool else `Lean.ofReduceNat;
let aux := Lean.mkConst auxDeclName;
let reduceVal := mkApp (Lean.mkConst reduceValFn) aux;
val? ← liftMetaM stx $ Meta.reduceNative? reduceVal;
val? ← liftMetaM $ Meta.reduceNative? reduceVal;
match val? with
| none => throwError stx ("failed to reduce term at `nativeRefl!` macro application" ++ indentExpr e)
| none => throwError ("failed to reduce term at `nativeRefl!` macro application" ++ indentExpr e)
| some val => do
rflPrf ← liftMetaM stx $ Meta.mkEqRefl val;
rflPrf ← liftMetaM $ Meta.mkEqRefl val;
let r := mkApp3 (Lean.mkConst reduceThm) aux val rflPrf;
eq ← liftMetaM stx $ Meta.mkEq e val;
mkExpectedTypeHint stx r eq
eq ← liftMetaM $ Meta.mkEq e val;
mkExpectedTypeHint r eq
private def getPropToDecide (ref : Syntax) (arg : Syntax) (expectedType? : Option Expr) : TermElabM Expr :=
private def getPropToDecide (arg : Syntax) (expectedType? : Option Expr) : TermElabM Expr :=
if arg.isOfKind `Lean.Parser.Term.hole then do
tryPostponeIfNoneOrMVar expectedType?;
match expectedType? with
| none => throwError ref "invalid macro, expected type is not available"
| none => throwError "invalid macro, expected type is not available"
| some expectedType => do
expectedType ← instantiateMVars ref expectedType;
expectedType ← instantiateMVars expectedType;
when (expectedType.hasFVar || expectedType.hasMVar) $
throwError ref ("expected type must not contain free or meta variables" ++ indentExpr expectedType);
throwError ("expected type must not contain free or meta variables" ++ indentExpr expectedType);
pure expectedType
else
let prop := mkSort levelZero;
@ -172,21 +171,21 @@ else
@[builtinTermElab «nativeDecide»] def elabNativeDecide : TermElab :=
fun stx expectedType? => do
let arg := stx.getArg 1;
p ← getPropToDecide stx arg expectedType?;
d ← mkAppM stx `Decidable.decide #[p];
auxDeclName ← mkNativeReflAuxDecl stx (Lean.mkConst `Bool) d;
rflPrf ← liftMetaM stx $ Meta.mkEqRefl (toExpr true);
p ← getPropToDecide arg expectedType?;
d ← mkAppM `Decidable.decide #[p];
auxDeclName ← mkNativeReflAuxDecl (Lean.mkConst `Bool) d;
rflPrf ← liftMetaM $ Meta.mkEqRefl (toExpr true);
let r := mkApp3 (Lean.mkConst `Lean.ofReduceBool) (Lean.mkConst auxDeclName) (toExpr true) rflPrf;
mkExpectedTypeHint stx r p
mkExpectedTypeHint r p
@[builtinTermElab Lean.Parser.Term.decide] def elabDecide : TermElab :=
fun stx expectedType? => do
let arg := stx.getArg 1;
p ← getPropToDecide stx arg expectedType?;
d ← mkAppM stx `Decidable.decide #[p];
d ← instantiateMVars stx d;
p ← getPropToDecide arg expectedType?;
d ← mkAppM `Decidable.decide #[p];
d ← instantiateMVars d;
let s := d.appArg!; -- get instance from `d`
rflPrf ← liftMetaM stx $ Meta.mkEqRefl (toExpr true);
rflPrf ← liftMetaM $ Meta.mkEqRefl (toExpr true);
pure $ mkApp3 (Lean.mkConst `ofDecideEqTrue) p s rflPrf
def elabInfix (f : Syntax) : Macro :=

16
stage0/src/Lean/Elab/CollectFVars.lean
View file

@ -10,26 +10,26 @@ namespace Lean
namespace Elab
namespace Term
def collectUsedFVars (ref : Syntax) (used : CollectFVars.State) (e : Expr) : TermElabM CollectFVars.State := do
e ← Term.instantiateMVars ref e;
def collectUsedFVars (used : CollectFVars.State) (e : Expr) : TermElabM CollectFVars.State := do
e ← Term.instantiateMVars e;
pure $ collectFVars used e
def collectUsedFVarsAtFVars (ref : Syntax) (used : CollectFVars.State) (fvars : Array Expr) : TermElabM CollectFVars.State :=
def collectUsedFVarsAtFVars (used : CollectFVars.State) (fvars : Array Expr) : TermElabM CollectFVars.State :=
fvars.foldlM
(fun used fvar => do
fvarType ← Term.inferType ref fvar;
collectUsedFVars ref used fvarType)
fvarType ← Term.inferType fvar;
collectUsedFVars used fvarType)
used
def removeUnused (ref : Syntax) (vars : Array Expr) (used : CollectFVars.State) : TermElabM (LocalContext × LocalInstances × Array Expr) := do
def removeUnused (vars : Array Expr) (used : CollectFVars.State) : TermElabM (LocalContext × LocalInstances × Array Expr) := do
localInsts ← Term.getLocalInsts;
lctx ← Term.getLCtx;
(lctx, localInsts, newVars, _) ← vars.foldrM
(fun var (result : LocalContext × LocalInstances × Array Expr × CollectFVars.State) =>
let (lctx, localInsts, newVars, used) := result;
if used.fvarSet.contains var.fvarId! then do
varType ← Term.inferType ref var;
used ← Term.collectUsedFVars ref used varType;
varType ← Term.inferType var;
used ← Term.collectUsedFVars used varType;
pure (lctx, localInsts, newVars.push var, used)
else
pure (lctx.erase var.fvarId!, localInsts.erase var.fvarId!, newVars, used))

30
stage0/src/Lean/Elab/Command.lean
View file

@ -500,7 +500,7 @@ fun stx => do
withoutModifyingEnv $ runTermElabM (some `_check) $ fun _ => do
e ← Term.elabTerm term none;
Term.synthesizeSyntheticMVars false;
type ← Term.inferType stx e;
type ← Term.inferType e;
logInfo stx (e ++ " : " ++ type);
pure ()
@ -531,8 +531,8 @@ when succeeded $
@[builtinCommandElab «check_failure»] def elabCheckFailure : CommandElab :=
fun stx => failIfSucceeds stx $ elabCheck stx
def addDecl (ref : Syntax) (decl : Declaration) : CommandElabM Unit := liftTermElabM none $ Term.addDecl ref decl
def compileDecl (ref : Syntax) (decl : Declaration) : CommandElabM Unit := liftTermElabM none $ Term.compileDecl ref decl
def addDecl (decl : Declaration) : CommandElabM Unit := liftTermElabM none $ Term.addDecl decl
def compileDecl (decl : Declaration) : CommandElabM Unit := liftTermElabM none $ Term.compileDecl decl
def addInstance (ref : Syntax) (declName : Name) : CommandElabM Unit := do
env ← getEnv;
@ -547,26 +547,26 @@ fun stx => withoutModifyingEnv do
ctx ← read;
env ← getEnv;
let addAndCompile (value : Expr) : TermElabM Unit := do {
type ← Term.inferType ref value;
type ← Term.inferType value;
let decl := Declaration.defnDecl { name := n, lparams := [], type := type,
value := value, hints := ReducibilityHints.opaque, isUnsafe := true };
Term.addDecl ref decl;
Term.compileDecl ref decl
Term.addDecl decl;
Term.compileDecl decl
};
let elabMetaEval : CommandElabM Unit := do {
act : IO Environment ← runTermElabM (some n) fun _ => do {
e ← Term.elabTerm term none;
Term.synthesizeSyntheticMVars false;
e ← Term.withLocalDecl ref `env BinderInfo.default (mkConst `Lean.Environment) fun env =>
Term.withLocalDecl ref `opts BinderInfo.default (mkConst `Lean.Options) fun opts => do {
e ← Term.mkAppM ref `Lean.MetaHasEval.eval #[env, opts, e, toExpr false];
Term.mkLambda ref #[env, opts] e
e ← Term.withLocalDecl `env BinderInfo.default (mkConst `Lean.Environment) fun env =>
Term.withLocalDecl `opts BinderInfo.default (mkConst `Lean.Options) fun opts => do {
e ← Term.mkAppM `Lean.MetaHasEval.eval #[env, opts, e, toExpr false];
Term.mkLambda #[env, opts] e
};
addAndCompile e;
env ← Term.getEnv;
opts ← Term.getOptions;
match env.evalConst (Environment → Options → IO Environment) n with
| Except.error e => Term.throwError ref e
| Except.error e => Term.throwError e
| Except.ok act => pure $ act env opts
};
(out, res) ← liftIO ref $ IO.Prim.withIsolatedStreams act;
@ -581,11 +581,11 @@ fun stx => withoutModifyingEnv do
act : IO Unit ← runTermElabM (some n) fun _ => do {
e ← Term.elabTerm term none;
Term.synthesizeSyntheticMVars false;
e ← Term.mkAppM ref `Lean.HasEval.eval #[e, toExpr false];
e ← Term.mkAppM `Lean.HasEval.eval #[e, toExpr false];
addAndCompile e;
env ← Term.getEnv;
match env.evalConst (IO Unit) n with
| Except.error e => Term.throwError ref e
| Except.error e => Term.throwError e
| Except.ok act => pure act
};
(out, res) ← liftIO ref $ IO.Prim.withIsolatedStreams act;
@ -609,8 +609,8 @@ fun stx => do
withoutModifyingEnv $ runTermElabM `_synth_cmd $ fun _ => do
inst ← Term.elabTerm term none;
Term.synthesizeSyntheticMVars false;
inst ← Term.instantiateMVars ref inst;
val ← Term.liftMetaM ref $ Meta.synthInstance inst;
inst ← Term.instantiateMVars inst;
val ← Term.liftMetaM $ Meta.synthInstance inst;
logInfo stx val;
pure ()

10
stage0/src/Lean/Elab/Declaration.lean
View file

@ -87,13 +87,13 @@ withDeclId declId $ fun name => do
decl ← runTermElabM declName $ fun vars => Term.elabBinders binders.getArgs $ fun xs => do {
type ← Term.elabType typeStx;
Term.synthesizeSyntheticMVars false;
type ← Term.instantiateMVars typeStx type;
type ← Term.mkForall typeStx xs type;
(type, _) ← Term.mkForallUsedOnly typeStx vars type;
type ← Term.instantiateMVars type;
type ← Term.mkForall xs type;
(type, _) ← Term.mkForallUsedOnly vars type;
(type, _) ← Term.levelMVarToParam type;
let usedParams := (collectLevelParams {} type).params;
match sortDeclLevelParams scopeLevelNames allUserLevelNames usedParams with
| Except.error msg => Term.throwError stx msg
| Except.error msg => Term.throwErrorAt stx msg
| Except.ok levelParams =>
pure $ Declaration.axiomDecl {
name := declName,
@ -102,7 +102,7 @@ withDeclId declId $ fun name => do
isUnsafe := modifiers.isUnsafe
}
};
addDecl stx decl;
addDecl decl;
applyAttributes stx declName modifiers.attrs AttributeApplicationTime.afterTypeChecking;
applyAttributes stx declName modifiers.attrs AttributeApplicationTime.afterCompilation

56
stage0/src/Lean/Elab/Definition.lean
View file

@ -40,55 +40,55 @@ structure DefView :=
(type? : Option Syntax)
(val : Syntax)
private def removeUnused (ref : Syntax) (vars : Array Expr) (xs : Array Expr) (e : Expr) (eType : Expr)
private def removeUnused (vars : Array Expr) (xs : Array Expr) (e : Expr) (eType : Expr)
: TermElabM (LocalContext × LocalInstances × Array Expr) := do
let used : CollectFVars.State := {};
used ← Term.collectUsedFVars ref used eType;
used ← Term.collectUsedFVars ref used e;
used ← Term.collectUsedFVarsAtFVars ref used xs;
Term.removeUnused ref vars used
used ← Term.collectUsedFVars used eType;
used ← Term.collectUsedFVars used e;
used ← Term.collectUsedFVarsAtFVars used xs;
Term.removeUnused vars used
private def withUsedWhen {α} (ref : Syntax) (vars : Array Expr) (xs : Array Expr) (e : Expr) (eType : Expr) (cond : Bool) (k : Array Expr → TermElabM α) : TermElabM α :=
private def withUsedWhen {α} (vars : Array Expr) (xs : Array Expr) (e : Expr) (eType : Expr) (cond : Bool) (k : Array Expr → TermElabM α) : TermElabM α :=
if cond then do
(lctx, localInsts, vars) ← removeUnused ref vars xs e eType;
(lctx, localInsts, vars) ← removeUnused vars xs e eType;
Term.withLCtx lctx localInsts $ k vars
else
k vars
private def withUsedWhen' {α} (ref : Syntax) (vars : Array Expr) (xs : Array Expr) (e : Expr) (cond : Bool) (k : Array Expr → TermElabM α) : TermElabM α :=
private def withUsedWhen' {α} (vars : Array Expr) (xs : Array Expr) (e : Expr) (cond : Bool) (k : Array Expr → TermElabM α) : TermElabM α :=
let dummyExpr := mkSort levelOne;
withUsedWhen ref vars xs e dummyExpr cond k
withUsedWhen vars xs e dummyExpr cond k
def mkDef (view : DefView) (declName : Name) (scopeLevelNames allUserLevelNames : List Name) (vars : Array Expr) (xs : Array Expr) (type : Expr) (val : Expr)
: TermElabM (Option Declaration) := do
let ref := view.ref;
Term.withRef view.ref do
Term.synthesizeSyntheticMVars;
val ← Term.ensureHasType view.val type val;
val ← Term.withRef view.val $ Term.ensureHasType type val;
Term.synthesizeSyntheticMVars false;
type ← Term.instantiateMVars ref type;
val ← Term.instantiateMVars view.val val;
type ← Term.instantiateMVars type;
val ← Term.instantiateMVars val;
if view.kind.isExample then pure none
else withUsedWhen ref vars xs val type view.kind.isDefOrAbbrevOrOpaque $ fun vars => do
type ← Term.mkForall ref xs type;
type ← Term.mkForall ref vars type;
val ← Term.mkLambda ref xs val;
val ← Term.mkLambda ref vars val;
else withUsedWhen vars xs val type view.kind.isDefOrAbbrevOrOpaque $ fun vars => do
type ← Term.mkForall xs type;
type ← Term.mkForall vars type;
val ← Term.mkLambda xs val;
val ← Term.mkLambda vars val;
(type, nextParamIdx) ← Term.levelMVarToParam type;
(val, _) ← Term.levelMVarToParam val nextParamIdx;
type ← Term.instantiateMVars ref type;
val ← Term.instantiateMVars view.val val;
type ← Term.instantiateMVars type;
val ← Term.instantiateMVars val;
let shareCommonTypeVal : Std.ShareCommonM (Expr × Expr) := do {
type ← Std.withShareCommon type;
val ← Std.withShareCommon val;
pure (type, val)
};
let (type, val) := shareCommonTypeVal.run;
Term.trace `Elab.definition.body ref $ fun _ => declName ++ " : " ++ type ++ " :=" ++ Format.line ++ val;
Term.trace `Elab.definition.body fun _ => declName ++ " : " ++ type ++ " :=" ++ Format.line ++ val;
let usedParams : CollectLevelParams.State := {};
let usedParams := collectLevelParams usedParams type;
let usedParams := collectLevelParams usedParams val;
match sortDeclLevelParams scopeLevelNames allUserLevelNames usedParams.params with
| Except.error msg => Term.throwError ref msg
| Except.error msg => Term.throwError msg
| Except.ok levelParams =>
match view.kind with
| DefKind.theorem =>
@ -115,7 +115,7 @@ if kind == `Lean.Parser.Command.declValSimple then
-- parser! " := " >> termParser
Term.elabTerm (defVal.getArg 1) expectedType
else if kind == `Lean.Parser.Command.declValEqns then
Term.throwError defVal "equations have not been implemented yet"
Term.throwErrorAt defVal "equations have not been implemented yet"
else
Term.throwUnsupportedSyntax
@ -131,21 +131,21 @@ withDeclId view.declId $ fun name => do
| some typeStx => do
type ← Term.elabType typeStx;
Term.synthesizeSyntheticMVars false;
type ← Term.instantiateMVars typeStx type;
withUsedWhen' ref vars xs type view.kind.isTheorem $ fun vars => do
type ← Term.instantiateMVars type;
withUsedWhen' vars xs type view.kind.isTheorem $ fun vars => do
val ← elabDefVal view.val type;
mkDef view declName scopeLevelNames allUserLevelNames vars xs type val
| none => do {
type ← Term.mkFreshTypeMVar view.binders;
type ← Term.withRef view.binders $ Term.mkFreshTypeMVar;
val ← elabDefVal view.val type;
mkDef view declName scopeLevelNames allUserLevelNames vars xs type val
};
match decl? with
| none => pure ()
| some decl => do
addDecl ref decl;
addDecl decl;
applyAttributes ref declName view.modifiers.attrs AttributeApplicationTime.afterTypeChecking;
compileDecl ref decl;
compileDecl decl;
applyAttributes ref declName view.modifiers.attrs AttributeApplicationTime.afterCompilation
@[init] private def regTraceClasses : IO Unit := do

67
stage0/src/Lean/Elab/DoNotation.lean
View file

@ -16,27 +16,27 @@ structure ExtractMonadResult :=
(α : Expr)
(hasBindInst : Expr)
private def mkIdBindFor (ref : Syntax) (type : Expr) : TermElabM ExtractMonadResult := do
u ← getLevel ref type;
private def mkIdBindFor (type : Expr) : TermElabM ExtractMonadResult := do
u ← getLevel type;
let id := Lean.mkConst `Id [u];
let idBindVal := Lean.mkConst `Id.hasBind [u];
pure { m := id, hasBindInst := idBindVal, α := type }
private def extractBind (ref : Syntax) (expectedType? : Option Expr) : TermElabM ExtractMonadResult := do
private def extractBind (expectedType? : Option Expr) : TermElabM ExtractMonadResult := do
match expectedType? with
| none => throwError ref "invalid do notation, expected type is not available"
| none => throwError "invalid do notation, expected type is not available"
| some expectedType => do
type ← withReducible $ whnf ref expectedType;
when type.getAppFn.isMVar $ throwError ref "invalid do notation, expected type is not available";
type ← withReducible $ whnf expectedType;
when type.getAppFn.isMVar $ throwError "invalid do notation, expected type is not available";
match type with
| Expr.app m α _ =>
catch
(do
bindInstType ← mkAppM ref `HasBind #[m];
bindInstVal ← synthesizeInst ref bindInstType;
bindInstType ← mkAppM `HasBind #[m];
bindInstVal ← synthesizeInst bindInstType;
pure { m := m, hasBindInst := bindInstVal, α := α })
(fun ex => mkIdBindFor ref type)
| _ => mkIdBindFor ref type
(fun ex => mkIdBindFor type)
| _ => mkIdBindFor type
private def getDoElems (stx : Syntax) : Array Syntax :=
--parser! "do " >> (bracketedDoSeq <|> doSeq)
@ -147,34 +147,34 @@ structure ProcessedDoElem :=
instance ProcessedDoElem.inhabited : Inhabited ProcessedDoElem := ⟨⟨arbitrary _, arbitrary _⟩⟩
private def extractTypeFormerAppArg (ref : Syntax) (type : Expr) : TermElabM Expr := do
type ← withReducible $ whnf ref type;
private def extractTypeFormerAppArg (type : Expr) : TermElabM Expr := do
type ← withReducible $ whnf type;
match type with
| Expr.app _ a _ => pure a
| _ => throwError ref ("type former application expected" ++ indentExpr type)
| _ => throwError ("type former application expected" ++ indentExpr type)
/-
HasBind.bind : ∀ {m : Type u_1 → Type u_2} [self : HasBind m] {α β : Type u_1}, m α → (α → m β) → m β
-/
private def mkBind (ref : Syntax) (m bindInstVal : Expr) (elems : Array ProcessedDoElem) (body : Expr) : TermElabM Expr :=
private def mkBind (m bindInstVal : Expr) (elems : Array ProcessedDoElem) (body : Expr) : TermElabM Expr :=
if elems.isEmpty then
pure body
else do
let x := elems.back.var; -- any variable would work since they must be in the same universe
xType ← inferType ref x;
u_1 ← getDecLevel ref xType;
bodyType ← inferType ref body;
u_2 ← getDecLevel ref bodyType;
xType ← inferType x;
u_1 ← getDecLevel xType;
bodyType ← inferType body;
u_2 ← getDecLevel bodyType;
let bindAndInst := mkApp2 (Lean.mkConst `HasBind.bind [u_1, u_2]) m bindInstVal;
elems.foldrM
(fun elem body => do
-- dbgTrace (">>> " ++ toString body);
let var := elem.var;
let action := elem.action;
α ← inferType ref var;
mβ ← inferType ref body;
β ← extractTypeFormerAppArg ref mβ;
f ← mkLambda ref #[var] body;
α ← inferType var;
mβ ← inferType body;
β ← extractTypeFormerAppArg mβ;
f ← mkLambda #[var] body;
-- dbgTrace (">>> f: " ++ toString f);
let body := mkAppN bindAndInst #[α, β, action, f];
pure body)
@ -184,45 +184,44 @@ private partial def processDoElemsAux (doElems : Array Syntax) (m bindInstVal :
| i, elems =>
let doElem := doElems.get! i;
let k := doElem.getKind;
let ref := doElem;
withRef doElem $
if k == `Lean.Parser.Term.doId then do
when (i == doElems.size - 1) $
throwError ref "the last statement in a 'do' block must be an expression";
throwError "the last statement in a 'do' block must be an expression";
-- try (ident >> optType >> leftArrow) >> termParser
let id := doElem.getIdAt 0;
let typeStx := expandOptType ref (doElem.getArg 1);
let typeStx := expandOptType doElem (doElem.getArg 1);
let actionStx := doElem.getArg 3;
type ← elabType typeStx;
let actionExpectedType := mkApp m type;
action ← elabTerm actionStx actionExpectedType;
action ← ensureHasType actionStx actionExpectedType action;
withLocalDecl ref id BinderInfo.default type $ fun x =>
action ← withRef actionStx $ ensureHasType actionExpectedType action;
withLocalDecl id BinderInfo.default type $ fun x =>
processDoElemsAux (i+1) (elems.push { action := action, var := x })
else if doElem.getKind == `Lean.Parser.Term.doExpr then do
when (i != doElems.size - 1) $
throwError ref ("unexpected 'do' expression element" ++ Format.line ++ doElem);
throwError ("unexpected 'do' expression element" ++ Format.line ++ doElem);
let bodyStx := doElem.getArg 0;
body ← elabTerm bodyStx expectedType;
body ← ensureHasType ref expectedType body;
mkBind ref m bindInstVal elems body
body ← ensureHasType expectedType body;
mkBind m bindInstVal elems body
else
throwError ref ("unexpected 'do' expression element" ++ Format.line ++ doElem)
throwError ("unexpected 'do' expression element" ++ Format.line ++ doElem)
private def processDoElems (doElems : Array Syntax) (m bindInstVal : Expr) (expectedType : Expr) : TermElabM Expr :=
processDoElemsAux doElems m bindInstVal expectedType 0 #[]
@[builtinTermElab «do»] def elabDo : TermElab :=
fun stx expectedType? => do
let ref := stx;
tryPostponeIfNoneOrMVar expectedType?;
let doElems := getDoElems stx;
stxNew? ← liftMacroM $ expandDoElems doElems;
match stxNew? with
| some stxNew => withMacroExpansion stx stxNew $ elabTerm stxNew expectedType?
| none => do
trace `Elab.do ref $ fun _ => stx;
trace `Elab.do $ fun _ => stx;
let doElems := doElems.getSepElems;
{ m := m, hasBindInst := bindInstVal, .. } ← extractBind ref expectedType?;
{ m := m, hasBindInst := bindInstVal, .. } ← extractBind expectedType?;
result ← processDoElems doElems m bindInstVal expectedType?.get!;
-- dbgTrace ("result: " ++ toString result);
pure result

184
stage0/src/Lean/Elab/Inductive.lean
View file

@ -81,13 +81,13 @@ private partial def elabHeaderAux (views : Array InductiveView)
localInsts ← Term.getLocalInsts;
match view.type? with
| none => do
u ← Term.mkFreshLevelMVar view.ref;
u ← Term.mkFreshLevelMVar;
let type := mkSort (mkLevelSucc u);
elabHeaderAux (i+1) (acc.push { lctx := lctx, localInsts := localInsts, params := params, type := type, view := view })
| some typeStx => do
type ← Term.elabTerm typeStx none;
unlessM (Term.isTypeFormerType view.ref type) $
Term.throwError typeStx "invalid inductive type, resultant type is not a sort";
unlessM (Term.isTypeFormerType type) $
Term.throwErrorAt typeStx "invalid inductive type, resultant type is not a sort";
elabHeaderAux (i+1) (acc.push { lctx := lctx, localInsts := localInsts, params := params, type := type, view := view })
else
pure acc
@ -95,71 +95,71 @@ private partial def elabHeaderAux (views : Array InductiveView)
private def checkNumParams (rs : Array ElabHeaderResult) : TermElabM Nat := do
let numParams := (rs.get! 0).params.size;
rs.forM fun r => unless (r.params.size == numParams) $
Term.throwError r.view.ref "invalid inductive type, number of parameters mismatch in mutually inductive datatypes";
Term.throwErrorAt r.view.ref "invalid inductive type, number of parameters mismatch in mutually inductive datatypes";
pure numParams
private def checkUnsafe (rs : Array ElabHeaderResult) : TermElabM Unit :=
let isUnsafe := (rs.get! 0).view.modifiers.isUnsafe;
rs.forM fun r => unless (r.view.modifiers.isUnsafe == isUnsafe) $
Term.throwError r.view.ref "invalid inductive type, cannot mix unsafe and safe declarations in a mutually inductive datatypes"
Term.throwErrorAt r.view.ref "invalid inductive type, cannot mix unsafe and safe declarations in a mutually inductive datatypes"
private def checkLevelNames (views : Array InductiveView) : TermElabM Unit :=
when (views.size > 1) do
let levelNames := (views.get! 0).levelNames;
views.forM fun view => unless (view.levelNames == levelNames) $
Term.throwError view.ref "invalid inductive type, universe parameters mismatch in mutually inductive datatypes"
Term.throwErrorAt view.ref "invalid inductive type, universe parameters mismatch in mutually inductive datatypes"
private def mkTypeFor (r : ElabHeaderResult) : TermElabM Expr := do
Term.withLocalContext r.lctx r.localInsts do
Term.mkForall r.view.ref r.params r.type
Term.mkForall r.params r.type
private def throwUnexpectedInductiveType {α} (ref : Syntax) : TermElabM α :=
Term.throwError ref "unexpected inductive resulting type"
private def throwUnexpectedInductiveType {α} : TermElabM α :=
Term.throwError "unexpected inductive resulting type"
-- Given `e` of the form `forall As, B`, return `B`.
private def getResultingType (ref : Syntax) (e : Expr) : TermElabM Expr :=
Term.liftMetaM ref $ Meta.forallTelescopeReducing e fun _ r => pure r
private def getResultingType (e : Expr) : TermElabM Expr :=
Term.liftMetaM $ Meta.forallTelescopeReducing e fun _ r => pure r
private def eqvFirstTypeResult (firstType type : Expr) : MetaM Bool :=
Meta.forallTelescopeReducing firstType fun _ firstTypeResult => Meta.isDefEq firstTypeResult type
-- Auxiliary function for checking whether the types in mutually inductive declaration are compatible.
private partial def checkParamsAndResultType (ref : Syntax) (numParams : Nat) : Nat → Expr → Expr → TermElabM Unit
private partial def checkParamsAndResultType (numParams : Nat) : Nat → Expr → Expr → TermElabM Unit
| i, type, firstType => do
type ← Term.whnf ref type;
type ← Term.whnf type;
if i < numParams then do
firstType ← Term.whnf ref firstType;
firstType ← Term.whnf firstType;
match type, firstType with
| Expr.forallE n₁ d₁ b₁ c₁, Expr.forallE n₂ d₂ b₂ c₂ => do
unless (n₁ == n₂) $
let msg : MessageData :=
"invalid mutually inductive types, parameter name mismatch '" ++ n₁ ++ "', expected '" ++ n₂ ++ "'";
Term.throwError ref msg;
unlessM (Term.isDefEq ref d₁ d₂) $
Term.throwError msg;
unlessM (Term.isDefEq d₁ d₂) $
let msg : MessageData :=
"invalid mutually inductive types, type mismatch at parameter '" ++ n₁ ++ "'" ++ indentExpr d₁
++ Format.line ++ "expected type" ++ indentExpr d₂;
Term.throwError ref msg;
Term.throwError msg;
unless (c₁.binderInfo == c₂.binderInfo) $
-- TODO: improve this error message?
Term.throwError ref ("invalid mutually inductive types, binder annotation mismatch at parameter '" ++ n₁ ++ "'");
Term.withLocalDecl ref n₁ c₁.binderInfo d₁ fun x =>
Term.throwError ("invalid mutually inductive types, binder annotation mismatch at parameter '" ++ n₁ ++ "'");
Term.withLocalDecl n₁ c₁.binderInfo d₁ fun x =>
let type := b₁.instantiate1 x;
let firstType := b₂.instantiate1 x;
checkParamsAndResultType (i+1) type firstType
| _, _ => throwUnexpectedInductiveType ref
| _, _ => throwUnexpectedInductiveType
else
match type with
| Expr.forallE n d b c =>
Term.withLocalDecl ref n c.binderInfo d fun x =>
Term.withLocalDecl n c.binderInfo d fun x =>
let type := b.instantiate1 x;
checkParamsAndResultType (i+1) type firstType
| Expr.sort _ _ =>
unlessM (Term.liftMetaM ref $ eqvFirstTypeResult firstType type) $
unlessM (Term.liftMetaM $ eqvFirstTypeResult firstType type) $
let msg : MessageData :=
"invalid mutually inductive types, resulting universe mismatch, given " ++ indentExpr type ++ Format.line ++ "expected type" ++ indentExpr firstType;
Term.throwError ref msg
| _ => throwUnexpectedInductiveType ref
Term.throwError msg
| _ => throwUnexpectedInductiveType
-- Auxiliary function for checking whether the types in mutually inductive declaration are compatible.
private def checkHeader (r : ElabHeaderResult) (numParams : Nat) (firstType? : Option Expr) : TermElabM Expr := do
@ -167,7 +167,7 @@ type ← mkTypeFor r;
match firstType? with
| none => pure type
| some firstType => do
checkParamsAndResultType r.view.ref numParams 0 type firstType;
Term.withRef r.view.ref $ checkParamsAndResultType numParams 0 type firstType;
pure firstType
-- Auxiliary function for checking whether the types in mutually inductive declaration are compatible.
@ -185,13 +185,13 @@ when (rs.size > 1) do {
};
pure rs
private partial def withInductiveLocalDeclsAux {α} (ref : Syntax) (namesAndTypes : Array (Name × Expr)) (params : Array Expr)
private partial def withInductiveLocalDeclsAux {α} (namesAndTypes : Array (Name × Expr)) (params : Array Expr)
(x : Array Expr → Array Expr → TermElabM α) : Nat → Array Expr → TermElabM α
| i, indFVars =>
if h : i < namesAndTypes.size then do
let (id, type) := namesAndTypes.get ⟨i, h⟩;
type ← Term.liftMetaM ref (Meta.instantiateForall type params);
Term.withLocalDecl ref id BinderInfo.default type fun indFVar => withInductiveLocalDeclsAux (i+1) (indFVars.push indFVar)
type ← Term.liftMetaM (Meta.instantiateForall type params);
Term.withLocalDecl id BinderInfo.default type fun indFVar => withInductiveLocalDeclsAux (i+1) (indFVars.push indFVar)
else
x params indFVars
@ -207,12 +207,12 @@ namesAndTypes ← rs.mapM fun r => do {
};
let r0 := rs.get! 0;
let params := r0.params;
Term.withLocalContext r0.lctx r0.localInsts $
withInductiveLocalDeclsAux r0.view.ref namesAndTypes params x 0 #[]
Term.withLocalContext r0.lctx r0.localInsts $ Term.withRef r0.view.ref $
withInductiveLocalDeclsAux namesAndTypes params x 0 #[]
private def isInductiveFamily (ref : Syntax) (indFVar : Expr) : TermElabM Bool := do
indFVarType ← Term.inferType ref indFVar;
indFVarType ← Term.whnf ref indFVarType;
private def isInductiveFamily (indFVar : Expr) : TermElabM Bool := do
indFVarType ← Term.inferType indFVar;
indFVarType ← Term.whnf indFVarType;
pure !indFVarType.isSort
/-
@ -222,33 +222,33 @@ pure !indFVarType.isSort
we do not check for:
- Positivity (it is a rare failure, and the kernel already checks for it).
- Universe constraints (the kernel checks for it). -/
private def elabCtors (indFVar : Expr) (params : Array Expr) (r : ElabHeaderResult) : TermElabM (List Constructor) := do
let ref := r.view.ref;
indFamily ← isInductiveFamily ref indFVar;
r.view.ctors.toList.mapM fun ctorView => Term.elabBinders ctorView.binders.getArgs fun ctorParams => do
let ref := ctorView.ref;
private def elabCtors (indFVar : Expr) (params : Array Expr) (r : ElabHeaderResult) : TermElabM (List Constructor) :=
Term.withRef r.view.ref do
indFamily ← isInductiveFamily indFVar;
r.view.ctors.toList.mapM fun ctorView => Term.elabBinders ctorView.binders.getArgs fun ctorParams =>
Term.withRef ctorView.ref $ do
type ← match ctorView.type? with
| none => do
when indFamily $
Term.throwError ref "constructor resulting type must be specified in inductive family declaration";
Term.throwError "constructor resulting type must be specified in inductive family declaration";
pure indFVar
| some ctorType => do {
type ← Term.elabTerm ctorType none;
resultingType ← getResultingType ref type;
resultingType ← getResultingType type;
unless (resultingType.getAppFn == indFVar) $
Term.throwError ref ("unexpected constructor resulting type" ++ indentExpr resultingType);
unlessM (Term.isType ref resultingType) $
Term.throwError ref ("unexpected constructor resulting type, type expected" ++ indentExpr resultingType);
Term.throwError ("unexpected constructor resulting type" ++ indentExpr resultingType);
unlessM (Term.isType resultingType) $
Term.throwError ("unexpected constructor resulting type, type expected" ++ indentExpr resultingType);
pure type
};
type ← Term.mkForall ref ctorParams type;
type ← Term.mkForall ref params type;
type ← Term.mkForall ctorParams type;
type ← Term.mkForall params type;
pure { name := ctorView.declName, type := type }
/- Convert universe metavariables occurring in the `indTypes` into new parameters.
Remark: if the resulting inductive datatype has universe metavariables, we will fix it later using
`inferResultingUniverse`. -/
private def levelMVarToParamAux (ref : Syntax) (indTypes : List InductiveType) : StateT Nat TermElabM (List InductiveType) :=
private def levelMVarToParamAux (indTypes : List InductiveType) : StateT Nat TermElabM (List InductiveType) :=
indTypes.mapM fun indType => do
type ← Term.levelMVarToParam' indType.type;
ctors ← indType.ctors.mapM fun ctor => do {
@ -257,16 +257,16 @@ indTypes.mapM fun indType => do
};
pure { indType with ctors := ctors, type := type }
private def levelMVarToParam (ref : Syntax) (indTypes : List InductiveType) : TermElabM (List InductiveType) :=
(levelMVarToParamAux ref indTypes).run' 1
private def levelMVarToParam (indTypes : List InductiveType) : TermElabM (List InductiveType) :=
(levelMVarToParamAux indTypes).run' 1
private def getResultingUniverse (ref : Syntax) : List InductiveType → TermElabM Level
| [] => Term.throwError ref "unexpected empty inductive declaration"
private def getResultingUniverse : List InductiveType → TermElabM Level
| [] => Term.throwError "unexpected empty inductive declaration"
| indType :: _ => do
r ← getResultingType ref indType.type;
r ← getResultingType indType.type;
match r with
| Expr.sort u _ => pure u
| _ => Term.throwError ref "unexpected inductive type resulting type"
| _ => Term.throwError "unexpected inductive type resulting type"
def tmpIndParam := mkLevelParam `_tmp_ind_univ_param
@ -274,15 +274,15 @@ def tmpIndParam := mkLevelParam `_tmp_ind_univ_param
Return true if `u` is of the form `?m + k`.
Return false if `u` does not contain universe metavariables.
Throw exception otherwise. -/
def shouldInferResultUniverse (ref : Syntax) (u : Level) : TermElabM Bool := do
u ← Term.instantiateLevelMVars ref u;
def shouldInferResultUniverse (u : Level) : TermElabM Bool := do
u ← Term.instantiateLevelMVars u;
if u.hasMVar then
match u.getLevelOffset with
| Level.mvar mvarId _ => do
Term.assignLevelMVar mvarId tmpIndParam;
pure true
| _ =>
Term.throwError ref $
Term.throwError $
"cannot infer resulting universe level of inductive datatype, given level contains metavariables " ++ mkSort u ++ ", provide universe explicitly"
else
pure false
@ -305,41 +305,41 @@ def accLevelAtCtor : Level → Level → Nat → Array Level → Except String (
else pure (us.push u)
/- Auxiliary function for `updateResultingUniverse` -/
private partial def collectUniversesFromCtorTypeAux (ref : Syntax) (r : Level) (rOffset : Nat) : Nat → Expr → Array Level → TermElabM (Array Level)
private partial def collectUniversesFromCtorTypeAux (r : Level) (rOffset : Nat) : Nat → Expr → Array Level → TermElabM (Array Level)
| 0, Expr.forallE n d b c, us => do
u ← Term.getLevel ref d;
u ← Term.instantiateLevelMVars ref u;
u ← Term.getLevel d;
u ← Term.instantiateLevelMVars u;
match accLevelAtCtor u r rOffset us with
| Except.error msg => Term.throwError ref msg
| Except.ok us => Term.withLocalDecl ref n c.binderInfo d $ fun x =>
| Except.error msg => Term.throwError msg
| Except.ok us => Term.withLocalDecl n c.binderInfo d $ fun x =>
let e := b.instantiate1 x;
collectUniversesFromCtorTypeAux 0 e us
| i+1, Expr.forallE n d b c, us => do
Term.withLocalDecl ref n c.binderInfo d $ fun x =>
Term.withLocalDecl n c.binderInfo d $ fun x =>
let e := b.instantiate1 x;
collectUniversesFromCtorTypeAux i e us
| _, _, us => pure us
/- Auxiliary function for `updateResultingUniverse` -/
private partial def collectUniversesFromCtorType
(ref : Syntax) (r : Level) (rOffset : Nat) (ctorType : Expr) (numParams : Nat) (us : Array Level) : TermElabM (Array Level) :=
collectUniversesFromCtorTypeAux ref r rOffset numParams ctorType us
(r : Level) (rOffset : Nat) (ctorType : Expr) (numParams : Nat) (us : Array Level) : TermElabM (Array Level) :=
collectUniversesFromCtorTypeAux r rOffset numParams ctorType us
/- Auxiliary function for `updateResultingUniverse` -/
private partial def collectUniverses (ref : Syntax) (r : Level) (rOffset : Nat) (numParams : Nat) (indTypes : List InductiveType) : TermElabM (Array Level) :=
private partial def collectUniverses (r : Level) (rOffset : Nat) (numParams : Nat) (indTypes : List InductiveType) : TermElabM (Array Level) :=
indTypes.foldlM
(fun us indType => indType.ctors.foldlM
(fun us ctor => collectUniversesFromCtorType ref r rOffset ctor.type numParams us)
(fun us ctor => collectUniversesFromCtorType r rOffset ctor.type numParams us)
us)
#[]
private def updateResultingUniverse (ref : Syntax) (numParams : Nat) (indTypes : List InductiveType) : TermElabM (List InductiveType) := do
r ← getResultingUniverse ref indTypes;
private def updateResultingUniverse (numParams : Nat) (indTypes : List InductiveType) : TermElabM (List InductiveType) := do
r ← getResultingUniverse indTypes;
let rOffset : Nat := r.getOffset;
let r : Level := r.getLevelOffset;
unless (r.isParam) $
Term.throwError ref "failed to compute resulting universe level of inductive datatype, provide universe explicitly";
us ← collectUniverses ref r rOffset numParams indTypes;
Term.throwError "failed to compute resulting universe level of inductive datatype, provide universe explicitly";
us ← collectUniverses r rOffset numParams indTypes;
let rNew := Level.mkNaryMax us.toList;
pure $ indTypes.map fun indType =>
let type := indType.type.replaceLevel fun u => if u == tmpIndParam then some rNew else none;
@ -349,23 +349,23 @@ private def traceIndTypes (indTypes : List InductiveType) : TermElabM Unit :=
indTypes.forM fun indType =>
indType.ctors.forM fun ctor => _root_.dbgTrace (" >> " ++ toString ctor.name ++ " : " ++ toString ctor.type) fun _ => pure ()
private def removeUnused (ref : Syntax) (vars : Array Expr) (indTypes : List InductiveType) : TermElabM (LocalContext × LocalInstances × Array Expr) := do
private def removeUnused (vars : Array Expr) (indTypes : List InductiveType) : TermElabM (LocalContext × LocalInstances × Array Expr) := do
used ← indTypes.foldlM
(fun (used : CollectFVars.State) indType => do
used ← Term.collectUsedFVars ref used indType.type;
indType.ctors.foldlM (fun (used : CollectFVars.State) ctor => Term.collectUsedFVars ref used ctor.type) used)
used ← Term.collectUsedFVars used indType.type;
indType.ctors.foldlM (fun (used : CollectFVars.State) ctor => Term.collectUsedFVars used ctor.type) used)
{};
Term.removeUnused ref vars used
Term.removeUnused vars used
private def withUsed {α} (ref : Syntax) (vars : Array Expr) (indTypes : List InductiveType) (k : Array Expr → TermElabM α) : TermElabM α := do
(lctx, localInsts, vars) ← removeUnused ref vars indTypes;
private def withUsed {α} (vars : Array Expr) (indTypes : List InductiveType) (k : Array Expr → TermElabM α) : TermElabM α := do
(lctx, localInsts, vars) ← removeUnused vars indTypes;
Term.withLCtx lctx localInsts $ k vars
private def updateParams (ref : Syntax) (vars : Array Expr) (indTypes : List InductiveType) : TermElabM (List InductiveType) :=
private def updateParams (vars : Array Expr) (indTypes : List InductiveType) : TermElabM (List InductiveType) :=
indTypes.mapM fun indType => do
type ← Term.mkForall ref vars indType.type;
type ← Term.mkForall vars indType.type;
ctors ← indType.ctors.mapM fun ctor => do {
ctorType ← Term.mkForall ref vars ctor.type;
ctorType ← Term.mkForall vars ctor.type;
pure { ctor with type := ctorType }
};
pure { indType with type := type, ctors := ctors }
@ -391,11 +391,11 @@ views.size.fold
private def replaceIndFVarsWithConsts (views : Array InductiveView) (indFVars : Array Expr) (levelNames : List Name) (numParams : Nat) (indTypes : List InductiveType)
: TermElabM (List InductiveType) :=
let ref := (views.get! 0).ref;
Term.withRef (views.get! 0).ref $
let indFVar2Const := mkIndFVar2Const views indFVars levelNames;
indTypes.mapM fun indType => do
ctors ← indType.ctors.mapM fun ctor => do {
type ← Term.liftMetaM ref $ Meta.forallBoundedTelescope ctor.type numParams fun params type => do {
type ← Term.liftMetaM $ Meta.forallBoundedTelescope ctor.type numParams fun params type => do {
let type := type.replace fun e => if !e.isFVar then none else
match indFVar2Const.find? e with
| some c => some $ mkAppN c params
@ -430,7 +430,7 @@ scopeLevelNames ← Term.getLevelNames;
checkLevelNames views;
let allUserLevelNames := view0.levelNames;
let isUnsafe := view0.modifiers.isUnsafe;
let ref := view0.ref;
Term.withRef view0.ref $
adaptReader (fun (ctx : Term.Context) => { ctx with levelNames := allUserLevelNames }) do
rs ← elabHeader views;
withInductiveLocalDecls rs fun params indFVars => do
@ -439,23 +439,23 @@ adaptReader (fun (ctx : Term.Context) => { ctx with levelNames := allUserLevelNa
(fun i (indTypes : List InductiveType) => do
let indFVar := indFVars.get! i;
let r := rs.get! i;
type ← Term.mkForall ref params r.type;
type ← Term.mkForall params r.type;
ctors ← elabCtors indFVar params r;
let indType := { name := r.view.declName, type := type, ctors := ctors : InductiveType };
pure (indType :: indTypes))
[];
let indTypes := indTypes.reverse;
Term.synthesizeSyntheticMVars false; -- resolve pending
u ← getResultingUniverse ref indTypes;
inferLevel ← shouldInferResultUniverse ref u;
withUsed ref vars indTypes $ fun vars => do
u ← getResultingUniverse indTypes;
inferLevel ← shouldInferResultUniverse u;
withUsed vars indTypes $ fun vars => do
let numParams := vars.size + numExplicitParams;
indTypes ← updateParams ref vars indTypes;
indTypes ← levelMVarToParam ref indTypes;
indTypes ← if inferLevel then updateResultingUniverse ref numParams indTypes else pure indTypes;
indTypes ← updateParams vars indTypes;
indTypes ← levelMVarToParam indTypes;
indTypes ← if inferLevel then updateResultingUniverse numParams indTypes else pure indTypes;
let usedLevelNames := collectLevelParamsInInductive indTypes;
match sortDeclLevelParams scopeLevelNames allUserLevelNames usedLevelNames with
| Except.error msg => Term.throwError ref msg
| Except.error msg => Term.throwError msg
| Except.ok levelParams => do
indTypes ← replaceIndFVarsWithConsts views indFVars levelParams numParams indTypes;
let indTypes := applyInferMod views numParams indTypes;
@ -485,9 +485,9 @@ views.forM fun view => do {
def elabInductiveViews (views : Array InductiveView) : CommandElabM Unit := do
let view0 := views.get! 0;
let ref := view0.ref;
decl ← runTermElabM view0.declName $ fun vars => mkInductiveDecl vars views;
addDecl ref decl;
let ref := view0.ref;
decl ← runTermElabM view0.declName $ fun vars => Term.withRef ref $ mkInductiveDecl vars views;
addDecl decl;
mkAuxConstructions views;
-- We need to invoke `applyAttributes` because `class` is implemented as an attribute.
views.forM fun view => applyAttributes ref view.declName view.modifiers.attrs AttributeApplicationTime.afterTypeChecking;

210
stage0/src/Lean/Elab/Match.lean
View file

@ -3,9 +3,9 @@ Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Elab.Term
import Lean.Meta.EqnCompiler.MatchPattern
import Lean.Meta.EqnCompiler.DepElim
import Lean.Elab.SyntheticMVars
namespace Lean
namespace Elab
@ -59,24 +59,24 @@ private def elabMatchOptType (matchStx : Syntax) (numDiscrs : Nat) : TermElabM E
typeStx ← liftMacroM $ expandMatchOptType matchStx (matchStx.getArg 2) numDiscrs;
elabType typeStx
private partial def elabDiscrsAux (ref : Syntax) (discrStxs : Array Syntax) (expectedType : Expr) : Nat → Expr → Array Expr → TermElabM (Array Expr)
private partial def elabDiscrsAux (discrStxs : Array Syntax) (expectedType : Expr) : Nat → Expr → Array Expr → TermElabM (Array Expr)
| i, matchType, discrs =>
if h : i < discrStxs.size then do
let discrStx := discrStxs.get ⟨i, h⟩;
matchType ← whnf ref matchType;
matchType ← whnf matchType;
match matchType with
| Expr.forallE _ d b _ => do
discr ← elabTerm discrStx d;
discr ← ensureHasType discrStx d discr;
discr ← ensureHasType d discr;
elabDiscrsAux (i+1) (b.instantiate1 discr) (discrs.push discr)
| _ => throwError ref ("invalid type provided to match-expression, function type with arity #" ++ toString discrStxs ++ " expected")
| _ => throwError ("invalid type provided to match-expression, function type with arity #" ++ toString discrStxs ++ " expected")
else do
unlessM (isDefEq ref matchType expectedType) $
throwError ref ("invalid result type provided to match-expression" ++ indentExpr matchType ++ Format.line ++ "expected type" ++ indentExpr expectedType);
unlessM (isDefEq matchType expectedType) $
throwError ("invalid result type provided to match-expression" ++ indentExpr matchType ++ Format.line ++ "expected type" ++ indentExpr expectedType);
pure discrs
private def elabDiscrs (ref : Syntax) (discrStxs : Array Syntax) (matchType : Expr) (expectedType : Expr) : TermElabM (Array Expr) :=
elabDiscrsAux ref discrStxs expectedType 0 matchType #[]
private def elabDiscrs (discrStxs : Array Syntax) (matchType : Expr) (expectedType : Expr) : TermElabM (Array Expr) :=
elabDiscrsAux discrStxs expectedType 0 matchType #[]
/-
nodeWithAntiquot "matchAlt" `Lean.Parser.Term.matchAlt $ sepBy1 termParser ", " >> darrow >> termParser
@ -92,6 +92,15 @@ private def getMatchAlts (stx : Syntax) : Array MatchAltView :=
let alts : Array Syntax := (stx.getArg 5).getArgs.filter fun alt => alt.getKind == `Lean.Parser.Term.matchAlt;
alts.map mkMatchAltView
/--
Auxiliary annotation used to mark terms marked with the "inaccessible" annotation `.(t)` and
`_` in patterns. -/
def mkInaccessible (e : Expr) : Expr :=
mkAnnotation `_inaccessible e
def isInaccessible? (e : Expr) : Option Expr :=
isAnnotation? `_inaccessible e
inductive PatternVar
| localVar (userName : Name)
-- anonymous variables (`_`) are encoded using metavariables
@ -105,6 +114,29 @@ instance PatternVar.hasToString : HasToString PatternVar :=
@[init] private def registerAuxiliaryNodeKind : IO Unit :=
Parser.registerBuiltinNodeKind `MVarWithIdKind
/--
Create an auxiliary Syntax node wrapping a fresh metavariable id.
We use this kind of Syntax for representing `_` occurring in patterns.
The metavariables are created before we elaborate the patterns into `Expr`s. -/
private def mkMVarSyntax : TermElabM Syntax := do
mvarId ← mkFreshId;
pure $ Syntax.node `MVarWithIdKind #[Syntax.node mvarId #[]]
/-- Given a syntax node constructed using `mkMVarSyntax`, return its MVarId -/
private def getMVarSyntaxMVarId (stx : Syntax) : MVarId :=
(stx.getArg 0).getKind
/--
The elaboration function for `Syntax` created using `mkMVarSyntax`.
It just converts the metavariable id wrapped by the Syntax into an `Expr`. -/
@[builtinTermElab MVarWithIdKind] def elabMVarWithIdKind : TermElab :=
fun stx expectedType? => pure $ mkInaccessible $ mkMVar (getMVarSyntaxMVarId stx)
@[builtinTermElab inaccessible] def elabInaccessible : TermElab :=
fun stx expectedType? => do
e ← elabTerm (stx.getArg 1) expectedType?;
pure $ mkInaccessible e
/-
Patterns define new local variables.
This module collect them and preprocess `_` occurring in patterns.
@ -134,55 +166,59 @@ structure State :=
abbrev M := StateT State TermElabM
private def throwCtorExpected {α} (stx : Syntax) : M α :=
liftM $ throwError stx "invalid pattern, constructor or constant marked with '[matchPattern]' expected"
private def throwCtorExpected {α} : M α :=
liftM $ throwError "invalid pattern, constructor or constant marked with '[matchPattern]' expected"
private def getNumExplicitCtorParams (ref : Syntax) (ctorVal : ConstructorVal) : TermElabM Nat :=
liftMetaM ref $ Meta.forallBoundedTelescope ctorVal.type ctorVal.nparams fun ps _ =>
def withRef {α} (ref : Syntax) (x : M α) : M α :=
adaptReader (fun (ctx : Context) => { ctx with ref := ref }) x
private def getNumExplicitCtorParams (ctorVal : ConstructorVal) : TermElabM Nat :=
liftMetaM $ Meta.forallBoundedTelescope ctorVal.type ctorVal.nparams fun ps _ =>
ps.foldlM
(fun acc p => do
localDecl ← Meta.getLocalDecl p.fvarId!;
if localDecl.binderInfo.isExplicit then pure $ acc+1 else pure acc)
0
private def throwAmbiguous {α} (ref : Syntax) (fs : List Expr) : M α :=
liftM $ throwError ref ("ambiguous pattern, use fully qualified name, possible interpretations " ++ fs)
private def throwAmbiguous {α} (fs : List Expr) : M α :=
liftM $ throwError ("ambiguous pattern, use fully qualified name, possible interpretations " ++ fs)
private def processVar (ref : Syntax) (id : Name) (mustBeCtor : Bool := false) : M Unit := do
when mustBeCtor $ throwCtorExpected ref;
unless id.eraseMacroScopes.isAtomic $ liftM $ throwError ref "invalid pattern variable, must be atomic";
private def processVar (id : Name) (mustBeCtor : Bool := false) : M Unit := do
when mustBeCtor $ throwCtorExpected;
unless id.eraseMacroScopes.isAtomic $ liftM $ throwError "invalid pattern variable, must be atomic";
s ← get;
when (s.found.contains id) $ liftM $ throwError ref ("invalid pattern, variable '" ++ id ++ "' occurred more than once");
when (s.found.contains id) $ liftM $ throwError ("invalid pattern, variable '" ++ id ++ "' occurred more than once");
modify fun s => { s with vars := s.vars.push (PatternVar.localVar id), found := s.found.insert id }
/- Check whether `stx` is a pattern variable or constructor-like (i.e., constructor or constant tagged with `[matchPattern]` attribute)
If `mustBeCtor == true`, then `stx` cannot be a pattern variable.
If `stx` is a constructor, then return the number of explicit arguments that are inductive type parameters. -/
private def processIdAux (stx : Syntax) (mustBeCtor : Bool) : M Nat := do
private def processIdAux (stx : Syntax) (mustBeCtor : Bool) : M Nat :=
withRef stx do
env ← liftM $ getEnv;
match stx.isTermId? true with
| none => throwCtorExpected stx
| none => throwCtorExpected
| some (id, opt) => do
when ((opt.getArg 0).isOfKind `Lean.Parser.Term.namedPattern) $
liftM $ throwError stx "invalid occurrence of named pattern";
liftM $ throwError "invalid occurrence of named pattern";
match id with
| Syntax.ident _ _ val preresolved => do
rs ← liftM $ catch (resolveName stx val preresolved []) (fun _ => pure []);
rs ← liftM $ catch (resolveName val preresolved []) (fun _ => pure []);
let rs := rs.filter fun ⟨f, projs⟩ => projs.isEmpty;
let fs := rs.map fun ⟨f, _⟩ => f;
match fs with
| [] => do processVar stx id.getId mustBeCtor; pure 0
| [] => do processVar id.getId mustBeCtor; pure 0
| [f] => match f with
| Expr.const fName _ _ =>
match env.find? fName with
| some $ ConstantInfo.ctorInfo val => liftM $ getNumExplicitCtorParams stx val
| some $ ConstantInfo.ctorInfo val => liftM $ getNumExplicitCtorParams val
| some $ info =>
if EqnCompiler.hasMatchPatternAttribute env fName then pure 0
else do processVar stx id.getId mustBeCtor; pure 0
| none => throwCtorExpected stx
| _ => do processVar stx id.getId mustBeCtor; pure 0
| _ => throwAmbiguous stx fs
else do processVar id.getId mustBeCtor; pure 0
| none => throwCtorExpected
| _ => do processVar id.getId mustBeCtor; pure 0
| _ => throwAmbiguous fs
| _ => unreachable!
private def processCtor (stx : Syntax) : M Nat :=
@ -191,17 +227,17 @@ processIdAux stx true
private def processId (stx : Syntax) : M Unit := do
_ ← processIdAux stx false; pure ()
private def throwInvalidPattern {α} (stx : Syntax) : M α :=
liftM $ throwError stx "invalid pattern"
private def throwInvalidPattern {α} : M α :=
liftM $ throwError "invalid pattern"
private partial def collect : Syntax → M Syntax
| stx@(Syntax.node k args) => withFreshMacroScope $
| stx@(Syntax.node k args) => withRef stx $ withFreshMacroScope $
if k == `Lean.Parser.Term.app then do
let appFn := args.get! 0;
let appArgs := (args.get! 1).getArgs;
appArgs.forM fun appArg =>
when (appArg.isOfKind `Lean.Parser.Term.namedPattern) $
liftM $ throwError appArg "named parameters are not allowed in patterns";
liftM $ throwErrorAt appArg "named parameters are not allowed in patterns";
/- We must skip explict inducitve datatype parameters since they are by defaul inaccessible.
Example: `A` is inaccessible term at `Sum.inl A b` -/
numArgsToSkip ← processCtor appFn;
@ -214,7 +250,7 @@ private partial def collect : Syntax → M Syntax
/- { " >> optional (try (termParser >> " with ")) >> sepBy structInstField ", " true >> optional ".." >> optional (" : " >> termParser) >> " }" -/
let withMod := args.get! 1;
unless withMod.isNone $
liftM $ throwError withMod "invalid struct instance pattern, 'with' is not allowed in patterns";
liftM $ throwErrorAt withMod "invalid struct instance pattern, 'with' is not allowed in patterns";
let fields := (args.get! 2).getArgs;
fields ← fields.mapSepElemsM fun field => do {
-- parser! structInstLVal >> " := " >> termParser
@ -223,8 +259,8 @@ private partial def collect : Syntax → M Syntax
};
pure $ Syntax.node k $ args.set! 2 $ mkNullNode fields
else if k == `Lean.Parser.Term.hole then do
r ← `(?x);
modify fun s => { s with vars := s.vars.push $ PatternVar.anonymousVar $ (r.getArg 1).getId };
r ← liftM mkMVarSyntax;
modify fun s => { s with vars := s.vars.push $ PatternVar.anonymousVar $ getMVarSyntaxMVarId r };
pure r
else if k == `Lean.Parser.Term.paren then
let arg := args.get! 1;
@ -262,12 +298,12 @@ private partial def collect : Syntax → M Syntax
def namedPattern := checkNoWsBefore "no space before '@'" >> parser! "@" >> termParser maxPrec
def id := parser! ident >> optional (explicitUniv <|> namedPattern) -/
let id := stx.getIdOfTermId;
processVar stx id;
processVar id;
let pat := (extra.getArg 0).getArg 1;
pat ← collect pat;
`(namedPattern $(mkTermIdFrom stx id) $pat)
else
throwInvalidPattern stx
throwInvalidPattern
else if k == `Lean.Parser.Term.inaccessible then
pure stx
else if k == `Lean.Parser.Term.str then
@ -277,18 +313,18 @@ private partial def collect : Syntax → M Syntax
else if k == `Lean.Parser.Term.char then
pure stx
else if k == choiceKind then
liftM $ throwError stx "invalid pattern, notation is ambiguous"
liftM $ throwError "invalid pattern, notation is ambiguous"
else
throwInvalidPattern stx
throwInvalidPattern
| stx@(Syntax.ident _ _ _ _) => do
processId stx;
pure stx
| stx =>
throwInvalidPattern stx
throwInvalidPattern
def main (alt : MatchAltView) : M MatchAltView := do
patterns ← alt.patterns.mapM fun p => do {
liftM $ trace `Elab.match p fun _ => "collecting variables at pattern: " ++ p;
liftM $ trace `Elab.match fun _ => "collecting variables at pattern: " ++ p;
collect p
};
pure { alt with patterns := patterns }
@ -299,42 +335,84 @@ private def collectPatternVars (alt : MatchAltView) : TermElabM (Array PatternVa
(alt, s) ← (CollectPatternVars.main alt).run {};
pure (s.vars, alt)
private partial def withPatternVarsAux {α} (ref : Syntax) (pVars : Array PatternVar) (k : TermElabM α) : Nat → TermElabM α
| i =>
/- We convert the collected `PatternVar`s intro `PatternVarDecl` -/
inductive PatternVarDecl
/- For `anonymousVar`, we create both a metavariable and a free variable. The free variable is used as an assignment for the metavariable
when it is not assigned during pattern elaboration. -/
| anonymousVar (mvarId : MVarId) (fvarId : FVarId)
| localVar (fvarId : FVarId)
private partial def withPatternVarsAux {α} (pVars : Array PatternVar) (k : Array PatternVarDecl → TermElabM α)
: Nat → Array PatternVarDecl → TermElabM α
| i, decls =>
if h : i < pVars.size then
match pVars.get ⟨i, h⟩ with
| PatternVar.anonymousVar _ => withPatternVarsAux (i+1)
| PatternVar.localVar userName => do
type ← mkFreshTypeMVar ref;
withLocalDecl ref userName BinderInfo.default type fun _ => withPatternVarsAux (i+1)
else
k
| PatternVar.anonymousVar mvarId => do
type ← mkFreshTypeMVar;
withLocalDecl ((`_x).appendIndexAfter i) BinderInfo.default type fun x =>
withPatternVarsAux (i+1) (decls.push (PatternVarDecl.anonymousVar mvarId x.fvarId!))
| PatternVar.localVar userName => do
type ← mkFreshTypeMVar;
withLocalDecl userName BinderInfo.default type fun x =>
withPatternVarsAux (i+1) (decls.push (PatternVarDecl.localVar x.fvarId!))
else do
/- We must create the metavariables for `PatternVar.anonymousVar` AFTER we create the new local decls using `withLocalDecl`.
Reason: their scope must include the new local decls since some of them will be assigned by typing constraints. -/
decls.forM fun decl => match decl with
| PatternVarDecl.anonymousVar mvarId fvarId => do
type ← inferType (mkFVar fvarId);
_ ← mkFreshExprMVarWithId mvarId type;
pure ()
| _ => pure ();
k decls
private def withPatternVars {α} (ref : Syntax) (pVars : Array PatternVar) (k : TermElabM α) : TermElabM α :=
withPatternVarsAux ref pVars k 0
private def withPatternVars {α} (pVars : Array PatternVar) (k : Array PatternVarDecl → TermElabM α) : TermElabM α :=
withPatternVarsAux pVars k 0 #[]
private partial def elabPatternsAux (ref : Syntax) (patternStxs : Array Syntax) : Nat → Expr → Array Expr → TermElabM (Array Expr)
private partial def elabPatternsAux (patternStxs : Array Syntax) : Nat → Expr → Array Expr → TermElabM (Array Expr)
| i, matchType, patterns =>
if h : i < patternStxs.size then do
matchType ← whnf ref matchType;
matchType ← whnf matchType;
match matchType with
| Expr.forallE _ d b _ => do
pattern ← elabTerm (patternStxs.get ⟨i, h⟩) d;
let patternStx := patternStxs.get ⟨i, h⟩;
pattern ← elabTerm patternStx d;
pattern ← withRef patternStx $ ensureHasType d pattern;
elabPatternsAux (i+1) (b.instantiate1 pattern) (patterns.push pattern)
| _ => throwError ref "unexpected match type"
| _ => throwError "unexpected match type"
else
pure patterns
private def elabPatterns (ref : Syntax) (patternStxs : Array Syntax) (matchType : Expr) : TermElabM (Array Expr) := do
patterns ← elabPatternsAux ref patternStxs 0 matchType #[];
trace `Elab.match ref fun _ => "patterns: " ++ patterns;
def finalizePatternDecls (patternVarDecls : Array PatternVarDecl) : TermElabM (Array LocalDecl) :=
patternVarDecls.foldlM
(fun (decls : Array LocalDecl) pdecl =>
match pdecl with
| PatternVarDecl.localVar fvarId => do
decl ← getLocalDecl fvarId;
pure $ decls.push decl
| PatternVarDecl.anonymousVar mvarId fvarId => do
condM (isExprMVarAssigned mvarId)
(pure decls) -- skip
(do /- metavariable was not assigned while elaborating the patterns,
so we assign to the auxiliary free variable we created at `withPatternVars` -/
assignExprMVar mvarId (mkFVar fvarId);
decl ← getLocalDecl fvarId;
pure $ decls.push decl))
#[]
private def elabPatterns (patternVarDecls : Array PatternVarDecl) (patternStxs : Array Syntax) (matchType : Expr) : TermElabM (Array Expr) := do
patterns ← withSynthesize $ elabPatternsAux patternStxs 0 matchType #[];
patterns ← patterns.mapM instantiateMVars;
decls ← finalizePatternDecls patternVarDecls;
trace `Elab.match fun _ => MessageData.ofArray $ decls.map fun (d : LocalDecl) => (d.userName ++ " : " ++ d.type : MessageData);
trace `Elab.match fun _ => "patterns: " ++ patterns;
pure patterns
def elabMatchAltView (alt : MatchAltView) (matchType : Expr) : TermElabM (Meta.DepElim.AltLHS × Expr) := do
(patternVars, alt) ← collectPatternVars alt;
trace `Elab.match alt.ref fun _ => "patternVars: " ++ toString patternVars;
withPatternVars alt.ref patternVars do
ps ← elabPatterns alt.ref alt.patterns matchType;
withRef alt.ref $ trace `Elab.match fun _ => "patternVars: " ++ toString patternVars;
withPatternVars patternVars fun patternVarDecls => do
ps ← withRef alt.ref $ elabPatterns patternVarDecls alt.patterns matchType;
-- TODO
pure (⟨[], []⟩, arbitrary _)
@ -348,13 +426,13 @@ private def elabMatchCore (stx : Syntax) (expectedType? : Option Expr) : TermEla
tryPostponeIfNoneOrMVar expectedType?;
expectedType ← match expectedType? with
| some expectedType => pure expectedType
| none => mkFreshTypeMVar stx;
| none => mkFreshTypeMVar;
let discrStxs := (stx.getArg 1).getArgs.getSepElems.map fun d => d.getArg 1;
matchType ← elabMatchOptType stx discrStxs.size;
matchAlts ← expandMacrosInPatterns $ getMatchAlts stx;
discrs ← elabDiscrs stx discrStxs matchType expectedType;
discrs ← elabDiscrs discrStxs matchType expectedType;
alts ← matchAlts.mapM $ fun alt => elabMatchAltView alt matchType;
throwError stx ("WIP type: " ++ matchType ++ "\n" ++ discrs ++ "\n" ++ toString (matchAlts.map fun alt => toString alt.patterns))
throwError ("WIP type: " ++ matchType ++ "\n" ++ discrs ++ "\n" ++ toString (matchAlts.map fun alt => toString alt.patterns))
/- Auxiliary method for `expandMatchDiscr?` -/
private partial def mkMatchType (discrs : Array Syntax) : Nat → MacroM Syntax
@ -367,7 +445,7 @@ private partial def mkMatchType (discrs : Array Syntax) : Nat → MacroM Syntax
`(_ → $type)
else
let t := discr.getArg 1;
`((x : _) → x = $t → $type)
`((x : _) → $t = x → $type)
else
mkMatchType (i+1)
else

26
stage0/src/Lean/Elab/Quotation.lean
View file

@ -89,7 +89,7 @@ private partial def quoteSyntax : Syntax → TermElabM Syntax
| stx@(Syntax.node k _) =>
if isAntiquot stx && !isEscapedAntiquot stx then
-- splices must occur in a `many` node
if isAntiquotSplice stx then throwError stx "unexpected antiquotation splice"
if isAntiquotSplice stx then throwErrorAt stx "unexpected antiquotation splice"
else pure $ getAntiquotTerm stx
else do
empty ← `(Array.empty);
@ -195,9 +195,9 @@ else if pat.isOfKind `Lean.Parser.Term.stxQuot then
let kind := if k == Name.anonymous then none else k;
let anti := getAntiquotTerm quoted;
-- Splices should only appear inside a nullKind node, see next case
if isAntiquotSplice quoted then unconditional $ fun _ => throwError quoted "unexpected antiquotation splice"
if isAntiquotSplice quoted then unconditional $ fun _ => throwErrorAt quoted "unexpected antiquotation splice"
else if anti.isOfKind `Lean.Parser.Term.id then { kind := kind, rhsFn := fun rhs => `(let $anti := discr; $rhs) }
else unconditional $ fun _ => throwError anti ("match_syntax: antiquotation must be variable " ++ toString anti)
else unconditional $ fun _ => throwErrorAt anti ("match_syntax: antiquotation must be variable " ++ toString anti)
else if isAntiquotSplicePat quoted && quoted.getArgs.size == 1 then
-- quotation is a single antiquotation splice => bind args array
let anti := getAntiquotTerm (quoted.getArg 0);
@ -209,7 +209,7 @@ else if pat.isOfKind `Lean.Parser.Term.stxQuot then
let argPats := quoted.getArgs.map $ fun arg => Syntax.node `Lean.Parser.Term.stxQuot #[mkAtom "`(", arg, mkAtom ")"];
{ kind := quoted.getKind, argPats := argPats }
else
unconditional $ fun _ => throwError pat ("match_syntax: unexpected pattern kind " ++ toString pat)
unconditional $ fun _ => throwErrorAt pat ("match_syntax: unexpected pattern kind " ++ toString pat)
-- Assuming that the first pattern of the alternative is taken, replace it with patterns (if any) for its
-- child nodes.
@ -224,9 +224,9 @@ private def explodeHeadPat (numArgs : Nat) : HeadInfo × Alt → TermElabM Alt
pure (newPats ++ pats, rhs)
| _ => unreachable!
private partial def compileStxMatch (ref : Syntax) : List Syntax → List Alt → TermElabM Syntax
private partial def compileStxMatch : List Syntax → List Alt → TermElabM Syntax
| [], ([], rhs)::_ => pure rhs -- nothing left to match
| _, [] => throwError ref "non-exhaustive 'match_syntax'"
| _, [] => throwError "non-exhaustive 'match_syntax'"
| discr::discrs, alts => do
let alts := (alts.map getHeadInfo).zip alts;
-- Choose a most specific pattern, ie. a minimal element according to `generalizes`.
@ -299,16 +299,16 @@ let alts := stx.getArg 4;
alts ← alts.getArgs.getSepElems.mapM $ fun alt => do {
let pats := alt.getArg 0;
pat ← if pats.getArgs.size == 1 then pure $ pats.getArg 0
else throwError stx "match_syntax: expected exactly one pattern per alternative";
else throwError "match_syntax: expected exactly one pattern per alternative";
let pat := if pat.isOfKind `Lean.Parser.Term.stxQuot then pat.setArg 1 $ elimAntiquotChoices $ pat.getArg 1 else pat;
match pat.find? $ fun stx => stx.getKind == choiceKind with
| some choiceStx => throwError choiceStx "invalid pattern, nested syntax has multiple interpretations"
| some choiceStx => throwErrorAt choiceStx "invalid pattern, nested syntax has multiple interpretations"
| none =>
let rhs := alt.getArg 2;
pure ([pat], rhs)
};
-- letBindRhss (compileStxMatch stx [discr]) alts.toList []
compileStxMatch stx [discr] alts.toList
compileStxMatch [discr] alts.toList
@[builtinTermElab «match_syntax»] def elabMatchSyntax : TermElab :=
adaptExpander match_syntax.expand
@ -317,13 +317,13 @@ adaptExpander match_syntax.expand
private def exprPlaceholder := mkMVar Name.anonymous
private unsafe partial def toPreterm : Syntax → TermElabM Expr
| stx =>
| stx => withRef stx $
let args := stx.getArgs;
match stx.getKind with
| `Lean.Parser.Term.id =>
match args.get! 0 with
| Syntax.ident _ _ val preresolved => do
resolved ← resolveName stx val preresolved [];
resolved ← resolveName val preresolved [];
match resolved with
| (pre,projs)::_ =>
let pre := match pre with
@ -390,7 +390,7 @@ private unsafe partial def toPreterm : Syntax → TermElabM Expr
| `Lean.Parser.Term.str => pure $ mkStrLit $ (stx.getArg 0).isStrLit?.getD ""
| `Lean.Parser.Term.num => pure $ mkNatLit $ (stx.getArg 0).isNatLit?.getD 0
| `expr => pure $ unsafeCast $ stx.getArg 0 -- HACK: see below
| k => throwError stx $ "stxQuot: unimplemented kind " ++ toString k
| k => throwError $ "stxQuot: unimplemented kind " ++ toString k
@[export lean_parse_expr]
def oldParseExpr (env : Environment) (input : String) (pos : String.Pos) : Except String (Syntax × String.Pos) := do
@ -437,7 +437,7 @@ let alts := alts.map $ fun alt =>
let pats := alt.1.map elimAntiquotChoices;
(pats, Syntax.node `expr #[alt.2]);
-- letBindRhss (compileStxMatch Syntax.missing [discr]) alts []
stx ← compileStxMatch Syntax.missing [discr] alts;
stx ← compileStxMatch [discr] alts;
toPreterm stx
end Quotation

131
stage0/src/Lean/Elab/StructInst.lean
View file

@ -51,6 +51,7 @@ def setStructSourceSyntax (structStx : Syntax) : Source → Syntax
| Source.explicit stx _ => (structStx.setArg 1 stx).setArg 3 mkNullNode
private def getStructSource (stx : Syntax) : TermElabM Source :=
withRef stx $
let explicitSource := stx.getArg 1;
let implicitSource := stx.getArg 3;
if explicitSource.isNone && implicitSource.isNone then
@ -63,7 +64,7 @@ else if implicitSource.isNone then do
| none => unreachable! -- expandNonAtomicExplicitSource must have been used when we get here
| some src => pure $ Source.explicit explicitSource src
else
throwError stx "invalid structure instance `with` and `..` cannot be used together"
throwError "invalid structure instance `with` and `..` cannot be used together"
/-
We say a `{ ... }` notation is a `modifyOp` if it contains only one
@ -86,15 +87,15 @@ s? ← args.foldSepByM
| none => pure (some arg)
| some s =>
if s.getKind == `Lean.Parser.Term.structInstArrayRef then
throwError arg "invalid {...} notation, at most one `[..]` at a given level"
throwErrorAt arg "invalid {...} notation, at most one `[..]` at a given level"
else
throwError arg "invalid {...} notation, can't mix field and `[..]` at a given level"
throwErrorAt arg "invalid {...} notation, can't mix field and `[..]` at a given level"
else
match s? with
| none => pure (some arg)
| some s =>
if s.getKind == `Lean.Parser.Term.structInstArrayRef then
throwError arg "invalid {...} notation, can't mix field and `[..]` at a given level"
throwErrorAt arg "invalid {...} notation, can't mix field and `[..]` at a given level"
else
pure s?)
none;
@ -108,10 +109,10 @@ let continue (val : Syntax) : TermElabM Expr := do {
let idx := lval.getArg 1;
let self := source.getArg 0;
stxNew ← `($(self).modifyOp (idx := $idx) (fun s => $val));
trace `Elab.struct.modifyOp stx $ fun _ => stx ++ "\n===>\n" ++ stxNew;
trace `Elab.struct.modifyOp fun _ => stx ++ "\n===>\n" ++ stxNew;
withMacroExpansion stx stxNew $ elabTerm stxNew expectedType?
}; do
trace `Elab.struct.modifyOp stx $ fun _ => modifyOp ++ "\nSource: " ++ source;
trace `Elab.struct.modifyOp fun _ => modifyOp ++ "\nSource: " ++ source;
let rest := modifyOp.getArg 1;
if rest.isNone then do
continue (modifyOp.getArg 3)
@ -126,27 +127,26 @@ else do
let valSource := source.modifyArg 0 $ fun _ => s;
let val := stx.setArg 1 valSource;
let val := val.setArg 2 $ mkNullNode #[valField];
trace `Elab.struct.modifyOp stx $ fun _ => stx ++ "\nval: " ++ val;
trace `Elab.struct.modifyOp fun _ => stx ++ "\nval: " ++ val;
continue val
/- Get structure name and elaborate explicit source (if available) -/
private def getStructName (stx : Syntax) (expectedType? : Option Expr) (sourceView : Source) : TermElabM Name := do
let ref := stx;
tryPostponeIfNoneOrMVar expectedType?;
let useSource : Unit → TermElabM Name := fun _ =>
match sourceView with
| Source.explicit _ src => do
srcType ← inferType stx src;
srcType ← whnf stx srcType;
srcType ← inferType src;
srcType ← whnf srcType;
tryPostponeIfMVar srcType;
match srcType.getAppFn with
| Expr.const constName _ _ => pure constName
| _ => throwError stx ("invalid {...} notation, source type is not of the form (C ...)" ++ indentExpr srcType)
| _ => throwError ref ("invalid {...} notation, expected type is not of the form (C ...)" ++ indentExpr expectedType?.get!);
| _ => throwError ("invalid {...} notation, source type is not of the form (C ...)" ++ indentExpr srcType)
| _ => throwError ("invalid {...} notation, expected type is not of the form (C ...)" ++ indentExpr expectedType?.get!);
match expectedType? with
| none => useSource ()
| some expectedType => do
expectedType ← whnf ref expectedType;
expectedType ← whnf expectedType;
match expectedType.getAppFn with
| Expr.const constName _ _ => pure constName
| _ => useSource ()
@ -292,8 +292,8 @@ s.modifyFieldsM $ fun fields => do
let fieldNames := getStructureFields env s.structName;
fields.mapM $ fun field => match field with
| { lhs := FieldLHS.fieldIndex ref idx :: rest, .. } =>
if idx == 0 then throwError ref "invalid field index, index must be greater than 0"
else if idx > fieldNames.size then throwError ref ("invalid field index, structure has only #" ++ toString fieldNames.size ++ " fields")
if idx == 0 then throwErrorAt ref "invalid field index, index must be greater than 0"
else if idx > fieldNames.size then throwErrorAt ref ("invalid field index, structure has only #" ++ toString fieldNames.size ++ " fields")
else pure { field with lhs := FieldLHS.fieldName ref (fieldNames.get! $ idx - 1) :: rest }
| _ => pure field
@ -317,7 +317,7 @@ env ← getEnv;
s.modifyFieldsM $ fun fields => fields.mapM $ fun field => match field with
| { lhs := FieldLHS.fieldName ref fieldName :: rest, .. } =>
match findField? env s.structName fieldName with
| none => throwError ref ("'" ++ fieldName ++ "' is not a field of structure '" ++ s.structName ++ "'")
| none => throwErrorAt ref ("'" ++ fieldName ++ "' is not a field of structure '" ++ s.structName ++ "'")
| some baseStructName =>
if baseStructName == s.structName then pure field
else match getPathToBaseStructure? env baseStructName s.structName with
@ -326,7 +326,7 @@ s.modifyFieldsM $ fun fields => fields.mapM $ fun field => match field with
| Name.str _ s _ => FieldLHS.fieldName ref (mkNameSimple s)
| _ => unreachable!;
pure { field with lhs := path ++ field.lhs }
| _ => throwError ref ("failed to access field '" ++ fieldName ++ "' in parent structure")
| _ => throwErrorAt ref ("failed to access field '" ++ fieldName ++ "' in parent structure")
| _ => pure field
private abbrev FieldMap := HashMap Name Fields
@ -339,7 +339,7 @@ fields.foldlM
match fieldMap.find? fieldName with
| some (prevField::restFields) =>
if field.isSimple || prevField.isSimple then
throwError field.ref ("field '" ++ fieldName ++ "' has already beed specified")
throwErrorAt field.ref ("field '" ++ fieldName ++ "' has already beed specified")
else
pure $ fieldMap.insert fieldName (field::prevField::restFields)
| _ => pure $ fieldMap.insert fieldName [field]
@ -350,18 +350,18 @@ private def isSimpleField? : Fields → Option (Field Struct)
| [field] => if field.isSimple then some field else none
| _ => none
private def getFieldIdx (ref : Syntax) (structName : Name) (fieldNames : Array Name) (fieldName : Name) : TermElabM Nat := do
private def getFieldIdx (structName : Name) (fieldNames : Array Name) (fieldName : Name) : TermElabM Nat := do
match fieldNames.findIdx? $ fun n => n == fieldName with
| some idx => pure idx
| none => throwError ref ("field '" ++ fieldName ++ "' is not a valid field of '" ++ structName ++ "'")
| none => throwError ("field '" ++ fieldName ++ "' is not a valid field of '" ++ structName ++ "'")
private def mkProjStx (s : Syntax) (fieldName : Name) : Syntax :=
Syntax.node `Lean.Parser.Term.proj #[s, mkAtomFrom s ".", mkIdentFrom s fieldName]
private def mkSubstructSource (ref : Syntax) (structName : Name) (fieldNames : Array Name) (fieldName : Name) (src : Source) : TermElabM Source :=
private def mkSubstructSource (structName : Name) (fieldNames : Array Name) (fieldName : Name) (src : Source) : TermElabM Source :=
match src with
| Source.explicit stx src => do
idx ← getFieldIdx ref structName fieldNames fieldName;
idx ← getFieldIdx structName fieldNames fieldName;
let stx := stx.modifyArg 0 $ fun stx => mkProjStx stx fieldName;
pure $ Source.explicit stx (mkProj structName idx src)
| s => pure s
@ -369,6 +369,7 @@ match src with
@[specialize] private def groupFields (expandStruct : Struct → TermElabM Struct) (s : Struct) : TermElabM Struct := do
env ← getEnv;
let fieldNames := getStructureFields env s.structName;
withRef s.ref $
s.modifyFieldsM $ fun fields => do
fieldMap ← mkFieldMap fields;
fieldMap.toList.mapM $ fun ⟨fieldName, fields⟩ =>
@ -376,7 +377,7 @@ s.modifyFieldsM $ fun fields => do
| some field => pure field
| none => do
let substructFields := fields.map $ fun field => { field with lhs := field.lhs.tail! };
substructSource ← mkSubstructSource s.ref s.structName fieldNames fieldName s.source;
substructSource ← mkSubstructSource s.structName fieldNames fieldName s.source;
let field := fields.head!;
match Lean.isSubobjectField? env s.structName fieldName with
| some substructName => do
@ -402,6 +403,7 @@ fields.find? $ fun field =>
env ← getEnv;
let fieldNames := getStructureFields env s.structName;
let ref := s.ref;
withRef ref do
fields ← fieldNames.foldlM
(fun fields fieldName => do
match findField? s.fields fieldName with
@ -412,7 +414,7 @@ fields ← fieldNames.foldlM
};
match Lean.isSubobjectField? env s.structName fieldName with
| some substructName => do
substructSource ← mkSubstructSource s.ref s.structName fieldNames fieldName s.source;
substructSource ← mkSubstructSource s.structName fieldNames fieldName s.source;
let substruct := Struct.mk s.ref substructName [] substructSource;
substruct ← expandStruct substruct;
addField (FieldVal.nested substruct)
@ -441,27 +443,27 @@ structure CtorHeaderResult :=
(ctorFnType : Expr)
(instMVars : Array MVarId := #[])
private def mkCtorHeaderAux (ref : Syntax) : Nat → Expr → Expr → Array MVarId → TermElabM CtorHeaderResult
private def mkCtorHeaderAux : Nat → Expr → Expr → Array MVarId → TermElabM CtorHeaderResult
| 0, type, ctorFn, instMVars => pure { ctorFn := ctorFn, ctorFnType := type, instMVars := instMVars }
| n+1, type, ctorFn, instMVars => do
type ← whnfForall ref type;
type ← whnfForall type;
match type with
| Expr.forallE _ d b c =>
match c.binderInfo with
| BinderInfo.instImplicit => do
a ← mkFreshExprMVar ref d MetavarKind.synthetic;
a ← mkFreshExprMVar d MetavarKind.synthetic;
mkCtorHeaderAux n (b.instantiate1 a) (mkApp ctorFn a) (instMVars.push a.mvarId!)
| _ => do
a ← mkFreshExprMVar ref d;
a ← mkFreshExprMVar d;
mkCtorHeaderAux n (b.instantiate1 a) (mkApp ctorFn a) instMVars
| _ => throwError ref "unexpected constructor type"
| _ => throwError "unexpected constructor type"
private partial def getForallBody : Nat → Expr → Option Expr
| i+1, Expr.forallE _ _ b _ => getForallBody i b
| i+1, _ => none
| 0, type => type
private def propagateExpectedType (ref : Syntax) (type : Expr) (numFields : Nat) (expectedType? : Option Expr) : TermElabM Unit :=
private def propagateExpectedType (type : Expr) (numFields : Nat) (expectedType? : Option Expr) : TermElabM Unit :=
match expectedType? with
| none => pure ()
| some expectedType =>
@ -469,16 +471,16 @@ match expectedType? with
| none => pure ()
| some typeBody =>
unless typeBody.hasLooseBVars $ do
_ ← isDefEq ref expectedType typeBody;
_ ← isDefEq expectedType typeBody;
pure ()
private def mkCtorHeader (ref : Syntax) (ctorVal : ConstructorVal) (expectedType? : Option Expr) : TermElabM CtorHeaderResult := do
lvls ← ctorVal.lparams.mapM $ fun _ => mkFreshLevelMVar ref;
private def mkCtorHeader (ctorVal : ConstructorVal) (expectedType? : Option Expr) : TermElabM CtorHeaderResult := do
lvls ← ctorVal.lparams.mapM $ fun _ => mkFreshLevelMVar;
let val := Lean.mkConst ctorVal.name lvls;
let type := (ConstantInfo.ctorInfo ctorVal).instantiateTypeLevelParams lvls;
r ← mkCtorHeaderAux ref ctorVal.nparams type val #[];
propagateExpectedType ref r.ctorFnType ctorVal.nfields expectedType?;
synthesizeAppInstMVars ref r.instMVars;
r ← mkCtorHeaderAux ctorVal.nparams type val #[];
propagateExpectedType r.ctorFnType ctorVal.nfields expectedType?;
synthesizeAppInstMVars r.instMVars;
pure r
def markDefaultMissing (e : Expr) : Expr :=
@ -487,20 +489,20 @@ mkAnnotation `structInstDefault e
def isDefaultMissing? (e : Expr) : Option Expr :=
isAnnotation? `structInstDefault e
def throwFailedToElabField {α} (ref : Syntax) (fieldName : Name) (structName : Name) (msgData : MessageData) : TermElabM α :=
throwError ref ("failed to elaborate field '" ++ fieldName ++ "' of '" ++ structName ++ ", " ++ msgData)
def throwFailedToElabField {α} (fieldName : Name) (structName : Name) (msgData : MessageData) : TermElabM α :=
throwError ("failed to elaborate field '" ++ fieldName ++ "' of '" ++ structName ++ ", " ++ msgData)
private partial def elabStruct : Struct → Option Expr → TermElabM (Expr × Struct)
| s, expectedType? => do
| s, expectedType? => withRef s.ref do
env ← getEnv;
let ctorVal := getStructureCtor env s.structName;
{ ctorFn := ctorFn, ctorFnType := ctorFnType, .. } ← mkCtorHeader s.ref ctorVal expectedType?;
{ ctorFn := ctorFn, ctorFnType := ctorFnType, .. } ← mkCtorHeader ctorVal expectedType?;
(e, _, fields) ← s.fields.foldlM
(fun (acc : Expr × Expr × Fields) field =>
let (e, type, fields) := acc;
match field.lhs with
| [FieldLHS.fieldName ref fieldName] => do
type ← whnfForall field.ref type;
type ← whnfForall type;
match type with
| Expr.forallE _ d b c =>
let continue (val : Expr) (field : Field Struct) : TermElabM (Expr × Expr × Fields) := do {
@ -510,11 +512,11 @@ private partial def elabStruct : Struct → Option Expr → TermElabM (Expr × S
pure (e, type, field::fields)
};
match field.val with
| FieldVal.term stx => do val ← elabTerm stx (some d); val ← ensureHasType stx d val; continue val field
| FieldVal.nested s => do (val, sNew) ← elabStruct s (some d); val ← ensureHasType s.ref d val; continue val { field with val := FieldVal.nested sNew }
| FieldVal.default => do val ← mkFreshExprMVar field.ref (some d); continue (markDefaultMissing val) field
| _ => throwFailedToElabField field.ref fieldName s.structName ("unexpected constructor type" ++ indentExpr type)
| _ => throwError field.ref "unexpected unexpanded structure field")
| FieldVal.term stx => do val ← elabTerm stx (some d); val ← withRef stx $ ensureHasType d val; continue val field
| FieldVal.nested s => do (val, sNew) ← elabStruct s (some d); val ← ensureHasType d val; continue val { field with val := FieldVal.nested sNew }
| FieldVal.default => do val ← withRef field.ref $ mkFreshExprMVar (some d); continue (markDefaultMissing val) field
| _ => withRef field.ref $ throwFailedToElabField fieldName s.structName ("unexpected constructor type" ++ indentExpr type)
| _ => throwErrorAt field.ref "unexpected unexpanded structure field")
(ctorFn, ctorFnType, []);
pure (e, s.setFields fields.reverse)
@ -603,19 +605,18 @@ struct.fields.findSome? $ fun field =>
none
partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Expr)
| Expr.lam n d b c =>
let ref := struct.ref;
| Expr.lam n d b c => withRef struct.ref $
if c.binderInfo.isExplicit then
let fieldName := n;
match getFieldValue? struct fieldName with
| none => pure none
| some val => do
valType ← inferType ref val;
condM (isDefEq ref valType d)
valType ← inferType val;
condM (isDefEq valType d)
(mkDefaultValueAux? (b.instantiate1 val))
(pure none)
else do
arg ← mkFreshExprMVar ref d;
arg ← mkFreshExprMVar d;
mkDefaultValueAux? (b.instantiate1 arg)
| e =>
if e.isAppOfArity `id 2 then
@ -623,9 +624,9 @@ partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Ex
else
pure (some e)
def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option Expr) := do
let ref := struct.ref;
us ← cinfo.lparams.mapM $ fun _ => mkFreshLevelMVar ref;
def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
withRef struct.ref do
us ← cinfo.lparams.mapM $ fun _ => mkFreshLevelMVar;
mkDefaultValueAux? struct (cinfo.instantiateValueLevelParams us)
/-- If `e` is a projection function of one of the given structures, then reduce it -/
@ -679,7 +680,7 @@ partial def reduce (structNames : Array Name) : Expr → MetaM Expr
| none => pure e
| e => pure e
partial def tryToSynthesizeDefaultAux (ref : Syntax) (structs : Array Struct) (allStructNames : Array Name) (maxDistance : Nat)
partial def tryToSynthesizeDefaultAux (structs : Array Struct) (allStructNames : Array Name) (maxDistance : Nat)
(fieldName : Name) (mvarId : MVarId) : Nat → Nat → TermElabM Bool
| i, dist =>
if dist > maxDistance then pure false
@ -694,21 +695,21 @@ partial def tryToSynthesizeDefaultAux (ref : Syntax) (structs : Array Struct) (a
match val? with
| none => do setMCtx mctx; tryToSynthesizeDefaultAux (i+1) (dist+1)
| some val => do
val ← liftMetaM struct.ref $ reduce allStructNames val;
val ← liftMetaM $ reduce allStructNames val;
match val.find? $ fun e => (isDefaultMissing? e).isSome with
| some _ => do setMCtx mctx; tryToSynthesizeDefaultAux (i+1) (dist+1)
| none => do
mvarDecl ← getMVarDecl mvarId;
val ← ensureHasType ref mvarDecl.type val;
val ← ensureHasType mvarDecl.type val;
assignExprMVar mvarId val;
pure true
| _ => tryToSynthesizeDefaultAux (i+1) dist
else
pure false
def tryToSynthesizeDefault (ref : Syntax) (structs : Array Struct) (allStructNames : Array Name)
def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Array Name)
(maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
tryToSynthesizeDefaultAux ref structs allStructNames maxDistance fieldName mvarId 0 0
tryToSynthesizeDefaultAux structs allStructNames maxDistance fieldName mvarId 0 0
partial def step : Struct → M Unit
| struct => unlessM isRoundDone $ adaptReader (fun (ctx : Context) => { ctx with structs := ctx.structs.push struct }) $ do
@ -721,7 +722,7 @@ partial def step : Struct → M Unit
| some (Expr.mvar mvarId _) =>
unlessM (liftM $ isExprMVarAssigned mvarId) $ do
ctx ← read;
whenM (liftM $ tryToSynthesizeDefault field.ref ctx.structs ctx.allStructNames ctx.maxDistance (getFieldName field) mvarId) $ do
whenM (liftM $ withRef field.ref $ tryToSynthesizeDefault ctx.structs ctx.allStructNames ctx.maxDistance (getFieldName field) mvarId) $ do
modify $ fun s => { s with progress := true }
| _ => pure ()
@ -732,7 +733,7 @@ partial def propagateLoop (hierarchyDepth : Nat) : Nat → Struct → M Unit
| none => pure () -- Done
| some field =>
if d > hierarchyDepth then
liftM $ throwError field.ref ("field '" ++ getFieldName field ++ "' is missing")
liftM $ throwErrorAt field.ref ("field '" ++ getFieldName field ++ "' is missing")
else adaptReader (fun (ctx : Context) => { ctx with maxDistance := d }) $ do
modify $ fun (s : State) => { s with progress := false };
step struct;
@ -753,12 +754,12 @@ private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sour
structName ← getStructName stx expectedType? source;
env ← getEnv;
unless (isStructureLike env structName) $
throwError stx ("invalid {...} notation, '" ++ structName ++ "' is not a structure");
throwError ("invalid {...} notation, '" ++ structName ++ "' is not a structure");
match mkStructView stx structName source with
| Except.error ex => throwError stx ex
| Except.error ex => throwError ex
| Except.ok struct => do
struct ← expandStruct struct;
trace `Elab.struct stx $ fun _ => toString struct;
trace `Elab.struct fun _ => toString struct;
(r, struct) ← elabStruct struct expectedType?;
DefaultFields.propagate struct;
pure r
@ -785,7 +786,7 @@ fun stx expectedType? => do
modifyOp? ← isModifyOp? stx;
match modifyOp?, sourceView with
| some modifyOp, Source.explicit source _ => elabModifyOp stx modifyOp source expectedType?
| some _, _ => throwError stx ("invalid {...} notation, explicit source is required when using '[<index>] := <value>'")
| some _, _ => throwError ("invalid {...} notation, explicit source is required when using '[<index>] := <value>'")
| _, _ => elabStructInstAux stx expectedType? sourceView
@[init] private def regTraceClasses : IO Unit := do

175
stage0/src/Lean/Elab/Structure.lean
View file

@ -192,14 +192,14 @@ match type with
| Expr.sort (Level.succ _ _) _ => true
| _ => false
private def checkParentIsStructure (ref : Syntax) (parent : Expr) : TermElabM Name :=
private def checkParentIsStructure (parent : Expr) : TermElabM Name :=
match parent.getAppFn with
| Expr.const c _ _ => do
env ← Term.getEnv;
unless (isStructure env c) $
Term.throwError ref $ "'" ++ toString c ++ "' is not a structure";
Term.throwError $ "'" ++ toString c ++ "' is not a structure";
pure c
| _ => Term.throwError ref $ "expected structure"
| _ => Term.throwError $ "expected structure"
private def findFieldInfo? (infos : Array StructFieldInfo) (fieldName : Name) : Option StructFieldInfo :=
infos.find? fun info => info.name == fieldName
@ -207,17 +207,17 @@ infos.find? fun info => info.name == fieldName
private def containsFieldName (infos : Array StructFieldInfo) (fieldName : Name) : Bool :=
(findFieldInfo? infos fieldName).isSome
private partial def processSubfields {α} (ref : Syntax) (structDeclName : Name) (parentFVar : Expr) (parentStructName : Name) (subfieldNames : Array Name)
private partial def processSubfields {α} (structDeclName : Name) (parentFVar : Expr) (parentStructName : Name) (subfieldNames : Array Name)
: Nat → Array StructFieldInfo → (Array StructFieldInfo → TermElabM α) → TermElabM α
| i, infos, k =>
if h : i < subfieldNames.size then do
let subfieldName := subfieldNames.get ⟨i, h⟩;
env ← Term.getEnv;
when (containsFieldName infos subfieldName) $
Term.throwError ref ("field '" ++ subfieldName ++ "' from '" ++ parentStructName ++ "' has already been declared");
val ← Term.liftMetaM ref $ Meta.mkProjection parentFVar subfieldName;
type ← Term.inferType ref val;
Term.withLetDecl ref subfieldName type val fun subfieldFVar =>
Term.throwError ("field '" ++ subfieldName ++ "' from '" ++ parentStructName ++ "' has already been declared");
val ← Term.liftMetaM $ Meta.mkProjection parentFVar subfieldName;
type ← Term.inferType val;
Term.withLetDecl subfieldName type val fun subfieldFVar =>
/- The following `declName` is only used for creating the `_default` auxiliary declaration name when
its default value is overwritten in the structure. -/
let declName := structDeclName ++ subfieldName;
@ -228,19 +228,20 @@ private partial def processSubfields {α} (ref : Syntax) (structDeclName : Name)
private partial def withParents {α} (view : StructView) : Nat → Array StructFieldInfo → (Array StructFieldInfo → TermElabM α) → TermElabM α
| i, infos, k =>
if h : i < view.parents.size then do
if h : i < view.parents.size then
let parentStx := view.parents.get ⟨i, h⟩;
Term.withRef parentStx do
parent ← Term.elabType parentStx;
parentName ← checkParentIsStructure parentStx parent;
parentName ← checkParentIsStructure parent;
let toParentName := mkNameSimple $ "to" ++ parentName.eraseMacroScopes.getString!; -- erase macro scopes?
when (containsFieldName infos toParentName) $
Term.throwError parentStx ("field '" ++ toParentName ++ "' has already been declared");
Term.throwErrorAt parentStx ("field '" ++ toParentName ++ "' has already been declared");
env ← Term.getEnv;
let binfo := if view.isClass && isClass env parentName then BinderInfo.instImplicit else BinderInfo.default;
Term.withLocalDecl parentStx toParentName binfo parent $ fun parentFVar =>
Term.withLocalDecl toParentName binfo parent $ fun parentFVar =>
let infos := infos.push { name := toParentName, declName := view.declName ++ toParentName, fvar := parentFVar, kind := StructFieldKind.subobject };
let subfieldNames := getStructureFieldsFlattened env parentName;
processSubfields parentStx view.declName parentFVar parentName subfieldNames 0 infos fun infos => withParents (i+1) infos k
processSubfields view.declName parentFVar parentName subfieldNames 0 infos fun infos => withParents (i+1) infos k
else
k infos
@ -248,141 +249,142 @@ private partial def withFields {α} (views : Array StructFieldView) : Nat → Ar
| i, infos, k =>
if h : i < views.size then do
let view := views.get ⟨i, h⟩;
Term.withRef view.ref $
match findFieldInfo? infos view.name with
| none => do
(type?, value?) ← Term.elabBinders view.binders.getArgs $ fun params => do {
type? ← match view.type? with
| none => pure none
| some typeStx => do { type ← Term.elabType typeStx; type ← Term.mkForall typeStx params type; pure $ some type };
| some typeStx => do { type ← Term.elabType typeStx; type ← Term.mkForall params type; pure $ some type };
value? ← match view.value? with
| none => pure none
| some valStx => do {
value ← Term.elabTerm valStx type?;
value ← Term.mkLambda valStx params value;
value ← Term.ensureHasType valStx type? value;
value ← Term.mkLambda params value;
value ← Term.withRef valStx $ Term.ensureHasType type? value;
pure $ some value
};
pure (type?, value?)
};
match type?, value? with
| none, none => Term.throwError view.ref "invalid field, type expected"
| none, none => Term.throwError "invalid field, type expected"
| some type, _ =>
Term.withLocalDecl view.ref view.name view.binderInfo type $ fun fieldFVar =>
Term.withLocalDecl view.name view.binderInfo type $ fun fieldFVar =>
let infos := infos.push { name := view.name, declName := view.declName, fvar := fieldFVar, value? := value?,
kind := StructFieldKind.newField, inferMod := view.inferMod };
withFields (i+1) infos k
| none, some value => do
type ← Term.inferType view.ref value;
Term.withLocalDecl view.ref view.name view.binderInfo type $ fun fieldFVar =>
type ← Term.inferType value;
Term.withLocalDecl view.name view.binderInfo type $ fun fieldFVar =>
let infos := infos.push { name := view.name, declName := view.declName, fvar := fieldFVar, kind := StructFieldKind.newField, inferMod := view.inferMod };
withFields (i+1) infos k
| some info =>
match info.kind with
| StructFieldKind.newField => Term.throwError view.ref ("field '" ++ view.name ++ "' has already been declared")
| StructFieldKind.newField => Term.throwError ("field '" ++ view.name ++ "' has already been declared")
| StructFieldKind.fromParent =>
match view.value? with
| none => Term.throwError view.ref ("field '" ++ view.name ++ "' has been declared in parent structure")
| none => Term.throwError ("field '" ++ view.name ++ "' has been declared in parent structure")
| some valStx => do
when (!view.binders.getArgs.isEmpty || view.type?.isSome) $
Term.throwError view.type?.get! ("omit field '" ++ view.name ++ "' type to set default value");
fvarType ← Term.inferType view.ref info.fvar;
Term.throwErrorAt view.type?.get! ("omit field '" ++ view.name ++ "' type to set default value");
fvarType ← Term.inferType info.fvar;
value ← Term.elabTerm valStx fvarType;
value ← Term.ensureHasType valStx fvarType value;
value ← Term.withRef valStx $ Term.ensureHasType fvarType value;
let infos := infos.push { info with value? := value };
withFields (i+1) infos k
| StructFieldKind.subobject => unreachable!
else
k infos
private def getResultUniverse (ref : Syntax) (type : Expr) : TermElabM Level := do
type ← Term.whnf ref type;
private def getResultUniverse (type : Expr) : TermElabM Level := do
type ← Term.whnf type;
match type with
| Expr.sort u _ => pure u
| _ => Term.throwError ref "unexpected structure resulting type"
| _ => Term.throwError "unexpected structure resulting type"
private def removeUnused (ref : Syntax) (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
private def removeUnused (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
: TermElabM (LocalContext × LocalInstances × Array Expr) := do
used ← params.foldlM
(fun (used : CollectFVars.State) p => do
type ← Term.inferType ref p;
Term.collectUsedFVars ref used type)
type ← Term.inferType p;
Term.collectUsedFVars used type)
{};
used ← fieldInfos.foldlM
(fun (used : CollectFVars.State) info => do
fvarType ← Term.inferType ref info.fvar;
used ← Term.collectUsedFVars ref used fvarType;
fvarType ← Term.inferType info.fvar;
used ← Term.collectUsedFVars used fvarType;
match info.value? with
| none => pure used
| some value => Term.collectUsedFVars ref used value)
| some value => Term.collectUsedFVars used value)
used;
Term.removeUnused ref scopeVars used
Term.removeUnused scopeVars used
private def withUsed {α} (ref : Syntax) (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) (k : Array Expr → TermElabM α)
private def withUsed {α} (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) (k : Array Expr → TermElabM α)
: TermElabM α := do
(lctx, localInsts, vars) ← removeUnused ref scopeVars params fieldInfos;
(lctx, localInsts, vars) ← removeUnused scopeVars params fieldInfos;
Term.withLCtx lctx localInsts $ k vars
private def levelMVarToParamFVar (ref : Syntax) (fvar : Expr) : StateT Nat TermElabM Unit := do
type ← liftM $ Term.inferType ref fvar;
private def levelMVarToParamFVar (fvar : Expr) : StateT Nat TermElabM Unit := do
type ← liftM $ Term.inferType fvar;
_ ← Term.levelMVarToParam' type;
pure ()
private def levelMVarToParamFVars (ref : Syntax) (fvars : Array Expr) : StateT Nat TermElabM Unit :=
fvars.forM (levelMVarToParamFVar ref)
private def levelMVarToParamFVars (fvars : Array Expr) : StateT Nat TermElabM Unit :=
fvars.forM levelMVarToParamFVar
private def levelMVarToParamAux (ref : Syntax) (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
private def levelMVarToParamAux (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
: StateT Nat TermElabM (Array StructFieldInfo) := do
levelMVarToParamFVars ref scopeVars;
levelMVarToParamFVars ref params;
levelMVarToParamFVars scopeVars;
levelMVarToParamFVars params;
fieldInfos.mapM fun info => do
levelMVarToParamFVar ref info.fvar;
levelMVarToParamFVar info.fvar;
match info.value? with
| none => pure info
| some value => do
value ← Term.levelMVarToParam' value;
pure { info with value? := value }
private def levelMVarToParam (ref : Syntax) (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM (Array StructFieldInfo) :=
(levelMVarToParamAux ref scopeVars params fieldInfos).run' 1
private def levelMVarToParam (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM (Array StructFieldInfo) :=
(levelMVarToParamAux scopeVars params fieldInfos).run' 1
private partial def collectUniversesFromFields (ref : Syntax) (r : Level) (rOffset : Nat) (fieldInfos : Array StructFieldInfo) : TermElabM (Array Level) := do
private partial def collectUniversesFromFields (r : Level) (rOffset : Nat) (fieldInfos : Array StructFieldInfo) : TermElabM (Array Level) := do
fieldInfos.foldlM
(fun (us : Array Level) (info : StructFieldInfo) => do
type ← Term.inferType ref info.fvar;
u ← Term.getLevel ref type;
u ← Term.instantiateLevelMVars ref u;
type ← Term.inferType info.fvar;
u ← Term.getLevel type;
u ← Term.instantiateLevelMVars u;
match accLevelAtCtor u r rOffset us with
| Except.error msg => Term.throwError ref msg
| Except.error msg => Term.throwError msg
| Except.ok us => pure us)
#[]
private def updateResultingUniverse (ref : Syntax) (fieldInfos : Array StructFieldInfo) (type : Expr) : TermElabM Expr := do
r ← getResultUniverse ref type;
private def updateResultingUniverse (fieldInfos : Array StructFieldInfo) (type : Expr) : TermElabM Expr := do
r ← getResultUniverse type;
let rOffset : Nat := r.getOffset;
let r : Level := r.getLevelOffset;
match r with
| Level.mvar mvarId _ => do
us ← collectUniversesFromFields ref r rOffset fieldInfos;
us ← collectUniversesFromFields r rOffset fieldInfos;
let rNew := Level.mkNaryMax us.toList;
Term.assignLevelMVar mvarId rNew;
Term.instantiateMVars ref type
| _ => Term.throwError ref "failed to compute resulting universe level of structure, provide universe explicitly"
Term.instantiateMVars type
| _ => Term.throwError "failed to compute resulting universe level of structure, provide universe explicitly"
private def collectLevelParamsInFVar (ref : Syntax) (s : CollectLevelParams.State) (fvar : Expr) : TermElabM CollectLevelParams.State := do
type ← Term.inferType ref fvar;
type ← Term.instantiateMVars ref type;
private def collectLevelParamsInFVar (s : CollectLevelParams.State) (fvar : Expr) : TermElabM CollectLevelParams.State := do
type ← Term.inferType fvar;
type ← Term.instantiateMVars type;
pure $ collectLevelParams s type
private def collectLevelParamsInFVars (ref : Syntax) (fvars : Array Expr) (s : CollectLevelParams.State) : TermElabM CollectLevelParams.State :=
fvars.foldlM (collectLevelParamsInFVar ref) s
private def collectLevelParamsInFVars (fvars : Array Expr) (s : CollectLevelParams.State) : TermElabM CollectLevelParams.State :=
fvars.foldlM collectLevelParamsInFVar s
private def collectLevelParamsInStructure (ref : Syntax) (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM (Array Name) := do
s ← collectLevelParamsInFVars ref scopeVars {};
s ← collectLevelParamsInFVars ref params s;
s ← fieldInfos.foldlM (fun (s : CollectLevelParams.State) info => collectLevelParamsInFVar ref s info.fvar) s;
private def collectLevelParamsInStructure (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM (Array Name) := do
s ← collectLevelParamsInFVars scopeVars {};
s ← collectLevelParamsInFVars params s;
s ← fieldInfos.foldlM (fun (s : CollectLevelParams.State) info => collectLevelParamsInFVar s info.fvar) s;
pure s.params
private def addCtorFields (ref : Syntax) (fieldInfos : Array StructFieldInfo) : Nat → Expr → TermElabM Expr
private def addCtorFields (fieldInfos : Array StructFieldInfo) : Nat → Expr → TermElabM Expr
| 0, type => pure type
| i+1, type => do
let info := fieldInfos.get! i;
@ -398,36 +400,37 @@ private def addCtorFields (ref : Syntax) (fieldInfos : Array StructFieldInfo) :
| StructFieldKind.newField =>
addCtorFields i (mkForall decl.userName decl.binderInfo decl.type type)
private def mkCtor (view : StructView) (levelParams : List Name) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM Constructor := do
private def mkCtor (view : StructView) (levelParams : List Name) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM Constructor :=
Term.withRef view.ref do
let type := mkAppN (mkConst view.declName (levelParams.map mkLevelParam)) params;
type ← addCtorFields view.ref fieldInfos fieldInfos.size type;
type ← Term.mkForall view.ref params type;
type ← Term.instantiateMVars view.ref type;
type ← addCtorFields fieldInfos fieldInfos.size type;
type ← Term.mkForall params type;
type ← Term.instantiateMVars type;
let type := type.inferImplicit params.size !view.ctor.inferMod;
pure { name := view.ctor.declName, type := type }
private def elabStructureView (view : StructView) : TermElabM ElabStructResult := do
let numExplicitParams := view.params.size;
type ← Term.elabType view.type;
unless (validStructType type) $ Term.throwError view.type "expected Type";
let ref := view.ref;
unless (validStructType type) $ Term.throwErrorAt view.type "expected Type";
Term.withRef view.ref do
withParents view 0 #[] fun fieldInfos =>
withFields view.fields 0 fieldInfos fun fieldInfos => do
Term.synthesizeSyntheticMVars false; -- resolve pending
u ← getResultUniverse ref type;
inferLevel ← shouldInferResultUniverse ref u;
withUsed ref view.scopeVars view.params fieldInfos $ fun scopeVars => do
u ← getResultUniverse type;
inferLevel ← shouldInferResultUniverse u;
withUsed view.scopeVars view.params fieldInfos $ fun scopeVars => do
let numParams := scopeVars.size + numExplicitParams;
fieldInfos ← levelMVarToParam ref scopeVars view.params fieldInfos;
type ← if inferLevel then updateResultingUniverse ref fieldInfos type else pure type;
usedLevelNames ← collectLevelParamsInStructure ref scopeVars view.params fieldInfos;
fieldInfos ← levelMVarToParam scopeVars view.params fieldInfos;
type ← if inferLevel then updateResultingUniverse fieldInfos type else pure type;
usedLevelNames ← collectLevelParamsInStructure scopeVars view.params fieldInfos;
match sortDeclLevelParams view.scopeLevelNames view.allUserLevelNames usedLevelNames with
| Except.error msg => Term.throwError ref msg
| Except.error msg => Term.throwError msg
| Except.ok levelParams => do
let params := scopeVars ++ view.params;
ctor ← mkCtor view levelParams params fieldInfos;
type ← Term.mkForall ref params type;
type ← Term.instantiateMVars ref type;
type ← Term.mkForall params type;
type ← Term.instantiateMVars type;
let indType := { name := view.declName, type := type, ctors := [ctor] : InductiveType };
let decl := Declaration.inductDecl levelParams params.size [indType] view.modifiers.isUnsafe;
let projInfos := (fieldInfos.filter fun (info : StructFieldInfo) => !info.isFromParent).toList.map fun (info : StructFieldInfo) =>
@ -442,7 +445,7 @@ withFields view.fields 0 fieldInfos fun fieldInfos => do
localInsts ← Term.getLocalInsts;
let fieldsWithDefault := fieldInfos.filter fun info => info.value?.isSome;
defaultAuxDecls ← fieldsWithDefault.mapM fun info => do {
type ← Term.inferType ref info.fvar;
type ← Term.inferType info.fvar;
pure (info.declName ++ `_default, type, info.value?.get!)
};
/- The `mctx`, `lctx`, `localInsts` and `defaultAuxDecls` are used to create the auxiliary `_default` declarations *after* the structure has been declarated.
@ -483,9 +486,9 @@ liftTermElabM none $ Term.withLocalContext lctx localInsts do
Term.setMCtx mctx;
defaultAuxDecls.forM fun ⟨declName, type, value⟩ => do
/- The identity function is used as "marker". -/
value ← Term.liftMetaM ref $ Meta.mkId value;
value ← Term.liftMetaM $ Meta.mkId value;
let zeta := true; -- expand `let-declarations`
_ ← Term.mkAuxDefinition ref declName type value zeta;
_ ← Term.mkAuxDefinition declName type value zeta;
Term.modifyEnv fun env => setReducibilityStatus env declName ReducibilityStatus.reducible;
pure ()
@ -532,7 +535,7 @@ withDeclId declId $ fun name => do
fields := fields
};
let ref := declId;
addDecl ref r.decl;
addDecl r.decl;
addProjections ref declName r.projInfos isClass;
mkAuxConstructions declName;
applyAttributes ref declName modifiers.attrs AttributeApplicationTime.afterTypeChecking;

22
stage0/src/Lean/Elab/Syntax.lean
View file

@ -54,9 +54,9 @@ if ctx.first && stx.getKind == `Lean.Parser.Syntax.cat then do
let cat := (stx.getIdAt 0).eraseMacroScopes;
if cat == ctx.catName then do
let prec? : Option Nat := expandOptPrecedence (stx.getArg 1);
unless prec?.isNone $ liftM $ throwError (stx.getArg 1) ("invalid occurrence of ':<num>' modifier in head");
unless prec?.isNone $ liftM $ throwErrorAt (stx.getArg 1) ("invalid occurrence of ':<num>' modifier in head");
unless ctx.leftRec $ liftM $
throwError (stx.getArg 3) ("invalid occurrence of '" ++ cat ++ "', parser algorithm does not allow this form of left recursion");
throwErrorAt (stx.getArg 3) ("invalid occurrence of '" ++ cat ++ "', parser algorithm does not allow this form of left recursion");
markAsTrailingParser; -- mark as trailing par
pure true
else
@ -71,7 +71,7 @@ partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
let args := stx.getArgs;
condM (checkLeftRec (stx.getArg 0))
(do
when (args.size == 1) $ liftM $ throwError stx "invalid atomic left recursive syntax";
when (args.size == 1) $ liftM $ throwErrorAt stx "invalid atomic left recursive syntax";
let args := args.eraseIdx 0;
args ← args.mapIdxM $ fun i arg => withNotFirst $ toParserDescrAux arg;
liftM $ mkParserSeq args)
@ -86,7 +86,7 @@ partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
let cat := (stx.getIdAt 0).eraseMacroScopes;
ctx ← read;
if ctx.first && cat == ctx.catName then
liftM $ throwError stx "invalid atomic left recursive syntax"
liftM $ throwErrorAt stx "invalid atomic left recursive syntax"
else do
let prec? : Option Nat := expandOptPrecedence (stx.getArg 1);
env ← liftM getEnv;
@ -109,11 +109,11 @@ partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
| _ => false;
let candidates := candidates.map fun ⟨c, _⟩ => c;
match candidates with
| [] => liftM $ throwError (stx.getArg 3) ("unknown category '" ++ cat ++ "' or parser declaration")
| [] => liftM $ throwErrorAt (stx.getArg 3) ("unknown category '" ++ cat ++ "' or parser declaration")
| [c] => do
unless prec?.isNone $ liftM $ throwError (stx.getArg 3) "unexpected precedence";
unless prec?.isNone $ liftM $ throwErrorAt (stx.getArg 3) "unexpected precedence";
`(ParserDescr.parser $(quote c))
| cs => liftM $ throwError (stx.getArg 3) ("ambiguous parser declaration " ++ toString cs)
| cs => liftM $ throwErrorAt (stx.getArg 3) ("ambiguous parser declaration " ++ toString cs)
else if kind == `Lean.Parser.Syntax.atom then do
match (stx.getArg 0).isStrLit? with
| some atom => do
@ -159,7 +159,7 @@ partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
d₂ ← withoutLeftRec $ toParserDescrAux (stx.getArg 2);
`(ParserDescr.orelse $d₁ $d₂)
else
liftM $ throwError stx $ "unexpected syntax kind of category `syntax`: " ++ kind
liftM $ throwErrorAt stx $ "unexpected syntax kind of category `syntax`: " ++ kind
/--
Given a `stx` of category `syntax`, return a pair `(newStx, trailingParser)`,
@ -429,10 +429,10 @@ fun stx => do
registerTraceClass `Elab.syntax;
pure ()
@[inline] def withExpectedType (ref : Syntax) (expectedType? : Option Expr) (x : Expr → TermElabM Expr) : TermElabM Expr := do
@[inline] def withExpectedType (expectedType? : Option Expr) (x : Expr → TermElabM Expr) : TermElabM Expr := do
Term.tryPostponeIfNoneOrMVar expectedType?;
some expectedType ← pure expectedType?
| Term.throwError ref "expected type must be known";
| Term.throwError "expected type must be known";
x expectedType
/-
@ -462,7 +462,7 @@ fun stx => do
if expectedTypeSpec.hasArgs then
if catName == `term then
let expId := expectedTypeSpec.getArg 1;
`(syntax $prec* [$kindId] $stxParts* : $cat @[termElab $kindId:ident] def elabFn : Lean.Elab.Term.TermElab := fun stx expectedType? => match_syntax stx with | `($pat) => Lean.Elab.Command.withExpectedType stx expectedType? fun $expId => $rhs | _ => Lean.Elab.Term.throwUnsupportedSyntax)
`(syntax $prec* [$kindId] $stxParts* : $cat @[termElab $kindId:ident] def elabFn : Lean.Elab.Term.TermElab := fun stx expectedType? => match_syntax stx with | `($pat) => Lean.Elab.Command.withExpectedType expectedType? fun $expId => $rhs | _ => Lean.Elab.Term.throwUnsupportedSyntax)
else
Macro.throwError expectedTypeSpec ("syntax category '" ++ toString catName ++ "' does not support expected type specification")
else if catName == `term then

79
stage0/src/Lean/Elab/SyntheticMVars.lean
View file

@ -12,23 +12,25 @@ namespace Term
open Tactic (TacticM evalTactic getUnsolvedGoals)
def liftTacticElabM {α} (ref : Syntax) (mvarId : MVarId) (x : TacticM α) : TermElabM α :=
def liftTacticElabM {α} (mvarId : MVarId) (x : TacticM α) : TermElabM α :=
withMVarContext mvarId $ fun ctx s =>
let savedSyntheticMVars := s.syntheticMVars;
match x { ctx with ref := ref, main := mvarId } { s with goals := [mvarId], syntheticMVars := [] } with
match x { ctx with main := mvarId } { s with goals := [mvarId], syntheticMVars := [] } with
| EStateM.Result.error ex newS => EStateM.Result.error (Term.Exception.ex ex) { newS.toTermState with syntheticMVars := savedSyntheticMVars }
| EStateM.Result.ok a newS => EStateM.Result.ok a { newS.toTermState with syntheticMVars := savedSyntheticMVars }
def ensureAssignmentHasNoMVars (ref : Syntax) (mvarId : MVarId) : TermElabM Unit := do
val ← instantiateMVars ref (mkMVar mvarId);
when val.hasExprMVar $ throwError ref ("tactic failed, result still contain metavariables" ++ indentExpr val)
def ensureAssignmentHasNoMVars (mvarId : MVarId) : TermElabM Unit := do
val ← instantiateMVars (mkMVar mvarId);
when val.hasExprMVar $ throwError ("tactic failed, result still contain metavariables" ++ indentExpr val)
def runTactic (ref : Syntax) (mvarId : MVarId) (tacticCode : Syntax) : TermElabM Unit := do
def runTactic (mvarId : MVarId) (tacticCode : Syntax) : TermElabM Unit := do
modify $ fun s => { s with mctx := s.mctx.instantiateMVarDeclMVars mvarId };
remainingGoals ← liftTacticElabM ref mvarId $ do { evalTactic tacticCode; getUnsolvedGoals };
remainingGoals ← liftTacticElabM mvarId $ do { evalTactic tacticCode; getUnsolvedGoals };
ref ← getCurrRef;
let tailRef := ref.getTailWithPos.getD ref;
unless remainingGoals.isEmpty (reportUnsolvedGoals tailRef remainingGoals);
ensureAssignmentHasNoMVars tailRef mvarId
withRef tailRef do
unless remainingGoals.isEmpty (reportUnsolvedGoals remainingGoals);
ensureAssignmentHasNoMVars mvarId
/-- Auxiliary function used to implement `synthesizeSyntheticMVars`. -/
private def resumeElabTerm (stx : Syntax) (expectedType? : Option Expr) (errToSorry := true) : TermElabM Expr :=
@ -41,16 +43,16 @@ adaptReader (fun (ctx : Context) => { ctx with errToSorry := ctx.errToSorry && e
It returns `true` if it succeeded, and `false` otherwise.
It is used to implement `synthesizeSyntheticMVars`. -/
private def resumePostponed (macroStack : MacroStack) (stx : Syntax) (mvarId : MVarId) (postponeOnError : Bool) : TermElabM Bool := do
withMVarContext mvarId $ do
withRef stx $ withMVarContext mvarId $ do
s ← get;
catch
(adaptReader (fun (ctx : Context) => { ctx with macroStack := macroStack }) $ do
mvarDecl ← getMVarDecl mvarId;
expectedType ← instantiateMVars stx mvarDecl.type;
expectedType ← instantiateMVars mvarDecl.type;
result ← resumeElabTerm stx expectedType (!postponeOnError);
/- We must ensure `result` has the expected type because it is the one expected by the method that postponed stx.
That is, the method does not have an opportunity to check whether `result` has the expected type or not. -/
result ← ensureHasType stx expectedType result;
result ← ensureHasType expectedType result;
assignExprMVar mvarId result;
pure true)
(fun ex => match ex with
@ -65,40 +67,41 @@ withMVarContext mvarId $ do
/--
Similar to `synthesizeInstMVarCore`, but makes sure that `instMVar` local context and instances
are used. It also logs any error message produced. -/
private def synthesizePendingInstMVar (ref : Syntax) (instMVar : MVarId) : TermElabM Bool := do
private def synthesizePendingInstMVar (instMVar : MVarId) : TermElabM Bool := do
withMVarContext instMVar $ catch
(synthesizeInstMVarCore ref instMVar)
(synthesizeInstMVarCore instMVar)
(fun ex => match ex with
| Exception.ex (Elab.Exception.error errMsg) => do logMessage errMsg; pure true
| _ => unreachable!)
/--
Similar to `synthesizePendingInstMVar`, but generates type mismatch error message. -/
private def synthesizePendingCoeInstMVar (ref : Syntax) (instMVar : MVarId) (expectedType : Expr) (eType : Expr) (e : Expr) (f? : Option Expr) : TermElabM Bool := do
private def synthesizePendingCoeInstMVar (instMVar : MVarId) (expectedType : Expr) (eType : Expr) (e : Expr) (f? : Option Expr) : TermElabM Bool := do
withMVarContext instMVar $ catch
(synthesizeInstMVarCore ref instMVar)
(synthesizeInstMVarCore instMVar)
(fun ex => match ex with
| Exception.ex (Elab.Exception.error errMsg) => throwTypeMismatchError ref expectedType eType e f? errMsg.data
| Exception.ex (Elab.Exception.error errMsg) => throwTypeMismatchError expectedType eType e f? errMsg.data
| _ => unreachable!)
/--
Return `true` iff `mvarId` is assigned to a term whose the
head is not a metavariable. We use this method to process `SyntheticMVarKind.withDefault`. -/
private def checkWithDefault (ref : Syntax) (mvarId : MVarId) : TermElabM Bool := do
val ← instantiateMVars ref (mkMVar mvarId);
private def checkWithDefault (mvarId : MVarId) : TermElabM Bool := do
val ← instantiateMVars (mkMVar mvarId);
pure $ !val.getAppFn.isMVar
/-- Try to synthesize the given pending synthetic metavariable. -/
private def synthesizeSyntheticMVar (mvarSyntheticDecl : SyntheticMVarDecl) (postponeOnError : Bool) (runTactics : Bool) : TermElabM Bool :=
withRef mvarSyntheticDecl.ref $
match mvarSyntheticDecl.kind with
| SyntheticMVarKind.typeClass => synthesizePendingInstMVar mvarSyntheticDecl.ref mvarSyntheticDecl.mvarId
| SyntheticMVarKind.coe expectedType eType e f? => synthesizePendingCoeInstMVar mvarSyntheticDecl.ref mvarSyntheticDecl.mvarId expectedType eType e f?
| SyntheticMVarKind.typeClass => synthesizePendingInstMVar mvarSyntheticDecl.mvarId
| SyntheticMVarKind.coe expectedType eType e f? => synthesizePendingCoeInstMVar mvarSyntheticDecl.mvarId expectedType eType e f?
-- NOTE: actual processing at `synthesizeSyntheticMVarsAux`
| SyntheticMVarKind.withDefault _ => checkWithDefault mvarSyntheticDecl.ref mvarSyntheticDecl.mvarId
| SyntheticMVarKind.withDefault _ => checkWithDefault mvarSyntheticDecl.mvarId
| SyntheticMVarKind.postponed macroStack => resumePostponed macroStack mvarSyntheticDecl.ref mvarSyntheticDecl.mvarId postponeOnError
| SyntheticMVarKind.tactic tacticCode =>
if runTactics then do
runTactic mvarSyntheticDecl.ref mvarSyntheticDecl.mvarId tacticCode;
runTactic mvarSyntheticDecl.mvarId tacticCode;
pure true
else
pure false
@ -119,9 +122,9 @@ modify $ fun s => { s with syntheticMVars := [] };
-- We use `filterRevM` instead of `filterM` to make sure we process the synthetic metavariables using the order they were created.
-- It would not be incorrect to use `filterM`.
remainingSyntheticMVars ← syntheticMVars.filterRevM $ fun mvarDecl => do {
trace `Elab.postpone mvarDecl.ref $ fun _ => "resuming ?" ++ mvarDecl.mvarId;
trace `Elab.postpone $ fun _ => "resuming ?" ++ mvarDecl.mvarId;
succeeded ← synthesizeSyntheticMVar mvarDecl postponeOnError runTactics;
trace `Elab.postpone mvarDecl.ref $ fun _ => if succeeded then fmt "succeeded" else fmt "not ready yet";
trace `Elab.postpone $ fun _ => if succeeded then fmt "succeeded" else fmt "not ready yet";
pure $ !succeeded
};
-- Merge new synthetic metavariables with `remainingSyntheticMVars`, i.e., metavariables that still couldn't be synthesized
@ -133,12 +136,13 @@ private def synthesizeUsingDefault : TermElabM Bool := do
s ← get;
let len := s.syntheticMVars.length;
newSyntheticMVars ← s.syntheticMVars.filterM $ fun mvarDecl =>
withRef mvarDecl.ref $
match mvarDecl.kind with
| SyntheticMVarKind.withDefault defaultVal => withMVarContext mvarDecl.mvarId $ do
val ← instantiateMVars mvarDecl.ref (mkMVar mvarDecl.mvarId);
val ← instantiateMVars (mkMVar mvarDecl.mvarId);
when val.getAppFn.isMVar $
unlessM (isDefEq mvarDecl.ref val defaultVal) $
throwError mvarDecl.ref "failed to assign default value to metavariable"; -- TODO: better error message
unlessM (isDefEq val defaultVal) $
throwError "failed to assign default value to metavariable"; -- TODO: better error message
pure false
| _ => pure true;
modify $ fun s => { s with syntheticMVars := newSyntheticMVars };
@ -148,6 +152,7 @@ pure $ newSyntheticMVars.length != len
private def reportStuckSyntheticMVars : TermElabM Unit := do
s ← get;
s.syntheticMVars.forM $ fun mvarSyntheticDecl =>
withRef mvarSyntheticDecl.ref $
match mvarSyntheticDecl.kind with
| SyntheticMVarKind.typeClass =>
withMVarContext mvarSyntheticDecl.mvarId $ do
@ -157,7 +162,7 @@ s.syntheticMVars.forM $ fun mvarSyntheticDecl =>
| SyntheticMVarKind.coe expectedType eType e f? =>
withMVarContext mvarSyntheticDecl.mvarId $ do
mvarDecl ← getMVarDecl mvarSyntheticDecl.mvarId;
throwTypeMismatchError mvarSyntheticDecl.ref expectedType eType e f? (some ("failed to create type class instance for " ++ indentExpr mvarDecl.type))
throwTypeMismatchError expectedType eType e f? (some ("failed to create type class instance for " ++ indentExpr mvarDecl.type))
| _ => unreachable! -- TODO handle other cases.
private def getSomeSynthethicMVarsRef : TermElabM Syntax := do
@ -177,7 +182,7 @@ private partial def synthesizeSyntheticMVarsAux (mayPostpone := true) : Unit →
| _ => do
let try (x : TermElabM Bool) (k : TermElabM Unit) : TermElabM Unit := condM x (synthesizeSyntheticMVarsAux ()) k;
ref ← getSomeSynthethicMVarsRef;
withIncRecDepth ref $ do
withRef ref $ withIncRecDepth $ do
s ← get;
unless s.syntheticMVars.isEmpty $ do
try (synthesizeSyntheticMVarsStep false false) $
@ -210,18 +215,24 @@ private partial def synthesizeSyntheticMVarsAux (mayPostpone := true) : Unit →
def synthesizeSyntheticMVars (mayPostpone := true) : TermElabM Unit :=
synthesizeSyntheticMVarsAux mayPostpone ()
/-- Elaborate `stx`, and make sure all pending synthetic metavariables created while elaborating `stx` are solved. -/
def elabTermAndSynthesize (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
/-- Execute `k`, and make sure all pending synthetic metavariables created while executing `k` are solved. -/
def withSynthesize {α} (k : TermElabM α) : TermElabM α := do
s ← get;
let syntheticMVars := s.syntheticMVars;
modify $ fun s => { s with syntheticMVars := [] };
finally
(do
v ← elabTerm stx expectedType?;
a ← k;
synthesizeSyntheticMVars false;
instantiateMVars stx v)
pure a)
(modify $ fun s => { s with syntheticMVars := s.syntheticMVars ++ syntheticMVars })
/-- Elaborate `stx`, and make sure all pending synthetic metavariables created while elaborating `stx` are solved. -/
def elabTermAndSynthesize (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr :=
withRef stx do
v ← withSynthesize $ elabTerm stx expectedType?;
instantiateMVars v
end Term
end Elab
end Lean

132
stage0/src/Lean/Elab/Tactic/Basic.lean
View file

@ -18,15 +18,15 @@ namespace Elab
def goalsToMessageData (goals : List MVarId) : MessageData :=
MessageData.joinSep (goals.map $ MessageData.ofGoal) (Format.line ++ Format.line)
def Term.reportUnsolvedGoals (ref : Syntax) (goals : List MVarId) : TermElabM Unit :=
def Term.reportUnsolvedGoals (goals : List MVarId) : TermElabM Unit := do
ref ← Term.getCurrRef;
let tailRef := ref.getTailWithPos.getD ref;
Term.throwError tailRef $ "unsolved goals" ++ Format.line ++ goalsToMessageData goals
Term.throwErrorAt tailRef $ "unsolved goals" ++ Format.line ++ goalsToMessageData goals
namespace Tactic
structure Context extends toTermCtx : Term.Context :=
(main : MVarId)
(ref : Syntax)
structure State extends toTermState : Term.State :=
(goals : List MVarId)
@ -60,7 +60,10 @@ fun ctx s => match x ctx.toTermCtx s.toTermState with
| EStateM.Result.error (Term.Exception.ex ex) newS => EStateM.Result.error ex { s with toTermState := newS }
| EStateM.Result.error Term.Exception.postpone _ => unreachable!
def liftMetaM {α} (ref : Syntax) (x : MetaM α) : TacticM α := liftTermElabM $ Term.liftMetaM ref x
def liftMetaM {α} (x : MetaM α) : TacticM α := liftTermElabM $ Term.liftMetaM x
@[inline] def withRef {α} (ref : Syntax) (x : TacticM α) : TacticM α := do
adaptReader (fun (ctx : Context) => { ctx with ref := ref }) x
def getEnv : TacticM Environment := do s ← get; pure s.env
def getMCtx : TacticM MetavarContext := do s ← get; pure s.mctx
@ -69,21 +72,21 @@ def getLCtx : TacticM LocalContext := do ctx ← read; pure ctx.lctx
def getLocalInsts : TacticM LocalInstances := do ctx ← read; pure ctx.localInstances
def getOptions : TacticM Options := do ctx ← read; pure ctx.config.opts
def getMVarDecl (mvarId : MVarId) : TacticM MetavarDecl := do mctx ← getMCtx; pure $ mctx.getDecl mvarId
def instantiateMVars (ref : Syntax) (e : Expr) : TacticM Expr := liftTermElabM $ Term.instantiateMVars ref e
def instantiateMVars (e : Expr) : TacticM Expr := liftTermElabM $ Term.instantiateMVars e
def addContext (msg : MessageData) : TacticM MessageData := liftTermElabM $ Term.addContext msg
def isExprMVarAssigned (mvarId : MVarId) : TacticM Bool := liftTermElabM $ Term.isExprMVarAssigned mvarId
def assignExprMVar (mvarId : MVarId) (val : Expr) : TacticM Unit := liftTermElabM $ Term.assignExprMVar mvarId val
def ensureHasType (ref : Syntax) (expectedType? : Option Expr) (e : Expr) : TacticM Expr := liftTermElabM $ Term.ensureHasType ref expectedType? e
def reportUnsolvedGoals (ref : Syntax) (goals : List MVarId) : TacticM Unit := liftTermElabM $ Term.reportUnsolvedGoals ref goals
def inferType (ref : Syntax) (e : Expr) : TacticM Expr := liftTermElabM $ Term.inferType ref e
def whnf (ref : Syntax) (e : Expr) : TacticM Expr := liftTermElabM $ Term.whnf ref e
def whnfCore (ref : Syntax) (e : Expr) : TacticM Expr := liftTermElabM $ Term.whnfCore ref e
def unfoldDefinition? (ref : Syntax) (e : Expr) : TacticM (Option Expr) := liftTermElabM $ Term.unfoldDefinition? ref e
def ensureHasType (expectedType? : Option Expr) (e : Expr) : TacticM Expr := liftTermElabM $ Term.ensureHasType expectedType? e
def reportUnsolvedGoals (goals : List MVarId) : TacticM Unit := liftTermElabM $ Term.reportUnsolvedGoals goals
def inferType (e : Expr) : TacticM Expr := liftTermElabM $ Term.inferType e
def whnf (e : Expr) : TacticM Expr := liftTermElabM $ Term.whnf e
def whnfCore (e : Expr) : TacticM Expr := liftTermElabM $ Term.whnfCore e
def unfoldDefinition? (e : Expr) : TacticM (Option Expr) := liftTermElabM $ Term.unfoldDefinition? e
def resolveGlobalName (n : Name) : TacticM (List (Name × List String)) := liftTermElabM $ Term.resolveGlobalName n
/-- Collect unassigned metavariables -/
def collectMVars (ref : Syntax) (e : Expr) : TacticM (List MVarId) := do
e ← instantiateMVars ref e;
def collectMVars (e : Expr) : TacticM (List MVarId) := do
e ← instantiateMVars e;
let s := Lean.collectMVars {} e;
pure s.result.toList
@ -94,15 +97,17 @@ instance monadLog : MonadLog TacticM :=
addContext := addContext,
logMessage := fun msg => modify $ fun s => { s with messages := s.messages.add msg } }
def throwError {α} (ref : Syntax) (msgData : MessageData) : TacticM α := do
ref ← if ref.getPos.isNone then do ctx ← read; pure ctx.ref else pure ref;
liftTermElabM $ Term.throwError ref msgData
def throwErrorAt {α} (ref : Syntax) (msgData : MessageData) : TacticM α := do
liftTermElabM $ Term.throwErrorAt ref msgData
def throwError {α} (msgData : MessageData) : TacticM α := do
liftTermElabM $ Term.throwError msgData
def throwUnsupportedSyntax {α} : TacticM α := liftTermElabM $ Term.throwUnsupportedSyntax
@[inline] def withIncRecDepth {α} (ref : Syntax) (x : TacticM α) : TacticM α := do
@[inline] def withIncRecDepth {α} (x : TacticM α) : TacticM α := do
ctx ← read;
when (ctx.currRecDepth == ctx.maxRecDepth) $ throwError ref maxRecDepthErrorMessage;
when (ctx.currRecDepth == ctx.maxRecDepth) $ throwError maxRecDepthErrorMessage;
adaptReader (fun (ctx : Context) => { ctx with currRecDepth := ctx.currRecDepth + 1 }) x
protected def getCurrMacroScope : TacticM MacroScope := do ctx ← read; pure ctx.currMacroScope
@ -123,14 +128,14 @@ mkElabAttribute Tactic `Lean.Elab.Tactic.tacticElabAttribute `builtinTactic `tac
@[init mkTacticAttribute] constant tacticElabAttribute : KeyedDeclsAttribute Tactic := arbitrary _
def logTrace (cls : Name) (ref : Syntax) (msg : MessageData) : TacticM Unit := liftTermElabM $ Term.logTrace cls ref msg
@[inline] def trace (cls : Name) (ref : Syntax) (msg : Unit → MessageData) : TacticM Unit := liftTermElabM $ Term.trace cls ref msg
@[inline] def trace (cls : Name) (msg : Unit → MessageData) : TacticM Unit := liftTermElabM $ Term.trace cls msg
@[inline] def traceAtCmdPos (cls : Name) (msg : Unit → MessageData) : TacticM Unit := liftTermElabM $ Term.traceAtCmdPos cls msg
def dbgTrace {α} [HasToString α] (a : α) : TacticM Unit :=_root_.dbgTrace (toString a) $ fun _ => pure ()
private def evalTacticUsing (s : State) (stx : Syntax) : List Tactic → TacticM Unit
| [] => do
let refFmt := stx.prettyPrint;
throwError stx ("unexpected syntax" ++ MessageData.nest 2 (Format.line ++ refFmt))
throwErrorAt stx ("unexpected syntax" ++ MessageData.nest 2 (Format.line ++ refFmt))
| (evalFn::evalFns) => catch (evalFn stx)
(fun ex => match ex with
| Exception.error _ =>
@ -150,11 +155,11 @@ instance : MonadMacroAdapter TacticM :=
setNextMacroScope := fun next => modify $ fun s => { s with nextMacroScope := next },
getCurrRecDepth := do ctx ← read; pure ctx.currRecDepth,
getMaxRecDepth := do ctx ← read; pure ctx.maxRecDepth,
throwError := @throwError,
throwError := @throwErrorAt,
throwUnsupportedSyntax := @throwUnsupportedSyntax }
@[specialize] private def expandTacticMacroFns (evalTactic : Syntax → TacticM Unit) (stx : Syntax) : List Macro → TacticM Unit
| [] => throwError stx ("tactic '" ++ toString stx.getKind ++ "' has not been implemented")
| [] => throwErrorAt stx ("tactic '" ++ toString stx.getKind ++ "' has not been implemented")
| m::ms => do
scp ← getCurrMacroScope;
catch
@ -171,21 +176,21 @@ let macroFns := (table.find? k).getD [];
expandTacticMacroFns evalTactic stx macroFns
partial def evalTactic : Syntax → TacticM Unit
| stx => withIncRecDepth stx $ withFreshMacroScope $ match stx with
| stx => withRef stx $ withIncRecDepth $ withFreshMacroScope $ match stx with
| Syntax.node k args =>
if k == nullKind then
-- list of tactics separated by `;` => evaluate in order
-- Syntax quotations can return multiple ones
stx.forSepArgsM evalTactic
else do
trace `Elab.step stx $ fun _ => stx;
trace `Elab.step fun _ => stx;
s ← get;
let table := (tacticElabAttribute.ext.getState s.env).table;
let k := stx.getKind;
match table.find? k with
| some evalFns => evalTacticUsing s stx evalFns
| none => expandTacticMacro evalTactic stx
| _ => throwError stx "unexpected command"
| _ => throwError "unexpected command"
/-- Adapt a syntax transformation to a regular tactic evaluator. -/
def adaptExpander (exp : Syntax → TacticM Syntax) : Tactic :=
@ -221,43 +226,43 @@ gs ← getGoals;
gs ← gs.filterM $ fun g => not <$> isExprMVarAssigned g;
setGoals gs
def getUnsolvedGoals : TacticM (List MVarId) := do pruneSolvedGoals; getGoals
def getMainGoal (ref : Syntax) : TacticM (MVarId × List MVarId) := do (g::gs) ← getUnsolvedGoals | throwError ref "no goals to be solved"; pure (g, gs)
def ensureHasNoMVars (ref : Syntax) (e : Expr) : TacticM Unit := do
e ← instantiateMVars ref e;
when e.hasMVar $ throwError ref ("tactic failed, resulting expression contains metavariables" ++ indentExpr e)
def getMainGoal : TacticM (MVarId × List MVarId) := do (g::gs) ← getUnsolvedGoals | throwError "no goals to be solved"; pure (g, gs)
def ensureHasNoMVars (e : Expr) : TacticM Unit := do
e ← instantiateMVars e;
when e.hasMVar $ throwError ("tactic failed, resulting expression contains metavariables" ++ indentExpr e)
def withMainMVarContext {α} (ref : Syntax) (x : TacticM α) : TacticM α := do
(mvarId, _) ← getMainGoal ref;
def withMainMVarContext {α} (x : TacticM α) : TacticM α := do
(mvarId, _) ← getMainGoal;
withMVarContext mvarId x
@[inline] def liftMetaMAtMain {α} (ref : Syntax) (x : MVarId → MetaM α) : TacticM α := do
(g, _) ← getMainGoal ref;
withMVarContext g $ liftMetaM ref $ x g
@[inline] def liftMetaMAtMain {α} (x : MVarId → MetaM α) : TacticM α := do
(g, _) ← getMainGoal;
withMVarContext g $ liftMetaM $ x g
@[inline] def liftMetaTacticAux {α} (ref : Syntax) (tactic : MVarId → MetaM (α × List MVarId)) : TacticM α := do
(g, gs) ← getMainGoal ref;
@[inline] def liftMetaTacticAux {α} (tactic : MVarId → MetaM (α × List MVarId)) : TacticM α := do
(g, gs) ← getMainGoal;
withMVarContext g $ do
(a, gs') ← liftMetaM ref $ tactic g;
(a, gs') ← liftMetaM $ tactic g;
setGoals (gs' ++ gs);
pure a
@[inline] def liftMetaTactic (ref : Syntax) (tactic : MVarId → MetaM (List MVarId)) : TacticM Unit :=
liftMetaTacticAux ref (fun mvarId => do gs ← tactic mvarId; pure ((), gs))
@[inline] def liftMetaTactic (tactic : MVarId → MetaM (List MVarId)) : TacticM Unit :=
liftMetaTacticAux (fun mvarId => do gs ← tactic mvarId; pure ((), gs))
def done (ref : Syntax) : TacticM Unit := do
def done : TacticM Unit := do
gs ← getUnsolvedGoals;
unless gs.isEmpty $ reportUnsolvedGoals ref gs
unless gs.isEmpty $ reportUnsolvedGoals gs
def focusAux {α} (ref : Syntax) (tactic : TacticM α) : TacticM α := do
(g, gs) ← getMainGoal ref;
def focusAux {α} (tactic : TacticM α) : TacticM α := do
(g, gs) ← getMainGoal;
setGoals [g];
a ← tactic;
gs' ← getGoals;
setGoals (gs' ++ gs);
pure a
def focus {α} (ref : Syntax) (tactic : TacticM α) : TacticM α :=
focusAux ref (do a ← tactic; done ref; pure a)
def focus {α} (tactic : TacticM α) : TacticM α :=
focusAux (do a ← tactic; done; pure a)
/--
Use `parentTag` to tag untagged goals at `newGoals`.
@ -306,7 +311,7 @@ fun stx =>
(catch
(do evalTactic tactic; pure true)
(fun _ => pure false))
(throwError stx ("tactic succeeded"))
(throwError ("tactic succeeded"))
@[builtinTactic traceState] def evalTraceState : Tactic :=
fun stx => do
@ -314,12 +319,12 @@ fun stx => do
logInfo stx (goalsToMessageData gs)
@[builtinTactic «assumption»] def evalAssumption : Tactic :=
fun stx => liftMetaTactic stx $ fun mvarId => do Meta.assumption mvarId; pure []
fun stx => liftMetaTactic $ fun mvarId => do Meta.assumption mvarId; pure []
@[builtinTactic «intro»] def evalIntro : Tactic :=
fun stx => match_syntax stx with
| `(tactic| intro) => liftMetaTactic stx $ fun mvarId => do (_, mvarId) ← Meta.intro1 mvarId; pure [mvarId]
| `(tactic| intro $h) => liftMetaTactic stx $ fun mvarId => do (_, mvarId) ← Meta.intro mvarId h.getId; pure [mvarId]
| `(tactic| intro) => liftMetaTactic $ fun mvarId => do (_, mvarId) ← Meta.intro1 mvarId; pure [mvarId]
| `(tactic| intro $h) => liftMetaTactic $ fun mvarId => do (_, mvarId) ← Meta.intro mvarId h.getId; pure [mvarId]
| _ => throwUnsupportedSyntax
private def getIntrosSize : Expr → Nat
@ -329,22 +334,23 @@ private def getIntrosSize : Expr → Nat
@[builtinTactic «intros»] def evalIntros : Tactic :=
fun stx => match_syntax stx with
| `(tactic| intros) => liftMetaTactic stx $ fun mvarId => do
| `(tactic| intros) => liftMetaTactic $ fun mvarId => do
type ← Meta.getMVarType mvarId;
type ← Meta.instantiateMVars type;
let n := getIntrosSize type;
(_, mvarId) ← Meta.introN mvarId n;
pure [mvarId]
| `(tactic| intros $ids*) => liftMetaTactic stx $ fun mvarId => do
| `(tactic| intros $ids*) => liftMetaTactic $ fun mvarId => do
(_, mvarId) ← Meta.introN mvarId ids.size (ids.map Syntax.getId).toList;
pure [mvarId]
| _ => throwUnsupportedSyntax
def getFVarId (id : Syntax) : TacticM FVarId := do
def getFVarId (id : Syntax) : TacticM FVarId :=
withRef id do
fvar? ← liftTermElabM $ Term.isLocalTermId? id true;
match fvar? with
| some fvar => pure fvar.fvarId!
| none => throwError id ("unknown variable '" ++ toString id.getId ++ "'")
| none => throwError ("unknown variable '" ++ toString id.getId ++ "'")
def getFVarIds (ids : Array Syntax) : TacticM (Array FVarId) :=
ids.mapM getFVarId
@ -352,36 +358,36 @@ ids.mapM getFVarId
@[builtinTactic «revert»] def evalRevert : Tactic :=
fun stx => match_syntax stx with
| `(tactic| revert $hs*) => do
(g, gs) ← getMainGoal stx;
(g, gs) ← getMainGoal;
withMVarContext g $ do
fvarIds ← getFVarIds hs;
(_, g) ← liftMetaM stx $ Meta.revert g fvarIds;
(_, g) ← liftMetaM $ Meta.revert g fvarIds;
setGoals (g :: gs)
| _ => throwUnsupportedSyntax
def forEachVar (ref : Syntax) (hs : Array Syntax) (tac : MVarId → FVarId → MetaM MVarId) : TacticM Unit :=
def forEachVar (hs : Array Syntax) (tac : MVarId → FVarId → MetaM MVarId) : TacticM Unit :=
hs.forM $ fun h => do
(g, gs) ← getMainGoal ref;
(g, gs) ← getMainGoal;
withMVarContext g $ do
fvarId ← getFVarId h;
g ← liftMetaM ref $ tac g fvarId;
g ← liftMetaM $ tac g fvarId;
setGoals (g :: gs)
@[builtinTactic «clear»] def evalClear : Tactic :=
fun stx => match_syntax stx with
| `(tactic| clear $hs*) => forEachVar stx hs Meta.clear
| `(tactic| clear $hs*) => forEachVar hs Meta.clear
| _ => throwUnsupportedSyntax
@[builtinTactic «subst»] def evalSubst : Tactic :=
fun stx => match_syntax stx with
| `(tactic| subst $hs*) => forEachVar stx hs Meta.subst
| `(tactic| subst $hs*) => forEachVar hs Meta.subst
| _ => throwUnsupportedSyntax
@[builtinTactic paren] def evalParen : Tactic :=
fun stx => evalTactic (stx.getArg 1)
@[builtinTactic nestedTacticBlock] def evalNestedTacticBlock : Tactic :=
fun stx => focus stx (evalTactic (stx.getArg 1))
fun stx => focus (evalTactic (stx.getArg 1))
@[builtinTactic nestedTacticBlockCurly] def evalNestedTacticBlockCurly : Tactic :=
evalNestedTacticBlock
@ -391,11 +397,11 @@ fun stx => match_syntax stx with
| `(tactic| case $tag $tac) => do
let tag := tag.getId;
gs ← getUnsolvedGoals;
some g ← gs.findM? (fun g => do mvarDecl ← getMVarDecl g; pure $ tag.isSuffixOf mvarDecl.userName) | throwError stx "tag not found";
some g ← gs.findM? (fun g => do mvarDecl ← getMVarDecl g; pure $ tag.isSuffixOf mvarDecl.userName) | throwError "tag not found";
let gs := gs.erase g;
setGoals [g];
evalTactic tac;
done stx;
done;
setGoals gs
| _ => throwUnsupportedSyntax

29
stage0/src/Lean/Elab/Tactic/ElabTerm.lean
View file

@ -15,21 +15,20 @@ namespace Tactic
/- `elabTerm` for Tactics and basic tactics that use it. -/
def elabTerm (stx : Syntax) (expectedType? : Option Expr) (mayPostpone := false) : TacticM Expr :=
liftTermElabM $ adaptReader (fun (ctx : Term.Context) => { ctx with errToSorry := false }) $ do
withRef stx $ liftTermElabM $ adaptReader (fun (ctx : Term.Context) => { ctx with errToSorry := false }) $ do
e ← Term.elabTerm stx expectedType?;
Term.synthesizeSyntheticMVars mayPostpone;
Term.instantiateMVars stx e
Term.instantiateMVars e
@[builtinTactic «exact»] def evalExact : Tactic :=
fun stx => match_syntax stx with
| `(tactic| exact $e) => do
let ref := stx;
(g, gs) ← getMainGoal stx;
(g, gs) ← getMainGoal;
withMVarContext g $ do {
decl ← getMVarDecl g;
val ← elabTerm e decl.type;
val ← ensureHasType ref decl.type val;
ensureHasNoMVars ref val;
val ← ensureHasType decl.type val;
ensureHasNoMVars val;
assignExprMVar g val
};
setGoals gs
@ -38,14 +37,13 @@ fun stx => match_syntax stx with
@[builtinTactic «refine»] def evalRefine : Tactic :=
fun stx => match_syntax stx with
| `(tactic| refine $e) => do
let ref := stx;
(g, gs) ← getMainGoal stx;
(g, gs) ← getMainGoal;
gs' ← withMVarContext g $ do {
decl ← getMVarDecl g;
val ← elabTerm e decl.type;
val ← ensureHasType ref decl.type val;
val ← ensureHasType decl.type val;
assignExprMVar g val;
gs' ← collectMVars ref val;
gs' ← collectMVars val;
tagUntaggedGoals decl.userName `refine gs';
pure gs'
};
@ -55,12 +53,11 @@ fun stx => match_syntax stx with
@[builtinTactic «apply»] def evalApply : Tactic :=
fun stx => match_syntax stx with
| `(tactic| apply $e) => do
let ref := stx;
(g, gs) ← getMainGoal stx;
(g, gs) ← getMainGoal;
gs' ← withMVarContext g $ do {
decl ← getMVarDecl g;
val ← elabTerm e none true;
gs' ← liftMetaM ref $ Meta.apply g val;
gs' ← liftMetaM $ Meta.apply g val;
liftTermElabM $ Term.synthesizeSyntheticMVars false;
pure gs'
};
@ -72,15 +69,15 @@ fun stx => match_syntax stx with
Elaborate `stx`. If it a free variable, return it. Otherwise, assert it, and return the free variable.
Note that, the main goal is updated when `Meta.assert` is used in the second case. -/
def elabAsFVar (stx : Syntax) (userName? : Option Name := none) : TacticM FVarId := do
(mvarId, others) ← getMainGoal stx;
(mvarId, others) ← getMainGoal;
withMVarContext mvarId $ do
e ← elabTerm stx none;
match e with
| Expr.fvar fvarId _ => pure fvarId
| _ => do
type ← inferType stx e;
type ← inferType e;
let intro (userName : Name) (useUnusedNames : Bool) : TacticM FVarId := do {
(fvarId, mvarId) ← liftMetaM stx $ do {
(fvarId, mvarId) ← liftMetaM $ do {
mvarId ← Meta.assert mvarId userName type e;
Meta.intro1 mvarId useUnusedNames
};

16
stage0/src/Lean/Elab/Tactic/Generalize.lean
View file

@ -31,8 +31,8 @@ let mvarId' := mvar'.mvarId!;
(_, mvarId') ← Meta.introN mvarId' 2 [] false;
pure [mvarId']
private def evalGeneralizeWithEq (ref : Syntax) (h : Name) (e : Expr) (x : Name) : TacticM Unit :=
liftMetaTactic ref $ fun mvarId => do
private def evalGeneralizeWithEq (h : Name) (e : Expr) (x : Name) : TacticM Unit :=
liftMetaTactic $ fun mvarId => do
mvarId ← Meta.generalize mvarId e x;
mvarDecl ← Meta.getMVarDecl mvarId;
match mvarDecl.type with
@ -46,8 +46,8 @@ liftMetaTactic ref $ fun mvarId => do
| _ => throw $ Meta.Exception.other Syntax.missing "unexpected type after generalize"
-- If generalizing fails, fall back to not replacing anything
private def evalGeneralizeFallback (ref : Syntax) (h : Name) (e : Expr) (x : Name) : TacticM Unit :=
liftMetaTactic ref $ fun mvarId => do
private def evalGeneralizeFallback (h : Name) (e : Expr) (x : Name) : TacticM Unit :=
liftMetaTactic $ fun mvarId => do
eType ← Meta.inferType e;
u ← Meta.getLevel eType;
mvarType ← Meta.getMVarType mvarId;
@ -55,21 +55,21 @@ liftMetaTactic ref $ fun mvarId => do
let target := Lean.mkForall x BinderInfo.default eType $ Lean.mkForall h BinderInfo.default eq mvarType;
evalGeneralizeFinalize mvarId e target
def evalGeneralizeAux (ref : Syntax) (h? : Option Name) (e : Expr) (x : Name) : TacticM Unit :=
def evalGeneralizeAux (h? : Option Name) (e : Expr) (x : Name) : TacticM Unit :=
match h? with
| none => liftMetaTactic ref $ fun mvarId => do
| none => liftMetaTactic $ fun mvarId => do
mvarId ← Meta.generalize mvarId e x;
(_, mvarId) ← Meta.intro1 mvarId false;
pure [mvarId]
| some h =>
evalGeneralizeWithEq ref h e x <|> evalGeneralizeFallback ref h e x
evalGeneralizeWithEq h e x <|> evalGeneralizeFallback h e x
@[builtinTactic «generalize»] def evalGeneralize : Tactic :=
fun stx => do
let h? := getAuxHypothesisName stx;
let x := getVarName stx;
e ← elabTerm (stx.getArg 2) none;
evalGeneralizeAux stx h? e x
evalGeneralizeAux h? e x
end Tactic
end Elab

129
stage0/src/Lean/Elab/Tactic/Induction.lean
View file

@ -23,25 +23,25 @@ else some (((stx.getArg 1).getArg 0).getIdAt 0)
private def getMajor (stx : Syntax) : Syntax :=
(stx.getArg 1).getArg 1
private def elabMajor (ref : Syntax) (h? : Option Name) (major : Syntax) : TacticM Expr := do
private def elabMajor (h? : Option Name) (major : Syntax) : TacticM Expr := do
match h? with
| none => withMainMVarContext ref $ elabTerm major none
| some h => withMainMVarContext ref $ do
| none => withMainMVarContext $ elabTerm major none
| some h => withMainMVarContext do
lctx ← getLCtx;
let x := lctx.getUnusedName `x;
major ← elabTerm major none;
evalGeneralizeAux ref h? major x;
withMainMVarContext ref $ do
evalGeneralizeAux h? major x;
withMainMVarContext do
lctx ← getLCtx;
match lctx.findFromUserName? x with
| some decl => pure decl.toExpr
| none => throwError ref "failed to generalize"
| none => throwError "failed to generalize"
private def generalizeMajor (ref : Syntax) (major : Expr) : TacticM Expr := do
private def generalizeMajor (major : Expr) : TacticM Expr := do
match major with
| Expr.fvar _ _ => pure major
| _ => do
liftMetaTacticAux ref $ fun mvarId => do
liftMetaTacticAux fun mvarId => do
mvarId ← Meta.generalize mvarId major `x;
(fvarId, mvarId) ← Meta.intro1 mvarId;
pure (mkFVar fvarId, [mvarId])
@ -54,17 +54,18 @@ match major with
```
`stx` is syntax for `induction`. -/
private def getGeneralizingFVarIds (stx : Syntax) : TacticM (Array FVarId) :=
withRef stx $
let generalizingStx := stx.getArg 3;
if generalizingStx.isNone then pure #[]
else withMainMVarContext stx $ do
trace `Elab.induction stx $ fun _ => generalizingStx;
else withMainMVarContext do
trace `Elab.induction fun _ => generalizingStx;
let vars := (generalizingStx.getArg 1).getArgs;
getFVarIds vars
-- process `generalizingVars` subterm of induction Syntax `stx`.
private def generalizeVars (stx : Syntax) (major : Expr) : TacticM Nat := do
fvarIds ← getGeneralizingFVarIds stx;
liftMetaTacticAux stx $ fun mvarId => do
liftMetaTacticAux fun mvarId => do
(fvarIds, mvarId') ← Meta.revert mvarId fvarIds;
when (fvarIds.contains major.fvarId!) $
Meta.throwTacticEx `induction mvarId "major premise depends on variable being generalized";
@ -92,17 +93,17 @@ private def getAltRHS (alt : Syntax) : Syntax := alt.getArg 3
private def checkAltCtorNames (alts : Array Syntax) (ctorNames : List Name) : TacticM Unit :=
alts.forM $ fun alt => do
let n := getAltName alt;
trace `Elab.checkAlt alt $ fun _ => n ++ ", " ++ alt;
withRef alt $ trace `Elab.checkAlt $ fun _ => n ++ ", " ++ alt;
unless (n == `_ || ctorNames.any (fun ctorName => n.isSuffixOf ctorName)) $
throwError (alt.getArg 0) ("invalid constructor name '" ++ toString n ++ "'")
throwErrorAt (alt.getArg 0) ("invalid constructor name '" ++ toString n ++ "'")
structure RecInfo :=
(recName : Name)
(altVars : Array (List Name) := #[]) -- new variable names for each minor premise
(altRHSs : Array Syntax := #[]) -- RHS for each minor premise
def getInductiveValFromMajor (ref : Syntax) (major : Expr) : TacticM InductiveVal :=
liftMetaMAtMain ref $ fun mvarId => do
def getInductiveValFromMajor (major : Expr) : TacticM InductiveVal :=
liftMetaMAtMain $ fun mvarId => do
majorType ← Meta.inferType major;
majorType ← Meta.whnf majorType;
match majorType.getAppFn with
@ -113,15 +114,15 @@ liftMetaMAtMain ref $ fun mvarId => do
| _ => Meta.throwTacticEx `induction mvarId ("major premise type is not an inductive type " ++ indentExpr majorType)
| _ => Meta.throwTacticEx `induction mvarId ("major premise type is not an inductive type " ++ indentExpr majorType)
private partial def getRecFromUsingLoop (ref : Syntax) (baseRecName : Name) : Expr → TacticM (Option Meta.RecursorInfo)
private partial def getRecFromUsingLoop (baseRecName : Name) : Expr → TacticM (Option Meta.RecursorInfo)
| majorType => do
let continue (majorType : Expr) : TacticM (Option Meta.RecursorInfo) := do {
majorType? ← unfoldDefinition? ref majorType;
majorType? ← unfoldDefinition? majorType;
match majorType? with
| some majorType => withIncRecDepth ref $ getRecFromUsingLoop majorType
| some majorType => withIncRecDepth $ getRecFromUsingLoop majorType
| none => pure none
};
majorType ← whnfCore ref majorType;
majorType ← whnfCore majorType;
match majorType.getAppFn with
| Expr.const name _ _ => do
let candidate := name ++ baseRecName;
@ -129,29 +130,29 @@ private partial def getRecFromUsingLoop (ref : Syntax) (baseRecName : Name) : Ex
match env.find? candidate with
| some _ =>
catch
(liftMetaMAtMain ref $ fun _ => do info ← Meta.mkRecursorInfo candidate; pure (some info))
(liftMetaMAtMain fun _ => do info ← Meta.mkRecursorInfo candidate; pure (some info))
(fun _ => continue majorType)
| none => continue majorType
| _ => continue majorType
def getRecFromUsing (ref : Syntax) (major : Expr) (baseRecName : Name) : TacticM Meta.RecursorInfo := do
majorType ← inferType ref major;
recInfo? ← getRecFromUsingLoop ref baseRecName majorType;
def getRecFromUsing (major : Expr) (baseRecName : Name) : TacticM Meta.RecursorInfo := do
majorType ← inferType major;
recInfo? ← getRecFromUsingLoop baseRecName majorType;
match recInfo? with
| some recInfo => pure recInfo
| none => do
result ← resolveGlobalName baseRecName;
match result with
| _::_::_ => throwError ref ("ambiguous recursor name '" ++ baseRecName ++ "', " ++ toString (result.map Prod.fst))
| _::_::_ => throwError ("ambiguous recursor name '" ++ baseRecName ++ "', " ++ toString (result.map Prod.fst))
| [(recName, [])] => do
catch
(liftMetaMAtMain ref $ fun _ => Meta.mkRecursorInfo recName)
(fun _ => throwError ref ("invalid recursor name '" ++ baseRecName ++ "'"))
| _ => throwError ref ("invalid recursor name '" ++ baseRecName ++ "'")
(liftMetaMAtMain fun _ => Meta.mkRecursorInfo recName)
(fun _ => throwError ("invalid recursor name '" ++ baseRecName ++ "'"))
| _ => throwError ("invalid recursor name '" ++ baseRecName ++ "'")
/- Create `RecInfo` assuming builtin recursor -/
private def getRecInfoDefault (ref : Syntax) (major : Expr) (withAlts : Syntax) (allowMissingAlts : Bool) : TacticM (RecInfo × Array Name) := do
indVal ← getInductiveValFromMajor ref major;
private def getRecInfoDefault (major : Expr) (withAlts : Syntax) (allowMissingAlts : Bool) : TacticM (RecInfo × Array Name) := do
indVal ← getInductiveValFromMajor major;
let recName := mkRecFor indVal.name;
if withAlts.isNone then pure ({ recName := recName }, #[])
else do
@ -176,10 +177,10 @@ else do
if allowMissingAlts then
pure (altVars.push [], altRHSs.push Syntax.missing, remainingAlts, prevAnonymousAlt?)
else
throwError ref ("alternative for constructor '" ++ toString ctorName ++ "' is missing"))
throwError ("alternative for constructor '" ++ toString ctorName ++ "' is missing"))
(#[], #[], alts, none);
unless remainingAlts.isEmpty $
throwError (remainingAlts.get! 0) "unused alternative";
throwErrorAt (remainingAlts.get! 0) "unused alternative";
pure ({ recName := recName, altVars := altVars, altRHSs := altRHSs }, ctorNames.toArray)
/-
@ -192,20 +193,20 @@ else do
usingRec : Parser := optional (" using " >> ident)
``` -/
private def getRecInfo (stx : Syntax) (major : Expr) : TacticM RecInfo :=
let ref := stx;
withRef stx $
let usingRecStx := stx.getArg 2;
let withAlts := stx.getArg 4;
if usingRecStx.isNone then do
(rinfo, _) ← getRecInfoDefault ref major withAlts false;
(rinfo, _) ← getRecInfoDefault major withAlts false;
pure rinfo
else do
let baseRecName := (usingRecStx.getIdAt 1).eraseMacroScopes;
recInfo ← getRecFromUsing ref major baseRecName;
recInfo ← getRecFromUsing major baseRecName;
let recName := recInfo.recursorName;
if withAlts.isNone then pure { recName := recName }
else do
let alts := getAlts withAlts;
paramNames ← liftMetaMAtMain ref $ fun _ => Meta.getParamNames recInfo.recursorName;
paramNames ← liftMetaMAtMain $ fun _ => Meta.getParamNames recInfo.recursorName;
(altVars, altRHSs, remainingAlts, _) ← paramNames.size.foldM
(fun (i : Nat) (result : Array (List Name) × Array Syntax × Array Syntax × Option Syntax) =>
if recInfo.isMinor i then
@ -222,59 +223,59 @@ else do
| none => match prevAnonymousAlt? with
| some alt =>
pure (altVars.push (getAltVarNames alt).toList, altRHSs.push (getAltRHS alt), remainingAlts, prevAnonymousAlt?)
| none => throwError ref ("alternative for minor premise '" ++ toString paramName ++ "' is missing")
| none => throwError ("alternative for minor premise '" ++ toString paramName ++ "' is missing")
else
pure result)
(#[], #[], alts, none);
unless remainingAlts.isEmpty $
throwError (remainingAlts.get! 0) "unused alternative";
throwErrorAt (remainingAlts.get! 0) "unused alternative";
pure { recName := recName, altVars := altVars, altRHSs := altRHSs }
-- Return true if `stx` is a term occurring in the RHS of the induction/cases tactic
private def isTermRHS (rhs : Syntax) : Bool :=
rhs.isOfKind `Lean.Parser.Term.namedHole || rhs.isOfKind `Lean.Parser.Term.hole
private def processResult (ref : Syntax) (altRHSs : Array Syntax) (result : Array Meta.InductionSubgoal) : TacticM Unit := do
private def processResult (altRHSs : Array Syntax) (result : Array Meta.InductionSubgoal) : TacticM Unit := do
if altRHSs.isEmpty then
setGoals $ result.toList.map $ fun s => s.mvarId
else do
unless (altRHSs.size == result.size) $
throwError ref ("mistmatch on the number of subgoals produced (" ++ toString result.size ++ ") and " ++
"alternatives provided (" ++ toString altRHSs.size ++ ")");
throwError ("mistmatch on the number of subgoals produced (" ++ toString result.size ++ ") and " ++
"alternatives provided (" ++ toString altRHSs.size ++ ")");
gs ← result.size.foldM
(fun i gs => do
let subgoal := result.get! i;
let rhs := altRHSs.get! i;
let ref := rhs;
let mvarId := subgoal.mvarId;
if isTermRHS rhs then withMVarContext mvarId $ do
if isTermRHS rhs then withMVarContext mvarId $ withRef rhs do
mvarDecl ← getMVarDecl mvarId;
val ← elabTerm rhs mvarDecl.type;
val ← ensureHasType rhs mvarDecl.type val;
val ← ensureHasType mvarDecl.type val;
assignExprMVar mvarId val;
gs' ← collectMVars rhs val;
gs' ← collectMVars val;
tagUntaggedGoals mvarDecl.userName `induction gs';
pure (gs ++ gs')
else do
setGoals [mvarId];
evalTactic rhs;
done ref;
done;
pure gs)
[];
setGoals gs
@[builtinTactic «induction»] def evalInduction : Tactic :=
fun stx => focusAux stx $ do
fun stx => focusAux $ do
let h? := getAuxHypothesisName stx;
major ← elabMajor stx h? (getMajor stx);
major ← generalizeMajor stx major;
major ← elabMajor h? (getMajor stx);
major ← generalizeMajor major;
n ← generalizeVars stx major;
recInfo ← getRecInfo stx major;
(mvarId, _) ← getMainGoal stx;
result ← liftMetaM stx $ Meta.induction mvarId major.fvarId! recInfo.recName recInfo.altVars;
processResult stx recInfo.altRHSs result
(mvarId, _) ← getMainGoal;
result ← liftMetaM $ Meta.induction mvarId major.fvarId! recInfo.recName recInfo.altVars;
processResult recInfo.altRHSs result
private partial def checkCasesResultAux (ref : Syntax) (casesResult : Array Meta.CasesSubgoal) (ctorNames : Array Name) (altRHSs : Array Syntax)
private partial def checkCasesResultAux (casesResult : Array Meta.CasesSubgoal) (ctorNames : Array Name) (altRHSs : Array Syntax)
: Nat → Nat → TacticM Unit
| i, j =>
if h : j < altRHSs.size then do
@ -288,32 +289,32 @@ private partial def checkCasesResultAux (ref : Syntax) (casesResult : Array Meta
if ctorName == subgoal.ctorName then
checkCasesResultAux (i+1) (j+1)
else
throwError ref ("alternative for '" ++ subgoal.ctorName ++ "' has not been provided")
throwError ("alternative for '" ++ subgoal.ctorName ++ "' has not been provided")
else
throwError ref ("alternative for '" ++ ctorName ++ "' is not needed")
throwError ("alternative for '" ++ ctorName ++ "' is not needed")
else if h : i < casesResult.size then
let subgoal := casesResult.get ⟨i, h⟩;
throwError ref ("alternative for '" ++ subgoal.ctorName ++ "' has not been provided")
throwError ("alternative for '" ++ subgoal.ctorName ++ "' has not been provided")
else
pure ()
private def checkCasesResult (ref : Syntax) (casesResult : Array Meta.CasesSubgoal) (ctorNames : Array Name) (altRHSs : Array Syntax) : TacticM Unit :=
unless altRHSs.isEmpty $ checkCasesResultAux ref casesResult ctorNames altRHSs 0 0
private def checkCasesResult (casesResult : Array Meta.CasesSubgoal) (ctorNames : Array Name) (altRHSs : Array Syntax) : TacticM Unit :=
unless altRHSs.isEmpty $ checkCasesResultAux casesResult ctorNames altRHSs 0 0
@[builtinTactic «cases»] def evalCases : Tactic :=
fun stx => focusAux stx $ do
fun stx => focusAux $ do
-- parser! nonReservedSymbol "cases " >> majorPremise >> withAlts
let h? := getAuxHypothesisName stx;
major ← elabMajor stx h? (getMajor stx);
major ← generalizeMajor stx major;
(mvarId, _) ← getMainGoal stx;
major ← elabMajor h? (getMajor stx);
major ← generalizeMajor major;
(mvarId, _) ← getMainGoal;
let withAlts := stx.getArg 2;
(recInfo, ctorNames) ← getRecInfoDefault stx major withAlts true;
result ← liftMetaM stx $ Meta.cases mvarId major.fvarId! recInfo.altVars;
checkCasesResult stx result ctorNames recInfo.altRHSs;
(recInfo, ctorNames) ← getRecInfoDefault major withAlts true;
result ← liftMetaM $ Meta.cases mvarId major.fvarId! recInfo.altVars;
checkCasesResult result ctorNames recInfo.altRHSs;
let result := result.map (fun s => s.toInductionSubgoal);
let altRHSs := recInfo.altRHSs.filter $ fun stx => !stx.isMissing;
processResult stx altRHSs result
processResult altRHSs result
end Tactic
end Elab

2
stage0/src/Lean/Elab/Tactic/Injection.lean
View file

@ -24,7 +24,7 @@ fun stx => do
-- parser! nonReservedSymbol "injection " >> termParser >> withIds
fvarId ← elabAsFVar (stx.getArg 1);
let ids := getInjectionNewIds (stx.getArg 2);
liftMetaTactic stx $ fun mvarId => do
liftMetaTactic $ fun mvarId => do
r ← Meta.injection mvarId fvarId ids (!ids.isEmpty);
match r with
| Meta.InjectionResult.solved => do checkUnusedIds mvarId ids; pure []

424
stage0/src/Lean/Elab/Term.lean
View file

@ -44,6 +44,7 @@ structure Context extends Meta.Context :=
(errToSorry : Bool := true)
/- If `macroStackAtErr == true`, we include it in error messages. -/
(macroStackAtErr : Bool := true)
(ref : Syntax := Syntax.missing)
/-- We use synthetic metavariables as placeholders for pending elaboration steps. -/
inductive SyntheticMVarKind
@ -145,22 +146,33 @@ instance monadLog : MonadLog TermElabM :=
addContext := addContext,
logMessage := fun msg => modify $ fun s => { s with messages := s.messages.add msg } }
/- Execute `x` using using `ref` as the default Syntax for providing position information to error messages. -/
@[inline] def withRef {α} (ref : Syntax) (x : TermElabM α) : TermElabM α := do
adaptReader (fun (ctx : Context) => { ctx with ref := ref }) x
def getCurrRef : TermElabM Syntax := do
ctx ← read; pure ctx.ref
/--
Throws an error with the given `msgData` and extracting position information from `ref`.
If `ref` does not contain position information, then use `cmdPos` -/
def throwError {α} (ref : Syntax) (msgData : MessageData) : TermElabM α := do
def throwErrorAt {α} (ref : Syntax) (msgData : MessageData) : TermElabM α := do
ctx ← read;
let ref := getBetterRef ref ctx.macroStack;
let msgData := if ctx.macroStackAtErr then addMacroStack msgData ctx.macroStack else msgData;
msg ← mkMessage msgData MessageSeverity.error ref;
throw (Exception.ex (Elab.Exception.error msg))
def throwError {α} (msgData : MessageData) : TermElabM α := do
ref ← getCurrRef;
throwErrorAt ref msgData
def throwUnsupportedSyntax {α} : TermElabM α :=
throw (Exception.ex Elab.Exception.unsupportedSyntax)
@[inline] def withIncRecDepth {α} (ref : Syntax) (x : TermElabM α) : TermElabM α := do
@[inline] def withIncRecDepth {α} (x : TermElabM α) : TermElabM α := do
ctx ← read;
when (ctx.currRecDepth == ctx.maxRecDepth) $ throwError ref maxRecDepthErrorMessage;
when (ctx.currRecDepth == ctx.maxRecDepth) $ throwError maxRecDepthErrorMessage;
adaptReader (fun (ctx : Context) => { ctx with currRecDepth := ctx.currRecDepth + 1 }) x
protected def getCurrMacroScope : TermElabM MacroScope := do ctx ← read; pure ctx.currMacroScope
@ -211,101 +223,104 @@ logInfo ref $
MessageData.withContext { env := s.env, mctx := s.mctx, lctx := ctx.lctx, opts := ctx.config.opts } $
MessageData.tagged cls msg
@[inline] def trace (cls : Name) (ref : Syntax) (msg : Unit → MessageData) : TermElabM Unit := do
@[inline] def trace (cls : Name) (msg : Unit → MessageData) : TermElabM Unit := do
opts ← getOptions;
ref ← getCurrRef;
when (checkTraceOption opts cls) $ logTrace cls ref (msg ())
def logDbgTrace (msg : MessageData) : TermElabM Unit := do
trace `Elab.debug Syntax.missing $ fun _ => msg
trace `Elab.debug $ fun _ => msg
/-- For testing `TermElabM` methods. The #eval command will sign the error. -/
def throwErrorIfErrors : TermElabM Unit := do
s ← get;
when s.messages.hasErrors $
throwError Syntax.missing "Error(s)"
throwError "Error(s)"
@[inline] def traceAtCmdPos (cls : Name) (msg : Unit → MessageData) : TermElabM Unit :=
trace cls Syntax.missing msg
withRef Syntax.missing $ trace cls msg
def dbgTrace {α} [HasToString α] (a : α) : TermElabM Unit :=
_root_.dbgTrace (toString a) $ fun _ => pure ()
/-- Auxiliary function for `liftMetaM` -/
private def mkMessageAux (ctx : Context) (ref : Syntax) (msgData : MessageData) (severity : MessageSeverity) : Message :=
mkMessageCore ctx.fileName ctx.fileMap msgData severity (ref.getPos.getD ctx.cmdPos)
private def mkMessageAux (ctx : Context) (msgData : MessageData) (severity : MessageSeverity) : Message :=
mkMessageCore ctx.fileName ctx.fileMap msgData severity (ctx.ref.getPos.getD ctx.cmdPos)
/-- Auxiliary function for `liftMetaM` -/
private def fromMetaException (ctx : Context) (ref : Syntax) (ex : Meta.Exception) : Exception :=
private def fromMetaException (ctx : Context) (ex : Meta.Exception) : Exception :=
-- We use `ref` stored in `ex` if it contains position information
let ref := match ex.getRef.getPos with
| some _ => ex.getRef
| none => ref;
Exception.ex $ Elab.Exception.error $ mkMessageAux ctx ref ex.toMessageData MessageSeverity.error
| none => ctx.ref;
Exception.ex $ Elab.Exception.error $ mkMessageAux ctx ex.toMessageData MessageSeverity.error
/-- Auxiliary function for `liftMetaM` -/
private def fromMetaState (ref : Syntax) (ctx : Context) (s : State) (newS : Meta.State) (oldTraceState : TraceState) : State :=
private def fromMetaState (ctx : Context) (s : State) (newS : Meta.State) (oldTraceState : TraceState) : State :=
let traces := newS.traceState.traces;
let messages := traces.foldl (fun (messages : MessageLog) trace => messages.add (mkMessageAux ctx ref trace MessageSeverity.information)) s.messages;
let messages := traces.foldl (fun (messages : MessageLog) trace => messages.add (mkMessageAux ctx trace MessageSeverity.information)) s.messages;
{ s with
toState := { newS with traceState := oldTraceState },
messages := messages }
@[inline] def liftMetaM {α} (ref : Syntax) (x : MetaM α) : TermElabM α :=
@[inline] def liftMetaM {α} (x : MetaM α) : TermElabM α :=
fun ctx s =>
let oldTraceState := s.traceState;
match x ctx.toContext { s.toState with traceState := {} } with
| EStateM.Result.ok a newS => EStateM.Result.ok a (fromMetaState ref ctx s newS oldTraceState)
| EStateM.Result.error ex newS => EStateM.Result.error (fromMetaException ctx ref ex) (fromMetaState ref ctx s newS oldTraceState)
| EStateM.Result.ok a newS => EStateM.Result.ok a (fromMetaState ctx s newS oldTraceState)
| EStateM.Result.error ex newS => EStateM.Result.error (fromMetaException ctx ex) (fromMetaState ctx s newS oldTraceState)
def ppGoal (ref : Syntax) (mvarId : MVarId) : TermElabM Format := liftMetaM ref $ Meta.ppGoal mvarId
def isType (ref : Syntax) (e : Expr) : TermElabM Bool := liftMetaM ref $ Meta.isType e
def isTypeFormer (ref : Syntax) (e : Expr) : TermElabM Bool := liftMetaM ref $ Meta.isTypeFormer e
def isTypeFormerType (ref : Syntax) (e : Expr) : TermElabM Bool := liftMetaM ref $ Meta.isTypeFormerType e
def isDefEqNoConstantApprox (ref : Syntax) (t s : Expr) : TermElabM Bool := liftMetaM ref $ Meta.approxDefEq $ Meta.isDefEq t s
def isDefEq (ref : Syntax) (t s : Expr) : TermElabM Bool := liftMetaM ref $ Meta.fullApproxDefEq $ Meta.isDefEq t s
def isLevelDefEq (ref : Syntax) (u v : Level) : TermElabM Bool := liftMetaM ref $ Meta.isLevelDefEq u v
def inferType (ref : Syntax) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.inferType e
def whnf (ref : Syntax) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.whnf e
def whnfForall (ref : Syntax) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.whnfForall e
def whnfCore (ref : Syntax) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.whnfCore e
def unfoldDefinition? (ref : Syntax) (e : Expr) : TermElabM (Option Expr) := liftMetaM ref $ Meta.unfoldDefinition? e
def instantiateMVars (ref : Syntax) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.instantiateMVars e
def instantiateLevelMVars (ref : Syntax) (u : Level) : TermElabM Level := liftMetaM ref $ Meta.instantiateLevelMVars u
def isClass (ref : Syntax) (t : Expr) : TermElabM (Option Name) := liftMetaM ref $ Meta.isClass t
def mkFreshId : TermElabM Name := liftMetaM Syntax.missing Meta.mkFreshId
def mkFreshLevelMVar (ref : Syntax) : TermElabM Level := liftMetaM ref $ Meta.mkFreshLevelMVar
def mkFreshExprMVar (ref : Syntax) (type? : Option Expr := none) (kind : MetavarKind := MetavarKind.natural) (userName? : Name := Name.anonymous) : TermElabM Expr :=
def ppGoal (mvarId : MVarId) : TermElabM Format := liftMetaM $ Meta.ppGoal mvarId
def isType (e : Expr) : TermElabM Bool := liftMetaM $ Meta.isType e
def isTypeFormer (e : Expr) : TermElabM Bool := liftMetaM $ Meta.isTypeFormer e
def isTypeFormerType (e : Expr) : TermElabM Bool := liftMetaM $ Meta.isTypeFormerType e
def isDefEqNoConstantApprox (t s : Expr) : TermElabM Bool := liftMetaM $ Meta.approxDefEq $ Meta.isDefEq t s
def isDefEq (t s : Expr) : TermElabM Bool := liftMetaM $ Meta.fullApproxDefEq $ Meta.isDefEq t s
def isLevelDefEq (u v : Level) : TermElabM Bool := liftMetaM $ Meta.isLevelDefEq u v
def inferType (e : Expr) : TermElabM Expr := liftMetaM $ Meta.inferType e
def whnf (e : Expr) : TermElabM Expr := liftMetaM $ Meta.whnf e
def whnfForall (e : Expr) : TermElabM Expr := liftMetaM $ Meta.whnfForall e
def whnfCore (e : Expr) : TermElabM Expr := liftMetaM $ Meta.whnfCore e
def unfoldDefinition? (e : Expr) : TermElabM (Option Expr) := liftMetaM $ Meta.unfoldDefinition? e
def instantiateMVars (e : Expr) : TermElabM Expr := liftMetaM $ Meta.instantiateMVars e
def instantiateLevelMVars (u : Level) : TermElabM Level := liftMetaM $ Meta.instantiateLevelMVars u
def isClass (t : Expr) : TermElabM (Option Name) := liftMetaM $ Meta.isClass t
def mkFreshId : TermElabM Name := liftMetaM Meta.mkFreshId
def mkFreshLevelMVar : TermElabM Level := liftMetaM $ Meta.mkFreshLevelMVar
def mkFreshExprMVar (type? : Option Expr := none) (kind : MetavarKind := MetavarKind.natural) (userName? : Name := Name.anonymous) : TermElabM Expr :=
match type? with
| some type => liftMetaM ref $ Meta.mkFreshExprMVar type userName? kind
| none => liftMetaM ref $ do u ← Meta.mkFreshLevelMVar; type ← Meta.mkFreshExprMVar (mkSort u); Meta.mkFreshExprMVar type userName? kind
def mkFreshExprMVarWithId (ref : Syntax) (mvarId : MVarId) (type? : Option Expr := none) (kind : MetavarKind := MetavarKind.natural) (userName? : Name := Name.anonymous) : TermElabM Expr :=
| some type => liftMetaM $ Meta.mkFreshExprMVar type userName? kind
| none => liftMetaM $ do u ← Meta.mkFreshLevelMVar; type ← Meta.mkFreshExprMVar (mkSort u); Meta.mkFreshExprMVar type userName? kind
def mkFreshExprMVarWithId (mvarId : MVarId) (type? : Option Expr := none) (kind : MetavarKind := MetavarKind.natural) (userName? : Name := Name.anonymous)
: TermElabM Expr :=
match type? with
| some type => liftMetaM ref $ Meta.mkFreshExprMVarWithId mvarId type userName? kind
| none => liftMetaM ref $ do u ← Meta.mkFreshLevelMVar; type ← Meta.mkFreshExprMVar (mkSort u); Meta.mkFreshExprMVarWithId mvarId type userName? kind
def mkFreshTypeMVar (ref : Syntax) (kind : MetavarKind := MetavarKind.natural) (userName? : Name := Name.anonymous) : TermElabM Expr :=
liftMetaM ref $ do u ← Meta.mkFreshLevelMVar; Meta.mkFreshExprMVar (mkSort u) userName? kind
def getLevel (ref : Syntax) (type : Expr) : TermElabM Level := liftMetaM ref $ Meta.getLevel type
def mkForall (ref : Syntax) (xs : Array Expr) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.mkForall xs e
def mkForallUsedOnly (ref : Syntax) (xs : Array Expr) (e : Expr) : TermElabM (Expr × Nat) := liftMetaM ref $ Meta.mkForallUsedOnly xs e
def mkLambda (ref : Syntax) (xs : Array Expr) (e : Expr) : TermElabM Expr := liftMetaM ref $ Meta.mkLambda xs e
def mkLet (ref : Syntax) (x : Expr) (e : Expr) : TermElabM Expr := mkLambda ref #[x] e
def trySynthInstance (ref : Syntax) (type : Expr) : TermElabM (LOption Expr) := liftMetaM ref $ Meta.trySynthInstance type
def mkAppM (ref : Syntax) (constName : Name) (args : Array Expr) : TermElabM Expr := liftMetaM ref $ Meta.mkAppM constName args
def mkExpectedTypeHint (ref : Syntax) (e : Expr) (expectedType : Expr) : TermElabM Expr := liftMetaM ref $ Meta.mkExpectedTypeHint e expectedType
def decLevel? (ref : Syntax) (u : Level) : TermElabM (Option Level) := liftMetaM ref $ Meta.decLevel? u
| some type => liftMetaM $ Meta.mkFreshExprMVarWithId mvarId type userName? kind
| none => liftMetaM $ do u ← Meta.mkFreshLevelMVar; type ← Meta.mkFreshExprMVar (mkSort u); Meta.mkFreshExprMVarWithId mvarId type userName? kind
def mkFreshTypeMVar (kind : MetavarKind := MetavarKind.natural) (userName? : Name := Name.anonymous) : TermElabM Expr :=
liftMetaM $ do u ← Meta.mkFreshLevelMVar; Meta.mkFreshExprMVar (mkSort u) userName? kind
def getLevel (type : Expr) : TermElabM Level := liftMetaM $ Meta.getLevel type
def getLocalDecl (fvarId : FVarId) : TermElabM LocalDecl := liftMetaM $ Meta.getLocalDecl fvarId
def mkForall (xs : Array Expr) (e : Expr) : TermElabM Expr := liftMetaM $ Meta.mkForall xs e
def mkForallUsedOnly (xs : Array Expr) (e : Expr) : TermElabM (Expr × Nat) := liftMetaM $ Meta.mkForallUsedOnly xs e
def mkLambda (xs : Array Expr) (e : Expr) : TermElabM Expr := liftMetaM $ Meta.mkLambda xs e
def mkLet (x : Expr) (e : Expr) : TermElabM Expr := mkLambda #[x] e
def trySynthInstance (type : Expr) : TermElabM (LOption Expr) := liftMetaM $ Meta.trySynthInstance type
def mkAppM (constName : Name) (args : Array Expr) : TermElabM Expr := liftMetaM $ Meta.mkAppM constName args
def mkExpectedTypeHint (e : Expr) (expectedType : Expr) : TermElabM Expr := liftMetaM $ Meta.mkExpectedTypeHint e expectedType
def decLevel? (u : Level) : TermElabM (Option Level) := liftMetaM $ Meta.decLevel? u
def decLevel (ref : Syntax) (u : Level) : TermElabM Level := do
u? ← decLevel? ref u;
def decLevel (u : Level) : TermElabM Level := do
u? ← decLevel? u;
match u? with
| some u => pure u
| none => throwError ref ("invalid universe level, " ++ u ++ " is not greater than 0")
| none => throwError ("invalid universe level, " ++ u ++ " is not greater than 0")
/- This function is useful for inferring universe level parameters for function that take arguments such as `{α : Type u}`.
Recall that `Type u` is `Sort (u+1)` in Lean. Thus, given `α`, we must infer its universe level,
and then decrement 1 to obtain `u`. -/
def getDecLevel (ref : Syntax) (type : Expr) : TermElabM Level := do
u ← getLevel ref type;
decLevel ref u
def getDecLevel (type : Expr) : TermElabM Level := do
u ← getLevel type;
decLevel u
@[inline] def savingMCtx {α} (x : TermElabM α) : TermElabM α := do
mctx ← getMCtx;
@ -337,7 +352,8 @@ adaptReader (fun (ctx : Context) => { ctx with macroStack := { before := beforeS
/-
Add the given metavariable to the list of pending synthetic metavariables.
The method `synthesizeSyntheticMVars` is used to process the metavariables on this list. -/
def registerSyntheticMVar (ref : Syntax) (mvarId : MVarId) (kind : SyntheticMVarKind) : TermElabM Unit :=
def registerSyntheticMVar (mvarId : MVarId) (kind : SyntheticMVarKind) : TermElabM Unit := do
ref ← getCurrRef;
modify $ fun s => { s with syntheticMVars := { mvarId := mvarId, ref := ref, kind := kind } :: s.syntheticMVars }
/-
@ -439,29 +455,29 @@ let id := s.ngen.curr;
modify $ fun s => { s with ngen := s.ngen.next };
pure id
def withLocalDecl {α} (ref : Syntax) (n : Name) (binderInfo : BinderInfo) (type : Expr) (k : Expr → TermElabM α) : TermElabM α := do
def withLocalDecl {α} (n : Name) (binderInfo : BinderInfo) (type : Expr) (k : Expr → TermElabM α) : TermElabM α := do
fvarId ← mkFreshFVarId;
ctx ← read;
let lctx := ctx.lctx.mkLocalDecl fvarId n type binderInfo;
let localInsts := ctx.localInstances;
let fvar := mkFVar fvarId;
c? ← isClass ref type;
c? ← isClass type;
match c? with
| some c => adaptReader (fun (ctx : Context) => { ctx with lctx := lctx, localInstances := localInsts.push { className := c, fvar := fvar } }) $ k fvar
| none => adaptReader (fun (ctx : Context) => { ctx with lctx := lctx }) $ k fvar
def withLetDecl {α} (ref : Syntax) (n : Name) (type : Expr) (val : Expr) (k : Expr → TermElabM α) : TermElabM α := do
def withLetDecl {α} (n : Name) (type : Expr) (val : Expr) (k : Expr → TermElabM α) : TermElabM α := do
fvarId ← mkFreshFVarId;
ctx ← read;
let lctx := ctx.lctx.mkLetDecl fvarId n type val;
let localInsts := ctx.localInstances;
let fvar := mkFVar fvarId;
c? ← isClass ref type;
c? ← isClass type;
match c? with
| some c => adaptReader (fun (ctx : Context) => { ctx with lctx := lctx, localInstances := localInsts.push { className := c, fvar := fvar } }) $ k fvar
| none => adaptReader (fun (ctx : Context) => { ctx with lctx := lctx }) $ k fvar
def throwTypeMismatchError {α} (ref : Syntax) (expectedType : Expr) (eType : Expr) (e : Expr)
def throwTypeMismatchError {α} (expectedType : Expr) (eType : Expr) (e : Expr)
(f? : Option Expr := none) (extraMsg? : Option MessageData := none) : TermElabM α :=
let extraMsg : MessageData := match extraMsg? with
| none => Format.nil
@ -473,10 +489,10 @@ match f? with
++ Format.line ++ "has type" ++ indentExpr eType
++ Format.line ++ "but it is expected to have type" ++ indentExpr expectedType
++ extraMsg;
throwError ref msg
throwError msg
| some f => do
env ← getEnv; mctx ← getMCtx; lctx ← getLCtx; opts ← getOptions;
throwError ref $ Meta.Exception.mkAppTypeMismatchMessage f e { env := env, mctx := mctx, lctx := lctx, opts := opts } ++ extraMsg
throwError $ Meta.Exception.mkAppTypeMismatchMessage f e { env := env, mctx := mctx, lctx := lctx, opts := opts } ++ extraMsg
@[inline] def withoutMacroStackAtErr {α} (x : TermElabM α) : TermElabM α :=
adaptReader (fun (ctx : Context) => { ctx with macroStackAtErr := false }) x
@ -487,24 +503,24 @@ adaptReader (fun (ctx : Context) => { ctx with macroStackAtErr := false }) x
Return `true` if the instance was synthesized successfully, and `false` if
the instance contains unassigned metavariables that are blocking the type class
resolution procedure. Throw an exception if resolution or assignment irrevocably fails. -/
def synthesizeInstMVarCore (ref : Syntax) (instMVar : MVarId) : TermElabM Bool := do
def synthesizeInstMVarCore (instMVar : MVarId) : TermElabM Bool := do
instMVarDecl ← getMVarDecl instMVar;
let type := instMVarDecl.type;
type ← instantiateMVars ref type;
result ← trySynthInstance ref type;
type ← instantiateMVars type;
result ← trySynthInstance type;
match result with
| LOption.some val => do
condM (isExprMVarAssigned instMVar)
(do oldVal ← instantiateMVars ref (mkMVar instMVar);
unlessM (isDefEq ref oldVal val) $
throwError ref $
(do oldVal ← instantiateMVars (mkMVar instMVar);
unlessM (isDefEq oldVal val) $
throwError $
"synthesized type class instance is not definitionally equal to expression "
++ "inferred by typing rules, synthesized" ++ indentExpr val
++ Format.line ++ "inferred" ++ indentExpr oldVal)
(assignExprMVar instMVar val);
pure true
| LOption.undef => pure false -- we will try later
| LOption.none => throwError ref ("failed to synthesize instance" ++ indentExpr type)
| LOption.none => throwError ("failed to synthesize instance" ++ indentExpr type)
/--
Try to apply coercion to make sure `e` has type `expectedType`.
@ -513,26 +529,26 @@ match result with
class CoeT (α : Sort u) (a : α) (β : Sort v)
abbrev coe {α : Sort u} {β : Sort v} (a : α) [CoeT α a β] : β
``` -/
def tryCoe (ref : Syntax) (expectedType : Expr) (eType : Expr) (e : Expr) (f? : Option Expr) : TermElabM Expr :=
condM (isDefEq ref expectedType eType) (pure e) $ do
u ← getLevel ref eType;
v ← getLevel ref expectedType;
def tryCoe (expectedType : Expr) (eType : Expr) (e : Expr) (f? : Option Expr) : TermElabM Expr :=
condM (isDefEq expectedType eType) (pure e) $ do
u ← getLevel eType;
v ← getLevel expectedType;
let coeTInstType := mkAppN (mkConst `CoeT [u, v]) #[eType, e, expectedType];
mvar ← mkFreshExprMVar ref coeTInstType MetavarKind.synthetic;
mvar ← mkFreshExprMVar coeTInstType MetavarKind.synthetic;
let eNew := mkAppN (mkConst `coe [u, v]) #[eType, expectedType, e, mvar];
let mvarId := mvar.mvarId!;
catch
(withoutMacroStackAtErr $ do
unlessM (synthesizeInstMVarCore ref mvarId) $
registerSyntheticMVar ref mvarId (SyntheticMVarKind.coe expectedType eType e f?);
unlessM (synthesizeInstMVarCore mvarId) $
registerSyntheticMVar mvarId (SyntheticMVarKind.coe expectedType eType e f?);
pure eNew)
(fun ex =>
match ex with
| Exception.ex (Elab.Exception.error errMsg) => throwTypeMismatchError ref expectedType eType e f? errMsg.data
| _ => throwTypeMismatchError ref expectedType eType e f?)
| Exception.ex (Elab.Exception.error errMsg) => throwTypeMismatchError expectedType eType e f? errMsg.data
| _ => throwTypeMismatchError expectedType eType e f?)
private def isTypeApp? (ref : Syntax) (type : Expr) : TermElabM (Option (Expr × Expr)) := do
type ← withReducible $ whnf ref type;
private def isTypeApp? (type : Expr) : TermElabM (Option (Expr × Expr)) := do
type ← withReducible $ whnf type;
match type with
| Expr.app m α _ => pure (some (m, α))
| _ => pure none
@ -542,37 +558,37 @@ structure IsMonadResult :=
(α : Expr)
(inst : Expr)
private def isMonad? (ref : Syntax) (type : Expr) : TermElabM (Option IsMonadResult) := do
type ← withReducible $ whnf ref type;
private def isMonad? (type : Expr) : TermElabM (Option IsMonadResult) := do
type ← withReducible $ whnf type;
match type with
| Expr.app m α _ =>
catch
(do
monadType ← mkAppM ref `Monad #[m];
result ← trySynthInstance ref monadType;
monadType ← mkAppM `Monad #[m];
result ← trySynthInstance monadType;
match result with
| LOption.some inst => pure (some { m := m, α := α, inst := inst })
| _ => pure none)
(fun _ => pure none)
| _ => pure none
def synthesizeInst (ref : Syntax) (type : Expr) : TermElabM Expr := do
type ← instantiateMVars ref type;
result ← trySynthInstance ref type;
def synthesizeInst (type : Expr) : TermElabM Expr := do
type ← instantiateMVars type;
result ← trySynthInstance type;
match result with
| LOption.some val => pure val
| LOption.undef => throwError ref ("failed to synthesize instance" ++ indentExpr type)
| LOption.none => throwError ref ("failed to synthesize instance" ++ indentExpr type)
| LOption.undef => throwError ("failed to synthesize instance" ++ indentExpr type)
| LOption.none => throwError ("failed to synthesize instance" ++ indentExpr type)
/--
Try to coerce `a : α` into `m β` by first coercing `a : α` into ‵β`, and then using `pure`.
The method is only applied if the head of `α` nor ‵β` is not a metavariable. -/
private def tryPureCoe? (ref : Syntax) (m β α a : Expr) : TermElabM (Option Expr) :=
private def tryPureCoe? (m β α a : Expr) : TermElabM (Option Expr) :=
if β.getAppFn.isMVar || α.getAppFn.isMVar then pure none
else catch
(do
aNew ← tryCoe ref β α a none;
aNew ← liftMetaM ref $ Meta.mkPure m aNew;
aNew ← tryCoe β α a none;
aNew ← liftMetaM $ Meta.mkPure m aNew;
pure $ some aNew)
(fun _ => pure none)
@ -633,46 +649,46 @@ On the other hand, TC can easily solve `[HasLiftT IO (StateT Nat IO)]`
since this goal does not contain any metavariables. And then, we
convert `g x` into `liftM $ g x`.
-/
def tryLiftAndCoe (ref : Syntax) (expectedType : Expr) (eType : Expr) (e : Expr) (f? : Option Expr) : TermElabM Expr := do
eType ← instantiateMVars ref eType;
some ⟨n, β, monadInst⟩ ← isMonad? ref expectedType | tryCoe ref expectedType eType e f?;
β ← instantiateMVars ref β;
eNew? ← tryPureCoe? ref n β eType e;
def tryLiftAndCoe (expectedType : Expr) (eType : Expr) (e : Expr) (f? : Option Expr) : TermElabM Expr := do
eType ← instantiateMVars eType;
some ⟨n, β, monadInst⟩ ← isMonad? expectedType | tryCoe expectedType eType e f?;
β ← instantiateMVars β;
eNew? ← tryPureCoe? n β eType e;
match eNew? with
| some eNew => pure eNew
| none => do
some (m, α) ← isTypeApp? ref eType | tryCoe ref expectedType eType e f?;
condM (isDefEq ref m n) (tryCoe ref expectedType eType e f?) $
some (m, α) ← isTypeApp? eType | tryCoe expectedType eType e f?;
condM (isDefEq m n) (tryCoe expectedType eType e f?) $
catch
(do
-- Construct lift from `m` to `n`
hasMonadLiftType ← mkAppM ref `HasMonadLiftT #[m, n];
hasMonadLiftVal ← synthesizeInst ref hasMonadLiftType;
u_1 ← getDecLevel ref α;
u_2 ← getDecLevel ref eType;
u_3 ← getDecLevel ref expectedType;
hasMonadLiftType ← mkAppM `HasMonadLiftT #[m, n];
hasMonadLiftVal ← synthesizeInst hasMonadLiftType;
u_1 ← getDecLevel α;
u_2 ← getDecLevel eType;
u_3 ← getDecLevel expectedType;
let eNew := mkAppN (Lean.mkConst `liftM [u_1, u_2, u_3]) #[m, n, hasMonadLiftVal, α, e];
eNewType ← inferType ref eNew;
condM (isDefEq ref expectedType eNewType)
eNewType ← inferType eNew;
condM (isDefEq expectedType eNewType)
(pure eNew) -- approach 2 worked
(do
u ← getLevel ref α;
v ← getLevel ref β;
u ← getLevel α;
v ← getLevel β;
let coeTInstType := Lean.mkForall `a BinderInfo.default α $ mkAppN (mkConst `CoeT [u, v]) #[α, mkBVar 0, β];
coeTInstVal ← synthesizeInst ref coeTInstType;
coeTInstVal ← synthesizeInst coeTInstType;
let eNew := mkAppN (Lean.mkConst `liftCoeM [u_1, u_2, u_3]) #[m, n, α, β, hasMonadLiftVal, coeTInstVal, monadInst, e];
eNewType ← inferType ref eNew;
condM (isDefEq ref expectedType eNewType)
eNewType ← inferType eNew;
condM (isDefEq expectedType eNewType)
(pure eNew) -- approach 3 worked
(throwTypeMismatchError ref expectedType eType e f?)))
(fun _ => throwTypeMismatchError ref expectedType eType e f?)
(throwTypeMismatchError expectedType eType e f?)))
(fun _ => throwTypeMismatchError expectedType eType e f?)
/--
If `expectedType?` is `some t`, then ensure `t` and `eType` are definitionally equal.
If they are not, then try coercions.
Argument `f?` is used only for generating error messages. -/
def ensureHasTypeAux (ref : Syntax) (expectedType? : Option Expr) (eType : Expr) (e : Expr) (f? : Option Expr := none) : TermElabM Expr :=
def ensureHasTypeAux (expectedType? : Option Expr) (eType : Expr) (e : Expr) (f? : Option Expr := none) : TermElabM Expr :=
match expectedType? with
| none => pure e
| some expectedType =>
@ -712,23 +728,23 @@ match expectedType? with
The `isDefEqNoConstantApprox` fails to unify the expected and inferred types. Then, `tryLiftAndCoe` first tries
the monadic extensions, and then falls back to `isDefEq` which enables all approximations.
-/
condM (isDefEqNoConstantApprox ref eType expectedType)
condM (isDefEqNoConstantApprox eType expectedType)
(pure e)
(tryLiftAndCoe ref expectedType eType e f?)
(tryLiftAndCoe expectedType eType e f?)
/--
If `expectedType?` is `some t`, then ensure `t` and type of `e` are definitionally equal.
If they are not, then try coercions. -/
def ensureHasType (ref : Syntax) (expectedType? : Option Expr) (e : Expr) : TermElabM Expr :=
def ensureHasType (expectedType? : Option Expr) (e : Expr) : TermElabM Expr :=
match expectedType? with
| none => pure e
| _ => do eType ← inferType ref e; ensureHasTypeAux ref expectedType? eType e
| _ => do eType ← inferType e; ensureHasTypeAux expectedType? eType e
private def exceptionToSorry (ref : Syntax) (errMsg : Message) (expectedType? : Option Expr) : TermElabM Expr := do
private def exceptionToSorry (errMsg : Message) (expectedType? : Option Expr) : TermElabM Expr := do
expectedType : Expr ← match expectedType? with
| none => mkFreshTypeMVar ref
| none => mkFreshTypeMVar
| some expectedType => pure expectedType;
u ← getLevel ref expectedType;
u ← getLevel expectedType;
-- TODO: should be `(sorryAx.{$u} $expectedType true) when we support antiquotations at that place
let syntheticSorry := mkApp2 (mkConst `sorryAx [u]) expectedType (mkConst `Bool.true);
unless errMsg.data.hasSyntheticSorry $ logMessage errMsg;
@ -749,10 +765,10 @@ match e? with
| none => tryPostpone
private def postponeElabTerm (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
trace `Elab.postpone stx $ fun _ => stx ++ " : " ++ expectedType?;
mvar ← mkFreshExprMVar stx expectedType? MetavarKind.syntheticOpaque;
trace `Elab.postpone $ fun _ => stx ++ " : " ++ expectedType?;
mvar ← mkFreshExprMVar expectedType? MetavarKind.syntheticOpaque;
ctx ← read;
registerSyntheticMVar stx mvar.mvarId! (SyntheticMVarKind.postponed ctx.macroStack);
withRef stx $ registerSyntheticMVar mvar.mvarId! (SyntheticMVarKind.postponed ctx.macroStack);
pure mvar
/-
@ -762,10 +778,10 @@ private def elabUsingElabFnsAux (s : State) (stx : Syntax) (expectedType? : Opti
: List TermElab → TermElabM Expr
| [] => do
let refFmt := stx.prettyPrint;
throwError stx ("unexpected syntax" ++ MessageData.nest 2 (Format.line ++ refFmt))
throwError ("unexpected syntax" ++ MessageData.nest 2 (Format.line ++ refFmt))
| (elabFn::elabFns) => catch (elabFn stx expectedType?)
(fun ex => match ex with
| Exception.ex (Elab.Exception.error errMsg) => do ctx ← read; if ctx.errToSorry then exceptionToSorry stx errMsg expectedType? else throw ex
| Exception.ex (Elab.Exception.error errMsg) => do ctx ← read; if ctx.errToSorry then exceptionToSorry errMsg expectedType? else throw ex
| Exception.ex Elab.Exception.unsupportedSyntax => do set s; elabUsingElabFnsAux elabFns
| Exception.postpone =>
if catchExPostpone then do
@ -794,7 +810,7 @@ let table := (termElabAttribute.ext.getState s.env).table;
let k := stx.getKind;
match table.find? k with
| some elabFns => elabUsingElabFnsAux s stx expectedType? catchExPostpone elabFns
| none => throwError stx ("elaboration function for '" ++ toString k ++ "' has not been implemented")
| none => throwError ("elaboration function for '" ++ toString k ++ "' has not been implemented")
instance : MonadMacroAdapter TermElabM :=
{ getEnv := getEnv,
@ -803,7 +819,7 @@ instance : MonadMacroAdapter TermElabM :=
setNextMacroScope := fun next => modify $ fun s => { s with nextMacroScope := next },
getCurrRecDepth := do ctx ← read; pure ctx.currRecDepth,
getMaxRecDepth := do ctx ← read; pure ctx.maxRecDepth,
throwError := @throwError,
throwError := @throwErrorAt,
throwUnsupportedSyntax := @throwUnsupportedSyntax}
private def isExplicit (stx : Syntax) : Bool :=
@ -839,7 +855,7 @@ def useImplicitLambda? (stx : Syntax) (expectedType? : Option Expr) : TermElabM
if blockImplicitLambda stx then pure none
else match expectedType? with
| some expectedType => do
expectedType ← whnfForall stx expectedType;
expectedType ← whnfForall expectedType;
match expectedType with
| Expr.forallE _ _ _ c => pure $ if c.binderInfo.isExplicit then none else some expectedType
| _ => pure $ none
@ -848,8 +864,8 @@ else match expectedType? with
def elabImplicitLambdaAux (stx : Syntax) (catchExPostpone : Bool) (expectedType : Expr) (fvars : Array Expr) : TermElabM Expr := do
body ← elabUsingElabFns stx expectedType catchExPostpone;
-- body ← ensureHasType stx expectedType body;
r ← mkLambda stx fvars body;
trace `Elab.implicitForall stx $ fun _ => r;
r ← mkLambda fvars body;
trace `Elab.implicitForall $ fun _ => r;
pure r
partial def elabImplicitLambda (stx : Syntax) (catchExPostpone : Bool) : Expr → Array Expr → TermElabM Expr
@ -858,16 +874,16 @@ partial def elabImplicitLambda (stx : Syntax) (catchExPostpone : Bool) : Expr
elabImplicitLambdaAux stx catchExPostpone type fvars
else withFreshMacroScope $ do
n ← MonadQuotation.addMacroScope n;
withLocalDecl stx n c.binderInfo d $ fun fvar => do
type ← whnfForall stx (b.instantiate1 fvar);
withLocalDecl n c.binderInfo d $ fun fvar => do
type ← whnfForall (b.instantiate1 fvar);
elabImplicitLambda type (fvars.push fvar)
| type, fvars =>
elabImplicitLambdaAux stx catchExPostpone type fvars
/- Main loop for `elabTerm` -/
partial def elabTermAux (expectedType? : Option Expr) (catchExPostpone : Bool) (implicitLambda : Bool) : Syntax → TermElabM Expr
| stx => withFreshMacroScope $ withIncRecDepth stx $ do
trace `Elab.step stx $ fun _ => expectedType? ++ " " ++ stx;
| stx => withFreshMacroScope $ withIncRecDepth do
trace `Elab.step $ fun _ => expectedType? ++ " " ++ stx;
s ← get;
stxNew? ← catch
(do newStx ← adaptMacro (getMacros s.env) stx; pure (some newStx))
@ -896,7 +912,7 @@ partial def elabTermAux (expectedType? : Option Expr) (catchExPostpone : Bool) (
The option `catchExPostpone == false` is used to implement `resumeElabTerm`
to prevent the creation of another synthetic metavariable when resuming the elaboration. -/
def elabTerm (stx : Syntax) (expectedType? : Option Expr) (catchExPostpone := true) : TermElabM Expr :=
elabTermAux expectedType? catchExPostpone true stx
withRef stx $ elabTermAux expectedType? catchExPostpone true stx
def elabTermWithoutImplicitLambdas (stx : Syntax) (expectedType? : Option Expr) (catchExPostpone := true) : TermElabM Expr := do
elabTermAux expectedType? catchExPostpone false stx
@ -940,11 +956,11 @@ ctx ← read;
let needReset := ctx.localInstances == mvarDecl.localInstances;
withLCtx mvarDecl.lctx mvarDecl.localInstances $ resettingSynthInstanceCacheWhen needReset x
def mkInstMVar (ref : Syntax) (type : Expr) : TermElabM Expr := do
mvar ← mkFreshExprMVar ref type MetavarKind.synthetic;
def mkInstMVar (type : Expr) : TermElabM Expr := do
mvar ← mkFreshExprMVar type MetavarKind.synthetic;
let mvarId := mvar.mvarId!;
unlessM (synthesizeInstMVarCore ref mvarId) $
registerSyntheticMVar ref mvarId SyntheticMVarKind.typeClass;
unlessM (synthesizeInstMVarCore mvarId) $
registerSyntheticMVar mvarId SyntheticMVarKind.typeClass;
pure mvar
/-
@ -953,61 +969,61 @@ pure mvar
class CoeSort (α : Sort u) (β : outParam (Sort v))
abbrev coeSort {α : Sort u} {β : Sort v} (a : α) [CoeSort α β] : β
``` -/
private def tryCoeSort (ref : Syntax) (α : Expr) (a : Expr) : TermElabM Expr := do
β ← mkFreshTypeMVar ref;
u ← getLevel ref α;
v ← getLevel ref β;
private def tryCoeSort (α : Expr) (a : Expr) : TermElabM Expr := do
β ← mkFreshTypeMVar;
u ← getLevel α;
v ← getLevel β;
let coeSortInstType := mkAppN (Lean.mkConst `CoeSort [u, v]) #[α, β];
mvar ← mkFreshExprMVar ref coeSortInstType MetavarKind.synthetic;
mvar ← mkFreshExprMVar coeSortInstType MetavarKind.synthetic;
let mvarId := mvar.mvarId!;
catch
(withoutMacroStackAtErr $ condM (synthesizeInstMVarCore ref mvarId)
(withoutMacroStackAtErr $ condM (synthesizeInstMVarCore mvarId)
(pure $ mkAppN (Lean.mkConst `coeSort [u, v]) #[α, β, a, mvar])
(throwError ref "type expected"))
(throwError "type expected"))
(fun ex =>
match ex with
| Exception.ex (Elab.Exception.error errMsg) => throwError ref ("type expected" ++ Format.line ++ errMsg.data)
| _ => throwError ref "type expected")
| Exception.ex (Elab.Exception.error errMsg) => throwError ("type expected" ++ Format.line ++ errMsg.data)
| _ => throwError "type expected")
/--
Make sure `e` is a type by inferring its type and making sure it is a `Expr.sort`
or is unifiable with `Expr.sort`, or can be coerced into one. -/
def ensureType (ref : Syntax) (e : Expr) : TermElabM Expr :=
condM (isType ref e)
def ensureType (e : Expr) : TermElabM Expr :=
condM (isType e)
(pure e)
(do
eType ← inferType ref e;
u ← mkFreshLevelMVar ref;
condM (isDefEq ref eType (mkSort u))
eType ← inferType e;
u ← mkFreshLevelMVar;
condM (isDefEq eType (mkSort u))
(pure e)
(tryCoeSort ref eType e))
(tryCoeSort eType e))
/-- Elaborate `stx` and ensure result is a type. -/
def elabType (stx : Syntax) : TermElabM Expr := do
u ← mkFreshLevelMVar stx;
u ← mkFreshLevelMVar;
type ← elabTerm stx (mkSort u);
ensureType stx type
withRef stx $ ensureType type
def addDecl (ref : Syntax) (decl : Declaration) : TermElabM Unit := do
def addDecl (decl : Declaration) : TermElabM Unit := do
env ← getEnv;
match env.addDecl decl with
| Except.ok env => setEnv env
| Except.error kex => do opts ← getOptions; throwError ref (kex.toMessageData opts)
| Except.error kex => do opts ← getOptions; throwError (kex.toMessageData opts)
def compileDecl (ref : Syntax) (decl : Declaration) : TermElabM Unit := do
def compileDecl (decl : Declaration) : TermElabM Unit := do
env ← getEnv;
opts ← getOptions;
match env.compileDecl opts decl with
| Except.ok env => setEnv env
| Except.error kex => throwError ref (kex.toMessageData opts)
| Except.error kex => throwError (kex.toMessageData opts)
def mkAuxDefinition (ref : Syntax) (declName : Name) (type : Expr) (value : Expr) (zeta : Bool := false) : TermElabM Expr := do
def mkAuxDefinition (declName : Name) (type : Expr) (value : Expr) (zeta : Bool := false) : TermElabM Expr := do
env ← getEnv;
opts ← getOptions;
mctx ← getMCtx;
lctx ← getLCtx;
match Lean.mkAuxDefinition env opts mctx lctx declName type value zeta with
| Except.error ex => throwError ref (ex.toMessageData opts)
| Except.error ex => throwError (ex.toMessageData opts)
| Except.ok (r, env, mctx) => do
setEnv env;
setMCtx mctx;
@ -1021,11 +1037,11 @@ private partial def mkAuxNameAux (env : Environment) (base : Name) : Nat → Nam
else
candidate
def mkAuxName (ref : Syntax) (suffix : Name) : TermElabM Name := do
def mkAuxName (suffix : Name) : TermElabM Name := do
env ← getEnv;
ctx ← read;
match ctx.declName? with
| none => throwError ref "auxiliary declaration cannot be created when declaration name is not available"
| none => throwError "auxiliary declaration cannot be created when declaration name is not available"
| some declName => pure $ mkAuxNameAux env (declName ++ suffix) 1
/- =======================================
@ -1052,30 +1068,30 @@ fun stx _ => do
pure $ mkSort (mkLevelSucc u)
@[builtinTermElab «hole»] def elabHole : TermElab :=
fun stx expectedType? => mkFreshExprMVar stx expectedType?
fun stx expectedType? => mkFreshExprMVar expectedType?
@[builtinTermElab «namedHole»] def elabNamedHole : TermElab :=
fun stx expectedType? =>
let name := stx.getIdAt 1;
mkFreshExprMVar stx expectedType? MetavarKind.syntheticOpaque name
mkFreshExprMVar expectedType? MetavarKind.syntheticOpaque name
def mkTacticMVar (ref : Syntax) (type : Expr) (tacticCode : Syntax) : TermElabM Expr := do
mvar ← mkFreshExprMVar ref type MetavarKind.syntheticOpaque `main;
def mkTacticMVar (type : Expr) (tacticCode : Syntax) : TermElabM Expr := do
mvar ← mkFreshExprMVar type MetavarKind.syntheticOpaque `main;
let mvarId := mvar.mvarId!;
registerSyntheticMVar ref mvarId $ SyntheticMVarKind.tactic tacticCode;
registerSyntheticMVar mvarId $ SyntheticMVarKind.tactic tacticCode;
pure mvar
@[builtinTermElab tacticBlock] def elabTacticBlock : TermElab :=
fun stx expectedType? =>
match expectedType? with
| some expectedType => mkTacticMVar stx expectedType (stx.getArg 1)
| none => throwError stx ("invalid tactic block, expected type has not been provided")
| some expectedType => mkTacticMVar expectedType (stx.getArg 1)
| none => throwError ("invalid tactic block, expected type has not been provided")
@[builtinTermElab byTactic] def elabByTactic : TermElab :=
fun stx expectedType? =>
match expectedType? with
| some expectedType => mkTacticMVar stx expectedType (stx.getArg 1)
| none => throwError stx ("invalid 'by' tactic, expected type has not been provided")
| some expectedType => mkTacticMVar expectedType (stx.getArg 1)
| none => throwError ("invalid 'by' tactic, expected type has not been provided")
/-- Main loop for `mkPairs`. -/
private partial def mkPairsAux (elems : Array Syntax) : Nat → Syntax → MacroM Syntax
@ -1109,18 +1125,17 @@ match stx? with
@[builtinTermElab paren] def elabParen : TermElab :=
fun stx expectedType? =>
let ref := stx;
match_syntax ref with
match_syntax stx with
| `(()) => pure $ Lean.mkConst `Unit.unit
| `(($e : $type)) => do
type ← elabType type;
e ← elabCDot e type;
ensureHasType ref type e
ensureHasType type e
| `(($e)) => elabCDot e expectedType?
| `(($e, $es*)) => do
pairs ← liftMacroM $ mkPairs (#[e] ++ es.getEvenElems);
withMacroExpansion stx pairs (elabTerm pairs expectedType?)
| _ => throwError stx "unexpected parentheses notation"
| _ => throwError "unexpected parentheses notation"
@[builtinMacro Lean.Parser.Term.listLit] def expandListLit : Macro :=
fun stx =>
@ -1159,31 +1174,31 @@ match stx.isTermId? relaxed with
| _ => pure none
| _ => pure none
private def mkFreshLevelMVars (ref : Syntax) (num : Nat) : TermElabM (List Level) :=
num.foldM (fun _ us => do u ← mkFreshLevelMVar ref; pure $ u::us) []
private def mkFreshLevelMVars (num : Nat) : TermElabM (List Level) :=
num.foldM (fun _ us => do u ← mkFreshLevelMVar; pure $ u::us) []
/--
Create an `Expr.const` using the given name and explicit levels.
Remark: fresh universe metavariables are created if the constant has more universe
parameters than `explicitLevels`. -/
def mkConst (ref : Syntax) (constName : Name) (explicitLevels : List Level := []) : TermElabM Expr := do
def mkConst (constName : Name) (explicitLevels : List Level := []) : TermElabM Expr := do
env ← getEnv;
match env.find? constName with
| none => throwError ref ("unknown constant '" ++ constName ++ "'")
| none => throwError ("unknown constant '" ++ constName ++ "'")
| some cinfo =>
if explicitLevels.length > cinfo.lparams.length then
throwError ref ("too many explicit universe levels")
throwError ("too many explicit universe levels")
else do
let numMissingLevels := cinfo.lparams.length - explicitLevels.length;
us ← mkFreshLevelMVars ref numMissingLevels;
us ← mkFreshLevelMVars numMissingLevels;
pure $ Lean.mkConst constName (explicitLevels ++ us)
private def mkConsts (ref : Syntax) (candidates : List (Name × List String)) (explicitLevels : List Level) : TermElabM (List (Expr × List String)) := do
private def mkConsts (candidates : List (Name × List String)) (explicitLevels : List Level) : TermElabM (List (Expr × List String)) := do
env ← getEnv;
candidates.foldlM
(fun result ⟨constName, projs⟩ => do
-- TODO: better suppor for `mkConst` failure. We may want to cache the failures, and report them if all candidates fail.
const ← mkConst ref constName explicitLevels;
const ← mkConst constName explicitLevels;
pure $ (const, projs) :: result)
[]
@ -1193,21 +1208,21 @@ currNamespace ← getCurrNamespace;
openDecls ← getOpenDecls;
pure (Lean.Elab.resolveGlobalName env currNamespace openDecls n)
def resolveName (ref : Syntax) (n : Name) (preresolved : List (Name × List String)) (explicitLevels : List Level) : TermElabM (List (Expr × List String)) := do
def resolveName (n : Name) (preresolved : List (Name × List String)) (explicitLevels : List Level) : TermElabM (List (Expr × List String)) := do
result? ← resolveLocalName n;
match result? with
| some (e, projs) => do
unless explicitLevels.isEmpty $
throwError ref ("invalid use of explicit universe parameters, '" ++ e ++ "' is a local");
throwError ("invalid use of explicit universe parameters, '" ++ e ++ "' is a local");
pure [(e, projs)]
| none =>
let process (candidates : List (Name × List String)) : TermElabM (List (Expr × List String)) := do {
when candidates.isEmpty $ do {
mainModule ← getMainModule;
let view := extractMacroScopes n;
throwError ref ("unknown identifier '" ++ view.format mainModule ++ "'")
throwError ("unknown identifier '" ++ view.format mainModule ++ "'")
};
mkConsts ref candidates explicitLevels
mkConsts candidates explicitLevels
};
if preresolved.isEmpty then do
r ← resolveGlobalName n;
@ -1216,7 +1231,7 @@ match result? with
process preresolved
@[builtinTermElab cdot] def elabBadCDot : TermElab :=
fun stx _ => throwError stx "invalid occurrence of `·` notation, it must be surrounded by parentheses (e.g. `(· + 1)`)"
fun stx _ => throwError "invalid occurrence of `·` notation, it must be surrounded by parentheses (e.g. `(· + 1)`)"
/-
A raw literal is not a valid term, but it is nice to have a handler for them because it allows `macros` to insert them into terms.
@ -1226,7 +1241,7 @@ fun stx _ => throwError stx "invalid occurrence of `·` notation, it must be sur
fun stx _ => do
match stx.isStrLit? with
| some val => pure $ mkStrLit val
| none => throwError stx "ill-formed syntax"
| none => throwError "ill-formed syntax"
@[builtinTermElab str] def elabStr : TermElab :=
fun stx expectedType? => elabRawStrLit (stx.getArg 0) expectedType?
@ -1234,18 +1249,17 @@ fun stx expectedType? => elabRawStrLit (stx.getArg 0) expectedType?
/- See `elabRawStrLit` -/
@[builtinTermElab numLit] def elabRawNumLit : TermElab :=
fun stx expectedType? => do
let ref := stx;
val ← match stx.isNatLit? with
| some val => pure (mkNatLit val)
| none => throwError stx "ill-formed syntax";
typeMVar ← mkFreshTypeMVar ref MetavarKind.synthetic;
registerSyntheticMVar ref typeMVar.mvarId! (SyntheticMVarKind.withDefault (Lean.mkConst `Nat));
| none => throwError "ill-formed syntax";
typeMVar ← mkFreshTypeMVar MetavarKind.synthetic;
registerSyntheticMVar typeMVar.mvarId! (SyntheticMVarKind.withDefault (Lean.mkConst `Nat));
match expectedType? with
| some expectedType => do _ ← isDefEq ref expectedType typeMVar; pure ()
| some expectedType => do _ ← isDefEq expectedType typeMVar; pure ()
| _ => pure ();
u ← getLevel ref typeMVar;
u ← decLevel ref u;
mvar ← mkInstMVar ref (mkApp (Lean.mkConst `HasOfNat [u]) typeMVar);
u ← getLevel typeMVar;
u ← decLevel u;
mvar ← mkInstMVar (mkApp (Lean.mkConst `HasOfNat [u]) typeMVar);
pure $ mkApp3 (Lean.mkConst `HasOfNat.ofNat [u]) typeMVar mvar val
@[builtinTermElab num] def elabNum : TermElab :=
@ -1256,7 +1270,7 @@ fun stx expectedType? => elabRawNumLit (stx.getArg 0) expectedType?
fun stx _ => do
match stx.isCharLit? with
| some val => pure $ mkApp (Lean.mkConst `Char.ofNat) (mkNatLit val.toNat)
| none => throwError stx "ill-formed syntax"
| none => throwError "ill-formed syntax"
@[builtinTermElab char] def elabChar : TermElab :=
fun stx expectedType? => elabRawCharLit (stx.getArg 0) expectedType?
@ -1265,7 +1279,7 @@ fun stx expectedType? => elabRawCharLit (stx.getArg 0) expectedType?
fun stx _ =>
match (stx.getArg 0).isNameLit? with
| some val => pure $ toExpr val
| none => throwError stx "ill-formed syntax"
| none => throwError "ill-formed syntax"
instance MetaHasEval {α} [MetaHasEval α] : MetaHasEval (TermElabM α) :=
⟨fun env opts x _ => do

63
stage0/src/Lean/Meta/EqnCompiler/DepElim.lean
View file

@ -276,19 +276,11 @@ structure ElimResult :=
(unusedAltIdxs : List Nat)
/- The number of patterns in each AltLHS must be equal to majors.length -/
private def checkNumPatterns (majors : List Expr) (lhss : List AltLHS) : MetaM Unit :=
let num := majors.length;
private def checkNumPatterns (majors : Array Expr) (lhss : List AltLHS) : MetaM Unit :=
let num := majors.size;
when (lhss.any (fun lhs => lhs.patterns.length != num)) $
throwOther "incorrect number of patterns"
/-
Given major premises `(x_1 : A_1) (x_2 : A_2[x_1]) ... (x_n : A_n[x_1, x_2, ...])`, return
`forall (x_1 : A_1) (x_2 : A_2[x_1]) ... (x_n : A_n[x_1, x_2, ...]), sortv` -/
private def withMotive {α} (majors : Array Expr) (sortv : Expr) (k : Expr → MetaM α) : MetaM α := do
type ← mkForall majors sortv;
trace! `Meta.EqnCompiler.matchDebug ("motive: " ++ type);
withLocalDecl `motive type BinderInfo.default k
private def localDeclsToMVarsAux : List LocalDecl → List MVarId → FVarSubst → MetaM (List MVarId × FVarSubst)
| [], mvars, s => pure (mvars.reverse, s)
| d::ds, mvars, s => do
@ -710,6 +702,30 @@ s ← majors.foldlM
s;
pure s.getUnusedLevelParam
def mkElim (elimName : Name) (motiveType : Expr) (lhss : List AltLHS) : MetaM ElimResult :=
withLocalDecl `motive motiveType BinderInfo.default fun motive => do
forallTelescopeReducing motiveType fun majors _ => do
checkNumPatterns majors lhss;
let mvarType := mkAppN motive majors;
trace! `Meta.EqnCompiler.matchDebug ("target: " ++ mvarType);
withAlts motive lhss fun alts minors => do
mvar ← mkFreshExprMVar mvarType;
let examples := majors.toList.map fun major => Example.var major.fvarId!;
s ← process { mvarId := mvar.mvarId!, vars := majors.toList, alts := alts, examples := examples } {};
let args := #[motive] ++ majors ++ minors;
type ← mkForall args mvarType;
val ← mkLambda args mvar;
trace! `Meta.EqnCompiler.matchDebug ("eliminator value: " ++ val ++ "\ntype: " ++ type);
elim ← mkAuxDefinition elimName type val;
setInlineAttribute elimName;
trace! `Meta.EqnCompiler.matchDebug ("eliminator: " ++ elim);
let unusedAltIdxs : List Nat := lhss.length.fold
(fun i r => if s.used.contains i then r else i::r)
[];
pure { elim := elim, counterExamples := s.counterExamples, unusedAltIdxs := unusedAltIdxs.reverse }
/- Helper methods for testins mkElim -/
/- Return `Prop` if `inProf == true` and `Sort u` otherwise, where `u` is a fresh universe level parameter. -/
private def mkElimSort (majors : List Expr) (lhss : List AltLHS) (inProp : Bool) : MetaM Expr :=
if inProp then
@ -718,32 +734,11 @@ else do
v ← getUnusedLevelParam majors lhss;
pure $ mkSort $ v
def mkElimCore (elimName : Name) (motive : Expr) (majors : List Expr) (lhss : List AltLHS) (inProp : Bool := false) : MetaM ElimResult := do
checkNumPatterns majors lhss;
generalizeTelescope majors.toArray `_d fun majors => do
let mvarType := mkAppN motive majors;
trace! `Meta.EqnCompiler.matchDebug ("target: " ++ mvarType);
withAlts motive lhss fun alts minors => do
mvar ← mkFreshExprMVar mvarType;
let examples := majors.toList.map fun major => Example.var major.fvarId!;
s ← process { mvarId := mvar.mvarId!, vars := majors.toList, alts := alts, examples := examples } {};
let args := #[motive] ++ majors ++ minors;
type ← mkForall args mvarType;
val ← mkLambda args mvar;
trace! `Meta.EqnCompiler.matchDebug ("eliminator value: " ++ val ++ "\ntype: " ++ type);
elim ← mkAuxDefinition elimName type val;
setInlineAttribute elimName;
trace! `Meta.EqnCompiler.matchDebug ("eliminator: " ++ elim);
let unusedAltIdxs : List Nat := lhss.length.fold
(fun i r => if s.used.contains i then r else i::r)
[];
pure { elim := elim, counterExamples := s.counterExamples, unusedAltIdxs := unusedAltIdxs.reverse }
def mkElim (elimName : Name) (majors : List Expr) (lhss : List AltLHS) (inProp : Bool := false) : MetaM ElimResult := do
def mkElimTester (elimName : Name) (majors : List Expr) (lhss : List AltLHS) (inProp : Bool := false) : MetaM ElimResult := do
sortv ← mkElimSort majors lhss inProp;
generalizeTelescope majors.toArray `_d fun majors => do
withMotive majors sortv fun motive =>
mkElimCore elimName motive majors.toList lhss inProp
motiveType ← mkForall majors sortv;
mkElim elimName motiveType lhss
@[init] private def regTraceClasses : IO Unit := do
registerTraceClass `Meta.EqnCompiler.match;

26147
stage0/stdlib/Lean/Elab/App.c
View file

File diff suppressed because it is too large Load diff

10465
stage0/stdlib/Lean/Elab/Binders.c
View file

File diff suppressed because it is too large Load diff

2419
stage0/stdlib/Lean/Elab/BuiltinNotation.c
View file

File diff suppressed because it is too large Load diff

1564
stage0/stdlib/Lean/Elab/CollectFVars.c
View file

File diff suppressed because it is too large Load diff

2650
stage0/stdlib/Lean/Elab/Command.c
View file

File diff suppressed because it is too large Load diff

27
stage0/stdlib/Lean/Elab/Declaration.c
View file

@ -14,13 +14,14 @@
extern "C" {
#endif
lean_object* l_Lean_Elab_Command_elabDeclaration(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Term_mkForall(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Term_mkForall(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Declaration_7__expandMutualPreamble_x3f___closed__2;
lean_object* l_Lean_Elab_Term_throwErrorAt___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_expandOptDeclSig(lean_object*);
extern lean_object* l_Lean_Parser_Command_abbrev___elambda__1___closed__2;
lean_object* l___private_Lean_Elab_Declaration_7__expandMutualPreamble_x3f___closed__7;
lean_object* l_Lean_Elab_Command_addDecl(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Term_instantiateMVars(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Command_addDecl(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Term_instantiateMVars(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Command_elabAxiom___lambda__2___boxed(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Command_elabConstant___closed__4;
lean_object* l_unreachable_x21___rarg(lean_object*);
@ -49,7 +50,7 @@ extern lean_object* l_Lean_PrettyPrinter_Parenthesizer_termParser_parenthesizer_
lean_object* l___private_Lean_Elab_Declaration_2__classInductiveSyntaxToView(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* lean_array_push(lean_object*, lean_object*);
lean_object* lean_array_get_size(lean_object*);
lean_object* l_Lean_Elab_Term_mkForallUsedOnly(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Term_mkForallUsedOnly(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___regBuiltin_Lean_Elab_Command_elabMutual(lean_object*);
extern lean_object* l_Lean_Parser_Command_mutual___elambda__1___closed__1;
lean_object* lean_string_utf8_byte_size(lean_object*);
@ -97,7 +98,6 @@ lean_object* l___private_Lean_Elab_Declaration_7__expandMutualPreamble_x3f___clo
extern lean_object* l_Lean_Meta_registerInstanceAttr___closed__2;
lean_object* l_Lean_Elab_Command_elabClassInductive(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* lean_name_mk_string(lean_object*, lean_object*);
lean_object* l_Lean_Elab_Term_throwError___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Command_throwError___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
extern lean_object* l_Lean_Parser_Command_instance___elambda__1___closed__1;
extern lean_object* l_Lean_Parser_Command_variable___elambda__1___closed__2;
@ -747,7 +747,6 @@ _start:
{
lean_object* x_11;
lean_inc(x_9);
lean_inc(x_1);
x_11 = l_Lean_Elab_Term_elabType(x_1, x_9, x_10);
if (lean_obj_tag(x_11) == 0)
{
@ -768,14 +767,14 @@ x_17 = lean_ctor_get(x_16, 1);
lean_inc(x_17);
lean_dec(x_16);
lean_inc(x_9);
x_18 = l_Lean_Elab_Term_instantiateMVars(x_1, x_12, x_9, x_17);
x_18 = l_Lean_Elab_Term_instantiateMVars(x_12, x_9, x_17);
x_19 = lean_ctor_get(x_18, 0);
lean_inc(x_19);
x_20 = lean_ctor_get(x_18, 1);
lean_inc(x_20);
lean_dec(x_18);
lean_inc(x_9);
x_21 = l_Lean_Elab_Term_mkForall(x_1, x_8, x_19, x_9, x_20);
x_21 = l_Lean_Elab_Term_mkForall(x_8, x_19, x_9, x_20);
if (lean_obj_tag(x_21) == 0)
{
lean_object* x_22; lean_object* x_23; lean_object* x_24;
@ -785,8 +784,7 @@ x_23 = lean_ctor_get(x_21, 1);
lean_inc(x_23);
lean_dec(x_21);
lean_inc(x_9);
x_24 = l_Lean_Elab_Term_mkForallUsedOnly(x_1, x_2, x_22, x_9, x_23);
lean_dec(x_1);
x_24 = l_Lean_Elab_Term_mkForallUsedOnly(x_2, x_22, x_9, x_23);
if (lean_obj_tag(x_24) == 0)
{
lean_object* x_25; lean_object* x_26; lean_object* x_27; lean_object* x_28; lean_object* x_29; uint8_t x_30;
@ -830,7 +828,7 @@ x_39 = lean_alloc_ctor(2, 1, 0);
lean_ctor_set(x_39, 0, x_38);
x_40 = lean_alloc_ctor(0, 1, 0);
lean_ctor_set(x_40, 0, x_39);
x_41 = l_Lean_Elab_Term_throwError___rarg(x_5, x_40, x_9, x_32);
x_41 = l_Lean_Elab_Term_throwErrorAt___rarg(x_5, x_40, x_9, x_32);
return x_41;
}
else
@ -884,7 +882,7 @@ x_55 = lean_alloc_ctor(2, 1, 0);
lean_ctor_set(x_55, 0, x_54);
x_56 = lean_alloc_ctor(0, 1, 0);
lean_ctor_set(x_56, 0, x_55);
x_57 = l_Lean_Elab_Term_throwError___rarg(x_5, x_56, x_9, x_48);
x_57 = l_Lean_Elab_Term_throwErrorAt___rarg(x_5, x_56, x_9, x_48);
return x_57;
}
else
@ -946,7 +944,6 @@ lean_dec(x_6);
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_2);
lean_dec(x_1);
x_68 = !lean_is_exclusive(x_21);
if (x_68 == 0)
{
@ -977,7 +974,6 @@ lean_dec(x_6);
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_2);
lean_dec(x_1);
x_72 = !lean_is_exclusive(x_16);
if (x_72 == 0)
{
@ -1007,7 +1003,6 @@ lean_dec(x_6);
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_2);
lean_dec(x_1);
x_76 = !lean_is_exclusive(x_11);
if (x_76 == 0)
{
@ -1661,7 +1656,7 @@ block_32:
{
lean_object* x_16;
lean_inc(x_8);
x_16 = l_Lean_Elab_Command_addDecl(x_3, x_14, x_8, x_15);
x_16 = l_Lean_Elab_Command_addDecl(x_14, x_8, x_15);
lean_dec(x_14);
if (lean_obj_tag(x_16) == 0)
{

2355
stage0/stdlib/Lean/Elab/Definition.c
View file

File diff suppressed because it is too large Load diff

3525
stage0/stdlib/Lean/Elab/DoNotation.c
View file

File diff suppressed because it is too large Load diff

10345
stage0/stdlib/Lean/Elab/Inductive.c
View file

File diff suppressed because it is too large Load diff

24482
stage0/stdlib/Lean/Elab/Match.c
View file

File diff suppressed because it is too large Load diff

27184
stage0/stdlib/Lean/Elab/Quotation.c
View file

File diff suppressed because it is too large Load diff

22540
stage0/stdlib/Lean/Elab/StructInst.c
View file

File diff suppressed because it is too large Load diff

10782
stage0/stdlib/Lean/Elab/Structure.c
View file

File diff suppressed because it is too large Load diff

2473
stage0/stdlib/Lean/Elab/Syntax.c
View file

File diff suppressed because it is too large Load diff

8073
stage0/stdlib/Lean/Elab/SyntheticMVars.c
View file

File diff suppressed because it is too large Load diff

7928
stage0/stdlib/Lean/Elab/Tactic/Basic.c
View file

File diff suppressed because it is too large Load diff

1405
stage0/stdlib/Lean/Elab/Tactic/ElabTerm.c
View file

File diff suppressed because it is too large Load diff

402
stage0/stdlib/Lean/Elab/Tactic/Generalize.c
View file

@ -21,7 +21,7 @@ lean_object* l_Lean_Meta_introN(lean_object*, lean_object*, lean_object*, uint8_
lean_object* l___private_Lean_Elab_Tactic_Generalize_1__getAuxHypothesisName___boxed(lean_object*);
lean_object* l_Lean_Syntax_getIdAt(lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_evalGeneralizeAux___lambda__1___boxed(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_liftMetaM___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_liftMetaM___rarg(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Meta_getMVarTag(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_restore(lean_object*, lean_object*);
lean_object* l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
@ -32,7 +32,7 @@ lean_object* l___private_Lean_Elab_Tactic_Generalize_3__evalGeneralizeFinalize(l
lean_object* l_Lean_KeyedDeclsAttribute_addBuiltin___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq___lambda__1___closed__4;
extern lean_object* l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
lean_object* l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_2__getVarName___boxed(lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq___lambda__1___boxed(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq___lambda__1___closed__1;
@ -40,11 +40,12 @@ lean_object* l_Lean_Meta_getMVarType(lean_object*, lean_object*, lean_object*);
lean_object* l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Meta_generalize(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_evalGeneralizeAux___lambda__1(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_getMainGoal(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_getMainGoal(lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_evalGeneralize___boxed(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_evalGeneralize(lean_object*, lean_object*, lean_object*);
extern lean_object* l_Lean_Elab_Tactic_tacticElabAttribute;
extern lean_object* l_Lean_Meta_mkEqRefl___closed__2;
lean_object* l_Lean_Elab_Tactic_evalGeneralizeAux(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_evalGeneralizeAux(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Meta_assignExprMVar(lean_object*, lean_object*, lean_object*, lean_object*);
extern lean_object* l_Lean_Meta_assertExt___lambda__1___closed__1;
lean_object* l_Lean_Meta_mkFreshExprMVar(lean_object*, lean_object*, uint8_t, lean_object*, lean_object*);
@ -59,7 +60,7 @@ lean_object* l_Lean_Meta_inferType(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Meta_intro1(lean_object*, uint8_t, lean_object*, lean_object*);
lean_object* l_Lean_Meta_getMVarDecl(lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq___lambda__1(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Syntax_getArg(lean_object*, lean_object*);
lean_object* l___regBuiltin_Lean_Elab_Tactic_evalGeneralize___closed__1;
extern lean_object* l_Lean_Parser_Tactic_generalize___elambda__1___closed__1;
@ -618,81 +619,78 @@ return x_57;
}
}
}
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq(lean_object* x_1, lean_object* x_2, lean_object* x_3, lean_object* x_4, lean_object* x_5, lean_object* x_6) {
lean_object* l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq(lean_object* x_1, lean_object* x_2, lean_object* x_3, lean_object* x_4, lean_object* x_5) {
_start:
{
lean_object* x_7;
lean_inc(x_5);
lean_inc(x_1);
x_7 = l_Lean_Elab_Tactic_getMainGoal(x_1, x_5, x_6);
if (lean_obj_tag(x_7) == 0)
{
lean_object* x_8; lean_object* x_9; lean_object* x_10; lean_object* x_11; lean_object* x_12; lean_object* x_13; lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17; lean_object* x_18; lean_object* x_19; lean_object* x_20;
x_8 = lean_ctor_get(x_7, 0);
lean_inc(x_8);
x_9 = lean_ctor_get(x_7, 1);
lean_inc(x_9);
lean_dec(x_7);
x_10 = lean_ctor_get(x_8, 0);
lean_inc(x_10);
x_11 = lean_ctor_get(x_8, 1);
lean_inc(x_11);
lean_dec(x_8);
lean_object* x_6;
lean_inc(x_4);
lean_inc(x_3);
x_6 = l_Lean_Elab_Tactic_getMainGoal(x_4, x_5);
if (lean_obj_tag(x_6) == 0)
{
lean_object* x_7; lean_object* x_8; lean_object* x_9; lean_object* x_10; lean_object* x_11; lean_object* x_12; lean_object* x_13; lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17; lean_object* x_18; lean_object* x_19;
x_7 = lean_ctor_get(x_6, 0);
lean_inc(x_7);
x_8 = lean_ctor_get(x_6, 1);
lean_inc(x_8);
lean_dec(x_6);
x_9 = lean_ctor_get(x_7, 0);
lean_inc(x_9);
x_10 = lean_ctor_get(x_7, 1);
lean_inc(x_10);
x_12 = lean_alloc_closure((void*)(l_Lean_Meta_generalize___boxed), 5, 3);
lean_closure_set(x_12, 0, x_10);
lean_closure_set(x_12, 1, x_3);
lean_closure_set(x_12, 2, x_4);
x_13 = lean_alloc_closure((void*)(l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq___lambda__1___boxed), 6, 3);
lean_closure_set(x_13, 0, x_3);
lean_closure_set(x_13, 1, x_2);
lean_closure_set(x_13, 2, x_4);
x_14 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_14, 0, x_12);
lean_closure_set(x_14, 1, x_13);
x_15 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_16 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_16, 0, x_14);
lean_closure_set(x_16, 1, x_15);
x_17 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 4, 2);
lean_closure_set(x_17, 0, x_1);
lean_closure_set(x_17, 1, x_16);
x_18 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaTacticAux___rarg___lambda__1___boxed), 4, 1);
lean_closure_set(x_18, 0, x_11);
x_19 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_19, 0, x_17);
lean_closure_set(x_19, 1, x_18);
x_20 = l_Lean_Elab_Tactic_withMVarContext___rarg(x_10, x_19, x_5, x_9);
lean_dec(x_10);
return x_20;
lean_dec(x_7);
lean_inc(x_3);
lean_inc(x_2);
lean_inc(x_9);
x_11 = lean_alloc_closure((void*)(l_Lean_Meta_generalize___boxed), 5, 3);
lean_closure_set(x_11, 0, x_9);
lean_closure_set(x_11, 1, x_2);
lean_closure_set(x_11, 2, x_3);
x_12 = lean_alloc_closure((void*)(l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq___lambda__1___boxed), 6, 3);
lean_closure_set(x_12, 0, x_2);
lean_closure_set(x_12, 1, x_1);
lean_closure_set(x_12, 2, x_3);
x_13 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_13, 0, x_11);
lean_closure_set(x_13, 1, x_12);
x_14 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_15 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_15, 0, x_13);
lean_closure_set(x_15, 1, x_14);
x_16 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 3, 1);
lean_closure_set(x_16, 0, x_15);
x_17 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaTacticAux___rarg___lambda__1___boxed), 4, 1);
lean_closure_set(x_17, 0, x_10);
x_18 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_18, 0, x_16);
lean_closure_set(x_18, 1, x_17);
x_19 = l_Lean_Elab_Tactic_withMVarContext___rarg(x_9, x_18, x_4, x_8);
lean_dec(x_9);
return x_19;
}
else
{
uint8_t x_21;
lean_dec(x_5);
uint8_t x_20;
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_2);
lean_dec(x_1);
x_21 = !lean_is_exclusive(x_7);
if (x_21 == 0)
x_20 = !lean_is_exclusive(x_6);
if (x_20 == 0)
{
return x_7;
return x_6;
}
else
{
lean_object* x_22; lean_object* x_23; lean_object* x_24;
x_22 = lean_ctor_get(x_7, 0);
x_23 = lean_ctor_get(x_7, 1);
lean_inc(x_23);
lean_object* x_21; lean_object* x_22; lean_object* x_23;
x_21 = lean_ctor_get(x_6, 0);
x_22 = lean_ctor_get(x_6, 1);
lean_inc(x_22);
lean_dec(x_7);
x_24 = lean_alloc_ctor(1, 2, 0);
lean_ctor_set(x_24, 0, x_22);
lean_ctor_set(x_24, 1, x_23);
return x_24;
lean_inc(x_21);
lean_dec(x_6);
x_23 = lean_alloc_ctor(1, 2, 0);
lean_ctor_set(x_23, 0, x_21);
lean_ctor_set(x_23, 1, x_22);
return x_23;
}
}
}
@ -804,79 +802,76 @@ return x_31;
}
}
}
lean_object* l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback(lean_object* x_1, lean_object* x_2, lean_object* x_3, lean_object* x_4, lean_object* x_5, lean_object* x_6) {
lean_object* l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback(lean_object* x_1, lean_object* x_2, lean_object* x_3, lean_object* x_4, lean_object* x_5) {
_start:
{
lean_object* x_7;
lean_inc(x_5);
lean_inc(x_1);
x_7 = l_Lean_Elab_Tactic_getMainGoal(x_1, x_5, x_6);
if (lean_obj_tag(x_7) == 0)
lean_object* x_6;
lean_inc(x_4);
x_6 = l_Lean_Elab_Tactic_getMainGoal(x_4, x_5);
if (lean_obj_tag(x_6) == 0)
{
lean_object* x_8; lean_object* x_9; lean_object* x_10; lean_object* x_11; lean_object* x_12; lean_object* x_13; lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17; lean_object* x_18; lean_object* x_19; lean_object* x_20;
x_8 = lean_ctor_get(x_7, 0);
lean_object* x_7; lean_object* x_8; lean_object* x_9; lean_object* x_10; lean_object* x_11; lean_object* x_12; lean_object* x_13; lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17; lean_object* x_18; lean_object* x_19;
x_7 = lean_ctor_get(x_6, 0);
lean_inc(x_7);
x_8 = lean_ctor_get(x_6, 1);
lean_inc(x_8);
x_9 = lean_ctor_get(x_7, 1);
lean_dec(x_6);
x_9 = lean_ctor_get(x_7, 0);
lean_inc(x_9);
x_10 = lean_ctor_get(x_7, 1);
lean_inc(x_10);
lean_dec(x_7);
x_10 = lean_ctor_get(x_8, 0);
lean_inc(x_10);
x_11 = lean_ctor_get(x_8, 1);
lean_inc(x_11);
lean_dec(x_8);
lean_inc(x_3);
x_12 = lean_alloc_closure((void*)(l_Lean_Meta_inferType), 3, 1);
lean_closure_set(x_12, 0, x_3);
lean_inc(x_10);
x_13 = lean_alloc_closure((void*)(l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback___lambda__1___boxed), 7, 4);
lean_closure_set(x_13, 0, x_10);
lean_closure_set(x_13, 1, x_3);
lean_closure_set(x_13, 2, x_2);
lean_closure_set(x_13, 3, x_4);
x_14 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_14, 0, x_12);
lean_closure_set(x_14, 1, x_13);
x_15 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_16 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_16, 0, x_14);
lean_closure_set(x_16, 1, x_15);
x_17 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 4, 2);
lean_closure_set(x_17, 0, x_1);
lean_closure_set(x_17, 1, x_16);
x_18 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaTacticAux___rarg___lambda__1___boxed), 4, 1);
lean_closure_set(x_18, 0, x_11);
x_19 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_19, 0, x_17);
lean_closure_set(x_19, 1, x_18);
x_20 = l_Lean_Elab_Tactic_withMVarContext___rarg(x_10, x_19, x_5, x_9);
lean_dec(x_10);
return x_20;
lean_inc(x_2);
x_11 = lean_alloc_closure((void*)(l_Lean_Meta_inferType), 3, 1);
lean_closure_set(x_11, 0, x_2);
lean_inc(x_9);
x_12 = lean_alloc_closure((void*)(l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback___lambda__1___boxed), 7, 4);
lean_closure_set(x_12, 0, x_9);
lean_closure_set(x_12, 1, x_2);
lean_closure_set(x_12, 2, x_1);
lean_closure_set(x_12, 3, x_3);
x_13 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_13, 0, x_11);
lean_closure_set(x_13, 1, x_12);
x_14 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_15 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_15, 0, x_13);
lean_closure_set(x_15, 1, x_14);
x_16 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 3, 1);
lean_closure_set(x_16, 0, x_15);
x_17 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaTacticAux___rarg___lambda__1___boxed), 4, 1);
lean_closure_set(x_17, 0, x_10);
x_18 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_18, 0, x_16);
lean_closure_set(x_18, 1, x_17);
x_19 = l_Lean_Elab_Tactic_withMVarContext___rarg(x_9, x_18, x_4, x_8);
lean_dec(x_9);
return x_19;
}
else
{
uint8_t x_21;
lean_dec(x_5);
uint8_t x_20;
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_2);
lean_dec(x_1);
x_21 = !lean_is_exclusive(x_7);
if (x_21 == 0)
x_20 = !lean_is_exclusive(x_6);
if (x_20 == 0)
{
return x_7;
return x_6;
}
else
{
lean_object* x_22; lean_object* x_23; lean_object* x_24;
x_22 = lean_ctor_get(x_7, 0);
x_23 = lean_ctor_get(x_7, 1);
lean_inc(x_23);
lean_object* x_21; lean_object* x_22; lean_object* x_23;
x_21 = lean_ctor_get(x_6, 0);
x_22 = lean_ctor_get(x_6, 1);
lean_inc(x_22);
lean_dec(x_7);
x_24 = lean_alloc_ctor(1, 2, 0);
lean_ctor_set(x_24, 0, x_22);
lean_ctor_set(x_24, 1, x_23);
return x_24;
lean_inc(x_21);
lean_dec(x_6);
x_23 = lean_alloc_ctor(1, 2, 0);
lean_ctor_set(x_23, 0, x_21);
lean_ctor_set(x_23, 1, x_22);
return x_23;
}
}
}
@ -992,109 +987,104 @@ return x_29;
}
}
}
lean_object* l_Lean_Elab_Tactic_evalGeneralizeAux(lean_object* x_1, lean_object* x_2, lean_object* x_3, lean_object* x_4, lean_object* x_5, lean_object* x_6) {
lean_object* l_Lean_Elab_Tactic_evalGeneralizeAux(lean_object* x_1, lean_object* x_2, lean_object* x_3, lean_object* x_4, lean_object* x_5) {
_start:
{
if (lean_obj_tag(x_2) == 0)
if (lean_obj_tag(x_1) == 0)
{
lean_object* x_7;
lean_inc(x_5);
lean_inc(x_1);
x_7 = l_Lean_Elab_Tactic_getMainGoal(x_1, x_5, x_6);
if (lean_obj_tag(x_7) == 0)
lean_object* x_6;
lean_inc(x_4);
x_6 = l_Lean_Elab_Tactic_getMainGoal(x_4, x_5);
if (lean_obj_tag(x_6) == 0)
{
lean_object* x_8; lean_object* x_9; lean_object* x_10; lean_object* x_11; lean_object* x_12; lean_object* x_13; lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17; lean_object* x_18;
x_8 = lean_ctor_get(x_7, 0);
lean_object* x_7; lean_object* x_8; lean_object* x_9; lean_object* x_10; lean_object* x_11; lean_object* x_12; lean_object* x_13; lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17;
x_7 = lean_ctor_get(x_6, 0);
lean_inc(x_7);
x_8 = lean_ctor_get(x_6, 1);
lean_inc(x_8);
x_9 = lean_ctor_get(x_7, 1);
lean_dec(x_6);
x_9 = lean_ctor_get(x_7, 0);
lean_inc(x_9);
x_10 = lean_ctor_get(x_7, 1);
lean_inc(x_10);
lean_dec(x_7);
x_10 = lean_ctor_get(x_8, 0);
lean_inc(x_10);
x_11 = lean_ctor_get(x_8, 1);
lean_inc(x_11);
lean_dec(x_8);
lean_inc(x_10);
x_12 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_evalGeneralizeAux___lambda__1___boxed), 5, 3);
lean_closure_set(x_12, 0, x_10);
lean_closure_set(x_12, 1, x_3);
lean_closure_set(x_12, 2, x_4);
x_13 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_14 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_14, 0, x_12);
lean_closure_set(x_14, 1, x_13);
x_15 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 4, 2);
lean_closure_set(x_15, 0, x_1);
lean_closure_set(x_15, 1, x_14);
x_16 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaTacticAux___rarg___lambda__1___boxed), 4, 1);
lean_closure_set(x_16, 0, x_11);
x_17 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_17, 0, x_15);
lean_closure_set(x_17, 1, x_16);
x_18 = l_Lean_Elab_Tactic_withMVarContext___rarg(x_10, x_17, x_5, x_9);
lean_dec(x_10);
return x_18;
lean_inc(x_9);
x_11 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_evalGeneralizeAux___lambda__1___boxed), 5, 3);
lean_closure_set(x_11, 0, x_9);
lean_closure_set(x_11, 1, x_2);
lean_closure_set(x_11, 2, x_3);
x_12 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_13 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_13, 0, x_11);
lean_closure_set(x_13, 1, x_12);
x_14 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 3, 1);
lean_closure_set(x_14, 0, x_13);
x_15 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaTacticAux___rarg___lambda__1___boxed), 4, 1);
lean_closure_set(x_15, 0, x_10);
x_16 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_16, 0, x_14);
lean_closure_set(x_16, 1, x_15);
x_17 = l_Lean_Elab_Tactic_withMVarContext___rarg(x_9, x_16, x_4, x_8);
lean_dec(x_9);
return x_17;
}
else
{
uint8_t x_19;
lean_dec(x_5);
uint8_t x_18;
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_1);
x_19 = !lean_is_exclusive(x_7);
if (x_19 == 0)
{
return x_7;
}
else
{
lean_object* x_20; lean_object* x_21; lean_object* x_22;
x_20 = lean_ctor_get(x_7, 0);
x_21 = lean_ctor_get(x_7, 1);
lean_inc(x_21);
lean_inc(x_20);
lean_dec(x_7);
x_22 = lean_alloc_ctor(1, 2, 0);
lean_ctor_set(x_22, 0, x_20);
lean_ctor_set(x_22, 1, x_21);
return x_22;
}
}
}
else
{
lean_object* x_23; lean_object* x_24; lean_object* x_25;
x_23 = lean_ctor_get(x_2, 0);
lean_inc(x_23);
lean_dec(x_2);
x_24 = l_Lean_Elab_Tactic_save(x_6);
lean_inc(x_5);
x_18 = !lean_is_exclusive(x_6);
if (x_18 == 0)
{
return x_6;
}
else
{
lean_object* x_19; lean_object* x_20; lean_object* x_21;
x_19 = lean_ctor_get(x_6, 0);
x_20 = lean_ctor_get(x_6, 1);
lean_inc(x_20);
lean_inc(x_19);
lean_dec(x_6);
x_21 = lean_alloc_ctor(1, 2, 0);
lean_ctor_set(x_21, 0, x_19);
lean_ctor_set(x_21, 1, x_20);
return x_21;
}
}
}
else
{
lean_object* x_22; lean_object* x_23; lean_object* x_24;
x_22 = lean_ctor_get(x_1, 0);
lean_inc(x_22);
lean_dec(x_1);
x_23 = l_Lean_Elab_Tactic_save(x_5);
lean_inc(x_4);
lean_inc(x_3);
lean_inc(x_23);
lean_inc(x_1);
x_25 = l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq(x_1, x_23, x_3, x_4, x_5, x_6);
if (lean_obj_tag(x_25) == 0)
lean_inc(x_2);
lean_inc(x_22);
x_24 = l___private_Lean_Elab_Tactic_Generalize_4__evalGeneralizeWithEq(x_22, x_2, x_3, x_4, x_5);
if (lean_obj_tag(x_24) == 0)
{
lean_dec(x_24);
lean_dec(x_23);
lean_dec(x_5);
lean_dec(x_22);
lean_dec(x_4);
lean_dec(x_3);
lean_dec(x_1);
return x_25;
lean_dec(x_2);
return x_24;
}
else
{
lean_object* x_26; lean_object* x_27; lean_object* x_28;
x_26 = lean_ctor_get(x_25, 1);
lean_inc(x_26);
lean_dec(x_25);
x_27 = l_Lean_Elab_Tactic_restore(x_26, x_24);
lean_object* x_25; lean_object* x_26; lean_object* x_27;
x_25 = lean_ctor_get(x_24, 1);
lean_inc(x_25);
lean_dec(x_24);
x_28 = l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback(x_1, x_23, x_3, x_4, x_5, x_27);
return x_28;
x_26 = l_Lean_Elab_Tactic_restore(x_25, x_23);
lean_dec(x_23);
x_27 = l___private_Lean_Elab_Tactic_Generalize_5__evalGeneralizeFallback(x_22, x_2, x_3, x_4, x_26);
return x_27;
}
}
}
@ -1129,7 +1119,7 @@ lean_inc(x_12);
x_13 = lean_ctor_get(x_11, 1);
lean_inc(x_13);
lean_dec(x_11);
x_14 = l_Lean_Elab_Tactic_evalGeneralizeAux(x_1, x_4, x_12, x_6, x_2, x_13);
x_14 = l_Lean_Elab_Tactic_evalGeneralizeAux(x_4, x_12, x_6, x_2, x_13);
return x_14;
}
else
@ -1138,7 +1128,6 @@ uint8_t x_15;
lean_dec(x_6);
lean_dec(x_4);
lean_dec(x_2);
lean_dec(x_1);
x_15 = !lean_is_exclusive(x_11);
if (x_15 == 0)
{
@ -1160,11 +1149,20 @@ return x_18;
}
}
}
lean_object* l_Lean_Elab_Tactic_evalGeneralize___boxed(lean_object* x_1, lean_object* x_2, lean_object* x_3) {
_start:
{
lean_object* x_4;
x_4 = l_Lean_Elab_Tactic_evalGeneralize(x_1, x_2, x_3);
lean_dec(x_1);
return x_4;
}
}
lean_object* _init_l___regBuiltin_Lean_Elab_Tactic_evalGeneralize___closed__1() {
_start:
{
lean_object* x_1;
x_1 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_evalGeneralize), 3, 0);
x_1 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_evalGeneralize___boxed), 3, 0);
return x_1;
}
}

13816
stage0/stdlib/Lean/Elab/Tactic/Induction.c
View file

File diff suppressed because it is too large Load diff

31
stage0/stdlib/Lean/Elab/Tactic/Injection.c
View file

@ -16,7 +16,7 @@ extern "C" {
lean_object* l___private_Lean_Elab_Tactic_Injection_1__getInjectionNewIds___boxed(lean_object*);
lean_object* l___private_Lean_Elab_Tactic_Injection_2__checkUnusedIds___closed__3;
lean_object* l_Lean_Elab_Tactic_withMVarContext___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_liftMetaM___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_liftMetaM___rarg(lean_object*, lean_object*, lean_object*);
lean_object* l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_KeyedDeclsAttribute_addBuiltin___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
extern lean_object* l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
@ -25,7 +25,8 @@ lean_object* l___regBuiltin_Lean_Elab_Tactic_evalInjection(lean_object*);
lean_object* l_List_toString___at_Lean_Elab_OpenDecl_HasToString___spec__2(lean_object*);
lean_object* l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg(lean_object*, lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Syntax_getId(lean_object*);
lean_object* l_Lean_Elab_Tactic_getMainGoal(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_getMainGoal(lean_object*, lean_object*);
lean_object* l_Lean_Elab_Tactic_evalInjection___boxed(lean_object*, lean_object*, lean_object*);
extern lean_object* l_Lean_Elab_Tactic_tacticElabAttribute;
extern lean_object* l_Lean_Parser_Tactic_injection___elambda__1___closed__1;
lean_object* l_Lean_Meta_throwTacticEx___rarg(lean_object*, lean_object*, lean_object*, lean_object*, lean_object*, lean_object*);
@ -338,8 +339,7 @@ x_11 = l_Lean_Syntax_getArg(x_1, x_10);
x_12 = l___private_Lean_Elab_Tactic_Injection_1__getInjectionNewIds(x_11);
lean_dec(x_11);
lean_inc(x_2);
lean_inc(x_1);
x_13 = l_Lean_Elab_Tactic_getMainGoal(x_1, x_2, x_9);
x_13 = l_Lean_Elab_Tactic_getMainGoal(x_2, x_9);
if (lean_obj_tag(x_13) == 0)
{
lean_object* x_14; lean_object* x_15; lean_object* x_16; lean_object* x_17; uint8_t x_18; lean_object* x_19; lean_object* x_20;
@ -379,9 +379,8 @@ x_25 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_26 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_26, 0, x_24);
lean_closure_set(x_26, 1, x_25);
x_27 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 4, 2);
lean_closure_set(x_27, 0, x_1);
lean_closure_set(x_27, 1, x_26);
x_27 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 3, 1);
lean_closure_set(x_27, 0, x_26);
x_28 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_28, 0, x_27);
lean_closure_set(x_28, 1, x_20);
@ -407,9 +406,8 @@ x_34 = l_Lean_Elab_Tactic_liftMetaTactic___closed__1;
x_35 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Meta_isClassExpensive___main___spec__4___rarg), 4, 2);
lean_closure_set(x_35, 0, x_33);
lean_closure_set(x_35, 1, x_34);
x_36 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 4, 2);
lean_closure_set(x_36, 0, x_1);
lean_closure_set(x_36, 1, x_35);
x_36 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_liftMetaM___rarg), 3, 1);
lean_closure_set(x_36, 0, x_35);
x_37 = lean_alloc_closure((void*)(l_ReaderT_bind___at_Lean_Elab_Tactic_monadLog___spec__2___rarg), 4, 2);
lean_closure_set(x_37, 0, x_36);
lean_closure_set(x_37, 1, x_20);
@ -424,7 +422,6 @@ uint8_t x_39;
lean_dec(x_12);
lean_dec(x_8);
lean_dec(x_2);
lean_dec(x_1);
x_39 = !lean_is_exclusive(x_13);
if (x_39 == 0)
{
@ -449,7 +446,6 @@ else
{
uint8_t x_43;
lean_dec(x_2);
lean_dec(x_1);
x_43 = !lean_is_exclusive(x_7);
if (x_43 == 0)
{
@ -480,11 +476,20 @@ lean_dec(x_4);
return x_6;
}
}
lean_object* l_Lean_Elab_Tactic_evalInjection___boxed(lean_object* x_1, lean_object* x_2, lean_object* x_3) {
_start:
{
lean_object* x_4;
x_4 = l_Lean_Elab_Tactic_evalInjection(x_1, x_2, x_3);
lean_dec(x_1);
return x_4;
}
}
lean_object* _init_l___regBuiltin_Lean_Elab_Tactic_evalInjection___closed__1() {
_start:
{
lean_object* x_1;
x_1 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_evalInjection), 3, 0);
x_1 = lean_alloc_closure((void*)(l_Lean_Elab_Tactic_evalInjection___boxed), 3, 0);
return x_1;
}
}

27576
stage0/stdlib/Lean/Elab/Term.c
View file

File diff suppressed because it is too large Load diff

4
stage0/stdlib/Lean/Meta/EqnCompiler.c
View file

@ -14,13 +14,13 @@
extern "C" {
#endif
lean_object* l_Lean_registerTraceClass(lean_object*, lean_object*);
extern lean_object* l___private_Lean_Meta_EqnCompiler_DepElim_6__withMotive___rarg___closed__2;
extern lean_object* l___private_Lean_Meta_EqnCompiler_DepElim_9__withAltsAux___main___rarg___closed__2;
lean_object* l___private_Lean_Meta_EqnCompiler_1__regTraceClasses(lean_object*);
lean_object* l___private_Lean_Meta_EqnCompiler_1__regTraceClasses(lean_object* x_1) {
_start:
{
lean_object* x_2; lean_object* x_3;
x_2 = l___private_Lean_Meta_EqnCompiler_DepElim_6__withMotive___rarg___closed__2;
x_2 = l___private_Lean_Meta_EqnCompiler_DepElim_9__withAltsAux___main___rarg___closed__2;
x_3 = l_Lean_registerTraceClass(x_2, x_1);
return x_3;
}

2912
stage0/stdlib/Lean/Meta/EqnCompiler/DepElim.c
View file

File diff suppressed because it is too large Load diff

6
stage0/stdlib/Lean/Parser/Term.c
View file

@ -570,6 +570,7 @@ lean_object* l___regBuiltin_Lean_Parser_Term_nomatch_parenthesizer(lean_object*)
lean_object* l_Lean_Parser_Term_listLit___closed__2;
lean_object* l_Lean_Parser_Term_andthen_parenthesizer___closed__4;
lean_object* l_Lean_Parser_Term_band___elambda__1(lean_object*, lean_object*);
extern lean_object* l___private_Lean_Meta_EqnCompiler_DepElim_19__processNonVariable___closed__1;
lean_object* l_Lean_Parser_ParserState_mkTrailingNode(lean_object*, lean_object*, lean_object*);
lean_object* l_Lean_Parser_Term_seqRight___elambda__1___closed__2;
lean_object* l_Lean_Parser_Term_eq_parenthesizer(lean_object*, lean_object*, lean_object*, lean_object*);
@ -2298,7 +2299,6 @@ lean_object* l_Lean_Parser_Term_haveAssign_parenthesizer(lean_object*, lean_obje
lean_object* l_Lean_Parser_Term_doPat_parenthesizer___closed__3;
lean_object* l_Lean_Parser_Term_paren_parenthesizer___closed__5;
lean_object* l___private_Lean_Parser_Parser_2__sepByFnAux___main___at_Lean_Parser_Term_subst___elambda__1___spec__2(uint8_t, lean_object*, uint8_t, uint8_t, lean_object*, lean_object*);
extern lean_object* l___private_Lean_Meta_EqnCompiler_DepElim_20__processNonVariable___closed__1;
lean_object* l_Lean_Parser_Term_id___closed__7;
lean_object* l_Lean_Parser_Term_bracketedDoSeq___closed__6;
lean_object* l_Lean_Parser_Term_let___elambda__1___closed__9;
@ -38020,7 +38020,7 @@ _start:
{
lean_object* x_1; lean_object* x_2; lean_object* x_3;
x_1 = l_Lean_mkAppStx___closed__6;
x_2 = l___private_Lean_Meta_EqnCompiler_DepElim_20__processNonVariable___closed__1;
x_2 = l___private_Lean_Meta_EqnCompiler_DepElim_19__processNonVariable___closed__1;
x_3 = lean_name_mk_string(x_1, x_2);
return x_3;
}
@ -38039,7 +38039,7 @@ lean_object* _init_l_Lean_Parser_Term_match___elambda__1___closed__3() {
_start:
{
lean_object* x_1; lean_object* x_2; uint8_t x_3; lean_object* x_4;
x_1 = l___private_Lean_Meta_EqnCompiler_DepElim_20__processNonVariable___closed__1;
x_1 = l___private_Lean_Meta_EqnCompiler_DepElim_19__processNonVariable___closed__1;
x_2 = l_Lean_Parser_Term_match___elambda__1___closed__2;
x_3 = 1;
x_4 = l_Lean_Parser_mkAntiquot(x_1, x_2, x_3);