quox/src/Quox/Typechecker.idr

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, Term d n, ScopeTerm d n)
expectPi ty =
  case (whnfT ty).fst of
       Pi qty _ arg res => pure (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, qout $= (:< zero)}

private
lookupBound : {n : Nat} -> Qty -> Var n -> TyContext d n -> InferResult 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)


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
  --
  -- [todo] probably need to check that pi is 1 or 0 like atkey said

  export covering %inline
  check : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
          (ctx : TyContext d n) -> (pi : Qty) ->
          (subj : Term d n) -> (ty : Term d n) ->
          m (CheckResult n)
  check ctx pi subj ty = check' ctx pi (pushSubstsT subj) ty

  export covering %inline
  infer : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
          (ctx : TyContext d n) -> (pi : Qty) -> (subj : Elim d n) ->
          m (InferResult d n)
  infer ctx pi subj = infer' ctx pi (pushSubstsE subj)


  export covering
  check' : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
           (ctx : TyContext d n) -> (pi : Qty) ->
           (subj : NotCloTerm d n) -> (ty : Term d n) ->
           m (CheckResult n)

  check' ctx pi (Element (TYPE l) _) ty = do
    l' <- expectTYPE ty
    expectEqualQ zero pi
    unless (l < l') $ throw $ BadUniverse l l'
    pure zero

  -- [todo] factor this stuff out
  check' ctx pi (Element (Pi qty x arg res) _) ty = do
    l <- expectTYPE ty
    expectEqualQ zero pi
    ignore $ check ctx zero arg (TYPE l)
    case res of
         TUsed   res => ignore $ check (extendTy arg zero ctx) zero res (TYPE l)
         TUnused res => ignore $ check ctx                     zero res (TYPE l)
    pure zero

  check' ctx pi (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 (pi * qty) ctx) pi body res
    popQ qty qout

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

  export covering
  infer' : MonadThrows [Typing.Error, Equal.Error] m => {d, n : Nat} ->
           (ctx : TyContext d n) -> (pi : Qty) -> (subj : NotCloElim d n) ->
           m (InferResult d n)

  infer' ctx pi (Element (F x) _) =
    -- [todo] check that global is erased ==> pi = zero
    case lookup x ctx.globals of
         Just g  => pure $ InfRes {type = g.type, qout = zero}
         Nothing => throw $ NotInScope x

  infer' ctx pi (Element (B i) _) =
    pure $ lookupBound pi i ctx

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

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