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

wip make qtys into polynomials

Browse source
This commit is contained in:
rhiannon morris 2024-05-27 21:28:22 +02:00
parent 1d8a6bb325
commit 4c008577b4
22 changed files with 1650 additions and 1254 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -32,11 +32,11 @@ import Derive.Prelude
public export
TermLike : Type
TermLike = Nat -> Nat -> Type
TermLike = (q, d, n : Nat) -> Type
public export
TSubstLike : Type
TSubstLike = Nat -> Nat -> Nat -> Type
TSubstLike = (q, d, n1, n2 : Nat) -> Type
public export
Universe : Type
@ -50,156 +50,162 @@ TagVal = String
mutual
public export
TSubst : TSubstLike
TSubst d = Subst $ \n => Elim d n
TSubst q d = Subst $ \n => Elim q d n
||| first argument `d` is dimension scope size;
||| second `n` is term scope size
public export
data Term : (d, n : Nat) -> Type where
data Term : (q, d, n : Nat) -> Type where
||| type of types
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
TYPE : (l : Universe) -> (loc : Loc) -> Term q d n
||| IO state token. this is a builtin because otherwise #[main] being a
||| builtin makes no sense
IOState : (loc : Loc) -> Term d n
IOState : (loc : Loc) -> Term q d n
||| function type
Pi : (qty : Qty) -> (arg : Term d n) ->
(res : ScopeTerm d n) -> (loc : Loc) -> Term d n
Pi : (qty : Qty q) -> (arg : Term q d n) ->
(res : ScopeTerm q d n) -> (loc : Loc) -> Term q d n
||| function term
Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
Lam : (body : ScopeTerm q d n) -> (loc : Loc) -> Term q d n
||| pair type
Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n
Sig : (fst : Term q d n) -> (snd : ScopeTerm q d n) -> (loc : Loc) ->
Term q d n
||| pair value
Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
Pair : (fst, snd : Term q d n) -> (loc : Loc) -> Term q d n
||| enumeration type
Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n
Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term q d n
||| enumeration value
Tag : (tag : TagVal) -> (loc : Loc) -> Term d n
Tag : (tag : TagVal) -> (loc : Loc) -> Term q d n
||| equality type
Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n
Eq : (ty : DScopeTerm q d n) -> (l, r : Term q d n) -> (loc : Loc) ->
Term q d n
||| equality term
DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
DLam : (body : DScopeTerm q d n) -> (loc : Loc) -> Term q d n
||| natural numbers (temporary until 𝐖 gets added)
NAT : (loc : Loc) -> Term d n
Nat : (val : Nat) -> (loc : Loc) -> Term d n
Succ : (p : Term d n) -> (loc : Loc) -> Term d n
NAT : (loc : Loc) -> Term q d n
Nat : (val : Nat) -> (loc : Loc) -> Term q d n
Succ : (p : Term q d n) -> (loc : Loc) -> Term q d n
||| strings
STRING : (loc : Loc) -> Term d n
Str : (str : String) -> (loc : Loc) -> Term d n
STRING : (loc : Loc) -> Term q d n
Str : (str : String) -> (loc : Loc) -> Term q d n
||| "box" (package a value up with a certain quantity)
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
Box : (val : Term d n) -> (loc : Loc) -> Term d n
BOX : (qty : Qty q) -> (ty : Term q d n) -> (loc : Loc) -> Term q d n
Box : (val : Term q d n) -> (loc : Loc) -> Term q d n
Let : (qty : Qty) -> (rhs : Elim d n) ->
(body : ScopeTerm d n) -> (loc : Loc) -> Term d n
Let : (qty : Qty q) -> (rhs : Elim q d n) ->
(body : ScopeTerm q d n) -> (loc : Loc) -> Term q d n
||| elimination
E : (e : Elim d n) -> Term d n
E : (e : Elim q d n) -> Term q d n
||| term closure/suspended substitution
CloT : WithSubst (Term d) (Elim d) n -> Term d n
CloT : WithSubst (Term q d) (Elim q d) n -> Term q d n
||| dimension closure/suspended substitution
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
DCloT : WithSubst (\d => Term q d n) Dim d -> Term q d n
||| quantity closure/suspended substitution
QCloT : WithSubstR (\q => Term q d n) Qty q -> Term q d n
%name Term s, t, r
||| first argument `d` is dimension scope size, second `n` is term scope size
public export
data Elim : (d, n : Nat) -> Type where
data Elim : (q, d, n : Nat) -> Type where
||| free variable, possibly with a displacement (see @crude, or @mugen for a
||| more abstract and formalised take)
|||
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim q d n
||| bound variable
B : (i : Var n) -> (loc : Loc) -> Elim d n
B : (i : Var n) -> (loc : Loc) -> Elim q d n
||| term application
App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n
App : (fun : Elim q d n) -> (arg : Term q d n) -> (loc : Loc) -> Elim q d n
||| pair destruction
|||
||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
CasePair : (qty : Qty) -> (pair : Elim d n) ->
(ret : ScopeTerm d n) ->
(body : ScopeTermN 2 d n) ->
CasePair : (qty : Qty q) -> (pair : Elim q d n) ->
(ret : ScopeTerm q d n) ->
(body : ScopeTermN 2 q d n) ->
(loc : Loc) ->
Elim d n
Elim q d n
||| first element of a pair. only works in non-linear contexts.
Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
Fst : (pair : Elim q d n) -> (loc : Loc) -> Elim q d n
||| second element of a pair. only works in non-linear contexts.
Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
Snd : (pair : Elim q d n) -> (loc : Loc) -> Elim q d n
||| enum matching
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
(ret : ScopeTerm d n) ->
(arms : CaseEnumArms d n) ->
CaseEnum : (qty : Qty q) -> (tag : Elim q d n) ->
(ret : ScopeTerm q d n) ->
(arms : CaseEnumArms q d n) ->
(loc : Loc) ->
Elim d n
Elim q d n
||| nat matching
CaseNat : (qty, qtyIH : Qty) -> (nat : Elim d n) ->
(ret : ScopeTerm d n) ->
(zero : Term d n) ->
(succ : ScopeTermN 2 d n) ->
CaseNat : (qty, qtyIH : Qty q) -> (nat : Elim q d n) ->
(ret : ScopeTerm q d n) ->
(zero : Term q d n) ->
(succ : ScopeTermN 2 q d n) ->
(loc : Loc) ->
Elim d n
Elim q d n
||| unboxing
CaseBox : (qty : Qty) -> (box : Elim d n) ->
(ret : ScopeTerm d n) ->
(body : ScopeTerm d n) ->
CaseBox : (qty : Qty q) -> (box : Elim q d n) ->
(ret : ScopeTerm q d n) ->
(body : ScopeTerm q d n) ->
(loc : Loc) ->
Elim d n
Elim q d n
||| dim application
DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n
DApp : (fun : Elim q d n) -> (arg : Dim d) -> (loc : Loc) -> Elim q d n
||| type-annotated term
Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
Ann : (tm, ty : Term q d n) -> (loc : Loc) -> Elim q d n
||| coerce a value along a type equality, or show its coherence
||| [@xtt; §2.1.1]
Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
(val : Term d n) -> (loc : Loc) -> Elim d n
Coe : (ty : DScopeTerm q d n) -> (p, p' : Dim d) ->
(val : Term q d n) -> (loc : Loc) -> Elim q d n
||| "generalised composition" [@xtt; §2.1.2]
Comp : (ty : Term d n) -> (p, q : Dim d) ->
(val : Term d n) -> (r : Dim d) ->
(zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
Comp : (ty : Term q d n) -> (p, p' : Dim d) ->
(val : Term q d n) -> (r : Dim d) ->
(zero, one : DScopeTerm q d n) -> (loc : Loc) -> Elim q d n
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
TypeCase : (ty : Elim d n) -> (ret : Term d n) ->
(arms : TypeCaseArms d n) -> (def : Term d n) ->
TypeCase : (ty : Elim q d n) -> (ret : Term q d n) ->
(arms : TypeCaseArms q d n) -> (def : Term q d n) ->
(loc : Loc) ->
Elim d n
Elim q d n
||| term closure/suspended substitution
CloE : WithSubst (Elim d) (Elim d) n -> Elim d n
CloE : WithSubst (Elim q d) (Elim q d) n -> Elim q d n
||| dimension closure/suspended substitution
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
DCloE : WithSubst (\d => Elim q d n) Dim d -> Elim q d n
||| quantity closure/suspended substitution
QCloE : WithSubstR (\q => Elim q d n) Qty q -> Elim q d n
%name Elim e, f
public export
CaseEnumArms : TermLike
CaseEnumArms d n = SortedMap TagVal (Term d n)
CaseEnumArms q d n = SortedMap TagVal (Term q d n)
public export
TypeCaseArms : TermLike
TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
TypeCaseArms q d n = SortedDMap TyConKind (\k => TypeCaseArmBody k q d n)
public export
TypeCaseArm : TermLike
TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
TypeCaseArm q d n = (k ** TypeCaseArmBody k q d n)
public export
TypeCaseArmBody : TyConKind -> TermLike
@ -208,35 +214,27 @@ mutual
public export
ScopeTermN, DScopeTermN : Nat -> TermLike
ScopeTermN s d n = Scoped s (Term d) n
DScopeTermN s d n = Scoped s (\d => Term d n) d
ScopeTermN s q d n = Scoped s (Term q d) n
DScopeTermN s q d n = Scoped s (\d => Term q d n) d
public export
ScopeTerm, DScopeTerm : TermLike
ScopeTerm = ScopeTermN 1
DScopeTerm = DScopeTermN 1
mutual
export %hint
EqTerm : Eq (Term d n)
EqTerm = assert_total {a = Eq (Term d n)} deriveEq
export %hint EqTerm : Eq (Term q d n)
export %hint EqElim : Eq (Elim q d n)
EqTerm = assert_total {a = Eq (Term q d n)} deriveEq
EqElim = assert_total {a = Eq (Elim q d n)} deriveEq
export %hint
EqElim : Eq (Elim d n)
EqElim = assert_total {a = Eq (Elim d n)} deriveEq
mutual
export %hint
ShowTerm : Show (Term d n)
ShowTerm = assert_total {a = Show (Term d n)} deriveShow
export %hint
ShowElim : Show (Elim d n)
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
-- export %hint ShowTerm : {q, d, n : Nat} -> Show (Term q d n)
-- export %hint ShowElim : {q, d, n : Nat} -> Show (Elim q d n)
-- ShowTerm = assert_total {a = Show (Term q d n)} deriveShow
-- ShowElim = assert_total {a = Show (Elim q d n)} deriveShow
export
Located (Elim d n) where
Located (Elim q d n) where
(F _ _ loc).loc = loc
(B _ loc).loc = loc
(App _ _ loc).loc = loc
@ -253,30 +251,32 @@ Located (Elim d n) where
(TypeCase _ _ _ _ loc).loc = loc
(CloE (Sub e _)).loc = e.loc
(DCloE (Sub e _)).loc = e.loc
(QCloE (SubR e _)).loc = e.loc
export
Located (Term d n) where
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ loc).loc = loc
(Lam _ loc).loc = loc
(Sig _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(Let _ _ _ loc).loc = loc
(E e).loc = e.loc
(CloT (Sub t _)).loc = t.loc
(DCloT (Sub t _)).loc = t.loc
Located (Term q d n) where
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ loc).loc = loc
(Lam _ loc).loc = loc
(Sig _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(Let _ _ _ loc).loc = loc
(E e).loc = e.loc
(CloT (Sub t _)).loc = t.loc
(DCloT (Sub t _)).loc = t.loc
(QCloT (SubR t _)).loc = t.loc
export
Located1 f => Located (ScopedBody s f n) where
@ -289,7 +289,7 @@ Located1 f => Located (Scoped s f n) where
export
Relocatable (Elim d n) where
Relocatable (Elim q d n) where
setLoc loc (F x u _) = F x u loc
setLoc loc (B i _) = B i loc
setLoc loc (App fun arg _) = App fun arg loc
@ -317,9 +317,11 @@ Relocatable (Elim d n) where
CloE $ Sub (setLoc loc term) subst
setLoc loc (DCloE (Sub term subst)) =
DCloE $ Sub (setLoc loc term) subst
setLoc loc (QCloE (SubR term subst)) =
QCloE $ SubR (setLoc loc term) subst
export
Relocatable (Term d n) where
Relocatable (Term q d n) where
setLoc loc (TYPE l _) = TYPE l loc
setLoc loc (IOState _) = IOState loc
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
@ -341,6 +343,7 @@ Relocatable (Term d n) where
setLoc loc (E e) = E $ setLoc loc e
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
setLoc loc (QCloT (SubR term subst)) = QCloT $ SubR (setLoc loc term) subst
export
Relocatable1 f => Relocatable (ScopedBody s f n) where
@ -354,93 +357,93 @@ Relocatable1 f => Relocatable (Scoped s f n) where
||| more convenient Pi
public export %inline
PiY : (qty : Qty) -> (x : BindName) ->
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
PiY : (qty : Qty q) -> (x : BindName) ->
(arg : Term q d n) -> (res : Term q d (S n)) -> (loc : Loc) -> Term q d n
PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
||| more convenient Lam
public export %inline
LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
LamY : (x : BindName) -> (body : Term q d (S n)) -> (loc : Loc) -> Term q d n
LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
public export %inline
LamN : (body : Term d n) -> (loc : Loc) -> Term d n
LamN : (body : Term q d n) -> (loc : Loc) -> Term q d n
LamN {body, loc} = Lam {body = SN body, loc}
||| non dependent function type
public export %inline
Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
Arr : (qty : Qty q) -> (arg, res : Term q d n) -> (loc : Loc) -> Term q d n
Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
||| more convenient Sig
public export %inline
SigY : (x : BindName) -> (fst : Term d n) ->
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
SigY : (x : BindName) -> (fst : Term q d n) ->
(snd : Term q d (S n)) -> (loc : Loc) -> Term q d n
SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
||| non dependent pair type
public export %inline
And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
And : (fst, snd : Term q d n) -> (loc : Loc) -> Term q d n
And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
||| more convenient Eq
public export %inline
EqY : (i : BindName) -> (ty : Term (S d) n) ->
(l, r : Term d n) -> (loc : Loc) -> Term d n
EqY : (i : BindName) -> (ty : Term q (S d) n) ->
(l, r : Term q d n) -> (loc : Loc) -> Term q d n
EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
||| more convenient DLam
public export %inline
DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
DLamY : (i : BindName) -> (body : Term q (S d) n) -> (loc : Loc) -> Term q d n
DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
public export %inline
DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
DLamN : (body : Term q d n) -> (loc : Loc) -> Term q d n
DLamN {body, loc} = DLam {body = SN body, loc}
||| non dependent equality type
public export %inline
Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
Eq0 : (ty, l, r : Term q d n) -> (loc : Loc) -> Term q d n
Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
||| same as `F` but as a term
public export %inline
FT : Name -> Universe -> Loc -> Term d n
FT : Name -> Universe -> Loc -> Term q d n
FT x u loc = E $ F x u loc
||| same as `B` but as a term
public export %inline
BT : Var n -> (loc : Loc) -> Term d n
BT : Var n -> (loc : Loc) -> Term q d n
BT i loc = E $ B i loc
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n
BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim q d n
BV i loc = B (V i) loc
||| same as `BV` but as a term
public export %inline
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term q d n
BVT i loc = E $ BV i loc
public export %inline
Zero : Loc -> Term d n
Zero : Loc -> Term q d n
Zero = Nat 0
public export %inline
enum : List TagVal -> Loc -> Term d n
enum : List TagVal -> Loc -> Term q d n
enum ts loc = Enum (SortedSet.fromList ts) loc
public export %inline
typeCase : Elim d n -> Term d n ->
List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n
typeCase : Elim q d n -> Term q d n ->
List (TypeCaseArm q d n) -> Term q d n -> Loc -> Elim q d n
typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc
public export %inline
typeCase1Y : Elim d n -> Term d n ->
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
typeCase1Y : Elim q d n -> Term q d n ->
(k : TyConKind) -> BContext (arity k) -> Term q d (arity k + n) ->
(loc : Loc) ->
{default (NAT loc) def : Term d n} ->
Elim d n
{default (NAT loc) def : Term q d n} ->
Elim q d n
typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc