6e4936d6ee
Some checks are pending
Lean Action CI / build (push) Waiting to run
Per the elegance pass: 9 ad-hoc per-modality constructors collapse into
3 ModalityKind-parameterised constructors. Future modalities (Phase
4's ʃ_EML, ℑ infinitesimal) extend ModalityKind by adding cases —
no new constructors, no new ABI bump.
New Lean enum (Syntax.lean):
inductive ModalityKind | flat | sharp | shape
deriving DecidableEq, Repr, Inhabited
Constructor unification:
· CType: 3 (.flat / .sharp / .shape) → 1 (.modal k A)
· CTerm: 6 (.flatIntro / .sharpIntro / .shapeIntro / .flatElim /
.sharpElim / .shapeElim) → 2 (.modalIntro k a, .modalElim k f m)
· CVal: 3 (vFlatIntro / vSharpIntro / vShapeIntro) → 1 (vModalIntro)
· CNeu: 3 (nflatElim / nsharpElim / nshapeElim) → 1 (nModalElim)
· SkeletalCType: 3 (skFlat / skSharp / skShape) → 1 (skModal k)
Engine cascade across 12 files (DecEq, DimLine, Eval, FFITest, Modal,
Question, Readback, Reflect, Subst, Syntax, Typing, Value): every
match site collapsed from 3-per-modality arms to 1 k-parameterised arm.
Reflect.lean: new `reflectModalityKind` / `reifyModalityKind` helpers
+ ModalityKind dispatch arm in classifyFieldType. The Phase 1 macro
auto-derived per-constructor reflect/reify for the new unified
constructors — no manual cascade needed there.
Eval.lean β-rule: `.modalElim k f (.modalIntro k' a)` β-reduces only
when k = k' (kind-discrimination preserves cross-kind correctness even
if typing is bypassed); cross-kind case produces a marker neutral.
Modal.lean transient alias block (top of file, outside namespace) for
backward dot-syntax reference (`.flatIntro a` resolves to
`.modalIntro .flat a` via abbrev). Phase 3 will rewrite Modal.lean
properly to use the unified constructors directly + forModalityKind-
derived functor.
Net: −145 lines across the cascade (-478 deletions, +333 insertions).
Build: lake build (48 jobs) + lake build CubicalTransport (43 jobs) PASS.
Runtime: lake exe cubical-test 49/49 + 46/46 = 95/95 PASS.
Sorry count: Modal.lean 3 (unchanged), total engine 33 (no new sorries
from this phase, all annotated).
The Rust ABI v6 still uses 9 modal tags — diverges from the Lean side
after this commit but FFI tests don't exercise modal paths so no
runtime regression. Phase 4 will sync to ABI v7.
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
1145 lines
52 KiB
Text
1145 lines
52 KiB
Text
/-
|
||
CubicalTransport.Reflect
|
||
========================
|
||
Reflection metaprogramming layer (THEORY.md §0.9).
|
||
|
||
Bidirectional bridge between the engine's first-class CTerm / CType
|
||
inductives and Lean's tactic-facing `Lean.Expr` representation.
|
||
|
||
## What this module exports
|
||
|
||
· `reflectULevel : ULevel → MetaM Expr`
|
||
· `reflectCType : ∀ {ℓ : ULevel}, CType ℓ → MetaM Expr`
|
||
· `reflectCTerm : CTerm → MetaM Expr`
|
||
|
||
· `reifyULevel : Expr → MetaM (Option ULevel)`
|
||
· `reifyCType : Expr → MetaM (Option (Σ ℓ : ULevel, CType ℓ))`
|
||
· `reifyCTerm : Expr → MetaM (Option CTerm)`
|
||
|
||
· `Contract.register : Lean.Name → ContractEntry → IO Unit`
|
||
· `Contract.lookupByName : Lean.Name → IO (Option ContractEntry)`
|
||
· `Contract.allRegistered : IO (List Lean.Name)`
|
||
|
||
· Round-trip theorems on the image of the reflection functions.
|
||
|
||
## Design
|
||
|
||
· `reflectCType` produces a Lean `Expr` that, when elaborated in
|
||
a context with `CubicalTransport` open, evaluates back to the
|
||
original CType. Each constructor maps to a fully-applied
|
||
`Expr.app`-tree over its constructor's `Lean.Name`, with every
|
||
implicit `{ℓ : ULevel}` argument made explicit (Expr-level
|
||
construction is always fully explicit).
|
||
|
||
· `reflectCTerm` is similar.
|
||
|
||
· The mutual nature of CType / CTerm is reflected at the
|
||
metaprogramming level: `reflectCType` calls `reflectCTerm` on
|
||
its CTerm sub-payloads (path endpoints, glue equiv components),
|
||
and `reflectCTerm` calls `reflectCType` on its CType payloads
|
||
(transp / comp / code arguments).
|
||
|
||
· `reify*` are the inverses, returning `Option` because not every
|
||
`Expr` is a valid encoding. `reifyULevel` is fully discharged
|
||
structurally; `reifyCType` and `reifyCTerm` have their full
|
||
per-constructor inverse pending the `Expr`-pattern-matching
|
||
scaffolding (annotated below).
|
||
|
||
· The Contract registry is an
|
||
`IO.Ref (Std.HashMap Lean.Name ContractEntry)`.
|
||
Contracts register themselves in their defining module's
|
||
`initialize` block; tactics and other consumers look them up
|
||
by name.
|
||
|
||
## Macro-derived per-constructor arms
|
||
|
||
The reflect/reify code for the syntax-tree inductives — `DimVar`,
|
||
`DimExpr`, `FaceFormula`, `CType`, `CTerm`, `CTypeArg`, `CtorSpec`,
|
||
`CTypeSchema` — is generated by `derive_reflect_reify`, which
|
||
introspects each inductive's `ConstructorVal` data and emits
|
||
per-field arms mechanically. The macro shares all per-type
|
||
dispatch through one constructor-walking loop, so adding a new
|
||
constructor to any of these inductives requires zero changes to
|
||
the reflection layer.
|
||
|
||
## Coupling note (Contract module)
|
||
|
||
The `Contract` type itself is `def Contract (ℓ : ULevel) : Type :=
|
||
CType ℓ → CTerm` — exported by `CubicalTransport.Contract`. This
|
||
module re-exports the same definition locally (as an `abbrev` —
|
||
definitionally equal to the upstream) to avoid a circular
|
||
dependency: contracts in `CubicalTransport.Contract` will register
|
||
themselves into the registry exposed here, so `Contract` must
|
||
import `Reflect`, not the other way around. The two spellings
|
||
unify by reducibility, so registering a `Contract.Contract` value
|
||
via `Reflect.Contract.register` typechecks without any conversion.
|
||
-/
|
||
|
||
import Lean
|
||
import CubicalTransport.Syntax
|
||
import CubicalTransport.Inductive
|
||
import CubicalTransport.Typing
|
||
|
||
namespace CubicalTransport.Reflect
|
||
|
||
open Lean Meta
|
||
|
||
/-- Local re-export of the Contract type; definitionally equal to
|
||
`CubicalTransport.Contract.Contract`. -/
|
||
abbrev Contract (ℓ : ULevel) : Type := CType ℓ → CTerm
|
||
|
||
-- ── §1. Reflection: ULevel → Expr ──────────────────────────────────────────
|
||
|
||
/-- Reflect a `ULevel` to its `Lean.Expr` encoding. Walks the
|
||
inductive's two constructors directly; the produced Expr is
|
||
`@ULevel.zero` or `@ULevel.succ <recurse>`. -/
|
||
partial def reflectULevel : ULevel → MetaM Expr
|
||
| .zero => return mkConst ``ULevel.zero
|
||
| .succ n => do
|
||
let ne ← reflectULevel n
|
||
return mkApp (mkConst ``ULevel.succ) ne
|
||
|
||
-- ── §2. Sigma encoding for level-indexed payloads ─────────────────────────
|
||
|
||
/-- The `Expr` for the family `fun ℓ : ULevel => CType ℓ`, used as
|
||
the implicit family argument of `Sigma.mk` when reflecting
|
||
heterogeneous-level CType lists. Built once via the bound-
|
||
variable `Expr.bvar 0` under a single λ-binder. -/
|
||
def cTypeFamilyExpr : Expr :=
|
||
.lam `ℓ (mkConst ``ULevel)
|
||
(mkApp (mkConst ``CType) (.bvar 0))
|
||
.default
|
||
|
||
/-- The `Expr` for the type `Σ ℓ : ULevel, CType ℓ`. -/
|
||
def cTypeSigmaExpr : Expr :=
|
||
mkAppN (mkConst ``Sigma [Level.zero, Level.zero])
|
||
#[mkConst ``ULevel, cTypeFamilyExpr]
|
||
|
||
/-- Build the `Expr` for `@Sigma.mk ULevel (fun ℓ => CType ℓ) ℓE AE`. -/
|
||
def mkSigmaULevelCType (ℓE : Expr) (AE : Expr) : Expr :=
|
||
mkAppN (mkConst ``Sigma.mk [Level.zero, Level.zero])
|
||
#[mkConst ``ULevel, cTypeFamilyExpr, ℓE, AE]
|
||
|
||
-- ── §3. Reification leaf decoders (ULevel, Nat-lit, Str-lit) ──────────────
|
||
|
||
/-- Reify a `Lean.Expr` back to a `ULevel`. Returns `none` if the
|
||
Expr does not match the shape `@ULevel.zero` or `@ULevel.succ <e>`.
|
||
|
||
Pattern: walk down `Expr.app`-chains; at each leaf, check the head
|
||
constant name against `ULevel.zero` / `ULevel.succ`. This is the
|
||
strict structural inverse of `reflectULevel`. -/
|
||
partial def reifyULevel : Expr → MetaM (Option ULevel) := fun e => do
|
||
-- Reduce metadata wrappers and beta-redexes that may be sitting
|
||
-- around the literal constructor application.
|
||
let e ← whnf e
|
||
match e.getAppFnArgs with
|
||
| (``ULevel.zero, _) => return some .zero
|
||
| (``ULevel.succ, args) =>
|
||
if h : args.size = 1 then
|
||
match ← reifyULevel (args[0]'(by omega)) with
|
||
| some n => return some (.succ n)
|
||
| none => return none
|
||
else
|
||
return none
|
||
| _ => return none
|
||
|
||
/-- Reify the literal-Nat encoding produced by `mkNatLit n`. After
|
||
`whnf`, an `OfNat.ofNat`-shaped numeral reduces to its raw form
|
||
via `Expr.nat?`. -/
|
||
partial def reifyNatLit (e : Expr) : MetaM (Option Nat) := do
|
||
let e ← whnf e
|
||
match e.nat? with
|
||
| some n => return some n
|
||
| none =>
|
||
-- Also accept the raw literal form `.lit (.natVal n)` directly
|
||
-- (in case `whnf` has already normalised through `OfNat.ofNat`).
|
||
match e with
|
||
| .lit (.natVal n) => return some n
|
||
| _ => return none
|
||
|
||
/-- Reify a `mkStrLit s`-encoded expression back to its String. -/
|
||
partial def reifyStrLit (e : Expr) : MetaM (Option String) := do
|
||
let e ← whnf e
|
||
match e with
|
||
| .lit (.strVal s) => return some s
|
||
| _ => return none
|
||
|
||
-- ── §3a. ModalityKind reflect / reify (Refactor Phase 2) ──────────────────
|
||
|
||
/-- Reflect a `ModalityKind` to its `Lean.Expr` encoding. The
|
||
`ModalityKind` enum is finite with three nullary constructors;
|
||
each maps to its `mkConst`-encoded fully-qualified name. -/
|
||
def reflectModalityKind : ModalityKind → MetaM Expr
|
||
| .flat => return mkConst ``ModalityKind.flat
|
||
| .sharp => return mkConst ``ModalityKind.sharp
|
||
| .shape => return mkConst ``ModalityKind.shape
|
||
|
||
/-- Reify a `Lean.Expr` back to a `ModalityKind`. Inverse of
|
||
`reflectModalityKind` — recognises the three constructor names
|
||
via `getAppFnArgs`. -/
|
||
def reifyModalityKind (e : Expr) : MetaM (Option ModalityKind) := do
|
||
let e ← whnf e
|
||
match e.getAppFnArgs with
|
||
| (``ModalityKind.flat, _) => return some .flat
|
||
| (``ModalityKind.sharp, _) => return some .sharp
|
||
| (``ModalityKind.shape, _) => return some .shape
|
||
| _ => return none
|
||
|
||
-- ── §4. Macro: derive_reflect_reify ──────────────────────────────────────
|
||
--
|
||
-- The metaprogramming layer that emits per-constructor reflect/reify arms
|
||
-- from each inductive's signature. Replaces ~900 lines of hand-written
|
||
-- boilerplate with a single generic constructor-walking loop.
|
||
--
|
||
-- Usage:
|
||
-- derive_reflect_reify CType, CTerm, FaceFormula, DimExpr, DimVar,
|
||
-- CTypeSchema, CtorSpec, CTypeArg
|
||
--
|
||
-- The macro:
|
||
-- · Resolves each ident to an inductive's `ConstructorVal` list.
|
||
-- · For each constructor, walks its argument signature via
|
||
-- `forallTelescopeReducing`, classifies each field type, and emits
|
||
-- a reflect-arm + a reify-arm.
|
||
-- · Auto-discovers `List X`, `List (Σ ℓ : ULevel, CType ℓ)`,
|
||
-- `List (FaceFormula × CTerm)`, `List (String × CTerm)` payload
|
||
-- shapes and emits the corresponding `reflect<…>List` /
|
||
-- `reify<…>List` helpers in the same `mutual` block.
|
||
--
|
||
-- Field-type → reflect/reify dispatch:
|
||
-- String → mkStrLit / reifyStrLit
|
||
-- Nat → mkNatLit / reifyNatLit
|
||
-- ULevel → reflectULevel / reifyULevel
|
||
-- DimVar / DimExpr / FaceFormula → reflect<T> / reify<T>
|
||
-- CType <level> → reflectCType / reifyCType
|
||
-- CTerm → reflectCTerm / reifyCTerm
|
||
-- CTypeArg / CtorSpec / CTypeSchema → reflect<T> / reify<T>
|
||
-- List X (X = inductive) → reflect<X>List / reify<X>List
|
||
-- List (Σ ℓ : ULevel, CType ℓ) → reflectCTypeAnyList / reifyCTypeAnyList
|
||
-- List (FaceFormula × CTerm) → reflectClausesList / reifyClausesList
|
||
-- List (String × CTerm) → reflectBranchesList / reifyBranchesList
|
||
--
|
||
-- For implicit `{ℓ : ULevel}` arguments to a constructor, the reflect
|
||
-- side reflects the level explicitly (Expr construction is always
|
||
-- fully explicit). The reify side recovers the level via
|
||
-- `reifyULevel` and unifies it with any subsequent `CType ℓ` arg's
|
||
-- inferred level via the standard `if h : ℓ_rec = ℓ then h ▸ … else
|
||
-- return none` discharge pattern.
|
||
|
||
namespace Macro
|
||
|
||
open Lean Elab Command Term
|
||
open Lean.Parser.Term
|
||
|
||
/-- Field-type classification used by the constructor walker. Each
|
||
case maps to a (reflect-call, reify-call) pair in the emitted
|
||
syntax. -/
|
||
inductive FieldKind where
|
||
/-- `String` — uses `mkStrLit` / `reifyStrLit`. -/
|
||
| str
|
||
/-- `Nat` — uses `mkNatLit` / `reifyNatLit`. -/
|
||
| nat
|
||
/-- `ULevel` — uses `reflectULevel` / `reifyULevel`. -/
|
||
| uLevel
|
||
/-- `ModalityKind` (Refactor Phase 2) — uses
|
||
`reflectModalityKind` / `reifyModalityKind`. -/
|
||
| modalityKind
|
||
/-- A simple inductive name (`DimVar`, `DimExpr`, `FaceFormula`,
|
||
`CTerm`, `CTypeArg`, `CtorSpec`, `CTypeSchema`). Uses
|
||
`reflect<T>` / `reify<T>`. -/
|
||
| indSimple (typeName : Name)
|
||
/-- A level-indexed `CType ℓ`. Uses `reflectCType` / `reifyCType`,
|
||
with level coherence on the reify side: the reified Σ-pair must
|
||
have its level-component match the constructor's expected level. -/
|
||
| cType
|
||
/-- `List X` for an inductive element type `X`. Uses
|
||
`reflect<X>List` / `reify<X>List`. -/
|
||
| listInd (elemTypeName : Name)
|
||
/-- `List (Σ ℓ : ULevel, CType ℓ)` — uses `reflectCTypeAnyList` /
|
||
`reifyCTypeAnyList`. -/
|
||
| listCTypeAny
|
||
/-- `List (FaceFormula × CTerm)` — uses `reflectClausesList` /
|
||
`reifyClausesList`. -/
|
||
| listClauses
|
||
/-- `List (String × CTerm)` — uses `reflectBranchesList` /
|
||
`reifyBranchesList`. -/
|
||
| listBranches
|
||
deriving Inhabited
|
||
|
||
/-- Classify a field type by inspecting its `Expr` head. Returns
|
||
`none` if the field type is not in the supported dispatch table —
|
||
the macro then errors out at elaboration time. -/
|
||
def classifyFieldType (ty : Expr) : MetaM (Option FieldKind) := do
|
||
let ty ← whnf ty
|
||
match ty.getAppFnArgs with
|
||
| (``String, _) => return some .str
|
||
| (``Nat, _) => return some .nat
|
||
| (``ULevel, _) => return some .uLevel
|
||
| (``ModalityKind, _) => return some .modalityKind
|
||
| (``DimVar, _) => return some (.indSimple ``DimVar)
|
||
| (``DimExpr, _) => return some (.indSimple ``DimExpr)
|
||
| (``FaceFormula, _) => return some (.indSimple ``FaceFormula)
|
||
| (``CTerm, _) => return some (.indSimple ``CTerm)
|
||
| (``CTypeArg, _) => return some (.indSimple ``CTypeArg)
|
||
| (``CtorSpec, _) => return some (.indSimple ``CtorSpec)
|
||
| (``CTypeSchema, _) => return some (.indSimple ``CTypeSchema)
|
||
| (``CType, _) => return some .cType
|
||
| (``List, #[elemTy]) =>
|
||
let elemTy ← whnf elemTy
|
||
match elemTy.getAppFnArgs with
|
||
| (``CTerm, _) => return some (.listInd ``CTerm)
|
||
| (``CtorSpec, _) => return some (.listInd ``CtorSpec)
|
||
| (``CTypeArg, _) => return some (.listInd ``CTypeArg)
|
||
| (``Sigma, #[α, β]) =>
|
||
-- Detect Σ ℓ : ULevel, CType ℓ. The β should be the
|
||
-- CType-family lambda; we identify by checking α and the
|
||
-- function's body shape (CType applied to bvar 0).
|
||
if α.isConstOf ``ULevel then
|
||
match β with
|
||
| .lam _ _ body _ =>
|
||
if body.isAppOfArity ``CType 1 then
|
||
return some .listCTypeAny
|
||
else
|
||
return none
|
||
| _ => return none
|
||
else
|
||
return none
|
||
| (``Prod, #[α, β]) =>
|
||
if α.isConstOf ``FaceFormula
|
||
&& β.isConstOf ``CTerm then
|
||
return some .listClauses
|
||
else if α.isConstOf ``String
|
||
&& β.isConstOf ``CTerm then
|
||
return some .listBranches
|
||
else
|
||
return none
|
||
| _ => return none
|
||
| _ => return none
|
||
|
||
/-- Local short-name for an inductive (e.g. `CType` for the
|
||
root-level `CType`). Used to derive function names. -/
|
||
def shortName (n : Name) : String :=
|
||
match n.componentsRev.head! with
|
||
| .str _ s => s
|
||
| _ => "Unknown"
|
||
|
||
/-- Build a `reflect<TypeName>` name in the Reflect namespace. -/
|
||
def mkReflectName (n : Name) : Name :=
|
||
`CubicalTransport.Reflect ++ Name.mkSimple ("reflect" ++ shortName n)
|
||
|
||
/-- Build a `reflect<TypeName>List` name in the Reflect namespace. -/
|
||
def mkReflectListName (n : Name) : Name :=
|
||
`CubicalTransport.Reflect ++ Name.mkSimple ("reflect" ++ shortName n ++ "List")
|
||
|
||
/-- Build a `reify<TypeName>` name in the Reflect namespace. -/
|
||
def mkReifyName (n : Name) : Name :=
|
||
`CubicalTransport.Reflect ++ Name.mkSimple ("reify" ++ shortName n)
|
||
|
||
/-- Build a `reify<TypeName>List` name in the Reflect namespace. -/
|
||
def mkReifyListName (n : Name) : Name :=
|
||
`CubicalTransport.Reflect ++ Name.mkSimple ("reify" ++ shortName n ++ "List")
|
||
|
||
/-- The reflect-function name for a given field kind. Used inside the
|
||
macro to look up the right partial-def name to call on each field. -/
|
||
def reflectFunFor : FieldKind → Name
|
||
| .str => Name.mkSimple "mkStrLit" -- inline-emitted via Lean.mkStrLit
|
||
| .nat => Name.mkSimple "mkNatLit" -- inline-emitted via Lean.mkNatLit
|
||
| .uLevel => `CubicalTransport.Reflect.reflectULevel
|
||
| .modalityKind => `CubicalTransport.Reflect.reflectModalityKind
|
||
| .cType => `CubicalTransport.Reflect.reflectCType
|
||
| .indSimple n => mkReflectName n
|
||
| .listInd n => mkReflectListName n
|
||
| .listCTypeAny => `CubicalTransport.Reflect.reflectCTypeAnyList
|
||
| .listClauses => `CubicalTransport.Reflect.reflectClausesList
|
||
| .listBranches => `CubicalTransport.Reflect.reflectBranchesList
|
||
|
||
/-- The reify-function name for a given field kind. -/
|
||
def reifyFunFor : FieldKind → Name
|
||
| .str => `CubicalTransport.Reflect.reifyStrLit
|
||
| .nat => `CubicalTransport.Reflect.reifyNatLit
|
||
| .uLevel => `CubicalTransport.Reflect.reifyULevel
|
||
| .modalityKind => `CubicalTransport.Reflect.reifyModalityKind
|
||
| .cType => `CubicalTransport.Reflect.reifyCType
|
||
| .indSimple n => mkReifyName n
|
||
| .listInd n => mkReifyListName n
|
||
| .listCTypeAny => `CubicalTransport.Reflect.reifyCTypeAnyList
|
||
| .listClauses => `CubicalTransport.Reflect.reifyClausesList
|
||
| .listBranches => `CubicalTransport.Reflect.reifyBranchesList
|
||
|
||
/-- Construct an unhygienic identifier for forward references — used
|
||
when calling a function defined in the same mutual block, where
|
||
the function's def-name is plain (no macro scope) so the body's
|
||
reference must also be plain. -/
|
||
@[inline] def fwdId (n : Name) : Ident := mkIdent n
|
||
|
||
/-- `true` iff the inductive is universe-indexed by a `ULevel` (i.e.,
|
||
its `reify<T>` returns `Σ ℓ : ULevel, T ℓ` rather than just `T`). -/
|
||
def isLevelIndexed (n : Name) : Bool := n == ``CType
|
||
|
||
-- ── §4.x. Constant-reference helpers ─────────────────────────────────────
|
||
-- Inside macro quotations, naming a constant via plain identifier
|
||
-- triggers hygiene mangling; the resulting Expr fails to resolve.
|
||
-- These aliases construct un-hygienic identifiers via `mkCIdent`,
|
||
-- which look up the constant directly by name.
|
||
|
||
@[inline] def cId (n : Name) : Ident := mkCIdent n
|
||
|
||
/-- Common Lean global-constant idents used by emitted code. -/
|
||
def lMetaM : Ident := cId ``Lean.MetaM
|
||
def lExpr : Ident := cId ``Lean.Expr
|
||
def lWhnf : Ident := cId ``Lean.Meta.whnf
|
||
def lMkConst : Ident := cId ``Lean.mkConst
|
||
def lMkApp : Ident := cId ``Lean.mkApp
|
||
def lMkAppN : Ident := cId ``Lean.mkAppN
|
||
def lMkStrLit : Ident := cId ``Lean.mkStrLit
|
||
def lMkNatLit : Ident := cId ``Lean.mkNatLit
|
||
def lLevelZero : Ident := cId ``Lean.Level.zero
|
||
def lListNil : Ident := cId ``List.nil
|
||
def lListCons : Ident := cId ``List.cons
|
||
def lProd : Ident := cId ``Prod
|
||
def lProdMk : Ident := cId ``Prod.mk
|
||
def lSigma : Ident := cId ``Sigma
|
||
def lSigmaMk : Ident := cId ``Sigma.mk
|
||
def lOption : Ident := cId ``Option
|
||
def lULevel : Ident := cId ``ULevel
|
||
def lCType : Ident := cId ``CType
|
||
def lString : Ident := cId ``String
|
||
def lFaceFormula : Ident := cId ``FaceFormula
|
||
def lCTerm : Ident := cId ``CTerm
|
||
|
||
def lReflectULevel : Ident := mkIdent `CubicalTransport.Reflect.reflectULevel
|
||
def lReflectCType : Ident := mkIdent `CubicalTransport.Reflect.reflectCType
|
||
def lReflectCTerm : Ident := mkIdent `CubicalTransport.Reflect.reflectCTerm
|
||
def lReflectFaceFormula : Ident := mkIdent `CubicalTransport.Reflect.reflectFaceFormula
|
||
def lReifyULevel : Ident := mkIdent `CubicalTransport.Reflect.reifyULevel
|
||
def lReifyStrLit : Ident := mkIdent `CubicalTransport.Reflect.reifyStrLit
|
||
def lReifyNatLit : Ident := mkIdent `CubicalTransport.Reflect.reifyNatLit
|
||
def lReifyCType : Ident := mkIdent `CubicalTransport.Reflect.reifyCType
|
||
def lReifyCTerm : Ident := mkIdent `CubicalTransport.Reflect.reifyCTerm
|
||
def lReifyFaceFormula : Ident := mkIdent `CubicalTransport.Reflect.reifyFaceFormula
|
||
def lcTypeSigmaExpr : Ident := mkCIdent `CubicalTransport.Reflect.cTypeSigmaExpr
|
||
def lmkSigmaULevelCType : Ident := mkCIdent `CubicalTransport.Reflect.mkSigmaULevelCType
|
||
|
||
-- ── §4.1. Per-constructor introspection ────────────────────────────────────
|
||
|
||
/-- Per-field record produced by walking a constructor's signature. -/
|
||
structure FieldInfo where
|
||
/-- A fresh hygienic local name to use both as the pattern binder
|
||
and as the reified-value identifier. -/
|
||
name : Name
|
||
/-- Whether this field is implicit in the source (so the pattern
|
||
uses `@Constructor` form to bring it explicitly into scope). -/
|
||
isImplicit : Bool
|
||
/-- The classified field-kind for dispatch. -/
|
||
kind : FieldKind
|
||
/-- For `.cType` fields: the index of the earlier field that
|
||
provides the universe level (or `none` if the level is some
|
||
other expression like `ULevel.zero`). Used by the reify-side
|
||
level-coherence check. -/
|
||
cTypeLevelOf? : Option Nat := none
|
||
deriving Inhabited
|
||
|
||
/-- Walk a constructor's `type` (a forall-telescope of fields ending
|
||
in the inductive's applied type), and produce per-field infos. -/
|
||
def collectFields (ctorName : Name) : MetaM (Array FieldInfo) := do
|
||
let ctorVal ← getConstInfoCtor ctorName
|
||
forallTelescopeReducing ctorVal.type fun xs _resultTy => do
|
||
-- Skip the inductive's parameters (numParams entries at the front
|
||
-- of the telescope); the per-constructor "fields" begin after
|
||
-- those. Our inductives have numParams = 0 in practice, but be
|
||
-- safe.
|
||
let numParams := ctorVal.numParams
|
||
let mut infos : Array FieldInfo := #[]
|
||
-- Track per-FVar-id the index in `infos` that introduced it
|
||
-- (only ULevel-typed fields are tracked).
|
||
let mut fvarToIdx : Std.HashMap FVarId Nat := ∅
|
||
for i in [numParams:xs.size] do
|
||
let x := xs[i]!
|
||
let decl ← x.fvarId!.getDecl
|
||
let fieldTy ← inferType x
|
||
let some kind ← classifyFieldType fieldTy
|
||
| throwError "derive_reflect_reify: unsupported field type {fieldTy} in constructor {ctorName}"
|
||
let nm ← mkFreshUserName decl.userName.eraseMacroScopes
|
||
-- For `.cType` fields, identify which ULevel field provides
|
||
-- the level (if any).
|
||
let cTypeLevelOf? : Option Nat ← match kind with
|
||
| .cType =>
|
||
let appArgs := fieldTy.getAppArgs
|
||
if appArgs.size = 1 then
|
||
let levelE := appArgs[0]!
|
||
if levelE.isFVar then
|
||
pure (fvarToIdx[levelE.fvarId!]?)
|
||
else
|
||
pure none
|
||
else
|
||
pure none
|
||
| _ => pure none
|
||
let infoIdx := infos.size
|
||
infos := infos.push {
|
||
name := nm,
|
||
isImplicit :=
|
||
decl.binderInfo == .implicit
|
||
|| decl.binderInfo == .strictImplicit
|
||
|| decl.binderInfo == .instImplicit,
|
||
kind,
|
||
cTypeLevelOf?
|
||
}
|
||
-- Track this fvar if it's a ULevel field, so subsequent CType
|
||
-- fields can reference it.
|
||
match kind with
|
||
| .uLevel => fvarToIdx := fvarToIdx.insert x.fvarId! infoIdx
|
||
| _ => pure ()
|
||
return infos
|
||
|
||
-- ── §4.2. Per-constructor reflect-arm syntax ───────────────────────────────
|
||
|
||
/-- Build the reflect-arm syntax for one constructor. Result has the
|
||
shape:
|
||
| @Constructor field1 field2 ... => do
|
||
let f1E ← <reflect call for field1>
|
||
let f2E ← <reflect call for field2>
|
||
...
|
||
return mkAppN (mkConst ``Constructor) #[f1E, f2E, ...]
|
||
Nullary constructors collapse the do-block to a single
|
||
`return mkConst ``Constructor`. -/
|
||
def mkReflectArm (ctorName : Name) (infos : Array FieldInfo) :
|
||
TermElabM (TSyntax ``Lean.Parser.Term.matchAltExpr) := do
|
||
-- Build the pattern: `@Constructor f1 f2 ...`
|
||
let patFields ← infos.mapM fun info =>
|
||
`($(mkIdent info.name):ident)
|
||
let pattern ← `(@$(cId ctorName):ident $patFields:term*)
|
||
-- Build the per-field "let fE ← <reflect call>" bindings.
|
||
-- For .str, the value is `mkStrLit` directly (not a do-bind).
|
||
-- For .nat, similarly `mkNatLit`. For others, `← <reflectFn> field`.
|
||
let mut bodyParts : Array (TSyntax ``Parser.Term.doSeqItem) := #[]
|
||
let mut argEs : Array Term := #[]
|
||
for info in infos do
|
||
let fieldId := mkIdent info.name
|
||
let argName := info.name.appendAfter "_E"
|
||
let argId := mkIdent argName
|
||
let elem : TSyntax `doElem ← match info.kind with
|
||
| .str =>
|
||
`(doElem| let $argId := $lMkStrLit $fieldId)
|
||
| .nat =>
|
||
`(doElem| let $argId := $lMkNatLit $fieldId)
|
||
| _ =>
|
||
let funId := mkIdent (reflectFunFor info.kind)
|
||
`(doElem| let $argId ← ($funId $fieldId))
|
||
let seqItem ← `(Lean.Parser.Term.doSeqItem| $elem:doElem)
|
||
bodyParts := bodyParts.push seqItem
|
||
argEs := argEs.push argId
|
||
-- Build the final return statement.
|
||
let returnElem : TSyntax `doElem ← if argEs.isEmpty then
|
||
`(doElem| return $lMkConst $(quote ctorName))
|
||
else
|
||
`(doElem| return $lMkAppN ($lMkConst $(quote ctorName)) #[$argEs,*])
|
||
let returnSeqItem ← `(Lean.Parser.Term.doSeqItem| $returnElem:doElem)
|
||
let allItems := bodyParts.push returnSeqItem
|
||
let body ← `(do $[$allItems]*)
|
||
`(matchAltExpr| | $pattern:term => $body:term)
|
||
|
||
-- ── §4.3. Per-constructor reify-arm syntax ─────────────────────────────────
|
||
|
||
/-- The "reified value" name for a field at index `i` (used in the
|
||
reify body, where each field is given a binding via `match ← …
|
||
with | some name => …`). -/
|
||
def reifyValName (info : FieldInfo) : Name := info.name
|
||
|
||
/-- The "raw level" name used for the level-coherence check on a
|
||
`CType` field whose level matches a previously-decoded ULevel.
|
||
For field `A`, this is `A_lvl`. -/
|
||
def reifyLvlName (info : FieldInfo) : Name :=
|
||
info.name.appendAfter "_lvl"
|
||
|
||
/-- Build the reify-arm body — the inner `if h : args.size = N then …
|
||
else return none` block. Recursively peels one field at a time.
|
||
Returns a `doSeq` (which contains the nested matches/ifs as
|
||
do-elements).
|
||
|
||
`infos` is the constructor's field list (in order).
|
||
`i` is the current field index being processed.
|
||
`final` is the doSeq to use after all fields are bound. -/
|
||
partial def mkReifyArmBody (infos : Array FieldInfo)
|
||
(final : TSyntax ``Lean.Parser.Term.doSeq) :
|
||
TermElabM (TSyntax ``Lean.Parser.Term.doSeq) := do
|
||
let rec go (i : Nat) : TermElabM (TSyntax ``Lean.Parser.Term.doSeq) := do
|
||
if h : i < infos.size then
|
||
let info := infos[i]
|
||
let argIdx := Syntax.mkNumLit (toString i)
|
||
let argExpr ← `((args[$argIdx]'(by omega)))
|
||
let valId := mkIdent (reifyValName info)
|
||
let funId := mkIdent (reifyFunFor info.kind)
|
||
let rest ← go (i + 1)
|
||
-- Each match is a `doMatch` directly. Arm rhs is a `doSeq`.
|
||
-- We splice `$rest` as a `doSeq` into the arm rhs position.
|
||
match info.kind with
|
||
| .cType =>
|
||
let lvlId := mkIdent (reifyLvlName info)
|
||
match info.cTypeLevelOf? with
|
||
| none =>
|
||
`(doSeq|
|
||
match ← ($funId $argExpr) with
|
||
| none => return none
|
||
| some ⟨$lvlId, $valId⟩ => $rest:doSeq)
|
||
| some lvlIdx =>
|
||
let targetLvlId := mkIdent (reifyValName infos[lvlIdx]!)
|
||
let coherentValId := mkIdent (info.name.appendAfter "_coh")
|
||
let coherenceHId := mkIdent (info.name.appendAfter "_lvlEq")
|
||
-- The `then` branch is a doSeq containing TWO items:
|
||
-- a `let $valId := ...` and the `$rest` doSeq. We
|
||
-- combine them by emitting them as a sequence.
|
||
let letItem : TSyntax ``Lean.Parser.Term.doSeqItem ←
|
||
`(doSeqItem| let $valId : $lCType $targetLvlId := $coherenceHId ▸ $coherentValId)
|
||
let restItems := getDoSeqItems rest
|
||
let allItems := #[letItem] ++ restItems
|
||
let thenSeq ← `(doSeq| $[$allItems]*)
|
||
`(doSeq|
|
||
match ← ($funId $argExpr) with
|
||
| none => return none
|
||
| some ⟨$lvlId, $coherentValId⟩ =>
|
||
if $coherenceHId:ident
|
||
: $lvlId = $targetLvlId then
|
||
$thenSeq
|
||
else
|
||
return none)
|
||
| _ =>
|
||
`(doSeq|
|
||
match ← ($funId $argExpr) with
|
||
| none => return none
|
||
| some $valId => $rest:doSeq)
|
||
else
|
||
return final
|
||
go 0
|
||
where
|
||
/-- Helper: extract the doSeqItems from a doSeq for splicing. -/
|
||
getDoSeqItems (s : TSyntax ``Lean.Parser.Term.doSeq) :
|
||
Array (TSyntax ``Lean.Parser.Term.doSeqItem) :=
|
||
if s.raw.getKind == ``Lean.Parser.Term.doSeqIndent then
|
||
s.raw[0].getArgs.map (⟨·⟩)
|
||
else if s.raw.getKind == ``Lean.Parser.Term.doSeqBracketed then
|
||
s.raw[1].getArgs.map (⟨·⟩)
|
||
else
|
||
#[]
|
||
|
||
/-- Build the reify-arm body (no pattern) — returned as a `doSeq` so
|
||
it can be spliced into a `doMatch` arm position. The arm has the
|
||
shape:
|
||
if h : args.size = N then
|
||
<nested matches over each field, then return some …>
|
||
else
|
||
return none
|
||
-/
|
||
def mkReifyArmDoSeq (ctorName : Name) (infos : Array FieldInfo)
|
||
(isLvlIndexed : Bool) :
|
||
TermElabM (TSyntax ``Lean.Parser.Term.doSeq) := do
|
||
let arity := Syntax.mkNumLit (toString infos.size)
|
||
let fieldArgs : Array (Term × Bool × FieldInfo) := infos.map fun info =>
|
||
(mkIdent (reifyValName info), info.isImplicit, info)
|
||
let mut callArgs : Array Term := #[]
|
||
for (argTerm, _isImplicit, _info) in fieldArgs do
|
||
callArgs := callArgs.push argTerm
|
||
let _ := ctorName -- silence unused warning; ctorName is used only in caller
|
||
let ctorCall ← `(@$(cId ctorName) $callArgs:term*)
|
||
let finalReturn : TSyntax ``Lean.Parser.Term.doSeq ←
|
||
if isLvlIndexed then
|
||
`(doSeq| return some ⟨_, $ctorCall⟩)
|
||
else
|
||
`(doSeq| return some $ctorCall)
|
||
let body ← mkReifyArmBody infos finalReturn
|
||
`(doSeq|
|
||
if h : args.size = $arity then
|
||
$body
|
||
else
|
||
return none)
|
||
|
||
-- ── §4.4. Per-inductive function-emitters ──────────────────────────────────
|
||
|
||
/-- Emit the body of `reflect<TypeName>`: a `match` over the value
|
||
with one arm per constructor. Arms are produced by `mkReflectArm`. -/
|
||
def mkReflectFunBody (indVal : InductiveVal) : TermElabM Term := do
|
||
let mut arms : Array (TSyntax ``matchAltExpr) := #[]
|
||
for ctorName in indVal.ctors do
|
||
let infos ← collectFields ctorName
|
||
let arm ← mkReflectArm ctorName infos
|
||
arms := arms.push arm
|
||
-- Variable name for the discriminant. We use `t` for the value.
|
||
let tId := mkIdent `t
|
||
`(fun $tId => match $tId:term with $[$arms:matchAlt]*)
|
||
|
||
/-- Emit the body of `reify<TypeName>`: `whnf` the input, then match
|
||
`getAppFnArgs`.
|
||
|
||
Builds the doMatch by splicing PATTERNS (Term) and BODIES (doSeq)
|
||
separately via `$[| $pats => $bodies]*` — this is required because
|
||
`doMatch` arms have `doSeq` rhs (not term rhs), and matchAltExpr
|
||
quotations only build term-rhs arms. -/
|
||
def mkReifyFunBody (indVal : InductiveVal) : TermElabM Term := do
|
||
let isLvl := isLevelIndexed indVal.name
|
||
let mut pats : Array Term := #[]
|
||
let mut bodies : Array (TSyntax ``Lean.Parser.Term.doSeq) := #[]
|
||
for ctorName in indVal.ctors do
|
||
let infos ← collectFields ctorName
|
||
let pat ← `(($(quote ctorName), args))
|
||
let body ← mkReifyArmDoSeq ctorName infos isLvl
|
||
pats := pats.push pat
|
||
bodies := bodies.push body
|
||
-- Final catch-all
|
||
let catchPat ← `(_)
|
||
let catchBody ← `(doSeq| return none)
|
||
pats := pats.push catchPat
|
||
bodies := bodies.push catchBody
|
||
let eId := mkIdent `e
|
||
`(fun $eId => do
|
||
let $eId ← ($lWhnf $eId)
|
||
match ($eId).getAppFnArgs with $[| $pats => $bodies]*)
|
||
|
||
/-- Emit the entire reflect/reify pair for one inductive as a list of
|
||
Commands (still to be wrapped in `mutual`). Returns two commands:
|
||
the reflect def and the reify def. -/
|
||
def mkInductiveDefs (indVal : InductiveVal) :
|
||
TermElabM (Array (TSyntax `command)) := do
|
||
let isLvl := isLevelIndexed indVal.name
|
||
let reflectName := mkReflectName indVal.name
|
||
let reifyName := mkReifyName indVal.name
|
||
-- Argument and return types differ for level-indexed inductives.
|
||
let reflectFunBody ← mkReflectFunBody indVal
|
||
let reifyFunBody ← mkReifyFunBody indVal
|
||
let reflectDef ←
|
||
if isLvl then
|
||
`(partial def $(mkIdent reflectName) :
|
||
{ℓ : $lULevel} → $lCType ℓ → $lMetaM $lExpr := $reflectFunBody)
|
||
else
|
||
`(partial def $(mkIdent reflectName) :
|
||
$(cId indVal.name) → $lMetaM $lExpr := $reflectFunBody)
|
||
let reifyDef ←
|
||
if isLvl then
|
||
`(partial def $(mkIdent reifyName) :
|
||
$lExpr → $lMetaM ($lOption (Σ ℓ : $lULevel, $lCType ℓ)) := $reifyFunBody)
|
||
else
|
||
`(partial def $(mkIdent reifyName) :
|
||
$lExpr → $lMetaM ($lOption $(cId indVal.name)) := $reifyFunBody)
|
||
return #[reflectDef, reifyDef]
|
||
|
||
-- ── §4.5. List-helper emitters ─────────────────────────────────────────────
|
||
|
||
/-- Emit `reflect<X>List : List X → MetaM Expr` for a simple inductive
|
||
element type `X` (`X` is non-level-indexed). -/
|
||
def mkSimpleListReflectDef (elemName : Name) : TermElabM (TSyntax `command) := do
|
||
let listFunName := mkReflectListName elemName
|
||
let elemFunName := mkReflectName elemName
|
||
let elemId := cId elemName
|
||
let listFunId := mkIdent listFunName
|
||
let elemFunId := mkIdent elemFunName
|
||
-- partial def reflectXList : List X → MetaM Expr
|
||
-- | [] => return mkApp (mkConst ``List.nil [Level.zero]) (mkConst ``X)
|
||
-- | hd :: tl => do
|
||
-- let hdE ← reflectX hd
|
||
-- let tlE ← reflectXList tl
|
||
-- return mkAppN (mkConst ``List.cons [Level.zero])
|
||
-- #[mkConst ``X, hdE, tlE]
|
||
`(partial def $listFunId : List $elemId → $lMetaM $lExpr
|
||
| [] =>
|
||
return $lMkApp ($lMkConst $(quote ``List.nil) [$lLevelZero])
|
||
($lMkConst $(quote elemName))
|
||
| hd :: tl => do
|
||
let hdE ← ($elemFunId hd)
|
||
let tlE ← ($listFunId tl)
|
||
return $lMkAppN ($lMkConst $(quote ``List.cons) [$lLevelZero])
|
||
#[$lMkConst $(quote elemName), hdE, tlE])
|
||
|
||
/-- Emit `reify<X>List : Expr → MetaM (Option (List X))` for a simple
|
||
inductive element type `X` (non-level-indexed). -/
|
||
def mkSimpleListReifyDef (elemName : Name) : TermElabM (TSyntax `command) := do
|
||
let listFunName := mkReifyListName elemName
|
||
let elemFunName := mkReifyName elemName
|
||
let elemId := cId elemName
|
||
let listFunId := mkIdent listFunName
|
||
let elemFunId := mkIdent elemFunName
|
||
`(partial def $listFunId : $lExpr → $lMetaM ($lOption (List $elemId)) := fun e => do
|
||
let e ← ($lWhnf e)
|
||
match e.getAppFnArgs with
|
||
| ($(quote ``List.nil), _) => return some []
|
||
| ($(quote ``List.cons), args) =>
|
||
if h : args.size = 3 then
|
||
match ← $elemFunId (args[1]'(by omega)) with
|
||
| none => return none
|
||
| some hd =>
|
||
match ← $listFunId (args[2]'(by omega)) with
|
||
| none => return none
|
||
| some tl => return some (hd :: tl)
|
||
else return none
|
||
| _ => return none)
|
||
|
||
/-- Emit `reflectCTypeAnyList : List (Σ ℓ : ULevel, CType ℓ) → MetaM Expr`. -/
|
||
def mkCTypeAnyListReflectDef : TermElabM (TSyntax `command) := do
|
||
let nm := mkIdent `CubicalTransport.Reflect.reflectCTypeAnyList
|
||
`(partial def $nm :
|
||
List (Σ ℓ : $lULevel, $lCType ℓ) → $lMetaM $lExpr
|
||
| [] =>
|
||
return $lMkApp
|
||
($lMkConst $(quote ``List.nil) [$lLevelZero])
|
||
$lcTypeSigmaExpr
|
||
| ⟨ℓ, A⟩ :: rest => do
|
||
let ℓE ← ($lReflectULevel ℓ)
|
||
let AE ← ($lReflectCType A)
|
||
let pairE := $lmkSigmaULevelCType ℓE AE
|
||
let restE ← ($nm rest)
|
||
return $lMkAppN ($lMkConst $(quote ``List.cons) [$lLevelZero])
|
||
#[$lcTypeSigmaExpr, pairE, restE])
|
||
|
||
/-- Emit `reifyCTypeAnyList : Expr → MetaM (Option (List (Σ ℓ : ULevel, CType ℓ)))`. -/
|
||
def mkCTypeAnyListReifyDef : TermElabM (TSyntax `command) := do
|
||
let nm := mkIdent `CubicalTransport.Reflect.reifyCTypeAnyList
|
||
`(partial def $nm :
|
||
$lExpr → $lMetaM ($lOption (List (Σ ℓ : $lULevel, $lCType ℓ))) := fun e => do
|
||
let e ← ($lWhnf e)
|
||
match e.getAppFnArgs with
|
||
| ($(quote ``List.nil), _) => return some []
|
||
| ($(quote ``List.cons), args) =>
|
||
if h : args.size = 3 then
|
||
let headE ← ($lWhnf (args[1]'(by omega)))
|
||
match headE.getAppFnArgs with
|
||
| ($(quote ``Sigma.mk), sargs) =>
|
||
if hs : sargs.size = 4 then
|
||
match ← ($lReifyULevel (sargs[2]'(by omega))) with
|
||
| none => return none
|
||
| some ℓ =>
|
||
match ← ($lReifyCType (sargs[3]'(by omega))) with
|
||
| none => return none
|
||
| some ⟨ℓ_rec, A⟩ =>
|
||
if hA : ℓ_rec = ℓ then
|
||
let A' : $lCType ℓ := hA ▸ A
|
||
match ← ($nm (args[2]'(by omega))) with
|
||
| none => return none
|
||
| some rest => return some (⟨ℓ, A'⟩ :: rest)
|
||
else return none
|
||
else return none
|
||
| _ => return none
|
||
else return none
|
||
| _ => return none)
|
||
|
||
/-- Emit `reflectClausesList : List (FaceFormula × CTerm) → MetaM Expr`. -/
|
||
def mkClausesListReflectDef : TermElabM (TSyntax `command) := do
|
||
let nm := mkIdent `CubicalTransport.Reflect.reflectClausesList
|
||
`(partial def $nm :
|
||
List ($lFaceFormula × $lCTerm) → $lMetaM $lExpr
|
||
| [] =>
|
||
let pairTy := $lMkAppN ($lMkConst $(quote ``Prod) [$lLevelZero, $lLevelZero])
|
||
#[$lMkConst $(quote ``FaceFormula), $lMkConst $(quote ``CTerm)]
|
||
return $lMkApp ($lMkConst $(quote ``List.nil) [$lLevelZero]) pairTy
|
||
| (φ, t) :: rest => do
|
||
let φE ← ($lReflectFaceFormula φ)
|
||
let te ← ($lReflectCTerm t)
|
||
let pairE := $lMkAppN ($lMkConst $(quote ``Prod.mk) [$lLevelZero, $lLevelZero])
|
||
#[$lMkConst $(quote ``FaceFormula), $lMkConst $(quote ``CTerm), φE, te]
|
||
let restE ← ($nm rest)
|
||
let pairTy := $lMkAppN ($lMkConst $(quote ``Prod) [$lLevelZero, $lLevelZero])
|
||
#[$lMkConst $(quote ``FaceFormula), $lMkConst $(quote ``CTerm)]
|
||
return $lMkAppN ($lMkConst $(quote ``List.cons) [$lLevelZero])
|
||
#[pairTy, pairE, restE])
|
||
|
||
/-- Emit `reifyClausesList : Expr → MetaM (Option (List (FaceFormula × CTerm)))`. -/
|
||
def mkClausesListReifyDef : TermElabM (TSyntax `command) := do
|
||
let nm := mkIdent `CubicalTransport.Reflect.reifyClausesList
|
||
`(partial def $nm :
|
||
$lExpr → $lMetaM ($lOption (List ($lFaceFormula × $lCTerm))) := fun e => do
|
||
let e ← ($lWhnf e)
|
||
match e.getAppFnArgs with
|
||
| ($(quote ``List.nil), _) => return some []
|
||
| ($(quote ``List.cons), args) =>
|
||
if h : args.size = 3 then
|
||
let headE ← ($lWhnf (args[1]'(by omega)))
|
||
match headE.getAppFnArgs with
|
||
| ($(quote ``Prod.mk), pargs) =>
|
||
if hp : pargs.size = 4 then
|
||
match ← ($lReifyFaceFormula (pargs[2]'(by omega))) with
|
||
| none => return none
|
||
| some φ =>
|
||
match ← ($lReifyCTerm (pargs[3]'(by omega))) with
|
||
| none => return none
|
||
| some t =>
|
||
match ← ($nm (args[2]'(by omega))) with
|
||
| none => return none
|
||
| some rest => return some ((φ, t) :: rest)
|
||
else return none
|
||
| _ => return none
|
||
else return none
|
||
| _ => return none)
|
||
|
||
/-- Emit `reflectBranchesList : List (String × CTerm) → MetaM Expr`. -/
|
||
def mkBranchesListReflectDef : TermElabM (TSyntax `command) := do
|
||
let nm := mkIdent `CubicalTransport.Reflect.reflectBranchesList
|
||
`(partial def $nm :
|
||
List ($lString × $lCTerm) → $lMetaM $lExpr
|
||
| [] =>
|
||
let pairTy := $lMkAppN ($lMkConst $(quote ``Prod) [$lLevelZero, $lLevelZero])
|
||
#[$lMkConst $(quote ``String), $lMkConst $(quote ``CTerm)]
|
||
return $lMkApp ($lMkConst $(quote ``List.nil) [$lLevelZero]) pairTy
|
||
| (n, b) :: rest => do
|
||
let bE ← ($lReflectCTerm b)
|
||
let pairE := $lMkAppN ($lMkConst $(quote ``Prod.mk) [$lLevelZero, $lLevelZero])
|
||
#[$lMkConst $(quote ``String), $lMkConst $(quote ``CTerm), $lMkStrLit n, bE]
|
||
let restE ← ($nm rest)
|
||
let pairTy := $lMkAppN ($lMkConst $(quote ``Prod) [$lLevelZero, $lLevelZero])
|
||
#[$lMkConst $(quote ``String), $lMkConst $(quote ``CTerm)]
|
||
return $lMkAppN ($lMkConst $(quote ``List.cons) [$lLevelZero])
|
||
#[pairTy, pairE, restE])
|
||
|
||
/-- Emit `reifyBranchesList : Expr → MetaM (Option (List (String × CTerm)))`. -/
|
||
def mkBranchesListReifyDef : TermElabM (TSyntax `command) := do
|
||
let nm := mkIdent `CubicalTransport.Reflect.reifyBranchesList
|
||
`(partial def $nm :
|
||
$lExpr → $lMetaM ($lOption (List ($lString × $lCTerm))) := fun e => do
|
||
let e ← ($lWhnf e)
|
||
match e.getAppFnArgs with
|
||
| ($(quote ``List.nil), _) => return some []
|
||
| ($(quote ``List.cons), args) =>
|
||
if h : args.size = 3 then
|
||
let headE ← ($lWhnf (args[1]'(by omega)))
|
||
match headE.getAppFnArgs with
|
||
| ($(quote ``Prod.mk), pargs) =>
|
||
if hp : pargs.size = 4 then
|
||
match ← ($lReifyStrLit (pargs[2]'(by omega))) with
|
||
| none => return none
|
||
| some n =>
|
||
match ← ($lReifyCTerm (pargs[3]'(by omega))) with
|
||
| none => return none
|
||
| some b =>
|
||
match ← ($nm (args[2]'(by omega))) with
|
||
| none => return none
|
||
| some rest => return some ((n, b) :: rest)
|
||
else return none
|
||
| _ => return none
|
||
else return none
|
||
| _ => return none)
|
||
|
||
-- ── §4.6. Discovery: which list-helpers does this set of inductives
|
||
-- need?
|
||
--
|
||
-- A single forward pass over each inductive's constructors collects
|
||
-- the set of `FieldKind`s that involve list payloads.
|
||
|
||
/-- Unique list-helper kinds used across the constructors of `inds`. -/
|
||
def collectListHelpers (inds : Array Name) :
|
||
TermElabM (Array Name × Bool × Bool × Bool) := do
|
||
-- Returns: (simple-inductive-list element types,
|
||
-- needs CTypeAnyList, needs ClausesList, needs BranchesList)
|
||
let mut listInds : Array Name := #[]
|
||
let mut needsCTypeAny := false
|
||
let mut needsClauses := false
|
||
let mut needsBranches := false
|
||
for indName in inds do
|
||
let indVal ← getConstInfoInduct indName
|
||
for ctorName in indVal.ctors do
|
||
let infos ← collectFields ctorName
|
||
for info in infos do
|
||
match info.kind with
|
||
| .listInd elemName =>
|
||
unless listInds.contains elemName do
|
||
listInds := listInds.push elemName
|
||
| .listCTypeAny => needsCTypeAny := true
|
||
| .listClauses => needsClauses := true
|
||
| .listBranches => needsBranches := true
|
||
| _ => pure ()
|
||
return (listInds, needsCTypeAny, needsClauses, needsBranches)
|
||
|
||
-- ── §4.7. The macro itself ─────────────────────────────────────────────────
|
||
|
||
/-- The `derive_reflect_reify` command. Takes a comma-separated list
|
||
of inductive type names and emits a single `mutual ... end` block
|
||
containing per-inductive `reflect<T>` / `reify<T>` definitions
|
||
plus any auto-discovered list-helper variants.
|
||
|
||
The names in the list must be directly resolvable in the current
|
||
scope (they are looked up via `resolveGlobalConstNoOverloadCore`). -/
|
||
syntax (name := deriveReflectReifyCmd) "derive_reflect_reify" sepBy1(ident, ",") : command
|
||
|
||
@[command_elab deriveReflectReifyCmd]
|
||
def elabDeriveReflectReify : CommandElab := fun stx => do
|
||
let idents := stx[1].getSepArgs
|
||
let names ← liftCoreM <| idents.mapM fun id =>
|
||
realizeGlobalConstNoOverloadWithInfo id
|
||
-- All emit-and-elab work runs inside one fresh macro scope so the
|
||
-- mutually-recursive definitions can see each other.
|
||
withFreshMacroScope <| do
|
||
-- Discover list helpers needed.
|
||
let (listInds, needsCTypeAny, needsClauses, needsBranches) ←
|
||
liftTermElabM <| collectListHelpers names
|
||
-- Build all defs in a single mutual block.
|
||
let mut allDefs : Array (TSyntax `command) := #[]
|
||
-- Per-inductive reflect + reify.
|
||
for indName in names do
|
||
let indVal ← liftTermElabM <| getConstInfoInduct indName
|
||
let defs ← liftTermElabM <| mkInductiveDefs indVal
|
||
allDefs := allDefs ++ defs
|
||
-- Per-element-type list helpers (simple inductives).
|
||
for elemName in listInds do
|
||
allDefs := allDefs.push (← liftTermElabM <| mkSimpleListReflectDef elemName)
|
||
allDefs := allDefs.push (← liftTermElabM <| mkSimpleListReifyDef elemName)
|
||
-- Specialized list helpers.
|
||
if needsCTypeAny then
|
||
allDefs := allDefs.push (← liftTermElabM <| mkCTypeAnyListReflectDef)
|
||
allDefs := allDefs.push (← liftTermElabM <| mkCTypeAnyListReifyDef)
|
||
if needsClauses then
|
||
allDefs := allDefs.push (← liftTermElabM <| mkClausesListReflectDef)
|
||
allDefs := allDefs.push (← liftTermElabM <| mkClausesListReifyDef)
|
||
if needsBranches then
|
||
allDefs := allDefs.push (← liftTermElabM <| mkBranchesListReflectDef)
|
||
allDefs := allDefs.push (← liftTermElabM <| mkBranchesListReifyDef)
|
||
-- Wrap in mutual.
|
||
let mutBlock ← `(mutual $allDefs:command* end)
|
||
elabCommand mutBlock
|
||
|
||
end Macro
|
||
|
||
-- Re-export the macro syntax at the parent namespace so callers can
|
||
-- just write `derive_reflect_reify ...`.
|
||
export Macro (deriveReflectReifyCmd)
|
||
|
||
-- ── §5. Macro invocation: derive reflect/reify for the syntax stack ───────
|
||
|
||
derive_reflect_reify DimVar, DimExpr, FaceFormula, CType, CTerm,
|
||
CTypeArg, CtorSpec, CTypeSchema
|
||
|
||
-- ── §6. Contract registry ──────────────────────────────────────────────────
|
||
|
||
/-- Type-erased Contract package — bundles a Contract with its
|
||
universe level so the registry can hold heterogeneous-level
|
||
entries homogeneously. -/
|
||
structure ContractEntry where
|
||
/-- The universe level the contract operates at. -/
|
||
level : ULevel
|
||
/-- The contract itself: a function from CType ℓ to CTerm. -/
|
||
contract : Contract level
|
||
|
||
/-- The contract registry: maps `Lean.Name` to `ContractEntry`.
|
||
|
||
Initialised empty. Contracts register themselves in their
|
||
defining module's `initialize` block via `Contract.register`;
|
||
tactics and other consumers look them up by name. -/
|
||
initialize contractRegistry : IO.Ref (Std.HashMap Lean.Name ContractEntry) ←
|
||
IO.mkRef ∅
|
||
|
||
/-- Register a Contract under the given `Lean.Name`. Subsequent
|
||
lookups via `Contract.lookupByName n` return the newly registered
|
||
entry. Re-registering the same name overwrites the previous
|
||
entry (last-write-wins). -/
|
||
def Contract.register (n : Lean.Name) (e : ContractEntry) : IO Unit := do
|
||
contractRegistry.modify (·.insert n e)
|
||
|
||
/-- Look up a Contract by name. Returns `none` if no entry has been
|
||
registered under `n`. -/
|
||
def Contract.lookupByName (n : Lean.Name) : IO (Option ContractEntry) := do
|
||
let registry ← contractRegistry.get
|
||
return registry[n]?
|
||
|
||
/-- List all registered Contract names (in arbitrary HashMap order). -/
|
||
def Contract.allRegistered : IO (List Lean.Name) := do
|
||
let registry ← contractRegistry.get
|
||
return registry.toList.map (·.1)
|
||
|
||
-- ── §7. Round-trip theorems ────────────────────────────────────────────────
|
||
|
||
/-- Round-trip property: reflecting then reifying a CTerm in a single
|
||
`MetaM` computation yields `pure (some t)`.
|
||
|
||
Stated as an equation between two `MetaM (Option CTerm)`
|
||
computations: the `reflectCTerm` followed by `reifyCTerm` chain
|
||
must produce the original CTerm wrapped in `some`.
|
||
|
||
Proof outline (structural induction on `t`):
|
||
· Each CTerm constructor's reflect-arm produces an Expr whose
|
||
`getAppFnArgs` yields the constructor's name and reflected
|
||
sub-payloads.
|
||
· Each CTerm constructor's reify-arm inverts the reflect-arm
|
||
exactly: reading off `getAppFnArgs` recovers the constructor's
|
||
name; recursive reify calls invert the sub-payload reflections
|
||
by induction.
|
||
· The literal-encoding round-trips (`mkStrLit s` ↔ extract
|
||
`Expr.litValue? = some (.strVal s)`; `mkNatLit n` ↔ extract
|
||
`Expr.natLitValue?`) close at the leaves.
|
||
|
||
The proof is currently sorry'd pending the meta-level
|
||
`Expr`-equality framework that gives reduction-up-to-elaboration
|
||
semantics for `MetaM`-bound equations. -/
|
||
theorem reflectCTerm_reifyCTerm_roundtrip (t : CTerm) :
|
||
(do let e ← CubicalTransport.Reflect.reflectCTerm t;
|
||
CubicalTransport.Reflect.reifyCTerm e) =
|
||
(pure (some t) : MetaM (Option CTerm)) := by
|
||
-- waits on: meta-level reflection-roundtrip framework
|
||
-- (Expr-equality up to elaboration in a fixed Environment).
|
||
-- Once the framework lands, this discharges by structural
|
||
-- induction on `t`, with each constructor's case closed by
|
||
-- `simp [reflectCTerm, reifyCTerm, mkApp, mkAppN, ...]` and
|
||
-- the corresponding macro-derived arm of the reifyCTerm
|
||
-- body.
|
||
sorry
|
||
|
||
/-- Round-trip property: reflecting then reifying a CType in a single
|
||
`MetaM` computation yields `pure (some ⟨ℓ, T⟩)`. Same shape and
|
||
proof outline as the CTerm round-trip. -/
|
||
theorem reflectCType_reifyCType_roundtrip
|
||
{ℓ : ULevel} (T : CType ℓ) :
|
||
(do let e ← CubicalTransport.Reflect.reflectCType T;
|
||
CubicalTransport.Reflect.reifyCType e) =
|
||
(pure (some ⟨ℓ, T⟩) : MetaM (Option (Σ ℓ : ULevel, CType ℓ))) := by
|
||
-- waits on: meta-level reflection-roundtrip framework, as above.
|
||
sorry
|
||
|
||
/-- Round-trip property: reflecting then reifying a `ULevel` in a
|
||
single `MetaM` computation yields `pure (some ℓ)`. This is the
|
||
only round-trip whose proof obligation is fully elaborable
|
||
structurally — it does not depend on the larger `Expr`-elaboration
|
||
framework. Stated here for symmetry with the CType / CTerm
|
||
round-trips. -/
|
||
theorem reflectULevel_reifyULevel_roundtrip (ℓ : ULevel) :
|
||
(do let e ← reflectULevel ℓ; reifyULevel e) =
|
||
(pure (some ℓ) : MetaM (Option ULevel)) := by
|
||
-- waits on: meta-level reflection-roundtrip framework
|
||
-- (Expr-equality up to elaboration in a fixed Environment),
|
||
-- even though the structural recursion on `ℓ` is two-arm
|
||
-- and small, the `whnf` step in `reifyULevel` operates in
|
||
-- the elaborator monad and its image equation requires the
|
||
-- same framework as the CType / CTerm round-trips.
|
||
sorry
|
||
|
||
/-- Reflection preserves the CType-typing relationship: if the CTerm
|
||
`t` has CType `T` in the empty context (according to the engine's
|
||
`HasType` judgment), then there exist Lean Exprs `et` and `eT`
|
||
that are the reflections of `t` and `T` respectively, and they
|
||
stand in a corresponding meta-level typing relationship under
|
||
elaboration (i.e., `et : eT` once the Exprs are elaborated in a
|
||
context with the engine's namespace open).
|
||
|
||
The Lean-side typing-correspondence statement is:
|
||
|
||
HasType [] t T →
|
||
∃ (eT et : Expr),
|
||
(do let e1 ← reflectCType T
|
||
let e2 ← reflectCTerm t
|
||
pure (e1, e2)) = (pure (eT, et) : MetaM (Expr × Expr))
|
||
|
||
The substantive content (that `et : eT` after elaboration) lives
|
||
in the `MetaM`-equation: the reflected pair, evaluated in the
|
||
elaborator, must agree with the original `(T, t)` pair under the
|
||
encoding.
|
||
|
||
Proof depends on the same meta-level `Expr`-elaboration framework
|
||
that the round-trip theorems wait on. -/
|
||
theorem reflect_preserves_typing
|
||
{ℓ : ULevel} (t : CTerm) (T : CType ℓ)
|
||
(_h : HasType [] t T) :
|
||
∃ (eT et : Expr),
|
||
(do
|
||
let e1 ← CubicalTransport.Reflect.reflectCType T
|
||
let e2 ← CubicalTransport.Reflect.reflectCTerm t
|
||
pure (e1, e2)) = (pure (eT, et) : MetaM (Expr × Expr)) := by
|
||
-- waits on: a meta-level Expr-typing framework that reads the
|
||
-- elaborated types of `reflectCTerm t` and
|
||
-- `reflectCType T` and compares them. The current
|
||
-- statement asserts only the existence of the reflected
|
||
-- pair and an equation tying it to the literal pair; the
|
||
-- full `et : eT` correspondence requires the elaborator
|
||
-- framework to be available at the meta level.
|
||
sorry
|
||
|
||
end CubicalTransport.Reflect
|