1{-# LANGUAGE Trustworthy #-} 2{-# OPTIONS_HADDOCK hide #-} 3 4module System.Console.ANSI.Windows.Detect 5 ( 6 ANSISupport (..) 7 , ConsoleDefaultState (..) 8 , aNSISupport 9 , detectHandleSupportsANSI 10 ) where 11 12#if !MIN_VERSION_base(4,8,0) 13import Control.Applicative ((<$>)) 14#endif 15 16import Control.Exception (SomeException(..), throwIO, try) 17import Data.Bits ((.&.), (.|.)) 18import System.Console.MinTTY (isMinTTYHandle) 19import System.IO (Handle, hIsWritable, stdout) 20import System.IO.Unsafe (unsafePerformIO) 21 22import System.Console.ANSI.Windows.Foreign (ConsoleException(..), 23 CONSOLE_SCREEN_BUFFER_INFO (..), DWORD, HANDLE, WORD, 24 bACKGROUND_INTENSE_WHITE, eNABLE_VIRTUAL_TERMINAL_PROCESSING, 25 fOREGROUND_INTENSE_WHITE, getConsoleMode, getConsoleScreenBufferInfo, 26 iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, withHandleToHANDLE) 27 28-- | The default state of the console. 29data ConsoleDefaultState = ConsoleDefaultState 30 { defaultForegroundAttributes :: WORD -- ^ Foreground attributes 31 , defaultBackgroundAttributes :: WORD -- ^ Background attributes 32 } deriving (Eq, Show) 33 34-- | How the console is assumed to support ANSI control codes. 35data ANSISupport 36 = Native -- ^ Assume ANSI-enabled 37 | Emulated ConsoleDefaultState -- ^ Not ANSI-enabled (including the state of 38 -- the console when that status was determined) 39 deriving (Eq, Show) 40 41-- | Terminals on Windows 42data Terminal 43 = NativeANSIEnabled -- ^ Windows 10 (Command Prompt or PowerShell) 44 | NativeANSIIncapable -- ^ Versions before Windows 10 (Command Prompt or 45 -- PowerShell) 46 | Mintty -- ^ ANSI-enabled 47 | UnknownTerminal 48 49-- | This function assumes that once it is first established whether or not the 50-- Windows console requires emulation, that will not change. If the console 51-- requires emulation, the state of the console is considered to be its default 52-- state. 53{-# NOINLINE aNSISupport #-} 54aNSISupport :: ANSISupport 55aNSISupport = unsafePerformIO $ withHandleToHANDLE stdout $ withHANDLE 56 (throwIO $ ConsoleException 6) -- Invalid handle or no handle 57 (\h -> do 58 terminal <- handleToTerminal h 59 case terminal of 60 NativeANSIIncapable -> Emulated <$> consoleDefaultState h 61 _ -> return Native) 62 where 63 consoleDefaultState h = do 64 info <- getConsoleScreenBufferInfo h 65 let attributes = csbi_attributes info 66 fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE 67 bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE 68 return ConsoleDefaultState 69 { defaultForegroundAttributes = fgAttributes 70 , defaultBackgroundAttributes = bgAttributes } 71 72-- | This function tests that the handle is writable. If what is attached to the 73-- handle is not recognised as a known terminal, it returns @return Nothing@. 74detectHandleSupportsANSI :: Handle -> IO (Maybe Bool) 75detectHandleSupportsANSI handle = do 76 isWritable <- hIsWritable handle 77 if isWritable 78 then withHandleToHANDLE handle $ withHANDLE 79 (return $ Just False) -- Invalid handle or no handle 80 (\h -> do 81 terminal <- handleToTerminal h 82 case terminal of 83 NativeANSIIncapable -> return (Just False) 84 UnknownTerminal -> return Nothing -- Not sure! 85 _ -> return (Just True)) 86 else return (Just False) -- Not an output handle 87 88-- | This function assumes that the Windows handle is writable. 89handleToTerminal :: HANDLE -> IO Terminal 90handleToTerminal h = do 91 tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD) 92 case tryMode of 93 Left _ -> do -- No ConHost mode 94 isMinTTY <- isMinTTYHandle h 95 if isMinTTY 96 then return Mintty -- 'mintty' terminal emulator 97 else return UnknownTerminal -- Not sure! 98 Right mode -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 99 then return NativeANSIEnabled -- VT processing already enabled 100 else do 101 let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING 102 trySetMode <- try (setConsoleMode h mode') 103 :: IO (Either SomeException ()) 104 case trySetMode of 105 Left _ -> return NativeANSIIncapable -- Can't enable VT processing 106 Right () -> return NativeANSIEnabled -- VT processing enabled 107 108-- | This function applies another to the Windows handle, if the handle is 109-- valid. If it is invalid, the specified default action is returned. 110withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a 111withHANDLE invalid action h = 112 if h == iNVALID_HANDLE_VALUE || h == nullHANDLE 113 then invalid -- Invalid handle or no handle 114 else action h 115