Fix UnkindPartition#120 Add reportColor, getReportedColor

Not supported by native terminals on Windows.

Also adds, and applies, utility `osc :: [(String, String)] -> String`, as several functions now use the XTerm OSC control sequences.

This means that `setTitleCode` now ends with the recommended STRING TERMINATOR (ST), rather than legacy `\007`. The filter in `setTitleCode` is changed to exclude all non-printable characters.

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
 
@@ -56,9 +59,10 @@ module System.Console.ANSI.Codes
   , setTitleCode
 
     -- * Utilities
-  , colorToCode, csi, sgrToCode
+  , colorToCode, csi, osc, sgrToCode
   ) where
 
+import Data.Char (isPrint)
 import Data.List (intercalate)
 
 import Data.Colour.SRGB (toSRGB24, RGB (..))
@@ -75,6 +79,18 @@ csi :: [Int]  -- ^ List of parameters for the control sequence
     -> String
 csi args code = "\ESC[" ++ intercalate ";" (map show args) ++ code
 
+-- | 'osc' @parameters@, where @parameters@ is a list of
+-- @(@'String'@, @'String'@)@, returns the XTerm control sequence comprising the
+-- control function OPERATING SYSTEM COMMAND (OSC) followed by the paramters
+-- (separated by \';\') and ending with the recommended STRING TERMINATOR (ST).
+--
+-- @since0.11.4
+osc :: [(String, String)] -- ^ List of (Ps, Pt) parameter pairs
+    -> String
+osc params = "\ESC]" ++ cmds ++ "\ESC\\"
+ where
+  cmds = intercalate ";" $ map (\(ps, pt) -> ps ++ ";" ++ pt) params
+
 -- | 'colorToCode' @color@ returns the 0-based index of the color (one of the
 -- eight colors in the ANSI standard).
 colorToCode :: Color -> Int
@@ -174,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,
@@ -219,7 +239,7 @@ hyperlinkWithParamsCode
   -- ^ Link text
   -> String
 hyperlinkWithParamsCode ps uri link =
-  "\ESC]8;" ++ ps' ++ ";" ++ uri ++ "\ESC\\" ++ link ++ "\ESC]8;;\ESC\\"
+  osc [("8", ps' ++ ";" ++ uri)] ++ link ++ osc [("8", ";")]
  where
   ps' = intercalate ":" $ map (\(k, v) -> k ++ "=" ++ v) ps
 
@@ -250,12 +270,13 @@ 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
 -- the title and "icon" text should be set. This is chosen for consistent
 -- behaviour between Unixes and Windows.
 setTitleCode :: String -- ^ New window title and icon name
              -> String
-setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007"
+setTitleCode title = osc [("0", filter isPrint title)]

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
@@ -86,7 +88,14 @@ hSupportsANSIWithoutEmulation h =
 
 -- getReportedCursorPosition :: IO String
 -- (See Common-Include.hs for Haddock documentation)
-getReportedCursorPosition = do
+getReportedCursorPosition = getReport 'R'
+
+-- getReportedLayerColor :: ConsoleLayer -> IO String
+-- (See Common-Include.hs for Haddock documentation)
+getReportedLayerColor _ = getReport '\\'
+
+getReport :: Char -> IO String
+getReport endChar = do
   -- If, unexpectedly, no data is available on the console input stream then
   -- the timeout will prevent the getChar blocking. For consistency with the
   -- Windows equivalent, returns "" if the expected information is unavailable.
@@ -101,8 +110,8 @@ getReportedCursorPosition = do
                       -- unexpected data in the input stream.
   get' s = do
     c <- getChar
-    if c /= 'R'
-      then get' (c:s) -- Continue building the list, until the expected 'R'
+    if c /= endChar
+      then get' (c:s) -- Continue building the list, until the expected end
                       -- character is obtained. Build the list in reverse order,
                       -- in order to avoid O(n^2) complexity.
       else return $ reverse (c:s) -- Reverse the order of the built list.
@@ -135,3 +144,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

@@ -21,7 +21,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
@@ -389,6 +389,8 @@ hReportCursorPosition h
             "\ESC[" ++ show y ++ ";" ++ show x ++ "R"
         return ()
 
+hReportLayerColor = Unix.hReportLayerColor  -- Not emulated
+
 keyPress :: Char -> [INPUT_RECORD]
 keyPress c = [keyDown, keyUp]
  where
@@ -510,6 +512,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