refactor Error into submodules

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 @@
-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)]