Add colors to errors and warnings

elm-compiler.cabal

@@ -113,6 +113,7 @@ Library
     Build-depends:
         aeson >= 0.7 && < 0.9,
         aeson-pretty >= 0.7 && < 0.8,
+        ansi-terminal >= 0.6.2.1 && < 0.7,
         base >=4.2 && <5,
         binary >= 0.7.0.0 && < 0.8,
         blaze-html >= 0.5 && < 0.8,
@@ -152,6 +153,7 @@ Executable elm
     Build-depends:
         aeson >= 0.7 && < 0.9,
         aeson-pretty >= 0.7 && < 0.8,
+        ansi-terminal >= 0.6.2.1 && < 0.7,
         base >=4.2 && <5,
         binary >= 0.7.0.0 && < 0.8,
         bytestring >= 0.9 && < 0.11,
@@ -196,6 +198,7 @@ Test-Suite compiler-tests
         QuickCheck >= 2 && < 3,
         aeson >= 0.7 && < 0.9,
         aeson-pretty >= 0.7 && < 0.8,
+        ansi-terminal >= 0.6.2.1 && < 0.7,
         base >=4.2 && <5,
         binary >= 0.7.0.0 && < 0.8,
         blaze-html >= 0.5 && < 0.8,

src/Elm/Compiler.hs

@@ -2,8 +2,8 @@
 module Elm.Compiler
     ( version, rawVersion
     , parseDependencies, compile
-    , Error, errorToString, errorToJson
-    , Warning, warningToString, warningToJson
+    , Error, errorToString, errorToJson, printError
+    , Warning, warningToString, warningToJson, printWarning
     ) where
 
 import qualified Data.Aeson as Json
@@ -91,6 +91,11 @@ errorToString location source (Error err) =
     Error.toString location source err
 
 
+printError :: String -> String -> Error -> IO ()
+printError location source (Error err) =
+    Error.print location source err
+
+
 errorToJson :: String -> Error -> Json.Value
 errorToJson location (Error err) =
     Error.toJson location err
@@ -106,6 +111,11 @@ warningToString location source (Warning err) =
     Warning.toString location source err
 
 
+printWarning :: String -> String -> Warning -> IO ()
+printWarning location source (Warning err) =
+    Warning.print location source err
+
+
 warningToJson :: String -> Warning -> Json.Value
 warningToJson location (Warning err) =
     Warning.toJson location err

src/Reporting/Error.hs

@@ -4,6 +4,7 @@ module Reporting.Error where
 
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Json
+import Prelude hiding (print)
 
 import qualified Reporting.Annotation as A
 import qualified Reporting.Error.Canonicalize as Canonicalize
@@ -20,23 +21,31 @@ data Error
     | Type Type.Error
 
 
+-- TO REPORT
+
+toReport :: Error -> Report.Report
+toReport err =
+  case err of
+    Syntax syntaxError ->
+        Syntax.toReport syntaxError
+
+    Canonicalize canonicalizeError ->
+        Canonicalize.toReport canonicalizeError
+
+    Type typeError ->
+        Type.toReport typeError
+
+
 -- TO STRING
 
 toString :: String -> String -> A.Located Error -> String
 toString location source (A.A region err) =
-  let
-    report =
-        case err of
-          Syntax syntaxError ->
-              Syntax.toReport syntaxError
+  Report.toString location region (toReport err) source
 
-          Canonicalize canonicalizeError ->
-              Canonicalize.toReport canonicalizeError
 
-          Type typeError ->
-              Type.toReport typeError
-  in
-      Report.toString location region report source
+print :: String -> String -> A.Located Error -> IO ()
+print location source (A.A region err) =
+  Report.printError location region (toReport err) source
 
 
 -- TO JSON

src/Reporting/Error/Type.hs

@@ -57,8 +57,7 @@ toReport err =
           (subRegion, preHint) = hintToString hint
 
           postHint =
-            "To be more specific, as I infer all the types, I am seeing a conflict between\n"
-            ++ "this type:\n\n"
+            "To be more specific, type inference is leading to a conflict between this type:\n\n"
             ++ P.render (P.nest 4 (P.pretty False leftType))
             ++ "\n\nand this type:\n\n"
             ++ P.render (P.nest 4 (P.pretty False rightType))

src/Reporting/Report.hs

@@ -5,10 +5,15 @@ module Reporting.Report
     , simple
     , toString
     , toJson
+    , printError, printWarning
     ) where
 
+import Control.Applicative ((<|>))
+import Control.Monad.Writer (Writer, execWriter, tell)
 import Data.Aeson ((.=))
 import qualified Data.Aeson.Types as Json
+import System.Console.ANSI
+import System.IO (hPutStr, stderr)
 
 import qualified Reporting.Region as R
 
@@ -27,13 +32,33 @@ simple title pre post =
 
 
 toString :: String -> R.Region -> Report -> String -> String
-toString location region (Report title highlight pre post) source =
-  concat
-    [ messageBar title location
-    , pre ++ "\n\n"
-    , grabRegion highlight region source ++ "\n"
-    , if null post then "\n" else post ++ "\n\n\n"
-    ]
+toString location region report source =
+  execWriter (render plain location region report source)
+
+
+printError :: String -> R.Region -> Report -> String -> IO ()
+printError location region report source =
+  render (ansi Error) location region report source
+
+
+printWarning :: String -> R.Region -> Report -> String -> IO ()
+printWarning location region report source =
+  render (ansi Warning) location region report source
+
+
+render
+    :: (Monad m)
+    => Renderer m
+    -> String
+    -> R.Region
+    -> Report
+    -> String
+    -> m ()
+render renderer location region (Report title highlight pre post) source =
+  do  messageBar renderer title location
+      normal renderer (pre ++ "\n\n")
+      grabRegion renderer highlight region source
+      normal renderer ("\n" ++ if null post then "\n" else post ++ "\n\n\n")
 
 
 toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])
@@ -48,21 +73,70 @@ toJson extraFields (Report title subregion pre post) =
     (subregion, fields ++ extraFields)
 
 
+-- RENDERING
+
+data Renderer m = Renderer
+    { normal :: String -> m ()
+    , header :: String -> m ()
+    , accent :: String -> m ()
+    }
+
+
+plain :: Renderer (Writer String)
+plain =
+  Renderer tell tell tell
+
+
+data Type = Error | Warning
+
+
+ansi :: Type -> Renderer IO
+ansi tipe =
+  let
+    put =
+      hPutStr stderr
+
+    put' intensity color string =
+      do  hSetSGR stderr [SetColor Foreground intensity color]
+          put string
+          hSetSGR stderr [Reset]
+
+    accentColor =
+      case tipe of
+        Error -> Red
+        Warning -> Yellow
+  in
+    Renderer
+      put
+      (put' Dull Cyan)
+      (put' Dull accentColor)
+
+
+
+
 -- REPORT HEADER
 
-messageBar :: String -> String -> String
-messageBar tag location =
-  let usedSpace = 4 + length tag + 1 + length location
+messageBar :: Renderer m -> String -> String -> m ()
+messageBar renderer tag location =
+  let
+    usedSpace = 4 + length tag + 1 + length location
   in
+    header renderer $
       "-- " ++ tag ++ " "
       ++ replicate (max 1 (80 - usedSpace)) '-'
       ++ " " ++ location ++ "\n\n"
 
 
 -- REGIONS
 
-grabRegion :: Maybe R.Region -> R.Region -> String -> String
-grabRegion maybeSubRegion (R.Region start end) source =
+grabRegion
+    :: (Monad m)
+    => Renderer m
+    -> Maybe R.Region
+    -> R.Region
+    -> String
+    -> m ()
+grabRegion renderer maybeSubRegion region@(R.Region start end) source =
   let
     (R.Position startLine startColumn) = start
     (R.Position endLine endColumn) = end
@@ -76,10 +150,10 @@ grabRegion maybeSubRegion (R.Region start end) source =
   in
   case relevantLines of
     [] ->
-        ""
+        normal renderer ""
 
     [sourceLine] ->
-        singleLineRegion startLine sourceLine $
+        singleLineRegion renderer startLine sourceLine $
           case maybeSubRegion of
             Nothing ->
                 (0, startColumn, endColumn, length sourceLine)
@@ -100,44 +174,61 @@ grabRegion maybeSubRegion (R.Region start end) source =
               filteredFirstLine : init rest ++ [filteredLastLine]
 
           lineNumbersWidth =
-              length (show (endLine + 1))
+              length (show endLine)
+
+          subregion =
+              maybeSubRegion <|> Just region
 
           numberedLines =
               zipWith
-                (addLineNumber maybeSubRegion lineNumbersWidth)
-                [startLine - 1 .. endLine + 1]
-                ("" : focusedRelevantLines ++ [""])
+                (addLineNumber renderer subregion lineNumbersWidth)
+                [startLine .. endLine]
+                focusedRelevantLines
         in
-            unlines numberedLines
-
-
-addLineNumber :: Maybe R.Region -> Int -> Int -> String -> String
-addLineNumber maybeSubRegion width n line =
+          mapM_ (\line -> line >> normal renderer "\n") numberedLines
+
+
+addLineNumber
+    :: (Monad m)
+    => Renderer m
+    -> Maybe R.Region
+    -> Int
+    -> Int
+    -> String
+    -> m ()
+addLineNumber renderer maybeSubRegion width n line =
   let
     number =
-        if n < 0 then " " else show n
+      if n < 0 then " " else show n
+
+    lineNumber =
+      replicate (width - length number) ' ' ++ number ++ "|"
 
     spacer (R.Region start end) =
-        if R.line start <= n && n <= R.line end
-          then ">"
-          else " "
+      if R.line start <= n && n <= R.line end
+        then accent renderer ">"
+        else normal renderer " "
   in
-    replicate (width - length number) ' ' ++ number
-    ++ "|" ++ maybe " " spacer maybeSubRegion
-    ++ line
-
-
-singleLineRegion :: Int -> String -> (Int, Int, Int, Int) -> String
-singleLineRegion lineNum sourceLine (start, innerStart, innerEnd, end) =
+    do  normal renderer lineNumber
+        maybe (normal renderer " ") spacer maybeSubRegion
+        normal renderer line
+
+
+singleLineRegion
+    :: (Monad m)
+    => Renderer m
+    -> Int
+    -> String
+    -> (Int, Int, Int, Int)
+    -> m ()
+singleLineRegion renderer lineNum sourceLine (start, innerStart, innerEnd, end) =
   let
-    w = length (show (lineNum + 1))
-
-    number =
-        addLineNumber Nothing w
+    width =
+      length (show lineNum)
 
     underline =
-        replicate (innerStart - 1) ' '
-        ++ replicate (max 1 (innerEnd - innerStart)) '^'
+      replicate (innerStart + width + 1) ' '
+      ++ replicate (max 1 (innerEnd - innerStart)) '^'
 
     (|>) = flip ($)
 
@@ -147,8 +238,5 @@ singleLineRegion lineNum sourceLine (start, innerStart, innerEnd, end) =
           |> take (end - start + 1)
           |> (++) (replicate (start - 1) ' ')
   in
-      unlines
-        [ number (lineNum-1) ""
-        , number lineNum trimmedSourceLine
-        , number (lineNum+1) underline
-        ]
+    do  addLineNumber renderer Nothing width lineNum trimmedSourceLine
+        accent renderer $ "\n" ++ underline

src/Reporting/Warning.hs

@@ -28,6 +28,11 @@ toString location source (A.A region warning) =
     Report.toString location region (toReport warning) source
 
 
+print :: String -> String -> A.Located Warning -> IO ()
+print location source (A.A region warning) =
+    Report.printWarning location region (toReport warning) source
+
+
 toReport :: Warning -> Report.Report
 toReport warning =
   case warning of