diff options
Diffstat (limited to 'src/Error')
-rw-r--r-- | src/Error/Base.hs | 37 | ||||
-rw-r--r-- | src/Error/Pretty.hs | 95 |
2 files changed, 132 insertions, 0 deletions
diff --git a/src/Error/Base.hs b/src/Error/Base.hs new file mode 100644 index 0000000..b6ae9a3 --- /dev/null +++ b/src/Error/Base.hs | |||
@@ -0,0 +1,37 @@ | |||
1 | module Error.Base ( | ||
2 | LispError (..) | ||
3 | , LispResult (..) | ||
4 | , unwrap | ||
5 | ) where | ||
6 | |||
7 | import Control.Monad.Except | ||
8 | import Data.List (intercalate, nub) | ||
9 | import Parser | ||
10 | import Text.Parsec | ||
11 | import Text.Parsec.Error | ||
12 | import Text.Parsec.Pos | ||
13 | import Text.Parsec.String (Parser) | ||
14 | import Text.ParserCombinators.Parsec | ||
15 | |||
16 | data LispError = Parse ParseError | ||
17 | | BadForm String Expr | ||
18 | | ArgCount Int [Expr] | ||
19 | | UnknownFunction String | ||
20 | | TypeMismatch String Expr | ||
21 | |||
22 | unwordsList :: [Expr] -> String | ||
23 | unwordsList = unwords . map show | ||
24 | |||
25 | instance Show LispError where | ||
26 | show (Parse e) = "Parser Error: " ++ show e | ||
27 | show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr | ||
28 | show (ArgCount n es) = "Invalid arity, expected " ++ show n ++ ", got value(s): " ++ unwordsList es | ||
29 | show (UnknownFunction fn) = "Cannot apply function: " ++ fn | ||
30 | show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got | ||
31 | |||
32 | type LispResult = Either LispError | ||
33 | |||
34 | unwrap :: LispResult t -> t | ||
35 | unwrap (Right v) = v | ||
36 | unwrap (Left _) = undefined -- should panic | ||
37 | |||
diff --git a/src/Error/Pretty.hs b/src/Error/Pretty.hs new file mode 100644 index 0000000..44601d6 --- /dev/null +++ b/src/Error/Pretty.hs | |||
@@ -0,0 +1,95 @@ | |||
1 | module Error.Pretty ( | ||
2 | showError | ||
3 | , Options (..) | ||
4 | , defaults | ||
5 | ) where | ||
6 | |||
7 | import Data.List (intercalate, nub) | ||
8 | import Error.Base (LispError (..)) | ||
9 | import Text.Parsec | ||
10 | import Text.Parsec.Error | ||
11 | import Text.Parsec.Pos | ||
12 | import Text.Parsec.String (Parser) | ||
13 | import Text.ParserCombinators.Parsec | ||
14 | |||
15 | data Options = | ||
16 | Options | ||
17 | { color :: Bool | ||
18 | , contextLineCount :: Int | ||
19 | , loudEscapeCode :: String | ||
20 | , softEscapeCode :: String | ||
21 | } | ||
22 | |||
23 | defaults :: Options | ||
24 | defaults = | ||
25 | Options True 1 "\ESC[31m" "\ESC[38;5;240m" | ||
26 | |||
27 | showError :: Options -> String -> LispError -> String | ||
28 | showError (Options color clc lec sec) source (Parse error) = | ||
29 | let | ||
30 | -- Colors | ||
31 | dull = if color then "\ESC[0m" else "" | ||
32 | loud = if color then lec else "" | ||
33 | soft = if color then sec else "" | ||
34 | |||
35 | -- Helper functions | ||
36 | spaces n = replicate n ' ' | ||
37 | pad n s = spaces (n - length s) ++ s | ||
38 | joinOr [] = "" | ||
39 | joinOr [s] = s | ||
40 | joinOr [s,t] = s ++ " or " ++ t | ||
41 | joinOr (s:t:u) = s ++ ", " ++ joinOr (t:u) | ||
42 | |||
43 | -- Data about the error | ||
44 | msgs = errorMessages error | ||
45 | pos = errorPos error | ||
46 | name = sourceName pos | ||
47 | y = sourceLine pos - 1 | ||
48 | x = sourceColumn pos - 1 | ||
49 | sourceLines = lines source | ||
50 | address = name ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) | ||
51 | |||
52 | -- Message display | ||
53 | showMsg (SysUnExpect s) = "unexpected " ++ s | ||
54 | showMsg (UnExpect s) = "unexpected " ++ s | ||
55 | showMsg (Expect s) = "expected " ++ s | ||
56 | showMsg (Message s) = s | ||
57 | showMsgs [] = "unknown parse error" | ||
58 | showMsgs [m] = showMsg m | ||
59 | showMsgs (m:ms) = showMsg m ++ "\n" ++ showMsgs ms | ||
60 | unexpections = joinOr $ nub $ [s | SysUnExpect s <- msgs, s /= ""] | ||
61 | ++ [s | UnExpect s <- msgs, s /= ""] | ||
62 | expections = joinOr $ nub [s | Expect s <- msgs, s /= ""] | ||
63 | cleanMsgs = [UnExpect unexpections | unexpections /= ""] | ||
64 | ++ [Expect expections | expections /= ""] | ||
65 | ++ nub [Message s | Message s <- msgs] | ||
66 | |||
67 | -- Margin display | ||
68 | marginSize = max 3 $ length $ show $ length sourceLines | ||
69 | margin l r = soft ++ pad marginSize l ++ " | " ++ dull ++ r | ||
70 | number i = margin (show i) | ||
71 | numbered = zipWith number [1..] sourceLines | ||
72 | |||
73 | -- Explanation display | ||
74 | -- (Wrap lines to "not much more than 50 chars" at any indentation.) | ||
75 | -- (The wrapping is for readability, not to meet a term width) | ||
76 | continue = margin "" | ||
77 | pointer = continue (spaces x) ++ loud ++ "^-- " | ||
78 | newline = dull ++ "\n" ++ continue (spaces (x + 4)) ++ loud | ||
79 | wrap n [] = dull | ||
80 | wrap n (w:ws) | n >= 50 = newline ++ w ++ wrap (length w) ws | ||
81 | | otherwise = " " ++ w ++ wrap (n + length w + 1) ws | ||
82 | msgLines = lines (showMsgs cleanMsgs) | ||
83 | wrappedLines = map (drop 1 . wrap 0 . words) msgLines | ||
84 | explanationBody = intercalate newline wrappedLines | ||
85 | explanation = pointer ++ explanationBody | ||
86 | |||
87 | -- Final output | ||
88 | flower = replicate marginSize '-' ++ "-> " | ||
89 | header = soft ++ flower ++ address ++ dull | ||
90 | before = drop (y - clc) $ take y numbered | ||
91 | focused = numbered !! y | ||
92 | after = take clc $ drop (y + 1) numbered | ||
93 | in | ||
94 | unlines $ header : before ++ (focused : explanation : after) | ||
95 | showError _ _ err = show err | ||