ansi-terminal 0.8.0.4 → 0.8.1

raw patch · 8 files changed

+148/−41 lines, 8 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• ansi-terminal.cabal +3/−3
• src/System/Console/ANSI/Unix.hs +7/−1
• src/System/Console/ANSI/Windows.hs +4/−0
• src/System/Console/ANSI/Windows/Detect.hs +70/−31
• src/System/Console/ANSI/Windows/Emulator.hs +23/−4
• src/includes/Common-Include.hs +32/−2
• src/includes/Exports-Include.hs +1/−0

@@ -1,11 +1,19 @@ Changes
 =======
 
+Version 0.8.1
+-------------
+
+* Add `hSupportsANSIWithoutEmulation`. On Windows 10, if the handle is identifed
+  as connected to a native terminal ('Command Prompt' or 'PowerShell'), the
+  processing of 'ANSI' control characters will be enabled.
+
 Version 0.8.0.4
 ---------------
 
 * On Windows, `hSupportsANSI` now recognises if the handle is connected to a
   'mintty' terminal.
+* Drop support for GHC versions before GHC 7.0.1 (released November 2010)
 
 Version 0.8.0.3
 ---------------

@@ -1,5 +1,5 @@ Name:                ansi-terminal
-Version:             0.8.0.4
+Version:             0.8.1
 Cabal-Version:       >= 1.8
 Category:            User Interfaces
 Synopsis:            Simple ANSI terminal support, with Windows compatibility
@@ -36,7 +36,7 @@ 
         Include-Dirs:           src/includes
 
-        Build-Depends:          base >= 4.2.0.0 && < 5
+        Build-Depends:          base >= 4.3.0.0 && < 5
                               , colour
         if os(windows)
                 Build-Depends:          containers >= 0.5.0.0
@@ -64,7 +64,7 @@ Executable ansi-terminal-example
         Hs-Source-Dirs:         app
         Main-Is:                Example.hs
-        Build-Depends:          base >= 4.2.0.0 && < 5
+        Build-Depends:          base >= 4.3.0.0 && < 5
                               , ansi-terminal
         Ghc-Options:            -Wall
         if !flag(example)

@@ -11,7 +11,8 @@ import Control.Exception.Base (bracket)
 import System.Environment (getEnvironment)
 import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho,
-  hIsTerminalDevice, hPutStr, hSetBuffering, hSetEcho, stdin, stdout)
+  hIsTerminalDevice, hIsWritable, hPutStr, hSetBuffering, hSetEcho, stdin,
+  stdout)
 import Text.ParserCombinators.ReadP (readP_to_S)
 
 import System.Console.ANSI.Codes
@@ -71,6 +72,11 @@  where
   -- cannot use lookupEnv since it only appeared in GHC 7.6
   isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment
+
+-- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool)
+-- (See Common-Include.hs for Haddock documentation)
+hSupportsANSIWithoutEmulation h =
+  Just <$> ((&&) <$> hIsWritable h <*> hSupportsANSI h)
 
 -- getReportedCursorPosition :: IO String
 -- (See Common-Include.hs for Haddock documentation)

@@ -182,6 +182,10 @@ -- (See Common-Include.hs for Haddock documentation)
 hSupportsANSI = E.hSupportsANSI
 
+-- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool)
+-- (See Common-Include.hs for Haddock documentation)
+hSupportsANSIWithoutEmulation = E.hSupportsANSIWithoutEmulation
+
 -- getReportedCursorPosition :: IO String
 -- (See Common-Include.hs for Haddock documentation)
 getReportedCursorPosition = E.getReportedCursorPosition

@@ -5,11 +5,17 @@     ANSISupport (..)
   , ConsoleDefaultState (..)
   , aNSISupport
+  , detectHandleSupportsANSI
   ) where
 
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative ((<$>))
+#endif
+
 import Control.Exception (SomeException(..), throwIO, try)
 import Data.Bits ((.&.), (.|.))
-import System.IO (stdout)
+import System.Console.MinTTY (isMinTTYHandle)
+import System.IO (Handle, hIsWritable, stdout)
 import System.IO.Unsafe (unsafePerformIO)
 
 import System.Console.ANSI.Windows.Foreign (ConsoleException(..),
@@ -31,44 +37,77 @@                                  -- the console when that status was determined)
   deriving (Eq, Show)
 
