quox/lib/Quox/Typing/Context.idr

201 lines
5.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
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
QContext : Type -> Nat -> Type
QContext = Context'
2023-03-13 16:41:57 -04:00
public export
TContext : Type -> Nat -> Nat -> Type
TContext q d = Context (Term q d)
public export
QOutput : Type -> Nat -> Type
QOutput = Context'
public export
DimAssign : Nat -> Type
DimAssign = Context' DimConst
2023-03-13 16:41:57 -04:00
public export
record TyContext q d n where
constructor MkTyContext
dctx : DimEq d
dnames : NContext d
tctx : TContext q d n
tnames : NContext n
2023-03-15 10:54:51 -04:00
qtys : QContext q n -- only used for printing
2023-03-13 16:41:57 -04:00
%name TyContext ctx
public export
record EqContext q n where
constructor MkEqContext
2023-03-15 10:54:51 -04:00
{dimLen : Nat}
dassign : DimAssign dimLen -- only used for printing
dnames : NContext dimLen -- only used for printing
tctx : TContext q 0 n
tnames : NContext n
2023-03-15 10:54:51 -04:00
qtys : QContext q n -- only used for printing
%name EqContext ctx
namespace TContext
export %inline
pushD : TContext q d n -> TContext q (S d) n
pushD tel = map (// shift 1) tel
export %inline
zeroFor : IsQty q => Context tm n -> QOutput q n
zeroFor ctx = zero <$ ctx
namespace TyContext
public export %inline
empty : TyContext q 0 0
2023-03-15 10:54:51 -04:00
empty =
MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
export %inline
2023-03-15 10:54:51 -04:00
extendTyN : Telescope (\n => (q, BaseName, Term q d n)) from to ->
TyContext q d from -> TyContext q d to
extendTyN xss ctx =
2023-03-15 10:54:51 -04:00
let (qs, xs, ss) = unzip3 xss in
{qtys $= (. qs), tctx $= (. ss), tnames $= (. xs)} ctx
export %inline
2023-03-15 10:54:51 -04:00
extendTy : q -> BaseName -> Term q d n -> TyContext q d n ->
TyContext q d (S n)
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
extendDim : BaseName -> TyContext q d n -> TyContext q (S d) n
extendDim x = {dctx $= (:<? Nothing), dnames $= (:< x), tctx $= pushD}
export %inline
eqDim : Dim d -> Dim d -> TyContext q d n -> TyContext q d n
eqDim p q = {dctx $= set p q}
namespace QOutput
parameters {auto _ : IsQty q}
export %inline
(+) : QOutput q n -> QOutput q n -> QOutput q n
(+) = zipWith (+)
export %inline
(*) : q -> QOutput q n -> QOutput q n
(*) pi = map (pi *)
export %inline
zeroFor : TyContext q _ n -> QOutput q 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-03-15 10:54:51 -04:00
makeEqContext' : {d : Nat} -> TyContext q d n -> DSubst d 0 -> EqContext q n
makeEqContext' ctx th = MkEqContext {
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
makeEqContext : TyContext q d n -> DSubst d 0 -> EqContext q n
makeEqContext ctx@(MkTyContext {dnames, _}) th =
let (d' ** Refl) = lengthPrf0 dnames in makeEqContext' ctx th
namespace EqContext
public export %inline
empty : EqContext q 0
2023-03-15 10:54:51 -04:00
empty = MkEqContext {
dassign = [<], dnames = [<], tctx = [<], tnames = [<], qtys = [<]
}
export %inline
2023-03-15 10:54:51 -04:00
extendTyN : Telescope (\n => (q, BaseName, Term q 0 n)) from to ->
EqContext q from -> EqContext q to
extendTyN tel ctx =
2023-03-15 10:54:51 -04:00
let (qs, xs, ss) = unzip3 tel in
{qtys $= (. qs), tctx $= (. ss), tnames $= (. xs)} ctx
export %inline
2023-03-15 10:54:51 -04:00
extendTy : q -> BaseName -> Term q 0 n -> EqContext q n -> EqContext q (S n)
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
extendDim : BaseName -> DimConst -> EqContext q n -> EqContext q n
extendDim x e ctx = {dassign $= (:< e), dnames $= (:< x)} ctx
export
2023-03-15 10:54:51 -04:00
toTyContext : (e : EqContext q n) -> TyContext q e.dimLen n
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
MkTyContext {
dctx = fromGround dassign,
tctx = map (// shift0 dimLen) tctx,
dnames, tnames, qtys
}
parameters {auto _ : (Eq q, PrettyHL q, IsQty q)} (unicode : Bool)
2023-03-15 10:54:51 -04:00
export covering
prettyTContext : QContext q n -> NContext n -> TContext q d n -> Doc HL
prettyTContext qs ns ctx = separate comma $ toList $ go qs ns ctx where
go : QContext q m -> NContext m -> TContext q d m -> SnocList (Doc HL)
go [<] [<] [<] = [<]
go (qs :< q) (xs :< x) (ctx :< t) =
let bind = MkWithQty q $ MkBinder x t in
go qs xs ctx :< runPretty unicode (pretty0M bind)
2023-03-15 10:54:51 -04:00
private
prettyDVars : NContext d -> Doc HL
prettyDVars ds = hseparate comma $ map (pretty0 unicode . DV) $ toList' ds
export
prettyDimEq1 : (PrettyHL a, PrettyHL b) => NContext d -> a -> b -> Doc HL
prettyDimEq1 ds p q = runPretty unicode $
local {dnames := toSnocList' ds} $ do
p <- pretty0M p; q <- pretty0M q
pure $ hsep [p, hl Syntax "=", q]
export
prettyDimEqCons : NContext d -> DimEq' d -> Doc HL
prettyDimEqCons ds eqs = hseparate comma $ toList $ go ds eqs
where
go : NContext e -> Context (Maybe . Dim) e -> SnocList (Doc HL)
go [<] [<] = [<]
go (ds :< _) (eqs :< Nothing) = go ds eqs
go (ds :< x) (eqs :< Just d) = go ds eqs :< prettyDimEq1 ds (DV x) d
export
prettyDimEq : NContext d -> DimEq d -> Doc HL
prettyDimEq ds ZeroIsOne =
prettyDVars ds <+> comma <++> prettyDimEq1 [<] Zero One
prettyDimEq ds (C eqs) =
prettyDVars ds <+> comma <%%> prettyDimEqCons ds eqs
export covering
prettyTyContext : TyContext q d n -> Doc HL
prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
sep [prettyDimEq dnames dctx <++> hl Syntax "|",
prettyTContext qtys tnames tctx]
export covering
prettyEqContext : EqContext q n -> Doc HL
prettyEqContext (MkEqContext dassign dnames tctx tnames qtys) =
sep [prettyDimEqCons dnames (fromGround' dassign) <++> hl Syntax "|",
prettyTContext qtys tnames tctx]