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: 847d229346431483b99adcff12e46c7bf6af15da).

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

4 files changed, 154 insertions, 98 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ea9c355010..4875753a1c 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -357,6 +357,7 @@ Library
         StaticFlags
         StaticPtrTable
         SysTools
+        SysTools.Terminal
         Elf
         TidyPgm
         Ctype
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 2b85e42b68..37a026c722 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -532,6 +532,7 @@ compiler_stage2_dll0_MODULES = \
 	SrcLoc \
 	StaticFlags \
 	StringBuffer \
+	SysTools.Terminal \
 	TcEvidence \
 	TcRnTypes \
 	TcType \
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f1bb6c0dd0..aee5edce85 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 -------------------------------------------------------------------------------
 --
@@ -157,16 +156,6 @@ 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
@@ -190,6 +179,7 @@ import Outputable
 import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
 import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
+import SysTools.Terminal ( stderrSupportsAnsiColors )
 
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.IORef
@@ -199,7 +189,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Except
-import Control.Exception (catch, throwIO)
+import Control.Exception (throwIO)
 
 import Data.Ord
 import Data.Bits
@@ -216,14 +206,6 @@ 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 System.Environment (lookupEnv)
-import qualified Graphics.Win32 as Win32
-#endif
 import Text.ParserCombinators.ReadP hiding (char)
 import Text.ParserCombinators.ReadP as R
 
@@ -1498,84 +1480,6 @@ 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
diff --git a/compiler/main/SysTools/Terminal.hs b/compiler/main/SysTools/Terminal.hs
new file mode 100644
index 0000000000..b3bf6e651d
--- /dev/null
+++ b/compiler/main/SysTools/Terminal.hs
@@ -0,0 +1,150 @@
+{-# 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