start of type stuff
This commit is contained in:
parent
f363dc3122
commit
88338050fc
2 changed files with 448 additions and 0 deletions
168
src/Quox/Typechecker.idr
Normal file
168
src/Quox/Typechecker.idr
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
module Quox.Typechecker
|
||||
|
||||
import public Quox.Syntax
|
||||
import public Quox.Typing
|
||||
import Quox.Error
|
||||
|
||||
import Data.Nat
|
||||
import Data.SortedMap
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Syntax.WithProof
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data Error : Type where
|
||||
ExpectedType : (subj, ty : Term d n) -> Error
|
||||
UniverseInconsistency : (lo, hi : Universe) -> Error
|
||||
GlobalNotInScope : Name -> Error
|
||||
|
||||
public export
|
||||
record CheckResult
|
||||
{0 d, n : Nat}
|
||||
(0 ctx : WfContext d n)
|
||||
(0 subj, ty : Term d n)
|
||||
where
|
||||
constructor MkCheckResult
|
||||
tmout, tyout : QOutput n
|
||||
hasType : HasTypeT {ctx = ctx.ctx, subj, ty, tmout, tyout}
|
||||
|
||||
|
||||
public export
|
||||
record InferResult
|
||||
{0 d, n : Nat}
|
||||
(0 ctx : WfContext d n)
|
||||
(0 subj : Elim d n)
|
||||
where
|
||||
constructor MkInferResult
|
||||
tmout, tyout : QOutput n
|
||||
ty : Term d n
|
||||
hasType : HasTypeE {ctx = ctx.ctx, subj, ty, tmout, tyout}
|
||||
|
||||
|
||||
public export
|
||||
zeroCtx : Globals -> TyContext 0 0
|
||||
zeroCtx globals = MkTyContext {globals, dctx = DNil, tctx = [<], qctx = [<]}
|
||||
|
||||
public export
|
||||
zeroWfCtx : Globals -> WfContext 0 0
|
||||
zeroWfCtx globals = MkWfContext (zeroCtx globals) NIL
|
||||
|
||||
public export
|
||||
Check0 : (globals : Globals) -> (subj, ty : Term 0 0) -> Type
|
||||
Check0 globals subj ty =
|
||||
HasTypeT {ctx = zeroCtx globals, subj, ty, tmout = [<], tyout = [<]}
|
||||
|
||||
public export
|
||||
record Infer0 (globals : Globals) (subj : Elim 0 0) where
|
||||
constructor MkInfer0
|
||||
ty : Term 0 0
|
||||
hasType : HasTypeE {ctx = zeroCtx globals, subj, ty, tmout = [<], tyout = [<]}
|
||||
|
||||
|
||||
export
|
||||
0 isTypeZeroTyout : HasTypeT {ty = TYPE _, tyout, _} -> IsZero tyout
|
||||
isTypeZeroTyout (TYPE {zty, _}) = zty
|
||||
isTypeZeroTyout (Pi {zty, _}) = zty
|
||||
isTypeZeroTyout (PushT {}) = ?isTypeZeroTyout_PushT
|
||||
|
||||
|
||||
parameters {auto _ : MonadThrow Error m} mutual
|
||||
private
|
||||
checkUniverse : (lo, hi : Universe) -> m (lo `LT` hi)
|
||||
checkUniverse lo hi with (lo `isLT` hi)
|
||||
_ | Yes lt = pure lt
|
||||
_ | No _ = throw $ UniverseInconsistency {lo, hi}
|
||||
|
||||
private
|
||||
expectType : (subj, ty : Term d n) ->
|
||||
m (l : Universe ** ty = TYPE l)
|
||||
expectType _ (TYPE l) = pure (l ** Refl)
|
||||
expectType subj ty = throw $ ExpectedType {subj, ty}
|
||||
|
||||
private
|
||||
checkType : (ctx : WfContext d n) ->
|
||||
(l : Universe) -> (ty : Term d n) ->
|
||||
m (CheckResult ctx (TYPE l) ty)
|
||||
checkType (MkWfContext {ctx, wf}) l ty = do
|
||||
(l' ** eq) <- expectType (TYPE l) ty; let Refl = eq
|
||||
lt <- checkUniverse l l'
|
||||
let Element _ zprf = zero ctx.qctx
|
||||
pure $ MkCheckResult {hasType = TYPE {wf, lt, ztm = zprf, zty = zprf}, _}
|
||||
|
||||
private
|
||||
checkPi : (ctx : WfContext d n) ->
|
||||
(qtm, qty : Qty) ->
|
||||
(x : Name) ->
|
||||
(arg : Term d n) ->
|
||||
(res : Term d (S n)) ->
|
||||
(ty : Term d n) ->
|
||||
m (CheckResult ctx (Pi qtm qty x arg res) ty)
|
||||
checkPi (MkWfContext {ctx, wf}) qtm qty x arg res ty = do
|
||||
let whole = Pi qtm qty x arg res
|
||||
(l' ** eq) <- expectType whole ty; let Refl = eq
|
||||
?checkPi_rhs
|
||||
|
||||
|
||||
private
|
||||
inferFree : (ctx : WfContext {}) -> (x : Name) -> m (InferResult ctx (F x))
|
||||
inferFree (MkWfContext {ctx, wf}) x =
|
||||
case @@ lookup x ctx.globals of
|
||||
(Just g ** eq) =>
|
||||
let Element _ zprf = zero ctx.tctx
|
||||
hasType = F {wf, g, eq, ztm = zprf, zty = zprf}
|
||||
in
|
||||
pure $ MkInferResult {hasType, _}
|
||||
_ => throw $ GlobalNotInScope x
|
||||
|
||||
private
|
||||
inferBound : (ctx : WfContext _ n) -> (i : Var n) -> m (InferResult ctx (B i))
|
||||
inferBound (MkWfContext {ctx, wf}) i =
|
||||
pure $ MkInferResult {hasType = B {wf, look = lookup ctx i, eq = Refl}, _}
|
||||
|
||||
private
|
||||
inferAnn : (ctx : WfContext d n) -> (tm, ty : Term d n) ->
|
||||
m (InferResult ctx (tm :# ty))
|
||||
inferAnn ctx tm ty = do
|
||||
ignore $ check ctx ty (TYPE UAny)
|
||||
MkCheckResult {hasType, _} <- check ctx tm ty
|
||||
pure $ MkInferResult {hasType = Ann hasType, _}
|
||||
|
||||
|
||||
export
|
||||
check : (ctx : WfContext d n) -> (subj, ty : Term d n) ->
|
||||
m (CheckResult ctx subj ty)
|
||||
check ctx subj ty = case subj of
|
||||
TYPE l => checkType ctx l ty
|
||||
Pi qtm qty x arg res => checkPi ctx qtm qty x arg res ty
|
||||
Lam x body => ?check_rhs_3
|
||||
E e => ?check_rhs_4
|
||||
CloT s th => ?check_rhs_5
|
||||
DCloT s th => ?check_rhs_6
|
||||
|
||||
export
|
||||
infer : (ctx : WfContext d n) -> (subj : Elim d n) ->
|
||||
m (InferResult ctx subj)
|
||||
infer ctx subj = case subj of
|
||||
F x => inferFree ctx x
|
||||
B i => inferBound ctx i
|
||||
fun :@ arg => ?infer_rhs_3
|
||||
tm :# ty => inferAnn ctx tm ty
|
||||
CloE e th => ?infer_rhs_5
|
||||
DCloE e th => ?infer_rhs_6
|
||||
|
||||
|
||||
parameters {auto _ : MonadThrow Error m} (globals : Globals)
|
||||
public export
|
||||
check0 : (subj, ty : Term 0 0) -> m (Check0 globals subj ty)
|
||||
check0 subj ty = pure $
|
||||
case !(check (zeroWfCtx globals) subj ty) of
|
||||
MkCheckResult [<] [<] prf => prf
|
||||
|
||||
public export
|
||||
infer0 : (subj : Elim 0 0) -> (ty : Term 0 0) -> m (Infer0 globals subj)
|
||||
infer0 subj ty = pure $
|
||||
case !(infer (zeroWfCtx globals) subj) of
|
||||
MkInferResult [<] [<] ty prf => MkInfer0 ty prf
|
||||
280
src/Quox/Typing.idr
Normal file
280
src/Quox/Typing.idr
Normal file
|
|
@ -0,0 +1,280 @@
|
|||
module Quox.Typing
|
||||
|
||||
import public Quox.Syntax
|
||||
import public Quox.Context
|
||||
|
||||
import Data.Nat
|
||||
import Data.SortedMap
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
|
||||
|
||||
%default total
|
||||
|
||||
public export
|
||||
data DContext : Nat -> Type where
|
||||
DNil : DContext 0
|
||||
DBind : DContext d -> DContext (S d)
|
||||
DEq : Dim d -> Dim d -> DContext d -> DContext d
|
||||
|
||||
public export
|
||||
TContext : Nat -> Nat -> Type
|
||||
TContext d = Context (Term d)
|
||||
|
||||
public export
|
||||
QContext : Nat -> Type
|
||||
QContext = Triangle' Qty
|
||||
|
||||
public export
|
||||
QOutput : Nat -> Type
|
||||
QOutput = Context' Qty
|
||||
|
||||
|
||||
public export
|
||||
record Global where
|
||||
constructor MkGlobal
|
||||
type, term : forall d, n. Term d n
|
||||
|
||||
public export
|
||||
Globals : Type
|
||||
Globals = SortedMap Name Global
|
||||
|
||||
|
||||
public export
|
||||
record TyContext (d, n : Nat) where
|
||||
constructor MkTyContext
|
||||
globals : Globals
|
||||
dctx : DContext d
|
||||
tctx : TContext d n
|
||||
qctx : QContext n
|
||||
|
||||
%name TyContext ctx
|
||||
|
||||
|
||||
namespace TContext
|
||||
export
|
||||
pushD : TContext d n -> TContext (S d) n
|
||||
pushD tel = map (/// shift 1) tel
|
||||
|
||||
|
||||
namespace TyContext
|
||||
export
|
||||
extendTy : Term d n -> QOutput n -> TyContext d n -> TyContext d (S n)
|
||||
extendTy s rhos = {tctx $= (:< s), qctx $= (:< rhos)}
|
||||
|
||||
export
|
||||
extendDim : TyContext d n -> TyContext (S d) n
|
||||
extendDim = {dctx $= DBind, tctx $= pushD}
|
||||
|
||||
export
|
||||
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
|
||||
eqDim p q = {dctx $= DEq p q}
|
||||
|
||||
|
||||
|
||||
namespace QOutput
|
||||
export
|
||||
(+) : QOutput n -> QOutput n -> QOutput n
|
||||
(+) = zipWith (+)
|
||||
|
||||
export
|
||||
(*) : Qty -> QOutput n -> QOutput n
|
||||
(*) pi = map (pi *)
|
||||
|
||||
|
||||
namespace Zero
|
||||
public export
|
||||
data IsZero : QOutput n -> Type where
|
||||
LinZ : IsZero [<]
|
||||
SnocZ : IsZero qctx -> IsZero (qctx :< Zero)
|
||||
|
||||
export
|
||||
isZeroIrrel : {qctx : _} -> (0 _ : IsZero qctx) -> IsZero qctx
|
||||
isZeroIrrel {qctx = [<]} LinZ = LinZ
|
||||
isZeroIrrel {qctx = _ :< _} (SnocZ x) = SnocZ $ isZeroIrrel x
|
||||
|
||||
export
|
||||
zero : Context _ n -> Subset (QOutput n) IsZero
|
||||
zero [<] = Element [<] LinZ
|
||||
zero (ctx :< _) = let zeroN = zero ctx in
|
||||
Element (zeroN.fst :< Zero) (SnocZ zeroN.snd)
|
||||
|
||||
|
||||
namespace Only
|
||||
public export
|
||||
data IsOnly : QOutput n -> Var n -> Type where
|
||||
Here : IsZero qctx -> IsOnly (qctx :< One) VZ
|
||||
There : IsOnly qctx i -> IsOnly (qctx :< Zero) (VS i)
|
||||
|
||||
export
|
||||
isOnlyIrrel : {qctx, i : _} -> (0 _ : IsOnly qctx i) -> IsOnly qctx i
|
||||
isOnlyIrrel {i = VZ} (Here z) = Here $ isZeroIrrel z
|
||||
isOnlyIrrel {i = (VS i)} (There o) = There $ isOnlyIrrel o
|
||||
|
||||
export
|
||||
only : Context _ n -> (i : Var n) ->
|
||||
Subset (QOutput n) (\qctx => IsOnly qctx i)
|
||||
only (ctx :< _) VZ =
|
||||
let zeroN = zero ctx in
|
||||
Element (zeroN.fst :< One) (Here zeroN.snd)
|
||||
only (ctx :< _) (VS i) =
|
||||
let onlyN = only ctx i in
|
||||
Element (onlyN.fst :< Zero) (There onlyN.snd)
|
||||
|
||||
|
||||
namespace Universe
|
||||
public export
|
||||
data LT : Universe -> Universe -> Type where
|
||||
Fin : k `LT` l -> U k `LT` U l
|
||||
Any : U _ `LT` UAny
|
||||
|
||||
export
|
||||
Uninhabited (UAny `LT` j) where
|
||||
uninhabited _ impossible
|
||||
|
||||
export
|
||||
isLT : (i, j : Universe) -> Dec (i `LT` j)
|
||||
isLT (U i) (U j) with (i `isLT` j)
|
||||
_ | Yes prf = Yes $ Fin prf
|
||||
_ | No contra = No $ \(Fin prf) => contra prf
|
||||
isLT (U _) UAny = Yes Any
|
||||
isLT UAny _ = No uninhabited
|
||||
|
||||
|
||||
namespace Lookup
|
||||
public export
|
||||
data IsLookup :
|
||||
(tctx : TContext d n) ->
|
||||
(i : Var n) ->
|
||||
(ty : Term d from) ->
|
||||
(by : Shift from n) -> Type
|
||||
where
|
||||
Here : IsLookup {tctx=(tctx :< ty), i=VZ, ty, by=(SS SZ)}
|
||||
There : IsLookup {tctx, i, ty, by} ->
|
||||
IsLookup {tctx=(tctx :< ty'), i=(VS i), ty, by=(SS by)}
|
||||
|
||||
public export
|
||||
record Lookup'
|
||||
{0 d, n : Nat}
|
||||
(0 tctx : TContext d n)
|
||||
(0 qctx : QContext n)
|
||||
(0 i : Var n)
|
||||
where
|
||||
constructor MkLookup
|
||||
tmout, tyout : QOutput n
|
||||
type : Term d from
|
||||
by : Shift from n
|
||||
0 only : IsOnly tmout i
|
||||
0 look : IsLookup tctx i type by
|
||||
|
||||
public export
|
||||
lookup' : (tctx : TContext d n) -> (qctx : QContext n) ->
|
||||
(i : Var n) -> Lookup' tctx qctx i
|
||||
lookup' tctx@(_ :< _) (_ :< tyout) VZ =
|
||||
MkLookup {only = (only tctx VZ).snd, look = Here,
|
||||
tyout = tyout :< Zero, _}
|
||||
lookup' (tctx :< _) (qctx :< _) (VS i) =
|
||||
let inner = lookup' tctx qctx i in
|
||||
MkLookup {only = There inner.only, look = There inner.look,
|
||||
tyout = inner.tyout :< Zero, _}
|
||||
|
||||
|
||||
public export %inline
|
||||
Lookup : TyContext d n -> Var n -> Type
|
||||
Lookup ctx i = Lookup' ctx.tctx ctx.qctx i
|
||||
|
||||
public export %inline
|
||||
lookup : (ctx : TyContext d n) -> (i : Var n) -> Lookup ctx i
|
||||
lookup ctx = lookup' ctx.tctx ctx.qctx
|
||||
|
||||
|
||||
|
||||
mutual
|
||||
public export
|
||||
data HasTypeT :
|
||||
{0 d, n : Nat} ->
|
||||
(ctx : TyContext d n) ->
|
||||
(subj : Term d n) ->
|
||||
(ty : Term d n) ->
|
||||
(tmout, tyout : QOutput n) ->
|
||||
Type
|
||||
where
|
||||
TYPE :
|
||||
(0 wf : IsWf ctx) ->
|
||||
(lt : k `LT` l) ->
|
||||
(0 ztm : IsZero tmout) -> (0 zty : IsZero tyout) ->
|
||||
HasTypeT {ctx, subj = TYPE k, ty = TYPE l, tmout, tyout}
|
||||
Pi :
|
||||
(tyA : HasTypeT {ctx, subj = a, ty = TYPE l, tmout = tmoutA, tyout}) ->
|
||||
(tyB : HasTypeT {ctx = extendTy a tmoutA ctx, subj = b, ty = TYPE l,
|
||||
tmout = tmoutB :< qty, tyout = tyout :< Zero}) ->
|
||||
(0 zty : IsZero tyout) ->
|
||||
HasTypeT {ctx, subj = Pi qtm qty x a b, ty = TYPE l,
|
||||
tmout = tmoutA + tmoutB, tyout}
|
||||
PushT :
|
||||
(0 eq : ty' = pushSubstsT' ty) ->
|
||||
(j : HasTypeT {ctx, subj, ty = ty', tmout, tyout}) ->
|
||||
HasTypeT {ctx, subj, ty, tmout, tyout}
|
||||
|
||||
public export
|
||||
data HasTypeE :
|
||||
{0 d, n : Nat} ->
|
||||
(ctx : TyContext d n) ->
|
||||
(subj : Elim d n) ->
|
||||
(ty : Term d n) ->
|
||||
(tmout, tyout : QOutput n) ->
|
||||
Type
|
||||
where
|
||||
F :
|
||||
(0 wf : IsWf ctx) ->
|
||||
(g : Global) ->
|
||||
(0 eq : lookup x ctx.globals = Just g) ->
|
||||
(0 ztm : IsZero tmout) -> (0 zty : IsZero tyout) ->
|
||||
HasTypeE {ctx, subj = F x, ty = g.type, tmout, tyout}
|
||||
B :
|
||||
{0 ctx : TyContext d n} ->
|
||||
(0 wf : IsWf ctx) ->
|
||||
(look : Lookup ctx i) ->
|
||||
(0 eq : ty = look.type // look.by) ->
|
||||
HasTypeE {ctx, subj = B i, ty, tmout = look.tmout, tyout = look.tyout}
|
||||
Ann :
|
||||
HasTypeT {ctx, subj = tm, ty, tmout, tyout} ->
|
||||
HasTypeE {ctx, subj = tm :# ty, ty, tmout, tyout}
|
||||
PushE :
|
||||
(0 eq : ty' = pushSubstsT' ty) ->
|
||||
HasTypeE {ctx, subj, ty = ty', tmout, tyout} ->
|
||||
HasTypeE {ctx, subj, ty, tmout, tyout}
|
||||
|
||||
public export
|
||||
data IsWf' :
|
||||
(globals : Globals) ->
|
||||
(dctx : DContext d) ->
|
||||
(tctx : TContext d n) ->
|
||||
(qctx : QContext n) -> Type
|
||||
where
|
||||
NIL : IsWf' globals dctx [<] [<]
|
||||
BIND :
|
||||
IsWf' {globals, dctx, tctx, qctx} ->
|
||||
HasTypeT {ctx = MkTyContext {globals, dctx, tctx, qctx},
|
||||
subj, ty = TYPE l, tmout, tyout} ->
|
||||
IsWf' {globals, dctx, tctx = tctx :< subj, qctx = qctx :< tmout}
|
||||
|
||||
public export %inline
|
||||
IsWf : TyContext d n -> Type
|
||||
IsWf (MkTyContext {globals, dctx, tctx, qctx}) =
|
||||
IsWf' {globals, dctx, tctx, qctx}
|
||||
|
||||
public export
|
||||
record WfContext (d, n : Nat) where
|
||||
constructor MkWfContext
|
||||
ctx : TyContext d n
|
||||
0 wf : IsWf ctx
|
||||
|
||||
|
||||
public export
|
||||
record TypeTerm {0 d, n : Nat} (ctx : TyContext d n) where
|
||||
constructor MkTypeTerm
|
||||
term : Term d n
|
||||
univ : Universe
|
||||
tmout, tyout : QOutput n
|
||||
isType : HasTypeT {ctx, subj = term, ty = TYPE univ, tmout, tyout}
|
||||
Loading…
Reference in a new issue