blob: 0260aa19097e6b4a743fbde8d8c961e67de63413 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
-- MIT License, Copyright (c) 2022 Marvin Borner
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Error where
import Data.List ( intercalate )
import Text.Megaparsec
import Helper
errPrefix :: String
errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m "
okPrefix :: String
okPrefix = "\ESC[102m\ESC[30m OK \ESC[0m "
data Error = SyntaxError String
| UndefinedIdentifier Identifier
| UnmatchedMixfix [MixfixIdentifierKind] [Mixfix]
| InvalidIndex Int
| FailedTest Expression Expression Expression Expression
| PassedTest Expression Expression
| ContextualError Error Context
| SuggestSolution Error String
| ImportError String
| OptimizerError String
instance Show Error where
show (ContextualError err ctx) = show err <> "\n" <> printContext ctx
show (SuggestSolution err sol) =
show err <> "\n\ESC[102m\ESC[30msuggestion\ESC[0m Perhaps you meant " <> sol
show (SyntaxError err) =
errPrefix <> "invalid syntax\n\ESC[105m\ESC[30mnear\ESC[0m " <> err
show (UndefinedIdentifier ident) =
errPrefix <> "undefined identifier " <> show ident
show (UnmatchedMixfix ks ms) =
errPrefix
<> "couldn't find matching mixfix for "
<> intercalate "" (map show ks)
<> "\n\ESC[105m\ESC[30mnear\ESC[0m "
<> unwords (map show ms)
show (InvalidIndex err) = errPrefix <> "invalid index " <> show err
show (PassedTest exp1 exp2) =
okPrefix <> "test passed: " <> show exp1 <> " = " <> show exp2
show (FailedTest exp1 exp2 red1 red2) =
errPrefix
<> "test failed: "
<> show exp1
<> " = "
<> show exp2
<> "\n reduced to "
<> show red1
<> " = "
<> show red2
show (ImportError path) = errPrefix <> "invalid import " <> show path
show (OptimizerError msg ) = errPrefix <> "optimizer failed: " <> msg
type Failable = Either Error
-- Modified from megaparsec's errorBundlePretty
printBundle
:: forall s e
. (VisualStream s, TraversableStream s, ShowErrorComponent e)
=> ParseErrorBundle s e
-> String
printBundle ParseErrorBundle {..} =
let (r, _) = foldl f (id, bundlePosState) bundleErrors in drop 1 (r "")
where
f :: (ShowS, PosState s) -> ParseError s e -> (ShowS, PosState s)
f (o, !pst) e = (o . (outChunk ++), pst')
where
(msline, pst') = reachOffset (errorOffset e) pst
epos = pstateSourcePos pst'
outChunk = "\n\n" <> offendingLine <> init (parseErrorTextPretty e)
offendingLine = case msline of
Nothing -> ""
Just sline ->
let pointer = "^"
rpadding = replicate rpshift ' '
rpshift = unPos (sourceColumn epos) - 2
lineNumber = (show . unPos . sourceLine) epos
padding = replicate (length lineNumber + 1) ' '
in padding
<> "|\n"
<> " | "
<> sline
<> "\n"
<> padding
<> "| "
<> rpadding
<> pointer
<> "\n"
|
