From 8641ce3e1a730c8195e5a74fabef8814f43b05f8 Mon Sep 17 00:00:00 2001 From: Akshay Date: Tue, 13 Oct 2020 18:07:08 +0530 Subject: refactor Error into submodules --- bin/Main.hs | 8 +++-- src/Error.hs | 31 ----------------- src/Error/Base.hs | 37 +++++++++++++++++++++ src/Error/Pretty.hs | 95 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Evaluator.hs | 2 +- src/Operators.hs | 2 +- 6 files changed, 139 insertions(+), 36 deletions(-) delete mode 100644 src/Error.hs create mode 100644 src/Error/Base.hs create mode 100644 src/Error/Pretty.hs diff --git a/bin/Main.hs b/bin/Main.hs index a088fdb..54ed6b2 100644 --- a/bin/Main.hs +++ b/bin/Main.hs @@ -2,8 +2,9 @@ module Main where import Control.Monad (liftM) import Control.Monad.Except (throwError) -import Error (LispError (..), LispResult (..), +import Error.Base (LispError (..), LispResult (..), unwrap) +import Error.Pretty (defaults, showError) import Evaluator (eval) import Parser (Expr (..), parseLispValue) import System.Console.Readline @@ -12,7 +13,7 @@ import Text.ParserCombinators.Parsec readExpr :: String -> LispResult Expr readExpr inp = - case parse parseLispValue "(unknown)" inp of + case parse parseLispValue "(lisk-repl)" inp of Left err -> throwError $ Parse err Right val -> return val @@ -26,7 +27,8 @@ repl = do Just ",q" -> return () Just line -> do addHistory line - putStrLn $ either show show $ eval =<< readExpr line + let pp = showError defaults + either (putStrLn . pp line) print $ readExpr line >>= eval repl main :: IO () diff --git a/src/Error.hs b/src/Error.hs deleted file mode 100644 index bfc8d14..0000000 --- a/src/Error.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Error ( - LispError (..) - , LispResult (..) - , unwrap - ) where - -import Control.Monad.Except -import Parser -import Text.ParserCombinators.Parsec - -data LispError = Parse ParseError - | BadForm String Expr - | ArgCount Int [Expr] - | UnknownFunction String - | TypeMismatch String Expr - -unwordsList :: [Expr] -> String -unwordsList = unwords . map show - -instance Show LispError where - show (Parse e) = "Parser Error: " ++ show e - show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr - show (ArgCount n es) = "Invalid arity, expected " ++ show n ++ ", got value(s): " ++ unwordsList es - show (UnknownFunction fn) = "Cannot apply function: " ++ fn - show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got - -type LispResult = Either LispError - -unwrap :: LispResult t -> t -unwrap (Right v) = v -unwrap (Left _) = undefined -- should panic 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 @@ +module Error.Base ( + LispError (..) + , LispResult (..) + , unwrap + ) where + +import Control.Monad.Except +import Data.List (intercalate, nub) +import Parser +import Text.Parsec +import Text.Parsec.Error +import Text.Parsec.Pos +import Text.Parsec.String (Parser) +import Text.ParserCombinators.Parsec + +data LispError = Parse ParseError + | BadForm String Expr + | ArgCount Int [Expr] + | UnknownFunction String + | TypeMismatch String Expr + +unwordsList :: [Expr] -> String +unwordsList = unwords . map show + +instance Show LispError where + show (Parse e) = "Parser Error: " ++ show e + show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr + show (ArgCount n es) = "Invalid arity, expected " ++ show n ++ ", got value(s): " ++ unwordsList es + show (UnknownFunction fn) = "Cannot apply function: " ++ fn + show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got + +type LispResult = Either LispError + +unwrap :: LispResult t -> t +unwrap (Right v) = v +unwrap (Left _) = undefined -- should panic + 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 @@ +module Error.Pretty ( + showError + , Options (..) + , defaults + ) where + +import Data.List (intercalate, nub) +import Error.Base (LispError (..)) +import Text.Parsec +import Text.Parsec.Error +import Text.Parsec.Pos +import Text.Parsec.String (Parser) +import Text.ParserCombinators.Parsec + +data Options = + Options + { color :: Bool + , contextLineCount :: Int + , loudEscapeCode :: String + , softEscapeCode :: String + } + +defaults :: Options +defaults = + Options True 1 "\ESC[31m" "\ESC[38;5;240m" + +showError :: Options -> String -> LispError -> String +showError (Options color clc lec sec) source (Parse error) = + let + -- Colors + dull = if color then "\ESC[0m" else "" + loud = if color then lec else "" + soft = if color then sec else "" + + -- Helper functions + spaces n = replicate n ' ' + pad n s = spaces (n - length s) ++ s + joinOr [] = "" + joinOr [s] = s + joinOr [s,t] = s ++ " or " ++ t + joinOr (s:t:u) = s ++ ", " ++ joinOr (t:u) + + -- Data about the error + msgs = errorMessages error + pos = errorPos error + name = sourceName pos + y = sourceLine pos - 1 + x = sourceColumn pos - 1 + sourceLines = lines source + address = name ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) + + -- Message display + showMsg (SysUnExpect s) = "unexpected " ++ s + showMsg (UnExpect s) = "unexpected " ++ s + showMsg (Expect s) = "expected " ++ s + showMsg (Message s) = s + showMsgs [] = "unknown parse error" + showMsgs [m] = showMsg m + showMsgs (m:ms) = showMsg m ++ "\n" ++ showMsgs ms + unexpections = joinOr $ nub $ [s | SysUnExpect s <- msgs, s /= ""] + ++ [s | UnExpect s <- msgs, s /= ""] + expections = joinOr $ nub [s | Expect s <- msgs, s /= ""] + cleanMsgs = [UnExpect unexpections | unexpections /= ""] + ++ [Expect expections | expections /= ""] + ++ nub [Message s | Message s <- msgs] + + -- Margin display + marginSize = max 3 $ length $ show $ length sourceLines + margin l r = soft ++ pad marginSize l ++ " | " ++ dull ++ r + number i = margin (show i) + numbered = zipWith number [1..] sourceLines + + -- Explanation display + -- (Wrap lines to "not much more than 50 chars" at any indentation.) + -- (The wrapping is for readability, not to meet a term width) + continue = margin "" + pointer = continue (spaces x) ++ loud ++ "^-- " + newline = dull ++ "\n" ++ continue (spaces (x + 4)) ++ loud + wrap n [] = dull + wrap n (w:ws) | n >= 50 = newline ++ w ++ wrap (length w) ws + | otherwise = " " ++ w ++ wrap (n + length w + 1) ws + msgLines = lines (showMsgs cleanMsgs) + wrappedLines = map (drop 1 . wrap 0 . words) msgLines + explanationBody = intercalate newline wrappedLines + explanation = pointer ++ explanationBody + + -- Final output + flower = replicate marginSize '-' ++ "-> " + header = soft ++ flower ++ address ++ dull + before = drop (y - clc) $ take y numbered + focused = numbered !! y + after = take clc $ drop (y + 1) numbered + in + unlines $ header : before ++ (focused : explanation : after) +showError _ _ 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 ( ) where import Control.Monad.Except -import Error (LispError (..), LispResult (..), +import Error.Base (LispError (..), LispResult (..), unwrap) import Operators import 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 ( ) where import Control.Monad.Except -import Error (LispError (..), LispResult (..)) +import Error.Base (LispError (..), LispResult (..)) import Parser primitives :: [(String, [Expr] -> LispResult Expr)] -- cgit v1.2.3