Fix UnkindPartition#120 Add reportLayerColor, getReportedLayerColor, …

…getLayerColor

Also adds `hReportLayerColor`, `hGetLayerColor` and `layerColor`.

Also updates and reorganises some Haddock documentation for developments in Windows.

On Windows, emulated using the Windows Console API but the emulation of `reportLayerColor` works only on the native ConHost terminal and not on Windows Terminal. Non-native terminals cannot make use of `getReportedLayerColor`.

app/Example.hs

@@ -26,6 +26,7 @@ examples = [ cursorMovementExample
            , titleExample
            , getCursorPositionExample
            , getTerminalSizeExample
+           , getLayerColorExample
            ]
 
 main :: IO ()
@@ -427,3 +428,16 @@ getTerminalSizeExample = do
     Nothing -> putStrLn "Error: unable to get the terminal size\n"
   pause
   -- The size of the terminal is 25 rows by 80 columns.
+
+getLayerColorExample :: IO ()
+getLayerColorExample = do
+  fgResult <- getLayerColor Foreground
+  case fgResult of
+    Just fgCol -> putStrLn $ "The reported foreground color is:\n" ++
+      show fgCol ++ "\n"
+    Nothing -> putStrLn "Error: unable to get the foreground color\n"
+  bgResult <- getLayerColor Background
+  case bgResult of
+    Just bgCol -> putStrLn $ "The reported background color is:\n" ++
+      show bgCol ++ "\n"
+    Nothing -> putStrLn "Error: unable to get the background color\n"

src/System/Console/ANSI.hs

@@ -1,9 +1,10 @@
 #include "Common-Safe-Haskell.hs"
 
