feat: elabDefLike

src/Init/Lean/Elab/Definition.lean

@@ -4,16 +4,31 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura, Sebastian Ullrich
 -/
 prelude
+import Init.Lean.Util.CollectLevelParams
+import Init.Lean.Util.CollectFVars
 import Init.Lean.Elab.DeclModifiers
+import Init.Lean.Elab.TermBinders
 
 namespace Lean
 namespace Elab
-
 namespace Command
 
 inductive DefKind
 | «def» | «theorem» | «example» | «opaque»
 
+def DefKind.isTheorem : DefKind → Bool
+| DefKind.theorem => true
+| _               => false
+
+def DefKind.isDefOrOpaque : DefKind → Bool
+| DefKind.def    => true
+| DefKind.opaque => true
+| _              => false
+
+def DefKind.isExample : DefKind → Bool
+| DefKind.example => true
+| _               => false
+
 structure DefView :=
 (kind          : DefKind)
 (ref           : Syntax)
@@ -23,24 +38,116 @@ structure DefView :=
 (type?         : Option Syntax)
 (val           : Syntax)
 
+def collectUsedFVars (ref : Syntax) (used : CollectFVars.State) (e : Expr) : TermElabM CollectFVars.State := do
+e ← Term.instantiateMVars ref e;
+pure $ collectFVars used e
+
+def collectUsedFVarsAtFVars (ref : Syntax) (used : CollectFVars.State) (fvars : Array Expr) : TermElabM CollectFVars.State :=
+fvars.foldlM
+  (fun used fvar => do
+    fvarType ← Term.inferType ref fvar;
+    collectUsedFVars ref used fvarType)
+  used
+
+def removeUnused (ref : Syntax) (vars : Array Expr) (xs : Array Expr) (e : Expr) (eType : Expr)
+    : TermElabM (LocalContext × LocalInstances × Array Expr) := do
+let used : CollectFVars.State := {};
+used ← collectUsedFVars ref used eType;
+used ← collectUsedFVars ref used e;
+used ← collectUsedFVarsAtFVars ref used xs;
+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 ← collectUsedFVars ref used varType;
+      pure (lctx, localInsts, newVars.push var, used)
+    else
+      pure (lctx.erase var.fvarId!, localInsts.erase var.fvarId!, newVars, used))
+  (lctx, localInsts, #[], used);
+pure (lctx, localInsts, newVars.reverse)
+
+def withUsedWhen {α} (ref : Syntax) (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;
+ Term.withLCtx lctx localInsts $ k vars
+else
+ k vars
+
+def withUsedWhen' {α} (ref : Syntax) (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
+
+def mkDef (view : DefView) (declName : Name) (explictLevelNames : List Name) (vars : Array Expr) (xs : Array Expr) (type : Expr) (val : Expr)
+    : TermElabM (Option Declaration) := do
+let ref := view.ref;
+Term.synthesizeSyntheticMVars false;
+type    ← Term.instantiateMVars ref type;
+val     ← Term.instantiateMVars view.val val;
+valType ← Term.inferType view.val val;
+val     ← Term.ensureHasType ref type valType val;
+if view.kind.isExample then pure none
+else withUsedWhen ref vars xs val type view.kind.isDefOrOpaque $ 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;
+  let usedParams : CollectLevelParams.State := {};
+  let usedParams  := collectLevelParams usedParams type;
+  let usedParams  := collectLevelParams usedParams val;
+  let levelParams := sortDeclLevelParams explictLevelNames usedParams.params;
+  match view.kind with
+  | DefKind.theorem =>
+    -- TODO theorem elaboration in parallel
+    pure $ some $ Declaration.thmDecl { name := declName, lparams := levelParams, type := type, value := Task.pure val }
+  | DefKind.opaque  =>
+    pure $ some $ Declaration.opaqueDecl { name := declName, lparams := levelParams, type := type, value := val, isUnsafe := view.modifiers.isUnsafe }
+  | DefKind.def =>
+    pure $ some $ Declaration.defnDecl {
+      name := declName, lparams := levelParams, type := type, value := val,
+      hints := ReducibilityHints.regular 0, -- TODO
+      isUnsafe := view.modifiers.isUnsafe }
+  | _ => unreachable!
+
+def elabDefVal (defVal : Syntax) (expectedType : Expr) : TermElabM Expr := do
+let kind := defVal.getKind;
+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"
+else
+  Term.throwUnexpectedSyntax defVal "definition body"
+
 def elabDefLike (view : DefView) : CommandElabM Unit :=
+let ref := view.ref;
 withDeclId view.declId $ fun name => do
-  currNamespace ← getCurrNamespace;
-  runTermElabM $ fun vars => Term.elabBinders view.binders.getArgs $ fun xs =>
+  declName          ← mkDeclName view.modifiers name;
+  applyAttributes ref declName view.modifiers.attrs AttributeApplicationTime.beforeElaboration;
+  explictLevelNames ← getLevelNames;
+  decl? ← runTermElabM $ fun vars => Term.elabBinders view.binders.getArgs $ fun xs =>
     match view.type? with
     | some typeStx => do
-      type    ← Term.elabType typeStx;
+      type ← Term.elabType typeStx;
       Term.synthesizeSyntheticMVars false;
-      type    ← Term.instantiateMVars typeStx type;
-      defType ← Term.mkForall typeStx xs type;
-      -- TODO: unassigned universe metavariables to new parameters
-      -- TODO: if theorem, filter unused vars
-      Term.dbgTrace (">>> " ++ toString type);
-      pure ()
-    | none => do
+      type ← Term.instantiateMVars typeStx type;
+      withUsedWhen' ref vars xs type view.kind.isTheorem $ fun vars => do
+        val  ← elabDefVal view.val type;
+        mkDef view declName explictLevelNames vars xs type val
+    | none => do {
       type ← Term.mkFreshTypeMVar view.binders;
-
-      pure ()
+      val  ← elabDefVal view.val type;
+      mkDef view declName explictLevelNames vars xs type val
+    };
+  match decl? with
+  | none      => pure ()
+  | some decl => do
+    addDecl ref decl;
+    applyAttributes ref declName view.modifiers.attrs AttributeApplicationTime.afterTypeChecking;
+    -- TODO invoke compiler
+    applyAttributes ref declName view.modifiers.attrs AttributeApplicationTime.afterCompilation
 
 end Command
 end Elab

src/Init/Lean/MetavarContext.lean

@@ -234,6 +234,12 @@ i₁.fvar == i₂.fvar
 
 instance LocalInstance.hasBeq : HasBeq LocalInstance := ⟨LocalInstance.beq⟩
 
+/-- Remove local instance with the given `fvarId`. Do nothing if `localInsts` does not contain any free variable with id `fvarId`. -/
+def LocalInstances.erase (localInsts : LocalInstances) (fvarId : FVarId) : LocalInstances :=
+match localInsts.findIdx? (fun inst => inst.fvar.fvarId! == fvarId) with
+| some idx => localInsts.eraseIdx idx
+| _        => localInsts
+
 inductive MetavarKind
 | natural
 | synthetic

tests/lean/run/frontend1.lean

@@ -198,3 +198,5 @@ f a
 #eval run "#check HasToString.toString 0"
 #eval run "@[instance] axiom newInst : HasToString Nat #check newInst #check HasToString.toString 0"
 #eval run "variables {β σ} universes w1 w2 /-- Testing axiom -/ unsafe axiom Nat.aux.{u, v} (γ : Type w1) (v : Nat) : β → (α : Type _) → v = zero /- Nat.zero -/ → Array α #check @Nat.aux"
+#eval run "def x : Nat := Nat.zero #check x"
+#eval run "def x := Nat.zero #check x"