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

natural numbers

Browse source
This commit is contained in:
rhiannon morris 2023-03-26 14:40:54 +02:00
parent fae534dae0
commit 9250789219
15 changed files with 305 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

54
lib/Quox/Equal.idr
View file

@ -61,6 +61,9 @@ isTyCon (Enum {}) = True
isTyCon (Tag {}) = False
isTyCon (Eq {}) = True
isTyCon (DLam {}) = False
isTyCon Nat = True
isTyCon Zero = False
isTyCon (Succ {}) = False
isTyCon (E {}) = True
isTyCon (CloT {}) = False
isTyCon (DCloT {}) = False
@ -79,6 +82,8 @@ sameTyCon (Enum {}) (Enum {}) = True
sameTyCon (Enum {}) _ = False
sameTyCon (Eq {}) (Eq {}) = True
sameTyCon (Eq {}) _ = False
sameTyCon Nat Nat = True
sameTyCon Nat _ = False
sameTyCon (E {}) (E {}) = True
sameTyCon (E {}) _ = False
@ -107,6 +112,9 @@ parameters (defs : Definitions' q g)
Tag {} => pure False
Eq {} => pure True
DLam {} => pure False
Nat => pure False
Zero => pure False
Succ {} => pure False
E (s :# _) => isSubSing s
E _ => pure False
@ -218,6 +226,31 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
-- Γ ⊢ e = f : Eq [i ⇒ A] s t
pure ()
compare0' ctx Nat s t = local {mode := Equal} $
case (s, t) of
-- ---------------
-- Γ ⊢ 0 = 0 : ℕ
(Zero, Zero) => pure ()
-- Γ ⊢ m = n : ℕ
-- -------------------------
-- Γ ⊢ succ m = succ n : ℕ
(Succ m, Succ n) => compare0 ctx Nat m n
(E e, E f) => Elim.compare0 ctx e f
(Zero, Succ _) => clashT ctx Nat s t
(Zero, E _) => clashT ctx Nat s t
(Succ _, Zero) => clashT ctx Nat s t
(Succ _, E _) => clashT ctx Nat s t
(E _, Zero) => clashT ctx Nat s t
(E _, Succ _) => clashT ctx Nat s t
(Zero, t) => wrongType ctx Nat t
(Succ _, t) => wrongType ctx Nat t
(E _, t) => wrongType ctx Nat t
(s, _) => wrongType ctx Nat s
compare0' ctx ty@(E _) s t = do
-- a neutral type can only be inhabited by neutral values
-- e.g. an abstract value in an abstract type, bound variables, …
@ -290,6 +323,11 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
-- a runtime coercion
unless (tags1 == tags2) $ clashTy ctx s t
compareType' ctx Nat Nat =
-- ------------
-- Γ ⊢ ℕ <: ℕ
pure ()
compareType' ctx (E e) (E f) = do
-- no fanciness needed here cos anything other than a neutral
-- has been inlined by whnf
@ -311,6 +349,7 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
pure $ sub1 res (s :# arg)
computeElimType ctx (CasePair {pair, ret, _}) _ = pure $ sub1 ret pair
computeElimType ctx (CaseEnum {tag, ret, _}) _ = pure $ sub1 ret tag
computeElimType ctx (CaseNat {nat, ret, _}) _ = pure $ sub1 ret nat
computeElimType ctx (f :% p) ne = do
(ty, _, _) <- expectEqE defs ctx !(computeElimType ctx f (noOr1 ne))
pure $ dsub1 ty p
@ -401,6 +440,21 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
Nothing => throwError $ TagNotIn t (fromList $ keys arms)
compare0' ctx e@(CaseEnum {}) f _ _ = clashE ctx e f
compare0' ctx (CaseNat epi epi' e eret ezer esuc)
(CaseNat fpi fpi' f fret fzer fsuc) ne nf =
local {mode := Equal} $ do
compare0 ctx e f
ety <- computeElimType ctx e (noOr1 ne)
compareType (extendTy zero eret.name ety ctx) eret.term fret.term
compare0 ctx (sub1 eret (Zero :# Nat)) ezer fzer
let [< p, ih] = esuc.names
compare0 (extendTyN [< (epi, p, Nat), (epi', ih, eret.term)] ctx)
(weakT eret.term)
esuc.term fsuc.term
expectEqualQ epi fpi
expectEqualQ epi' fpi'
compare0' ctx e@(CaseNat {}) f _ _ = clashE ctx e f
compare0' ctx (s :# a) (t :# b) _ _ =
Term.compare0 ctx !(bigger a b) s t
where