-{-| Through this module, this library provides platform-independent support for
+{-| == Introduction
+Through this module, this library provides platform-independent support for
 control character sequences following the \'ANSI\' standards (see further below)
 for terminal software that supports those sequences, running on a Unix-like
-operating system or Windows.
+operating system or Windows (see further below).
 
 The sequences of control characters (also referred to as \'escape\' sequences or
 codes) provide a rich range of functionality for terminal control, which
@@ -29,23 +30,7 @@ A terminal that supports control character sequences acts on them when they
 are flushed from the output buffer (with a newline character @\"\\n\"@ or, for
 the standard output channel, @hFlush stdout@).
 
-The functions moving the cursor to an absolute position are 0-based (the
-top-left corner is considered to be at row 0 column 0) (see 'setCursorPosition')
-and so is 'getCursorPosition'. The \'ANSI\' standards themselves are 1-based
-(that is, the top-left corner is considered to be at row 1 column 1) and some
-functions reporting the position of the cursor are too (see
-'reportCursorPosition').
-
-The native terminal software on Windows is \'Command Prompt\' or \`PowerShell\`.
-Before Windows 10 version 1511 (known as the \'November [2015] Update\' or
-\'Threshold 2\') that software did not support such control sequences. For that
-software, this library also provides support for such sequences by using
-emulation.
-
-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).
-
+== \'ANSI\' standards
 The \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for
 Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T
 Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information
@@ -59,35 +44,73 @@ current versions of Windows at
 
 The whole of the \'ANSI\' standards are not supported by this library but most
 (if not all) of the parts that are popular and well-supported by terminal
-software are supported. Every function exported by this module comes in three
-variants, namely:
+software are supported (see further below).
+
+== Cursor positions
+The functions moving the cursor to an absolute position are 0-based (the
+top-left corner is considered to be at row 0 column 0) (see 'setCursorPosition')
+and so is 'getCursorPosition'. The \'ANSI\' standards themselves are 1-based
+(that is, the top-left corner is considered to be at row 1 column 1) and some
+functions reporting the position of the cursor are too (see
+'reportCursorPosition').
+
+== Windows and control character sequences
+The native terminal software on Windows has developed over time. Before
+Windows 10 version 1511 (known as the \'November [2015] Update\' or
+\'Threshold 2\') that software did not support control character sequences. For
+that software, this library also provides support for such sequences by using
+emulation based on the Windows Console API. From 2018, Microsoft introduced the
+Windows Pseudo Console (\'ConPTY\') API and then 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\').
+
+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).
+
+Some control sequences emit data into the console input stream. For GHC's
+historical and default IO manager, the function 'hGetBufNonBlocking' in module
+"System.IO" does not work on Windows. This has been attributed to the lack of
+non-blocking primatives in the operating system (see the GHC bug report #806 at
+<https://ghc.haskell.org/trac/ghc/ticket/806>). GHC's native IO manager on
+Windows (\'WinIO\'), introduced in GHC 9.0.1, has not yet provided a solution.
+On Windows, this library uses emulation based on the Windows Console API to try
+to read data emitted into the console input stream.
+
+== Function variants provided
+Every function exported by this module comes in three variants, namely:
 
  * A variant that has an @IO ()@ type and doesn't take a @Handle@ (for example,
    @clearScreen :: IO ()@). This variant just outputs the \`ANSI\` command
    directly to the standard output channel ('stdout') and any terminal
    corresponding to it. Commands issued like this should work as you expect on
-   both Unix-like operating systems and Windows.
+   both Unix-like operating systems and Windows (unless exceptions on Windows
+   are stated).
 
  * An \'@h@...\' variant that has an @IO ()@ type but takes a @Handle@ (for
    example, @hClearScreen :: Handle -> IO ()@). This variant outputs the
    \`ANSI\` command to the supplied handle and any terminal corresponding to it.
    Commands issued like this should also work as you expect on both Unix-like
-   operating systems and Windows.
+   operating systems and Windows (unless exceptions on Windows are stated).
 
  * A \'...@Code@\' variant that has a @String@ type (for example,
    @clearScreenCode :: String@). This variant outputs the sequence of control
    characters as a 'String', which can be added to any other bit of text before
-   being output. The use of these codes is generally discouraged because they
-   will not work on legacy versions of Windows where the terminal in use is not
-   ANSI-enabled (see further above). On Windows, where emulation has been
-   necessary, these variants will always output the empty string. That is done
-   so that it is possible to use them portably; for example, coloring console
-   output on the understanding that you will see colors only if you are running
-   on a Unix-like operating system or a version of Windows where emulation has
-   not been necessary. If the control characters are always required, see module
+   being output. If a high degree of backwards compatability is rewuired, the
+   use of these codes is discouraged because they will not work on legacy
+   versions of Windows where the terminal in use is not ANSI-enabled (see
+   further above). On Windows, where emulation has been necessary, these
+   variants will always output the empty string. That is done so that it is
+   possible to use them portably; for example, coloring console output on the
+   understanding that you will see colors only if you are running on a Unix-like
+   operating system or a version of Windows where emulation has not been
+   necessary. If the control characters are always required, see module
    "System.Console.ANSI.Codes".
 
-Example:
+== Examples of use
+
+A simple example is below:
 
 > module Main where
 >
@@ -102,7 +125,7 @@ Example:
 >   setSGR [Reset]  -- Reset to default colour scheme
 >   putStrLn "Default colors."
 
-Another example:
+Another example is below:
 
 > module Main where
 >

src/System/Console/ANSI/Codes.hs

@@ -41,6 +41,9 @@ module System.Console.ANSI.Codes
     -- * Scrolling the screen
   , scrollPageUpCode, scrollPageDownCode
 
+    -- * Reporting background or foreground colors
+  , reportLayerColorCode
+
     -- * Select Graphic Rendition mode: colors and other whizzy stuff
   , setSGRCode
 
@@ -180,16 +183,30 @@ restoreCursorCode = "\ESC8"
 -- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this
 -- function may be of limited use on Windows operating systems because of
 -- difficulties in obtaining the data emitted into the console input stream.
--- The function 'hGetBufNonBlocking' in module "System.IO" does not work on
--- Windows. This has been attributed to the lack of non-blocking primatives in
--- the operating system (see the GHC bug report #806 at
--- <https://ghc.haskell.org/trac/ghc/ticket/806>).
 --
 -- @since 0.7.1
 reportCursorPositionCode :: String
-
 reportCursorPositionCode = csi [] "6n"
 
+-- | Code to emit the layer color into the console input stream, immediately
+-- after being recognised on the output stream, as:
+-- @ESC ] \<Ps> ; rgb: \<red> ; \<green> ; \<blue> \<ST>@
+-- where @\<Ps>@ is @10@ for 'Foreground' and @11@ for 'Background'; @\<red>@,
+-- @\<green>@ and @\<blue>@ are the color channel values in hexadecimal (4, 8,
+-- 12 and 16 bit values are possible, although 16 bit values are most common);
+-- and @\<ST>@ is the STRING TERMINATOR (ST). ST depends on the terminal
+-- software and may be the @BEL@ character or @ESC \\@ characters.
+--
+-- This function may be of limited, or no, use on Windows operating systems
+-- because (1) the control character sequence is not supported on native
+-- terminals (2) of difficulties in obtaining the data emitted into the
+-- console input stream. See 'getReportedLayerColor'.
+--
+-- @since 0.11.4
+reportLayerColorCode :: ConsoleLayer -> String
+reportLayerColorCode Foreground = osc "10" "?"
+reportLayerColorCode Background = osc "11" "?"
+
 clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,
   clearScreenCode :: String
 clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,

src/System/Console/ANSI/Unix.hs

@@ -22,7 +22,6 @@ import System.Timeout (timeout)
 import Text.ParserCombinators.ReadP (readP_to_S)
 
 import System.Console.ANSI.Codes
-import System.Console.ANSI.Types
 
 -- This file contains code that is common to modules System.Console.ANSI.Unix,
 -- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as
@@ -62,6 +61,8 @@ hClearLine h = hPutStr h clearLineCode
 hScrollPageUp h n = hPutStr h $ scrollPageUpCode n
 hScrollPageDown h n = hPutStr h $ scrollPageDownCode n
 
+hReportLayerColor h layer = hPutStr h $ reportLayerColorCode layer
+
 hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs
 
 hHideCursor h = hPutStr h hideCursorCode
@@ -91,6 +92,15 @@ hSupportsANSIWithoutEmulation h =
 -- (See Common-Include.hs for Haddock documentation)
 getReportedCursorPosition = getReport "\ESC[" ["R"]
 
+-- getReportedLayerColor :: ConsoleLayer -> IO String
+-- (See Common-Include.hs for Haddock documentation)
+getReportedLayerColor layer =
+  getReport ("\ESC]" ++ pS ++ ";rgb:") ["\BEL", "\ESC\\"]
+ where
+   pS = case layer of
+          Foreground -> "10"
+          Background -> "11"
+
 getReport :: String -> [String] -> IO String
 getReport _ [] = error "getReport requires a list of terminating sequences."
 getReport startChars endChars = do
@@ -166,3 +176,30 @@ hGetCursorPosition h = fmap to0base <$> getCursorPosition'
     when isReady $ do
       _ <-getChar
       clearStdin
+
+-- hGetLayerColor :: Handle -> IO (Maybe (Colour Word16))
+-- (See Common-Include.hs for Haddock documentation)
+hGetLayerColor h layer = do
+  input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do
+    -- set no buffering (if 'no buffering' is not already set, the contents of
+    -- the buffer will be discarded, so this needs to be done before the
+    -- cursor positon is emitted)
+    hSetBuffering stdin NoBuffering
+    -- ensure that echoing is off
+    bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
+      hSetEcho stdin False
+      clearStdin
+      hReportLayerColor h layer
+      hFlush h -- ensure the report cursor position code is sent to the
+               -- operating system
+      getReportedLayerColor layer
+  case readP_to_S (layerColor layer) input of
+      [] -> return Nothing
+      [(col, _)] -> return $ Just col
+      (_:_) -> return Nothing
+ where
+  clearStdin = do
+    isReady <- hReady stdin
+    when isReady $ do
+      _ <-getChar
+      clearStdin

src/System/Console/ANSI/Windows.hs

@@ -11,7 +11,6 @@ module System.Console.ANSI.Windows
 
 import System.IO (Handle)
 
-import System.Console.ANSI.Types
 import qualified System.Console.ANSI.Unix as U
 import System.Console.ANSI.Windows.Detect (ANSISupport (..),
   ConsoleDefaultState (..), aNSISupport)
@@ -145,6 +144,13 @@ scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode
 scrollPageDownCode :: Int -> String
 scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode
 
+-- * Reporting the background or foreground colors
+hReportLayerColor = E.hReportLayerColor
+
+reportLayerColorCode :: ConsoleLayer -> String
+reportLayerColorCode = nativeOrEmulated
+  U.reportLayerColorCode E.reportLayerColorCode
+
 -- * Select Graphic Rendition mode: colors and other whizzy stuff
 --
 -- The following SGR codes are NOT implemented by Windows 10 Threshold 2:
@@ -220,3 +226,11 @@ getReportedCursorPosition = E.getReportedCursorPosition
 -- hGetCursorPosition :: Handle -> IO (Maybe (Int, Int))
 -- (See Common-Include.hs for Haddock documentation)
 hGetCursorPosition = E.hGetCursorPosition
+
+-- getReportedLayerColor :: ConsoleLayer -> IO String
+-- (See Common-Include.hs for Haddock documentation)
+getReportedLayerColor = E.getReportedLayerColor
+
+-- hGetLayerColor :: ConsoleLayer -> IO (Maybe (RGB Word16))
+-- (See Common-Include.hs for Haddock documentation)
+hGetLayerColor = E.hGetLayerColor