1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
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
|
