143 lines
4.7 KiB
Idris
143 lines
4.7 KiB
Idris
module Quox.Typechecker
|
|
|
|
import public Quox.Syntax
|
|
import public Quox.Typing
|
|
import Quox.Error
|
|
|
|
%default total
|
|
|
|
|
|
private covering %inline
|
|
expectTYPE : MonadThrow Typing.Error m => Term d n -> m Universe
|
|
expectTYPE s =
|
|
case (whnfT s).fst of
|
|
TYPE l => pure l
|
|
_ => throw $ ExpectedTYPE s
|
|
|
|
private covering %inline
|
|
expectPi : MonadThrow Typing.Error m => Term d n ->
|
|
m (Qty, Qty, Term d n, ScopeTerm d n)
|
|
expectPi ty =
|
|
case (whnfT ty).fst of
|
|
Pi qtm qty _ arg res => pure (qtm, qty, arg, res)
|
|
_ => throw $ ExpectedPi ty
|
|
|
|
private %inline
|
|
expectEqualQ : MonadThrow Equal.Error m =>
|
|
(expect, actual : Qty) -> m ()
|
|
expectEqualQ pi rh = unless (pi == rh) $ throw $ ClashQ pi rh
|
|
|
|
|
|
private %inline
|
|
popQ : MonadThrow Equal.Error m => Qty -> QOutput (S n) -> m (QOutput n)
|
|
popQ pi (qctx :< rh) = expectEqualQ pi rh $> qctx
|
|
|
|
|
|
private %inline
|
|
tail : TyContext d (S n) -> TyContext d n
|
|
tail = {tctx $= tail, qctx $= tail}
|
|
|
|
|
|
private %inline
|
|
weakI : InferResult d n -> InferResult d (S n)
|
|
weakI = {type $= weakT, tmout $= (:< zero), tyout $= (:< zero)}
|
|
|
|
private
|
|
lookupBound : {n : Nat} -> Var n -> TyContext d n -> InferResult d n
|
|
lookupBound VZ (MkTyContext {tctx = _ :< ty, qctx = _ :< tyout, _}) =
|
|
InfRes {type = weakT ty, tmout = zero :< one, tyout = tyout :< zero}
|
|
lookupBound (VS i) ctx =
|
|
weakI $ lookupBound i (tail ctx)
|
|
|
|
|
|
mutual
|
|
-- [todo] it seems like the options here for dealing with substitutions are
|
|
-- to either push them or parametrise the whole typechecker over ambient
|
|
-- substitutions. both of them seem like the same amount of work for the
|
|
-- computer but pushing is less work for the me
|
|
|
|
export covering %inline
|
|
check : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
|
|
(ctx : TyContext d n) -> (subj : Term d n) -> (ty : Term d n) ->
|
|
m (CheckResult n)
|
|
check ctx subj ty = check' ctx (pushSubstsT subj) ty
|
|
|
|
export covering %inline
|
|
infer : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
|
|
(ctx : TyContext d n) -> (subj : Elim d n) ->
|
|
m (InferResult d n)
|
|
infer ctx subj = infer' ctx (pushSubstsE subj)
|
|
|
|
|
|
export covering
|
|
check' : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
|
|
(ctx : TyContext d n) ->
|
|
(subj : NotCloTerm d n) -> (ty : Term d n) ->
|
|
m (CheckResult n)
|
|
|
|
check' ctx (Element (TYPE l) _) ty = do
|
|
l' <- expectTYPE ty
|
|
unless (l < l') $ throw $ BadUniverse l l'
|
|
pure $ ChkRes {tmout = zero, tyout = zero}
|
|
|
|
-- [todo] factor this stuff out
|
|
check' ctx (Element (Pi qtm qty x arg (TUsed res)) _) ty = do
|
|
l <- expectTYPE ty
|
|
argty <- check ctx arg (TYPE l)
|
|
resty <- check (extendTy arg argty.tmout ctx) res (TYPE l)
|
|
res'tmout <- popQ qty resty.tmout
|
|
pure $ ChkRes {tmout = argty.tmout + res'tmout, tyout = zero}
|
|
check' ctx (Element (Pi qtm qty x arg (TUnused res)) _) ty = do
|
|
ignore $ expectTYPE ty
|
|
argty <- check ctx arg ty
|
|
resty <- check ctx res ty
|
|
expectEqualQ qty zero
|
|
pure $ ChkRes {tmout = argty.tmout + resty.tmout, tyout = zero}
|
|
|
|
check' ctx (Element (Lam x body) _) ty = do
|
|
(qtm, qty, arg, res) <- expectPi ty
|
|
-- [todo] do this properly?
|
|
let body = fromScopeTerm body; res = fromScopeTerm res
|
|
argres <- check ctx arg (TYPE UAny)
|
|
let ctx' = extendTy arg argres.tmout ctx
|
|
bodyres <- check ctx' body res
|
|
tmout <- popQ qtm bodyres.tmout
|
|
tyout <- popQ qty bodyres.tyout
|
|
pure $ ChkRes {tmout, tyout = argres.tmout + tyout}
|
|
|
|
check' ctx (Element (E e) _) ty = do
|
|
infres <- infer ctx e
|
|
tyres <- check ctx ty (TYPE UAny)
|
|
infres.type `subT` ty
|
|
pure $ ChkRes {tmout = infres.tmout, tyout = tyres.tmout}
|
|
|
|
export covering
|
|
infer' : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
|
|
(ctx : TyContext d n) -> (subj : NotCloElim d n) ->
|
|
m (InferResult d n)
|
|
|
|
infer' ctx (Element (F x) _) =
|
|
case lookup x ctx.globals of
|
|
Just g => pure $ InfRes {type = g.type, tmout = zero, tyout = zero}
|
|
Nothing => throw $ NotInScope x
|
|
|
|
infer' ctx (Element (B i) _) = pure $ lookupBound i ctx
|
|
|
|
infer' ctx (Element (fun :@ arg) _) = do
|
|
funres <- infer ctx fun
|
|
(qtm, qty, argty, resty) <- expectPi funres.type
|
|
let resty = fromScopeTerm resty
|
|
argres <- check ctx arg argty
|
|
let ctx' = extendTy argty argres.tyout ctx
|
|
resres <- check ctx' resty (TYPE UAny)
|
|
res'tyout <- popQ qty resres.tmout
|
|
let type = resty //. (arg :# argty ::: id)
|
|
pure $ InfRes {type,
|
|
tmout = funres.tmout + qtm * argres.tmout,
|
|
tyout = res'tyout + qty * argres.tmout}
|
|
|
|
infer' ctx (Element (tm :# ty) _) = do
|
|
ignore $ check ctx ty (TYPE UAny)
|
|
res <- check ctx tm ty
|
|
pure $ InfRes {type = ty, tmout = res.tmout, tyout = res.tyout}
|