quox/lib/Quox/Typechecker.idr

module Quox.Typechecker

import public Quox.Syntax
import public Quox.Typing
import public Quox.Equal
import public Control.Monad.Either
import Decidable.Decidable

%default total


private covering %inline
expectTYPE : HasErr q m => Term q d n -> m Universe
expectTYPE s =
  case (whnfT s).fst of
       TYPE l => pure l
       _      => throwError $ ExpectedTYPE s

private covering %inline
expectPi : HasErr q m => Term q d n ->
           m (q, Term q d n, ScopeTerm q d n)
expectPi ty =
  case (whnfT ty).fst of
       Pi qty _ arg res => pure (qty, arg, res)
       _                => throwError $ ExpectedPi ty

private %inline
expectEqualQ : HasErr q m => Eq q =>
               (expect, actual : q) -> m ()
expectEqualQ pi rh =
  unless (pi == rh) $ throwError $ ClashQ pi rh


private %inline
popQ : HasErr q m => Eq q => q -> QOutput q (S n) -> m (QOutput q n)
popQ pi (qctx :< rh) = expectEqualQ pi rh $> qctx


private %inline
tail : TyContext q d (S n) -> TyContext q d n
tail = {tctx $= tail, qctx $= tail}


private %inline
weakI : IsQty q => InferResult q d n -> InferResult q d (S n)
weakI = {type $= weakT, qout $= (:< zero)}

private
lookupBound : IsQty q =>
              {n : Nat} -> q -> Var n -> TyContext q d n -> InferResult q d n
lookupBound pi VZ (MkTyContext {tctx = _ :< ty, _}) =
  InfRes {type = weakT ty, qout = zero :< pi}
lookupBound pi (VS i) ctx =
  weakI $ lookupBound pi i (tail ctx)


private %inline
subjMult : IsQty q => (sg : SQty q) -> q -> SQty q
subjMult (Element sg subj) qty =
  if isYes (isZero sg) || isYes (isZero qty)
     then Element zero zeroIsSubj
     else Element sg   subj


public export
0 CanTC' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
CanTC' q isGlobal m = (HasErr q m, MonadReader (Definitions' q isGlobal) m)

public export
0 CanTC : (q : Type) -> IsQty q => (Type -> Type) -> Type
CanTC q = CanTC' q IsGlobal

parameters {auto _ : IsQty q} {auto _ : CanTC q m}
 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 : {d, n : Nat} ->
          (ctx : TyContext q d n) -> (sg : SQty q) ->
          (subj : Term q d n) -> (ty : Term q d n) ->
          m (CheckResult q n)
  check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty

  export covering %inline
  infer : {d, n : Nat} ->
          (ctx : TyContext q d n) -> (sg : SQty q) ->
          (subj : Elim q d n) ->
          m (InferResult q d n)
  infer ctx sg subj = infer' ctx sg (pushSubstsE subj)


  export covering
  check' : {d, n : Nat} ->
           (ctx : TyContext q d n) -> (sg : SQty q) ->
           (subj : NotCloTerm q d n) -> (ty : Term q d n) ->
           m (CheckResult q n)

  check' ctx sg (Element (TYPE l) _) ty = do
    l' <- expectTYPE ty
    expectEqualQ zero sg.fst
    unless (l < l') $ throwError $ BadUniverse l l'
    pure zero

  check' ctx sg (Element (Pi qty x arg res) _) ty = do
    l <- expectTYPE ty
    expectEqualQ zero sg.fst
    ignore $ check ctx szero arg (TYPE l)
    case res of
         TUsed   res =>
           ignore $ check (extendTy arg zero ctx) szero res (TYPE l)
         TUnused res =>
           ignore $ check ctx szero res (TYPE l)
    pure zero

  check' ctx sg (Element (Lam x body) _) ty = do
    (qty, arg, res) <- expectPi ty
    -- [todo] do this properly?
    let body = fromScopeTerm body; res = fromScopeTerm res
    qout <- check (extendTy arg (sg.fst * qty) ctx) sg body res
    popQ qty qout

  check' ctx sg (Element (E e) _) ty = do
    infres <- infer ctx sg e
    ignore $ check ctx szero ty (TYPE UAny)
    subT infres.type ty
    pure infres.qout

  export covering
  infer' : {d, n : Nat} ->
           (ctx : TyContext q d n) -> (sg : SQty q) ->
           (subj : NotCloElim q d n) ->
           m (InferResult q d n)

  infer' ctx sg (Element (F x) _) = do
    Just g <- asks $ lookup x  | Nothing => throwError $ NotInScope x
    when (isZero g) $ expectEqualQ sg.fst zero
    pure $ InfRes {type = g.type.get, qout = zero}

  infer' ctx sg (Element (B i) _) =
    pure $ lookupBound sg.fst i ctx

  infer' ctx sg (Element (fun :@ arg) _) = do
    funres <- infer ctx sg fun
    (qty, argty, res) <- expectPi funres.type
    let sg' = subjMult sg qty
    argout <- check ctx sg' arg argty
    pure $ InfRes {type = fromScopeTerm res //. ((arg :# argty) ::: id),
                   qout = funres.qout + argout}

  infer' ctx sg (Element (tm :# ty) _) = do
    ignore $ check ctx szero ty (TYPE UAny)
    qout <- check ctx sg tm ty
    pure $ InfRes {type = ty, qout}