138 lines
3.9 KiB
Idris
138 lines
3.9 KiB
Idris
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 (TyContext q d n) (Term q d n)
|
|
| ExpectedPi (TyContext q d n) (Term q d n)
|
|
| ExpectedSig (TyContext q d n) (Term q d n)
|
|
| ExpectedEnum (TyContext q d n) (Term q d n)
|
|
| ExpectedEq (TyContext q d n) (Term q d n)
|
|
| BadUniverse Universe Universe
|
|
| TagNotIn TagVal (SortedSet TagVal)
|
|
| BadCaseQtys (TyContext q d n) (List (QOutput q n, TagVal, Term q d n))
|
|
|
|
-- first term arg of ClashT is the type
|
|
| ClashT (EqContext q n) EqMode (Term q 0 n) (Term q 0 n) (Term q 0 n)
|
|
| ClashTy (EqContext q n) EqMode (Term q 0 n) (Term q 0 n)
|
|
| ClashE (EqContext q n) EqMode (Elim q 0 n) (Elim q 0 n)
|
|
| ClashU EqMode Universe Universe
|
|
| ClashQ q q
|
|
| NotInScope Name
|
|
|
|
| NotType (TyContext q d n) (Term q d n)
|
|
| WrongType (EqContext q n) (Term q 0 n) (Term q 0 n) (Term q 0 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
|
|
(EqContext q n) EqMode
|
|
(Term q 0 n) -- type
|
|
(Term q 0 n) (Term q 0 n) -- lhs/rhs
|
|
(Error q)
|
|
| WhileComparingE
|
|
(EqContext q n) EqMode
|
|
(Elim q 0 n) (Elim q 0 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
|
|
|