rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

typed equality

Browse source
This commit is contained in:
rhiannon morris 2023-02-10 21:40:44 +01:00
parent 3b13f0a82c
commit 42798f243f
8 changed files with 410 additions and 250 deletions
Download patch file Download diff file Expand all files Collapse all files

24
lib/Quox/Typechecker.idr
View file

@ -22,7 +22,7 @@ CanTC q = CanTC' q IsGlobal
private covering %inline
expectTYPE : CanTC' q _ m => Term q d n -> m Universe
expectTYPE s =
case whnf !ask s of
case whnfD !ask s of
Element (TYPE l) _ => pure l
_ => throwError $ ExpectedTYPE s
@ -30,7 +30,7 @@ private covering %inline
expectPi : CanTC' q _ m => Term q d n ->
m (q, Term q d n, ScopeTerm q d n)
expectPi ty =
case whnf !ask ty of
case whnfD !ask ty of
Element (Pi qty _ arg res) _ => pure (qty, arg, res)
_ => throwError $ ExpectedPi ty
@ -38,7 +38,7 @@ private covering %inline
expectSig : CanTC' q _ m => Term q d n ->
m (Term q d n, ScopeTerm q d n)
expectSig ty =
case whnf !ask ty of
case whnfD !ask ty of
Element (Sig _ arg res) _ => pure (arg, res)
_ => throwError $ ExpectedSig ty
@ -46,7 +46,7 @@ private covering %inline
expectEq : CanTC' q _ m => Term q d n ->
m (DScopeTerm q d n, Term q d n, Term q d n)
expectEq ty =
case whnf !ask ty of
case whnfD !ask ty of
Element (Eq _ ty l r) _ => pure (ty, l, r)
_ => throwError $ ExpectedEq ty
@ -80,11 +80,8 @@ lookupBound pi (VS i) ctx =
weakI $ lookupBound pi i (tail ctx)
private
lookupFree : IsQty q => CanTC q m => Name -> m (Definition q)
lookupFree x =
case lookup x !ask of
Just d => pure d
Nothing => throwError $ NotInScope x
lookupFree : CanTC' q g m => Name -> m (Definition' q g)
lookupFree x = lookupFree' !ask x
private %inline
subjMult : IsQty q => (sg : SQty q) -> q -> SQty q
@ -202,9 +199,9 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
qout <- check (extendDim ctx) sg body.term ty.term
let eqs = makeDimEq ctx.dctx
-- if Ψ ⊢ t‹0› = l
equal !ask eqs body.zero l
equal eqs ctx.tctx ty.zero body.zero l
-- if Ψ ⊢ t‹1› = r
equal !ask eqs body.one r
equal eqs ctx.tctx ty.one body.one r
-- then Ψ | Γ ⊢ (λᴰi ⇒ t) · σ ⇐ Eq [i ⇒ A] l r ⊳ Σ
pure qout
@ -212,7 +209,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
-- if Ψ | Γ ⊢ e · σ ⇒ A' ⊳ Σ
infres <- infer ctx sg e
-- if Ψ ⊢ A' <: A
sub !ask (makeDimEq ctx.dctx) infres.type ty
subtype (makeDimEq ctx.dctx) ctx.tctx infres.type ty
-- then Ψ | Γ ⊢ e · σ ⇐ A ⊳ Σ
pure infres.qout
@ -258,8 +255,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
-- ⊳ Σ₂, x · π₁, y · π₂
-- if π₁, π₂ ≤ π
let bodyctx = extendTyN [< (tfst, pi), (tsnd.term, pi)] ctx
retarg = Pair (BVT 0) (BVT 1) :# (pairres.type // fromNat 2)
bodyty = ret.term // (retarg ::: shift 2)
bodyty = substCasePairRet pairres.type ret
bodyout <- check bodyctx sg body.term bodyty >>= popQs [< pi, pi]
-- then Ψ | Γ ⊢ σ case ⋯ ⇒ ret[pair] ⊳ πΣ₁ + Σ₂
pure $ InfRes {