diff --git a/app/Example.hs b/app/Example.hs index bdb4b45..3b2587d 100644 --- a/app/Example.hs +++ b/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" diff --git a/src/System/Console/ANSI.hs b/src/System/Console/ANSI.hs index 1f41d19..679f627 100644 --- a/src/System/Console/ANSI.hs +++ b/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 on 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,78 @@ 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). + +GHC's management of input and output (IO) on Windows has also developed over +time. If they are supported by the terminal software, some control character +sequences cause data to be emitted 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 +). GHC's native IO manager on +Windows (\'WinIO\'), introduced as a preview in + [GHC 9.0.1](https://downloads.haskell.org/ghc/9.0.1/docs/html/users_guide/9.0.1-notes.html#highlights), +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. Functions that use that emulation are not supported on consoles, such +as mintty, that are not based on that API. + +== 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 +130,7 @@ Example: > setSGR [Reset] -- Reset to default colour scheme > putStrLn "Default colors." -Another example: +Another example is below: > module Main where > diff --git a/src/System/Console/ANSI/Codes.hs b/src/System/Console/ANSI/Codes.hs index 418d084..5b574db 100644 --- a/src/System/Console/ANSI/Codes.hs +++ b/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 --- ). -- -- @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 ] \ ; rgb: \ ; \ ; \ \@ +-- where @\@ is @10@ for 'Foreground' and @11@ for 'Background'; @\@, +-- @\@ and @\@ are the color channel values in hexadecimal (4, 8, +-- 12 and 16 bit values are possible, although 16 bit values are most common); +-- and @\@ 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, diff --git a/src/System/Console/ANSI/Unix.hs b/src/System/Console/ANSI/Unix.hs index 74d3840..82e8f53 100644 --- a/src/System/Console/ANSI/Unix.hs +++ b/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 diff --git a/src/System/Console/ANSI/Windows.hs b/src/System/Console/ANSI/Windows.hs index dbed40b..b3db080 100644 --- a/src/System/Console/ANSI/Windows.hs +++ b/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 diff --git a/src/System/Console/ANSI/Windows/Emulator.hs b/src/System/Console/ANSI/Windows/Emulator.hs index f0e5cbd..e2303e3 100644 --- a/src/System/Console/ANSI/Windows/Emulator.hs +++ b/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 " ++ diff --git a/src/System/Console/ANSI/Windows/Emulator/Codes.hs b/src/System/Console/ANSI/Windows/Emulator/Codes.hs index e24b184..f6ade78 100644 --- a/src/System/Console/ANSI/Windows/Emulator/Codes.hs +++ b/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 diff --git a/src/System/Console/ANSI/Windows/Foreign.hs b/src/System/Console/ANSI/Windows/Foreign.hs index 5914c7b..7c017ba 100644 --- a/src/System/Console/ANSI/Windows/Foreign.hs +++ b/src/System/Console/ANSI/Windows/Foreign.hs @@ -18,9 +18,10 @@ module System.Console.ANSI.Windows.Foreign charToWCHAR, cWcharsToChars, - COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, - rect_width, rect_height, CONSOLE_CURSOR_INFO(..), - CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), + COLORTABLE(..), COLORREF, COORD(..), SMALL_RECT(..), rect_top, rect_bottom, + rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), + CONSOLE_SCREEN_BUFFER_INFO(..), CONSOLE_SCREEN_BUFFER_INFOEX(..), + CHAR_INFO(..), sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, @@ -34,6 +35,7 @@ module System.Console.ANSI.Windows.Foreign getStdHandle, getConsoleScreenBufferInfo, + getConsoleScreenBufferInfoEx, getConsoleCursorInfo, getConsoleMode, @@ -59,6 +61,7 @@ import Control.Exception (Exception, throw) import Data.Bits ((.|.), shiftL) import Data.Char (chr, ord) import Data.Typeable (Typeable) +import Data.Word (Word32) import Foreign.C.Types (CInt (..), CWchar (..)) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray, peekArray, withArrayLen) @@ -67,7 +70,7 @@ import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (..)) -- `SHORT` and `withHandleToHANDLE` are not both available before Win32-2.5.1.0 import System.Win32.Compat (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, - SHORT, TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, + SHORT, TCHAR, UINT, ULONG, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, nullHANDLE, withHandleToHANDLE, withTString) #if defined(i386_HOST_ARCH) @@ -206,6 +209,136 @@ instance Storable CONSOLE_SCREEN_BUFFER_INFO where ptr4 <- pokeAndOffset ptr3 window poke ptr4 maximum_window_size +data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX + { csbix_size :: COORD + , csbix_cursor_position :: COORD + , csbix_attributes :: WORD + , csbix_window :: SMALL_RECT + , csbix_maximum_window_size :: COORD + , csbix_popup_attributes :: WORD + , csbix_fullscreen_supported :: BOOL + , csbix_color_table :: COLORTABLE + } deriving (Show) + +data COLORTABLE = COLORTABLE + { ct_color0 :: COLORREF + , ct_color1 :: COLORREF + , ct_color2 :: COLORREF + , ct_color3 :: COLORREF + , ct_color4 :: COLORREF + , ct_color5 :: COLORREF + , ct_color6 :: COLORREF + , ct_color7 :: COLORREF + , ct_color8 :: COLORREF + , ct_color9 :: COLORREF + , ct_colorA :: COLORREF + , ct_colorB :: COLORREF + , ct_colorC :: COLORREF + , ct_colorD :: COLORREF + , ct_colorE :: COLORREF + , ct_colorF :: COLORREF + } deriving (Show) + +instance Storable COLORTABLE where + sizeOf ~(COLORTABLE + color0 color1 color2 color3 color4 color5 color6 color7 color8 color9 colorA + colorB colorC colorD colorE colorF) + = sizeOf color0 + sizeOf color1 + sizeOf color2 + sizeOf color3 + + sizeOf color4 + sizeOf color5 + sizeOf color6 + sizeOf color7 + + sizeOf color8 + sizeOf color9 + sizeOf colorA + sizeOf colorB + + sizeOf colorC + sizeOf colorD + sizeOf colorE + sizeOf colorF + alignment ~(COLORTABLE color0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = + alignment color0 + peek ptr = do + (color0, ptr1) <- peekAndOffset (castPtr ptr) + (color1, ptr2) <- peekAndOffset ptr1 + (color2, ptr3) <- peekAndOffset ptr2 + (color3, ptr4) <- peekAndOffset ptr3 + (color4, ptr5) <- peekAndOffset ptr4 + (color5, ptr6) <- peekAndOffset ptr5 + (color6, ptr7) <- peekAndOffset ptr6 + (color7, ptr8) <- peekAndOffset ptr7 + (color8, ptr9) <- peekAndOffset ptr8 + (color9, ptr10) <- peekAndOffset ptr9 + (colorA, ptr11) <- peekAndOffset ptr10 + (colorB, ptr12) <- peekAndOffset ptr11 + (colorC, ptr13) <- peekAndOffset ptr12 + (colorD, ptr14) <- peekAndOffset ptr13 + (colorE, ptr15) <- peekAndOffset ptr14 + colorF <- peek ptr15 + return (COLORTABLE + color0 color1 color2 color3 color4 color5 color6 color7 color8 color9 + colorA colorB colorC colorD colorE colorF) + poke ptr (COLORTABLE + color0 color1 color2 color3 color4 color5 color6 color7 color8 color9 colorA + colorB colorC colorD colorE colorF) + = do + ptr1 <- pokeAndOffset (castPtr ptr) color0 + ptr2 <- pokeAndOffset ptr1 color1 + ptr3 <- pokeAndOffset ptr2 color2 + ptr4 <- pokeAndOffset ptr3 color3 + ptr5 <- pokeAndOffset ptr4 color4 + ptr6 <- pokeAndOffset ptr5 color5 + ptr7 <- pokeAndOffset ptr6 color6 + ptr8 <- pokeAndOffset ptr7 color7 + ptr9 <- pokeAndOffset ptr8 color8 + ptr10 <- pokeAndOffset ptr9 color9 + ptr11 <- pokeAndOffset ptr10 colorA + ptr12 <- pokeAndOffset ptr11 colorB + ptr13 <- pokeAndOffset ptr12 colorC + ptr14 <- pokeAndOffset ptr13 colorD + ptr15 <- pokeAndOffset ptr14 colorE + poke ptr15 colorF + +-- When specifying an explicit RGB color, the COLORREF value has the following +-- hexadecimal form: +-- 0x00bbggrr +-- The low-order byte contains a value for the relative intensity of red; the +-- second byte contains a value for green; and the third byte contains a value +-- for blue. The high-order byte must be zero. The maximum value for a single +-- byte is 0xFF. +type COLORREF = Word32 + +instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where + sizeOf ~(CONSOLE_SCREEN_BUFFER_INFOEX + size cursor_position attributes window maximum_window_size popup_attributes + fullscreen_supported color_table) + = sizeOf sizeCsbix + sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + + sizeOf maximum_window_size + sizeOf popup_attributes + + sizeOf fullscreen_supported + sizeOf color_table + alignment ~(CONSOLE_SCREEN_BUFFER_INFOEX _ _ _ _ _ _ _ _) = alignment sizeCsbix + peek ptr = do + let ptr0 = castPtr ptr `plusPtr` sizeOf sizeCsbix + (size, ptr1) <- peekAndOffset ptr0 + (cursor_position, ptr2) <- peekAndOffset ptr1 + (attributes, ptr3) <- peekAndOffset ptr2 + (window, ptr4) <- peekAndOffset ptr3 + (maximum_window_size, ptr5) <- peekAndOffset ptr4 + (popup_attributes, ptr6) <- peekAndOffset ptr5 + (fullscreen_supported, ptr7) <- peekAndOffset ptr6 + color_table <- peek ptr7 + return (CONSOLE_SCREEN_BUFFER_INFOEX + size cursor_position attributes window maximum_window_size + popup_attributes fullscreen_supported color_table) + poke ptr (CONSOLE_SCREEN_BUFFER_INFOEX + size cursor_position attributes window maximum_window_size popup_attributes + fullscreen_supported color_table) + = do + ptr0 <- pokeAndOffset (castPtr ptr) sizeCsbix + ptr1 <- pokeAndOffset ptr0 size + ptr2 <- pokeAndOffset ptr1 cursor_position + ptr3 <- pokeAndOffset ptr2 attributes + ptr4 <- pokeAndOffset ptr3 window + ptr5 <- pokeAndOffset ptr4 maximum_window_size + ptr6 <- pokeAndOffset ptr5 popup_attributes + ptr7 <- pokeAndOffset ptr6 fullscreen_supported + poke ptr7 color_table + +sizeCsbix :: ULONG +sizeCsbix = fromIntegral $ + sizeOf (undefined :: CONSOLE_SCREEN_BUFFER_INFOEX) + + data CHAR_INFO = CHAR_INFO { ci_char :: WCHAR , ci_attributes :: WORD @@ -265,6 +398,10 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfoEx" + cGetConsoleScreenBufferInfoEx :: HANDLE + -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" @@ -347,6 +484,17 @@ getConsoleScreenBufferInfo handle cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info peek ptr_console_screen_buffer_info +getConsoleScreenBufferInfoEx :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFOEX +getConsoleScreenBufferInfoEx handle + = alloca $ \ptr_console_screen_buffer_infoex -> do + -- In the Windows Console API, the `CONSOLE_SCREEN_BUFFER_INFOEX` + -- structure passed to the `GetConsoleScreenBufferInfoEx` function must + -- include the size of the structure. + poke (castPtr ptr_console_screen_buffer_infoex) sizeCsbix + throwIfFalse $ + cGetConsoleScreenBufferInfoEx handle ptr_console_screen_buffer_infoex + peek ptr_console_screen_buffer_infoex + getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info diff --git a/src/System/Win32/Compat.hs b/src/System/Win32/Compat.hs index 1e10a13..102c32d 100644 --- a/src/System/Win32/Compat.hs +++ b/src/System/Win32/Compat.hs @@ -27,6 +27,7 @@ module System.Win32.Compat , SHORT -- from Win32-2.5.0.0 , TCHAR , UINT + , ULONG -- from Win32-2.5.0.0 , WORD , failIfFalse_ , getLastError @@ -53,7 +54,7 @@ import System.Win32.Types (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, #if !defined(PATCHING_WIN32_PACKAGE) -import System.Win32.Types (SHORT, withHandleToHANDLE) +import System.Win32.Types (SHORT, ULONG, withHandleToHANDLE) #else @@ -73,8 +74,9 @@ import System.Win32.Types (withHandleToHANDLEPosix) #if !MIN_VERSION_Win32(2,5,0) import Foreign.C.Types (CShort (..)) +import Data.Word (Word32) #else -import System.Win32.Types (SHORT) +import System.Win32.Types (SHORT, ULONG) #endif #if !MIN_VERSION_Win32(2,5,1) @@ -88,6 +90,7 @@ import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 #if !MIN_VERSION_Win32(2,5,0) type SHORT = CShort +type ULONG = Word32 #endif withStablePtr :: a -> (StablePtr a -> IO b) -> IO b diff --git a/src/includes/Common-Include-Enabled.hs b/src/includes/Common-Include-Enabled.hs index 8678f86..3665e84 100644 --- a/src/includes/Common-Include-Enabled.hs +++ b/src/includes/Common-Include-Enabled.hs @@ -2,10 +2,10 @@ -- in the case of the module System.Console.ANSI.Windows.Emulator (see the file -- Common-Include-Emulator.hs in respect of the latter). --- | Set the Select Graphic Rendition mode +-- Set the Select Graphic Rendition mode hSetSGR :: Handle - -> [SGR] -- ^ Commands: these will typically be applied on top of the + -> [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 left to -- right. @@ -40,11 +40,11 @@ clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout clearLine = hClearLine stdout --- | Scroll the displayed information up or down the terminal: not widely +-- Scroll the displayed information up or down the terminal: not widely -- supported hScrollPageUp, hScrollPageDown :: Handle - -> Int -- ^ Number of lines to scroll by + -> Int -- Number of lines to scroll by -> IO () -- | Scroll the displayed information up or down the terminal: not widely diff --git a/src/includes/Common-Include.hs b/src/includes/Common-Include.hs index 71f55da..83e1047 100644 --- a/src/includes/Common-Include.hs +++ b/src/includes/Common-Include.hs @@ -10,14 +10,19 @@ 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 (..)) + +import System.Console.ANSI.Types hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: Handle - -> Int -- ^ Number of lines or characters to move + -> Int -- Number of lines or characters to move -> IO () cursorUp, cursorDown, cursorForward, cursorBackward :: Int -- ^ Number of lines or characters to move @@ -28,7 +33,7 @@ cursorForward = hCursorForward stdout cursorBackward = hCursorBackward stdout hCursorDownLine, hCursorUpLine :: Handle - -> Int -- ^ Number of lines to move + -> Int -- Number of lines to move -> IO () cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move -> IO () @@ -36,7 +41,7 @@ cursorDownLine = hCursorDownLine stdout cursorUpLine = hCursorUpLine stdout hSetCursorColumn :: Handle - -> Int -- ^ 0-based column to move to + -> Int -- 0-based column to move to -> IO () -- | Move the cursor to the specified column. The column numbering is 0-based @@ -46,8 +51,8 @@ setCursorColumn :: Int -- ^ 0-based column to move to setCursorColumn = hSetCursorColumn stdout hSetCursorPosition :: Handle - -> Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to + -> Int -- 0-based row to move to + -> Int -- 0-based column to move to -> IO () -- | Move the cursor to the specified position (row and column). The position is @@ -103,16 +108,16 @@ hideCursor, showCursor :: IO () hideCursor = hHideCursor stdout showCursor = hShowCursor stdout --- | Introduce a hyperlink with (key, value) parameters. Some terminals support +-- Introduce a hyperlink with (key, value) parameters. Some terminals support -- an @id@ parameter key, so that hyperlinks with the same @id@ value are -- treated as connected. -- -- @since 0.11.3 hHyperlinkWithParams :: Handle - -> [(String, String)] -- ^ Parameters - -> String -- ^ URI - -> String -- ^ Link text + -> [(String, String)] -- Parameters + -> String -- URI + -> String -- Link text -> IO () -- | Introduce a hyperlink with (key, value) parameters. Some terminals support @@ -127,13 +132,13 @@ hyperlinkWithParams -> IO () hyperlinkWithParams = hHyperlinkWithParams stdout --- | Introduce a hyperlink. +-- Introduce a hyperlink. -- -- @since 0.11.3 hHyperlink :: Handle - -> String -- ^ URI - -> String -- ^ Link text + -> String -- URI + -> String -- Link text -> IO () hHyperlink h = hHyperlinkWithParams h [] @@ -146,16 +151,16 @@ hyperlink -> IO () hyperlink = hHyperlink stdout --- | Introduce a hyperlink with an identifier for the link. Some terminals +-- Introduce a hyperlink with an identifier for the link. Some terminals -- support an identifier, so that hyperlinks with the same identifier are -- treated as connected. -- -- @since 0.11.3 hHyperlinkWithId :: Handle - -> String -- ^ Identifier for the link - -> String -- ^ URI - -> String -- ^ Link text + -> String -- Identifier for the link + -> String -- URI + -> String -- Link text -> IO () hHyperlinkWithId h linkId = hHyperlinkWithParams h [("id", linkId)] @@ -171,10 +176,10 @@ hyperlinkWithId -> IO () hyperlinkWithId = hHyperlinkWithId stdout --- | Set the terminal window title and icon name (that is, the text for the +-- Set the terminal window title and icon name (that is, the text for the -- window in the Start bar, or similar). hSetTitle :: Handle - -> String -- ^ New window title and icon name + -> String -- New window title and icon name -> IO () -- | Set the terminal window title and icon name (that is, the text for the -- window in the Start bar, or similar). @@ -332,6 +337,132 @@ getCursorPosition = hGetCursorPosition stdout -- @since 0.10.1 hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) +-- | Looking for a way to get layer colors? See 'getLayerColor'. +-- +-- Emit the layerColor into the console input stream, immediately after +-- being recognised on the output stream, as: +-- @ESC ] \ ; rgb: \ ; \ ; \ \@ +-- where @\@ is @10@ for 'Foreground' and @11@ for 'Background'; @\@, +-- @\@ and @\@ are the color channel values in hexadecimal (4, 8, +-- 12 and 16 bit values are possible, although 16 bit values are most common); +-- and @\@ 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 function is not supported on native terminals and is +-- emulated, but the emulation does not work on Windows Terminal and (2) of +-- difficulties in obtaining the data emitted into the console input stream. +-- +-- @since 0.11.4 +reportLayerColor :: ConsoleLayer -> IO () +reportLayerColor = hReportLayerColor stdout + +-- @since 0.11.4 +hReportLayerColor :: Handle -> ConsoleLayer -> IO () + +-- | Attempts to get the reported layer color data from the console input +-- stream. The function is intended to be called immediately after +-- 'reportLayerColor' (or related functions) have caused characters to be +-- emitted into the stream. +-- +-- For example, on a Unix-like operating system: +-- +-- > -- 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 +-- > input <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do +-- > hSetEcho stdin False +-- > reportLayerColor Foreground +-- > hFlush stdout -- ensure the report cursor position code is sent to the +-- > -- operating system +-- > getReportedLayerColor Foreground +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) +-- +-- @since 0.11.4 +getReportedLayerColor :: ConsoleLayer -> IO String + +-- | Attempts to get the reported layer color, combining the functions +-- 'reportLayerColor', 'getReportedLayerColor' and 'layerColor'. Any RGB color +-- is scaled to be 16 bits per channel, the most common format reported by +-- terminal software. Returns 'Nothing' if any data emitted by +-- 'reportLayerColor', obtained by 'getReportedLayerColor', cannot be parsed by +-- 'layerColor'. Uses 'stdout'. If 'stdout' will be redirected, see +-- 'hGetLayerColor' for a more general function. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) This function also relies on +-- emulation that does not work on Windows Terminal. +-- +-- @since 0.11.4 +getLayerColor :: ConsoleLayer -> IO (Maybe(RGB Word16)) +getLayerColor = hGetLayerColor stdout + +-- | Attempts to get the reported layer color, combining the functions +-- 'hReportLayerColor', 'getReportedLayerColor' and 'layerColor'. Any RGB color +-- is scaled to be 16 bits per channel, the most common format reported by +-- terminal software. Returns 'Nothing' if any data emitted by +-- 'hReportLayerColor', obtained by 'getReportedLayerColor', cannot be parsed by +-- 'layerColor'. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) This function also relies on +-- emulation that does not work on Windows Terminal. +-- +-- @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 layer) 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 ";rgb:" + 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 "\BEL" <++ 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). -- diff --git a/src/includes/Exports-Include.hs b/src/includes/Exports-Include.hs index 57335b2..c1c5717 100644 --- a/src/includes/Exports-Include.hs +++ b/src/includes/Exports-Include.hs @@ -10,10 +10,12 @@ , cursorDown , cursorForward , cursorBackward + -- ** \'h...\' variants , hCursorUp , hCursorDown , hCursorForward , hCursorBackward + -- ** \'...Code\' variants , cursorUpCode , cursorDownCode , cursorForwardCode @@ -29,52 +31,57 @@ -- for the details. , cursorUpLine , cursorDownLine + -- ** \'h...\' variants , hCursorUpLine , hCursorDownLine + -- ** \'...Code\' variants , cursorUpLineCode , cursorDownLineCode -- * Directly changing cursor position , setCursorColumn - , hSetCursorColumn - , setCursorColumnCode - , setCursorPosition + -- ** \'h...\' variants + , hSetCursorColumn , hSetCursorPosition + -- ** \'...Code\' variants + , setCursorColumnCode , setCursorPositionCode -- * Saving, restoring and reporting cursor position , saveCursor - , hSaveCursor - , saveCursorCode - , restoreCursor - , hRestoreCursor - , restoreCursorCode - , reportCursorPosition + -- ** \'h...\' variants + , hSaveCursor + , hRestoreCursor , hReportCursorPosition + -- ** \'...Code\' variants + , saveCursorCode + , restoreCursorCode , reportCursorPositionCode -- * Clearing parts of the screen - -- | Note that these functions only clear parts of the screen. They do not move the - -- cursor. + -- | Note that these functions only clear parts of the screen. They do not + -- move the cursor. Some functions are based on the whole screen and others + -- are based on the line in which the cursor is located. , clearFromCursorToScreenEnd , clearFromCursorToScreenBeginning , clearScreen - , hClearFromCursorToScreenEnd - , hClearFromCursorToScreenBeginning - , hClearScreen - , clearFromCursorToScreenEndCode - , clearFromCursorToScreenBeginningCode - , clearScreenCode - , clearFromCursorToLineEnd , clearFromCursorToLineBeginning , clearLine + -- ** \'h...\' variants + , hClearFromCursorToScreenEnd + , hClearFromCursorToScreenBeginning + , hClearScreen , hClearFromCursorToLineEnd , hClearFromCursorToLineBeginning - , hClearLine + , hClearLine + -- ** \'...Code\' variants + , clearFromCursorToScreenEndCode + , clearFromCursorToScreenBeginningCode + , clearScreenCode , clearFromCursorToLineEndCode , clearFromCursorToLineBeginningCode , clearLineCode @@ -82,11 +89,18 @@ -- * Scrolling the screen , scrollPageUp , scrollPageDown + -- ** \'h...\' variants , hScrollPageUp , hScrollPageDown + -- ** \'...Code\' variants , scrollPageUpCode , scrollPageDownCode + -- * Reporting the background or foreground colors + , reportLayerColor + , hReportLayerColor + , reportLayerColorCode + -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGR , hSetSGR @@ -95,8 +109,10 @@ -- * Cursor visibilty changes , hideCursor , showCursor + -- ** \'h...\' variants , hHideCursor , hShowCursor + -- ** \'...Code\' variants , hideCursorCode , showCursorCode @@ -105,13 +121,15 @@ -- text that points to a URI. On Windows, if emulation is required, -- hyperlinks are not emulated. , hyperlink - , hHyperlink - , hyperlinkCode , hyperlinkWithId - , hHyperlinkWithId - , hyperlinkWithIdCode , hyperlinkWithParams + -- ** \'h...\' variants + , hHyperlink + , hHyperlinkWithId , hHyperlinkWithParams + -- ** \'...Code\' variants + , hyperlinkCode + , hyperlinkWithIdCode , hyperlinkWithParamsCode -- * Changing the title @@ -133,3 +151,9 @@ -- * Getting the terminal size , getTerminalSize , hGetTerminalSize + + -- * Getting the background or foreground colors + , getLayerColor + , hGetLayerColor + , getReportedLayerColor + , layerColor