Commit 3dbd2b09 authored by Rufflewind's avatar Rufflewind Committed by Ben Gamari

Windows: Improve terminal detection mechanism

The previous detection mechanism allowed environment variables (ANSICON,
ConEmuANSI, TERM) to supersede the fact that the stderr is not a
terminal, which is probably what led to color codes appearing in the
stderr of the tests (see: 847d2293).

This commit changes the detection mechanism to detect Cygwin/MSYS2
terminals in a more reliable manner, avoiding the use of environment
variables entirely.

Test Plan: validate

Reviewers: Phyx, austin, erikd, bgamari

Reviewed By: Phyx, bgamari

Subscribers: RyanGlScott, thomie

Differential Revision: https://phabricator.haskell.org/D2809
parent 8906e7b7
...@@ -357,6 +357,7 @@ Library ...@@ -357,6 +357,7 @@ Library
StaticFlags StaticFlags
StaticPtrTable StaticPtrTable
SysTools SysTools
SysTools.Terminal
Elf Elf
TidyPgm TidyPgm
Ctype Ctype
......
...@@ -532,6 +532,7 @@ compiler_stage2_dll0_MODULES = \ ...@@ -532,6 +532,7 @@ compiler_stage2_dll0_MODULES = \
SrcLoc \ SrcLoc \
StaticFlags \ StaticFlags \
StringBuffer \ StringBuffer \
SysTools.Terminal \
TcEvidence \ TcEvidence \
TcRnTypes \ TcRnTypes \
TcType \ TcType \
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- --
...@@ -157,16 +156,6 @@ module DynFlags ( ...@@ -157,16 +156,6 @@ module DynFlags (
#include "HsVersions.h" #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 Platform
import PlatformConstants import PlatformConstants
import Module import Module
...@@ -190,6 +179,7 @@ import Outputable ...@@ -190,6 +179,7 @@ import Outputable
import Foreign.C ( CInt(..) ) import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO ) import System.IO.Unsafe ( unsafeDupablePerformIO )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn ) import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
import SysTools.Terminal ( stderrSupportsAnsiColors )
import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef import Data.IORef
...@@ -199,7 +189,7 @@ import Control.Monad.Trans.Class ...@@ -199,7 +189,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Exception (catch, throwIO) import Control.Exception (throwIO)
import Data.Ord import Data.Ord
import Data.Bits import Data.Bits
...@@ -216,14 +206,6 @@ import System.Directory ...@@ -216,14 +206,6 @@ import System.Directory
import System.Environment (getEnv) import System.Environment (getEnv)
import System.IO import System.IO
import System.IO.Error 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 System.Environment (lookupEnv)
import qualified Graphics.Win32 as Win32
#endif
import Text.ParserCombinators.ReadP hiding (char) import Text.ParserCombinators.ReadP hiding (char)
import Text.ParserCombinators.ReadP as R import Text.ParserCombinators.ReadP as R
...@@ -1498,84 +1480,6 @@ initDynFlags dflags = do ...@@ -1498,84 +1480,6 @@ initDynFlags dflags = do
rtccInfo = refRtccInfo 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 -- | The normal 'DynFlags'. Note that they are not suitable for use in this form
-- and must be fully initialized by 'GHC.runGhc' first. -- and must be fully initialized by 'GHC.runGhc' first.
defaultDynFlags :: Settings -> DynFlags defaultDynFlags :: Settings -> DynFlags
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module SysTools.Terminal (stderrSupportsAnsiColors) where
#if defined MIN_VERSION_terminfo
import Control.Exception (catch)
import Data.Maybe (fromMaybe)
import System.Console.Terminfo (SetupTermError, Terminal, getCapability,
setupTermFromEnv, termColors)
import System.Posix (queryTerminal, stdError)
#elif defined mingw32_HOST_OS
import Control.Exception (catch, try)
import Data.Bits ((.|.), (.&.))
import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import Foreign (FunPtr, Ptr, allocaBytes, castPtrToFunPtr,
peek, plusPtr, sizeOf, with)
import Foreign.C (CInt(..), CWchar, peekCWStringLen)
import qualified Graphics.Win32 as Win32
import qualified System.Win32 as Win32
#endif
#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
-- | 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
h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE
`catch` \ (_ :: IOError) ->
pure Win32.nullHANDLE
if h == Win32.nullHANDLE
then pure False
else do
eMode <- try (getConsoleMode h)
case eMode of
Left (_ :: IOError) -> queryCygwinTerminal h
Right mode
| modeHasVTP mode -> pure True
| otherwise -> enableVTP h mode
where
queryCygwinTerminal :: Win32.HANDLE -> IO Bool
queryCygwinTerminal h = do
fileType <- Win32.getFileType h
if fileType /= Win32.fILE_TYPE_PIPE
then pure False
else do
fn <- getFileNameByHandle h
pure (("\\cygwin-" `isPrefixOf` fn || "\\msys-" `isPrefixOf` fn) &&
"-pty" `isInfixOf` fn &&
"-master" `isSuffixOf` fn)
`catch` \ (_ :: IOError) ->
pure False
enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool
enableVTP h mode = do
setConsoleMode h (modeAddVTP mode)
modeHasVTP <$> getConsoleMode h
`catch` \ (_ :: IOError) ->
pure False
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
fileNameInfo :: CInt
fileNameInfo = 2
mAX_PATH :: Num a => a
mAX_PATH = 260
getFileNameByHandle :: Win32.HANDLE -> IO String
getFileNameByHandle h = do
let sizeOfDWORD = sizeOf (undefined :: Win32.DWORD)
let sizeOfWchar = sizeOf (undefined :: CWchar)
-- note: implicitly assuming that DWORD has stronger alignment than wchar_t
let bufSize = sizeOfDWORD + mAX_PATH * sizeOfWchar
allocaBytes bufSize $ \ buf -> do
getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize)
len :: Win32.DWORD <- peek buf
let len' = fromIntegral len `div` sizeOfWchar
peekCWStringLen (buf `plusPtr` sizeOfDWORD, min len' mAX_PATH)
getFileInformationByHandleEx
:: Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO ()
getFileInformationByHandleEx h cls buf bufSize = do
lib <- Win32.getModuleHandle (Just "kernel32.dll")
ptr <- Win32.getProcAddress lib "GetFileInformationByHandleEx"
let c_GetFileInformationByHandleEx =
mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr)
Win32.failIfFalse_ "getFileInformationByHandleEx"
(c_GetFileInformationByHandleEx h cls buf bufSize)
type F_GetFileInformationByHandleEx a =
Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO Win32.BOOL
foreign import WINAPI "dynamic"
mk_GetFileInformationByHandleEx
:: FunPtr (F_GetFileInformationByHandleEx a)
-> F_GetFileInformationByHandleEx a
#else
pure False
#endif
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