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

wip

Browse source
This commit is contained in:
rhiannon morris 2023-08-13 20:55:14 +02:00
parent 0dd3c231e6
commit 7a6c4c61d1
7 changed files with 201 additions and 96 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
examples/natw.quox Normal file
View file

@ -0,0 +1,36 @@
load "misc.quox"
namespace natw {
def0 Tag : ★ = {z, s}
def0 Child : Tag → ★ =
λ t ⇒ case t return ★ of { 'z ⇒ {}; 's ⇒ {pred} }
def0 NatW : ★ = (t : Tag) ⊲ Child t
def Zero : NatW =
'z ⋄ (λ v ⇒ case v return NatW of {})
def Suc : ω.NatW → NatW =
λ n ⇒ 's ⋄ (λ u ⇒ case u return NatW of { 'pred ⇒ n })
def elim : 0.(P : NatW → ★) →
ω.(P Zero) →
ω.(0.(n : NatW) → ω.(P n) → P (Suc n)) →
ω.(n : NatW) → P n =
λ P pz ps n ⇒
caseω n return n' ⇒ P n' of {
t ⋄ f, ω.ih ⇒
(case t
return t' ⇒ 0.(eq : t ≡ t' : Tag) →
P (t' ⋄ coe (𝑖 ⇒ ω.(Child (eq @𝑖)) → NatW) f)
of {
'z ⇒ λ _ ⇒ pz;
's ⇒ λ eq ⇒
ps (f (coe (𝑖 ⇒ Child (eq @𝑖)) @1 @0 'pred))
(ih (coe (𝑖 ⇒ Child (eq @𝑖)) @1 @0 'pred))
}) (δ 𝑖 ⇒ t)
}
}

27
lib/Quox/Equal.idr
View file

@ -521,10 +521,13 @@ parameters (defs : Definitions)
compare0 ctx e f
ety <- computeElimTypeE defs ctx e @{noOr1 ne}
compareType (extendTy Zero eret.name ety ctx) eret.term fret.term
for_ !(expectEnum defs ctx eloc ety) $ \t => do
l <- lookupArm eloc t earms
for_ (SortedMap.toList earms) $ \(t, l) => do
r <- lookupArm floc t farms
compare0 ctx (sub1 eret $ Ann (Tag t l.loc) ety l.loc) l r
-- for_ !(expectEnum defs ctx eloc ety) $ \t => do
-- l <- lookupArm eloc t earms
-- r <- lookupArm floc t farms
-- compare0 ctx (sub1 eret $ Ann (Tag t l.loc) ety l.loc) l r
expectEqualQ eloc epi fpi
where
lookupArm : Loc -> TagVal -> CaseEnumArms d n -> Equal_ (Term d n)
@ -592,16 +595,18 @@ parameters (defs : Definitions)
-- Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖›
-- Ψ | Γ ⊢ A‹q₁/𝑖› <: B‹q₂/𝑖›
-- Ψ | Γ ⊢ e <: f ⇒ _
-- (non-neutral forms have the coercion already pushed in)
-- Ψ | Γ ⊢ s <: t ⇐ B‹p₂/𝑖›
-- -----------------------------------------------------------
-- Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ e
-- <: coe [𝑖 ⇒ B] @p₂ @q₂ f ⇒ B‹q₂/𝑖›
compare0' ctx (Coe ty1 p1 q1 (E val1) _)
(Coe ty2 p2 q2 (E val2) _) ne nf = do
compareType ctx (dsub1 ty1 p1) (dsub1 ty2 p2)
compareType ctx (dsub1 ty1 q1) (dsub1 ty2 q2)
compare0 ctx val1 val2
-- Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ s
-- <: coe [𝑖 ⇒ B] @p₂ @q₂ t ⇒ B‹q₂/𝑖›
compare0' ctx (Coe ty1 p1 q1 val1 _)
(Coe ty2 p2 q2 val2 _) ne nf = do
let typ1 = dsub1 ty1 p1; tyq1 = dsub1 ty1 q1
typ2 = dsub1 ty2 p2; tyq2 = dsub1 ty2 q2
compareType ctx typ1 typ2
compareType ctx tyq1 tyq2
let ty = case !mode of Super => typ1; _ => typ2
Term.compare0 ctx ty val1 val2
compare0' ctx e@(Coe {}) f _ _ = clashE e.loc ctx e f
-- (no neutral compositions in a closed dctx)

15
lib/Quox/No.idr
View file

@ -52,3 +52,18 @@ export %inline
nchoose : (b : Bool) -> Either (So b) (No b)
nchoose True = Left Oh
nchoose False = Right Ah
private
0 notFalseTrue : (a : Bool) -> not a = True -> a = False
notFalseTrue False Refl = Refl
export %inline
soNot : So (not a) -> No a
soNot x with 0 (not a) proof eq
soNot Oh | True =
rewrite notFalseTrue a eq in Ah
export %inline
soNot' : So a -> No (not a)
soNot' Oh = Ah

190
lib/Quox/Reduce.idr
View file

@ -119,10 +119,10 @@ isTyCon : Term {} -> Bool
isTyCon (TYPE {}) = True
isTyCon (Pi {}) = True
isTyCon (Lam {}) = False
isTyCon (W {}) = True
isTyCon (Sup {}) = False
isTyCon (Sig {}) = True
isTyCon (Pair {}) = False
isTyCon (W {}) = True
isTyCon (Sup {}) = False
isTyCon (Enum {}) = True
isTyCon (Tag {}) = False
isTyCon (Eq {}) = True
@ -136,6 +136,37 @@ isTyCon (E {}) = False
isTyCon (CloT {}) = False
isTyCon (DCloT {}) = False
||| canPushCoe A s is true if a coercion along (𝑖 ⇒ A) on s can be pushed.
||| for a type with η like functions, or a ground type like ℕ,
||| this is true for any s.
||| otherwise, like for pairs, it is only true if s is a constructor form.
||| if A isn't a type, or isn't in whnf, then the question is meaningless. but
||| it returns False anyway.
public export %inline
canPushCoe : Term (S d) n -> Term d n -> Bool
canPushCoe (TYPE {}) _ = True
canPushCoe (Pi {}) _ = True
canPushCoe (Lam {}) _ = False
canPushCoe (Sig {}) (Pair {}) = True
canPushCoe (Sig {}) _ = False
canPushCoe (Pair {}) _ = False
canPushCoe (W {}) (Sup {}) = True
canPushCoe (W {}) _ = False
canPushCoe (Sup {}) _ = False
canPushCoe (Enum {}) _ = True
canPushCoe (Tag {}) _ = False
canPushCoe (Eq {}) _ = True
canPushCoe (DLam {}) _ = False
canPushCoe (Nat {}) _ = True
canPushCoe (Zero {}) _ = False
canPushCoe (Succ {}) _ = False
canPushCoe (BOX {}) _ = True
canPushCoe (Box {}) _ = False
canPushCoe (E {}) _ = False
canPushCoe (CloT {}) _ = False
canPushCoe (DCloT {}) _ = False
||| true if a term is syntactically a type, or a neutral.
public export %inline
isTyConE : Term {} -> Bool
@ -175,8 +206,9 @@ mutual
isRedexE defs fun || isDLamHead fun || isK arg
isRedexE defs (Ann {tm, ty, _}) =
isE tm || isRedexT defs tm || isRedexT defs ty
isRedexE defs (Coe {val, _}) =
isRedexT defs val || not (isE val)
isRedexE defs (Coe {ty, val, _}) =
let ty = assert_smaller ty ty.term in
isRedexT defs ty || canPushCoe ty val
isRedexE defs (Comp {ty, r, _}) =
isRedexT defs ty || isK r
isRedexE defs (TypeCase {ty, ret, _}) =
@ -585,111 +617,106 @@ reduceTypeCase defs ctx ty u ret arms def loc = case ty of
||| pushes a coercion inside a whnf-ed term
private covering
pushCoe : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
BindName ->
(ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) =>
BindName -> (ty : Term (S d) n) ->
Dim d -> Dim d ->
(s : Term d n) -> (0 snf : No (isRedexT defs s)) => Loc ->
(s : Term d n) -> (0 snf : No (isRedexT defs s)) =>
(0 pc : So (canPushCoe ty s)) => Loc ->
Eff Whnf (NonRedex Elim d n defs)
pushCoe defs ctx i ty p q s loc =
if p == q then whnf defs ctx $ Ann s (ty // one q) loc else
case s of
-- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ)
TYPE {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
Pi {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
W {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
Sig {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
Enum {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
Eq {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
Nat {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
BOX {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
case ty of
-- (coe ★ᵢ @p @q s) ⇝ (s ∷ ★ᵢ)
--
-- no η (what would that even mean), but ground type
TYPE {l, loc = tyLoc} =>
whnf defs ctx $ Ann s (TYPE l tyLoc) loc
-- just η expand it. then whnf for App will handle it later
-- this is how @xtt does it
--
-- (coe [i ⇒ A] @p @q (λ x ⇒ s)) ⇝
-- (λ y ⇒ (coe [i ⇒ A] @p @q (λ x ⇒ s)) y) ∷ A‹q/i› ⇝ ⋯
lam@(Lam {body, _}) => do
let lam' = CoeT i ty p q lam loc
term' = LamY !(fresh body.name)
(E $ App (weakE 1 lam') (BVT 0 loc) loc) loc
type' = ty // one q
whnf defs ctx $ Ann term' type' loc
-- (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) ⇝
-- (λ y ⇒ (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) y)
-- ∷ (π.(x : A) → B)‹q/𝑖›
Pi {} => do
y <- mnb "y" loc
let s' = Coe (SY [< i] ty) p q s loc
body = SY [< y] $ E $ App (weakE 1 s') (BVT 0 y.loc) s.loc
ret = ty // one q
whnf defs ctx $ Ann (Lam body loc) ret loc
-- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝
-- (coe [i ⇒ A] @p @q s,
-- coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t)
-- ∷ (x : A‹q/i›) × B‹q/i›
--
-- can't use η here because... it doesn't exist
Pair {fst, snd, loc = pairLoc} => do
let Sig {fst = tfst, snd = tsnd, loc = sigLoc} = ty
| _ => throw $ ExpectedSig ty.loc (extendDim i ctx.names) ty
let fst' = E $ CoeT i tfst p q fst fst.loc
-- no η so only reduce on an actual pair 🍐
Sig {fst = tfst, snd = tsnd, loc = tyLoc} => do
let Pair fst snd sLoc = s
fst' = E $ CoeT i tfst p q fst fst.loc
tfst' = tfst // (B VZ i.loc ::: shift 2)
tsnd' = sub1 tsnd $
CoeT !(fresh i) tfst' (weakD 1 p) (B VZ snd.loc)
(dweakT 1 fst) snd.loc
snd' = E $ CoeT i tsnd' p q snd snd.loc
pure $
Element (Ann (Pair fst' snd' pairLoc)
(Sig (tfst // one q) (tsnd // one q) sigLoc) loc) Ah
pure $ nred $
Ann (Pair fst' snd' sLoc)
(Sig (tfst // one q) (tsnd // one q) tyLoc) loc
-- (coe [i ⇒ (x : A) ⊲ π.B] @p @q (s ⋄ t) ⇝
-- (coe [i ⇒ A] @p @q s ⋄
-- coe [i ⇒ ω.B[coe [j ⇒ A‹j/i›] @p @i s/x] → (x : A) ⊲ B] t)
-- ∷ ((x : A) ⊲ B)‹q/i›
Sup {root, sub, loc = supLoc} => do
let W {shape, body, loc = wLoc} = ty
| _ => throw $ ExpectedW ty.loc (extendDim i ctx.names) ty
let root' = E $ CoeT i shape p q root root.loc
tsub0 = sub1 body $
CoeT !(fresh i) (shape // (B VZ root.loc ::: shift 2))
(weakD 1 p) (BV 0 sub.loc)
(dweakT 1 sub) sub.loc
tsub' = Arr Any tsub0 ty sub.loc
--
-- again, no η
W {shape, body, loc = tyLoc} => do
let Sup root sub sLoc = s
root' = E $ CoeT i shape p q root root.loc
shape' = shape // (B VZ i.loc ::: shift 2)
coeRoot =
CoeT (setLoc shape.loc !(fresh i)) shape'
(weakD 1 p) (B VZ i.loc) (dweakT 1 root) root.loc
tsub' = Arr Any (sub1 body coeRoot) ty sub.loc
sub' = E $ CoeT i tsub' p q sub sub.loc
pure $
Element (Ann (Sup root' sub' supLoc)
(W (shape // one q) (body // one q) wLoc) loc) Ah
pure $ nred $
Ann (Sup root' sub' sLoc)
(W (shape // one q) (body // one q) tyLoc) loc
-- (coe {𝗮, …} @p @q s) ⇝ (s ∷ {𝗮, …})
--
-- no η, but ground type
Enum {cases, loc = tyLoc} =>
whnf defs ctx $ Ann s (Enum cases tyLoc) loc
-- η expand, like for Lam
--
-- (coe [i ⇒ A] @p @q (δ j ⇒ s)) ⇝
-- (δ k ⇒ (coe [i ⇒ A] @p @q (δ j ⇒ s)) @k) ∷ A‹q/i› ⇝ ⋯
dlam@(DLam {body, _}) => do
let dlam' = CoeT i ty p q dlam loc
term' = DLamY !(mnb "j" loc)
(E $ DApp (dweakE 1 dlam') (B VZ loc) loc) loc
type' = ty // one q
whnf defs ctx $ Ann term' type' loc
-- (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s) ⇝
-- (δ k ⇒ (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s) @k)
-- ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖›
Eq {} => do
k <- mnb "k" loc
let s' = Coe (SY [< i] ty) p q s loc
term = DLam (SY [< k] $ E $ DApp (dweakE 1 s') (BV 0 k.loc) loc) loc
ret = ty // one q
whnf defs ctx $ Ann term ret loc
-- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯})
Tag {tag, loc = tagLoc} => do
let Enum {cases, loc = enumLoc} = ty
| _ => throw $ ExpectedEnum ty.loc (extendDim i ctx.names) ty
pure $ Element (Ann (Tag tag tagLoc) (Enum cases enumLoc) loc) Ah
-- (coe ℕ @p @q s) ⇝ (s ∷ ℕ)
--
-- no η, but ground type
Nat {loc = tyLoc} =>
whnf defs ctx $ Ann s (Nat tyLoc) loc
-- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ)
Zero {loc = zeroLoc} => do
pure $ Element (Ann (Zero zeroLoc) (Nat ty.loc) loc) Ah
Succ {p = pred, loc = succLoc} => do
pure $ Element (Ann (Succ pred succLoc) (Nat ty.loc) loc) Ah
-- (coe [i ⇒ [π.A]] @p @q [s]) ⇝
-- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›]
Box {val, loc = boxLoc} => do
let BOX {qty, ty = a, loc = tyLoc} = ty
| _ => throw $ ExpectedBOX ty.loc (extendDim i ctx.names) ty
pure $ Element
(Ann (Box (E $ CoeT i a p q val val.loc) boxLoc)
(BOX qty (a // one q) tyLoc) loc)
Ah
E e => pure $ Element (CoeT i ty p q (E e) e.loc) (snf `orNo` Ah)
where
unwrapTYPE : Term (S d) n -> Eff Whnf Universe
unwrapTYPE (TYPE {l, _}) = pure l
unwrapTYPE ty = throw $ ExpectedTYPE ty.loc (extendDim i ctx.names) ty
-- (coe (𝑖 ⇒ [π. A]) @p @q s) ⇝
-- [coe (𝑖 ⇒ A) @p @q (case1 s ∷ [π. A‹p/𝑖›] return A‹p/𝑖› of {[x] ⇒ x})]
-- ∷ [π. A‹q/𝑖›]
--
-- [todo] box should probably have an η rule
BOX {qty, ty = innerTy, loc = tyLoc} => do
let s' = Ann s (BOX qty (innerTy // one p) tyLoc) s.loc
inner' = CaseBox One s' (SN $ innerTy // one p)
(SY [< !(mnb "x" s.loc)] $ BVT 0 s.loc) s.loc
inner = Box (E $ CoeT i innerTy p q (E inner') loc) loc
ret = BOX qty (innerTy // one q) tyLoc
whnf defs ctx $ Ann inner ret loc
export covering
@ -862,7 +889,10 @@ CanWhnf Elim Reduce.isRedexE where
whnf defs ctx (Coe (S [< i] (Y ty)) p q val coeLoc) = do
Element ty tynf <- whnf defs (extendDim i ctx) ty
Element val valnf <- whnf defs ctx val
pushCoe defs ctx i ty p q val coeLoc
case nchoose $ canPushCoe ty val of
Right n => pure $ Element (Coe (SY [< i] ty) p q val coeLoc) $
tynf `orNo` n
Left y => pushCoe defs ctx i ty p q val coeLoc
whnf defs ctx (Comp ty p q val r zero one compLoc) =
-- comp [A] @p @p s { ⋯ } ⇝ s ∷ A

5
lib/Quox/Syntax/Term/Base.idr
View file

@ -361,6 +361,11 @@ public export %inline
enum : List TagVal -> Loc -> Term d n
enum ts loc = Enum (SortedSet.fromList ts) loc
public export %inline
caseEnum : Qty -> Elim d n -> ScopeTerm d n -> List (TagVal, Term d n) -> Loc ->
Elim d n
caseEnum q e ret arms loc = CaseEnum q e ret (SortedMap.fromList arms) loc
public export %inline
typeCase : Elim d n -> Term d n ->
List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n

8
lib/Quox/Syntax/Term/Subst.idr
View file

@ -147,24 +147,24 @@ weakE by t = t // shift by
parameters {s : Nat}
namespace ScopeTermBody
export %inline
public export %inline
(.term) : ScopedBody s (Term d) n -> Term d (s + n)
(Y b).term = b
(N b).term = weakT s b
namespace ScopeTermN
export %inline
public export %inline
(.term) : ScopeTermN s d n -> Term d (s + n)
t.term = t.body.term
namespace DScopeTermBody
export %inline
public export %inline
(.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
(Y b).term = b
(N b).term = dweakT s b
namespace DScopeTermN
export %inline
public export %inline
(.term) : DScopeTermN s d n -> Term (s + d) n
t.term = t.body.term

14
tests/Tests/Equal.idr
View file

@ -16,6 +16,8 @@ defGlobals = fromList
("a'", ^mkPostulate gany (^FT "A" 0)),
("b", ^mkPostulate gany (^FT "B" 0)),
("f", ^mkPostulate gany (^Arr One (^FT "A" 0) (^FT "A" 0))),
("absurd", ^mkDef gany (^Arr One (^enum []) (^FT "A" 0))
(^LamY "v" (E $ ^caseEnum One (^BV 0) (SN $ ^FT "A" 0) []))),
("id", ^mkDef gany (^Arr One (^FT "A" 0) (^FT "A" 0)) (^LamY "x" (^BVT 0))),
("eq-AB", ^mkPostulate gzero (^Eq0 (^TYPE 0) (^FT "A" 0) (^FT "B" 0))),
("two", ^mkDef gany (^Nat) (^Succ (^Succ (^Zero))))]
@ -517,6 +519,18 @@ tests = "equality & subtyping" :- [
todo "pair elim",
todo "w types",
"sup" :- [
testEq "a ⋄ absurd ≡ a ⋄ absurd : A ⊲ {}" $
equalT empty
(^W (^FT "A" 0) (SN $ ^enum []))
(^Sup (^FT "a" 0) (^FT "absurd" 0))
(^Sup (^FT "a" 0) (^FT "absurd" 0))
],
todo "w elim",
todo "enum types",
todo "enum",
todo "enum elim",