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

tweaks in equality checking

Browse source
This commit is contained in:
rhiannon morris 2023-03-26 14:38:37 +02:00
parent 5053e9b234
commit fae534dae0
1 changed files with 25 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
lib/Quox/Equal.idr
View file

@ -40,6 +40,10 @@ parameters {auto _ : CanEqual q m} (ctx : EqContext q n)
clashE : Elim q 0 n -> Elim q 0 n -> m a clashE : Elim q 0 n -> Elim q 0 n -> m a
clashE e f = throwError $ ClashE ctx !mode e f clashE e f = throwError $ ClashE ctx !mode e f
private %inline
wrongType : Term q 0 n -> Term q 0 n -> m a
wrongType ty s = throwError $ WrongType ctx ty s
||| true if a term is syntactically a type, or is neutral. ||| true if a term is syntactically a type, or is neutral.
||| |||
@ -161,9 +165,9 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
(E e, E f) => Elim.compare0 ctx e f (E e, E f) => Elim.compare0 ctx e f
(Lam _, t) => throwError $ WrongType ctx ty t (Lam _, t) => wrongType ctx ty t
(E _, t) => throwError $ WrongType ctx ty t (E _, t) => wrongType ctx ty t
(s, _) => throwError $ WrongType ctx ty s (s, _) => wrongType ctx ty s
where where
ctx' : EqContext q (S n) ctx' : EqContext q (S n)
ctx' = extendTy qty res.name arg ctx ctx' = extendTy qty res.name arg ctx
@ -185,9 +189,12 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
(E e, E f) => Elim.compare0 ctx e f (E e, E f) => Elim.compare0 ctx e f
(Pair {}, t) => throwError $ WrongType ctx ty t (Pair {}, E _) => clashT ctx ty s t
(E _, t) => throwError $ WrongType ctx ty t (E _, Pair {}) => clashT ctx ty s t
(s, _) => throwError $ WrongType ctx ty s
(Pair {}, t) => wrongType ctx ty t
(E _, t) => wrongType ctx ty t
(s, _) => wrongType ctx ty s
compare0' ctx ty@(Enum tags) s t = local {mode := Equal} $ compare0' ctx ty@(Enum tags) s t = local {mode := Equal} $
case (s, t) of case (s, t) of
@ -198,9 +205,12 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
(Tag t1, Tag t2) => unless (t1 == t2) $ clashT ctx ty s t (Tag t1, Tag t2) => unless (t1 == t2) $ clashT ctx ty s t
(E e, E f) => Elim.compare0 ctx e f (E e, E f) => Elim.compare0 ctx e f
(Tag _, t) => throwError $ WrongType ctx ty t (Tag _, E _) => clashT ctx ty s t
(E _, t) => throwError $ WrongType ctx ty t (E _, Tag _) => clashT ctx ty s t
(s, _) => throwError $ WrongType ctx ty s
(Tag _, t) => wrongType ctx ty t
(E _, t) => wrongType ctx ty t
(s, _) => wrongType ctx ty s
compare0' _ (Eq {}) _ _ = compare0' _ (Eq {}) _ _ =
-- ✨ uip ✨ -- ✨ uip ✨
@ -211,8 +221,8 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
compare0' ctx ty@(E _) s t = do compare0' ctx ty@(E _) s t = do
-- a neutral type can only be inhabited by neutral values -- a neutral type can only be inhabited by neutral values
-- e.g. an abstract value in an abstract type, bound variables, … -- e.g. an abstract value in an abstract type, bound variables, …
E e <- pure s | _ => throwError $ WrongType ctx ty s E e <- pure s | _ => wrongType ctx ty s
E f <- pure t | _ => throwError $ WrongType ctx ty t E f <- pure t | _ => wrongType ctx ty t
Elim.compare0 ctx e f Elim.compare0 ctx e f
||| compares two types, using the current variance `mode` for universes. ||| compares two types, using the current variance `mode` for universes.
@ -295,20 +305,16 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, IsQty q)}
computeElimType ctx (F x) _ = do computeElimType ctx (F x) _ = do
defs <- lookupFree' defs x defs <- lookupFree' defs x
pure $ injectT ctx defs.type pure $ injectT ctx defs.type
computeElimType ctx (B i) _ = do computeElimType ctx (B i) _ = pure $ ctx.tctx !! i
pure $ ctx.tctx !! i
computeElimType ctx (f :@ s) ne = do computeElimType ctx (f :@ s) ne = do
(_, arg, res) <- expectPiE defs ctx !(computeElimType ctx f (noOr1 ne)) (_, arg, res) <- expectPiE defs ctx !(computeElimType ctx f (noOr1 ne))
pure $ sub1 res (s :# arg) pure $ sub1 res (s :# arg)
computeElimType ctx (CasePair {pair, ret, _}) _ = do computeElimType ctx (CasePair {pair, ret, _}) _ = pure $ sub1 ret pair
pure $ sub1 ret pair computeElimType ctx (CaseEnum {tag, ret, _}) _ = pure $ sub1 ret tag
computeElimType ctx (CaseEnum {tag, ret, _}) _ = do
pure $ sub1 ret tag
computeElimType ctx (f :% p) ne = do computeElimType ctx (f :% p) ne = do
(ty, _, _) <- expectEqE defs ctx !(computeElimType ctx f (noOr1 ne)) (ty, _, _) <- expectEqE defs ctx !(computeElimType ctx f (noOr1 ne))
pure $ dsub1 ty p pure $ dsub1 ty p
computeElimType ctx (_ :# ty) _ = do computeElimType ctx (_ :# ty) _ = pure ty
pure ty
private covering private covering
replaceEnd : EqContext q n -> replaceEnd : EqContext q n ->