module SysTools.Terminal (stderrSupportsAnsiColors) where
import GhcPrelude
#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
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)
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