Fix #120 Add reportLayerColor, getReportedLayerColor, getLayerColor

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

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/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
 
@@ -186,6 +189,25 @@ restoreCursorCode = "\ESC8"
 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 'System.Console.ANSI.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

src/System/Console/ANSI/Windows/Emulator.hs

@@ -18,14 +18,14 @@ import qualified Data.Map.Strict as Map (Map, empty, insert, lookup)
 import System.IO (Handle, hIsTerminalDevice, hPutStr, stdin)
 import System.IO.Unsafe (unsafePerformIO)
 import Text.ParserCombinators.ReadP (readP_to_S)
+import Text.Printf(printf)
 
 import Data.Colour (Colour)
 import Data.Colour.Names (black, blue, cyan, green, grey, lime, magenta, maroon,
   navy, olive, purple, red, silver, teal, white, yellow)
-import Data.Colour.SRGB (RGB (..), toSRGB)
+import Data.Colour.SRGB (toSRGB)
 import System.Console.MinTTY (isMinTTYHandle)
 
-import System.Console.ANSI.Types
 import qualified System.Console.ANSI.Unix as Unix
 import System.Console.ANSI.Windows.Detect
 import System.Console.ANSI.Windows.Emulator.Codes
@@ -390,6 +390,45 @@ hReportCursorPosition h
             "\ESC[" ++ show y ++ ";" ++ show x ++ "R"
         return ()
 
+hReportLayerColor h layer
+  = emulatorFallback (Unix.hReportLayerColor h layer) $ withHandle h $
+      \handle -> do
+        result <- getConsoleScreenBufferInfoEx handle
+        let attributes = csbix_attributes result
+            ct = csbix_color_table result
+            colorTable = map (\f -> f ct)
+              [ ct_color0
+              , ct_color1
+              , ct_color2
+              , ct_color3
+              , ct_color4
+              , ct_color5
+              , ct_color6
+              , ct_color7
+              , ct_color8
+              , ct_color9
+              , ct_colorA
+              , ct_colorB
+              , ct_colorC
+              , ct_colorD
+              , ct_colorE
+              , ct_colorF
+              ]
+            fgRef = attributes .&. fOREGROUND_INTENSE_WHITE
+            bgRef = shiftR (attributes .&. bACKGROUND_INTENSE_WHITE) 4
+            fgColor = colorTable !! fromIntegral fgRef
+            bgColor = colorTable !! fromIntegral bgRef
+            (oscCode, color) = case layer of
+              Foreground -> ("10", fgColor)
+              Background -> ("11", bgColor)
+            r = shiftL (color .&. 0xFF) 8
+            g = color .&. 0xFF00
+            b = shiftR (color .&. 0xFF0000) 8
+            report = printf "\ESC]%s;rgb:%04x/%04x/%04x\ESC\\" oscCode r g b
+        hIn <- getStdHandle sTD_INPUT_HANDLE
+        _ <- writeConsoleInput hIn $ keyPresses report
+        return ()
+
 keyPress :: Char -> [INPUT_RECORD]
 keyPress c = [keyDown, keyUp]
  where
@@ -463,10 +502,12 @@ isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment
 
 -- getReportedCursorPosition :: IO String
 -- (See Common-Include.hs for Haddock documentation)
-getReportedCursorPosition
-  = CE.catch getReportedCursorPosition' getCPExceptionHandler
+getReportedCursorPosition = getReported
+
+getReported :: IO String
+getReported = CE.catch getReported' getReportedExceptionHandler
  where
-  getReportedCursorPosition' = withHandleToHANDLE stdin action
+  getReported' = withHandleToHANDLE stdin action
    where
     action hdl = do
       n <- getNumberOfConsoleInputEvents hdl
@@ -494,25 +535,40 @@ getReportedCursorPosition
 hGetCursorPosition h = fmap to0base <$> getCursorPosition'
  where
   to0base (row, col) = (row - 1, col - 1)
-  getCursorPosition' = CE.catch getCursorPosition'' getCPExceptionHandler
+  getCursorPosition' =
+    hGetReport h hReportCursorPosition getReportedCursorPosition cursorPosition
+
+hGetReport :: Handle
+           -> (Handle -> IO ())
+           -> IO String -> ReadP a -> IO (Maybe a)
+hGetReport h report get parse =
+  CE.catch getReport getReportedExceptionHandler
    where
-    getCursorPosition'' = do
+    getReport = do
       withHandleToHANDLE stdin flush -- Flush the console input buffer
-      hReportCursorPosition h
+      report h
       hFlush h -- ensure the report cursor position code is sent to the
                -- operating system
-      input <- getReportedCursorPosition
-      case readP_to_S cursorPosition input of
+      input <- get
+      case readP_to_S parse input of
         [] -> return Nothing
-        [((row, col),_)] -> return $ Just (row, col)
+        [(value,_)] -> return $ Just value
         (_:_) -> return Nothing
      where
       flush hdl = do
         n <- getNumberOfConsoleInputEvents hdl
         unless (n == 0) (void $ readConsoleInput hdl n)
 
-getCPExceptionHandler :: IOException -> IO a
-getCPExceptionHandler e = error msg
+
+-- getReportedLayerColor :: ConsoleLayer -> IO String
+--(See Common-Include.hs for Haddock documentation)
+getReportedLayerColor _ = getReported
+
+hGetLayerColor h layer = hGetReport h
+  (`hReportLayerColor` layer) (getReportedLayerColor layer) (layerColor layer)
+
+getReportedExceptionHandler :: IOException -> IO a
+getReportedExceptionHandler e = error msg
  where
   msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " ++
         "console based on the Windows' Console API, such as Command Prompt " ++

src/System/Console/ANSI/Windows/Emulator/Codes.hs

@@ -23,6 +23,9 @@ module System.Console.ANSI.Windows.Emulator.Codes
     -- * Scrolling the screen
   , scrollPageUpCode, scrollPageDownCode
 
+    -- * Reporting background and foreground colors
+  , reportLayerColorCode
+
     -- * Select Graphic Rendition mode: colors and other whizzy stuff
   , setSGRCode
 
@@ -82,6 +85,9 @@ scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by
 scrollPageUpCode _   = ""
 scrollPageDownCode _ = ""
 
+reportLayerColorCode :: ConsoleLayer -> String
+reportLayerColorCode _ = ""
+
 setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the
                     -- current console SGR mode. An empty list of commands is
                     -- equivalent to the list @[Reset]@. Commands are applied