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