Commit 52222f9b authored by Rufflewind's avatar Rufflewind Committed by Ben Gamari

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
parent f1fc8cbf
......@@ -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)
......
{-# 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment