Split neutrals from canonical values so stuck eliminators arent encoded via constructor overloading
This commit is contained in:
+189
-172
@@ -73,16 +73,19 @@ mutual
|
||||
eval (vt :: env) u
|
||||
|
||||
partial def vApp : Val → Val → EvalM Val
|
||||
| .lam c, u => cApp c u
|
||||
| t, u => pure (.app t u)
|
||||
| .lam c, u => cApp c u
|
||||
| .neu t, u => pure (.neu (.app t u))
|
||||
| _, _ => throw "bad application head during evaluation"
|
||||
|
||||
partial def vFst : Val → EvalM Val
|
||||
| .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
|
||||
| .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
|
||||
| _, z, _, .zero => pure z
|
||||
@@ -90,93 +93,102 @@ mutual
|
||||
let ih ← vNatElim m z s n
|
||||
let step ← vApp s n
|
||||
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
|
||||
| _, t, .triv => pure t
|
||||
| m, t, u => pure (.unitElim m t u)
|
||||
| _, t, .triv => pure t
|
||||
| m, t, .neu u => pure (.neu (.unitElim m t u))
|
||||
| _, _, _ => throw "bad Unit eliminand during evaluation"
|
||||
|
||||
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
|
||||
| _, 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
|
||||
| .mk env body, v => eval (v :: env) body
|
||||
end
|
||||
|
||||
partial def quote : Lvl → Val → EvalM Tm
|
||||
| l, .var x =>
|
||||
if x < l then
|
||||
pure (.var (l - x - 1))
|
||||
else
|
||||
throw s!"bad level {x} while quoting at level {l}"
|
||||
| l, .app t u => do
|
||||
let qt ← quote l t
|
||||
let qu ← quote l u
|
||||
pure (.app qt qu)
|
||||
| l, .fst t => do
|
||||
let qt ← quote l t
|
||||
pure (.fst qt)
|
||||
| l, .snd t => do
|
||||
let qt ← quote l t
|
||||
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
|
||||
let qm ← quote l m
|
||||
let qz ← quote l z
|
||||
let qs ← quote l s
|
||||
let qn ← quote l n
|
||||
pure (.natElim qm qz qs qn)
|
||||
| _, .unit => pure .unit
|
||||
| _, .triv => pure .triv
|
||||
| l, .unitElim m t u => do
|
||||
let qm ← quote l m
|
||||
let qt ← quote l t
|
||||
let qu ← quote l u
|
||||
pure (.unitElim qm qt qu)
|
||||
| _, .empty => pure .empty
|
||||
| l, .emptyElim m e => do
|
||||
let qm ← quote l m
|
||||
let qe ← quote l e
|
||||
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
|
||||
let qm ← quote l m
|
||||
let qr ← quote l r
|
||||
let qy ← quote l y
|
||||
let qp ← quote l p
|
||||
pure (.idElim qm qr qy qp)
|
||||
| l, .lam c => do
|
||||
let body ← cApp c (.var l)
|
||||
let qb ← quote (l + 1) body
|
||||
pure (.lam qb)
|
||||
| l, .pi a c => do
|
||||
let qa ← quote l a
|
||||
let body ← cApp c (.var l)
|
||||
let qb ← quote (l + 1) body
|
||||
pure (.pi qa qb)
|
||||
| l, .sig a c => do
|
||||
let qa ← quote l a
|
||||
let body ← cApp c (.var l)
|
||||
let qb ← quote (l + 1) body
|
||||
pure (.sig qa qb)
|
||||
| l, .pair a b => do
|
||||
let qa ← quote l a
|
||||
let qb ← quote l b
|
||||
pure (.pair qa qb)
|
||||
| _, .univ i => pure (.univ i)
|
||||
mutual
|
||||
partial def quoteNeutral : Lvl → Neutral → EvalM Tm
|
||||
| l, .var x =>
|
||||
if x < l then
|
||||
pure (.var (l - x - 1))
|
||||
else
|
||||
throw s!"bad level {x} while quoting at level {l}"
|
||||
| l, .app t u => do
|
||||
let qt ← quoteNeutral l t
|
||||
let qu ← quote l u
|
||||
pure (.app qt qu)
|
||||
| l, .fst t => do
|
||||
let qt ← quoteNeutral l t
|
||||
pure (.fst qt)
|
||||
| l, .snd t => do
|
||||
let qt ← quoteNeutral l t
|
||||
pure (.snd qt)
|
||||
| l, .natElim m z s n => do
|
||||
let qm ← quote l m
|
||||
let qz ← quote l z
|
||||
let qs ← quote l s
|
||||
let qn ← quoteNeutral l n
|
||||
pure (.natElim qm qz qs qn)
|
||||
| l, .unitElim m t u => do
|
||||
let qm ← quote l m
|
||||
let qt ← quote l t
|
||||
let qu ← quoteNeutral l u
|
||||
pure (.unitElim qm qt qu)
|
||||
| l, .emptyElim m e => do
|
||||
let qm ← quote l m
|
||||
let qe ← quoteNeutral l e
|
||||
pure (.emptyElim qm qe)
|
||||
| l, .idElim m r y p => do
|
||||
let qm ← quote l m
|
||||
let qr ← quote l r
|
||||
let qy ← quote l y
|
||||
let qp ← quoteNeutral l p
|
||||
pure (.idElim qm qr qy qp)
|
||||
|
||||
partial def quote : Lvl → Val → EvalM Tm
|
||||
| l, .neu n => quoteNeutral l n
|
||||
| l, .lam c => do
|
||||
let body ← cApp c (.neu (.var l))
|
||||
let qb ← quote (l + 1) body
|
||||
pure (.lam qb)
|
||||
| l, .pi a c => do
|
||||
let qa ← quote l a
|
||||
let body ← cApp c (.neu (.var l))
|
||||
let qb ← quote (l + 1) body
|
||||
pure (.pi qa qb)
|
||||
| l, .sig a c => do
|
||||
let qa ← quote l a
|
||||
let body ← cApp c (.neu (.var l))
|
||||
let qb ← quote (l + 1) body
|
||||
pure (.sig qa qb)
|
||||
| l, .pair a b => do
|
||||
let qa ← quote l a
|
||||
let qb ← quote l b
|
||||
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)
|
||||
end
|
||||
|
||||
private def andThen (lhs : EvalM Bool) (rhs : Unit → EvalM Bool) : EvalM Bool := do
|
||||
if (← lhs) then
|
||||
@@ -184,114 +196,119 @@ private def andThen (lhs : EvalM Bool) (rhs : Unit → EvalM Bool) : EvalM Bool
|
||||
else
|
||||
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 (.var l)
|
||||
let b' ← cApp c' (.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 (.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' =>
|
||||
andThen (conv l m m') fun _ => do
|
||||
let sameZ ← conv l z z'
|
||||
if sameZ then
|
||||
let sameS ← conv l s s'
|
||||
if sameS then
|
||||
conv l n n'
|
||||
mutual
|
||||
partial def convNeutral : Lvl → Neutral → Neutral → EvalM Bool
|
||||
| _, .var x, .var y => pure (x == y)
|
||||
| l, .app t u, .app t' u' =>
|
||||
andThen (convNeutral l t t') fun _ => conv l u u'
|
||||
| l, .fst t, .fst t' =>
|
||||
convNeutral l t t'
|
||||
| l, .snd t, .snd t' =>
|
||||
convNeutral l t t'
|
||||
| l, .natElim m z s n, .natElim m' z' s' n' =>
|
||||
andThen (conv l m m') fun _ => do
|
||||
let sameZ ← conv l z z'
|
||||
if sameZ then
|
||||
let sameS ← conv l s s'
|
||||
if sameS then
|
||||
convNeutral l n n'
|
||||
else
|
||||
pure false
|
||||
else
|
||||
pure false
|
||||
else
|
||||
pure false
|
||||
| _, .unit, .unit => pure true
|
||||
| _, .triv, .triv => pure true
|
||||
| l, .unitElim m t u, .unitElim m' t' u' =>
|
||||
andThen (conv l m m') fun _ => do
|
||||
let sameT ← conv l t t'
|
||||
if sameT then
|
||||
conv l u u'
|
||||
else
|
||||
pure false
|
||||
| _, .empty, .empty => pure true
|
||||
| l, .emptyElim m e, .emptyElim m' e' =>
|
||||
andThen (conv l m m') fun _ => conv l e e'
|
||||
| l, .id a t u, .id a' t' u' =>
|
||||
andThen (conv l a a') fun _ => do
|
||||
let sameT ← conv l t t'
|
||||
if sameT then
|
||||
conv l u u'
|
||||
else
|
||||
pure false
|
||||
| _, .refl, .refl => pure true
|
||||
| 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
|
||||
conv l p p'
|
||||
| l, .unitElim m t u, .unitElim m' t' u' =>
|
||||
andThen (conv l m m') fun _ => do
|
||||
let sameT ← conv l t t'
|
||||
if sameT then
|
||||
convNeutral l u u'
|
||||
else
|
||||
pure false
|
||||
else
|
||||
pure false
|
||||
| l, .lam c, .lam c' =>
|
||||
do
|
||||
let body ← cApp c (.var l)
|
||||
let body' ← cApp c' (.var l)
|
||||
| l, .emptyElim m e, .emptyElim m' 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' =>
|
||||
andThen (conv l a a') fun _ => do
|
||||
let sameT ← conv l t t'
|
||||
if sameT then
|
||||
conv l u u'
|
||||
else
|
||||
pure false
|
||||
| _, .refl, .refl => pure true
|
||||
| l, .lam c, .lam c' => do
|
||||
let body ← cApp c (.neu (.var l))
|
||||
let body' ← cApp c' (.neu (.var l))
|
||||
conv (l + 1) body body'
|
||||
| l, .lam c, t =>
|
||||
do
|
||||
let body ← cApp c (.var l)
|
||||
let apped ← vApp t (.var l)
|
||||
| l, .lam c, t => do
|
||||
let body ← cApp c (.neu (.var l))
|
||||
let apped ← vApp t (.neu (.var l))
|
||||
conv (l + 1) body apped
|
||||
| l, t, .lam c =>
|
||||
do
|
||||
let apped ← vApp t (.var l)
|
||||
let body ← cApp c (.var l)
|
||||
| l, t, .lam c => do
|
||||
let apped ← vApp t (.neu (.var l))
|
||||
let body ← cApp c (.neu (.var l))
|
||||
conv (l + 1) apped body
|
||||
| l, .pair a b, .pair a' b' =>
|
||||
andThen (conv l a a') fun _ => conv l b b'
|
||||
| l, .pair a b, p =>
|
||||
andThen
|
||||
(do
|
||||
let fstp ← vFst p
|
||||
conv l a fstp)
|
||||
fun _ => do
|
||||
let sndp ← vSnd p
|
||||
conv l b sndp
|
||||
| l, p, .pair a b =>
|
||||
andThen
|
||||
(do
|
||||
let fstp ← vFst p
|
||||
conv l fstp a)
|
||||
fun _ => do
|
||||
let sndp ← vSnd p
|
||||
conv l sndp b
|
||||
| _, .var x, .var y => pure (x == y)
|
||||
| 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
|
||||
| l, .pair a b, .pair a' b' =>
|
||||
andThen (conv l a a') fun _ => conv l b b'
|
||||
| l, .pair a b, p =>
|
||||
andThen
|
||||
(do
|
||||
let fstp ← vFst p
|
||||
conv l a fstp)
|
||||
fun _ => do
|
||||
let sndp ← vSnd p
|
||||
conv l b sndp
|
||||
| l, p, .pair a b =>
|
||||
andThen
|
||||
(do
|
||||
let fstp ← vFst p
|
||||
conv l fstp a)
|
||||
fun _ => do
|
||||
let sndp ← vSnd p
|
||||
conv l sndp b
|
||||
| l, .neu n, .neu n' => convNeutral l n n'
|
||||
| _, _, _ => pure false
|
||||
end
|
||||
|
||||
partial def sub : Lvl → Val → Val → EvalM Bool
|
||||
| _, .univ i, .univ j => pure (i <= j)
|
||||
| l, .pi a c, .pi a' c' =>
|
||||
andThen (sub l a' a) fun _ => do
|
||||
let b ← cApp c (.var l)
|
||||
let b' ← cApp c' (.var l)
|
||||
let b ← cApp c (.neu (.var l))
|
||||
let b' ← cApp c' (.neu (.var l))
|
||||
sub (l + 1) b b'
|
||||
| l, .sig a c, .sig a' c' =>
|
||||
andThen (sub l a a') fun _ => do
|
||||
let b ← cApp c (.var l)
|
||||
let b' ← cApp c' (.var l)
|
||||
let b ← cApp c (.neu (.var l))
|
||||
let b' ← cApp c' (.neu (.var l))
|
||||
sub (l + 1) b b'
|
||||
| l, t, t' => conv l t t'
|
||||
|
||||
|
||||
Reference in New Issue
Block a user