88b746dd48
This PR adjusts the results of `inferInstanceAs` and the `def` `deriving` handler to conform to recently strengthened restrictions on reducibility. This change ensures that when deriving or inferring an instance for a semireducible type definition, the definition's RHS is not leaked when the instance is reduced at lower than semireducible transparency. More specifically, given the "source type" and "target type" (the given and expected type for `inferInstanceAs`, the right-hand side and applied left-hand side of the `def` for `deriving`), we synthesize an instance for the source type and then unfold and rewrap its components (fields, nested instances) as necessary to make them compatible with the target type. The individual steps are represented by the following options, which all default to enabled and can be disabled to help with porting: - `backward.inferInstanceAs.wrap`: master switch for instance adjustment in both `inferInstanceAs` and the default `deriving` handler - `backward.inferInstanceAs.wrap.reuseSubInstances`: reuse existing instances for the target type for sub-instance fields to avoid non-defeq instance diamonds - `backward.inferInstanceAs.wrap.instances`: wrap non-reducible instances in auxiliary definitions - `backward.inferInstanceAs.wrap.data`: wrap data fields in auxiliary definitions (proof fields are always wrapped) This PR is an extension and rewrite of prior work in Mathlib: https://github.com/leanprover-community/mathlib4/pull/36420 Last(?) part of fix for #9077 🤖 Prepared with Claude Code # Breaking changes Proofs that relied on the prior "defeq abuse" of these instance or that depended on their specific structure may need adjustments. As `inferInstanceAs A` now needs to know the source and target types exactly before it can continue, it cannot be used anymore as a synonym for `(inferInstance : A)`, use the latter instead when source and target type are identical.
901 lines
38 KiB
Text
901 lines
38 KiB
Text
/-
|
||
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Leonardo de Moura, Gabriel Ebner
|
||
-/
|
||
module
|
||
|
||
prelude
|
||
public import Lean.Meta.Diagnostics
|
||
public import Lean.Elab.Binders
|
||
public import Lean.Elab.Command.Scope
|
||
public import Lean.Elab.SetOption
|
||
public meta import Lean.Parser.Command
|
||
|
||
public section
|
||
|
||
namespace Lean.Elab.Command
|
||
|
||
structure State where
|
||
env : Environment
|
||
messages : MessageLog := {}
|
||
scopes : List Scope := [{ header := "" }]
|
||
usedQuotCtxts : NameSet := {}
|
||
nextMacroScope : Nat := firstFrontendMacroScope + 1
|
||
maxRecDepth : Nat
|
||
ngen : NameGenerator := {}
|
||
auxDeclNGen : DeclNameGenerator := .ofPrefix .anonymous
|
||
infoState : InfoState := {}
|
||
traceState : TraceState := {}
|
||
snapshotTasks : Array (Language.SnapshotTask Language.SnapshotTree) := #[]
|
||
deriving Nonempty
|
||
|
||
structure Context where
|
||
fileName : String
|
||
fileMap : FileMap
|
||
currRecDepth : Nat := 0
|
||
cmdPos : String.Pos.Raw := 0
|
||
macroStack : MacroStack := []
|
||
quotContext? : Option Name := none
|
||
currMacroScope : MacroScope := firstFrontendMacroScope
|
||
ref : Syntax := Syntax.missing
|
||
/--
|
||
Snapshot for incremental reuse and reporting of command elaboration. Currently only used for
|
||
(mutual) defs and contained tactics, in which case the `DynamicSnapshot` is a
|
||
`HeadersParsedSnapshot`.
|
||
|
||
Definitely resolved in `Lean.Elab.Command.elabCommandTopLevel`.
|
||
|
||
Invariant: if the bundle's `old?` is set, the context and state at the beginning of current and
|
||
old elaboration are identical.
|
||
-/
|
||
snap? : Option (Language.SnapshotBundle Language.DynamicSnapshot)
|
||
/-- Cancellation token forwarded to `Core.cancelTk?`. -/
|
||
cancelTk? : Option IO.CancelToken
|
||
/--
|
||
If set (when `showPartialSyntaxErrors` is not set and parsing failed), suppresses most elaboration
|
||
errors; see also `logMessage` below.
|
||
-/
|
||
suppressElabErrors : Bool := false
|
||
|
||
abbrev CommandElabM := ReaderT Context $ StateRefT State $ EIO Exception
|
||
abbrev CommandElab := Syntax → CommandElabM Unit
|
||
structure Linter where
|
||
run : Syntax → CommandElabM Unit
|
||
name : Name := by exact decl_name%
|
||
|
||
/-
|
||
Make the compiler generate specialized `pure`/`bind` so we do not have to optimize through the
|
||
whole monad stack at every use site. May eventually be covered by `deriving`.
|
||
|
||
Remark: see comment at TermElabM
|
||
-/
|
||
@[always_inline]
|
||
instance : Monad CommandElabM := let i : Monad CommandElabM := inferInstance; { pure := i.pure, bind := i.bind }
|
||
|
||
/--
|
||
Like `Core.tryCatchRuntimeEx`; runtime errors are generally used to abort term elaboration, so we do
|
||
want to catch and process them at the command level.
|
||
-/
|
||
@[inline] protected def tryCatch (x : CommandElabM α) (h : Exception → CommandElabM α) :
|
||
CommandElabM α := do
|
||
try
|
||
x
|
||
catch ex =>
|
||
if ex.isInterrupt then
|
||
throw ex
|
||
else
|
||
h ex
|
||
|
||
instance : MonadExceptOf Exception CommandElabM where
|
||
throw := throw
|
||
tryCatch := Command.tryCatch
|
||
|
||
def mkState (env : Environment) (messages : MessageLog := {}) (opts : Options := {}) : State := {
|
||
env := env
|
||
messages := messages
|
||
scopes := [{ header := "", opts }]
|
||
maxRecDepth := maxRecDepth.get opts
|
||
-- Outside of declarations, fall back to a module-specific prefix
|
||
auxDeclNGen := .ofPrefix <| mkPrivateName env .anonymous
|
||
}
|
||
|
||
/- Linters should be loadable as plugins, so store in a global IO ref instead of an attribute managed by the
|
||
environment (which only contains `import`ed objects). -/
|
||
builtin_initialize lintersRef : IO.Ref (Array Linter) ← IO.mkRef #[]
|
||
builtin_initialize registerTraceClass `Elab.lint
|
||
|
||
def addLinter (l : Linter) : IO Unit := do
|
||
let ls ← lintersRef.get
|
||
lintersRef.set (ls.push l)
|
||
|
||
instance : MonadInfoTree CommandElabM where
|
||
getInfoState := return (← get).infoState
|
||
modifyInfoState f := modify fun s => { s with infoState := f s.infoState }
|
||
|
||
instance : MonadEnv CommandElabM where
|
||
getEnv := do pure (← get).env
|
||
modifyEnv f := modify fun s => { s with env := f s.env }
|
||
|
||
@[always_inline]
|
||
instance : MonadOptions CommandElabM where
|
||
getOptions := do pure (← get).scopes.head!.opts
|
||
|
||
protected def getRef : CommandElabM Syntax :=
|
||
return (← read).ref
|
||
|
||
instance : AddMessageContext CommandElabM where
|
||
addMessageContext := addMessageContextPartial
|
||
|
||
instance : MonadRef CommandElabM where
|
||
getRef := Command.getRef
|
||
withRef ref x := withReader (fun ctx => { ctx with ref := ref }) x
|
||
|
||
instance : MonadTrace CommandElabM where
|
||
getTraceState := return (← get).traceState
|
||
modifyTraceState f := modify fun s => { s with traceState := f s.traceState }
|
||
|
||
instance : AddErrorMessageContext CommandElabM where
|
||
add ref msg := do
|
||
let ctx ← read
|
||
let ref := getBetterRef ref ctx.macroStack
|
||
let msg ← addMessageContext msg
|
||
let msg ← addMacroStack msg ctx.macroStack
|
||
return (ref, msg)
|
||
|
||
instance : MonadDeclNameGenerator CommandElabM where
|
||
getDeclNGen := return (← get).auxDeclNGen
|
||
setDeclNGen ngen := modify fun s => { s with auxDeclNGen := ngen }
|
||
|
||
protected def getCurrMacroScope : CommandElabM Nat := do pure (← read).currMacroScope
|
||
protected def getMainModule : CommandElabM Name := do pure (← getEnv).mainModule
|
||
|
||
protected def withFreshMacroScope {α} (x : CommandElabM α) : CommandElabM α := do
|
||
let fresh ← modifyGet (fun st => (st.nextMacroScope, { st with nextMacroScope := st.nextMacroScope + 1 }))
|
||
withReader (fun ctx => { ctx with currMacroScope := fresh }) x
|
||
|
||
instance : MonadQuotation CommandElabM where
|
||
getCurrMacroScope := Command.getCurrMacroScope
|
||
getContext := do (← read).quotContext?.getDM getMainModule
|
||
withFreshMacroScope := Command.withFreshMacroScope
|
||
|
||
private def runCore (x : CoreM α) : CommandElabM α := do
|
||
let s ← get
|
||
let ctx ← read
|
||
let heartbeats ← IO.getNumHeartbeats
|
||
let env := Kernel.resetDiag s.env
|
||
let scope := s.scopes.head!
|
||
let coreCtx : Core.Context := {
|
||
fileName := ctx.fileName
|
||
fileMap := ctx.fileMap
|
||
currRecDepth := ctx.currRecDepth
|
||
maxRecDepth := s.maxRecDepth
|
||
ref := ctx.ref
|
||
currNamespace := scope.currNamespace
|
||
openDecls := scope.openDecls
|
||
initHeartbeats := heartbeats
|
||
quotContext := (← MonadQuotation.getMainModule)
|
||
currMacroScope := ctx.currMacroScope
|
||
options := scope.opts
|
||
cancelTk? := ctx.cancelTk?
|
||
suppressElabErrors := ctx.suppressElabErrors }
|
||
let x : EIO _ _ := x.run coreCtx {
|
||
env
|
||
ngen := s.ngen
|
||
auxDeclNGen := s.auxDeclNGen
|
||
nextMacroScope := s.nextMacroScope
|
||
infoState.enabled := s.infoState.enabled
|
||
-- accumulate lazy assignments from all `CoreM` lifts
|
||
infoState.lazyAssignment := s.infoState.lazyAssignment
|
||
traceState := s.traceState
|
||
snapshotTasks := s.snapshotTasks
|
||
}
|
||
let (ea, coreS) ← liftM x
|
||
modify fun s => { s with
|
||
env := coreS.env
|
||
nextMacroScope := coreS.nextMacroScope
|
||
ngen := coreS.ngen
|
||
auxDeclNGen := coreS.auxDeclNGen
|
||
infoState.trees := s.infoState.trees.append coreS.infoState.trees
|
||
-- we assume substitution of `assignment` has already happened, but for lazy assignments we only
|
||
-- do it at the very end
|
||
infoState.lazyAssignment := coreS.infoState.lazyAssignment
|
||
traceState.traces := coreS.traceState.traces.map fun t => { t with ref := replaceRef t.ref ctx.ref }
|
||
snapshotTasks := coreS.snapshotTasks
|
||
messages := s.messages ++ coreS.messages
|
||
}
|
||
return ea
|
||
|
||
def liftCoreM (x : CoreM α) : CommandElabM α := do
|
||
MonadExcept.ofExcept (← runCore (observing x))
|
||
|
||
@[inline] def liftIO {α} (x : IO α) : CommandElabM α := do
|
||
let ctx ← read
|
||
IO.toEIO (fun (ex : IO.Error) => Exception.error ctx.ref ex.toString) x
|
||
|
||
instance : MonadLiftT IO CommandElabM where
|
||
monadLift := liftIO
|
||
|
||
/-- Return the current scope. -/
|
||
def getScope : CommandElabM Scope := do pure (← get).scopes.head!
|
||
|
||
instance : MonadResolveName CommandElabM where
|
||
getCurrNamespace := return (← getScope).currNamespace
|
||
getOpenDecls := return (← getScope).openDecls
|
||
|
||
instance : MonadLog CommandElabM where
|
||
getRef := getRef
|
||
getFileMap := return (← read).fileMap
|
||
getFileName := return (← read).fileName
|
||
hasErrors := return (← get).messages.hasErrors
|
||
logMessage msg := do
|
||
if (← read).suppressElabErrors then
|
||
-- discard elaboration errors on parse error
|
||
unless msg.data.hasTag (· matches `trace) do
|
||
return
|
||
let currNamespace ← getCurrNamespace
|
||
let openDecls ← getOpenDecls
|
||
let msg := { msg with data := MessageData.withNamingContext { currNamespace := currNamespace, openDecls := openDecls } msg.data }
|
||
modify fun s => { s with messages := s.messages.add msg }
|
||
|
||
def runLinters (stx : Syntax) : CommandElabM Unit := do
|
||
profileitM Exception "linting" (← getOptions) do
|
||
withTraceNode `Elab.lint (fun _ => return m!"running linters") do
|
||
let linters ← lintersRef.get
|
||
unless linters.isEmpty do
|
||
for linter in linters do
|
||
withTraceNode `Elab.lint (fun _ => return m!"running linter: {.ofConstName linter.name}")
|
||
(tag := linter.name.toString) do
|
||
let savedState ← get
|
||
try
|
||
linter.run stx
|
||
catch ex =>
|
||
match ex with
|
||
| Exception.error ref msg =>
|
||
logException (.error ref m!"linter {.ofConstName linter.name} failed: {msg}")
|
||
| Exception.internal _ _ =>
|
||
logException ex
|
||
finally
|
||
-- TODO: it would be good to preserve even more state (#4363) but preserving info
|
||
-- trees currently breaks from linters adding context-less info nodes
|
||
modify fun s => { savedState with messages := s.messages, traceState := s.traceState }
|
||
|
||
/--
|
||
Catches and logs exceptions occurring in `x`. Unlike `try catch` in `CommandElabM`, this function
|
||
catches interrupt exceptions as well and thus is intended for use at the top level of elaboration.
|
||
Interrupt and abort exceptions are caught but not logged.
|
||
-/
|
||
@[inline] def withLoggingExceptions (x : CommandElabM Unit) : CommandElabM Unit := fun ctx ref =>
|
||
EIO.catchExceptions (withLogging x ctx ref) (fun _ => pure ())
|
||
|
||
@[inherit_doc Core.wrapAsync]
|
||
def wrapAsync {α β : Type} (act : α → CommandElabM β) (cancelTk? : Option IO.CancelToken) :
|
||
CommandElabM (α → EIO Exception β) := do
|
||
let ctx ← read
|
||
let ctx := { ctx with cancelTk? }
|
||
let (childNGen, parentNGen) := (← get).ngen.mkChild
|
||
modify fun s => { s with ngen := parentNGen }
|
||
let (childDeclNGen, parentDeclNGen) := (← getDeclNGen).mkChild
|
||
setDeclNGen parentDeclNGen
|
||
let st ← get
|
||
let st := { st with auxDeclNGen := childDeclNGen, ngen := childNGen }
|
||
return (act · |>.run ctx |>.run' st)
|
||
|
||
open Language in
|
||
@[inherit_doc Core.wrapAsyncAsSnapshot]
|
||
-- `CoreM` and `CommandElabM` are too different to meaningfully share this code
|
||
def wrapAsyncAsSnapshot {α : Type} (act : α → CommandElabM Unit) (cancelTk? : Option IO.CancelToken)
|
||
(desc : String := by exact decl_name%.toString) :
|
||
CommandElabM (α → BaseIO SnapshotTree) := do
|
||
let f ← wrapAsync (cancelTk? := cancelTk?) fun a => do
|
||
IO.FS.withIsolatedStreams (isolateStderr := Core.stderrAsMessages.get (← getOptions)) do
|
||
let tid ← IO.getTID
|
||
-- reset trace state and message log so as not to report them twice
|
||
modify fun st => { st with
|
||
messages := st.messages.markAllReported
|
||
traceState := { tid }
|
||
snapshotTasks := #[]
|
||
}
|
||
try
|
||
withTraceNode `Elab.async (fun _ => return desc) do
|
||
act a
|
||
catch e =>
|
||
logException e
|
||
finally
|
||
addTraceAsMessages
|
||
get
|
||
let ctx ← read
|
||
return fun a => do
|
||
match (← (f a).toBaseIO) with
|
||
| .ok (output, st) =>
|
||
let mut msgs := st.messages
|
||
if !output.isEmpty then
|
||
msgs := msgs.add {
|
||
fileName := ctx.fileName
|
||
severity := MessageSeverity.information
|
||
pos := ctx.fileMap.toPosition <| ctx.ref.getPos?.getD 0
|
||
data := output
|
||
}
|
||
return .mk {
|
||
desc
|
||
diagnostics := (← Language.Snapshot.Diagnostics.ofMessageLog msgs)
|
||
traces := st.traceState
|
||
} st.snapshotTasks
|
||
-- interrupt or abort exception as `try catch` above should have caught any others
|
||
| .error _ => default
|
||
|
||
@[inherit_doc Core.logSnapshotTask]
|
||
def logSnapshotTask (task : Language.SnapshotTask Language.SnapshotTree) : CommandElabM Unit :=
|
||
modify fun s => { s with snapshotTasks := s.snapshotTasks.push task }
|
||
|
||
open Language in
|
||
def runLintersAsync (stx : Syntax) : CommandElabM Unit := do
|
||
if !Elab.async.get (← getOptions) then
|
||
withoutModifyingEnv do
|
||
runLinters stx
|
||
return
|
||
|
||
-- linters should have access to the complete info tree and message log
|
||
let mut snaps := (← get).snapshotTasks
|
||
if let some elabSnap := (← read).snap? then
|
||
snaps := snaps.push { stx? := none, cancelTk? := none, task := elabSnap.new.result!.map (sync := true) toSnapshotTree }
|
||
let tree := SnapshotTree.mk { diagnostics := .empty } snaps
|
||
let treeTask ← tree.waitAll
|
||
|
||
-- We only start one task for all linters for now as most linters are fast and we simply want
|
||
-- to unblock elaboration of the next command
|
||
let cancelTk ← IO.CancelToken.new
|
||
let lintAct ← wrapAsyncAsSnapshot (cancelTk? := cancelTk) fun infoSt => do
|
||
let messages := tree.getAll.map (·.diagnostics.msgLog) |>.foldl (· ++ ·) .empty
|
||
-- do not double-report
|
||
let messages := messages.markAllReported
|
||
modify fun st => { st with messages := st.messages ++ messages }
|
||
modifyInfoState fun _ => infoSt
|
||
runLinters stx
|
||
|
||
let task ← BaseIO.bindTask (sync := true) (t := (← getInfoState).substituteLazy) fun infoSt =>
|
||
BaseIO.mapTask (t := treeTask) fun _ =>
|
||
lintAct infoSt
|
||
logSnapshotTask { stx? := none, task, cancelTk? := cancelTk }
|
||
|
||
/--
|
||
Registers a command elaborator for the given syntax node kind.
|
||
|
||
A command elaborator should have type `Lean.Elab.Command.CommandElab` (which is
|
||
`Lean.Syntax → Lean.Elab.Term.CommandElabM Unit`), i.e. should take syntax of the given syntax
|
||
node kind as a parameter and perform an action.
|
||
|
||
The `elab_rules` and `elab` commands should usually be preferred over using this attribute
|
||
directly.
|
||
-/
|
||
@[builtin_doc]
|
||
unsafe builtin_initialize commandElabAttribute : KeyedDeclsAttribute CommandElab ←
|
||
mkElabAttribute CommandElab `builtin_command_elab `command_elab `Lean.Parser.Command `Lean.Elab.Command.CommandElab "command"
|
||
|
||
private def mkInfoTree (elaborator : Name) (stx : Syntax) (trees : PersistentArray InfoTree) : CommandElabM InfoTree := do
|
||
let ctx ← read
|
||
let s ← get
|
||
let scope := s.scopes.head!
|
||
let tree := InfoTree.node (Info.ofCommandInfo { elaborator, stx }) trees
|
||
let ctx := PartialContextInfo.commandCtx {
|
||
env := s.env, cmdEnv? := some s.env, fileMap := ctx.fileMap, mctx := {},
|
||
currNamespace := scope.currNamespace,
|
||
openDecls := scope.openDecls, options := scope.opts, ngen := s.ngen
|
||
}
|
||
return InfoTree.context ctx tree
|
||
|
||
/--
|
||
Disables incremental command reuse *and* reporting for `act` if `cond` is true by setting
|
||
`Context.snap?` to `none`.
|
||
-/
|
||
def withoutCommandIncrementality (cond : Bool) (act : CommandElabM α) : CommandElabM α := do
|
||
let opts ← getOptions
|
||
-- Cancel old elaboration when discarding it (for commands without incrementality support)
|
||
if cond then
|
||
if let some old := (← read).snap?.bind (·.old?) then
|
||
old.val.cancelRec
|
||
withReader (fun ctx => { ctx with snap? := ctx.snap?.filter fun snap => Id.run do
|
||
if let some old := snap.old? then
|
||
if cond && opts.getBool `trace.Elab.reuse then
|
||
dbg_trace "reuse stopped: guard failed at {old.stx}"
|
||
return !cond
|
||
}) act
|
||
|
||
private def elabCommandUsing (s : State) (stx : Syntax) : List (KeyedDeclsAttribute.AttributeEntry CommandElab) → CommandElabM Unit
|
||
| [] => withInfoTreeContext (mkInfoTree := mkInfoTree `no_elab stx) <| throwError "unexpected syntax{indentD stx}"
|
||
| (elabFn::elabFns) =>
|
||
catchInternalId unsupportedSyntaxExceptionId
|
||
(do
|
||
-- prevent unsupported commands from accidentally accessing `Context.snap?` (e.g. by nested
|
||
-- supported commands)
|
||
withoutCommandIncrementality (!(← isIncrementalElab elabFn.declName)) do
|
||
withInfoTreeContext (mkInfoTree := mkInfoTree elabFn.declName stx) do
|
||
elabFn.value stx)
|
||
(fun _ => do set s; elabCommandUsing s stx elabFns)
|
||
|
||
/-- Elaborate `x` with `stx` on the macro stack -/
|
||
def withMacroExpansion (beforeStx afterStx : Syntax) (x : CommandElabM α) : CommandElabM α :=
|
||
withInfoContext (mkInfo := pure <| .ofMacroExpansionInfo { stx := beforeStx, output := afterStx, lctx := .empty }) do
|
||
withReader (fun ctx => { ctx with macroStack := { before := beforeStx, after := afterStx } :: ctx.macroStack }) x
|
||
|
||
instance : MonadMacroAdapter CommandElabM where
|
||
getNextMacroScope := return (← get).nextMacroScope
|
||
setNextMacroScope next := modify fun s => { s with nextMacroScope := next }
|
||
|
||
instance : MonadRecDepth CommandElabM where
|
||
withRecDepth d x := withReader (fun ctx => { ctx with currRecDepth := d }) x
|
||
getRecDepth := return (← read).currRecDepth
|
||
getMaxRecDepth := return (← get).maxRecDepth
|
||
|
||
builtin_initialize registerTraceClass `Elab.command
|
||
|
||
open Language in
|
||
/-- Snapshot after macro expansion of a command. -/
|
||
structure MacroExpandedSnapshot extends Snapshot where
|
||
/-- The declaration name of the macro. -/
|
||
macroDecl : Name
|
||
/-- The expanded syntax tree. -/
|
||
newStx : Syntax
|
||
/-- `State.nextMacroScope` after expansion. -/
|
||
newNextMacroScope : Nat
|
||
/-- Whether any traces were present after expansion. -/
|
||
hasTraces : Bool
|
||
/--
|
||
Follow-up elaboration snapshots, one per command if `newStx` is a sequence of commands.
|
||
-/
|
||
next : Array (SnapshotTask DynamicSnapshot)
|
||
deriving TypeName
|
||
open Language in
|
||
instance : ToSnapshotTree MacroExpandedSnapshot where
|
||
toSnapshotTree s := ⟨s.toSnapshot, s.next.map (·.map (sync := true) toSnapshotTree)⟩
|
||
|
||
partial def elabCommand (stx : Syntax) : CommandElabM Unit :=
|
||
try
|
||
go
|
||
finally
|
||
addTraceAsMessages
|
||
where go := do
|
||
withLogging <| withRef stx <| withIncRecDepth <| withFreshMacroScope do
|
||
match stx with
|
||
| Syntax.node _ k args =>
|
||
if k == nullKind then
|
||
-- list of commands => elaborate in order
|
||
-- The parser will only ever return a single command at a time, but syntax quotations can return multiple ones
|
||
-- Incrementality is currently limited to the common case where the sequence is the direct
|
||
-- output of a macro, see below.
|
||
withoutCommandIncrementality true do
|
||
args.forM elabCommand
|
||
else withTraceNode `Elab.command (fun _ => return stx) (tag :=
|
||
-- special case: show actual declaration kind for `declaration` commands
|
||
(if stx.isOfKind ``Parser.Command.declaration then stx[1] else stx).getKind.toString) do
|
||
let s ← get
|
||
match (← liftMacroM <| expandMacroImpl? s.env stx) with
|
||
| some (decl, stxNew?) =>
|
||
withInfoTreeContext (mkInfoTree := mkInfoTree decl stx) do
|
||
let stxNew ← liftMacroM <| liftExcept stxNew?
|
||
withMacroExpansion stx stxNew do
|
||
-- Support incrementality; see also Note [Incremental Macros]
|
||
if let some snap := (←read).snap? then
|
||
-- Unpack nested commands; see `MacroExpandedSnapshot.next`
|
||
let cmds := if stxNew.isOfKind nullKind then stxNew.getArgs else #[stxNew]
|
||
let nextMacroScope := (← get).nextMacroScope
|
||
let hasTraces := (← getTraceState).traces.size > 0
|
||
let oldSnap? := do
|
||
let oldSnap ← snap.old?
|
||
let oldSnap ← oldSnap.val.get.toTyped? MacroExpandedSnapshot
|
||
guard <| oldSnap.macroDecl == decl && oldSnap.newNextMacroScope == nextMacroScope
|
||
-- check absence of traces; see Note [Incremental Macros]
|
||
guard <| !oldSnap.hasTraces && !hasTraces
|
||
return oldSnap
|
||
if snap.old?.isSome && oldSnap?.isNone then
|
||
snap.old?.forM (·.val.cancelRec)
|
||
let oldCmds? := oldSnap?.map fun old =>
|
||
if old.newStx.isOfKind nullKind then old.newStx.getArgs else #[old.newStx]
|
||
let cmdPromises ← cmds.mapM fun _ => IO.Promise.new
|
||
let cancelTk? := (← read).cancelTk?
|
||
snap.new.resolve <| .ofTyped {
|
||
diagnostics := .empty
|
||
macroDecl := decl
|
||
newStx := stxNew
|
||
newNextMacroScope := nextMacroScope
|
||
hasTraces
|
||
next := Array.zipWith (fun cmdPromise cmd =>
|
||
{ stx? := some cmd, task := cmdPromise.resultD default, cancelTk? }) cmdPromises cmds
|
||
: MacroExpandedSnapshot
|
||
}
|
||
-- After the first command whose syntax tree changed, we must disable
|
||
-- incremental reuse
|
||
let mut reusedCmds := true
|
||
let opts ← getOptions
|
||
-- For each command, associate it with new promise and old snapshot, if any, and
|
||
-- elaborate recursively
|
||
for cmd in cmds, cmdPromise in cmdPromises, i in *...cmds.size do
|
||
let oldCmd? := oldCmds?.bind (·[i]?)
|
||
withReader ({ · with snap? := some {
|
||
new := cmdPromise
|
||
old? := do
|
||
guard reusedCmds
|
||
let old ← oldSnap?
|
||
return { stx := (← oldCmd?), val := (← old.next[i]?) }
|
||
} }) do
|
||
if oldSnap?.isSome && (← read).snap?.isNone then
|
||
oldSnap?.bind (·.next[i]?) |>.forM (·.cancelRec)
|
||
elabCommand cmd
|
||
-- Resolve promise for commands not supporting incrementality; waiting for
|
||
-- `withAlwaysResolvedPromises` to do this could block reporting by later
|
||
-- commands
|
||
cmdPromise.resolve default
|
||
reusedCmds := reusedCmds && oldCmd?.any (·.eqWithInfoAndTraceReuse opts cmd)
|
||
else
|
||
elabCommand stxNew
|
||
| _ =>
|
||
match commandElabAttribute.getEntries s.env k with
|
||
| [] =>
|
||
withInfoTreeContext (mkInfoTree := mkInfoTree `no_elab stx) <|
|
||
throwError "elaboration function for `{k}` has not been implemented"
|
||
| elabFns => elabCommandUsing s stx elabFns
|
||
| _ =>
|
||
withInfoTreeContext (mkInfoTree := mkInfoTree `no_elab stx) <|
|
||
throwError "unexpected command"
|
||
|
||
builtin_initialize registerTraceClass `Elab.input
|
||
|
||
/-- Option for showing elaboration errors from partial syntax errors. -/
|
||
register_builtin_option showPartialSyntaxErrors : Bool := {
|
||
defValue := false
|
||
descr := "show elaboration errors from partial syntax trees (i.e. after parser recovery)"
|
||
}
|
||
|
||
builtin_initialize
|
||
registerTraceClass `Elab.info
|
||
registerTraceClass `Elab.snapshotTree
|
||
|
||
/--
|
||
If `hint?` is `some hint`, establishes a new context for macro scope naming and runs `act` in it,
|
||
otherwise runs `act` directly without changes.
|
||
|
||
Context names as documented in Note `Macro Scope Representation` help with avoiding rebuilds and
|
||
`prefer_native` lookup misses from macro scopes in declaration names and other exported information.
|
||
This function establishes a new context with a globally unique name by combining the name of the
|
||
current module with `hint` while also checking for previously used `hint`s in the same module.
|
||
Thus `hint` does not need to be unique but ensuring it is usually unique helps with keeping the
|
||
context name stable.
|
||
|
||
In the current implementation, we call `withInitQuotContext` once in `elabCommandTopLevel` using the
|
||
source input of the command as the hint. This helps with keeping macro scopes stable on changes to
|
||
other parts of the file but not on changes to the command itself. Thus in each *declaration*
|
||
elaborator we call `withInitQuotContext` again with the declaration name(s) as a hint so that
|
||
changes to any other part of the declaration do not change the context name.
|
||
-/
|
||
def withInitQuotContext (hint? : Option UInt64) (act : CommandElabM Unit) : CommandElabM Unit := do
|
||
let some hint := hint?
|
||
| act
|
||
let mut idx := hint.toUInt32.toNat
|
||
while (← get).usedQuotCtxts.contains ((← getMainModule).num idx |>.str "_hygCtx") do
|
||
idx := idx + 1
|
||
let quotCtx := (← getMainModule).num idx |>.str "_hygCtx"
|
||
let nextMacroScope := (← get).nextMacroScope
|
||
try
|
||
modify fun st => { st with
|
||
usedQuotCtxts := st.usedQuotCtxts.insert quotCtx
|
||
nextMacroScope := firstFrontendMacroScope + 1
|
||
}
|
||
withReader (fun ctx => { ctx with
|
||
quotContext? := some quotCtx
|
||
currMacroScope := firstFrontendMacroScope
|
||
}) act
|
||
finally
|
||
modify ({ · with nextMacroScope })
|
||
|
||
private partial def recordUsedSyntaxKinds (stx : Syntax) : CommandElabM Unit := do
|
||
if let .node _ k .. := stx then
|
||
-- do not record builtin parsers, they do not have to be imported
|
||
if !(← Parser.builtinSyntaxNodeKindSetRef.get).contains k then
|
||
recordExtraModUseFromDecl (isMeta := true) k
|
||
stx.forArgsM recordUsedSyntaxKinds
|
||
|
||
/--
|
||
`elabCommand` wrapper that should be used for the initial invocation, not for recursive calls after
|
||
macro expansion etc.
|
||
-/
|
||
def elabCommandTopLevel (stx : Syntax) : CommandElabM Unit := withRef stx do profileitM Exception "elaboration" (← getOptions) do
|
||
withReader ({ · with suppressElabErrors :=
|
||
stx.hasMissing && !showPartialSyntaxErrors.get (← getOptions) }) do
|
||
-- initialize quotation context using hash of input string
|
||
let ss? := stx.getSubstring? (withLeading := false) (withTrailing := false)
|
||
withInitQuotContext (ss?.map (hash ·.toString.trimAscii.copy)) do
|
||
-- Reset messages and info state, which are both per-command
|
||
modify fun st => { st with messages := {}, infoState := { enabled := st.infoState.enabled } }
|
||
try
|
||
-- We should *not* factor out `elabCommand`'s `withLogging` to here since it would make its error
|
||
-- recovery more coarse. In particular, if `c` in `set_option ... in $c` fails, the remaining
|
||
-- `end` command of the `in` macro would be skipped and the option would be leaked to the outside!
|
||
elabCommand stx
|
||
finally
|
||
-- This call could be placed at a prior point in this function except that it
|
||
-- would then record uses of `#guard_msgs` before that elaborator is run, which
|
||
-- would increase noise in related tests. Thus all other things being equal, we
|
||
-- place it here.
|
||
recordUsedSyntaxKinds stx
|
||
-- Make sure `snap?` is definitely resolved; we do not use it for reporting as `#guard_msgs` may
|
||
-- be the caller of this function and add new messages and info trees
|
||
if let some snap := (← read).snap? then
|
||
snap.new.resolve default
|
||
|
||
-- Run the linters, unless `#guard_msgs` is present, which is special and runs `elabCommandTopLevel` itself,
|
||
-- so it is a "super-top-level" command. This is the only command that does this, so we just special case it here
|
||
-- rather than engineer a general solution.
|
||
unless (stx.find? (·.isOfKind ``Lean.guardMsgsCmd)).isSome do
|
||
withLogging do
|
||
runLintersAsync stx
|
||
|
||
/-- Adapt a syntax transformation to a regular, command-producing elaborator. -/
|
||
def adaptExpander (exp : Syntax → CommandElabM Syntax) : CommandElab := fun stx => do
|
||
let stx' ← exp stx
|
||
withMacroExpansion stx stx' <| elabCommand stx'
|
||
|
||
private def getVarDecls (s : State) : Array Syntax :=
|
||
s.scopes.head!.varDecls
|
||
|
||
instance {α} : Inhabited (CommandElabM α) where
|
||
default := throw default
|
||
|
||
/--
|
||
The environment linter framework needs to be able to run linters with the same context
|
||
as `liftTermElabM`, so we expose that context as a public function here.
|
||
-/
|
||
def mkMetaContext : Meta.Context := {
|
||
keyedConfig := Meta.Config.toConfigWithKey { foApprox := true, ctxApprox := true, quasiPatternApprox := true }
|
||
}
|
||
|
||
open Lean.Parser.Term in
|
||
/-- Return identifier names in the given bracketed binder. -/
|
||
def getBracketedBinderIds : Syntax → CommandElabM (Array Name)
|
||
| `(bracketedBinderF|($ids* $[: $ty?]? $(_annot?)?)) => return ids.map Syntax.getId
|
||
| `(bracketedBinderF|{$ids* $[: $ty?]?}) => return ids.map Syntax.getId
|
||
| `(bracketedBinderF|⦃$ids* : $_⦄) => return ids.map Syntax.getId
|
||
| `(bracketedBinderF|[$id : $_]) => return #[id.getId]
|
||
| `(bracketedBinderF|[$_]) => return #[Name.anonymous]
|
||
| _ => throwUnsupportedSyntax
|
||
|
||
private def mkTermContext (ctx : Context) (s : State) : CommandElabM Term.Context := do
|
||
let scope := s.scopes.head!
|
||
let mut sectionVars := {}
|
||
for id in (← scope.varDecls.flatMapM getBracketedBinderIds), uid in scope.varUIds do
|
||
sectionVars := sectionVars.insert id uid
|
||
return {
|
||
macroStack := ctx.macroStack
|
||
sectionVars := sectionVars
|
||
isNoncomputableSection := scope.isNoncomputable }
|
||
|
||
/--
|
||
Lift the `TermElabM` monadic action `x` into a `CommandElabM` monadic action.
|
||
|
||
Note that `x` is executed with an empty message log. Thus, `x` cannot modify/view messages produced by
|
||
previous commands.
|
||
|
||
If you need to access the free variables corresponding to the ones declared using the `variable` command,
|
||
consider using `runTermElabM`.
|
||
|
||
Recall that `TermElabM` actions can automatically lift `MetaM` and `CoreM` actions.
|
||
Example:
|
||
```
|
||
public import Lean
|
||
|
||
open Lean Elab Command Meta
|
||
|
||
def printExpr (e : Expr) : MetaM Unit := do
|
||
IO.println s!"{← ppExpr e} : {← ppExpr (← inferType e)}"
|
||
|
||
#eval
|
||
liftTermElabM do
|
||
printExpr (mkConst ``Nat)
|
||
```
|
||
-/
|
||
def liftTermElabM (x : TermElabM α) : CommandElabM α := do
|
||
let ctx ← read
|
||
let s ← get
|
||
-- dbg_trace "heartbeats: {heartbeats}"
|
||
let scope := s.scopes.head!
|
||
-- We execute `x` with an empty message log. Thus, `x` cannot modify/view messages produced by previous commands.
|
||
-- This is useful for implementing `runTermElabM` where we use `Term.resetMessageLog`
|
||
let x : TermElabM _ := withSaveInfoContext x
|
||
-- make sure `observing` below also catches runtime exceptions (like we do by default in
|
||
-- `CommandElabM`)
|
||
let _ := MonadAlwaysExcept.except (m := TermElabM)
|
||
let x : MetaM _ := (observing (try x finally Meta.reportDiag)).run (← mkTermContext ctx s) { levelNames := scope.levelNames }
|
||
let x : CoreM _ := x.run mkMetaContext {}
|
||
let ((ea, _), _) ← runCore x
|
||
MonadExcept.ofExcept ea
|
||
|
||
instance : MonadEval TermElabM CommandElabM where
|
||
monadEval := liftTermElabM
|
||
|
||
/--
|
||
Execute the monadic action `elabFn xs` as a `CommandElabM` monadic action, where `xs` are free variables
|
||
corresponding to all active scoped variables declared using the `variable` command.
|
||
|
||
This method is similar to `liftTermElabM`, but it elaborates all scoped variables declared using the `variable`
|
||
command.
|
||
|
||
Example:
|
||
```
|
||
public import Lean
|
||
|
||
public section
|
||
|
||
open Lean Elab Command Meta
|
||
|
||
variable {α : Type u} {f : α → α}
|
||
variable (n : Nat)
|
||
|
||
#eval
|
||
runTermElabM fun xs => do
|
||
for x in xs do
|
||
IO.println s!"{← ppExpr x} : {← ppExpr (← inferType x)}"
|
||
```
|
||
-/
|
||
def runTermElabM (elabFn : Array Expr → TermElabM α) : CommandElabM α := do
|
||
let scope ← getScope
|
||
liftTermElabM <|
|
||
Term.withAutoBoundImplicit <|
|
||
Term.elabBinders scope.varDecls fun xs => do
|
||
-- We need to synthesize postponed terms because this is a checkpoint for the auto-bound implicit feature
|
||
-- If we don't use this checkpoint here, then auto-bound implicits in the postponed terms will not be handled correctly.
|
||
Term.synthesizeSyntheticMVarsNoPostponing
|
||
let mut sectionFVars := {}
|
||
for uid in scope.varUIds, x in xs do
|
||
sectionFVars := sectionFVars.insert uid x
|
||
withReader ({ · with sectionFVars := sectionFVars }) do
|
||
-- We don't want to store messages produced when elaborating `(getVarDecls s)` because they have already been saved when we elaborated the `variable`(s) command.
|
||
-- So, we use `Core.resetMessageLog`.
|
||
Core.resetMessageLog
|
||
let xs ← Term.addAutoBoundImplicits xs none
|
||
if xs.all (·.isFVar) then
|
||
Term.withoutAutoBoundImplicit <| elabFn xs
|
||
else
|
||
-- Abstract any mvars that appear in `xs` using `mkForallFVars` (the type `mkSort Level.zero` is an arbitrary placeholder)
|
||
-- and then rebuild the local context from scratch.
|
||
-- Resetting prevents the local context from including the original fvars from `xs`.
|
||
let ctxType ← Meta.mkForallFVars' xs (mkSort Level.zero)
|
||
Meta.withLCtx {} {} <| Meta.forallBoundedTelescope ctxType xs.size fun xs _ =>
|
||
Term.withoutAutoBoundImplicit <| elabFn xs
|
||
|
||
private def liftAttrM {α} (x : AttrM α) : CommandElabM α := do
|
||
liftCoreM x
|
||
|
||
/--
|
||
Return the stack of all currently active scopes:
|
||
the base scope always comes last; new scopes are prepended in the front.
|
||
In particular, the current scope is always the first element.
|
||
-/
|
||
def getScopes : CommandElabM (List Scope) := do
|
||
pure (← get).scopes
|
||
|
||
def modifyScope (f : Scope → Scope) : CommandElabM Unit :=
|
||
modify fun s => { s with
|
||
scopes := match s.scopes with
|
||
| h::t => f h :: t
|
||
| [] => unreachable!
|
||
}
|
||
|
||
def withScope (f : Scope → Scope) (x : CommandElabM α) : CommandElabM α := do
|
||
match (← get).scopes with
|
||
| [] => x
|
||
| h :: t =>
|
||
try
|
||
modify fun s => { s with scopes := f h :: t }
|
||
x
|
||
finally
|
||
modify fun s => { s with scopes := h :: t }
|
||
|
||
def getLevelNames : CommandElabM (List Name) :=
|
||
return (← getScope).levelNames
|
||
|
||
def addUnivLevel (idStx : Syntax) : CommandElabM Unit := withRef idStx do
|
||
let id := idStx.getId
|
||
let levelNames ← getLevelNames
|
||
if levelNames.elem id then
|
||
throwAlreadyDeclaredUniverseLevel id
|
||
else
|
||
modifyScope fun scope => { scope with levelNames := id :: scope.levelNames }
|
||
|
||
end Elab.Command
|
||
|
||
open Elab Command MonadRecDepth
|
||
|
||
private def liftCommandElabMCore (cmd : CommandElabM α) (throwOnError : Bool) : CoreM α := do
|
||
let s : Core.State ← get
|
||
let ctx : Core.Context ← read
|
||
let (a, commandState) ←
|
||
cmd.run {
|
||
fileName := ctx.fileName
|
||
fileMap := ctx.fileMap
|
||
currRecDepth := ctx.currRecDepth
|
||
currMacroScope := ctx.currMacroScope
|
||
ref := ctx.ref
|
||
snap? := none
|
||
cancelTk? := ctx.cancelTk?
|
||
suppressElabErrors := ctx.suppressElabErrors
|
||
} |>.run {
|
||
env := s.env
|
||
nextMacroScope := s.nextMacroScope
|
||
maxRecDepth := ctx.maxRecDepth
|
||
ngen := s.ngen
|
||
auxDeclNGen := s.auxDeclNGen
|
||
scopes := [{ header := "", opts := ctx.options }]
|
||
infoState.enabled := s.infoState.enabled
|
||
}
|
||
modify fun coreState => { coreState with
|
||
env := commandState.env
|
||
nextMacroScope := commandState.nextMacroScope
|
||
ngen := commandState.ngen
|
||
auxDeclNGen := commandState.auxDeclNGen
|
||
traceState.traces := coreState.traceState.traces ++ commandState.traceState.traces
|
||
}
|
||
if throwOnError then
|
||
if let some err := commandState.messages.toArray.find? (·.severity matches .error) then
|
||
throwError err.data
|
||
modify fun coreState => { coreState with
|
||
infoState.trees := coreState.infoState.trees.append commandState.infoState.trees
|
||
messages := coreState.messages ++ commandState.messages
|
||
}
|
||
return a
|
||
|
||
/--
|
||
Lifts an action in `CommandElabM` into `CoreM`, updating the environment,
|
||
messages, info trees, traces, the name generator, and macro scopes.
|
||
The action is run in a context with an empty message log, empty trace state, and empty info trees.
|
||
|
||
If `throwOnError` is true, then if the command produces an error message, it is converted into an exception.
|
||
In this case, info trees and messages are not carried over.
|
||
|
||
Commands that modify the processing of subsequent commands,
|
||
such as `open` and `namespace` commands,
|
||
only have an effect for the remainder of the `CommandElabM` computation passed here,
|
||
and do not affect subsequent commands.
|
||
|
||
*Warning:* when using this from `MetaM` monads, the caches are *not* reset.
|
||
If the command defines new instances for example, you should use `Lean.Meta.resetSynthInstanceCache`
|
||
to reset the instance cache.
|
||
While the `modifyEnv` function for `MetaM` clears its caches entirely,
|
||
`liftCommandElabM` has no way to reset these caches.
|
||
-/
|
||
def liftCommandElabM (cmd : CommandElabM α) (throwOnError : Bool := true) : CoreM α := do
|
||
-- `observing` ensures that if `cmd` throws an exception we still thread state back to `CoreM`.
|
||
MonadExcept.ofExcept (← liftCommandElabMCore (observing cmd) throwOnError)
|
||
|
||
/--
|
||
Given a command elaborator `cmd`, returns a new command elaborator that
|
||
first evaluates any local `set_option ... in ...` clauses and then invokes `cmd` on what remains.
|
||
-/
|
||
partial def withSetOptionIn (cmd : CommandElab) : CommandElab := fun stx => do
|
||
if stx.getKind == ``Lean.Parser.Command.in &&
|
||
stx[0].getKind == ``Lean.Parser.Command.set_option then
|
||
let opts ← Elab.elabSetOption stx[0][1] stx[0][3]
|
||
Command.withScope (fun scope => { scope with opts }) do
|
||
withSetOptionIn cmd stx[2]
|
||
else
|
||
cmd stx
|
||
|
||
export Elab.Command (Linter addLinter)
|
||
|
||
namespace Parser.Command
|
||
|
||
/--
|
||
Returns syntax for `private` or `public` visibility depending on `isPublic`. This function should be
|
||
used to generate visibility syntax for declarations that is independent of the presence of
|
||
`public section`s.
|
||
-/
|
||
def visibility.ofBool (isPublic : Bool) : TSyntax ``visibility :=
|
||
Unhygienic.run <| if isPublic then `(visibility| public) else `(visibility| private)
|
||
|
||
/--
|
||
Returns syntax for `private` if `attrKind` is `local` and `public` otherwise.
|
||
-/
|
||
def visibility.ofAttrKind (attrKind : TSyntax ``Term.attrKind) : TSyntax ``visibility :=
|
||
visibility.ofBool <| !attrKind matches `(attrKind| local)
|
||
|
||
end Parser.Command
|
||
|
||
end Lean
|