rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

%default total

Browse source
This commit is contained in:
rhiannon morris 2023-10-20 05:28:42 +02:00
parent b651ed5447
commit fbb862c88b
2 changed files with 161 additions and 154 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/Quox/Parser/FromParser/Error.idr
View file

@ -7,6 +7,8 @@ import System.File
import Quox.Pretty
%default total
%hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)

53
lib/Quox/Typing/Error.idr
View file

@ -13,6 +13,8 @@ import Derive.Prelude
%language ElabReflection
%hide TT.Name
%default total
public export
record NameContexts d n where
@ -246,10 +248,26 @@ where
hangDSingle "with quantities" $
separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
parameters {opts : LayoutOpts} (showContext : Bool)
export
prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
Eff Pretty (Doc opts)
prettyErrorNoLoc showContext = \case
inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
Doc opts -> Eff Pretty (Doc opts)
inContext' null ctx f doc =
if showContext && not null then
pure $ vappend doc (sep ["in context", !(f ctx)])
else pure doc
export %inline
inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
inTContext ctx = inContext' (null ctx) ctx prettyTyContext
export %inline
inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
inEContext ctx = inContext' (null ctx) ctx prettyEqContext
export
prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
prettyErrorNoLoc err0 = case err0 of
ExpectedTYPE _ ctx s =>
hangDSingle "expected a type universe, but got"
!(prettyTerm ctx.dnames ctx.tnames s)
@ -348,14 +366,14 @@ prettyErrorNoLoc showContext = \case
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a),
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc showContext err)|]
(prettyErrorNoLoc err)|]
WhileCheckingTy ctx a k err =>
[|vappendBlank
(inTContext ctx . sep =<< sequence
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
pure $ text $ isTypeInUniverse k])
(prettyErrorNoLoc showContext err)|]
(prettyErrorNoLoc err)|]
WhileInferring ctx sg e err =>
[|vappendBlank
@ -363,7 +381,7 @@ prettyErrorNoLoc showContext = \case
[hangDSingle "while inferring the type of"
!(prettyElim ctx.dnames ctx.tnames e),
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc showContext err)|]
(prettyErrorNoLoc err)|]
WhileComparingT ctx mode sg a s t err =>
[|vappendBlank
@ -373,7 +391,7 @@ prettyErrorNoLoc showContext = \case
!(prettyTerm [<] ctx.tnames t),
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc showContext err)|]
(prettyErrorNoLoc err)|]
WhileComparingE ctx mode sg e f err =>
[|vappendBlank
@ -382,26 +400,13 @@ prettyErrorNoLoc showContext = \case
hangDSingle (text "is \{prettyMode mode}")
!(prettyElim [<] ctx.tnames f),
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc showContext err)|]
(prettyErrorNoLoc err)|]
where
vappendBlank : Doc opts -> Doc opts -> Doc opts
vappendBlank a b = flush a `vappend` b
inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
inTContext ctx doc =
if showContext && not (null ctx) then
pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
else pure doc
inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
inEContext ctx doc =
if showContext && not (null ctx) then
pure $ vappend doc (sep ["in context", !(prettyEqContext ctx)])
else pure doc
export
prettyError : {opts : _} -> (showContext : Bool) ->
Error -> Eff Pretty (Doc opts)
prettyError showContext err = sep <$> sequence
[prettyLoc err.loc, indentD =<< prettyErrorNoLoc showContext err]
prettyError : Error -> Eff Pretty (Doc opts)
prettyError err = sep <$> sequence
[prettyLoc err.loc, indentD =<< prettyErrorNoLoc err]