396 lines
11 KiB
Idris
396 lines
11 KiB
Idris
module Quox.Typing.Context
|
|
|
|
import Quox.Syntax
|
|
import Quox.Context
|
|
import Quox.Pretty
|
|
import public Data.Singleton
|
|
import Derive.Prelude
|
|
|
|
%default total
|
|
%language ElabReflection
|
|
|
|
|
|
public export
|
|
QContext : Nat -> Type
|
|
QContext = Context' Qty
|
|
|
|
public export
|
|
record LocalVar d n where
|
|
constructor MkLocal
|
|
type : Term d n
|
|
term : Maybe (Term d n) -- if from a `let`
|
|
%runElab deriveIndexed "LocalVar" [Show]
|
|
|
|
export
|
|
CanShift (LocalVar d) where
|
|
l // by = {type $= (// by), term $= map (// by)} l
|
|
|
|
namespace LocalVar
|
|
export %inline
|
|
letVar : (type, term : Term d n) -> LocalVar d n
|
|
letVar type term = MkLocal {type, term = Just term}
|
|
|
|
export %inline
|
|
lamVar : (type : Term d n) -> LocalVar d n
|
|
lamVar type = MkLocal {type, term = Nothing}
|
|
|
|
subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n
|
|
subD th = {type $= (// th), term $= map (// th)}
|
|
|
|
weakD : LocalVar d n -> LocalVar (S d) n
|
|
weakD = subD $ shift 1
|
|
|
|
public export
|
|
TContext : TermLike
|
|
TContext d = Context (\n => LocalVar d n)
|
|
|
|
public export
|
|
QOutput : Nat -> Type
|
|
QOutput = Context' Qty
|
|
|
|
public export
|
|
DimAssign : Nat -> Type
|
|
DimAssign = Context' DimConst
|
|
|
|
|
|
public export
|
|
record TyContext d n where
|
|
constructor MkTyContext
|
|
{auto dimLen : Singleton d}
|
|
{auto termLen : Singleton n}
|
|
dctx : DimEq d
|
|
dnames : BContext d
|
|
tctx : TContext d n
|
|
tnames : BContext n -- only used for printing
|
|
qtys : QContext n -- only used for printing
|
|
%name TyContext ctx
|
|
%runElab deriveIndexed "TyContext" [Show]
|
|
|
|
|
|
public export
|
|
record EqContext n where
|
|
constructor MkEqContext
|
|
{dimLen : Nat}
|
|
{auto termLen : Singleton n}
|
|
dassign : DimAssign dimLen -- only used for printing
|
|
dnames : BContext dimLen -- only used for printing
|
|
tctx : TContext 0 n
|
|
tnames : BContext n -- only used for printing
|
|
qtys : QContext n -- only used for printing
|
|
%name EqContext ctx
|
|
%runElab deriveIndexed "EqContext" [Show]
|
|
|
|
|
|
public export
|
|
record WhnfContext d n where
|
|
constructor MkWhnfContext
|
|
{auto dimLen : Singleton d}
|
|
{auto termLen : Singleton n}
|
|
dnames : BContext d
|
|
tnames : BContext n
|
|
tctx : TContext d n
|
|
%name WhnfContext ctx
|
|
%runElab deriveIndexed "WhnfContext" [Show]
|
|
|
|
namespace TContext
|
|
export %inline
|
|
zeroFor : Context tm n -> QOutput n
|
|
zeroFor ctx = Zero <$ ctx
|
|
|
|
public export
|
|
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
|
|
extendLen [<] x = x
|
|
extendLen (tel :< _) x = [|S $ extendLen tel x|]
|
|
|
|
|
|
public export
|
|
CtxExtension : Nat -> Nat -> Nat -> Type
|
|
CtxExtension d = Telescope ((Qty, BindName,) . Term d)
|
|
|
|
public export
|
|
CtxExtension0 : Nat -> Nat -> Nat -> Type
|
|
CtxExtension0 d = Telescope ((BindName,) . Term d)
|
|
|
|
public export
|
|
CtxExtensionLet : Nat -> Nat -> Nat -> Type
|
|
CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d)
|
|
|
|
public export
|
|
CtxExtensionLet0 : Nat -> Nat -> Nat -> Type
|
|
CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d)
|
|
|
|
namespace TyContext
|
|
public export %inline
|
|
empty : TyContext 0 0
|
|
empty =
|
|
MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
|
|
|
|
public export %inline
|
|
null : TyContext d n -> Bool
|
|
null ctx = null ctx.dnames && null ctx.tnames
|
|
|
|
export %inline
|
|
extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
|
|
extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
|
|
let (qs, xs, ls) = unzip3 xss in
|
|
MkTyContext {
|
|
dctx, dnames,
|
|
termLen = extendLen xss termLen,
|
|
tctx = tctx . ls,
|
|
tnames = tnames . xs,
|
|
qtys = qtys . qs
|
|
}
|
|
|
|
export %inline
|
|
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
|
|
extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
|
|
|
|
export %inline
|
|
extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2
|
|
extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
|
|
|
|
export %inline
|
|
extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2
|
|
extendTyN0 xss = extendTyN (map (Zero,) xss)
|
|
|
|
export %inline
|
|
extendTyLet : Qty -> BindName -> Term d n -> Term d n ->
|
|
TyContext d n -> TyContext d (S n)
|
|
extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
|
|
|
|
export %inline
|
|
extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
|
|
extendTy q x s = extendTyN [< (q, x, s)]
|
|
|
|
export %inline
|
|
extendTy0 : BindName -> Term d n -> TyContext d n -> TyContext d (S n)
|
|
extendTy0 = extendTy Zero
|
|
|
|
export %inline
|
|
extendDim : BindName -> 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 = map weakD tctx,
|
|
tnames, qtys
|
|
}
|
|
|
|
export %inline
|
|
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
|
|
eqDim p q = {dctx $= set p q, dimLen $= id, termLen $= id}
|
|
|
|
export
|
|
toWhnfContext : TyContext d n -> WhnfContext d n
|
|
toWhnfContext (MkTyContext {dnames, tnames, tctx, _}) =
|
|
MkWhnfContext {dnames, tnames, tctx}
|
|
|
|
|
|
namespace QOutput
|
|
export %inline
|
|
(+) : QOutput n -> QOutput n -> QOutput n
|
|
(+) = zipWith (+)
|
|
|
|
export %inline
|
|
(*) : Qty -> QOutput n -> QOutput n
|
|
(*) pi = map (pi *)
|
|
|
|
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
|
|
makeEqContext' : {d : Nat} -> TyContext d n -> DSubst d 0 -> EqContext n
|
|
makeEqContext' ctx th = MkEqContext {
|
|
termLen = ctx.termLen,
|
|
dassign = makeDAssign th,
|
|
dnames = ctx.dnames,
|
|
tctx = map (subD th) ctx.tctx,
|
|
tnames = ctx.tnames,
|
|
qtys = ctx.qtys
|
|
}
|
|
|
|
export
|
|
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
|
|
makeEqContext ctx@(MkTyContext {dnames, _}) th =
|
|
let Val d = lengthPrf0 dnames in makeEqContext' ctx th
|
|
|
|
namespace EqContext
|
|
public export %inline
|
|
empty : EqContext 0
|
|
empty = MkEqContext {
|
|
dassign = [<], dnames = [<], tctx = [<], tnames = [<], qtys = [<]
|
|
}
|
|
|
|
public export %inline
|
|
null : EqContext n -> Bool
|
|
null ctx = null ctx.dnames && null ctx.tnames
|
|
|
|
export %inline
|
|
extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
|
|
extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
|
|
let (qs, xs, ls) = unzip3 xss in
|
|
MkEqContext {
|
|
termLen = extendLen xss termLen,
|
|
tctx = tctx . ls,
|
|
tnames = tnames . xs,
|
|
qtys = qtys . qs,
|
|
dassign, dnames
|
|
}
|
|
|
|
export %inline
|
|
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
|
|
extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
|
|
|
|
export %inline
|
|
extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2
|
|
extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
|
|
|
|
export %inline
|
|
extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2
|
|
extendTyN0 xss = extendTyN (map (Zero,) xss)
|
|
|
|
export %inline
|
|
extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n ->
|
|
EqContext n -> EqContext (S n)
|
|
extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
|
|
|
|
export %inline
|
|
extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
|
|
extendTy q x s = extendTyN [< (q, x, s)]
|
|
|
|
export %inline
|
|
extendTy0 : BindName -> Term 0 n -> EqContext n -> EqContext (S n)
|
|
extendTy0 = extendTy Zero
|
|
|
|
export %inline
|
|
extendDim : BindName -> 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
|
|
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
|
|
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
|
|
MkTyContext {
|
|
dctx = fromGround dnames dassign,
|
|
tctx = map (subD $ shift0 dimLen) tctx,
|
|
dnames, tnames, qtys
|
|
}
|
|
|
|
export
|
|
toWhnfContext : (ectx : EqContext n) -> WhnfContext 0 n
|
|
toWhnfContext (MkEqContext {tnames, tctx, _}) =
|
|
MkWhnfContext {dnames = [<], tnames, tctx}
|
|
|
|
export
|
|
injElim : WhnfContext d n -> Elim 0 0 -> Elim d n
|
|
injElim ctx e =
|
|
let Val d = ctx.dimLen; Val n = ctx.termLen in
|
|
e // shift0 d // shift0 n
|
|
|
|
namespace WhnfContext
|
|
public export %inline
|
|
empty : WhnfContext 0 0
|
|
empty = MkWhnfContext [<] [<] [<]
|
|
|
|
export
|
|
extendTy' : BindName -> LocalVar d n -> WhnfContext d n -> WhnfContext d (S n)
|
|
extendTy' x var (MkWhnfContext {termLen, dnames, tnames, tctx}) =
|
|
MkWhnfContext {
|
|
dnames,
|
|
termLen = [|S termLen|],
|
|
tnames = tnames :< x,
|
|
tctx = tctx :< var
|
|
}
|
|
|
|
export %inline
|
|
extendTy : BindName -> Term d n -> WhnfContext d n -> WhnfContext d (S n)
|
|
extendTy x ty ctx = extendTy' x (lamVar ty) ctx
|
|
|
|
export %inline
|
|
extendTyLet : BindName -> (type, term : Term d n) ->
|
|
WhnfContext d n -> WhnfContext d (S n)
|
|
extendTyLet x type term ctx = extendTy' x (letVar {type, term}) ctx
|
|
|
|
export
|
|
extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
|
|
WhnfContext (s + d) n
|
|
extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
|
|
MkWhnfContext {
|
|
dimLen = [|Val s + dimLen|],
|
|
dnames = dnames ++ toSnocVect' ns,
|
|
tctx = map (subD $ shift s) tctx,
|
|
tnames
|
|
}
|
|
|
|
export
|
|
extendDim : BindName -> WhnfContext d n -> WhnfContext (S d) n
|
|
extendDim i = extendDimN [< i]
|
|
|
|
|
|
private
|
|
prettyTContextElt : {opts : _} ->
|
|
BContext d -> BContext n ->
|
|
Doc opts -> BindName -> LocalVar d n ->
|
|
Eff Pretty (Doc opts)
|
|
prettyTContextElt dnames tnames q x s = do
|
|
dot <- dotD
|
|
x <- prettyTBind x; colon <- colonD
|
|
ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD
|
|
tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term
|
|
d <- askAt INDENT
|
|
let qx = hcat [q, dot, x]
|
|
pure $ case tm of
|
|
Nothing =>
|
|
ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty])
|
|
Just tm =>
|
|
ifMultiline (hsep [qx, colon, ty, eq, tm])
|
|
(vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm])
|
|
|
|
private
|
|
prettyTContext' : {opts : _} ->
|
|
BContext d -> Context' (Doc opts) n -> BContext n ->
|
|
TContext d n -> Eff Pretty (SnocList (Doc opts))
|
|
prettyTContext' _ [<] [<] [<] = pure [<]
|
|
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
|
|
[|prettyTContext' dnames qtys tnames tys :<
|
|
prettyTContextElt dnames tnames q x t|]
|
|
|
|
export
|
|
prettyTContext : {opts : _} ->
|
|
BContext d -> QContext n -> BContext n ->
|
|
TContext d n -> Eff Pretty (Doc opts)
|
|
prettyTContext dnames qtys tnames tys = do
|
|
comma <- commaD
|
|
qtys <- traverse prettyQty qtys
|
|
sepSingle . exceptLast (<+> comma) . toList <$>
|
|
prettyTContext' dnames qtys tnames tys
|
|
|
|
export
|
|
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
|
|
prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
|
|
case dctx of
|
|
C [<] => prettyTContext dnames qtys tnames tctx
|
|
_ => pure $
|
|
sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD,
|
|
!(prettyTContext dnames qtys tnames tctx)]
|
|
|
|
export
|
|
prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
|
|
prettyEqContext ctx = prettyTyContext $ toTyContext ctx
|
|
|
|
export
|
|
prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts)
|
|
prettyWhnfContext ctx =
|
|
let Val n = ctx.termLen in
|
|
separateTight !commaD <$>
|
|
prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx
|