aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorAkshay <[email protected]>2020-10-13 13:37:08 +0100
committerAkshay <[email protected]>2020-10-13 13:37:08 +0100
commit8641ce3e1a730c8195e5a74fabef8814f43b05f8 (patch)
treecdacd671ba7445c4823ffb8bbccb20de6e56f655 /src
parent4842ab6362077a62893ac79b752c7da5578292b9 (diff)
refactor Error into submodules
Diffstat (limited to 'src')
-rw-r--r--src/Error/Base.hs (renamed from src/Error.hs)8
-rw-r--r--src/Error/Pretty.hs95
-rw-r--r--src/Evaluator.hs2
-rw-r--r--src/Operators.hs2
4 files changed, 104 insertions, 3 deletions
diff --git a/src/Error.hs b/src/Error/Base.hs
index bfc8d14..b6ae9a3 100644
--- a/src/Error.hs
+++ b/src/Error/Base.hs
@@ -1,11 +1,16 @@
1module Error ( 1module Error.Base (
2 LispError (..) 2 LispError (..)
3 , LispResult (..) 3 , LispResult (..)
4 , unwrap 4 , unwrap
5 ) where 5 ) where
6 6
7import Control.Monad.Except 7import Control.Monad.Except
8import Data.List (intercalate, nub)
8import Parser 9import Parser
10import Text.Parsec
11import Text.Parsec.Error
12import Text.Parsec.Pos
13import Text.Parsec.String (Parser)
9import Text.ParserCombinators.Parsec 14import Text.ParserCombinators.Parsec
10 15
11data LispError = Parse ParseError 16data LispError = Parse ParseError
@@ -29,3 +34,4 @@ type LispResult = Either LispError
29unwrap :: LispResult t -> t 34unwrap :: LispResult t -> t
30unwrap (Right v) = v 35unwrap (Right v) = v
31unwrap (Left _) = undefined -- should panic 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
diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index 10e5e58..b0171ba 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -3,7 +3,7 @@ module Evaluator (
3 ) where 3 ) where
4 4
5import Control.Monad.Except 5import Control.Monad.Except
6import Error (LispError (..), LispResult (..), 6import Error.Base (LispError (..), LispResult (..),
7 unwrap) 7 unwrap)
8import Operators 8import Operators
9import Parser 9import Parser
diff --git a/src/Operators.hs b/src/Operators.hs
index 84d2894..27488f3 100644
--- a/src/Operators.hs
+++ b/src/Operators.hs
@@ -3,7 +3,7 @@ module Operators (
3 ) where 3 ) where
4 4
5import Control.Monad.Except 5import Control.Monad.Except
6import Error (LispError (..), LispResult (..)) 6import Error.Base (LispError (..), LispResult (..))
7import Parser 7import Parser
8 8
9primitives :: [(String, [Expr] -> LispResult Expr)] 9primitives :: [(String, [Expr] -> LispResult Expr)]