feat: Printing field projection in sexp
This commit is contained in:
parent
3a26bb1924
commit
8ce4cbdcf5
|
@ -14,25 +14,25 @@ namespace Pantograph
|
||||||
|
|
||||||
inductive Projection where
|
inductive Projection where
|
||||||
-- Normal field case
|
-- Normal field case
|
||||||
| field (projector : Name) (numParams : Nat) (struct : Expr)
|
| field (projector : Name) (numParams : Nat)
|
||||||
-- Singular inductive case
|
-- Singular inductive case
|
||||||
| singular (recursor : Name) (numParams : Nat) (struct : Expr)
|
| singular (recursor : Name) (numParams : Nat)
|
||||||
|
|
||||||
/-- Converts a `.proj` expression to a form suitable for exporting/transpilation -/
|
/-- Converts a `.proj` expression to a form suitable for exporting/transpilation -/
|
||||||
@[export pantograph_analyze_projection]
|
@[export pantograph_analyze_projection]
|
||||||
def analyzeProjection (env: Environment) (e: Expr): Projection :=
|
def analyzeProjection (env: Environment) (e: Expr): Projection :=
|
||||||
let (typeName, idx, struct) := match e with
|
let (typeName, idx, _) := match e with
|
||||||
| .proj typeName idx struct => (typeName, idx, struct)
|
| .proj typeName idx struct => (typeName, idx, struct)
|
||||||
| _ => panic! "Argument must be proj"
|
| _ => panic! "Argument must be proj"
|
||||||
if (getStructureInfo? env typeName).isSome then
|
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!
|
||||||
.field projector ctor.numParams struct
|
.field projector ctor.numParams
|
||||||
else
|
else
|
||||||
let recursor := mkRecOnName typeName
|
let recursor := mkRecOnName typeName
|
||||||
let ctor := getStructureCtor env typeName
|
let ctor := getStructureCtor env typeName
|
||||||
.singular recursor ctor.numParams struct
|
.singular recursor ctor.numParams
|
||||||
|
|
||||||
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") _
|
||||||
|
|
||||||
|
@ -291,7 +291,7 @@ partial def serializeSortLevel (level: Level) : String :=
|
||||||
| _, .zero => s!"{k}"
|
| _, .zero => s!"{k}"
|
||||||
| _, _ => s!"(+ {u_str} {k})"
|
| _, _ => s!"(+ {u_str} {k})"
|
||||||
|
|
||||||
|
#check Exists.recOn
|
||||||
/--
|
/--
|
||||||
Completely serializes an expression tree. Json not used due to compactness
|
Completely serializes an expression tree. Json not used due to compactness
|
||||||
|
|
||||||
|
@ -378,7 +378,14 @@ partial def serializeExpressionSexp (expr: Expr) : MetaM String := do
|
||||||
-- NOTE: Equivalent to expr itself, but mdata influences the prettyprinter
|
-- NOTE: Equivalent to expr itself, but mdata influences the prettyprinter
|
||||||
-- It may become necessary to incorporate the metadata.
|
-- It may become necessary to incorporate the metadata.
|
||||||
self inner
|
self inner
|
||||||
| .proj typeName idx e => do
|
| .proj typeName idx inner => do
|
||||||
|
let env ← getEnv
|
||||||
|
match analyzeProjection env e with
|
||||||
|
| .field projector numParams =>
|
||||||
|
let autos := String.intercalate " " (List.replicate numParams "_")
|
||||||
|
let inner' ← self inner
|
||||||
|
pure s!"((:c {projector}) {autos} {inner'})"
|
||||||
|
| .singular _ _ =>
|
||||||
let typeName' := serializeName typeName (sanitize := false)
|
let typeName' := serializeName typeName (sanitize := false)
|
||||||
let e' ← self e
|
let e' ← self e
|
||||||
pure s!"(:proj {typeName'} {idx} {e'})"
|
pure s!"(:proj {typeName'} {idx} {e'})"
|
||||||
|
|
|
@ -77,7 +77,7 @@ def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do
|
||||||
.default)
|
.default)
|
||||||
.implicit)
|
.implicit)
|
||||||
.implicit,
|
.implicit,
|
||||||
"(:lambda p (:sort 0) (:lambda q (:sort 0) (:lambda k ((:c And) 1 0) (:proj And 1 0)) :i) :i)"
|
"(:lambda p (:sort 0) (:lambda q (:sort 0) (:lambda k ((:c And) 1 0) ((:c And.right) _ _ 0)) :i) :i)"
|
||||||
),
|
),
|
||||||
]
|
]
|
||||||
let termElabM: Elab.TermElabM LSpec.TestSeq := entries.foldlM (λ suites (expr, target) => do
|
let termElabM: Elab.TermElabM LSpec.TestSeq := entries.foldlM (λ suites (expr, target) => do
|
||||||
|
@ -99,20 +99,18 @@ def test_instance (env: Environment): IO LSpec.TestSeq :=
|
||||||
def test_projection_prod (env: Environment) : IO LSpec.TestSeq:= runTest do
|
def test_projection_prod (env: Environment) : IO LSpec.TestSeq:= runTest do
|
||||||
let struct := .app (.bvar 1) (.bvar 0)
|
let struct := .app (.bvar 1) (.bvar 0)
|
||||||
let expr := .proj `Prod 1 struct
|
let expr := .proj `Prod 1 struct
|
||||||
let .field projector numParams struct' := analyzeProjection env expr |
|
let .field projector numParams := analyzeProjection env expr |
|
||||||
fail "`Prod has fields"
|
fail "`Prod has fields"
|
||||||
checkEq "projector" projector `Prod.snd
|
checkEq "projector" projector `Prod.snd
|
||||||
checkEq "numParams" numParams 2
|
checkEq "numParams" numParams 2
|
||||||
checkTrue "struct" $ struct.equal struct'
|
|
||||||
|
|
||||||
def test_projection_exists (env: Environment) : IO LSpec.TestSeq:= runTest do
|
def test_projection_exists (env: Environment) : IO LSpec.TestSeq:= runTest do
|
||||||
let struct := .app (.bvar 1) (.bvar 0)
|
let struct := .app (.bvar 1) (.bvar 0)
|
||||||
let expr := .proj `Exists 1 struct
|
let expr := .proj `Exists 1 struct
|
||||||
let .singular recursor numParams struct' := analyzeProjection env expr |
|
let .singular recursor numParams := analyzeProjection env expr |
|
||||||
fail "`Exists has no projectors"
|
fail "`Exists has no projectors"
|
||||||
checkEq "recursor" recursor `Exists.recOn
|
checkEq "recursor" recursor `Exists.recOn
|
||||||
checkEq "numParams" numParams 2
|
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) :=
|
||||||
[
|
[
|
||||||
|
|
Loading…
Reference in New Issue