1f8d7561fa
As far as I can tell, the ability to pass a structure instance to a deriving handler is not actually used in practice. It didn't seem to be used in the test suite, at least. Do we want to remove this, or do we want to use and document it? This PR removes it, but that's not something I feel strongly about - but seeing if it breaks Mathlib is a useful data point.
277 lines
13 KiB
Text
277 lines
13 KiB
Text
/-
|
|
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
|
|
Released under Apache 2.0 license as described in the file LICENSE.
|
|
Authors: Kyle Miller
|
|
-/
|
|
prelude
|
|
import Lean.Util.CollectAxioms
|
|
import Lean.Elab.Deriving.Basic
|
|
import Lean.Elab.MutualDef
|
|
|
|
/-!
|
|
# Implementation of `#eval` command
|
|
-/
|
|
|
|
namespace Lean.Elab.Command
|
|
open Meta
|
|
|
|
register_builtin_option eval.pp : Bool := {
|
|
defValue := true
|
|
descr := "('#eval' command) enables using 'ToExpr' instances to pretty print the result, \
|
|
otherwise uses 'Repr' or 'ToString' instances"
|
|
}
|
|
|
|
register_builtin_option eval.type : Bool := {
|
|
defValue := false -- TODO: set to 'true'
|
|
descr := "('#eval' command) enables pretty printing the type of the result"
|
|
}
|
|
|
|
register_builtin_option eval.derive.repr : Bool := {
|
|
defValue := true
|
|
descr := "('#eval' command) enables auto-deriving 'Repr' instances as a fallback"
|
|
}
|
|
|
|
builtin_initialize
|
|
registerTraceClass `Elab.eval
|
|
|
|
/--
|
|
Elaborates the term, ensuring the result has no expression metavariables.
|
|
If there would be unsolved-for metavariables, tries hinting that the resulting type
|
|
is a monadic value with the `CommandElabM`, `TermElabM`, or `IO` monads.
|
|
Throws errors if the term is a proof or a type, but lifts props to `Bool` using `mkDecide`.
|
|
-/
|
|
private def elabTermForEval (term : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
|
|
let ty ← expectedType?.getDM mkFreshTypeMVar
|
|
let e ← Term.elabTermEnsuringType term ty
|
|
synthesizeWithHinting ty
|
|
let e ← instantiateMVars e
|
|
if (← Term.logUnassignedUsingErrorInfos (← getMVars e)) then throwAbortTerm
|
|
if ← isProof e then
|
|
throwError m!"cannot evaluate, proofs are not computationally relevant"
|
|
let e ← if (← isProp e) then mkDecide e else pure e
|
|
if ← isType e then
|
|
throwError m!"cannot evaluate, types are not computationally relevant"
|
|
trace[Elab.eval] "elaborated term:{indentExpr e}"
|
|
return e
|
|
where
|
|
/-- Try different strategies to make `Term.synthesizeSyntheticMVarsNoPostponing` succeed. -/
|
|
synthesizeWithHinting (ty : Expr) : TermElabM Unit := do
|
|
Term.synthesizeSyntheticMVarsUsingDefault
|
|
let s ← saveState
|
|
try
|
|
Term.synthesizeSyntheticMVarsNoPostponing
|
|
catch ex =>
|
|
let exS ← saveState
|
|
-- Try hinting that `ty` is a monad application.
|
|
for m in #[``CommandElabM, ``TermElabM, ``IO] do
|
|
s.restore true
|
|
try
|
|
if ← isDefEq ty (← mkFreshMonadApp m) then
|
|
Term.synthesizeSyntheticMVarsNoPostponing
|
|
return
|
|
catch _ => pure ()
|
|
-- None of the hints worked, so throw the original error.
|
|
exS.restore true
|
|
throw ex
|
|
mkFreshMonadApp (n : Name) : MetaM Expr := do
|
|
let m ← mkConstWithFreshMVarLevels n
|
|
let (args, _, _) ← forallMetaBoundedTelescope (← inferType m) 1
|
|
return mkAppN m args
|
|
|
|
private def addAndCompileExprForEval (declName : Name) (value : Expr) (allowSorry := false) : TermElabM Unit := do
|
|
-- Use the `elabMutualDef` machinery to be able to support `let rec`.
|
|
-- Hack: since we are using the `TermElabM` version, we can insert the `value` as a metavariable via `exprToSyntax`.
|
|
-- An alternative design would be to make `elabTermForEval` into a term elaborator and elaborate the command all at once
|
|
-- with `unsafe def _eval := term_for_eval% $t`, which we did try, but unwanted error messages
|
|
-- such as "failed to infer definition type" can surface.
|
|
let defView := mkDefViewOfDef { isUnsafe := true }
|
|
(← `(Parser.Command.definition|
|
|
def $(mkIdent <| `_root_ ++ declName) := $(← Term.exprToSyntax value)))
|
|
Term.elabMutualDef #[] { header := "" } #[defView]
|
|
unless allowSorry do
|
|
let axioms ← collectAxioms declName
|
|
if axioms.contains ``sorryAx then
|
|
throwError "\
|
|
aborting evaluation since the expression depends on the 'sorry' axiom, \
|
|
which can lead to runtime instability and crashes.\n\n\
|
|
To attempt to evaluate anyway despite the risks, use the '#eval!' command."
|
|
|
|
/--
|
|
Try to make a `@projFn ty inst e` application, even if it takes unfolding the type `ty` of `e` to synthesize the instance `inst`.
|
|
-/
|
|
private partial def mkDeltaInstProj (inst projFn : Name) (e : Expr) (ty? : Option Expr := none) (tryReduce : Bool := true) : MetaM Expr := do
|
|
let ty ← ty?.getDM (inferType e)
|
|
if let .some inst ← trySynthInstance (← mkAppM inst #[ty]) then
|
|
mkAppOptM projFn #[ty, inst, e]
|
|
else
|
|
let ty ← whnfCore ty
|
|
let some ty ← unfoldDefinition? ty
|
|
| guard tryReduce
|
|
-- Reducing the type is a strategy `#eval` used before the refactor of #5627.
|
|
-- The test lean/run/hlistOverload.lean depends on it, so we preserve the behavior.
|
|
let ty ← reduce (skipTypes := false) ty
|
|
mkDeltaInstProj inst projFn e ty (tryReduce := false)
|
|
mkDeltaInstProj inst projFn e ty tryReduce
|
|
|
|
/-- Try to make a `toString e` application, even if it takes unfolding the type of `e` to find a `ToString` instance. -/
|
|
private def mkToString (e : Expr) (ty? : Option Expr := none) : MetaM Expr := do
|
|
mkDeltaInstProj ``ToString ``toString e ty?
|
|
|
|
/-- Try to make a `repr e` application, even if it takes unfolding the type of `e` to find a `Repr` instance. -/
|
|
private def mkRepr (e : Expr) (ty? : Option Expr := none) : MetaM Expr := do
|
|
mkDeltaInstProj ``Repr ``repr e ty?
|
|
|
|
/-- Try to make a `toExpr e` application, even if it takes unfolding the type of `e` to find a `ToExpr` instance. -/
|
|
private def mkToExpr (e : Expr) (ty? : Option Expr := none) : MetaM Expr := do
|
|
mkDeltaInstProj ``ToExpr ``toExpr e ty?
|
|
|
|
/--
|
|
Returns a representation of `e` using `Format`, or else fails.
|
|
If the `eval.derive.repr` option is true, then tries automatically deriving a `Repr` instance first.
|
|
Currently auto-derivation does not attempt to derive recursively.
|
|
-/
|
|
private def mkFormat (e : Expr) : MetaM Expr := do
|
|
mkRepr e <|> (do mkAppM ``Std.Format.text #[← mkToString e])
|
|
<|> do
|
|
if eval.derive.repr.get (← getOptions) then
|
|
if let .const name _ := (← whnf (← inferType e)).getAppFn then
|
|
try
|
|
trace[Elab.eval] "Attempting to derive a 'Repr' instance for '{.ofConstName name}'"
|
|
liftCommandElabM do applyDerivingHandlers ``Repr #[name]
|
|
resetSynthInstanceCache
|
|
return ← mkRepr e
|
|
catch ex =>
|
|
trace[Elab.eval] "Failed to use derived 'Repr' instance. Exception: {ex.toMessageData}"
|
|
throwError m!"could not synthesize a 'Repr' or 'ToString' instance for type{indentExpr (← inferType e)}"
|
|
|
|
/--
|
|
Returns a representation of `e` using `MessageData`, or else fails.
|
|
Tries `mkFormat` if a `ToExpr` instance can't be synthesized.
|
|
-/
|
|
private def mkMessageData (e : Expr) : MetaM Expr := do
|
|
(do guard <| eval.pp.get (← getOptions); mkAppM ``MessageData.ofExpr #[← mkToExpr e])
|
|
<|> (return mkApp (mkConst ``MessageData.ofFormat) (← mkFormat e))
|
|
<|> do throwError m!"could not synthesize a 'ToExpr', 'Repr', or 'ToString' instance for type{indentExpr (← inferType e)}"
|
|
|
|
private structure EvalAction where
|
|
eval : CommandElabM MessageData
|
|
/-- Whether to print the result of evaluation.
|
|
If `some`, the expression is what type to use for the type ascription when `pp.type` is true. -/
|
|
printVal : Option Expr
|
|
|
|
unsafe def elabEvalCoreUnsafe (bang : Bool) (tk term : Syntax) (expectedType? : Option Expr) : CommandElabM Unit := withRef tk do
|
|
let declName := `_eval
|
|
-- `t` is either `MessageData` or `Format`, and `mkT` is for synthesizing an expression that yields a `t`.
|
|
-- The `toMessageData` function adapts `t` to `MessageData`.
|
|
let mkAct {t : Type} [Inhabited t] (toMessageData : t → MessageData) (mkT : Expr → MetaM Expr) (e : Expr) : TermElabM EvalAction := do
|
|
-- Create a monadic action given the name of the monad `mc`, the monad `m` itself,
|
|
-- and an expression `e` to evaluate in this monad.
|
|
-- A trick here is that `mkMAct?` makes use of `MonadEval` instances are currently available in this stage,
|
|
-- and we do not need them to be available in the target environment.
|
|
let mkMAct? (mc : Name) (m : Type → Type) [Monad m] [MonadEvalT m CommandElabM] (e : Expr) : TermElabM (Option EvalAction) := do
|
|
let some e ← observing? (mkAppOptM ``MonadEvalT.monadEval #[none, mkConst mc, none, none, e])
|
|
| return none
|
|
let eType := e.appFn!.appArg!
|
|
if ← isDefEq eType (mkConst ``Unit) then
|
|
addAndCompileExprForEval declName e (allowSorry := bang)
|
|
let mf : m Unit ← evalConst (m Unit) declName
|
|
return some { eval := do MonadEvalT.monadEval mf; pure "", printVal := none }
|
|
else
|
|
let rf ← withLocalDeclD `x eType fun x => do mkLambdaFVars #[x] (← mkT x)
|
|
let r ← mkAppM ``Functor.map #[rf, e]
|
|
addAndCompileExprForEval declName r (allowSorry := bang)
|
|
let mf : m t ← evalConst (m t) declName
|
|
return some { eval := toMessageData <$> MonadEvalT.monadEval mf, printVal := some eType }
|
|
if let some act ← mkMAct? ``CommandElabM CommandElabM e
|
|
-- Fallbacks in case we are in the Lean package but don't have `CommandElabM` yet
|
|
<||> mkMAct? ``TermElabM TermElabM e <||> mkMAct? ``MetaM MetaM e <||> mkMAct? ``CoreM CoreM e
|
|
-- Fallback in case nothing is imported
|
|
<||> mkMAct? ``IO IO e then
|
|
return act
|
|
else
|
|
-- Otherwise, assume this is a pure value.
|
|
-- There is no need to adapt pure values to `CommandElabM`.
|
|
-- This enables `#eval` to work on pure values even when `CommandElabM` is not available.
|
|
let r ← try mkT e catch ex => do
|
|
-- Diagnose whether the value is monadic for a representable value, since it's better to mention `MonadEval` in that case.
|
|
try
|
|
let some (m, ty) ← isTypeApp? (← inferType e) | failure
|
|
guard <| (← isMonad? m).isSome
|
|
-- Verify that there is a way to form some representation:
|
|
discard <| withLocalDeclD `x ty fun x => mkT x
|
|
catch _ =>
|
|
throw ex
|
|
throwError m!"unable to synthesize '{.ofConstName ``MonadEval}' instance \
|
|
to adapt{indentExpr (← inferType e)}\n\
|
|
to '{.ofConstName ``IO}' or '{.ofConstName ``CommandElabM}'."
|
|
addAndCompileExprForEval declName r (allowSorry := bang)
|
|
-- `evalConst` may emit IO, but this is collected by `withIsolatedStreams` below.
|
|
let r ← toMessageData <$> evalConst t declName
|
|
return { eval := pure r, printVal := some (← inferType e) }
|
|
let (output, exOrRes) ← IO.FS.withIsolatedStreams do
|
|
try
|
|
-- Generate an action without executing it. We use `withoutModifyingEnv` to ensure
|
|
-- we don't pollute the environment with auxiliary declarations.
|
|
let act : EvalAction ← liftTermElabM do Term.withDeclName declName do withoutModifyingEnv do
|
|
let e ← elabTermForEval term expectedType?
|
|
-- If there is an elaboration error, don't evaluate!
|
|
if e.hasSyntheticSorry then throwAbortTerm
|
|
-- We want `#eval` to work even in the core library, so if `ofFormat` isn't available,
|
|
-- we fall back on a `Format`-based approach.
|
|
if (← getEnv).contains ``Lean.MessageData.ofFormat then
|
|
mkAct id (mkMessageData ·) e
|
|
else
|
|
mkAct Lean.MessageData.ofFormat (mkFormat ·) e
|
|
let res ← act.eval
|
|
return Sum.inr (res, act.printVal)
|
|
catch ex =>
|
|
return Sum.inl ex
|
|
if !output.isEmpty then logInfoAt tk output
|
|
match exOrRes with
|
|
| .inl ex => logException ex
|
|
| .inr (_, none) => pure ()
|
|
| .inr (res, some type) =>
|
|
if eval.type.get (← getOptions) then
|
|
logInfo m!"{res} : {type}"
|
|
else
|
|
logInfo res
|
|
|
|
@[implemented_by elabEvalCoreUnsafe]
|
|
opaque elabEvalCore (bang : Bool) (tk term : Syntax) (expectedType? : Option Expr) : CommandElabM Unit
|
|
|
|
@[builtin_command_elab «eval»]
|
|
def elabEval : CommandElab
|
|
| `(#eval%$tk $term) => elabEvalCore false tk term none
|
|
| _ => throwUnsupportedSyntax
|
|
|
|
@[builtin_command_elab evalBang]
|
|
def elabEvalBang : CommandElab
|
|
| `(#eval!%$tk $term) => elabEvalCore true tk term none
|
|
| _ => throwUnsupportedSyntax
|
|
|
|
@[builtin_command_elab runCmd]
|
|
def elabRunCmd : CommandElab
|
|
| `(run_cmd%$tk $elems:doSeq) => do
|
|
unless (← getEnv).contains ``CommandElabM do
|
|
throwError "to use this command, include `import Lean.Elab.Command`"
|
|
elabEvalCore false tk (← `(discard do $elems)) (mkApp (mkConst ``CommandElabM) (mkConst ``Unit))
|
|
| _ => throwUnsupportedSyntax
|
|
|
|
@[builtin_command_elab runElab]
|
|
def elabRunElab : CommandElab
|
|
| `(run_elab%$tk $elems:doSeq) => do
|
|
unless (← getEnv).contains ``TermElabM do
|
|
throwError "to use this command, include `import Lean.Elab.Term`"
|
|
elabEvalCore false tk (← `(discard do $elems)) (mkApp (mkConst ``TermElabM) (mkConst ``Unit))
|
|
| _ => throwUnsupportedSyntax
|
|
|
|
@[builtin_command_elab runMeta]
|
|
def elabRunMeta : CommandElab := fun stx =>
|
|
match stx with
|
|
| `(run_meta%$tk $elems:doSeq) => do
|
|
unless (← getEnv).contains ``MetaM do
|
|
throwError "to use this command, include `import Lean.Meta.Basic`"
|
|
elabEvalCore false tk (← `(discard do $elems)) (mkApp (mkConst ``MetaM) (mkConst ``Unit))
|
|
| _ => throwUnsupportedSyntax
|
|
|
|
end Lean.Elab.Command
|