print colorized errors to stderr if attached to a tty

src/Data/Syntax/Assignment.hs

@@ -75,7 +75,7 @@ module Data.Syntax.Assignment
 , Result(..)
 , Error(..)
 , ErrorCause(..)
-, showError
+, printError
 , showExpectation
 -- Running
 , assign
@@ -94,14 +94,15 @@ import qualified Data.IntMap.Lazy as IntMap
 import Data.Ix (inRange)
 import Data.List.NonEmpty (nonEmpty)
 import Data.Record
-import Data.String
 import GHC.Stack
 import qualified Info
 import Prologue hiding (Alt, get, Location, state)
 import Range (offsetRange)
 import qualified Source (Source(..), drop, slice, sourceText, actualLines)
+import System.Console.ANSI
 import Text.Parser.TreeSitter.Language
 import Text.Show hiding (show)
+import System.IO (hIsTerminalDevice, hPutStr)
 
 -- | Assignment from an AST with some set of 'symbol's onto some other value.
 --
@@ -180,18 +181,27 @@ data ErrorCause grammar
   deriving (Eq, Show)
 
 -- | Pretty-print an Error with reference to the source where it occurred.
-showError :: Show grammar => Source.Source -> Error grammar -> String
-showError source error@Error{..}
-  = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n'
-  . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n')
-  . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . withSGRCode [SetColor Foreground Vivid Green] (showChar '^') . showChar '\n'
-  . showString (prettyCallStack callStack)
-  $ ""
+printError :: Show grammar => Source.Source -> Error grammar -> IO ()
+printError source error@Error{..}
+  =  do
+
+    _ <- withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " $ ""
+    _ <- withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') $ ""
+
+    _ <- withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " $ ""
+    _ <- withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') $ ""
+    withSGRCode [SetColor Foreground Vivid Green] (showChar '^') . showChar '\n' . showString (prettyCallStack callStack) $ ""
+
   where context = maybe "\n" (Source.sourceText . sconcat) (nonEmpty [ Source.Source (toS (showLineNumber i)) <> Source.Source ": " <> l | (i, l) <- zip [1..] (Source.actualLines source), inRange (Info.line errorPos - 2, Info.line errorPos) i ])
         showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
         lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.line errorPos) :: Double)))
         showSGRCode = showString . setSGRCode
-        withSGRCode code s = showSGRCode code . s . showSGRCode []
+        withSGRCode code showS s = do
+          isTerm <- hIsTerminalDevice stderr
+          hPutStr stderr $ if isTerm then
+            (showSGRCode code . showS . showSGRCode []) s
+          else
+            showS s
 
 showExpectation :: Show grammar => Error grammar -> ShowS
 showExpectation Error{..} = case errorCause of

src/Parser.hs

@@ -26,7 +26,7 @@ import qualified Language.Ruby.Syntax as Ruby
 import Prologue hiding (Location)
 import Source
 import Syntax hiding (Go)
-import System.IO (hPutStrLn)
+import System.IO (hPutStrLn, hIsTerminalDevice)
 import System.Console.ANSI
 import Term
 import qualified Text.Parser.TreeSitter as TS
@@ -82,20 +82,25 @@ runParser parser = case parser of
   AssignmentParser parser by assignment -> \ source -> do
     ast <- runParser parser source
     let Result err term = assignBy by assignment source ast
-    traverse_ (hPutStrLn stderr . showError source) (toList err)
+    traverse_ (printError source) (toList err)
     case term of
       Just term -> do
         let errors = termErrors term `asTypeOf` toList err
-        traverse_ (hPutStrLn stderr . showError source) errors
-        unless (Prologue.null errors) $
-          hPutStrLn stderr (withSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ "")
+        traverse_ (printError source) errors
+        unless (Prologue.null errors) $ do
+          printErrors [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ ""
         pure term
       Nothing -> pure (errorTerm source err)
   TreeSitterParser language tslanguage -> treeSitterParser language tslanguage
   MarkdownParser -> pure . cmarkParser
   LineByLineParser -> lineByLineParser
   where showSGRCode = showString . setSGRCode
-        withSGRCode code s = showSGRCode code . s . showSGRCode []
+        printErrors code showS s = do
+          isTerm <- hIsTerminalDevice stderr
+          hPutStrLn stderr $ if isTerm then
+            (showSGRCode code . showS . showSGRCode []) s
+          else
+            showS s
 
 errorTerm :: Syntax.Error (Error grammar) :< fs => Source -> Maybe (Error grammar) -> Term (Union fs) (Record Location)
 errorTerm source err = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error (fromMaybe (Error (SourcePos 0 0) (UnexpectedEndOfInput [])) err)))