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

pair stuff

Browse source
This commit is contained in:
rhiannon morris 2023-01-26 19:54:46 +01:00
parent 6073ab4705
commit 4b36d8b7c8
16 changed files with 441 additions and 117 deletions
Download patch file Download diff file Expand all files Collapse all files

44
lib/Quox/Equal.idr
View file

@ -41,21 +41,6 @@ private %inline
clashE : CanEqual q m => Elim q d n -> Elim q d n -> m a
clashE e f = throwError $ ClashE !mode e f
export %inline
compareU' : HasEnv m => Universe -> Universe -> m Bool
compareU' i j = pure $
case !mode of Equal => i == j; Sub => i <= j
export %inline
compareU : CanEqual q m => Universe -> Universe -> m ()
compareU k l = unless !(compareU' k l) $
throwError $ ClashU !mode k l
export %inline
compareD : HasErr q m => Dim d -> Dim d -> m ()
compareD p q = unless (p == q) $
throwError $ ClashD p q
parameters {0 isGlobal : _} (defs : Definitions' q isGlobal)
mutual
@ -66,11 +51,11 @@ parameters {0 isGlobal : _} (defs : Definitions' q isGlobal)
(0 _ : NotRedex defs s) -> (0 _ : NotRedex defs t) ->
m ()
compareN' (TYPE k) (TYPE l) _ _ = compareU k l
compareN' (TYPE k) (TYPE l) _ _ = expectModeU !mode k l
compareN' s@(TYPE _) t _ _ = clashT s t
compareN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
expectEqualQ qty1 qty2
compare0 arg2 arg1 -- reversed for contravariant domain
compare0 res1 res2
compareN' s@(Pi {}) t _ _ = clashT s t
@ -80,6 +65,17 @@ parameters {0 isGlobal : _} (defs : Definitions' q isGlobal)
local {mode := Equal} $ compare0 body1 body2
compareN' s@(Lam {}) t _ _ = clashT s t
compareN' (Sig _ fst1 snd1) (Sig _ fst2 snd2) _ _ = do
compare0 fst1 fst2
compare0 snd1 snd2
compareN' s@(Sig {}) t _ _ = clashT s t
compareN' (Pair fst1 snd1) (Pair fst2 snd2) _ _ =
local {mode := Equal} $ do
compare0 fst1 fst2
compare0 snd1 snd2
compareN' s@(Pair {}) t _ _ = clashT s t
compareN' (Eq _ ty1 l1 r1) (Eq _ ty2 l2 r2) _ _ = do
compare0 ty1 ty2
local {mode := Equal} $ do
@ -88,7 +84,8 @@ parameters {0 isGlobal : _} (defs : Definitions' q isGlobal)
compareN' s@(Eq {}) t _ _ = clashT s t
compareN' (DLam _ body1) (DLam _ body2) _ _ =
compare0 body1 body2
local {mode := Equal} $ do
compare0 body1 body2
compareN' s@(DLam {}) t _ _ = clashT s t
compareN' (E e) (E f) ne nf = compareN' e f (noOr2 ne) (noOr2 nf)
@ -117,11 +114,20 @@ parameters {0 isGlobal : _} (defs : Definitions' q isGlobal)
compare0 arg1 arg2
compareN' e@(_ :@ _) f _ _ = clashE e f
compareN' (CasePair pi1 pair1 _ ret1 _ _ body1)
(CasePair pi2 pair2 _ ret2 _ _ body2) _ _ =
local {mode := Equal} $ do
expectEqualQ pi1 pi2
compare0 pair1 pair2
compare0 ret1 ret2
compare0 body1 body2
compareN' e@(CasePair {}) f _ _ = clashE e f
-- retain the mode unlike above because dimensions can't do
-- anything that would mess up variance
compareN' (fun1 :% dim1) (fun2 :% dim2) _ _ = do
compare0 fun1 fun2
compareD dim1 dim2
expectEqualD dim1 dim2
compareN' e@(_ :% _) f _ _ = clashE e f
-- using the same mode for the type allows, e.g.