Fix #160 Add hNowSupportsANSI

Also, in Windows Terminal and ConHost terminals, `hSupportsANSI` will yield `False` if the the processing of \'ANSI\' control characters in output is not enabled.

Also makes deprecated `hSupportsANSIWithoutEmulation` consistent with `hNowSupportsANSI`.

ansi-terminal/CHANGELOG.md

@@ -1,10 +1,30 @@
 Changes
 =======
 
+Version 1.0.1
+-------------
+
+* On Windows, the processing of \'ANSI\' control characters in output is enabled
+  by default in Windows Terminal but is not enabled by default in ConHost
+  terminals. Additions have been made to allow support of users of ConHost
+  terminals.
+* Add `hNowSupportsANSI`. On Unix, the function is equivalent to
+  `hSupportsANSI`. On Windows, in Windows Terminal and ConHost terminals, the
+  action can try to enable the processing of \'ANSI\' control characters in
+  output.
+* In Windows Terminal and ConHost terminals, `hSupportsANSI` will yield `False`
+  if the the processing of \'ANSI\' control characters in output is not enabled.
+* Deprecated `hSupportsANSIWithoutEmulation` is now consistent with
+  `hNowSupportsANSI`.
+* Improvements to Haddock documentation.
+
 Version 1.0
 -----------
 
-* On Windows, drop support for legacy Windows requiring emulation.
+* On Windows, drop support for legacy Windows requiring emulation. The package
+  assumes Windows Terminal has replaced ConHost terminals on supported versions
+  of Windows. Functions that yield actions no longer enable (re-enable) the
+  processing of \'ANSI\' control characters in output.
 * On Windows, the package no longer depends (directly or indirectly) on the
   `Win32`, `array`,`containers`, `deepseq`, `filepath`, `ghc-boot-th`, `mintty`,
   `pretty` or `template-haskell` packages.

ansi-terminal/ansi-terminal.cabal

@@ -1,6 +1,6 @@
 Cabal-Version:       1.22
 Name:                ansi-terminal
-Version:             1.0
+Version:             1.0.1
 Category:            User Interfaces
 Synopsis:            Simple ANSI terminal support
 Description:         ANSI terminal support for Haskell: allows cursor movement,
@@ -16,6 +16,7 @@ Build-Type:          Simple
 Extra-Source-Files:     CHANGELOG.md
                         README.md
                         win/include/errors.h
+                        win/include/HsWin32.h
                         win/include/winternl_compat.h
 
 Source-repository head
@@ -47,8 +48,11 @@ Library
                                 System.Console.ANSI.Windows.Win32.MinTTY
             Include-Dirs:       win/include
             Includes:           errors.h
+                                HsWin32.h
                                 winternl_compat.h
+            Install-Includes:   HsWin32.h
             C-Sources:          win/c-source/errors.c
+                                win/c-source/HsWin32.c
         else
             Hs-Source-Dirs:     unix
 

ansi-terminal/app/Example.hs

@@ -31,7 +31,13 @@ examples = [ cursorMovementExample
            ]
 
 main :: IO ()
-main = mapM_ (resetScreen >>) examples
+main = do
+  stdoutSupportsANSI <- hNowSupportsANSI stdout
+  if stdoutSupportsANSI
+    then
+      mapM_ (resetScreen >>) examples
+    else
+      putStrLn "Standard output does not support 'ANSI' escape codes."
 
 -- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation
 -- of an erased state is implementation-dependent. There may or may not be a

ansi-terminal/src/System/Console/ANSI.hs

