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

remove IsQty interface

Browse source
This commit is contained in:
rhiannon morris 2023-04-01 19:16:43 +02:00
parent 5fdba77d04
commit ba2818a865
24 changed files with 729 additions and 889 deletions
Download patch file Download diff file Expand all files Collapse all files

102
lib/Quox/Equal.idr
View file

@ -13,12 +13,12 @@ public export
EqModeState = State EqMode
public export
0 EqualEff : Type -> List (Type -> Type)
EqualEff q = [ErrorEff q, EqModeState]
0 EqualEff : List (Type -> Type)
EqualEff = [ErrorEff, EqModeState]
public export
0 EqualE : Type -> Type -> Type
EqualE q = Eff $ EqualEff q
0 EqualE : Type -> Type
EqualE = Eff $ EqualEff
export %inline
@ -26,21 +26,21 @@ mode : Has EqModeState fs => Eff fs EqMode
mode = get
parameters (ctx : EqContext q n)
parameters (ctx : EqContext n)
private %inline
clashT : Term q 0 n -> Term q 0 n -> Term q 0 n -> EqualE q a
clashT : Term 0 n -> Term 0 n -> Term 0 n -> EqualE a
clashT ty s t = throw $ ClashT ctx !mode ty s t
private %inline
clashTy : Term q 0 n -> Term q 0 n -> EqualE q a
clashTy : Term 0 n -> Term 0 n -> EqualE a
clashTy s t = throw $ ClashTy ctx !mode s t
private %inline
clashE : Elim q 0 n -> Elim q 0 n -> EqualE q a
clashE : Elim 0 n -> Elim 0 n -> EqualE a
clashE e f = throw $ ClashE ctx !mode e f
private %inline
wrongType : Term q 0 n -> Term q 0 n -> EqualE q a
wrongType : Term 0 n -> Term 0 n -> EqualE a
wrongType ty s = throw $ WrongType ctx ty s
@ -70,7 +70,7 @@ isTyCon (CloT {}) = False
isTyCon (DCloT {}) = False
public export %inline
sameTyCon : (s, t : Term q d n) ->
sameTyCon : (s, t : Term d n) ->
(0 ts : So (isTyCon s)) => (0 tt : So (isTyCon t)) =>
Bool
sameTyCon (TYPE {}) (TYPE {}) = True
@ -91,7 +91,7 @@ sameTyCon (E {}) (E {}) = True
sameTyCon (E {}) _ = False
parameters (defs : Definitions' q g)
parameters (defs : Definitions)
||| true if a type is known to be a subsingleton purely by its form.
||| a subsingleton is a type with only zero or one possible values.
||| equality/subtyping accepts immediately on values of subsingleton types.
@ -102,8 +102,8 @@ parameters (defs : Definitions' q g)
||| boundary separation.
||| * an enum type is a subsingleton if it has zero or one tags.
public export covering
isSubSing : Has (ErrorEff q) fs =>
{n : Nat} -> Term q 0 n -> Eff fs Bool
isSubSing : Has ErrorEff fs =>
{n : Nat} -> Term 0 n -> Eff fs Bool
isSubSing ty0 = do
Element ty0 nc <- whnfT defs ty0
case ty0 of
@ -126,14 +126,14 @@ parameters (defs : Definitions' q g)
export
ensureTyCon : Has (ErrorEff q) fs =>
(ctx : EqContext q n) -> (t : Term q 0 n) ->
ensureTyCon : Has ErrorEff fs =>
(ctx : EqContext n) -> (t : Term 0 n) ->
Eff fs (So (isTyCon t))
ensureTyCon ctx t = case nchoose $ isTyCon t of
Left y => pure y
Right n => throw $ NotType (toTyContext ctx) (t // shift0 ctx.dimLen)
parameters (defs : Definitions' q _) {auto _ : IsQty q}
parameters (defs : Definitions)
mutual
namespace Term
||| `compare0 ctx ty s t` compares `s` and `t` at type `ty`, according to
@ -141,7 +141,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
|||
||| ⚠ **assumes that `s`, `t` have already been checked against `ty`**. ⚠
export covering %inline
compare0 : EqContext q n -> (ty, s, t : Term q 0 n) -> EqualE q ()
compare0 : EqContext n -> (ty, s, t : Term 0 n) -> EqualE ()
compare0 ctx ty s t =
wrapErr (WhileComparingT ctx !mode ty s t) $ do
let Val n = ctx.termLen
@ -154,15 +154,15 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
||| converts an elim "Γ ⊢ e" to "Γ, x ⊢ e x", for comparing with
||| a lambda "Γ ⊢ λx ⇒ t" that has been converted to "Γ, x ⊢ t".
private %inline
toLamBody : Elim q d n -> Term q d (S n)
toLamBody : Elim d n -> Term d (S n)
toLamBody e = E $ weakE e :@ BVT 0
private covering
compare0' : EqContext q n ->
(ty, s, t : Term q 0 n) ->
compare0' : EqContext n ->
(ty, s, t : Term 0 n) ->
(0 nty : NotRedex defs ty) => (0 tty : So (isTyCon ty)) =>
(0 ns : NotRedex defs s) => (0 nt : NotRedex defs t) =>
EqualE q ()
EqualE ()
compare0' ctx (TYPE _) s t = compareType ctx s t
compare0' ctx ty@(Pi {qty, arg, res}) s t {n} = local_ Equal $
@ -184,10 +184,10 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
(E _, t) => wrongType ctx ty t
(s, _) => wrongType ctx ty s
where
ctx' : EqContext q (S n)
ctx' : EqContext (S n)
ctx' = extendTy qty res.name arg ctx
eta : Elim q 0 n -> ScopeTerm q 0 n -> EqualE q ()
eta : Elim 0 n -> ScopeTerm 0 n -> EqualE ()
eta e (S _ (Y b)) = compare0 ctx' res.term (toLamBody e) b
eta e (S _ (N _)) = clashT ctx ty s t
@ -281,7 +281,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
||| compares two types, using the current variance `mode` for universes.
||| fails if they are not types, even if they would happen to be equal.
export covering %inline
compareType : EqContext q n -> (s, t : Term q 0 n) -> EqualE q ()
compareType : EqContext n -> (s, t : Term 0 n) -> EqualE ()
compareType ctx s t = do
let Val n = ctx.termLen
Element s ns <- whnfT defs s
@ -293,11 +293,11 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
compareType' ctx s t
private covering
compareType' : EqContext q n -> (s, t : Term q 0 n) ->
compareType' : EqContext n -> (s, t : Term 0 n) ->
(0 ns : NotRedex defs s) => (0 ts : So (isTyCon s)) =>
(0 nt : NotRedex defs t) => (0 tt : So (isTyCon t)) =>
(0 st : So (sameTyCon s t)) =>
EqualE q ()
EqualE ()
-- equality is the same as subtyping, except with the
-- "≤" in the TYPE rule being replaced with "="
compareType' ctx (TYPE k) (TYPE l) =
@ -313,7 +313,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
-- Γ ⊢ (π·x : A₁) → B₁ <: (π·x : A₂) → B₂
expectEqualQ sQty tQty
local flip $ compareType ctx sArg tArg -- contra
compareType (extendTy zero sRes.name sArg ctx) sRes.term tRes.term
compareType (extendTy Zero sRes.name sArg ctx) sRes.term tRes.term
compareType' ctx (Sig {fst = sFst, snd = sSnd, _})
(Sig {fst = tFst, snd = tSnd, _}) = do
@ -321,7 +321,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
-- --------------------------------------
-- Γ ⊢ (x : A₁) × B₁ <: (x : A₂) × B₂
compareType ctx sFst tFst
compareType (extendTy zero sSnd.name sFst ctx) sSnd.term tSnd.term
compareType (extendTy Zero sSnd.name sFst ctx) sSnd.term tSnd.term
compareType' ctx (Eq {ty = sTy, l = sl, r = sr, _})
(Eq {ty = tTy, l = tl, r = tr, _}) = do
@ -361,9 +361,9 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
|||
||| ⚠ **assumes the elim is already typechecked.** ⚠
private covering
computeElimType : EqContext q n -> (e : Elim q 0 n) ->
computeElimType : EqContext n -> (e : Elim 0 n) ->
(0 ne : NotRedex defs e) ->
EqualE q (Term q 0 n)
EqualE (Term 0 n)
computeElimType ctx (F x) _ = do
defs <- lookupFree' defs x
pure $ injectT ctx defs.type
@ -381,9 +381,9 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
computeElimType ctx (_ :# ty) _ = pure ty
private covering
replaceEnd : EqContext q n ->
(e : Elim q 0 n) -> DimConst -> (0 ne : NotRedex defs e) ->
EqualE q (Elim q 0 n)
replaceEnd : EqContext n ->
(e : Elim 0 n) -> DimConst -> (0 ne : NotRedex defs e) ->
EqualE (Elim 0 n)
replaceEnd ctx e p ne = do
(ty, l, r) <- expectEqE defs ctx !(computeElimType ctx e ne)
pure $ ends l r p :# dsub1 ty (K p)
@ -397,7 +397,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
||| ⚠ **assumes that they have both been typechecked, and have
||| equal types.** ⚠
export covering %inline
compare0 : EqContext q n -> (e, f : Elim q 0 n) -> EqualE q ()
compare0 : EqContext n -> (e, f : Elim 0 n) -> EqualE ()
compare0 ctx e f =
wrapErr (WhileComparingE ctx !mode e f) $ do
let Val n = ctx.termLen
@ -408,10 +408,10 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
compare0' ctx e f ne nf
private covering
compare0' : EqContext q n ->
(e, f : Elim q 0 n) ->
compare0' : EqContext n ->
(e, f : Elim 0 n) ->
(0 ne : NotRedex defs e) -> (0 nf : NotRedex defs f) ->
EqualE q ()
EqualE ()
-- replace applied equalities with the appropriate end first
-- e.g. e : Eq [i ⇒ A] s t ⊢ e 𝟎 = s : A‹𝟎/i›
--
@ -439,7 +439,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
local_ Equal $ do
compare0 ctx e f
ety <- computeElimType ctx e (noOr1 ne)
compareType (extendTy zero eret.name ety ctx) eret.term fret.term
compareType (extendTy Zero eret.name ety ctx) eret.term fret.term
(fst, snd) <- expectSigE defs ctx ety
let [< x, y] = ebody.names
Term.compare0 (extendTyN [< (epi, x, fst), (epi, y, snd.term)] ctx)
@ -453,13 +453,13 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
local_ Equal $ do
compare0 ctx e f
ety <- computeElimType ctx e (noOr1 ne)
compareType (extendTy zero eret.name ety ctx) eret.term fret.term
compareType (extendTy Zero eret.name ety ctx) eret.term fret.term
for_ !(expectEnumE defs ctx ety) $ \t =>
compare0 ctx (sub1 eret $ Tag t :# ety)
!(lookupArm t earms) !(lookupArm t farms)
expectEqualQ epi fpi
where
lookupArm : TagVal -> CaseEnumArms q d n -> EqualE q (Term q d n)
lookupArm : TagVal -> CaseEnumArms d n -> EqualE (Term d n)
lookupArm t arms = case lookup t arms of
Just arm => pure arm
Nothing => throw $ TagNotIn t (fromList $ keys arms)
@ -470,7 +470,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
local_ Equal $ do
compare0 ctx e f
ety <- computeElimType ctx e (noOr1 ne)
compareType (extendTy zero eret.name ety ctx) eret.term fret.term
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)
@ -485,7 +485,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
local_ Equal $ do
compare0 ctx e f
ety <- computeElimType ctx e (noOr1 ne)
compareType (extendTy zero eret.name ety ctx) eret.term fret.term
compareType (extendTy Zero eret.name ety ctx) eret.term fret.term
(q, ty) <- expectBOXE defs ctx ety
compare0 (extendTy (epi * q) ebody.name ty ctx)
(substCaseBoxRet ety eret)
@ -496,7 +496,7 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
compare0' ctx (s :# a) (t :# b) _ _ =
Term.compare0 ctx !(bigger a b) s t
where
bigger : forall a. a -> a -> EqualE q a
bigger : forall a. a -> a -> EqualE a
bigger l r = mode <&> \case Super => l; _ => r
compare0' ctx (s :# a) f _ _ = Term.compare0 ctx a s (E f)
@ -504,16 +504,14 @@ parameters (defs : Definitions' q _) {auto _ : IsQty q}
compare0' ctx e@(_ :# _) f _ _ = clashE ctx e f
parameters {auto _ : (Has (DefsReader' q _) fs, Has (ErrorEff q) fs)}
{auto _ : IsQty q}
(ctx : TyContext q d n)
parameters {auto _ : (Has DefsReader fs, Has ErrorEff fs)} (ctx : TyContext d n)
-- [todo] only split on the dvars that are actually used anywhere in
-- the calls to `splits`
parameters (mode : EqMode)
namespace Term
export covering
compare : (ty, s, t : Term q d n) -> Eff fs ()
compare : (ty, s, t : Term d n) -> Eff fs ()
compare ty s t = do
defs <- ask
map fst $ runState @{Z} mode $
@ -522,7 +520,7 @@ parameters {auto _ : (Has (DefsReader' q _) fs, Has (ErrorEff q) fs)}
lift $ compare0 defs ectx (ty // th) (s // th) (t // th)
export covering
compareType : (s, t : Term q d n) -> Eff fs ()
compareType : (s, t : Term d n) -> Eff fs ()
compareType s t = do
defs <- ask
map fst $ runState @{Z} mode $
@ -534,7 +532,7 @@ parameters {auto _ : (Has (DefsReader' q _) fs, Has (ErrorEff q) fs)}
||| you don't have to pass the type in but the arguments must still be
||| of the same type!!
export covering %inline
compare : (e, f : Elim q d n) -> Eff fs ()
compare : (e, f : Elim d n) -> Eff fs ()
compare e f = do
defs <- ask
map fst $ runState @{Z} mode $
@ -544,20 +542,20 @@ parameters {auto _ : (Has (DefsReader' q _) fs, Has (ErrorEff q) fs)}
namespace Term
export covering %inline
equal, sub, super : (ty, s, t : Term q d n) -> Eff fs ()
equal, sub, super : (ty, s, t : Term d n) -> Eff fs ()
equal = compare Equal
sub = compare Sub
super = compare Super
export covering %inline
equalType, subtype, supertype : (s, t : Term q d n) -> Eff fs ()
equalType, subtype, supertype : (s, t : Term d n) -> Eff fs ()
equalType = compareType Equal
subtype = compareType Sub
supertype = compareType Super
namespace Elim
export covering %inline
equal, sub, super : (e, f : Elim q d n) -> Eff fs ()
equal, sub, super : (e, f : Elim d n) -> Eff fs ()
equal = compare Equal
sub = compare Sub
super = compare Super