imiel/iris
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Split neutrals from canonical values so stuck eliminators arent encoded via constructor overloading

Browse Source
This commit is contained in:
imiel
2026-04-19 15:03:40 +00:00
parent bb002a4d92
commit 963c9f3e94
5 changed files with 245 additions and 207 deletions
Download Patch File Download Diff File Expand all files Collapse all files
BidirTT/Check.lean
+4 -4
View File
@@ -14,7 +14,7 @@ private def showTy (l : Lvl) (v : Val) : String :=
mutual mutual
partial def check (cxt : Cxt) : Raw → Val → TCM Tm partial def check (cxt : Cxt) : Raw → Val → TCM Tm
| .lam x t, .pi a c => do | .lam x t, .pi a c => do
let bodyTy ← cApp c (.var cxt.lvl) let bodyTy ← cApp c (.neu (.var cxt.lvl))
let t' ← check (cxt.bind x a) t bodyTy let t' ← check (cxt.bind x a) t bodyTy
pure (.lam t') pure (.lam t')
| .pair t u, .sig a c => do | .pair t u, .sig a c => do
@@ -62,8 +62,8 @@ mutual
let zTy ← vApp vmotive .zero let zTy ← vApp vmotive .zero
let z' ← check cxt z zTy let z' ← check cxt z zTy
let kCxt := cxt.bind k .nat let kCxt := cxt.bind k .nat
let ihTy ← vApp vmotive (.var cxt.lvl) let ihTy ← vApp vmotive (.neu (.var cxt.lvl))
let stepTy ← vApp vmotive (.succ (.var cxt.lvl)) let stepTy ← vApp vmotive (.succ (.neu (.var cxt.lvl)))
let stepBody' ← check (kCxt.bind ih ihTy) s stepTy let stepBody' ← check (kCxt.bind ih ihTy) s stepTy
let step' : Tm := .lam (.lam stepBody') let step' : Tm := .lam (.lam stepBody')
let resultTy ← vApp vmotive vscrut let resultTy ← vApp vmotive vscrut
@@ -109,7 +109,7 @@ mutual
let vtarget ← eval cxt.env target' let vtarget ← eval cxt.env target'
if !(← conv cxt.lvl vtarget rhs) then if !(← conv cxt.lvl vtarget rhs) then
throw s!"idElim target {showTy cxt.lvl vtarget} does not match the equality endpoint {showTy cxt.lvl rhs}" throw s!"idElim target {showTy cxt.lvl vtarget} does not match the equality endpoint {showTy cxt.lvl rhs}"
let eqVarTy : Val := .id a x (.var cxt.lvl) let eqVarTy : Val := .id a x (.neu (.var cxt.lvl))
let (motiveBody', level) ← inferUniverse ((cxt.bind y a).bind p eqVarTy) motive let (motiveBody', level) ← inferUniverse ((cxt.bind y a).bind p eqVarTy) motive
let motive' : Tm := .lam (.lam motiveBody') let motive' : Tm := .lam (.lam motiveBody')
let vmotive ← eval cxt.env motive' let vmotive ← eval cxt.env motive'
BidirTT/Context.lean
+1 -1
View File
@@ -11,7 +11,7 @@ structure Cxt where
def Cxt.empty : Cxt := ⟨[], [], 0⟩ def Cxt.empty : Cxt := ⟨[], [], 0⟩
def Cxt.bind (cxt : Cxt) (x : Name) (a : Val) : Cxt := def Cxt.bind (cxt : Cxt) (x : Name) (a : Val) : Cxt :=
{ env := .var cxt.lvl :: cxt.env { env := .neu (.var cxt.lvl) :: cxt.env
, types := (x, a) :: cxt.types , types := (x, a) :: cxt.types
, lvl := cxt.lvl + 1 } , lvl := cxt.lvl + 1 }
BidirTT/Eval.lean
+102 -85
View File
@@ -74,15 +74,18 @@ mutual
partial def vApp : Val → Val → EvalM Val partial def vApp : Val → Val → EvalM Val
| .lam c, u => cApp c u | .lam c, u => cApp c u
| t, u => pure (.app t u) | .neu t, u => pure (.neu (.app t u))
| _, _ => throw "bad application head during evaluation"
partial def vFst : Val → EvalM Val partial def vFst : Val → EvalM Val
| .pair a _ => pure a | .pair a _ => pure a
| t => pure (.fst t) | .neu t => pure (.neu (.fst t))
| _ => throw "bad fst projection during evaluation"
partial def vSnd : Val → EvalM Val partial def vSnd : Val → EvalM Val
| .pair _ b => pure b | .pair _ b => pure b
| t => pure (.snd t) | .neu t => pure (.neu (.snd t))
| _ => throw "bad snd projection during evaluation"
partial def vNatElim : Val → Val → Val → Val → EvalM Val partial def vNatElim : Val → Val → Val → Val → EvalM Val
| _, z, _, .zero => pure z | _, z, _, .zero => pure z
@@ -90,93 +93,102 @@ mutual
let ih ← vNatElim m z s n let ih ← vNatElim m z s n
let step ← vApp s n let step ← vApp s n
vApp step ih vApp step ih
| m, z, s, n => pure (.natElim m z s n) | m, z, s, .neu n => pure (.neu (.natElim m z s n))
| _, _, _, _ => throw "bad Nat eliminand during evaluation"
partial def vUnitElim : Val → Val → Val → EvalM Val partial def vUnitElim : Val → Val → Val → EvalM Val
| _, t, .triv => pure t | _, t, .triv => pure t
| m, t, u => pure (.unitElim m t u) | m, t, .neu u => pure (.neu (.unitElim m t u))
| _, _, _ => throw "bad Unit eliminand during evaluation"
partial def vEmptyElim : Val → Val → EvalM Val partial def vEmptyElim : Val → Val → EvalM Val
| m, e => pure (.emptyElim m e) | m, .neu e => pure (.neu (.emptyElim m e))
| _, _ => throw "bad Empty eliminand during evaluation"
partial def vIdElim : Val → Val → Val → Val → EvalM Val partial def vIdElim : Val → Val → Val → Val → EvalM Val
| _, r, _, .refl => pure r | _, r, _, .refl => pure r
| m, r, y, p => pure (.idElim m r y p) | m, r, y, .neu p => pure (.neu (.idElim m r y p))
| _, _, _, _ => throw "bad Id eliminand during evaluation"
partial def cApp : Closure → Val → EvalM Val partial def cApp : Closure → Val → EvalM Val
| .mk env body, v => eval (v :: env) body | .mk env body, v => eval (v :: env) body
end end
partial def quote : Lvl → Val → EvalM Tm mutual
partial def quoteNeutral : Lvl → Neutral → EvalM Tm
| l, .var x => | l, .var x =>
if x < l then if x < l then
pure (.var (l - x - 1)) pure (.var (l - x - 1))
else else
throw s!"bad level {x} while quoting at level {l}" throw s!"bad level {x} while quoting at level {l}"
| l, .app t u => do | l, .app t u => do
let qt ← quote l t let qt ← quoteNeutral l t
let qu ← quote l u let qu ← quote l u
pure (.app qt qu) pure (.app qt qu)
| l, .fst t => do | l, .fst t => do
let qt ← quote l t let qt ← quoteNeutral l t
pure (.fst qt) pure (.fst qt)
| l, .snd t => do | l, .snd t => do
let qt ← quote l t let qt ← quoteNeutral l t
pure (.snd qt) pure (.snd qt)
| _, .nat => pure .nat
| _, .zero => pure .zero
| l, .succ t => do
let qt ← quote l t
pure (.succ qt)
| l, .natElim m z s n => do | l, .natElim m z s n => do
let qm ← quote l m let qm ← quote l m
let qz ← quote l z let qz ← quote l z
let qs ← quote l s let qs ← quote l s
let qn ← quote l n let qn ← quoteNeutral l n
pure (.natElim qm qz qs qn) pure (.natElim qm qz qs qn)
| _, .unit => pure .unit
| _, .triv => pure .triv
| l, .unitElim m t u => do | l, .unitElim m t u => do
let qm ← quote l m let qm ← quote l m
let qt ← quote l t let qt ← quote l t
let qu ← quote l u let qu ← quoteNeutral l u
pure (.unitElim qm qt qu) pure (.unitElim qm qt qu)
| _, .empty => pure .empty
| l, .emptyElim m e => do | l, .emptyElim m e => do
let qm ← quote l m let qm ← quote l m
let qe ← quote l e let qe ← quoteNeutral l e
pure (.emptyElim qm qe) pure (.emptyElim qm qe)
| l, .id a t u => do
let qa ← quote l a
let qt ← quote l t
let qu ← quote l u
pure (.id qa qt qu)
| _, .refl => pure .refl
| l, .idElim m r y p => do | l, .idElim m r y p => do
let qm ← quote l m let qm ← quote l m
let qr ← quote l r let qr ← quote l r
let qy ← quote l y let qy ← quote l y
let qp ← quote l p let qp ← quoteNeutral l p
pure (.idElim qm qr qy qp) pure (.idElim qm qr qy qp)
partial def quote : Lvl → Val → EvalM Tm
| l, .neu n => quoteNeutral l n
| l, .lam c => do | l, .lam c => do
let body ← cApp c (.var l) let body ← cApp c (.neu (.var l))
let qb ← quote (l + 1) body let qb ← quote (l + 1) body
pure (.lam qb) pure (.lam qb)
| l, .pi a c => do | l, .pi a c => do
let qa ← quote l a let qa ← quote l a
let body ← cApp c (.var l) let body ← cApp c (.neu (.var l))
let qb ← quote (l + 1) body let qb ← quote (l + 1) body
pure (.pi qa qb) pure (.pi qa qb)
| l, .sig a c => do | l, .sig a c => do
let qa ← quote l a let qa ← quote l a
let body ← cApp c (.var l) let body ← cApp c (.neu (.var l))
let qb ← quote (l + 1) body let qb ← quote (l + 1) body
pure (.sig qa qb) pure (.sig qa qb)
| l, .pair a b => do | l, .pair a b => do
let qa ← quote l a let qa ← quote l a
let qb ← quote l b let qb ← quote l b
pure (.pair qa qb) pure (.pair qa qb)
| _, .nat => pure .nat
| _, .zero => pure .zero
| l, .succ t => do
let qt ← quote l t
pure (.succ qt)
| _, .unit => pure .unit
| _, .triv => pure .triv
| _, .empty => pure .empty
| l, .id a t u => do
let qa ← quote l a
let qt ← quote l t
let qu ← quote l u
pure (.id qa qt qu)
| _, .refl => pure .refl
| _, .univ i => pure (.univ i) | _, .univ i => pure (.univ i)
end
private def andThen (lhs : EvalM Bool) (rhs : Unit → EvalM Bool) : EvalM Bool := do private def andThen (lhs : EvalM Bool) (rhs : Unit → EvalM Bool) : EvalM Bool := do
if (← lhs) then if (← lhs) then
@@ -184,44 +196,66 @@ private def andThen (lhs : EvalM Bool) (rhs : Unit → EvalM Bool) : EvalM Bool
else else
pure false pure false
partial def conv : Lvl → Val → Val → EvalM Bool mutual
| _, .univ i, .univ j => pure (i == j) partial def convNeutral : Lvl → Neutral → Neutral → EvalM Bool
| l, .pi a c, .pi a' c' => | _, .var x, .var y => pure (x == y)
andThen (conv l a a') fun _ => do | l, .app t u, .app t' u' =>
let b ← cApp c (.var l) andThen (convNeutral l t t') fun _ => conv l u u'
let b' ← cApp c' (.var l) | l, .fst t, .fst t' =>
conv (l + 1) b b' convNeutral l t t'
| l, .sig a c, .sig a' c' => | l, .snd t, .snd t' =>
andThen (conv l a a') fun _ => do convNeutral l t t'
let b ← cApp c (.var l)
let b' ← cApp c' (.var l)
conv (l + 1) b b'
| _, .nat, .nat => pure true
| _, .zero, .zero => pure true
| l, .succ n, .succ n' => conv l n n'
| l, .natElim m z s n, .natElim m' z' s' n' => | l, .natElim m z s n, .natElim m' z' s' n' =>
andThen (conv l m m') fun _ => do andThen (conv l m m') fun _ => do
let sameZ ← conv l z z' let sameZ ← conv l z z'
if sameZ then if sameZ then
let sameS ← conv l s s' let sameS ← conv l s s'
if sameS then if sameS then
conv l n n' convNeutral l n n'
else else
pure false pure false
else else
pure false pure false
| _, .unit, .unit => pure true
| _, .triv, .triv => pure true
| l, .unitElim m t u, .unitElim m' t' u' => | l, .unitElim m t u, .unitElim m' t' u' =>
andThen (conv l m m') fun _ => do andThen (conv l m m') fun _ => do
let sameT ← conv l t t' let sameT ← conv l t t'
if sameT then if sameT then
conv l u u' convNeutral l u u'
else else
pure false pure false
| _, .empty, .empty => pure true
| l, .emptyElim m e, .emptyElim m' e' => | l, .emptyElim m e, .emptyElim m' e' =>
andThen (conv l m m') fun _ => conv l e e' andThen (conv l m m') fun _ => convNeutral l e e'
| l, .idElim m r y p, .idElim m' r' y' p' =>
andThen (conv l m m') fun _ => do
let sameR ← conv l r r'
if sameR then
let sameY ← conv l y y'
if sameY then
convNeutral l p p'
else
pure false
else
pure false
| _, _, _ => pure false
partial def conv : Lvl → Val → Val → EvalM Bool
| _, .univ i, .univ j => pure (i == j)
| l, .pi a c, .pi a' c' =>
andThen (conv l a a') fun _ => do
let b ← cApp c (.neu (.var l))
let b' ← cApp c' (.neu (.var l))
conv (l + 1) b b'
| l, .sig a c, .sig a' c' =>
andThen (conv l a a') fun _ => do
let b ← cApp c (.neu (.var l))
let b' ← cApp c' (.neu (.var l))
conv (l + 1) b b'
| _, .nat, .nat => pure true
| _, .zero, .zero => pure true
| l, .succ n, .succ n' => conv l n n'
| _, .unit, .unit => pure true
| _, .triv, .triv => pure true
| _, .empty, .empty => pure true
| l, .id a t u, .id a' t' u' => | l, .id a t u, .id a' t' u' =>
andThen (conv l a a') fun _ => do andThen (conv l a a') fun _ => do
let sameT ← conv l t t' let sameT ← conv l t t'
@@ -230,31 +264,17 @@ partial def conv : Lvl → Val → Val → EvalM Bool
else else
pure false pure false
| _, .refl, .refl => pure true | _, .refl, .refl => pure true
| l, .idElim m r y p, .idElim m' r' y' p' => | l, .lam c, .lam c' => do
andThen (conv l m m') fun _ => do let body ← cApp c (.neu (.var l))
let sameR ← conv l r r' let body' ← cApp c' (.neu (.var l))
if sameR then
let sameY ← conv l y y'
if sameY then
conv l p p'
else
pure false
else
pure false
| l, .lam c, .lam c' =>
do
let body ← cApp c (.var l)
let body' ← cApp c' (.var l)
conv (l + 1) body body' conv (l + 1) body body'
| l, .lam c, t => | l, .lam c, t => do
do let body ← cApp c (.neu (.var l))
let body ← cApp c (.var l) let apped ← vApp t (.neu (.var l))
let apped ← vApp t (.var l)
conv (l + 1) body apped conv (l + 1) body apped
| l, t, .lam c => | l, t, .lam c => do
do let apped ← vApp t (.neu (.var l))
let apped ← vApp t (.var l) let body ← cApp c (.neu (.var l))
let body ← cApp c (.var l)
conv (l + 1) apped body conv (l + 1) apped body
| l, .pair a b, .pair a' b' => | l, .pair a b, .pair a' b' =>
andThen (conv l a a') fun _ => conv l b b' andThen (conv l a a') fun _ => conv l b b'
@@ -274,24 +294,21 @@ partial def conv : Lvl → Val → Val → EvalM Bool
fun _ => do fun _ => do
let sndp ← vSnd p let sndp ← vSnd p
conv l sndp b conv l sndp b
| _, .var x, .var y => pure (x == y) | l, .neu n, .neu n' => convNeutral l n n'
| l, .app t u, .app t' u' =>
andThen (conv l t t') fun _ => conv l u u'
| l, .fst t, .fst t' => conv l t t'
| l, .snd t, .snd t' => conv l t t'
| _, _, _ => pure false | _, _, _ => pure false
end
partial def sub : Lvl → Val → Val → EvalM Bool partial def sub : Lvl → Val → Val → EvalM Bool
| _, .univ i, .univ j => pure (i <= j) | _, .univ i, .univ j => pure (i <= j)
| l, .pi a c, .pi a' c' => | l, .pi a c, .pi a' c' =>
andThen (sub l a' a) fun _ => do andThen (sub l a' a) fun _ => do
let b ← cApp c (.var l) let b ← cApp c (.neu (.var l))
let b' ← cApp c' (.var l) let b' ← cApp c' (.neu (.var l))
sub (l + 1) b b' sub (l + 1) b b'
| l, .sig a c, .sig a' c' => | l, .sig a c, .sig a' c' =>
andThen (sub l a a') fun _ => do andThen (sub l a a') fun _ => do
let b ← cApp c (.var l) let b ← cApp c (.neu (.var l))
let b' ← cApp c' (.var l) let b' ← cApp c' (.neu (.var l))
sub (l + 1) b b' sub (l + 1) b b'
| l, t, t' => conv l t t' | l, t, t' => conv l t t'
BidirTT/Value.lean
+12 -8
View File
@@ -3,11 +3,18 @@ import BidirTT.Syntax
namespace BidirTT namespace BidirTT
mutual mutual
inductive Neutral where
| var : Nat → Neutral
| app : Neutral → Val → Neutral
| fst : Neutral → Neutral
| snd : Neutral → Neutral
| natElim : Val → Val → Val → Neutral → Neutral
| unitElim : Val → Val → Neutral → Neutral
| emptyElim : Val → Neutral → Neutral
| idElim : Val → Val → Val → Neutral → Neutral
inductive Val where inductive Val where
| var : Nat → Val | neu : Neutral → Val
| app : Val → Val → Val
| fst : Val → Val
| snd : Val → Val
| lam : Closure → Val | lam : Closure → Val
| pi : Val → Closure → Val | pi : Val → Closure → Val
| sig : Val → Closure → Val | sig : Val → Closure → Val
@@ -15,15 +22,11 @@ mutual
| nat : Val | nat : Val
| zero : Val | zero : Val
| succ : Val → Val | succ : Val → Val
| natElim : Val → Val → Val → Val → Val
| unit : Val | unit : Val
| triv : Val | triv : Val
| unitElim : Val → Val → Val → Val
| empty : Val | empty : Val
| emptyElim : Val → Val → Val
| id : Val → Val → Val → Val | id : Val → Val → Val → Val
| refl : Val | refl : Val
| idElim : Val → Val → Val → Val → Val
| univ : Nat → Val | univ : Nat → Val
inductive Closure where inductive Closure where
@@ -33,6 +36,7 @@ end
abbrev Env := List Val abbrev Env := List Val
abbrev Lvl := Nat abbrev Lvl := Nat
instance : Inhabited Neutral := ⟨.var 0⟩
instance : Inhabited Val := ⟨.univ 0⟩ instance : Inhabited Val := ⟨.univ 0⟩
instance : Inhabited Closure := ⟨.mk [] (.univ 0)⟩ instance : Inhabited Closure := ⟨.mk [] (.univ 0)⟩
Tests.lean
+39 -22
View File
@@ -84,52 +84,52 @@ def runCase (tc : TestCase) : IO Bool := do
match renderType ty with match renderType ty with
| Except.ok actualTy => | Except.ok actualTy =>
if actualTy == expectedTy then if actualTy == expectedTy then
IO.println s!"PASS {tc.name}" IO.println s!"pass {tc.name}"
pure true pure true
else else
IO.println s!"FAIL {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got {BidirTT.prettyTm actualTy})" IO.println s!"fail {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got {BidirTT.prettyTm actualTy})"
pure false pure false
| Except.error err => | Except.error err =>
IO.println s!"FAIL {tc.name} (could not quote type: {err})" IO.println s!"fail {tc.name} (could not quote type: {err})"
pure false pure false
| .okTyNorm expectedTy expectedNf, .ok (tm, ty) => | .okTyNorm expectedTy expectedNf, .ok (tm, ty) =>
match renderType ty, renderNormal tm with match renderType ty, renderNormal tm with
| Except.ok actualTy, Except.ok actualNf => | Except.ok actualTy, Except.ok actualNf =>
if actualTy == expectedTy && actualNf == expectedNf then if actualTy == expectedTy && actualNf == expectedNf then
IO.println s!"PASS {tc.name}" IO.println s!"pass {tc.name}"
pure true pure true
else if actualTy != expectedTy then else if actualTy != expectedTy then
IO.println s!"FAIL {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got {BidirTT.prettyTm actualTy})" IO.println s!"fail {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got {BidirTT.prettyTm actualTy})"
pure false pure false
else else
IO.println s!"FAIL {tc.name} (expected nf {BidirTT.prettyTm expectedNf}, got {BidirTT.prettyTm actualNf})" IO.println s!"fail {tc.name} (expected nf {BidirTT.prettyTm expectedNf}, got {BidirTT.prettyTm actualNf})"
pure false pure false
| Except.error err, _ => | Except.error err, _ =>
IO.println s!"FAIL {tc.name} (could not quote type: {err})" IO.println s!"fail {tc.name} (could not quote type: {err})"
pure false pure false
| _, Except.error err => | _, Except.error err =>
IO.println s!"FAIL {tc.name} (could not normalize term: {err})" IO.println s!"fail {tc.name} (could not normalize term: {err})"
pure false pure false
| .okTy expectedTy, .error err => | .okTy expectedTy, .error err =>
IO.println s!"FAIL {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got error {err})" IO.println s!"fail {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got error {err})"
pure false pure false
| .okTyNorm expectedTy _, .error err => | .okTyNorm expectedTy _, .error err =>
IO.println s!"FAIL {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got error {err})" IO.println s!"fail {tc.name} (expected type {BidirTT.prettyTm expectedTy}, got error {err})"
pure false pure false
| .errContains needle, .error err => | .errContains needle, .error err =>
if containsText err needle then if containsText err needle then
IO.println s!"PASS {tc.name}" IO.println s!"pass {tc.name}"
pure true pure true
else else
IO.println s!"FAIL {tc.name} (expected error containing {needle}, got {err})" IO.println s!"fail {tc.name} (expected error containing {needle}, got {err})"
pure false pure false
| .errContains needle, .ok (_, ty) => | .errContains needle, .ok (_, ty) =>
match renderType ty with match renderType ty with
| Except.ok actualTy => | Except.ok actualTy =>
IO.println s!"FAIL {tc.name} (expected error containing {needle}, got type {BidirTT.prettyTm actualTy})" IO.println s!"fail {tc.name} (expected error containing {needle}, got type {BidirTT.prettyTm actualTy})"
pure false pure false
| Except.error err => | Except.error err =>
IO.println s!"FAIL {tc.name} (expected error containing {needle}, got quote failure {err})" IO.println s!"fail {tc.name} (expected error containing {needle}, got quote failure {err})"
pure false pure false
def runInternalSafetyChecks : IO Bool := do def runInternalSafetyChecks : IO Bool := do
@@ -138,14 +138,30 @@ def runInternalSafetyChecks : IO Bool := do
| Except.error err => containsText err "bad de Bruijn index 0" | Except.error err => containsText err "bad de Bruijn index 0"
| Except.ok _ => false | Except.ok _ => false
let malformedQuoteOk := let malformedQuoteOk :=
match quote 0 (.var 0) with match quote 0 (.neu (.var 0)) with
| Except.error err => containsText err "bad level 0" | Except.error err => containsText err "bad level 0"
| Except.ok _ => false | Except.ok _ => false
if malformedEvalOk && malformedQuoteOk then if malformedEvalOk && malformedQuoteOk then
IO.println "PASS malformed core terms are rejected safely" IO.println "pass malformed core terms are rejected safely"
pure true pure true
else else
IO.println "FAIL malformed core terms are rejected safely" IO.println "fail malformed core terms are rejected safely"
pure false
def runNeutralRepresentationChecks : IO Bool := do
let stuckAppOk :=
match vApp (.neu (.var 0)) .zero with
| Except.ok (.neu (.app (.var 0) .zero)) => true
| _ => false
let stuckNatElimOk :=
match vNatElim .nat .zero (.neu (.var 1)) (.neu (.var 0)) with
| Except.ok (.neu (.natElim .nat .zero (.neu (.var 1)) (.var 0))) => true
| _ => false
if stuckAppOk && stuckNatElimOk then
IO.println "pass stuck eliminators stay in the neutral fragment"
pure true
else
IO.println "fail stuck eliminators stay in the neutral fragment"
pure false pure false
def runPrettyPrinterChecks : IO Bool := do def runPrettyPrinterChecks : IO Bool := do
@@ -160,23 +176,24 @@ def runPrettyPrinterChecks : IO Bool := do
containsText typeText "Pi (x0 : U0)" && containsText typeText "Pi (x0 : U0)" &&
!containsText typeText "#" !containsText typeText "#"
if ok then if ok then
IO.println "PASS pretty printer rehydrates binder names" IO.println "pass pretty printer rehydrates binder names"
pure true pure true
else else
IO.println s!"FAIL pretty printer rehydrates binder names (term: {termText}, type: {typeText})" IO.println s!"fail pretty printer rehydrates binder names (term: {termText}, type: {typeText})"
pure false pure false
| Except.error err => | Except.error err =>
IO.println s!"FAIL pretty printer rehydrates binder names (could not quote type: {err})" IO.println s!"fail pretty printer rehydrates binder names (could not quote type: {err})"
pure false pure false
| .error err => | .error err =>
IO.println s!"FAIL pretty printer rehydrates binder names (could not elaborate fixture: {err})" IO.println s!"fail pretty printer rehydrates binder names (could not elaborate fixture: {err})"
pure false pure false
def main : IO UInt32 := do def main : IO UInt32 := do
let results ← cases.mapM runCase let results ← cases.mapM runCase
let safetyOk ← runInternalSafetyChecks let safetyOk ← runInternalSafetyChecks
let neutralOk ← runNeutralRepresentationChecks
let prettyOk ← runPrettyPrinterChecks let prettyOk ← runPrettyPrinterChecks
let allResults := results ++ [safetyOk, prettyOk] let allResults := results ++ [safetyOk, neutralOk, prettyOk]
let failed := allResults.countP (· == false) let failed := allResults.countP (· == false)
if failed == 0 then if failed == 0 then
IO.println s!"\n{allResults.length} passed, 0 failed" IO.println s!"\n{allResults.length} passed, 0 failed"