remove IsQty interface
This commit is contained in:
parent
5fdba77d04
commit
ba2818a865
24 changed files with 729 additions and 889 deletions
|
|
@ -9,16 +9,16 @@ import public Data.Singleton
|
|||
|
||||
|
||||
public export
|
||||
QContext : Type -> Nat -> Type
|
||||
QContext = Context'
|
||||
QContext : Nat -> Type
|
||||
QContext = Context' Qty
|
||||
|
||||
public export
|
||||
TContext : Type -> Nat -> Nat -> Type
|
||||
TContext q d = Context (Term q d)
|
||||
TContext : TermLike
|
||||
TContext d = Context (Term d)
|
||||
|
||||
public export
|
||||
QOutput : Type -> Nat -> Type
|
||||
QOutput = Context'
|
||||
QOutput : Nat -> Type
|
||||
QOutput = Context' Qty
|
||||
|
||||
public export
|
||||
DimAssign : Nat -> Type
|
||||
|
|
@ -26,39 +26,39 @@ DimAssign = Context' DimConst
|
|||
|
||||
|
||||
public export
|
||||
record TyContext q d n where
|
||||
record TyContext d n where
|
||||
constructor MkTyContext
|
||||
{auto dimLen : Singleton d}
|
||||
{auto termLen : Singleton n}
|
||||
dctx : DimEq d
|
||||
dnames : NContext d
|
||||
tctx : TContext q d n
|
||||
tctx : TContext d n
|
||||
tnames : NContext n
|
||||
qtys : QContext q n -- only used for printing
|
||||
qtys : QContext n -- only used for printing
|
||||
%name TyContext ctx
|
||||
|
||||
|
||||
public export
|
||||
record EqContext q n where
|
||||
record EqContext n where
|
||||
constructor MkEqContext
|
||||
{dimLen : Nat}
|
||||
{auto termLen : Singleton n}
|
||||
dassign : DimAssign dimLen -- only used for printing
|
||||
dnames : NContext dimLen -- only used for printing
|
||||
tctx : TContext q 0 n
|
||||
tctx : TContext 0 n
|
||||
tnames : NContext n
|
||||
qtys : QContext q n -- only used for printing
|
||||
qtys : QContext n -- only used for printing
|
||||
%name EqContext ctx
|
||||
|
||||
|
||||
namespace TContext
|
||||
export %inline
|
||||
pushD : TContext q d n -> TContext q (S d) n
|
||||
pushD : TContext d n -> TContext (S d) n
|
||||
pushD tel = map (// shift 1) tel
|
||||
|
||||
export %inline
|
||||
zeroFor : IsQty q => Context tm n -> QOutput q n
|
||||
zeroFor ctx = zero <$ ctx
|
||||
zeroFor : Context tm n -> QOutput n
|
||||
zeroFor ctx = Zero <$ ctx
|
||||
|
||||
private
|
||||
extendLen : Telescope a from to -> Singleton from -> Singleton to
|
||||
|
|
@ -67,17 +67,17 @@ extendLen (tel :< _) x = [|S $ extendLen tel x|]
|
|||
|
||||
namespace TyContext
|
||||
public export %inline
|
||||
empty : TyContext q 0 0
|
||||
empty : TyContext 0 0
|
||||
empty =
|
||||
MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
|
||||
|
||||
public export %inline
|
||||
null : TyContext q d n -> Bool
|
||||
null : TyContext d n -> Bool
|
||||
null ctx = null ctx.dnames && null ctx.tnames
|
||||
|
||||
export %inline
|
||||
extendTyN : Telescope (\n => (q, BaseName, Term q d n)) from to ->
|
||||
TyContext q d from -> TyContext q d to
|
||||
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}) =
|
||||
let (qs, xs, ss) = unzip3 xss in
|
||||
MkTyContext {
|
||||
|
|
@ -89,12 +89,12 @@ namespace TyContext
|
|||
}
|
||||
|
||||
export %inline
|
||||
extendTy : q -> BaseName -> Term q d n -> TyContext q d n ->
|
||||
TyContext q d (S n)
|
||||
extendTy : Qty -> BaseName -> Term d n -> TyContext d n ->
|
||||
TyContext 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 : BaseName -> TyContext d n -> TyContext (S d) n
|
||||
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||
MkTyContext {
|
||||
dctx = dctx :<? Nothing,
|
||||
|
|
@ -105,33 +105,32 @@ namespace TyContext
|
|||
}
|
||||
|
||||
export %inline
|
||||
eqDim : Dim d -> Dim d -> TyContext q d n -> TyContext q d n
|
||||
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
|
||||
eqDim p q = {dctx $= set p q, dimLen $= id, termLen $= id}
|
||||
|
||||
export
|
||||
injectT : TyContext q d n -> Term q 0 0 -> Term q d n
|
||||
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
|
||||
injectE : TyContext q d n -> Elim q 0 0 -> Elim q d n
|
||||
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
|
||||
parameters {auto _ : IsQty q}
|
||||
export %inline
|
||||
(+) : QOutput q n -> QOutput q n -> QOutput q n
|
||||
(+) = zipWith (+)
|
||||
export %inline
|
||||
(+) : QOutput n -> QOutput n -> QOutput n
|
||||
(+) = zipWith (+)
|
||||
|
||||
export %inline
|
||||
(*) : q -> QOutput q n -> QOutput q n
|
||||
(*) pi = map (pi *)
|
||||
export %inline
|
||||
(*) : Qty -> QOutput n -> QOutput n
|
||||
(*) pi = map (pi *)
|
||||
|
||||
export %inline
|
||||
zeroFor : TyContext q _ n -> QOutput q n
|
||||
zeroFor ctx = zeroFor ctx.tctx
|
||||
export %inline
|
||||
zeroFor : TyContext _ n -> QOutput n
|
||||
zeroFor ctx = zeroFor ctx.tctx
|
||||
|
||||
|
||||
export
|
||||
|
|
@ -140,7 +139,7 @@ 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' : {d : Nat} -> TyContext d n -> DSubst d 0 -> EqContext n
|
||||
makeEqContext' ctx th = MkEqContext {
|
||||
termLen = ctx.termLen,
|
||||
dassign = makeDAssign th,
|
||||
|
|
@ -151,24 +150,24 @@ makeEqContext' ctx th = MkEqContext {
|
|||
}
|
||||
|
||||
export
|
||||
makeEqContext : TyContext q d n -> DSubst d 0 -> EqContext q n
|
||||
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
|
||||
makeEqContext ctx@(MkTyContext {dnames, _}) th =
|
||||
let (d' ** Refl) = lengthPrf0 dnames in makeEqContext' ctx th
|
||||
|
||||
namespace EqContext
|
||||
public export %inline
|
||||
empty : EqContext q 0
|
||||
empty : EqContext 0
|
||||
empty = MkEqContext {
|
||||
dassign = [<], dnames = [<], tctx = [<], tnames = [<], qtys = [<]
|
||||
}
|
||||
|
||||
public export %inline
|
||||
null : EqContext q n -> Bool
|
||||
null : EqContext n -> Bool
|
||||
null ctx = null ctx.dnames && null ctx.tnames
|
||||
|
||||
export %inline
|
||||
extendTyN : Telescope (\n => (q, BaseName, Term q 0 n)) from to ->
|
||||
EqContext q from -> EqContext q to
|
||||
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 {
|
||||
|
|
@ -180,17 +179,17 @@ namespace EqContext
|
|||
}
|
||||
|
||||
export %inline
|
||||
extendTy : q -> BaseName -> Term q 0 n -> EqContext q n -> EqContext q (S n)
|
||||
extendTy : Qty -> BaseName -> Term 0 n -> EqContext n -> EqContext (S n)
|
||||
extendTy q x s = extendTyN [< (q, x, s)]
|
||||
|
||||
export %inline
|
||||
extendDim : BaseName -> DimConst -> EqContext q n -> EqContext q n
|
||||
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
|
||||
toTyContext : (e : EqContext q n) -> TyContext q e.dimLen n
|
||||
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
|
||||
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||
MkTyContext {
|
||||
dctx = fromGround dassign,
|
||||
|
|
@ -199,11 +198,11 @@ namespace EqContext
|
|||
}
|
||||
|
||||
export
|
||||
injectT : EqContext q n -> Term q 0 0 -> Term q 0 n
|
||||
injectT : EqContext n -> Term 0 0 -> Term 0 n
|
||||
injectT (MkEqContext {termLen = Val n, _}) tm = tm // shift0 n
|
||||
|
||||
export
|
||||
injectE : EqContext q n -> Elim q 0 0 -> Elim q 0 n
|
||||
injectE : EqContext n -> Elim 0 0 -> Elim 0 n
|
||||
injectE (MkEqContext {termLen = Val n, _}) el = el // shift0 n
|
||||
|
||||
|
||||
|
|
@ -214,17 +213,17 @@ PrettyHL a => PrettyHL (CtxBinder a) where
|
|||
prettyM (MkCtxBinder x t) = pure $
|
||||
sep [hsep [!(pretty0M $ TV x), colonD], !(pretty0M t)]
|
||||
|
||||
parameters {auto _ : (Eq q, PrettyHL q, IsQty q)} (unicode : Bool)
|
||||
parameters (unicode : Bool)
|
||||
private
|
||||
pipeD : Doc HL
|
||||
pipeD = hl Syntax "|"
|
||||
|
||||
export covering
|
||||
prettyTContext : NContext d ->
|
||||
QContext q n -> NContext n ->
|
||||
TContext q d n -> Doc HL
|
||||
QContext n -> NContext n ->
|
||||
TContext d n -> Doc HL
|
||||
prettyTContext ds qs xs ctx = separate comma $ toList $ go qs xs ctx where
|
||||
go : QContext q m -> NContext m -> TContext q d m -> SnocList (Doc HL)
|
||||
go : QContext m -> NContext m -> TContext d m -> SnocList (Doc HL)
|
||||
go [<] [<] [<] = [<]
|
||||
go (qs :< q) (xs :< x) (ctx :< t) =
|
||||
let bind = MkWithQty q $ MkCtxBinder x t in
|
||||
|
|
@ -232,7 +231,7 @@ parameters {auto _ : (Eq q, PrettyHL q, IsQty q)} (unicode : Bool)
|
|||
runPrettyWith unicode (toSnocList' ds) (toSnocList' xs) (pretty0M bind)
|
||||
|
||||
export covering
|
||||
prettyTyContext : TyContext q d n -> Doc HL
|
||||
prettyTyContext : TyContext d n -> Doc HL
|
||||
prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
|
||||
case dctx of
|
||||
C [<] => prettyTContext dnames qtys tnames tctx
|
||||
|
|
@ -240,7 +239,7 @@ parameters {auto _ : (Eq q, PrettyHL q, IsQty q)} (unicode : Bool)
|
|||
prettyTContext dnames qtys tnames tctx]
|
||||
|
||||
export covering
|
||||
prettyEqContext : EqContext q n -> Doc HL
|
||||
prettyEqContext : EqContext n -> Doc HL
|
||||
prettyEqContext (MkEqContext dassign dnames tctx tnames qtys) =
|
||||
case dassign of
|
||||
[<] => prettyTContext [<] qtys tnames tctx
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue