marking code in error messages with backticks (purescript#2079)

soupi · paf31 · commit 2ca82f87d232 · 2016-05-28T13:12:09.000-07:00
* marking code in error messages with backticks

* adding 'endWith' box combinator and using it to mark code on boxes

* removing backticks from multiple lines

* marking code with color

* refactoring prettyPrintSingleError to get an Options record. namely - PPEOptions

* Checking for terminal
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
@@ -65,7 +65,7 @@ compile (HierarchyOptions inputGlob mOutput) = do
   input <- glob inputGlob
   modules <- readInput input
   case modules of
-    Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure
+    Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
     Right ms -> do
       for_ ms $ \(P.Module _ _ moduleName decls _) ->
         let name = runModuleName moduleName
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
@@ -95,7 +95,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
       Right x ->
         return x
       Left err -> do
-        hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
+        hPutStrLn stderr $ P.prettyPrintMultipleErrors P.defaultPPEOptions err
         exitFailure
 
   takeByName = takeModulesByName D.modName
diff --git a/psc/Main.hs b/psc/Main.hs
@@ -11,6 +11,7 @@ import           Control.Monad
 import           Control.Monad.Writer.Strict
 
 import qualified Data.Aeson as A
+import           Data.Bool (bool)
 import qualified Data.ByteString.Lazy as B
 import qualified Data.ByteString.UTF8 as BU8
 import qualified Data.Map as M
@@ -24,6 +25,7 @@ import           Options.Applicative as Opts
 
 import qualified Paths_purescript as Paths
 
+import qualified System.Console.ANSI as ANSI
 import           System.Exit (exitSuccess, exitFailure)
 import           System.FilePath.Glob (glob)
 import           System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
@@ -40,11 +42,13 @@ data PSCMakeOptions = PSCMakeOptions
 -- | Argumnets: verbose, use JSON, warnings, errors
 printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
 printWarningsAndErrors verbose False warnings errors = do
+  cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
+  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose }
   when (P.nonEmpty warnings) $
-    hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)
+    hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings)
   case errors of
     Left errs -> do
-      hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)
+      hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs)
       exitFailure
     Right _ -> return ()
 printWarningsAndErrors verbose True warnings errors = do
diff --git a/psci/Main.hs b/psci/Main.hs
@@ -107,7 +107,7 @@ main = getOpt >>= loop
           (externs, env) <- ExceptT . runMake . make $ modules
           return (modules, externs, env)
         case e of
-          Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
+          Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
           Right (modules, externs, env) -> do
             historyFilename <- getHistoryFilename
             let settings = defaultSettings { historyFile = Just historyFilename }
diff --git a/purescript.cabal b/purescript.cabal
@@ -94,6 +94,7 @@ library
     build-depends: base >=4.8 && <5,
                    aeson >= 0.8 && < 0.12,
                    aeson-better-errors >= 0.8,
+                   ansi-terminal >= 0.6.2 && < 0.7,
                    base-compat >=0.6.0,
                    bower-json >= 0.8,
                    boxes >= 0.1.4 && < 0.2.0,
@@ -303,6 +304,7 @@ executable psc
     build-depends: base >=4 && <5,
                    purescript -any,
                    aeson >= 0.8 && < 0.12,
+                   ansi-terminal >= 0.6.2 && < 0.7,
                    base-compat >=0.6.0,
                    bytestring -any,
                    containers -any,
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs
@@ -47,7 +47,7 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro
 toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError
 toJSONError verbose level e =
   JSONError (toErrorPosition <$> sspan)
-            (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e)))
+            (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e)))
             (P.errorCode e)
             (P.wikiUri e)
             (P.spanName <$> sspan)
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
@@ -44,7 +44,7 @@ import           System.Process (readProcessWithExitCode)
 
 -- | Pretty-print errors
 printErrors :: MonadIO m => P.MultipleErrors -> m ()
-printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors False
+printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions
 
 -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
 -- options and ignores the warning messages.
diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs
@@ -26,7 +26,7 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)
 loadModule :: FilePath -> IO (Either String [P.Module])
 loadModule filename = do
   content <- readUTF8File filename
-  return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
+  return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
 
 -- |
 -- Load all modules.
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
@@ -153,3 +153,7 @@ before b1 b2 | rows b1 > 1 = b1 // b2
 
 beforeWithSpace :: Box -> Box -> Box
 beforeWithSpace b1 = before (b1 <> text " ")
+
+-- | Place a Box on the bottom right of another
+endWith :: Box -> Box -> Box
+endWith l r = l <> vcat top [emptyBox (rows l - 1) (cols r), r]
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -225,7 +225,7 @@ displayUserError e = case e of
   CompileError err ->
     vcat
       [ para "Compile error:"
-      , indented (vcat (P.prettyPrintMultipleErrorsBox False err))
+      , indented (vcat (P.prettyPrintMultipleErrorsBox P.defaultPPEOptions err))
       ]
   DirtyWorkingTree ->
     para (
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
@@ -76,7 +76,7 @@ spec = do
       externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
       return (zip (map snd modules) externs)
     case supportExterns of
-      Left errs -> fail (P.prettyPrintMultipleErrors False errs)
+      Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
       Right externs -> return (externs, passingFiles, warningFiles, failingFiles)
 
   context "Passing examples" $
@@ -232,7 +232,7 @@ assertCompiles
 assertCompiles supportExterns inputFiles =
   assert supportExterns inputFiles checkMain $ \e ->
     case e of
-      Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
+      Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
       Right _ -> do
         process <- findNodeProcess
         let entryPoint = modulesDir </> "index.js"
@@ -255,15 +255,15 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =
   assert supportExterns inputFiles checkMain $ \e ->
     case e of
       Left errs ->
-        return . Just . P.prettyPrintMultipleErrors False $ errs
+        return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
       Right warnings ->
         return
           . fmap (printAllWarnings warnings)
           $ checkShouldFailWith shouldWarnWith warnings
 
   where
   printAllWarnings warnings =
-    (<> "\n\n" <> P.prettyPrintMultipleErrors False warnings)
+    (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings)
 
 assertDoesNotCompile
   :: [(P.Module, P.ExternsFile)]