+-- | Terminals on Windows
+data Terminal
+  = NativeANSIEnabled    -- ^ Windows 10 (Command Prompt or PowerShell)
+  | NativeANSIIncapable  -- ^ Versions before Windows 10 (Command Prompt or
+                         -- PowerShell)
+  | Mintty               -- ^ ANSI-enabled
+  | UnknownTerminal
+
 -- | This function assumes that once it is first established whether or not the
 -- Windows console requires emulation, that will not change. If the console
 -- requires emulation, the state of the console is considered to be its default
 -- state.
 {-# NOINLINE aNSISupport #-}
 aNSISupport :: ANSISupport
-aNSISupport = unsafePerformIO $ withHandleToHANDLE stdout aNSISupport'
-
--- | This function first checks if the Windows handle is valid and throws an
--- exception if it is not. It then tries to get a ConHost console mode for
--- that handle. If it can not, it assumes that the handle is ANSI-enabled. If
--- virtual termimal (VT) processing is already enabled, the handle does not
--- require emulation. Otherwise, it trys to enable processing. If it can, the
--- handle is ANSI-enabled. If it can not, emulation will be attempted and the
--- state of the console is considered to be its default state.
-aNSISupport' :: HANDLE -> IO ANSISupport
-aNSISupport' h =
-  if h == iNVALID_HANDLE_VALUE || h == nullHANDLE
-    then throwIO $ ConsoleException 6  -- Invalid handle or no handle
-    else do
-      tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD)
-      case tryMode of
-        Left _     -> return Native  -- No ConHost mode
-        Right mode -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
-          then return Native  -- VT processing already enabled
-          else do
-            let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
-            trySetMode <- try (setConsoleMode h mode') :: IO (Either SomeException ())
-            case trySetMode of
-              Left _   -> emulated       -- Can't enable VT processing
-              Right () -> return Native  -- VT processing enabled
+aNSISupport = unsafePerformIO $ withHandleToHANDLE stdout $ withHANDLE
+  (throwIO $ ConsoleException 6)  -- Invalid handle or no handle
+  (\h -> do
+    terminal <- handleToTerminal h
+    case terminal of
+      NativeANSIIncapable -> Emulated <$> consoleDefaultState h
+      _                   -> return Native)
  where
-  emulated = do
+  consoleDefaultState h = do
     info <- getConsoleScreenBufferInfo h
     let attributes = csbi_attributes info
         fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE
         bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE
-        consoleDefaultState = ConsoleDefaultState
-          { defaultForegroundAttributes = fgAttributes
-          , defaultBackgroundAttributes = bgAttributes }
-    return $ Emulated consoleDefaultState
+    return ConsoleDefaultState
+      { defaultForegroundAttributes = fgAttributes
+      , defaultBackgroundAttributes = bgAttributes }
+
+-- | This function tests that the handle is writable. If what is attached to the
+-- handle is not recognised as a known terminal, it returns @return Nothing@.
+detectHandleSupportsANSI :: Handle -> IO (Maybe Bool)
+detectHandleSupportsANSI handle = do
+  isWritable <- hIsWritable handle
+  if isWritable
+    then withHandleToHANDLE handle $ withHANDLE
+      (return $ Just False)  -- Invalid handle or no handle
+      (\h -> do
+        terminal <- handleToTerminal h
+        case terminal of
+          NativeANSIIncapable -> return (Just False)
+          UnknownTerminal     -> return Nothing  -- Not sure!
+          _                   -> return (Just True))
+    else return (Just False)  -- Not an output handle
+
+-- | This function assumes that the Windows handle is writable.
+handleToTerminal :: HANDLE -> IO Terminal
+handleToTerminal h = do
+  tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD)
+  case tryMode of
+    Left _     -> do  -- No ConHost mode
+      isMinTTY <- isMinTTYHandle h
+      if isMinTTY
+        then return Mintty  -- 'mintty' terminal emulator
+        else return UnknownTerminal  -- Not sure!
+    Right mode -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
+      then return NativeANSIEnabled  -- VT processing already enabled
+      else do
+        let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
+        trySetMode <- try (setConsoleMode h mode')
+          :: IO (Either SomeException ())
+        case trySetMode of
+          Left _   -> return NativeANSIIncapable  -- Can't enable VT processing
+          Right () -> return NativeANSIEnabled  -- VT processing enabled
+
+-- | 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

@@ -417,14 +417,33 @@ 
 -- hSupportsANSI :: Handle -> IO Bool
 -- (See Common-Include.hs for Haddock documentation)
-hSupportsANSI h = (||) <$> isTDNotDumb <*> isMinTTY
+hSupportsANSI h = (||) <$> isTDNotDumb h <*> isMinTTY
  where
   isMinTTY = withHandleToHANDLE h isMinTTYHandle
+
+-- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool)
+-- (See Common-Include.hs for Haddock documentation)
+hSupportsANSIWithoutEmulation handle = do
+  supportsANSI <- detectHandleSupportsANSI handle  -- Without reference to the
+                                                   -- environment
+  case supportsANSI of
+    Just isSupported -> return (Just isSupported)
+    Nothing -> do  -- Not sure, based on the handle alone
+      notDumb <- isNotDumb  -- Test the environment
+      if notDumb
+        then return Nothing  -- Still not sure!
+        else return (Just False) -- A dumb terminal
+
 -- Borrowed from an HSpec patch by Simon Hengel
 -- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd)