@@ -65,6 +65,17 @@ Windows Terminal, with the objective of replacing most of the Windows Console
 API with the use of control character sequences and retiring the historical
 user-interface role of Windows Console Host (\'ConHost\').
 
+Windows Terminal is supported on Windows 10 version 19041.0 or higher and
+provided with Windows 11. It can be downloaded from the Microsoft Store. Windows
+Terminal can be set as the default terminal application on Windows 10 (from
+the 22H2 update) and is the default application on Windows 11 (from the 22H2
+update).
+
+Despite the above developments, some Windows users may continue to use ConHost.
+ConHost does not enable the processing of \'ANSI\' control characters in output
+by default. See 'hNowSupportsANSI' for a function that can try to enable such
+processing.
+
 Terminal software other than the native software exists for Windows. One example
 is the \'mintty\' terminal emulator for \'Cygwin\', \'MSYS\' or \'MSYS2\', and
 dervied projects, and for \'WSL\' (Windows Subsystem for Linux).
@@ -120,15 +131,21 @@ A simple example is below:
 > module Main where
 >
 > import System.Console.ANSI
+> import System.IO (stdout)
 >
 > -- Set colors and write some text in those colors.
 > main :: IO ()
 > main = do
->   setSGR [SetColor Foreground Vivid Red]
->   setSGR [SetColor Background Vivid Blue]
->   putStrLn "Red-On-Blue"
->   setSGR [Reset]  -- Reset to default colour scheme
->   putStrLn "Default colors."
+>   stdoutSupportsANSI <- hNowSupportsANSI stdout
+>   if stdoutSupportsANSI
+>     then
+>       setSGR [SetColor Foreground Vivid Red]
+>       setSGR [SetColor Background Vivid Blue]
+>       putStrLn "Red-On-Blue"
+>       setSGR [Reset]  -- Reset to default colour scheme
+>       putStrLn "Default colors."
+>     else
+>       putStrLn "Standard output does not support 'ANSI' escape codes."
 
 Another example is below:
 
@@ -139,14 +156,19 @@ Another example is below:
 >
 > main :: IO ()
 > main = do
->   setSGR [SetColor Foreground Dull Blue]
->   putStr "Enter your name: "
->   setSGR [SetColor Foreground Dull Yellow]
->   hFlush stdout  -- flush the output buffer before getLine
->   name <- getLine
->   setSGR [SetColor Foreground Dull Blue]
->   putStrLn $ "Hello, " ++ name ++ "!"
->   setSGR [Reset]  -- reset to default colour scheme
+>   stdoutSupportsANSI <- hNowSupportsANSI stdout
+>   if stdoutSupportsANSI
+>     then
+>       setSGR [SetColor Foreground Dull Blue]
+>       putStr "Enter your name: "
+>       setSGR [SetColor Foreground Dull Yellow]
+>       hFlush stdout  -- flush the output buffer before getLine
+>       name <- getLine
+>       setSGR [SetColor Foreground Dull Blue]
+>       putStrLn $ "Hello, " ++ name ++ "!"
+>       setSGR [Reset]  -- reset to default colour scheme
+>     else
+>       putStrLn "Standard output does not support 'ANSI' escape codes."
 
 For many more examples, see the project's extensive
 <https://github.com/UnkindPartition/ansi-terminal/blob/master/app/Example.hs Example.hs> file.
@@ -317,6 +339,7 @@ module System.Console.ANSI
 
     -- * Checking if handle supports ANSI (not portable: GHC only)
   , hSupportsANSI
+  , hNowSupportsANSI
   , hSupportsANSIColor
 
     -- * Getting the cursor position
@@ -573,29 +596,41 @@ setTitle :: String -- ^ New window title and icon name
          -> IO ()
 setTitle = hSetTitle stdout
 
--- | Use heuristics to determine whether the functions defined in this
--- package will work with a given handle.
+-- | Use heuristics to determine whether the functions defined in this package
+-- will work with a given handle.
 --
 -- If the handle is not writable (that is, it cannot manage output - see
 -- 'hIsWritable'), then @pure False@ is returned.
 --
 -- For Unix-like operating systems, the current implementation checks
--- that: (1) the handle is a terminal; and (2) a @TERM@
--- environment variable is not set to @dumb@ (which is what the GNU Emacs text
--- editor sets for its integrated terminal).
---
--- For Windows, the current implementation performs the same checks as for
--- Unix-like operating systems and, as an alternative, checks whether the
--- handle is connected to a \'mintty\' terminal. (That is because the function
--- 'hIsTerminalDevice' is used to check if the handle is a
--- terminal. However, where a non-native Windows terminal (such as \'mintty\')
--- is implemented using redirection, that function will not identify a
--- handle to the terminal as a terminal.)
+-- that: (1) the handle is a terminal; and (2) a @TERM@ environment variable is
+-- not set to @dumb@ (which is what the GNU Emacs text editor sets for its
+-- integrated terminal).
+--
+-- For Windows, the current implementation checks: first that (1) the handle is
+-- a terminal, (2) a @TERM@ environment variable is not set to @dumb@, and (3)
+-- the processing of \'ANSI\' control characters in output is enabled; and
+-- second, as an alternative, whether the handle is connected to a \'mintty\'
+-- terminal. (That is because the function 'hIsTerminalDevice' is used to check
+-- if the handle is a terminal. However, where a non-native Windows terminal
+-- (such as \'mintty\') is implemented using redirection, that function will not
+-- identify a handle to the terminal as a terminal.) If it is not already
+-- enabled, this function does *not* enable the processing of \'ANSI\' control
+-- characters in output (see 'hNowSupportsANSI').
 --
 -- @since 0.6.2
 hSupportsANSI :: Handle -> IO Bool
 hSupportsANSI = Internal.hSupportsANSI
 
+-- | With one exception, equivalent to 'hSupportsANSI'. The exception is that,
+-- on Windows only, if a @TERM@ environment variable is not set to @dumb@ and
+-- the processing of \'ANSI\' control characters in output is not enabled, this
+-- function first tries to enable such processing.
+--
+-- @Since 1.0.1
+hNowSupportsANSI :: Handle -> IO Bool
+hNowSupportsANSI = Internal.hNowSupportsANSI
+
 -- | Some terminals (e.g. Emacs) are not fully ANSI compliant but can support
 -- ANSI colors. This can be used in such cases, if colors are all that is
 -- needed.
@@ -610,15 +645,15 @@ hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm
 
 -- | Use heuristics to determine whether a given handle will support \'ANSI\'
 -- control characters in output. The function is consistent with
--- 'hSupportsANSI'.
+-- 'hNowSupportsANSI'.
 --
 -- This function is deprecated as, from version 1.0, the package no longer
 -- supports legacy versions of Windows that required emulation.
 --
 -- @since 0.8.1
-{-# DEPRECATED hSupportsANSIWithoutEmulation "See Haddock documentation and hSupportsANSI." #-}
+{-# DEPRECATED hSupportsANSIWithoutEmulation "See Haddock documentation and hNowSupportsANSI." #-}
 hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool)
-hSupportsANSIWithoutEmulation h = Just <$> hSupportsANSI h
+hSupportsANSIWithoutEmulation h = Just <$> hNowSupportsANSI h
 
 -- | Parses the characters emitted by 'reportCursorPosition' into the console
 -- input stream. Returns the cursor row and column as a tuple.

ansi-terminal/unix/System/Console/ANSI/Internal.hs

@@ -4,6 +4,7 @@ module System.Console.ANSI.Internal
   ( getReportedCursorPosition
   , getReportedLayerColor
   , hSupportsANSI
+  , hNowSupportsANSI
   ) where
 
 import Data.List ( uncons )
@@ -73,3 +74,6 @@ hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI'
  where
   hSupportsANSI' = (&&) <$> hIsTerminalDevice h <*> isNotDumb
   isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM"
+
+hNowSupportsANSI :: Handle -> IO Bool
+hNowSupportsANSI = hSupportsANSI

ansi-terminal/win/System/Console/ANSI/Internal.hs

@@ -3,10 +3,12 @@
 module System.Console.ANSI.Internal
   ( getReportedCursorPosition
   , getReportedLayerColor
+  , hNowSupportsANSI
   , hSupportsANSI
   ) where
 
-import Control.Exception ( IOException, catch )
+import Control.Exception ( IOException, SomeException, catch, try )
+import Data.Bits ( (.&.), (.|.) )
 import Data.Maybe ( mapMaybe )
 import System.Environment ( lookupEnv )
 import System.IO ( Handle, hIsTerminalDevice, hIsWritable, stdin )
@@ -15,12 +17,13 @@ import System.Console.ANSI.Types ( ConsoleLayer )
 -- Provided by the ansi-terminal package
 import System.Console.ANSI.Windows.Foreign
          ( INPUT_RECORD (..), INPUT_RECORD_EVENT (..), KEY_EVENT_RECORD (..)
-         , cWcharsToChars, getNumberOfConsoleInputEvents, readConsoleInput
-         , unicodeAsciiChar
+         , cWcharsToChars, eNABLE_VIRTUAL_TERMINAL_PROCESSING
+         , getConsoleMode, getNumberOfConsoleInputEvents, iNVALID_HANDLE_VALUE
+         , nullHANDLE, readConsoleInput, setConsoleMode, unicodeAsciiChar
          )
 import System.Console.ANSI.Windows.Win32.MinTTY ( isMinTTYHandle )
-import System.Console.ANSI.Windows.Win32.Types ( withHandleToHANDLE )
-
+import System.Console.ANSI.Windows.Win32.Types
+         ( DWORD, HANDLE, withHandleToHANDLE )
 
 getReportedCursorPosition :: IO String
 getReportedCursorPosition = getReported
@@ -62,11 +65,41 @@ getReportedExceptionHandler e = error msg
         "or PowerShell."
 
 hSupportsANSI :: Handle -> IO Bool
-hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI'
- where
-  hSupportsANSI' = (||) <$> isTDNotDumb <*> isMinTTY
-  -- Borrowed from an HSpec patch by Simon Hengel
-  -- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd)
-  isTDNotDumb = (&&) <$> hIsTerminalDevice h <*> isNotDumb
-  isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM"
-  isMinTTY = withHandleToHANDLE h isMinTTYHandle
+hSupportsANSI = hSupportsANSI' False
+
+hNowSupportsANSI :: Handle -> IO Bool
+hNowSupportsANSI = hSupportsANSI' True
+
+hSupportsANSI' :: Bool -> Handle -> IO Bool
+hSupportsANSI' tryToEnable handle = do
+  isWritable <- hIsWritable handle
+  if isWritable
+    then withHandleToHANDLE handle $ withHANDLE
+      (pure False) -- Invalid handle or no handle
+      ( \h -> do
+          tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD)
+          case tryMode of
+            Left _ -> isMinTTYHandle h -- No ConHost mode
+            Right mode -> do
+              let isVTEnabled = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
+                  isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM"
+              isTDNotDumb <- (&&) <$> hIsTerminalDevice handle <*> isNotDumb
+              if isTDNotDumb && not isVTEnabled && tryToEnable
+                then do
+                  let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
+                  trySetMode <- try (setConsoleMode h mode')
+                    :: IO (Either SomeException ())
+                  case trySetMode of
+                    Left _ -> pure False -- Can't enable VT processing
+                    Right () -> pure True -- VT processing enabled
+                else pure $ isTDNotDumb && isVTEnabled
+      )
+    else pure False
+
+-- | This function applies another to the Windows handle, if the handle is
+-- valid. If it is invalid, the specified default action is returned.
+withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a
+withHANDLE invalid action h =
+  if h == iNVALID_HANDLE_VALUE || h == nullHANDLE
+    then invalid  -- Invalid handle or no handle
+    else action h

ansi-terminal/win/System/Console/ANSI/Windows/Foreign.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE RankNTypes         #-}
-{-# LANGUAGE Safe               #-}
+{-# LANGUAGE Trustworthy        #-}
 
 module System.Console.ANSI.Windows.Foreign
   (
@@ -11,6 +11,11 @@ module System.Console.ANSI.Windows.Foreign
   , readConsoleInput
   , cWcharsToChars
   , unicodeAsciiChar
+  , eNABLE_VIRTUAL_TERMINAL_PROCESSING
+  , iNVALID_HANDLE_VALUE
+  , nullHANDLE
+  , getConsoleMode
+  , setConsoleMode
   ) where
 
 import Control.Exception ( Exception )
@@ -20,11 +25,11 @@ import Data.Word ( Word32 )
 import Foreign.C.Types ( CWchar (..) )
 import Foreign.Marshal.Alloc ( alloca )
 import Foreign.Marshal.Array ( allocaArray, peekArray, pokeArray )
-import Foreign.Ptr ( Ptr, castPtr, plusPtr )
+import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )
 import Foreign.Storable ( Storable (..) )
 import System.Console.ANSI.Windows.Win32.Types
-         ( BOOL, DWORD, ErrCode, HANDLE, LPDWORD, SHORT, UINT, ULONG, WCHAR
-         , WORD, failIfFalse_
+         ( BOOL, DWORD, ErrCode, HANDLE, LPDWORD, SHORT, UINT, UINT_PTR, ULONG
+         , WCHAR, WORD, failIfFalse_
          )
 
 peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b)
@@ -461,3 +466,29 @@ cWcharsToChars = map chr . fromUTF16 . map fromIntegral
       ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
   fromUTF16 (c:wcs) = c : fromUTF16 wcs
   fromUTF16 [] = []
+
+eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD
+eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4
+
+iNVALID_HANDLE_VALUE :: HANDLE
+iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound
+
+nullHANDLE :: HANDLE
+nullHANDLE = nullPtr
+
+foreign import ccall unsafe "HsWin32.h"
+  castUINTPtrToPtr :: UINT_PTR -> Ptr a
+
+foreign import ccall unsafe "windows.h GetConsoleMode"
+  c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL
+
+foreign import ccall unsafe "windows.h SetConsoleMode"
+  c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL
+
+getConsoleMode :: HANDLE -> IO DWORD
+getConsoleMode h = alloca $ \ptr -> do
+  failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr
+  peek ptr
+
+setConsoleMode :: HANDLE -> DWORD -> IO ()
+setConsoleMode h mode = failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h mode