refactor Error into submodules

5 files changed, 109 insertions, 6 deletions

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/Base.hs
index bfc8d14..b6ae9a3 100644
--- a/src/Error.hs
+++ b/src/Error/Base.hs
@@ -1,11 +1,16 @@
-module Error (
+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
@@ -29,3 +34,4 @@ 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)]