-  isTDNotDumb = (&&) <$> hIsTerminalDevice h <*> isNotDumb
-  -- cannot use lookupEnv since it only appeared in GHC 7.6
-  isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment
+isTDNotDumb :: Handle -> IO Bool
+isTDNotDumb h = (&&) <$> hIsTerminalDevice h <*> isNotDumb
+
+-- Borrowed from an HSpec patch by Simon Hengel
+-- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd)
+isNotDumb :: IO Bool
+-- cannot use lookupEnv since it only appeared in GHC 7.6
+isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment
 
 -- getReportedCursorPosition :: IO String
 -- (See Common-Include.hs for Haddock documentation)

@@ -92,7 +92,8 @@ setTitle = hSetTitle stdout
 
 -- | Use heuristics to determine whether the functions defined in this
--- package will work with a given handle.
+-- package will work with a given handle. This function assumes that the handle
+-- is writable (that is, it manages output - see 'hIsWritable').
 --
 -- For Unix-like operating systems, the current implementation checks
 -- that: (1) the handle is a terminal; and (2) a @TERM@
@@ -105,8 +106,37 @@ -- '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.)
+-- handle to the terminal as a terminal.) On Windows 10, if the handle is
+-- identified as connected to a native terminal, this function does /not/ enable
+-- the processing of \'ANSI\' control characters in output (see
+-- 'hSupportsANSIWithoutEmulation').
 hSupportsANSI :: Handle -> IO Bool
+
+-- | Use heuristics to determine whether a given handle will support \'ANSI\'
+-- control characters in output. (On Windows versions before Windows 10, that
+-- means \'support without emulation\'.)
+--
+-- If the handle is not writable (that is, it cannot manage output - see
+-- 'hIsWritable'), then @return (Just False)@ is returned.
+--
+-- On Unix-like operating systems, with one exception, the function is
+-- consistent with 'hSupportsANSI'. The exception is if the handle is not
+-- writable.
+--
+-- On Windows, what is returned will depend on what the handle is connected to
+-- and the version of the operating system. If the handle is identified as
+-- connected to a \'mintty\' terminal, @return (Just True)@ is
+-- returned. If it is identifed as connected to a native terminal, then, on
+-- Windows 10, the processing of \'ANSI\' control characters will be enabled and
+-- @return (Just True)@ returned; and, on versions of Windows before Windows 10,
+-- @return (Just False)@ is returned. Otherwise, if a @TERM@ environment
+-- variable is set to @dumb@, @return (Just False)@ is returned. In all other
+-- cases of a writable handle, @return Nothing@ is returned; this indicates that
+-- the heuristics cannot assist - the handle may be connected to a file or
+-- to another type of terminal.
+--
+-- @since 0.8.1
+hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool)
 
 -- | Parses the characters emitted by 'reportCursorPosition' into the console
 -- input stream. Returns the cursor row and column as a tuple.

@@ -107,6 +107,7 @@ 
     -- * Checking if handle supports ANSI (not portable: GHC only)
   , hSupportsANSI
+  , hSupportsANSIWithoutEmulation
 
     -- * Getting the cursor position
   , getCursorPosition