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