pass the subject quantity through equality etc
in preparation for non-linear η laws
This commit is contained in:
parent
3fe9b96f05
commit
e6c06a5c81
17 changed files with 654 additions and 605 deletions
|
|
@ -70,22 +70,22 @@ sameTyCon (E {}) _ = False
|
|||
||| * `[π.A]` is empty if `A` is.
|
||||
||| * that's it.
|
||||
public export covering
|
||||
isEmpty : {n : Nat} -> Definitions -> EqContext n -> Term 0 n ->
|
||||
isEmpty : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n ->
|
||||
Eff EqualInner Bool
|
||||
isEmpty defs ctx ty0 = do
|
||||
Element ty0 nc <- whnf defs ctx ty0.loc ty0
|
||||
isEmpty defs ctx sg ty0 = do
|
||||
Element ty0 nc <- whnf defs ctx sg ty0.loc ty0
|
||||
case ty0 of
|
||||
TYPE {} => pure False
|
||||
Pi {arg, res, _} => pure False
|
||||
Sig {fst, snd, _} =>
|
||||
isEmpty defs ctx fst `orM`
|
||||
isEmpty defs (extendTy0 snd.name fst ctx) snd.term
|
||||
isEmpty defs ctx sg fst `orM`
|
||||
isEmpty defs (extendTy0 snd.name fst ctx) sg snd.term
|
||||
Enum {cases, _} =>
|
||||
pure $ null cases
|
||||
Eq {} => pure False
|
||||
Nat {} => pure False
|
||||
BOX {ty, _} => isEmpty defs ctx ty
|
||||
E (Ann {tm, _}) => isEmpty defs ctx tm
|
||||
BOX {ty, _} => isEmpty defs ctx sg ty
|
||||
E (Ann {tm, _}) => isEmpty defs ctx sg tm
|
||||
E _ => pure False
|
||||
Lam {} => pure False
|
||||
Pair {} => pure False
|
||||
|
|
@ -106,24 +106,24 @@ isEmpty defs ctx ty0 = do
|
|||
||| * an enum type is a subsingleton if it has zero or one tags.
|
||||
||| * a box type is a subsingleton if its content is
|
||||
public export covering
|
||||
isSubSing : {n : Nat} -> Definitions -> EqContext n -> Term 0 n ->
|
||||
isSubSing : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n ->
|
||||
Eff EqualInner Bool
|
||||
isSubSing defs ctx ty0 = do
|
||||
Element ty0 nc <- whnf defs ctx ty0.loc ty0
|
||||
isSubSing defs ctx sg ty0 = do
|
||||
Element ty0 nc <- whnf defs ctx sg ty0.loc ty0
|
||||
case ty0 of
|
||||
TYPE {} => pure False
|
||||
Pi {arg, res, _} =>
|
||||
isEmpty defs ctx arg `orM`
|
||||
isSubSing defs (extendTy0 res.name arg ctx) res.term
|
||||
isEmpty defs ctx sg arg `orM`
|
||||
isSubSing defs (extendTy0 res.name arg ctx) sg res.term
|
||||
Sig {fst, snd, _} =>
|
||||
isSubSing defs ctx fst `andM`
|
||||
isSubSing defs (extendTy0 snd.name fst ctx) snd.term
|
||||
isSubSing defs ctx sg fst `andM`
|
||||
isSubSing defs (extendTy0 snd.name fst ctx) sg snd.term
|
||||
Enum {cases, _} =>
|
||||
pure $ length (SortedSet.toList cases) <= 1
|
||||
Eq {} => pure True
|
||||
Nat {} => pure False
|
||||
BOX {ty, _} => isSubSing defs ctx ty
|
||||
E (Ann {tm, _}) => isSubSing defs ctx tm
|
||||
BOX {ty, _} => isSubSing defs ctx sg ty
|
||||
E (Ann {tm, _}) => isSubSing defs ctx sg tm
|
||||
E _ => pure False
|
||||
Lam {} => pure False
|
||||
Pair {} => pure False
|
||||
|
|
@ -155,7 +155,7 @@ namespace Term
|
|||
|||
|
||||
||| ⚠ **assumes that `s`, `t` have already been checked against `ty`**. ⚠
|
||||
export covering %inline
|
||||
compare0 : Definitions -> EqContext n -> (ty, s, t : Term 0 n) ->
|
||||
compare0 : Definitions -> EqContext n -> SQty -> (ty, s, t : Term 0 n) ->
|
||||
Eff EqualInner ()
|
||||
|
||||
namespace Elim
|
||||
|
|
@ -164,7 +164,7 @@ namespace Elim
|
|||
||| ⚠ **assumes that they have both been typechecked, and have
|
||||
||| equal types.** ⚠
|
||||
export covering %inline
|
||||
compare0 : Definitions -> EqContext n -> (e, f : Elim 0 n) ->
|
||||
compare0 : Definitions -> EqContext n -> SQty -> (e, f : Elim 0 n) ->
|
||||
Eff EqualInner (Term 0 n)
|
||||
|
||||
||| compares two types, using the current variance `mode` for universes.
|
||||
|
|
@ -176,14 +176,14 @@ compareType : Definitions -> EqContext n -> (s, t : Term 0 n) ->
|
|||
|
||||
namespace Term
|
||||
private covering
|
||||
compare0' : (defs : Definitions) -> EqContext n ->
|
||||
compare0' : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
|
||||
(ty, s, t : Term 0 n) ->
|
||||
(0 _ : NotRedex defs ty) => (0 _ : So (isTyConE ty)) =>
|
||||
(0 _ : NotRedex defs s) => (0 _ : NotRedex defs t) =>
|
||||
(0 _ : NotRedex defs SZero ty) => (0 _ : So (isTyConE ty)) =>
|
||||
(0 _ : NotRedex defs sg s) => (0 _ : NotRedex defs sg t) =>
|
||||
Eff EqualInner ()
|
||||
compare0' defs ctx (TYPE {}) s t = compareType defs ctx s t
|
||||
compare0' defs ctx sg (TYPE {}) s t = compareType defs ctx s t
|
||||
|
||||
compare0' defs ctx ty@(Pi {qty, arg, res, _}) s t = local_ Equal $
|
||||
compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = local_ Equal $
|
||||
-- Γ ⊢ A empty
|
||||
-- -------------------------------------------
|
||||
-- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B
|
||||
|
|
@ -193,7 +193,7 @@ namespace Term
|
|||
-- -------------------------------------------
|
||||
-- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B
|
||||
(Lam b1 {}, Lam b2 {}) =>
|
||||
compare0 defs ctx' res.term b1.term b2.term
|
||||
compare0 defs ctx' sg res.term b1.term b2.term
|
||||
|
||||
-- Γ, x : A ⊢ s = e x : B
|
||||
-- -----------------------------------
|
||||
|
|
@ -201,14 +201,14 @@ namespace Term
|
|||
(E e, Lam b {}) => eta s.loc e b
|
||||
(Lam b {}, E e) => eta s.loc e b
|
||||
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx e f
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
|
||||
|
||||
(Lam {}, t) => wrongType t.loc ctx ty t
|
||||
(E _, t) => wrongType t.loc ctx ty t
|
||||
(s, _) => wrongType s.loc ctx ty s
|
||||
where
|
||||
isEmpty' : Term 0 n -> Eff EqualInner Bool
|
||||
isEmpty' t = let Val n = ctx.termLen in isEmpty defs ctx arg
|
||||
isEmpty' t = let Val n = ctx.termLen in isEmpty defs ctx sg arg
|
||||
|
||||
ctx' : EqContext (S n)
|
||||
ctx' = extendTy qty res.name arg ctx
|
||||
|
|
@ -218,9 +218,9 @@ namespace Term
|
|||
|
||||
eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Eff EqualInner ()
|
||||
eta loc e (S _ (N _)) = clashT loc ctx ty s t
|
||||
eta _ e (S _ (Y b)) = compare0 defs ctx' res.term (toLamBody e) b
|
||||
eta _ e (S _ (Y b)) = compare0 defs ctx' sg res.term (toLamBody e) b
|
||||
|
||||
compare0' defs ctx ty@(Sig {fst, snd, _}) s t = local_ Equal $
|
||||
compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = local_ Equal $
|
||||
case (s, t) of
|
||||
-- Γ ⊢ s₁ = t₁ : A Γ ⊢ s₂ = t₂ : B{s₁/x}
|
||||
-- --------------------------------------------
|
||||
|
|
@ -228,10 +228,10 @@ namespace Term
|
|||
--
|
||||
-- [todo] η for π ≥ 0 maybe
|
||||
(Pair sFst sSnd {}, Pair tFst tSnd {}) => do
|
||||
compare0 defs ctx fst sFst tFst
|
||||
compare0 defs ctx (sub1 snd (Ann sFst fst fst.loc)) sSnd tSnd
|
||||
compare0 defs ctx sg fst sFst tFst
|
||||
compare0 defs ctx sg (sub1 snd (Ann sFst fst fst.loc)) sSnd tSnd
|
||||
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx e f
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
|
||||
|
||||
(Pair {}, E _) => clashT s.loc ctx ty s t
|
||||
(E _, Pair {}) => clashT s.loc ctx ty s t
|
||||
|
|
@ -240,7 +240,7 @@ namespace Term
|
|||
(E _, t) => wrongType t.loc ctx ty t
|
||||
(s, _) => wrongType s.loc ctx ty s
|
||||
|
||||
compare0' defs ctx ty@(Enum {}) s t = local_ Equal $
|
||||
compare0' defs ctx sg ty@(Enum {}) s t = local_ Equal $
|
||||
case (s, t) of
|
||||
-- --------------------
|
||||
-- Γ ⊢ `t = `t : {ts}
|
||||
|
|
@ -248,7 +248,7 @@ namespace Term
|
|||
-- t ∈ ts is in the typechecker, not here, ofc
|
||||
(Tag t1 {}, Tag t2 {}) =>
|
||||
unless (t1 == t2) $ clashT s.loc ctx ty s t
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx e f
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
|
||||
|
||||
(Tag {}, E _) => clashT s.loc ctx ty s t
|
||||
(E _, Tag {}) => clashT s.loc ctx ty s t
|
||||
|
|
@ -257,14 +257,14 @@ namespace Term
|
|||
(E _, t) => wrongType t.loc ctx ty t
|
||||
(s, _) => wrongType s.loc ctx ty s
|
||||
|
||||
compare0' _ _ (Eq {}) _ _ =
|
||||
compare0' _ _ _ (Eq {}) _ _ =
|
||||
-- ✨ uip ✨
|
||||
--
|
||||
-- ----------------------------
|
||||
-- Γ ⊢ e = f : Eq [i ⇒ A] s t
|
||||
pure ()
|
||||
|
||||
compare0' defs ctx nat@(Nat {}) s t = local_ Equal $
|
||||
compare0' defs ctx sg nat@(Nat {}) s t = local_ Equal $
|
||||
case (s, t) of
|
||||
-- ---------------
|
||||
-- Γ ⊢ 0 = 0 : ℕ
|
||||
|
|
@ -273,9 +273,9 @@ namespace Term
|
|||
-- Γ ⊢ s = t : ℕ
|
||||
-- -------------------------
|
||||
-- Γ ⊢ succ s = succ t : ℕ
|
||||
(Succ s' {}, Succ t' {}) => compare0 defs ctx nat s' t'
|
||||
(Succ s' {}, Succ t' {}) => compare0 defs ctx sg nat s' t'
|
||||
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx e f
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
|
||||
|
||||
(Zero {}, Succ {}) => clashT s.loc ctx nat s t
|
||||
(Zero {}, E _) => clashT s.loc ctx nat s t
|
||||
|
|
@ -289,12 +289,12 @@ namespace Term
|
|||
(E _, t) => wrongType t.loc ctx nat t
|
||||
(s, _) => wrongType s.loc ctx nat s
|
||||
|
||||
compare0' defs ctx bty@(BOX q ty {}) s t = local_ Equal $
|
||||
compare0' defs ctx sg bty@(BOX q ty {}) s t = local_ Equal $
|
||||
case (s, t) of
|
||||
-- Γ ⊢ s = t : A
|
||||
-- -----------------------
|
||||
-- Γ ⊢ [s] = [t] : [π.A]
|
||||
(Box s _, Box t _) => compare0 defs ctx ty s t
|
||||
(Box s _, Box t _) => compare0 defs ctx sg ty s t
|
||||
|
||||
-- Γ ⊢ s = (case1 e return A of {[x] ⇒ x}) ⇐ A
|
||||
-- -----------------------------------------------
|
||||
|
|
@ -302,7 +302,7 @@ namespace Term
|
|||
(Box s loc, E f) => eta s f
|
||||
(E e, Box t loc) => eta t e
|
||||
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx e f
|
||||
(E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
|
||||
|
||||
(Box {}, _) => wrongType t.loc ctx bty t
|
||||
(E _, _) => wrongType t.loc ctx bty t
|
||||
|
|
@ -312,20 +312,20 @@ namespace Term
|
|||
eta s e = do
|
||||
nm <- mnb "inner" e.loc
|
||||
let e = CaseBox One e (SN ty) (SY [< nm] (BVT 0 nm.loc)) e.loc
|
||||
compare0 defs ctx ty s (E e)
|
||||
compare0 defs ctx sg ty s (E e)
|
||||
|
||||
compare0' defs ctx ty@(E _) s t = do
|
||||
compare0' defs ctx sg 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, …
|
||||
let E e = s | _ => wrongType s.loc ctx ty s
|
||||
E f = t | _ => wrongType t.loc ctx ty t
|
||||
ignore $ Elim.compare0 defs ctx e f
|
||||
ignore $ Elim.compare0 defs ctx sg e f
|
||||
|
||||
|
||||
private covering
|
||||
compareType' : (defs : Definitions) -> EqContext n -> (s, t : Term 0 n) ->
|
||||
(0 _ : NotRedex defs s) => (0 _ : So (isTyConE s)) =>
|
||||
(0 _ : NotRedex defs t) => (0 _ : So (isTyConE t)) =>
|
||||
(0 _ : NotRedex defs SZero s) => (0 _ : So (isTyConE s)) =>
|
||||
(0 _ : NotRedex defs SZero t) => (0 _ : So (isTyConE t)) =>
|
||||
(0 _ : So (sameTyCon s t)) =>
|
||||
Eff EqualInner ()
|
||||
-- equality is the same as subtyping, except with the
|
||||
|
|
@ -363,8 +363,8 @@ compareType' defs ctx (Eq {ty = sTy, l = sl, r = sr, _})
|
|||
compareType defs (extendDim sTy.name One ctx) sTy.one tTy.one
|
||||
ty <- bigger sTy tTy
|
||||
local_ Equal $ do
|
||||
Term.compare0 defs ctx ty.zero sl tl
|
||||
Term.compare0 defs ctx ty.one sr tr
|
||||
Term.compare0 defs ctx SZero ty.zero sl tl
|
||||
Term.compare0 defs ctx SZero ty.one sr tr
|
||||
|
||||
compareType' defs ctx s@(Enum tags1 {}) t@(Enum tags2 {}) = do
|
||||
-- ------------------
|
||||
|
|
@ -386,7 +386,7 @@ compareType' defs ctx (BOX pi a loc) (BOX rh b {}) = do
|
|||
compareType' defs ctx (E e) (E f) = do
|
||||
-- no fanciness needed here cos anything other than a neutral
|
||||
-- has been inlined by whnf
|
||||
ignore $ Elim.compare0 defs ctx e f
|
||||
ignore $ Elim.compare0 defs ctx SZero e f
|
||||
|
||||
|
||||
private
|
||||
|
|
@ -411,12 +411,12 @@ namespace Elim
|
|||
EqualElim = InnerErrEff :: EqualInner
|
||||
|
||||
private covering
|
||||
computeElimTypeE : (defs : Definitions) -> EqContext n ->
|
||||
(e : Elim 0 n) -> (0 ne : NotRedex defs e) =>
|
||||
computeElimTypeE : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
|
||||
(e : Elim 0 n) -> (0 ne : NotRedex defs sg e) =>
|
||||
Eff EqualElim (Term 0 n)
|
||||
computeElimTypeE defs ectx e =
|
||||
computeElimTypeE defs ectx sg e =
|
||||
let Val n = ectx.termLen in
|
||||
lift $ computeElimType defs (toWhnfContext ectx) e
|
||||
lift $ computeElimType defs (toWhnfContext ectx) sg e
|
||||
|
||||
private
|
||||
putError : Has InnerErrEff fs => Error -> Eff fs ()
|
||||
|
|
@ -427,12 +427,12 @@ namespace Elim
|
|||
try act = lift $ catch putError $ lift act {fs' = EqualElim}
|
||||
|
||||
private covering %inline
|
||||
clashE : (defs : Definitions) -> EqContext n ->
|
||||
(e, f : Elim 0 n) -> (0 nf : NotRedex defs f) =>
|
||||
clashE : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
|
||||
(e, f : Elim 0 n) -> (0 nf : NotRedex defs sg f) =>
|
||||
Eff EqualElim (Term 0 n)
|
||||
clashE defs ctx e f = do
|
||||
clashE defs ctx sg e f = do
|
||||
putError $ ClashE e.loc ctx !mode e f
|
||||
computeElimTypeE defs ctx f
|
||||
computeElimTypeE defs ctx sg f
|
||||
|
||||
|
||||
||| compare two type-case branches, which came from the arms of the given
|
||||
|
|
@ -454,24 +454,24 @@ namespace Elim
|
|||
(b1, b2 : TypeCaseArmBody k 0 n) ->
|
||||
Eff EqualElim ()
|
||||
compareArm_ defs ctx KTYPE ret u b1 b2 =
|
||||
try $ Term.compare0 defs ctx ret b1.term b2.term
|
||||
try $ Term.compare0 defs ctx SZero ret b1.term b2.term
|
||||
|
||||
compareArm_ defs ctx KPi ret u b1 b2 = do
|
||||
let [< a, b] = b1.names
|
||||
ctx = extendTyN0
|
||||
[< (a, TYPE u a.loc),
|
||||
(b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx
|
||||
try $ Term.compare0 defs ctx (weakT 2 ret) b1.term b2.term
|
||||
try $ Term.compare0 defs ctx SZero (weakT 2 ret) b1.term b2.term
|
||||
|
||||
compareArm_ defs ctx KSig ret u b1 b2 = do
|
||||
let [< a, b] = b1.names
|
||||
ctx = extendTyN0
|
||||
[< (a, TYPE u a.loc),
|
||||
(b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx
|
||||
try $ Term.compare0 defs ctx (weakT 2 ret) b1.term b2.term
|
||||
try $ Term.compare0 defs ctx SZero (weakT 2 ret) b1.term b2.term
|
||||
|
||||
compareArm_ defs ctx KEnum ret u b1 b2 =
|
||||
try $ Term.compare0 defs ctx ret b1.term b2.term
|
||||
try $ Term.compare0 defs ctx SZero ret b1.term b2.term
|
||||
|
||||
compareArm_ defs ctx KEq ret u b1 b2 = do
|
||||
let [< a0, a1, a, l, r] = b1.names
|
||||
|
|
@ -481,45 +481,45 @@ namespace Elim
|
|||
(a, Eq0 (TYPE u a.loc) (BVT 1 a0.loc) (BVT 0 a1.loc) a.loc),
|
||||
(l, BVT 2 a0.loc),
|
||||
(r, BVT 2 a1.loc)] ctx
|
||||
try $ Term.compare0 defs ctx (weakT 5 ret) b1.term b2.term
|
||||
try $ Term.compare0 defs ctx SZero (weakT 5 ret) b1.term b2.term
|
||||
|
||||
compareArm_ defs ctx KNat ret u b1 b2 =
|
||||
try $ Term.compare0 defs ctx ret b1.term b2.term
|
||||
try $ Term.compare0 defs ctx SZero ret b1.term b2.term
|
||||
|
||||
compareArm_ defs ctx KBOX ret u b1 b2 = do
|
||||
let ctx = extendTy0 b1.name (TYPE u b1.name.loc) ctx
|
||||
try $ Term.compare0 defs ctx (weakT 1 ret) b1.term b1.term
|
||||
try $ Term.compare0 defs ctx SZero (weakT 1 ret) b1.term b1.term
|
||||
|
||||
|
||||
private covering
|
||||
compare0Inner : Definitions -> EqContext n -> (e, f : Elim 0 n) ->
|
||||
Eff EqualElim (Term 0 n)
|
||||
compare0Inner : Definitions -> EqContext n -> (sg : SQty) ->
|
||||
(e, f : Elim 0 n) -> Eff EqualElim (Term 0 n)
|
||||
|
||||
private covering
|
||||
compare0Inner' : (defs : Definitions) -> EqContext n ->
|
||||
compare0Inner' : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
|
||||
(e, f : Elim 0 n) ->
|
||||
(0 ne : NotRedex defs e) -> (0 nf : NotRedex defs f) ->
|
||||
(0 ne : NotRedex defs sg e) -> (0 nf : NotRedex defs sg f) ->
|
||||
Eff EqualElim (Term 0 n)
|
||||
|
||||
compare0Inner' defs ctx e@(F {}) f _ _ = do
|
||||
if e == f then computeElimTypeE defs ctx f
|
||||
else clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(F {}) f _ _ = do
|
||||
if e == f then computeElimTypeE defs ctx sg f
|
||||
else clashE defs ctx sg e f
|
||||
|
||||
compare0Inner' defs ctx e@(B {}) f _ _ = do
|
||||
if e == f then computeElimTypeE defs ctx f
|
||||
else clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(B {}) f _ _ = do
|
||||
if e == f then computeElimTypeE defs ctx sg f
|
||||
else clashE defs ctx sg e f
|
||||
|
||||
-- Ψ | Γ ⊢ e = f ⇒ π.(x : A) → B
|
||||
-- Ψ | Γ ⊢ s = t ⇐ A
|
||||
-- -------------------------------
|
||||
-- Ψ | Γ ⊢ e s = f t ⇒ B[s∷A/x]
|
||||
compare0Inner' defs ctx (App e s eloc) (App f t floc) ne nf = do
|
||||
ety <- compare0Inner defs ctx e f
|
||||
(_, arg, res) <- expectPi defs ctx eloc ety
|
||||
try $ Term.compare0 defs ctx arg s t
|
||||
compare0Inner' defs ctx sg (App e s eloc) (App f t floc) ne nf = do
|
||||
ety <- compare0Inner defs ctx sg e f
|
||||
(_, arg, res) <- expectPi defs ctx sg eloc ety
|
||||
try $ Term.compare0 defs ctx sg arg s t
|
||||
pure $ sub1 res $ Ann s arg s.loc
|
||||
compare0Inner' defs ctx e'@(App {}) f' ne nf =
|
||||
clashE defs ctx e' f'
|
||||
compare0Inner' defs ctx sg e'@(App {}) f' ne nf =
|
||||
clashE defs ctx sg e' f'
|
||||
|
||||
-- Ψ | Γ ⊢ e = f ⇒ (x : A) × B
|
||||
-- Ψ | Γ, 0.p : (x : A) × B ⊢ Q = R
|
||||
|
|
@ -527,22 +527,22 @@ namespace Elim
|
|||
-- -----------------------------------------------------------
|
||||
-- Ψ | Γ ⊢ caseπ e return Q of { (x, y) ⇒ s }
|
||||
-- = caseπ f return R of { (x, y) ⇒ t } ⇒ Q[e/p]
|
||||
compare0Inner' defs ctx (CasePair epi e eret ebody eloc)
|
||||
(CasePair fpi f fret fbody floc) ne nf =
|
||||
compare0Inner' defs ctx sg (CasePair epi e eret ebody eloc)
|
||||
(CasePair fpi f fret fbody floc) ne nf =
|
||||
local_ Equal $ do
|
||||
ety <- compare0Inner defs ctx e f
|
||||
(fst, snd) <- expectSig defs ctx eloc ety
|
||||
ety <- compare0Inner defs ctx sg e f
|
||||
(fst, snd) <- expectSig defs ctx sg eloc ety
|
||||
let [< x, y] = ebody.names
|
||||
try $ do
|
||||
compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
|
||||
Term.compare0 defs
|
||||
(extendTyN [< (epi, x, fst), (epi, y, snd.term)] ctx)
|
||||
(extendTyN [< (epi, x, fst), (epi, y, snd.term)] ctx) sg
|
||||
(substCasePairRet ebody.names ety eret)
|
||||
ebody.term fbody.term
|
||||
expectEqualQ e.loc epi fpi
|
||||
pure $ sub1 eret e
|
||||
compare0Inner' defs ctx e'@(CasePair {}) f' ne nf =
|
||||
clashE defs ctx e' f'
|
||||
compare0Inner' defs ctx sg e'@(CasePair {}) f' ne nf =
|
||||
clashE defs ctx sg e' f'
|
||||
|
||||
-- Ψ | Γ ⊢ e = f ⇒ {𝐚s}
|
||||
-- Ψ | Γ, x : {𝐚s} ⊢ Q = R
|
||||
|
|
@ -550,20 +550,20 @@ namespace Elim
|
|||
-- --------------------------------------------------
|
||||
-- Ψ | Γ ⊢ caseπ e return Q of { '𝐚ᵢ ⇒ sᵢ }
|
||||
-- = caseπ f return R of { '𝐚ᵢ ⇒ tᵢ } ⇒ Q[e/x]
|
||||
compare0Inner' defs ctx (CaseEnum epi e eret earms eloc)
|
||||
(CaseEnum fpi f fret farms floc) ne nf =
|
||||
compare0Inner' defs ctx sg (CaseEnum epi e eret earms eloc)
|
||||
(CaseEnum fpi f fret farms floc) ne nf =
|
||||
local_ Equal $ do
|
||||
ety <- compare0Inner defs ctx e f
|
||||
ety <- compare0Inner defs ctx sg e f
|
||||
try $
|
||||
compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
|
||||
for_ (SortedMap.toList earms) $ \(t, l) => do
|
||||
let Just r = lookup t farms
|
||||
| Nothing => putError $ TagNotIn floc t (fromList $ keys farms)
|
||||
let t' = Ann (Tag t l.loc) ety l.loc
|
||||
try $ Term.compare0 defs ctx (sub1 eret t') l r
|
||||
try $ Term.compare0 defs ctx sg (sub1 eret t') l r
|
||||
try $ expectEqualQ eloc epi fpi
|
||||
pure $ sub1 eret e
|
||||
compare0Inner' defs ctx e@(CaseEnum {}) f _ _ = clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(CaseEnum {}) f _ _ = clashE defs ctx sg e f
|
||||
|
||||
-- Ψ | Γ ⊢ e = f ⇒ ℕ
|
||||
-- Ψ | Γ, x : ℕ ⊢ Q = R
|
||||
|
|
@ -573,23 +573,23 @@ namespace Elim
|
|||
-- Ψ | Γ ⊢ caseπ e return Q of { 0 ⇒ s₀; x, π.y ⇒ s₁ }
|
||||
-- = caseπ f return R of { 0 ⇒ t₀; x, π.y ⇒ t₁ }
|
||||
-- ⇒ Q[e/x]
|
||||
compare0Inner' defs ctx (CaseNat epi epi' e eret ezer esuc eloc)
|
||||
(CaseNat fpi fpi' f fret fzer fsuc floc) ne nf =
|
||||
compare0Inner' defs ctx sg (CaseNat epi epi' e eret ezer esuc eloc)
|
||||
(CaseNat fpi fpi' f fret fzer fsuc floc) ne nf =
|
||||
local_ Equal $ do
|
||||
ety <- compare0Inner defs ctx e f
|
||||
ety <- compare0Inner defs ctx sg e f
|
||||
let [< p, ih] = esuc.names
|
||||
try $ do
|
||||
compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
|
||||
Term.compare0 defs ctx
|
||||
Term.compare0 defs ctx sg
|
||||
(sub1 eret (Ann (Zero ezer.loc) (Nat ezer.loc) ezer.loc))
|
||||
ezer fzer
|
||||
Term.compare0 defs
|
||||
(extendTyN [< (epi, p, Nat p.loc), (epi', ih, eret.term)] ctx)
|
||||
(extendTyN [< (epi, p, Nat p.loc), (epi', ih, eret.term)] ctx) sg
|
||||
(substCaseSuccRet esuc.names eret) esuc.term fsuc.term
|
||||
expectEqualQ e.loc epi fpi
|
||||
expectEqualQ e.loc epi' fpi'
|
||||
pure $ sub1 eret e
|
||||
compare0Inner' defs ctx e@(CaseNat {}) f _ _ = clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(CaseNat {}) f _ _ = clashE defs ctx sg e f
|
||||
|
||||
-- Ψ | Γ ⊢ e = f ⇒ [ρ. A]
|
||||
-- Ψ | Γ, x : [ρ. A] ⊢ Q = R
|
||||
|
|
@ -597,32 +597,34 @@ namespace Elim
|
|||
-- --------------------------------------------------
|
||||
-- Ψ | Γ ⊢ caseπ e return Q of { [x] ⇒ s }
|
||||
-- = caseπ f return R of { [x] ⇒ t } ⇒ Q[e/x]
|
||||
compare0Inner' defs ctx (CaseBox epi e eret ebody eloc)
|
||||
(CaseBox fpi f fret fbody floc) ne nf =
|
||||
compare0Inner' defs ctx sg (CaseBox epi e eret ebody eloc)
|
||||
(CaseBox fpi f fret fbody floc) ne nf =
|
||||
local_ Equal $ do
|
||||
ety <- compare0Inner defs ctx e f
|
||||
(q, ty) <- expectBOX defs ctx eloc ety
|
||||
ety <- compare0Inner defs ctx sg e f
|
||||
(q, ty) <- expectBOX defs ctx sg eloc ety
|
||||
try $ do
|
||||
compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
|
||||
Term.compare0 defs (extendTy (epi * q) ebody.name ty ctx)
|
||||
Term.compare0 defs (extendTy (epi * q) ebody.name ty ctx) sg
|
||||
(substCaseBoxRet ebody.name ety eret)
|
||||
ebody.term fbody.term
|
||||
expectEqualQ eloc epi fpi
|
||||
pure $ sub1 eret e
|
||||
compare0Inner' defs ctx e@(CaseBox {}) f _ _ = clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(CaseBox {}) f _ _ = clashE defs ctx sg e f
|
||||
|
||||
-- (no neutral dim apps in a closed dctx)
|
||||
compare0Inner' _ _ (DApp _ (K {}) _) _ ne _ = void $ absurd $ noOr2 $ noOr2 ne
|
||||
compare0Inner' _ _ _ (DApp _ (K {}) _) _ nf = void $ absurd $ noOr2 $ noOr2 nf
|
||||
compare0Inner' _ _ _ (DApp _ (K {}) _) _ ne _ =
|
||||
void $ absurd $ noOr2 $ noOr2 ne
|
||||
compare0Inner' _ _ _ _ (DApp _ (K {}) _) _ nf =
|
||||
void $ absurd $ noOr2 $ noOr2 nf
|
||||
|
||||
-- Ψ | Γ ⊢ s <: t : B
|
||||
-- --------------------------------
|
||||
-- Ψ | Γ ⊢ (s ∷ A) <: (t ∷ B) ⇒ B
|
||||
--
|
||||
-- and similar for :> and A
|
||||
compare0Inner' defs ctx (Ann s a _) (Ann t b _) _ _ = do
|
||||
compare0Inner' defs ctx sg (Ann s a _) (Ann t b _) _ _ = do
|
||||
ty <- bigger a b
|
||||
try $ Term.compare0 defs ctx ty s t
|
||||
try $ Term.compare0 defs ctx sg ty s t
|
||||
pure ty
|
||||
|
||||
-- Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖›
|
||||
|
|
@ -631,82 +633,86 @@ namespace Elim
|
|||
-- -----------------------------------------------------------
|
||||
-- Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ s
|
||||
-- <: coe [𝑖 ⇒ B] @p₂ @q₂ t ⇒ B‹q₂/𝑖›
|
||||
compare0Inner' defs ctx (Coe ty1 p1 q1 val1 _)
|
||||
(Coe ty2 p2 q2 val2 _) ne nf = do
|
||||
compare0Inner' defs ctx sg (Coe ty1 p1 q1 val1 _)
|
||||
(Coe ty2 p2 q2 val2 _) ne nf = do
|
||||
let ty1p = dsub1 ty1 p1; ty2p = dsub1 ty2 p2
|
||||
ty1q = dsub1 ty1 q1; ty2q = dsub1 ty2 q2
|
||||
(ty_p, ty_q) <- bigger (ty1p, ty1q) (ty2p, ty2q)
|
||||
try $ do
|
||||
compareType defs ctx ty1p ty2p
|
||||
compareType defs ctx ty1q ty2q
|
||||
Term.compare0 defs ctx ty_p val1 val2
|
||||
Term.compare0 defs ctx sg ty_p val1 val2
|
||||
pure $ ty_q
|
||||
compare0Inner' defs ctx e@(Coe {}) f _ _ = clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(Coe {}) f _ _ = clashE defs ctx sg e f
|
||||
|
||||
-- (no neutral compositions in a closed dctx)
|
||||
compare0Inner' _ _ (Comp {r = K e _, _}) _ ne _ = void $ absurd $ noOr2 ne
|
||||
compare0Inner' _ _ (Comp {r = B i _, _}) _ _ _ = absurd i
|
||||
compare0Inner' _ _ _ (Comp {r = K _ _, _}) _ nf = void $ absurd $ noOr2 nf
|
||||
compare0Inner' _ _ _ (Comp {r = K {}, _}) _ ne _ = void $ absurd $ noOr2 ne
|
||||
compare0Inner' _ _ _ (Comp {r = B i _, _}) _ _ _ = absurd i
|
||||
compare0Inner' _ _ _ _ (Comp {r = K {}, _}) _ nf = void $ absurd $ noOr2 nf
|
||||
|
||||
-- (type case equality purely structural)
|
||||
compare0Inner' defs ctx (TypeCase ty1 ret1 arms1 def1 eloc)
|
||||
(TypeCase ty2 ret2 arms2 def2 floc) ne _ =
|
||||
local_ Equal $ do
|
||||
ety <- compare0Inner defs ctx ty1 ty2
|
||||
u <- expectTYPE defs ctx eloc ety
|
||||
try $ do
|
||||
compareType defs ctx ret1 ret2
|
||||
compareType defs ctx def1 def2
|
||||
for_ allKinds $ \k =>
|
||||
compareArm defs ctx k ret1 u
|
||||
(lookupPrecise k arms1) (lookupPrecise k arms2) def1
|
||||
pure ret1
|
||||
compare0Inner' defs ctx e@(TypeCase {}) f _ _ = clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg (TypeCase ty1 ret1 arms1 def1 eloc)
|
||||
(TypeCase ty2 ret2 arms2 def2 floc) ne _ =
|
||||
case sg `decEq` SZero of
|
||||
Yes Refl => local_ Equal $ do
|
||||
ety <- compare0Inner defs ctx SZero ty1 ty2
|
||||
u <- expectTYPE defs ctx SZero eloc ety
|
||||
try $ do
|
||||
compareType defs ctx ret1 ret2
|
||||
compareType defs ctx def1 def2
|
||||
for_ allKinds $ \k =>
|
||||
compareArm defs ctx k ret1 u
|
||||
(lookupPrecise k arms1) (lookupPrecise k arms2) def1
|
||||
pure ret1
|
||||
No _ => do
|
||||
putError $ ClashQ eloc sg.qty Zero
|
||||
computeElimTypeE defs ctx sg $ TypeCase ty1 ret1 arms1 def1 eloc
|
||||
compare0Inner' defs ctx sg e@(TypeCase {}) f _ _ = clashE defs ctx sg e f
|
||||
|
||||
-- Ψ | Γ ⊢ s <: f ⇐ A
|
||||
-- --------------------------
|
||||
-- Ψ | Γ ⊢ (s ∷ A) <: f ⇒ A
|
||||
--
|
||||
-- and vice versa
|
||||
compare0Inner' defs ctx (Ann s a _) f _ _ = do
|
||||
try $ Term.compare0 defs ctx a s (E f)
|
||||
compare0Inner' defs ctx sg (Ann s a _) f _ _ = do
|
||||
try $ Term.compare0 defs ctx sg a s (E f)
|
||||
pure a
|
||||
compare0Inner' defs ctx e (Ann t b _) _ _ = do
|
||||
try $ Term.compare0 defs ctx b (E e) t
|
||||
compare0Inner' defs ctx sg e (Ann t b _) _ _ = do
|
||||
try $ Term.compare0 defs ctx sg b (E e) t
|
||||
pure b
|
||||
compare0Inner' defs ctx e@(Ann {}) f _ _ =
|
||||
clashE defs ctx e f
|
||||
compare0Inner' defs ctx sg e@(Ann {}) f _ _ =
|
||||
clashE defs ctx sg e f
|
||||
|
||||
compare0Inner defs ctx e f = do
|
||||
compare0Inner defs ctx sg e f = do
|
||||
let Val n = ctx.termLen
|
||||
Element e ne <- whnf defs ctx e.loc e
|
||||
Element f nf <- whnf defs ctx f.loc f
|
||||
ty <- compare0Inner' defs ctx e f ne nf
|
||||
if !(lift $ isSubSing defs ctx ty)
|
||||
Element e ne <- whnf defs ctx sg e.loc e
|
||||
Element f nf <- whnf defs ctx sg f.loc f
|
||||
ty <- compare0Inner' defs ctx sg e f ne nf
|
||||
if !(lift $ isSubSing defs ctx sg ty) && isJust !(getAt InnerErr)
|
||||
then putAt InnerErr Nothing
|
||||
else modifyAt InnerErr $ map $ WhileComparingE ctx !mode e f
|
||||
else modifyAt InnerErr $ map $ WhileComparingE ctx !mode sg e f
|
||||
pure ty
|
||||
|
||||
|
||||
namespace Term
|
||||
compare0 defs ctx ty s t =
|
||||
wrapErr (WhileComparingT ctx !mode ty s t) $ do
|
||||
compare0 defs ctx sg ty s t =
|
||||
wrapErr (WhileComparingT ctx !mode sg ty s t) $ do
|
||||
let Val n = ctx.termLen
|
||||
Element ty' _ <- whnf defs ctx ty.loc ty
|
||||
Element s' _ <- whnf defs ctx s.loc s
|
||||
Element t' _ <- whnf defs ctx t.loc t
|
||||
Element ty' _ <- whnf defs ctx SZero ty.loc ty
|
||||
Element s' _ <- whnf defs ctx sg s.loc s
|
||||
Element t' _ <- whnf defs ctx sg t.loc t
|
||||
tty <- ensureTyCon ty.loc ctx ty'
|
||||
compare0' defs ctx ty' s' t'
|
||||
compare0' defs ctx sg ty' s' t'
|
||||
|
||||
namespace Elim
|
||||
compare0 defs ctx e f = do
|
||||
(ty, err) <- runStateAt InnerErr Nothing $ compare0Inner defs ctx e f
|
||||
compare0 defs ctx sg e f = do
|
||||
(ty, err) <- runStateAt InnerErr Nothing $ compare0Inner defs ctx sg e f
|
||||
maybe (pure ty) throw err
|
||||
|
||||
compareType defs ctx s t = do
|
||||
let Val n = ctx.termLen
|
||||
Element s' _ <- whnf defs ctx s.loc s
|
||||
Element t' _ <- whnf defs ctx t.loc t
|
||||
Element s' _ <- whnf defs ctx SZero s.loc s
|
||||
Element t' _ <- whnf defs ctx SZero t.loc t
|
||||
ts <- ensureTyCon s.loc ctx s'
|
||||
tt <- ensureTyCon t.loc ctx t'
|
||||
st <- either pure (const $ clashTy s.loc ctx s' t') $
|
||||
|
|
@ -744,9 +750,9 @@ parameters (loc : Loc) (ctx : TyContext d n)
|
|||
|
||||
namespace Term
|
||||
export covering
|
||||
compare : (ty, s, t : Term d n) -> Eff Equal ()
|
||||
compare ty s t = runCompare (fdvAll [ty, s, t]) $ \defs, ectx, th =>
|
||||
compare0 defs ectx (ty // th) (s // th) (t // th)
|
||||
compare : SQty -> (ty, s, t : Term d n) -> Eff Equal ()
|
||||
compare sg ty s t = runCompare (fdvAll [ty, s, t]) $ \defs, ectx, th =>
|
||||
compare0 defs ectx sg (ty // th) (s // th) (t // th)
|
||||
|
||||
export covering
|
||||
compareType : (s, t : Term d n) -> Eff Equal ()
|
||||
|
|
@ -757,13 +763,13 @@ parameters (loc : Loc) (ctx : TyContext d n)
|
|||
||| you don't have to pass the type in but the arguments must still be
|
||||
||| of the same type!!
|
||||
export covering
|
||||
compare : (e, f : Elim d n) -> Eff Equal ()
|
||||
compare e f = runCompare (fdvAll [e, f]) $ \defs, ectx, th =>
|
||||
ignore $ compare0 defs ectx (e // th) (f // th)
|
||||
compare : SQty -> (e, f : Elim d n) -> Eff Equal ()
|
||||
compare sg e f = runCompare (fdvAll [e, f]) $ \defs, ectx, th =>
|
||||
ignore $ compare0 defs ectx sg (e // th) (f // th)
|
||||
|
||||
namespace Term
|
||||
export covering %inline
|
||||
equal, sub, super : (ty, s, t : Term d n) -> Eff Equal ()
|
||||
equal, sub, super : SQty -> (ty, s, t : Term d n) -> Eff Equal ()
|
||||
equal = compare Equal
|
||||
sub = compare Sub
|
||||
super = compare Super
|
||||
|
|
@ -776,7 +782,7 @@ parameters (loc : Loc) (ctx : TyContext d n)
|
|||
|
||||
namespace Elim
|
||||
export covering %inline
|
||||
equal, sub, super : (e, f : Elim d n) -> Eff Equal ()
|
||||
equal, sub, super : SQty -> (e, f : Elim d n) -> Eff Equal ()
|
||||
equal = compare Equal
|
||||
sub = compare Sub
|
||||
super = compare Super
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue