add local bindings to context
- without this, inside the body of `let x = e in …`, the typechecker would forget that `x = e` - now bound variables can reduce, if they have a definition, so RedexTest needs to take the context too
This commit is contained in:
parent
cdf1ec6deb
commit
03c197bd04
13 changed files with 300 additions and 211 deletions
|
|
@ -14,9 +14,27 @@ 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
|
||||
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 (Term d)
|
||||
TContext d = Context (\n => LocalVar d n)
|
||||
|
||||
public export
|
||||
QOutput : Nat -> Type
|
||||
|
|
@ -67,10 +85,6 @@ record WhnfContext d n where
|
|||
%runElab deriveIndexed "WhnfContext" [Show]
|
||||
|
||||
namespace TContext
|
||||
export %inline
|
||||
pushD : TContext d n -> TContext (S d) n
|
||||
pushD tel = map (// shift 1) tel
|
||||
|
||||
export %inline
|
||||
zeroFor : Context tm n -> QOutput n
|
||||
zeroFor ctx = Zero <$ ctx
|
||||
|
|
@ -89,6 +103,14 @@ 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
|
||||
|
|
@ -100,21 +122,34 @@ namespace TyContext
|
|||
null ctx = null ctx.dnames && null ctx.tnames
|
||||
|
||||
export %inline
|
||||
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
|
||||
extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||
let (qs, xs, ss) = unzip3 xss in
|
||||
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 . ss,
|
||||
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, MkLocal s Nothing))
|
||||
|
||||
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, MkLocal s (Just e))]
|
||||
|
||||
export %inline
|
||||
extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
|
||||
extendTy q x s = extendTyN [< (q, x, s)]
|
||||
|
|
@ -130,7 +165,7 @@ namespace TyContext
|
|||
dctx = dctx :<? Nothing,
|
||||
dnames = dnames :< x,
|
||||
dimLen = [|S dimLen|],
|
||||
tctx = pushD tctx,
|
||||
tctx = map weakD tctx,
|
||||
tnames, qtys
|
||||
}
|
||||
|
||||
|
|
@ -169,7 +204,7 @@ makeEqContext' ctx th = MkEqContext {
|
|||
termLen = ctx.termLen,
|
||||
dassign = makeDAssign th,
|
||||
dnames = ctx.dnames,
|
||||
tctx = map (// th) ctx.tctx,
|
||||
tctx = map (subD th) ctx.tctx,
|
||||
tnames = ctx.tnames,
|
||||
qtys = ctx.qtys
|
||||
}
|
||||
|
|
@ -191,21 +226,34 @@ namespace EqContext
|
|||
null ctx = null ctx.dnames && null ctx.tnames
|
||||
|
||||
export %inline
|
||||
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
|
||||
extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||
let (qs, xs, ss) = unzip3 xss in
|
||||
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 . ss,
|
||||
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, MkLocal s Nothing))
|
||||
|
||||
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, MkLocal s (Just e))]
|
||||
|
||||
export %inline
|
||||
extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
|
||||
extendTy q x s = extendTyN [< (q, x, s)]
|
||||
|
|
@ -225,7 +273,7 @@ namespace EqContext
|
|||
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||
MkTyContext {
|
||||
dctx = fromGround dassign,
|
||||
tctx = map (// shift0 dimLen) tctx,
|
||||
tctx = map (subD $ shift0 dimLen) tctx,
|
||||
dnames, tnames, qtys
|
||||
}
|
||||
|
||||
|
|
@ -252,7 +300,7 @@ namespace WhnfContext
|
|||
MkWhnfContext {
|
||||
dimLen = [|Val s + dimLen|],
|
||||
dnames = dnames ++ toSnocVect' ns,
|
||||
tctx = dweakT s <$> tctx,
|
||||
tctx = map (subD $ shift s) tctx,
|
||||
tnames
|
||||
}
|
||||
|
||||
|
|
@ -264,10 +312,20 @@ namespace WhnfContext
|
|||
private
|
||||
prettyTContextElt : {opts : _} ->
|
||||
BContext d -> BContext n ->
|
||||
Qty -> BindName -> Term d n -> Eff Pretty (Doc opts)
|
||||
prettyTContextElt dnames tnames q x s =
|
||||
pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD,
|
||||
!(withPrec Outer $ prettyTerm dnames tnames s)]
|
||||
Qty -> BindName -> LocalVar d n -> Eff Pretty (Doc opts)
|
||||
prettyTContextElt dnames tnames q x s = do
|
||||
q <- prettyQty q; 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 : _} ->
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue