refactor Error into submodules

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 @@
+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