Fix UnkindPartition#120 Add reportLayerColor, getReportedLayerColor

Not supported by terminals on Windows. Native terminals do not allow the color to be reported. Other terminals do not allow the reported color to be read from the console input stream.

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 " ++
+      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 " ++
+      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
 
@@ -187,9 +190,13 @@ restoreCursorCode = "\ESC8"
 --
 -- @since 0.7.1
 reportCursorPositionCode :: String
-
 reportCursorPositionCode = csi [] "6n"
 
+-- @since 0.11.4
+reportLayerColorCode :: ConsoleLayer -> String
+reportLayerColorCode Foreground = osc "10" "?"
+reportLayerColorCode Background = osc "11" "?"
+
 clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,
   clearScreenCode :: String
 clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,
@@ -264,7 +271,8 @@ hyperlinkWithIdCode
 hyperlinkWithIdCode linkId = hyperlinkWithParamsCode [("id", linkId)]
 
 -- | Code to set the terminal window title and the icon name (that is, the text
--- for the window in the Start bar, or similar).
+-- for the window in the Start bar, or similar). Ignores any non-printable
+-- characters in the title.
 
 -- Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the right
 -- direction on xterm title setting on haskell-cafe. The "0" signifies that both

src/System/Console/ANSI/Unix.hs

@@ -59,6 +59,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
@@ -88,6 +90,10 @@ hSupportsANSIWithoutEmulation h =
 -- (See Common-Include.hs for Haddock documentation)
 getReportedCursorPosition = getReport "R"
 
+-- getReportedLayerColor :: ConsoleLayer -> IO String
+-- (See Common-Include.hs for Haddock documentation)
+getReportedLayerColor _ = getReport "\ESC\\"
+
 getReport :: String -> IO String
 getReport [] = error "getReport requires a sequence of terminating characters."
 getReport (e:es) = do
@@ -148,3 +154,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

@@ -145,6 +145,13 @@ scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode
 scrollPageDownCode :: Int -> String
 scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode
 
+-- * Reporting the background or foreground colors
+hReportLayerColor = nativeOrEmulated U.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 +227,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

@@ -22,7 +22,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 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
@@ -390,6 +390,8 @@ hReportCursorPosition h
             "\ESC[" ++ show y ++ ";" ++ show x ++ "R"
         return ()
 
+hReportLayerColor = Unix.hReportLayerColor  -- Not emulated
+
 keyPress :: Char -> [INPUT_RECORD]
 keyPress c = [keyDown, keyUp]
  where
@@ -511,6 +513,12 @@ hGetCursorPosition h = fmap to0base <$> getCursorPosition'
         n <- getNumberOfConsoleInputEvents hdl
         unless (n == 0) (void $ readConsoleInput hdl n)
 
+-- getReportedLayerColor :: ConsoleLayer -> IO String
+--(See Common-Include.hs for Haddock documentation)
+getReportedLayerColor _ = return ""  -- not supported
+
+hGetLayerColor _ _ = return Nothing  -- not supported
+
 getCPExceptionHandler :: IOException -> IO a
 getCPExceptionHandler e = error msg
  where

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

src/includes/Common-Include.hs

@@ -10,10 +10,13 @@ import Data.Functor ((<$>))
 #endif
 
 import Control.Monad (void)
-import Data.Char (isDigit)
+import Data.Char (digitToInt, isDigit, isHexDigit)
+import Data.Word (Word16)
 import System.Environment (getEnvironment)
 import System.IO (hFlush, stdout)
-import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy)
+import Text.ParserCombinators.ReadP (ReadP, char, many1, satisfy, string)
+
+import Data.Colour.SRGB (RGB (..))
 
 hCursorUp, hCursorDown, hCursorForward, hCursorBackward
   :: Handle
@@ -332,6 +335,68 @@ getCursorPosition = hGetCursorPosition stdout
 -- @since 0.10.1
 hGetCursorPosition :: Handle -> IO (Maybe (Int, Int))
 
+-- @since 0.11.4
+reportLayerColor :: ConsoleLayer -> IO ()
+reportLayerColor = hReportLayerColor stdout
+
+-- @since 0.11.4
+hReportLayerColor :: Handle -> ConsoleLayer -> IO ()
+
+-- @since 0.11.4
+getReportedLayerColor :: ConsoleLayer -> IO String
+
+-- @since 0.11.4
+getLayerColor :: ConsoleLayer -> IO (Maybe(RGB Word16))
+getLayerColor = hGetLayerColor stdout
+
+-- @since 0.11.4
+hGetLayerColor :: Handle -> ConsoleLayer -> IO (Maybe (RGB Word16))
+
+-- | Parses the characters emitted by 'reportLayerColor' into the console input
+-- stream.
+--
+-- For example, if the characters emitted by 'reportLayerColor' are in 'String'
+-- @input@ then the parser could be applied like this:
+--
+-- > let result = readP_to_S layerColor input
+-- > case result of
+-- >     [] -> putStrLn $ "Error: could not parse " ++ show input
+-- >     [(col, _)] -> putStrLn $ "The color was " ++ show col ++ "."
+-- >     (_:_) -> putStrLn $ "Error: parse not unique"
+--
+-- @since 0.11.4
+layerColor :: ConsoleLayer -> ReadP (RGB Word16)
+layerColor layer = do
+  void $ string "\ESC]"
+  void $ string $ case layer of
+    Foreground -> "10"
+    Background -> "11"
+  void $ string ";rbg:"
+  redHex <- hexadecimal -- A non-negative whole hexadecimal number
+  void $ char '/'
+  greenHex <- hexadecimal -- A non-negative whole hexadecimal number
+  void $ char '/'
+  blueHex <- hexadecimal -- A non-negative whole hexadecimal number
+  void $ string "\ESC\\"
+  let lenRed = length redHex
+      lenGreen = length greenHex
+      lenBlue = length blueHex
+  if lenRed == lenGreen && lenGreen == lenBlue
+    then
+      if lenRed == 0 || lenRed > 4
+        then fail "Color format not recognised"
+        else
+          let m = 16 ^ (4 - lenRed)
+              r = fromIntegral $ m * hexToInt redHex
+              g = fromIntegral $ m * hexToInt greenHex
+              b = fromIntegral $ m * hexToInt blueHex
+          in  return $ RGB r g b
+    else fail "Color format not recognised"
+ where
+  hexDigit = satisfy isHexDigit
+  hexadecimal = many1 hexDigit
+  hexToInt hex = foldl (\d a -> d * 16 + a) 0 (map digitToInt hex)
+
 -- | Attempts to get the current terminal size (height in rows, width in
 -- columns).
 --

src/includes/Exports-Include.hs

@@ -87,6 +87,11 @@
   , scrollPageUpCode
   , scrollPageDownCode
 
+    -- * Reporting the background or foreground colors
+  , reportLayerColor
+  , hReportLayerColor
+  , reportLayerColorCode
+
     -- * Select Graphic Rendition mode: colors and other whizzy stuff
   , setSGR
   , hSetSGR
@@ -124,6 +129,12 @@
   , hSupportsANSIColor
   , hSupportsANSIWithoutEmulation
 
+    -- * Getting the background or foreground colors
+  , getLayerColor
+  , hGetLayerColor
+  , getReportedLayerColor
+  , layerColor
+
     -- * Getting the cursor position
   , getCursorPosition
   , hGetCursorPosition