From 0519493ca936c8e555cfdf9178195418e342ff05 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Tue, 28 Oct 2014 19:04:48 +0000
Subject: [PATCH] Use terminfo to highlight warnings and errors in blue and red

This replaces the hardwired ANSI escape codes that were accidentally included
in a previous patch.

This adds a dependency on terminfo, but this should be unproblematic, since
haskeline already depends on the same underlying C library.

The color highlighting is omitted on Windows.
---
 gf.cabal                             |  2 +-
 src/compiler/GF/CompileInParallel.hs |  5 ++++-
 src/compiler/GF/CompileOne.hs        |  4 +++-
 src/compiler/GF/System/Console.hs    | 27 ++++++++++++++++++++++++++-
 4 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/gf.cabal b/gf.cabal
index c60989d2f..ce1c24f0a 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -289,7 +289,7 @@ Library
   if os(windows)
     build-depends: Win32
   else
-    build-depends: unix
+    build-depends: unix, terminfo>=0.4
 
 
 Executable gf
diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs
index a70741971..22a53a841 100644
--- a/src/compiler/GF/CompileInParallel.hs
+++ b/src/compiler/GF/CompileInParallel.hs
@@ -17,6 +17,7 @@ import GF.Data.Operations
 import GF.Grammar.Grammar(emptyGrammar,prependModule)
 import GF.Infra.Ident(moduleNameS)
 import GF.Text.Pretty
+import GF.System.Console(TermColors(..),getTermColors)
 import qualified Data.ByteString.Lazy as BS
 
 -- | Compile the given grammar files and everything they depend on,
@@ -81,13 +82,15 @@ batchCompile1 lib_dir (opts,filepaths) =
          ppPath ps = "-path="<>intercalate ":" (map rel ps)
      deps <- newMVar M.empty
      toLog <- newLog runIOE
+     term <- getTermColors
      let --logStrLn = toLog . ePutStrLn
        --ok :: CollectOutput IO a -> IO a
          ok (CO m) = err bad good =<< appIOE m
            where
               good (o,r) = do toLog o; return r
               bad e = do toLog (redPutStrLn e); fail "failed"
-              redPutStrLn s = do ePutStr "\ESC[31m";ePutStr s;ePutStrLn "\ESC[m"
+              redPutStrLn s = do ePutStr (redFg term);ePutStr s
+                                 ePutStrLn (restore term)
      sgr <- liftIO $ newMVar emptyGrammar
      let extendSgr sgr m =
            modifyMVar_ sgr $ \ gr ->
diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs
index 6aac4011b..0a6572134 100644
--- a/src/compiler/GF/CompileOne.hs
+++ b/src/compiler/GF/CompileOne.hs
@@ -27,6 +27,7 @@ import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
 import System.FilePath(makeRelative)
 import qualified Data.Map as Map
 import GF.Text.Pretty(render,(<+>),($$)) --Doc,
+import GF.System.Console(TermColors(..),getTermColors)
 import Control.Monad((<=<))
 
 type OneOutput = (Maybe FullPath,CompiledModule)
@@ -161,7 +162,8 @@ idump opts pass = intermOut opts (Dump pass) . ppModule Internal
 
 warnOut opts warnings
   | null warnings = done
-  | otherwise     = do ePutStr "\ESC[34m";ePutStr ws;ePutStrLn "\ESC[m"
+  | otherwise     = do t <- getTermColors
+                       ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
   where
     ws = if flag optVerbosity opts == Normal
          then '\n':warnings
diff --git a/src/compiler/GF/System/Console.hs b/src/compiler/GF/System/Console.hs
index 975b229f1..37eac816d 100644
--- a/src/compiler/GF/System/Console.hs
+++ b/src/compiler/GF/System/Console.hs
@@ -1,11 +1,18 @@
 {-# LANGUAGE CPP #-}
 module GF.System.Console(
     -- ** Changing which character encoding to use for console IO
-    setConsoleEncoding,changeConsoleEncoding) where
+    setConsoleEncoding,changeConsoleEncoding,
+    -- ** Console colors
+    TermColors(..),getTermColors
+) where
 import System.IO
+import Control.Monad(guard)
+import Control.Monad.Trans(MonadIO(..))
 #ifdef mingw32_HOST_OS
 import System.Win32.Console
 import System.Win32.NLS
+#else
+import System.Console.Terminfo
 #endif
 
 -- | Set the console encoding (for Windows, has no effect on Unix-like systems)
@@ -43,3 +50,21 @@ readCP code =
          "UTF-8"   -> Just 65001
          _         -> Nothing
 #endif
+
+data TermColors = TermColors { redFg,blueFg,restore :: String } deriving Show
+noTermColors = TermColors "" "" ""
+
+getTermColors :: MonadIO m => m TermColors
+#ifdef mingw32_HOST_OS
+getTermColors = return noTermColors
+#else
+getTermColors =
+    liftIO $
+    do term <- setupTermFromEnv
+       return $ maybe noTermColors id $ getCapability term $
+         do n <- termColors
+            guard (n>=8)
+            fg <- setForegroundColor
+            restore <- restoreDefaultColors
+            return $ TermColors (fg Red) (fg Blue) restore
+#endif