fix: Analyze projection application

This commit is contained in:
Leni Aniva 2025-01-22 12:49:33 -08:00
parent 5994f0ddf0
commit 3a26bb1924
Signed by: aniva
GPG Key ID: 4D9B1C8D10EA4C50
2 changed files with 35 additions and 28 deletions

View File

@ -12,27 +12,27 @@ open Lean
namespace Pantograph namespace Pantograph
structure ProjectionApplication where inductive Projection where
projector: Name -- Normal field case
numParams: Nat | field (projector : Name) (numParams : Nat) (struct : Expr)
inner: Expr -- Singular inductive case
| singular (recursor : Name) (numParams : Nat) (struct : Expr)
/-- Converts a `.proj` expression to a function application if possible. Not all /-- Converts a `.proj` expression to a form suitable for exporting/transpilation -/
such expressions are convertible. -/ @[export pantograph_analyze_projection]
@[export pantograph_expr_proj_to_app] def analyzeProjection (env: Environment) (e: Expr): Projection :=
def exprProjToApp (env: Environment) (e: Expr): Option ProjectionApplication := do let (typeName, idx, struct) := match e with
let (typeName, idx, inner) := match e with | .proj typeName idx struct => (typeName, idx, struct)
| .proj typeName idx inner => (typeName, idx, inner)
| _ => panic! "Argument must be proj" | _ => panic! "Argument must be proj"
let _ ← getStructureInfo? env typeName if (getStructureInfo? env typeName).isSome then
let ctor := getStructureCtor env typeName let ctor := getStructureCtor env typeName
let fieldName := getStructureFields env typeName |>.get! idx let fieldName := getStructureFields env typeName |>.get! idx
let projector := getProjFnForField? env typeName fieldName |>.get! let projector := getProjFnForField? env typeName fieldName |>.get!
return { .field projector ctor.numParams struct
projector, else
numParams := ctor.numParams, let recursor := mkRecOnName typeName
inner, let ctor := getStructureCtor env typeName
} .singular recursor ctor.numParams struct
def _root_.Lean.Name.isAuxLemma (n : Lean.Name) : Bool := n matches .num (.str _ "_auxLemma") _ def _root_.Lean.Name.isAuxLemma (n : Lean.Name) : Bool := n matches .num (.str _ "_auxLemma") _

View File

@ -96,17 +96,23 @@ def test_instance (env: Environment): IO LSpec.TestSeq :=
let _expr := (← runTermElabMInMeta <| elabTerm s) |>.toOption |>.get! let _expr := (← runTermElabMInMeta <| elabTerm s) |>.toOption |>.get!
return LSpec.TestSeq.done return LSpec.TestSeq.done
def test_projection (env: Environment) : IO LSpec.TestSeq:= runTest do def test_projection_prod (env: Environment) : IO LSpec.TestSeq:= runTest do
let prod := .app (.bvar 1) (.bvar 0) let struct := .app (.bvar 1) (.bvar 0)
let expr := .proj `Prod 1 prod let expr := .proj `Prod 1 struct
let .some { projector, numParams, inner }:= exprProjToApp env expr | let .field projector numParams struct' := analyzeProjection env expr |
fail "`Prod should have projection function" fail "`Prod has fields"
checkEq "projector" projector `Prod.snd checkEq "projector" projector `Prod.snd
checkEq "numParams" numParams 2 checkEq "numParams" numParams 2
checkTrue "inner" $ inner.equal prod checkTrue "struct" $ struct.equal struct'
let expr := .proj `Exists 1 prod def test_projection_exists (env: Environment) : IO LSpec.TestSeq:= runTest do
checkTrue "Exists" (exprProjToApp env expr).isNone let struct := .app (.bvar 1) (.bvar 0)
let expr := .proj `Exists 1 struct
let .singular recursor numParams struct' := analyzeProjection env expr |
fail "`Exists has no projectors"
checkEq "recursor" recursor `Exists.recOn
checkEq "numParams" numParams 2
checkTrue "struct" $ struct.equal struct'
def suite (env: Environment): List (String × IO LSpec.TestSeq) := def suite (env: Environment): List (String × IO LSpec.TestSeq) :=
[ [
@ -116,7 +122,8 @@ def suite (env: Environment): List (String × IO LSpec.TestSeq) :=
("Sexp from elaborated expr", test_sexp_of_elab env), ("Sexp from elaborated expr", test_sexp_of_elab env),
("Sexp from expr", test_sexp_of_expr env), ("Sexp from expr", test_sexp_of_expr env),
("Instance", test_instance env), ("Instance", test_instance env),
("Projection", test_projection env), ("Projection Prod", test_projection_prod env),
("Projection Exists", test_projection_exists env),
] ]
end Pantograph.Test.Delate end Pantograph.Test.Delate