quox/lib/Quox/Typing/Context.idr

248 lines
6.7 KiB
Idris
Raw Normal View History

2023-03-13 16:41:57 -04:00
module Quox.Typing.Context
import Quox.Syntax
import Quox.Context
2023-03-15 10:54:51 -04:00
import Quox.Pretty
import public Data.Singleton
2023-03-13 16:41:57 -04:00
%default total
2023-03-13 16:41:57 -04:00
2023-03-15 10:54:51 -04:00
public export
2023-04-01 13:16:43 -04:00
QContext : Nat -> Type
QContext = Context' Qty
2023-03-15 10:54:51 -04:00
2023-03-13 16:41:57 -04:00
public export
2023-04-01 13:16:43 -04:00
TContext : TermLike
TContext d = Context (Term d)
2023-03-13 16:41:57 -04:00
public export
2023-04-01 13:16:43 -04:00
QOutput : Nat -> Type
QOutput = Context' Qty
2023-03-13 16:41:57 -04:00
public export
DimAssign : Nat -> Type
DimAssign = Context' DimConst
2023-03-13 16:41:57 -04:00
public export
2023-04-01 13:16:43 -04:00
record TyContext d n where
2023-03-13 16:41:57 -04:00
constructor MkTyContext
{auto dimLen : Singleton d}
{auto termLen : Singleton n}
dctx : DimEq d
dnames : NContext d
2023-04-01 13:16:43 -04:00
tctx : TContext d n
tnames : NContext n
2023-04-01 13:16:43 -04:00
qtys : QContext n -- only used for printing
2023-03-13 16:41:57 -04:00
%name TyContext ctx
public export
2023-04-01 13:16:43 -04:00
record EqContext n where
constructor MkEqContext
2023-03-15 10:54:51 -04:00
{dimLen : Nat}
{auto termLen : Singleton n}
2023-03-15 10:54:51 -04:00
dassign : DimAssign dimLen -- only used for printing
dnames : NContext dimLen -- only used for printing
2023-04-01 13:16:43 -04:00
tctx : TContext 0 n
tnames : NContext n
2023-04-01 13:16:43 -04:00
qtys : QContext n -- only used for printing
%name EqContext ctx
namespace TContext
export %inline
2023-04-01 13:16:43 -04:00
pushD : TContext d n -> TContext (S d) n
pushD tel = map (// shift 1) tel
export %inline
2023-04-01 13:16:43 -04:00
zeroFor : Context tm n -> QOutput n
zeroFor ctx = Zero <$ ctx
private
extendLen : Telescope a from to -> Singleton from -> Singleton to
extendLen [<] x = x
extendLen (tel :< _) x = [|S $ extendLen tel x|]
namespace TyContext
public export %inline
2023-04-01 13:16:43 -04:00
empty : TyContext 0 0
2023-03-15 10:54:51 -04:00
empty =
MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
2023-03-26 10:10:39 -04:00
public export %inline
2023-04-01 13:16:43 -04:00
null : TyContext d n -> Bool
2023-03-26 10:10:39 -04:00
null ctx = null ctx.dnames && null ctx.tnames
export %inline
2023-04-01 13:16:43 -04:00
extendTyN : Telescope (\n => (Qty, BaseName, Term d n)) from to ->
TyContext d from -> TyContext d to
extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
2023-03-15 10:54:51 -04:00
let (qs, xs, ss) = unzip3 xss in
MkTyContext {
dctx, dnames,
termLen = extendLen xss termLen,
tctx = tctx . ss,
tnames = tnames . xs,
qtys = qtys . qs
}
export %inline
2023-04-01 13:16:43 -04:00
extendTy : Qty -> BaseName -> Term d n -> TyContext d n ->
TyContext d (S n)
2023-03-15 10:54:51 -04:00
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
2023-04-01 13:16:43 -04:00
extendDim : BaseName -> TyContext d n -> TyContext (S d) n
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
MkTyContext {
dctx = dctx :<? Nothing,
dnames = dnames :< x,
dimLen = [|S dimLen|],
tctx = pushD tctx,
tnames, qtys
}
export %inline
2023-04-01 13:16:43 -04:00
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
eqDim p q = {dctx $= set p q, dimLen $= id, termLen $= id}
export
2023-04-01 13:16:43 -04:00
injectT : TyContext d n -> Term 0 0 -> Term d n
injectT (MkTyContext {dimLen = Val d, termLen = Val n, _}) tm =
tm // shift0 d // shift0 n
export
2023-04-01 13:16:43 -04:00
injectE : TyContext d n -> Elim 0 0 -> Elim d n
injectE (MkTyContext {dimLen = Val d, termLen = Val n, _}) el =
el // shift0 d // shift0 n
namespace QOutput
2023-04-01 13:16:43 -04:00
export %inline
(+) : QOutput n -> QOutput n -> QOutput n
(+) = zipWith (+)
2023-04-01 13:16:43 -04:00
export %inline
(*) : Qty -> QOutput n -> QOutput n
(*) pi = map (pi *)
2023-04-01 13:16:43 -04:00
export %inline
zeroFor : TyContext _ n -> QOutput n
zeroFor ctx = zeroFor ctx.tctx
export
makeDAssign : DSubst d 0 -> DimAssign d
makeDAssign (Shift SZ) = [<]
makeDAssign (K e ::: th) = makeDAssign th :< e
export
2023-04-01 13:16:43 -04:00
makeEqContext' : {d : Nat} -> TyContext d n -> DSubst d 0 -> EqContext n
2023-03-15 10:54:51 -04:00
makeEqContext' ctx th = MkEqContext {
termLen = ctx.termLen,
dassign = makeDAssign th,
dnames = ctx.dnames,
tctx = map (// th) ctx.tctx,
2023-03-15 10:54:51 -04:00
tnames = ctx.tnames,
qtys = ctx.qtys
}
2023-03-15 10:54:51 -04:00
export
2023-04-01 13:16:43 -04:00
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
2023-03-15 10:54:51 -04:00
makeEqContext ctx@(MkTyContext {dnames, _}) th =
let (d' ** Refl) = lengthPrf0 dnames in makeEqContext' ctx th
namespace EqContext
public export %inline
2023-04-01 13:16:43 -04:00
empty : EqContext 0
2023-03-15 10:54:51 -04:00
empty = MkEqContext {
dassign = [<], dnames = [<], tctx = [<], tnames = [<], qtys = [<]
}
2023-03-26 10:10:39 -04:00
public export %inline
2023-04-01 13:16:43 -04:00
null : EqContext n -> Bool
2023-03-26 10:10:39 -04:00
null ctx = null ctx.dnames && null ctx.tnames
export %inline
2023-04-01 13:16:43 -04:00
extendTyN : Telescope (\n => (Qty, BaseName, Term 0 n)) from to ->
EqContext from -> EqContext to
extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
let (qs, xs, ss) = unzip3 xss in
MkEqContext {
termLen = extendLen xss termLen,
tctx = tctx . ss,
tnames = tnames . xs,
qtys = qtys . qs,
dassign, dnames
}
export %inline
2023-04-01 13:16:43 -04:00
extendTy : Qty -> BaseName -> Term 0 n -> EqContext n -> EqContext (S n)
2023-03-15 10:54:51 -04:00
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
2023-04-01 13:16:43 -04:00
extendDim : BaseName -> DimConst -> EqContext n -> EqContext n
extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
MkEqContext {dassign = dassign :< e, dnames = dnames :< x,
tctx, tnames, qtys}
export
2023-04-01 13:16:43 -04:00
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
2023-03-15 10:54:51 -04:00
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
MkTyContext {
dctx = fromGround dassign,
tctx = map (// shift0 dimLen) tctx,
dnames, tnames, qtys
}
export
2023-04-01 13:16:43 -04:00
injectT : EqContext n -> Term 0 0 -> Term 0 n
injectT (MkEqContext {termLen = Val n, _}) tm = tm // shift0 n
export
2023-04-01 13:16:43 -04:00
injectE : EqContext n -> Elim 0 0 -> Elim 0 n
injectE (MkEqContext {termLen = Val n, _}) el = el // shift0 n
2023-03-15 10:54:51 -04:00
private
data CtxBinder a = MkCtxBinder BaseName a
PrettyHL a => PrettyHL (CtxBinder a) where
prettyM (MkCtxBinder x t) = pure $
sep [hsep [!(pretty0M $ TV x), colonD], !(pretty0M t)]
2023-04-01 13:16:43 -04:00
parameters (unicode : Bool)
2023-03-25 15:54:31 -04:00
private
pipeD : Doc HL
pipeD = hl Syntax "|"
2023-03-15 10:54:51 -04:00
export covering
prettyTContext : NContext d ->
2023-04-01 13:16:43 -04:00
QContext n -> NContext n ->
TContext d n -> Doc HL
prettyTContext ds qs xs ctx = separate comma $ toList $ go qs xs ctx where
2023-04-01 13:16:43 -04:00
go : QContext m -> NContext m -> TContext d m -> SnocList (Doc HL)
2023-03-15 10:54:51 -04:00
go [<] [<] [<] = [<]
go (qs :< q) (xs :< x) (ctx :< t) =
let bind = MkWithQty q $ MkCtxBinder x t in
go qs xs ctx :<
runPrettyWith unicode (toSnocList' ds) (toSnocList' xs) (pretty0M bind)
2023-03-15 10:54:51 -04:00
export covering
2023-04-01 13:16:43 -04:00
prettyTyContext : TyContext d n -> Doc HL
2023-03-15 10:54:51 -04:00
prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
case dctx of
C [<] => prettyTContext dnames qtys tnames tctx
_ => sep [prettyDimEq dnames dctx <++> pipeD,
prettyTContext dnames qtys tnames tctx]
2023-03-15 10:54:51 -04:00
export covering
2023-04-01 13:16:43 -04:00
prettyEqContext : EqContext n -> Doc HL
2023-03-15 10:54:51 -04:00
prettyEqContext (MkEqContext dassign dnames tctx tnames qtys) =
case dassign of
[<] => prettyTContext [<] qtys tnames tctx
_ => sep [prettyDimEq dnames (fromGround dassign) <++> pipeD,
prettyTContext [<] qtys tnames tctx]