06ac472859
This PR extends the procedure behind `inferInstanceAs`/`def ... deriving` to continue recursion through the class graph even when a (local) instance to wrap was found in order to re-use already-wrapped instance of subclasses.
278 lines
13 KiB
Text
278 lines
13 KiB
Text
/-
|
||
Copyright (c) 2026 Lean FRO, LLC. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Authors: Eric Wieser, Kyle Miller, Jovan Gerbscheid, Kim Morrison, Sebastian Ullrich
|
||
-/
|
||
module
|
||
|
||
prelude
|
||
public import Lean.Meta.Closure
|
||
public import Lean.Meta.SynthInstance
|
||
public import Lean.Meta.CtorRecognizer
|
||
public import Lean.Meta.AppBuilder
|
||
import Lean.Structure
|
||
|
||
/-!
|
||
# Instance Wrapping
|
||
|
||
Both `inferInstanceAs` and the default `deriving` handler wrap instance bodies to ensure
|
||
that when deriving or inferring an instance for a semireducible type definition, the
|
||
definition's RHS is not leaked when reduced at lower than semireducible transparency.
|
||
|
||
## Algorithm
|
||
|
||
Given an instance `i : I` and expected type `I'` (where `I'` must be mvar-free),
|
||
`wrapInstance` constructs a result instance as follows, executing all steps at
|
||
`instances` transparency:
|
||
|
||
1. If `I'` is not a class application, return `i` unchanged.
|
||
2. If `I'` is a proposition, wrap `i` in an auxiliary theorem of type `I'` and return it
|
||
(controlled by `backward.inferInstanceAs.wrap.instances`).
|
||
3. Reduce `i` to whnf.
|
||
4. If `i` is not a constructor application: if `I` is already defeq to `I'`,
|
||
return `i`; otherwise (if `backward.inferInstanceAs.wrap.reuseSubInstances` is set) try
|
||
(recursive) eta-expansion and wrapping of `i` to see if any sub-instances can be reused;
|
||
otherwise wrap `i` in an auxiliary definition of type `I'` and return it (controlled by
|
||
`backward.inferInstanceAs.wrap.instances`).
|
||
5. Otherwise, if `i` is an application of `ctor` of class `C`:
|
||
- Unify the conclusion of the type of `ctor` with `I'` to obtain adjusted field type `Fᵢ'` for
|
||
each field.
|
||
- Return a new application `ctor ... : I'` where the fields are adjusted as follows:
|
||
- If the field type is a proposition: assign directly if types are defeq, otherwise
|
||
wrap in an auxiliary theorem.
|
||
- If the field is a parent field (subobject) `p : P`: first try to reuse an existing
|
||
instance that can be synthesized for `P` (controlled by
|
||
`backward.inferInstanceAs.wrap.reuseSubInstances`) in order to preserve defeqs; if that
|
||
fails, recurse.
|
||
- If it is a field of a flattened parent class `C'` and
|
||
`backward.inferInstanceAs.wrap.reuseSubInstances` is true, try synthesizing an instance of
|
||
`C'` for `I'` and if successful, use the corresponding projection of the found instance in
|
||
order to preserve defeqs; otherwise, continue.
|
||
- Specifically, construct the chain of base projections from `C` to `C'` applied to `_ : I'`
|
||
and infer its type to obtain an appropriate application of `C'` for the instance search.
|
||
- Otherwise (non-inherited data field): assign directly if types are defeq, otherwise wrap in an
|
||
auxiliary definition to fix the type (controlled by `backward.inferInstanceAs.wrap.data`).
|
||
|
||
## Options
|
||
|
||
- `backward.inferInstanceAs.wrap`: master switch for wrapping in both `inferInstanceAs`
|
||
and the default `deriving` handler
|
||
- `backward.inferInstanceAs.wrap.reuseSubInstances`: reuse existing instances 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
|
||
-/
|
||
|
||
namespace Lean.Meta
|
||
|
||
public register_builtin_option backward.inferInstanceAs.wrap : Bool := {
|
||
defValue := true
|
||
descr := "wrap instance bodies in `inferInstanceAs` and the default `deriving` handler"
|
||
}
|
||
|
||
public register_builtin_option backward.inferInstanceAs.wrap.reuseSubInstances : Bool := {
|
||
defValue := true
|
||
descr := "when recursing into sub-instances, reuse existing instances for the target type instead of re-wrapping them, which can be important to avoid non-defeq instance diamonds"
|
||
}
|
||
|
||
public register_builtin_option backward.inferInstanceAs.wrap.instances : Bool := {
|
||
defValue := true
|
||
descr := "wrap non-reducible instances in auxiliary definitions to fix their types"
|
||
}
|
||
|
||
public register_builtin_option backward.inferInstanceAs.wrap.data : Bool := {
|
||
defValue := true
|
||
descr := "wrap data fields in auxiliary definitions to fix their types"
|
||
}
|
||
|
||
builtin_initialize registerTraceClass `Meta.wrapInstance
|
||
|
||
open Meta
|
||
|
||
partial def getFieldOrigin (structName field : Name) : MetaM (Name × StructureFieldInfo) := do
|
||
let env ← getEnv
|
||
for parent in getStructureParentInfo env structName do
|
||
if (findField? env parent.structName field).isSome then
|
||
return ← getFieldOrigin parent.structName field
|
||
let some fi := getFieldInfo? env structName field
|
||
| throwError "no such field {field} in {structName}"
|
||
return (structName, fi)
|
||
|
||
/-- Projects application of a structure type to corresponding application of a parent structure. -/
|
||
def getParentStructType? (structName parentStructName : Name) (structType : Expr) : MetaM (Option Expr) := OptionT.run do
|
||
let env ← getEnv
|
||
let some path := getPathToBaseStructure? env parentStructName structName | failure
|
||
withLocalDeclD `self structType fun self => do
|
||
let proj ← path.foldlM (init := self) fun e projFn => do
|
||
let ty ← whnf (← inferType e)
|
||
let .const _ us := ty.getAppFn
|
||
| trace[Meta.wrapInstance] "could not reduce type `{ty}`"
|
||
failure
|
||
let params := ty.getAppArgs
|
||
pure <| mkApp (mkAppN (.const projFn us) params) e
|
||
let projTy ← whnf <| ← inferType proj
|
||
if projTy.containsFVar self.fvarId! then
|
||
trace[Meta.wrapInstance] "parent type depends on instance fields{indentExpr projTy}"
|
||
failure
|
||
return projTy
|
||
|
||
def etaStructExpand? (e : Expr) : MetaM (Option Expr) := OptionT.run do
|
||
guard <| (← liftM <| isConstructorApp? e).isNone
|
||
let eType ← instantiateMVars (← whnf (← inferType e))
|
||
let .const inductName us := eType.getAppFn | failure
|
||
let env ← getEnv
|
||
guard <| isStructure env inductName
|
||
guard <| isNonRecStructure env inductName
|
||
guard <| !(← isProp eType)
|
||
let iv ← getConstInfoInduct inductName
|
||
let some ctorName := iv.ctors.head? | failure
|
||
let ctorInfo ← getConstInfoCtor ctorName
|
||
let params := eType.getAppArgs.shrink ctorInfo.numParams
|
||
let structInfo? := getStructureInfo? env inductName
|
||
let mut result := mkAppN (mkConst ctorName us) params
|
||
for i in *...ctorInfo.numFields do
|
||
let proj := match structInfo?.bind (·.getProjFn? i) with
|
||
| some projFn => mkApp (mkAppN (mkConst projFn us) params) e
|
||
| none => mkProj inductName i e
|
||
result := mkApp result proj
|
||
return result
|
||
|
||
/--
|
||
Wrap an instance value so its type matches the expected type exactly.
|
||
See the module docstring for the full algorithm specification.
|
||
-/
|
||
public partial def wrapInstance (inst expectedType : Expr) (compile : Bool := true)
|
||
(logCompileErrors : Bool := true) (isMeta : Bool := false) : MetaM Expr :=
|
||
withTransparency .instances do
|
||
return (← go (isEta := false) inst expectedType).get!
|
||
-- If `isEta` is true, will return `none` if no sub-instance was found, i.e. eta-expansion had no
|
||
-- effect.
|
||
where go (inst expectedType : Expr) (isEta : Bool) : MetaM (Option Expr) := do
|
||
withTraceNode `Meta.wrapInstance
|
||
(fun _ => return m!"type: {expectedType}") do
|
||
let some className ← isClass? expectedType
|
||
| return inst
|
||
trace[Meta.wrapInstance] "class is {className}"
|
||
|
||
if ← isProp expectedType then
|
||
if backward.inferInstanceAs.wrap.instances.get (← getOptions) then
|
||
return (← mkAuxTheorem expectedType inst (zetaDelta := true))
|
||
else
|
||
return inst
|
||
|
||
-- Try to reduce it to a constructor.
|
||
(← whnf inst).withApp fun f args => do
|
||
let some (.ctorInfo ci) ← f.constName?.mapM getConstInfo
|
||
| do
|
||
trace[Meta.wrapInstance] "did not reduce to constructor application: {inst}"
|
||
let instType ← inferType inst
|
||
if ← isDefEq expectedType instType then
|
||
return inst
|
||
|
||
if backward.inferInstanceAs.wrap.reuseSubInstances.get (← getOptions) then
|
||
if let some inst ← etaStructExpand? inst then
|
||
if let some inst ← go (isEta := true) inst expectedType then
|
||
return inst
|
||
|
||
if backward.inferInstanceAs.wrap.instances.get (← getOptions) then
|
||
let name ← mkAuxDeclName
|
||
let wrapped ← mkAuxDefinition name expectedType inst (compile := false)
|
||
if isMeta then modifyEnv (markMeta · name)
|
||
if compile then
|
||
compileDecls (logErrors := logCompileErrors) #[name]
|
||
enableRealizationsForConst name
|
||
return wrapped
|
||
|
||
return inst
|
||
let (mvars, _, cls) ← forallMetaTelescope (← inferType f)
|
||
if h₁ : args.size ≠ mvars.size then
|
||
throwError "wrapInstance: incorrect number of arguments for \
|
||
constructor application `{f}`: {args}"
|
||
else
|
||
unless ← isDefEq expectedType cls do
|
||
throwError "wrapInstance: `{expectedType}` does not unify with the conclusion of \
|
||
`{.ofConstName ci.name}`"
|
||
let mut isEta := isEta
|
||
for h₂ : i in ci.numParams...args.size do
|
||
have : i < mvars.size := by
|
||
simp only [ne_eq, Decidable.not_not] at h₁
|
||
rw [← h₁]
|
||
get_elem_tactic
|
||
let mvarId := mvars[i].mvarId!
|
||
let mvarDecl ← mvarId.getDecl
|
||
let argExpectedType ← instantiateMVars mvarDecl.type
|
||
let arg := args[i]
|
||
if ← isProp argExpectedType then
|
||
let argType ← inferType arg
|
||
if ← isDefEq argExpectedType argType then
|
||
mvarId.assign arg
|
||
else
|
||
trace[Meta.wrapInstance] "proof field {i} does not have expected type {argExpectedType} but {argType}, wrapping in auxiliary theorem: {arg}"
|
||
mvarId.assign (← mkAuxTheorem argExpectedType arg (zetaDelta := true))
|
||
continue
|
||
|
||
-- Recurse into instance arguments of the constructor
|
||
if (← isClass? argExpectedType).isSome then
|
||
if backward.inferInstanceAs.wrap.reuseSubInstances.get (← getOptions) then
|
||
-- Reuse existing instance for the target type if any. This is especially important when recursing
|
||
-- as it guarantees subinstances of overlapping instances are defeq under more than just
|
||
-- semireducible transparency.
|
||
try
|
||
if let .some new ← trySynthInstance argExpectedType then
|
||
-- ignore instances from non-defeq diamonds
|
||
if (← withDefault <| isDefEq new arg) then
|
||
trace[Meta.wrapInstance] "using existing instance {new}"
|
||
mvarId.assign new
|
||
isEta := false
|
||
continue
|
||
catch _ => pure ()
|
||
|
||
-- continue eta-expansion recursively so we know whether any sub-instance was found
|
||
if isEta then
|
||
if let some arg ← etaStructExpand? arg then
|
||
if let some inst ← go (isEta := true) arg argExpectedType then
|
||
mvarId.assign inst
|
||
isEta := false
|
||
continue
|
||
|
||
mvarId.assign (← go (isEta := false) arg argExpectedType).get!
|
||
continue
|
||
|
||
-- If we hit a data field without having found any sub-instances, we can stop early
|
||
if isEta then
|
||
return none
|
||
|
||
if backward.inferInstanceAs.wrap.reuseSubInstances.get (← getOptions) then
|
||
let (baseClassName, fieldInfo) ← getFieldOrigin className mvarDecl.userName
|
||
if baseClassName != className then
|
||
trace[Meta.wrapInstance] "found inherited field `{mvarDecl.userName}` from parent `{baseClassName}`"
|
||
if let some baseClassType ← getParentStructType? className baseClassName expectedType then
|
||
try
|
||
if let .some existingBaseClassInst ← trySynthInstance baseClassType then
|
||
let proj ← mkProjection existingBaseClassInst fieldInfo.fieldName
|
||
-- ignore instances from non-defeq diamonds
|
||
if (← withDefault <| isDefEq proj arg) then
|
||
trace[Meta.wrapInstance] "using projection of existing instance `{existingBaseClassInst}`"
|
||
mvarId.assign proj
|
||
continue
|
||
trace[Meta.wrapInstance] "did not find existing instance for `{baseClassName}`"
|
||
catch e =>
|
||
trace[Meta.wrapInstance] "error when attempting to reuse existing instance for `{baseClassName}`: {e.toMessageData}"
|
||
|
||
-- For data fields, assign directly or wrap in aux def to fix types.
|
||
if backward.inferInstanceAs.wrap.data.get (← getOptions) then
|
||
let argType ← inferType arg
|
||
if ← isDefEq argExpectedType argType then
|
||
mvarId.assign arg
|
||
else
|
||
let name ← mkAuxDeclName
|
||
mvarId.assign (← mkAuxDefinition name argExpectedType arg (compile := false))
|
||
setInlineAttribute name
|
||
if isMeta then modifyEnv (markMeta · name)
|
||
if compile then
|
||
compileDecls (logErrors := logCompileErrors) #[name]
|
||
enableRealizationsForConst name
|
||
else
|
||
mvarId.assign arg
|
||
return mkAppN f (← mvars.mapM instantiateMVars)
|