314 lines
9.3 KiB
Idris
314 lines
9.3 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 Control.Eff
|
|
|
|
|
|
public export
|
|
data Error
|
|
= ExpectedTYPE (TyContext d n) (Term d n)
|
|
| ExpectedPi (TyContext d n) (Term d n)
|
|
| ExpectedSig (TyContext d n) (Term d n)
|
|
| ExpectedEnum (TyContext d n) (Term d n)
|
|
| ExpectedEq (TyContext d n) (Term d n)
|
|
| ExpectedNat (TyContext d n) (Term d n)
|
|
| ExpectedBOX (TyContext d n) (Term d n)
|
|
| BadUniverse Universe Universe
|
|
| TagNotIn TagVal (SortedSet TagVal)
|
|
| BadCaseEnum (SortedSet TagVal) (SortedSet TagVal)
|
|
| BadCaseQtys (TyContext d n) (List (QOutput n, Term d n))
|
|
|
|
-- first term arg of ClashT is the type
|
|
| ClashT (EqContext n) EqMode (Term 0 n) (Term 0 n) (Term 0 n)
|
|
| ClashTy (EqContext n) EqMode (Term 0 n) (Term 0 n)
|
|
| ClashE (EqContext n) EqMode (Elim 0 n) (Elim 0 n)
|
|
| ClashU EqMode Universe Universe
|
|
| ClashQ Qty Qty
|
|
| NotInScope Name
|
|
|
|
| NotType (TyContext d n) (Term d n)
|
|
| WrongType (EqContext n) (Term 0 n) (Term 0 n)
|
|
|
|
-- extra context
|
|
| WhileChecking
|
|
(TyContext d n) Qty
|
|
(Term d n) -- term
|
|
(Term d n) -- type
|
|
Error
|
|
| WhileCheckingTy
|
|
(TyContext d n)
|
|
(Term d n)
|
|
(Maybe Universe)
|
|
Error
|
|
| WhileInferring
|
|
(TyContext d n) Qty
|
|
(Elim d n)
|
|
Error
|
|
| WhileComparingT
|
|
(EqContext n) EqMode
|
|
(Term 0 n) -- type
|
|
(Term 0 n) (Term 0 n) -- lhs/rhs
|
|
Error
|
|
| WhileComparingE
|
|
(EqContext n) EqMode
|
|
(Elim 0 n) (Elim 0 n)
|
|
Error
|
|
|
|
| WhnfError WhnfError
|
|
%name Error err
|
|
|
|
public export
|
|
ErrorEff : Type -> Type
|
|
ErrorEff = Except Error
|
|
|
|
|
|
||| whether the error is surrounded in some context
|
|
||| (e.g. "while checking s : A, …")
|
|
public export
|
|
isErrorContext : Error -> 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) -> (0 _ : So (isErrorContext e)) =>
|
|
(Error -> Error, Error)
|
|
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 -> (List (Error -> Error), Error)
|
|
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 -> Error
|
|
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
|
|
|
|
|
|
private
|
|
expect : Has (Except e) fs =>
|
|
(a -> a -> e) -> (a -> a -> Bool) -> a -> a -> Eff fs ()
|
|
expect err cmp x y = unless (x `cmp` y) $ throw $ err x y
|
|
|
|
parameters {auto _ : Has ErrorEff fs}
|
|
export %inline
|
|
expectEqualQ : Qty -> Qty -> Eff fs ()
|
|
expectEqualQ = expect ClashQ (==)
|
|
|
|
export %inline
|
|
expectCompatQ : Qty -> Qty -> Eff fs ()
|
|
expectCompatQ = expect ClashQ compat
|
|
|
|
export %inline
|
|
expectModeU : EqMode -> Universe -> Universe -> Eff fs ()
|
|
expectModeU mode = expect (ClashU mode) $ ucmp mode
|
|
|
|
|
|
private
|
|
prettyMode : EqMode -> Doc HL
|
|
prettyMode Equal = "equal to"
|
|
prettyMode Sub = "a subtype of"
|
|
prettyMode Super = "a supertype of"
|
|
|
|
private
|
|
prettyModeU : EqMode -> Doc HL
|
|
prettyModeU Equal = "equal to"
|
|
prettyModeU Sub = "less than or equal to"
|
|
prettyModeU Super = "greater than or equal to"
|
|
|
|
private
|
|
isTypeInUniverse : Maybe Universe -> Doc HL
|
|
isTypeInUniverse Nothing = "is a type"
|
|
isTypeInUniverse (Just k) = "is a type in universe" <++> prettyUniverse k
|
|
|
|
parameters (unicode : Bool)
|
|
private
|
|
termt : TyContext d n -> Term d n -> Doc HL
|
|
termt ctx = hang 4 . prettyTerm unicode ctx.dnames ctx.tnames
|
|
|
|
private
|
|
terme : EqContext n -> Term 0 n -> Doc HL
|
|
terme ctx = hang 4 . prettyTerm unicode [<] ctx.tnames
|
|
|
|
private
|
|
dissectCaseQtys : TyContext d n ->
|
|
NContext n' -> List (QOutput n', z) ->
|
|
List (Doc HL)
|
|
dissectCaseQtys ctx [<] arms = []
|
|
dissectCaseQtys ctx (tel :< x) arms =
|
|
let qs = map (head . fst) arms
|
|
tl = dissectCaseQtys ctx tel (map (mapFst tail) arms)
|
|
in
|
|
if allSame qs then tl else
|
|
("-" <++> asep [hsep [pretty0 unicode $ TV x, "is used with quantities"],
|
|
hseparate comma $ map (pretty0 unicode) qs]) :: tl
|
|
where
|
|
allSame : List Qty -> Bool
|
|
allSame [] = True
|
|
allSame (q :: qs) = all (== q) qs
|
|
|
|
export
|
|
prettyWhnfError : WhnfError -> Doc HL
|
|
prettyWhnfError = \case
|
|
MissingEnumArm tag tags =>
|
|
sep [hsep ["the tag", hl Tag $ pretty tag, "is not contained in"],
|
|
termt empty $ Enum $ fromList tags]
|
|
|
|
-- [todo] only show some contexts, probably
|
|
export
|
|
prettyError : (showContext : Bool) -> Error -> Doc HL
|
|
prettyError showContext = \case
|
|
ExpectedTYPE ctx s =>
|
|
sep ["expected a type universe, but got", termt ctx s]
|
|
|
|
ExpectedPi ctx s =>
|
|
sep ["expected a function type, but got", termt ctx s]
|
|
|
|
ExpectedSig ctx s =>
|
|
sep ["expected a pair type, but got", termt ctx s]
|
|
|
|
ExpectedEnum ctx s =>
|
|
sep ["expected an enumeration type, but got", termt ctx s]
|
|
|
|
ExpectedEq ctx s =>
|
|
sep ["expected an equality type, but got", termt ctx s]
|
|
|
|
ExpectedNat ctx s {d, n} =>
|
|
sep ["expected the type", pretty0 unicode $ Nat {d, n},
|
|
"but got", termt ctx s]
|
|
|
|
ExpectedBOX ctx s =>
|
|
sep ["expected a box type, but got", termt ctx s]
|
|
|
|
BadUniverse k l =>
|
|
sep ["the universe level", prettyUniverse k,
|
|
"is not strictly less than", prettyUniverse l]
|
|
|
|
TagNotIn tag set =>
|
|
sep [sep ["tag", prettyTag tag, "is not contained in"],
|
|
termt empty (Enum set)]
|
|
|
|
BadCaseEnum type arms =>
|
|
sep ["case expression has head of type", termt empty (Enum type),
|
|
"but cases for", termt empty (Enum arms)]
|
|
|
|
BadCaseQtys ctx arms =>
|
|
hang 4 $ sep $
|
|
"inconsistent variable usage in case arms" ::
|
|
dissectCaseQtys ctx ctx.tnames arms
|
|
|
|
ClashT ctx mode ty s t =>
|
|
inEContext ctx $
|
|
sep ["the term", terme ctx s,
|
|
hsep ["is not", prettyMode mode], terme ctx t,
|
|
"at type", terme ctx ty]
|
|
|
|
ClashTy ctx mode a b =>
|
|
inEContext ctx $
|
|
sep ["the type", terme ctx a,
|
|
hsep ["is not", prettyMode mode], terme ctx b]
|
|
|
|
ClashE ctx mode e f =>
|
|
inEContext ctx $
|
|
sep ["the term", terme ctx $ E e,
|
|
hsep ["is not", prettyMode mode], terme ctx $ E f]
|
|
|
|
ClashU mode k l =>
|
|
sep ["the universe level", prettyUniverse k,
|
|
hsep ["is not", prettyMode mode], prettyUniverse l]
|
|
|
|
ClashQ pi rh =>
|
|
sep ["the quantity", pretty0 unicode pi,
|
|
"is not equal to", pretty0 unicode rh]
|
|
|
|
NotInScope x =>
|
|
hsep [hl' Free $ pretty0 unicode x, "is not in scope"]
|
|
|
|
NotType ctx s =>
|
|
inTContext ctx $
|
|
sep ["the term", termt ctx s, "is not a type"]
|
|
|
|
WrongType ctx ty s =>
|
|
inEContext ctx $
|
|
sep ["the term", terme ctx s,
|
|
"cannot have type", terme ctx ty]
|
|
|
|
WhileChecking ctx pi s a err =>
|
|
vsep [inTContext ctx $
|
|
sep ["while checking", termt ctx s,
|
|
"has type", termt ctx a,
|
|
hsep ["with quantity", pretty0 unicode pi]],
|
|
prettyError showContext err]
|
|
|
|
WhileCheckingTy ctx a k err =>
|
|
vsep [inTContext ctx $
|
|
sep ["while checking", termt ctx a,
|
|
isTypeInUniverse k],
|
|
prettyError showContext err]
|
|
|
|
WhileInferring ctx pi e err =>
|
|
vsep [inTContext ctx $
|
|
sep ["while inferring the type of", termt ctx $ E e,
|
|
hsep ["with quantity", pretty0 unicode pi]],
|
|
prettyError showContext err]
|
|
|
|
WhileComparingT ctx mode a s t err =>
|
|
vsep [inEContext ctx $
|
|
sep ["while checking that", terme ctx s,
|
|
hsep ["is", prettyMode mode], terme ctx t,
|
|
"at type", terme ctx a],
|
|
prettyError showContext err]
|
|
|
|
WhileComparingE ctx mode e f err =>
|
|
vsep [inEContext ctx $
|
|
sep ["while checking that", terme ctx $ E e,
|
|
hsep ["is", prettyMode mode], terme ctx $ E f],
|
|
prettyError showContext err]
|
|
|
|
WhnfError err => prettyWhnfError err
|
|
where
|
|
inTContext : TyContext d n -> Doc HL -> Doc HL
|
|
inTContext ctx doc =
|
|
if showContext && not (null ctx) then
|
|
vsep [sep ["in context", prettyTyContext unicode ctx], doc]
|
|
else doc
|
|
|
|
inEContext : EqContext n -> Doc HL -> Doc HL
|
|
inEContext ctx doc =
|
|
if showContext && not (null ctx) then
|
|
vsep [sep ["in context", prettyEqContext unicode ctx], doc]
|
|
else doc
|