{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.SysTools.Terminal (stderrSupportsAnsiColors) where

import GHC.Prelude

#if !defined(mingw32_HOST_OS)
import System.Environment (lookupEnv)
import System.IO (hIsTerminalDevice, stderr)
#else
import GHC.IO (catchException)
import GHC.Utils.Exception (try)
import Foreign (Ptr, peek, with)
import qualified Graphics.Win32 as Win32
import qualified System.Win32 as Win32
#endif

import System.IO.Unsafe

#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

-- | Does the controlling terminal support ANSI color sequences?
-- This memoized to avoid thread-safety issues in ncurses (see #17922).
stderrSupportsAnsiColors :: Bool
stderrSupportsAnsiColors :: Bool
stderrSupportsAnsiColors = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO IO Bool
stderrSupportsAnsiColors'
{-# NOINLINE stderrSupportsAnsiColors #-}

-- | Check if ANSI escape sequences can be used to control color in stderr.
stderrSupportsAnsiColors' :: IO Bool
stderrSupportsAnsiColors' :: IO Bool
stderrSupportsAnsiColors' = do
#if !defined(mingw32_HOST_OS)
  -- Equivalent of https://hackage.haskell.org/package/ansi-terminal/docs/System-Console-ANSI.html#v:hSupportsANSI
  isTerminal <- hIsTerminalDevice stderr
  term <- lookupEnv "TERM"
  pure $ isTerminal && term /= Just "dumb"
#else
  h <- DWORD -> IO HANDLE
Win32.getStdHandle DWORD
Win32.sTD_ERROR_HANDLE
         IO HANDLE -> (IOError -> IO HANDLE) -> IO HANDLE
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \ (IOError
_ :: IOError) ->
           HANDLE -> IO HANDLE
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HANDLE
Win32.nullHANDLE
  if h == Win32.nullHANDLE
    then pure False
    else do
      eMode <- try (getConsoleMode h)
      case eMode of
        Left (IOError
_ :: IOError) -> HANDLE -> IO Bool
Win32.isMinTTYHandle HANDLE
h
                                 -- Check if the we're in a MinTTY terminal
                                 -- (e.g., Cygwin or MSYS2)
        Right DWORD
mode
          | DWORD -> Bool
modeHasVTP DWORD
mode -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          | Bool
otherwise       -> HANDLE -> DWORD -> IO Bool
enableVTP HANDLE
h DWORD
mode

  where

    enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool
    enableVTP :: HANDLE -> DWORD -> IO Bool
enableVTP HANDLE
h DWORD
mode = do
        HANDLE -> DWORD -> IO ()
setConsoleMode HANDLE
h (DWORD -> DWORD
modeAddVTP DWORD
mode)
        DWORD -> Bool
modeHasVTP (DWORD -> Bool) -> IO DWORD -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HANDLE -> IO DWORD
getConsoleMode HANDLE
h
      IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \ (IOError
_ :: IOError) ->
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    modeHasVTP :: Win32.DWORD -> Bool
    modeHasVTP :: DWORD -> Bool
modeHasVTP DWORD
mode = DWORD
mode DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.&. DWORD
eNABLE_VIRTUAL_TERMINAL_PROCESSING DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
/= DWORD
0

    modeAddVTP :: Win32.DWORD -> Win32.DWORD
    modeAddVTP :: DWORD -> DWORD
modeAddVTP DWORD
mode = DWORD
mode DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. DWORD
eNABLE_VIRTUAL_TERMINAL_PROCESSING

eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD
eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD
eNABLE_VIRTUAL_TERMINAL_PROCESSING = DWORD
0x0004

getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD
getConsoleMode :: HANDLE -> IO DWORD
getConsoleMode HANDLE
h = DWORD -> (Ptr DWORD -> IO DWORD) -> IO DWORD
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with DWORD
64 ((Ptr DWORD -> IO DWORD) -> IO DWORD)
-> (Ptr DWORD -> IO DWORD) -> IO DWORD
forall a b. (a -> b) -> a -> b
$ \ Ptr DWORD
mode -> do
  String -> IO Bool -> IO ()
Win32.failIfFalse_ String
"GetConsoleMode" (HANDLE -> Ptr DWORD -> IO Bool
c_GetConsoleMode HANDLE
h Ptr DWORD
mode)
  Ptr DWORD -> IO DWORD
forall a. Storable a => Ptr a -> IO a
peek Ptr DWORD
mode

setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()
setConsoleMode :: HANDLE -> DWORD -> IO ()
setConsoleMode HANDLE
h DWORD
mode = do
  String -> IO Bool -> IO ()
Win32.failIfFalse_ String
"SetConsoleMode" (HANDLE -> DWORD -> IO Bool
c_SetConsoleMode HANDLE
h DWORD
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

#endif