quox/lib/Quox/Typing/Error.idr

module Quox.Typing.Error

import Quox.Syntax
import Quox.Reduce
import Quox.Typing.Context
import Quox.Typing.EqMode
import Quox.Pretty

import Data.List
import public Control.Monad.Either


public export
data Error q
= ExpectedTYPE (Term q d n)
| ExpectedPi   (Term q d n)
| ExpectedSig  (Term q d n)
| ExpectedEnum (Term q d n)
| ExpectedEq   (Term q d n)
| BadUniverse  Universe Universe
| TagNotIn     TagVal (SortedSet TagVal)
| BadCaseQtys  (List (QOutput q n))

-- first arg of ClashT is the type
| ClashT  EqMode (Term q d n) (Term q d n) (Term q d n)
| ClashTy EqMode (Term q d n) (Term q d n)
| ClashE  EqMode (Elim q d n) (Elim q d n)
| ClashU  EqMode Universe     Universe
| ClashQ        q            q
| ClashD        (Dim d)      (Dim d)
| NotInScope    Name

| NotType (Term q d n)
| WrongType (Term q d n) (Term q d n) (Term q d n)

-- extra context
| WhileChecking
    (TyContext q d n) q
    (Term q d n) -- term
    (Term q d n) -- type
    (Error q)
| WhileCheckingTy
    (TyContext q d n)
    (Term q d n)
    (Maybe Universe)
    (Error q)
| WhileInferring
    (TyContext q d n) q
    (Elim q d n)
    (Error q)
| WhileComparingT
    (TyContext q d n) EqMode
    (Term q d n) -- type
    (Term q d n) (Term q d n) -- lhs/rhs
    (Error q)
| WhileComparingE
    (TyContext q d n) EqMode
    (Elim q d n) (Elim q d n)
    (Error q)

| WhnfError WhnfError
%name Error err

public export
0 HasErr : Type -> (Type -> Type) -> Type
HasErr q = MonadError (Error q)


||| whether the error is surrounded in some context
||| (e.g. "while checking s : A, …")
public export
isErrorContext : Error q -> Bool
isErrorContext (WhileChecking   {}) = True
isErrorContext (WhileCheckingTy {}) = True
isErrorContext (WhileInferring  {}) = True
isErrorContext (WhileComparingT {}) = True
isErrorContext (WhileComparingE {}) = True
isErrorContext _                    = False

||| remove one layer of context
export
peelContext : (e : Error q) -> (0 _ : So (isErrorContext e)) =>
              (Error q -> Error q, Error q)
peelContext (WhileChecking ctx x s t err) =
  (WhileChecking ctx x s t, err)
peelContext (WhileCheckingTy ctx s k err) =
  (WhileCheckingTy ctx s k, err)
peelContext (WhileInferring ctx x e err) =
  (WhileInferring ctx x e, err)
peelContext (WhileComparingT ctx x s t r err) =
  (WhileComparingT ctx x s t r, err)
peelContext (WhileComparingE ctx x e f err) =
  (WhileComparingE ctx x e f, err)

||| separates out all the error context layers
||| (e.g. "while checking s : A, …")
export
explodeContext : Error q -> (List (Error q -> Error q), Error q)
explodeContext err =
  case choose $ isErrorContext err of
    Left y =>
      let (f,  inner) = peelContext err
          (fs, root)  = explodeContext $ assert_smaller err inner in
      (f :: fs, root)
    Right n => ([], err)

||| leaves the outermost context layer, and the innermost (up to) n, and removes
||| the rest if there are more than n+1 in total
export
trimContext : Nat -> Error q -> Error q
trimContext n err =
  case explodeContext err of
    ([],      err) => err
    (f :: fs, err) => f $ foldr apply err $ takeEnd n fs
where
  takeEnd : Nat -> List a -> List a
  takeEnd n = reverse . take n . reverse


export %inline
wrapErr : MonadError e m => (e -> e) -> m a -> m a
wrapErr f act = catchError act $ throwError . f

expect : MonadError e m => (a -> a -> e) -> (a -> a -> Bool) -> a -> a -> m ()
expect err cmp x y = unless (x `cmp` y) $ throwError $ err x y

parameters {auto _ : HasErr q m}
  export %inline
  expectEqualQ : Eq q => q -> q -> m ()
  expectEqualQ = expect ClashQ (==)

  export %inline
  expectCompatQ : IsQty q => q -> q -> m ()
  expectCompatQ = expect ClashQ $ \pi, rh => isYes $ pi `compat` rh

  export %inline
  expectModeU : EqMode -> Universe -> Universe -> m ()
  expectModeU mode = expect (ClashU mode) $ ucmp mode

  export %inline
  expectEqualD : Dim d -> Dim d -> m ()
  expectEqualD = expect ClashD (==)