[commit: ghc] master: Detect color support (52222f9b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/52222f9bf705ad64bc4a212088d153d8918b6173/ghc

>---------------------------------------------------------------

commit 52222f9bf705ad64bc4a212088d153d8918b6173
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Tue Nov 29 13:31:16 2016 -0500

    Detect color support
    
    Test Plan: validate
    
    Reviewers: erikd, Phyx, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2717
    
    GHC Trac Issues: #8809


>---------------------------------------------------------------

52222f9bf705ad64bc4a212088d153d8918b6173
 compiler/ghc.cabal.in     |   7 ++++
 compiler/main/DynFlags.hs | 102 +++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 107 insertions(+), 2 deletions(-)

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0a85ff1..9538e2c 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -40,6 +40,11 @@ Flag stage3
     Default: False
     Manual: True
 
+Flag terminfo
+    Description: Build GHC with terminfo support on non-Windows platforms.
+    Default: True
+    Manual: True
+
 Library
     Default-Language: Haskell2010
     Exposed: False
@@ -64,6 +69,8 @@ Library
     if os(windows)
         Build-Depends: Win32  == 2.3.*
     else
+        if flag(terminfo)
+            Build-Depends: terminfo == 0.4.*
         Build-Depends: unix   == 2.7.*
 
     if flag(ghci)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d1819a8..10c523e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -------------------------------------------------------------------------------
 --
@@ -155,6 +156,16 @@ module DynFlags (
 
 #include "HsVersions.h"
 
+#if defined mingw32_HOST_OS && !defined WINAPI
+# if defined i386_HOST_ARCH
+#  define WINAPI stdcall
+# elif defined x86_64_HOST_ARCH
+#  define WINAPI ccall
+# else
+#  error unknown architecture
+# endif
+#endif
+
 import Platform
 import PlatformConstants
 import Module
@@ -187,7 +198,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Except
-import Control.Exception (throwIO)
+import Control.Exception (catch, throwIO)
 
 import Data.Ord
 import Data.Bits
@@ -204,6 +215,15 @@ import System.Directory
 import System.Environment (getEnv)
 import System.IO
 import System.IO.Error
+#if defined MIN_VERSION_terminfo
+import System.Console.Terminfo (SetupTermError, Terminal, getCapability,
+                                setupTermFromEnv, termColors)
+import System.Posix (queryTerminal, stdError)
+#elif defined mingw32_HOST_OS
+import Foreign (Ptr, with, peek)
+import System.Environment (lookupEnv)
+import qualified Graphics.Win32 as Win32
+#endif
 import Text.ParserCombinators.ReadP hiding (char)
 import Text.ParserCombinators.ReadP as R
 
@@ -1455,7 +1475,7 @@ initDynFlags dflags = do
                           do str' <- peekCString enc cstr
                              return (str == str'))
                          `catchIOError` \_ -> return False
- canUseColor <- return False -- FIXME: Not implemented
+ canUseColor <- stderrSupportsAnsiColors
  return dflags{
         canGenerateDynamicToo = refCanGenerateDynamicToo,
         nextTempSuffix = refNextTempSuffix,
@@ -1470,6 +1490,84 @@ initDynFlags dflags = do
         rtccInfo      = refRtccInfo
         }
 
+-- | Check if ANSI escape sequences can be used to control color in stderr.
+stderrSupportsAnsiColors :: IO Bool
+stderrSupportsAnsiColors = do
+#if defined MIN_VERSION_terminfo
+  queryTerminal stdError `andM` do
+    (termSupportsColors <$> setupTermFromEnv)
+      `catch` \ (_ :: SetupTermError) ->
+        pure False
+
+  where
+
+    andM :: Monad m => m Bool -> m Bool -> m Bool
+    andM mx my = do
+      x <- mx
+      if x
+        then my
+        else pure x
+
+    termSupportsColors :: Terminal -> Bool
+    termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0
+
+#elif defined mingw32_HOST_OS
+  foldl1 orM
+    [ (/= "") <$> getEnvLM "ANSICON"
+    , (== "on") <$> getEnvLM "ConEmuANSI"
+    , (== "xterm") <$> getEnvLM "TERM"
+    , do
+        h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE
+        mode <- getConsoleMode h
+        if modeHasVTP mode
+          then pure True
+          else do
+            setConsoleMode h (modeAddVTP mode)
+            modeHasVTP <$> getConsoleMode h
+      `catch` \ (_ :: IOError) ->
+        pure False
+    ]
+
+  where
+
+    orM :: Monad m => m Bool -> m Bool -> m Bool
+    orM mx my = do
+      x <- mx
+      if x
+        then pure x
+        else my
+
+    getEnvLM :: String -> IO String
+    getEnvLM name = map toLower . fromMaybe "" <$> lookupEnv name
+
+    modeHasVTP :: Win32.DWORD -> Bool
+    modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
+
+    modeAddVTP :: Win32.DWORD -> Win32.DWORD
+    modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
+
+eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD
+eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
+
+getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD
+getConsoleMode h = with 64 $ \ mode -> do
+  Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode)
+  peek mode
+
+setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()
+setConsoleMode h mode = do
+  Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode)
+
+foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode
+  :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL
+
+foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode
+  :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL
+
+#else
+   pure False
+#endif
+
 -- | The normal 'DynFlags'. Note that they are not suitable for use in this form
 -- and must be fully initialized by 'GHC.runGhc' first.
 defaultDynFlags :: Settings -> DynFlags