aboutsummaryrefslogtreecommitdiff
path: root/src/Error
diff options
context:
space:
mode:
Diffstat (limited to 'src/Error')
-rw-r--r--src/Error/Base.hs37
-rw-r--r--src/Error/Pretty.hs95
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 @@
1module Error.Base (
2 LispError (..)
3 , LispResult (..)
4 , unwrap
5 ) where
6
7import Control.Monad.Except
8import Data.List (intercalate, nub)
9import Parser
10import Text.Parsec
11import Text.Parsec.Error
12import Text.Parsec.Pos
13import Text.Parsec.String (Parser)
14import Text.ParserCombinators.Parsec
15
16data LispError = Parse ParseError
17 | BadForm String Expr
18 | ArgCount Int [Expr]
19 | UnknownFunction String
20 | TypeMismatch String Expr
21
22unwordsList :: [Expr] -> String
23unwordsList = unwords . map show
24
25instance 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
32type LispResult = Either LispError
33
34unwrap :: LispResult t -> t
35unwrap (Right v) = v
36unwrap (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 @@
1module Error.Pretty (
2 showError
3 , Options (..)
4 , defaults
5 ) where
6
7import Data.List (intercalate, nub)
8import Error.Base (LispError (..))
9import Text.Parsec
10import Text.Parsec.Error
11import Text.Parsec.Pos
12import Text.Parsec.String (Parser)
13import Text.ParserCombinators.Parsec
14
15data Options =
16 Options
17 { color :: Bool
18 , contextLineCount :: Int
19 , loudEscapeCode :: String
20 , softEscapeCode :: String
21 }
22
23defaults :: Options
24defaults =
25 Options True 1 "\ESC[31m" "\ESC[38;5;240m"
26
27showError :: Options -> String -> LispError -> String
28showError (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)
95showError _ _ err = show err