diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ Changes ======= +Version 1.0 +----------- + +* On Windows, drop support for legacy Windows requiring emulation. +* On Windows, the package no longer depends (directly or indirectly) on the + `Win32`, `array`,`containers`, `deepseq`, `filepath`, `ghc-boot-th`, `mintty`, + `pretty` or `template-haskell` packages. +* `hSupportsANSI` no longer assumes that the given handle is writeable. +* `hSupportsANSIWithoutEmulation` is deprecated. + Version 0.11.5 -------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -19,4 +19,4 @@ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,10 +20,6 @@ - Clickable hyperlinks to URIs - Changing the title of the terminal -By using emulation, it is compatible with versions of 'Command Prompt' and -'PowerShell' on Windows that did not recognise 'ANSI' escape codes before -Windows 10 version 1511 was released in November 2015. - If you like this, you may be interested in [ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which provides a pretty-printer that can construct strings containing 'ANSI' @@ -55,8 +51,7 @@ - An `IO` variant similar to above, but which takes a `Handle` to which the escape code should be applied - A `String` variant that returns a literal string that should be - included to get the effect of the code. However, on Windows systems where - emulation has been necessary, these strings will always be blank! + included to get the effect of the code. Example ------- diff --git a/ansi-terminal.cabal b/ansi-terminal.cabal --- a/ansi-terminal.cabal +++ b/ansi-terminal.cabal @@ -1,8 +1,8 @@ Cabal-Version: 1.22 Name: ansi-terminal -Version: 0.11.5 +Version: 1.0 Category: User Interfaces -Synopsis: Simple ANSI terminal support, with Windows compatibility +Synopsis: Simple ANSI terminal support Description: ANSI terminal support for Haskell: allows cursor movement, screen clearing, color output, showing or hiding the cursor, and changing the title. Works on UNIX and Windows. @@ -13,13 +13,10 @@ Homepage: https://github.com/UnkindPartition/ansi-terminal Build-Type: Simple -Extra-Source-Files: src/includes/Common-Include.hs - src/includes/Common-Include-Emulator.hs - src/includes/Common-Include-Enabled.hs - src/includes/Common-Safe-Haskell.hs - src/includes/Exports-Include.hs - CHANGELOG.md +Extra-Source-Files: CHANGELOG.md README.md + win/include/errors.h + win/include/winternl_compat.h Source-repository head type: git @@ -29,11 +26,6 @@ Description: Build the example application Default: False -Flag Win32-2-13-1 - Description: Use Win32-2-13.1.0 or later. If used, there is - no dependency on the mintty package. - Default: True - Library Hs-Source-Dirs: src Exposed-Modules: System.Console.ANSI @@ -43,33 +35,24 @@ -- downstream users. Reexported-Modules: System.Console.ANSI.Types - Include-Dirs: src/includes + Other-Modules: System.Console.ANSI.Internal Build-Depends: base >= 4.8.0.0 && < 5 - , ansi-terminal-types ==0.11.5 - , colour >=2.1.0 + , ansi-terminal-types == 0.11.5 + , colour >= 2.1.0 if os(windows) - Build-Depends: containers >= 0.5.0.0 - if flag(Win32-2-13-1) - Build-Depends: Win32 >= 2.13.1 - else - Build-Depends: Win32 < 2.13.1, mintty - Cpp-Options: -DWINDOWS - Other-Modules: System.Console.ANSI.Windows - System.Console.ANSI.Windows.Detect - System.Console.ANSI.Windows.Emulator - System.Console.ANSI.Windows.Emulator.Codes - System.Console.ANSI.Windows.Foreign - -- NB: used for fallback by the emulator - System.Console.ANSI.Unix - System.Win32.Compat + Hs-Source-Dirs: win + Other-Modules: System.Console.ANSI.Windows.Foreign + System.Console.ANSI.Windows.Win32.Types + System.Console.ANSI.Windows.Win32.MinTTY + Include-Dirs: win/include + Includes: errors.h + winternl_compat.h + C-Sources: win/c-source/errors.c else - -- We assume any non-Windows platform is Unix - Cpp-Options: -DUNIX - Other-Modules: System.Console.ANSI.Unix + Hs-Source-Dirs: unix Default-Extensions: CPP - ForeignFunctionInterface Ghc-Options: -Wall Default-Language: Haskell2010 @@ -82,5 +65,5 @@ , colour Ghc-Options: -Wall if !flag(example) - Buildable: False + Buildable: False Default-Language: Haskell2010 diff --git a/src/System/Console/ANSI.hs b/src/System/Console/ANSI.hs --- a/src/System/Console/ANSI.hs +++ b/src/System/Console/ANSI.hs @@ -1,4 +1,4 @@ -#include "Common-Safe-Haskell.hs" +{-# LANGUAGE Safe #-} {-| == Introduction Through this module, this library provides platform-independent support for @@ -39,10 +39,10 @@ Technology – Open Document Architecture (ODA) and Interchange Format: Character Content Architectures\` (also published as ISO/IEC International Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal emulator for -the X Window System. The escape codes are described in a Wikipedia article at - and those codes supported on -current versions of Windows at -. +the X Window System. The escape codes are described in a + [Wikipedia article](http://en.wikipedia.org/wiki/ANSI_escape_code) and those +codes supported on current versions of Windows are descibed in + [Microsoft's documentation](https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences). 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 @@ -59,13 +59,11 @@ == 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\'). +\'Threshold 2\') that software did not support control character sequences. 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 @@ -76,9 +74,9 @@ 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 +non-blocking primatives in the operating system (see + [GHC bug report #806](https://ghc.haskell.org/trac/ghc/ticket/806). 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 @@ -153,25 +151,850 @@ For many more examples, see the project's extensive file. -} -#if defined(WINDOWS) + module System.Console.ANSI ( - module System.Console.ANSI.Windows - ) where + -- * Basic data types + module System.Console.ANSI.Types -import System.Console.ANSI.Windows + -- * Cursor movement by character + , cursorUp + , cursorDown + , cursorForward + , cursorBackward + -- ** \'h...\' variants + , hCursorUp + , hCursorDown + , hCursorForward + , hCursorBackward + -- ** \'...Code\' variants + , cursorUpCode + , cursorDownCode + , cursorForwardCode + , cursorBackwardCode -#elif defined(UNIX) + -- * Cursor movement by line + -- | The difference between movements \"by character\" and \"by line\" is + -- that @*Line@ functions additionally move the cursor to the start of the + -- line, while functions like @cursorUp@ and @cursorDown@ keep the column + -- the same. + , cursorUpLine + , cursorDownLine + -- ** \'h...\' variants + , hCursorUpLine + , hCursorDownLine + -- ** \'...Code\' variants + , cursorUpLineCode + , cursorDownLineCode -module System.Console.ANSI - ( - module System.Console.ANSI.Unix + -- * Directly changing cursor position + , setCursorColumn + , setCursorPosition + -- ** \'h...\' variants + , hSetCursorColumn + , hSetCursorPosition + -- ** \'...Code\' variants + , setCursorColumnCode + , setCursorPositionCode + + -- * Saving, restoring and reporting cursor position + -- | These code sequences are not part of ECMA-48 standard; they are popular, + -- but non-portable extensions. E. g., Terminal.app on MacOS + -- . + -- A more portable way would be to query @terminfo@ database + -- for @rc@ and @sc@ capabilities. + -- + -- Cursor positions + -- . + -- + , saveCursor + , restoreCursor + , 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. Some functions are based on the whole screen and others + -- are based on the line in which the cursor is located. + , clearFromCursorToScreenEnd + , clearFromCursorToScreenBeginning + , clearScreen + , clearFromCursorToLineEnd + , clearFromCursorToLineBeginning + , clearLine + -- ** \'h...\' variants + , hClearFromCursorToScreenEnd + , hClearFromCursorToScreenBeginning + , hClearScreen + , hClearFromCursorToLineEnd + , hClearFromCursorToLineBeginning + , hClearLine + -- ** \'...Code\' variants + , clearFromCursorToScreenEndCode + , clearFromCursorToScreenBeginningCode + , clearScreenCode + , clearFromCursorToLineEndCode + , clearFromCursorToLineBeginningCode + , clearLineCode + + -- * Scrolling the screen + , scrollPageUp + , scrollPageDown + -- ** \'h...\' variants + , hScrollPageUp + , hScrollPageDown + -- ** \'...Code\' variants + , scrollPageUpCode + , scrollPageDownCode + + -- * Using screen buffers + -- | These code sequences are not part of ECMA-48 standard; they are popular, + -- but non-portable extensions, corresponding to @smcup@ and @rmcup@ capabilities + -- in @terminfo@ database. + -- On Windows, if emulation is required, switching between alternate and + -- normal screen buffers is not emulated. + , useAlternateScreenBuffer + , useNormalScreenBuffer + -- ** \'h...\' variants + , hUseAlternateScreenBuffer + , hUseNormalScreenBuffer + -- ** \'...Code\' variants + , useAlternateScreenBufferCode + , useNormalScreenBufferCode + + -- * Reporting the background or foreground colors + , reportLayerColor + , hReportLayerColor + , reportLayerColorCode + + -- * Select Graphic Rendition mode: colors and other whizzy stuff + , setSGR + , hSetSGR + , setSGRCode + + -- * Cursor visibilty changes + -- | Strictly speaking, these code sequences are not part of ECMA-48 standard; + -- they are popular, but non-portable extensions. However, in practice they seem + -- to work pretty much everywhere. + , hideCursor + , showCursor + -- ** \'h...\' variants + , hHideCursor + , hShowCursor + -- ** \'...Code\' variants + , hideCursorCode + , showCursorCode + + -- * Hyperlinks + -- | These code sequences are not part of ECMA-48 standard and not even an + -- @xterm@ extension. Nevertheless + -- + -- support them. On Windows, if emulation is required, + -- hyperlinks are not emulated. + , hyperlink + , hyperlinkWithId + , hyperlinkWithParams + -- ** \'h...\' variants + , hHyperlink + , hHyperlinkWithId + , hHyperlinkWithParams + -- ** \'...Code\' variants + , hyperlinkCode + , hyperlinkWithIdCode + , hyperlinkWithParamsCode + + -- * Changing the title + , setTitle + , hSetTitle + , setTitleCode + + -- * Checking if handle supports ANSI (not portable: GHC only) + , hSupportsANSI + , hSupportsANSIColor + + -- * Getting the cursor position + , getCursorPosition + , hGetCursorPosition + , getReportedCursorPosition + , cursorPosition + + -- * Getting the terminal size + , getTerminalSize + , hGetTerminalSize + + -- * Getting the background or foreground colors + , getLayerColor + , hGetLayerColor + , getReportedLayerColor + , layerColor + + -- * Deprecated + , hSupportsANSIWithoutEmulation ) where -import System.Console.ANSI.Unix +import Control.Exception.Base ( bracket ) +import Control.Monad ( when, void ) +import Data.Char ( digitToInt, isDigit, isHexDigit ) +import Data.Colour.SRGB ( RGB (..) ) +import Data.Word ( Word16 ) +import System.Environment ( getEnvironment ) +import System.IO + ( BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, hPutStr + , hReady, hSetBuffering, hSetEcho, stdin, stdout + ) +import Text.ParserCombinators.ReadP + ( ReadP, (<++), char, many1, readP_to_S, satisfy, string ) -#else +import System.Console.ANSI.Codes +import qualified System.Console.ANSI.Internal as Internal +import System.Console.ANSI.Types -#error Unsupported platform for the ansi-terminal package +hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: + Handle + -> Int -- Number of lines or characters to move + -> IO () +hCursorUp h n = hPutStr h $ cursorUpCode n +hCursorDown h n = hPutStr h $ cursorDownCode n +hCursorForward h n = hPutStr h $ cursorForwardCode n +hCursorBackward h n = hPutStr h $ cursorBackwardCode n -#endif +cursorUp, cursorDown, cursorForward, cursorBackward :: + Int -- ^ Number of lines or characters to move + -> IO () +cursorUp = hCursorUp stdout +cursorDown = hCursorDown stdout +cursorForward = hCursorForward stdout +cursorBackward = hCursorBackward stdout + +hCursorDownLine, hCursorUpLine :: + Handle + -> Int -- Number of lines to move + -> IO () +hCursorDownLine h n = hPutStr h $ cursorDownLineCode n +hCursorUpLine h n = hPutStr h $ cursorUpLineCode n + +cursorDownLine, cursorUpLine :: + Int -- ^ Number of lines to move + -> IO () +cursorDownLine = hCursorDownLine stdout +cursorUpLine = hCursorUpLine stdout + +hSetCursorColumn :: + Handle + -> Int -- 0-based column to move to + -> IO () +hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n + +-- | Move the cursor to the specified column. The column numbering is 0-based +-- (that is, the left-most column is numbered 0). +setCursorColumn :: + Int -- ^ 0-based column to move to + -> IO () +setCursorColumn = hSetCursorColumn stdout + +hSetCursorPosition :: + Handle + -> Int -- 0-based row to move to + -> Int -- 0-based column to move to + -> IO () +hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m + +-- | Move the cursor to the specified position (row and column). The position is +-- 0-based (that is, the top-left corner is at row 0 column 0). +setCursorPosition :: + Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPosition = hSetCursorPosition stdout + +hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () +hSaveCursor h = hPutStr h saveCursorCode +hRestoreCursor h = hPutStr h restoreCursorCode +hReportCursorPosition h = hPutStr h reportCursorPositionCode + +-- | Save the cursor position in memory. The only way to access the saved value +-- is with the 'restoreCursor' command. +-- +-- @since 0.7.1 +saveCursor :: IO () +saveCursor = hSaveCursor stdout + +-- | Restore the cursor position from memory. There will be no value saved in +-- memory until the first use of the 'saveCursor' command. +-- +-- @since 0.7.1 +restoreCursor :: IO () +restoreCursor = hRestoreCursor stdout + +-- | Looking for a way to get the cursors position? See +-- 'getCursorPosition'. +-- +-- Emit the cursor position into the console input stream, immediately after +-- being recognised on the output stream, as: +-- @ESC [ \ ; \ R@ +-- +-- Note that the information that is emitted is 1-based (the top-left corner is +-- at row 1 column 1) but 'setCursorColumn' and 'setCursorPosition' are +-- 0-based. +-- +-- 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. +-- +-- @since 0.7.1 +reportCursorPosition :: IO () +reportCursorPosition = hReportCursorPosition stdout + +hHideCursor, hShowCursor :: Handle -> IO () +hHideCursor h = hPutStr h hideCursorCode +hShowCursor h = hPutStr h showCursorCode + +hideCursor, showCursor :: IO () +hideCursor = hHideCursor stdout +showCursor = hShowCursor stdout + +hUseAlternateScreenBuffer :: Handle -> IO () +hUseAlternateScreenBuffer h = hPutStr h useAlternateScreenBufferCode + +hUseNormalScreenBuffer :: Handle -> IO () +hUseNormalScreenBuffer h = hPutStr h useNormalScreenBufferCode + +-- | Use the Alternate Screen Buffer. If currently using the Normal Screen +-- Buffer, it will save the cursor position and switch to the Alternate Screen +-- Buffer. It will always clear the Alternate Screen Buffer. The Alternate +-- Screen Buffer has no scroll back facility. +-- +-- It is an application's responsibility to ensure that it switches back to the +-- Normal Screen Buffer if an exception is raised while the Alternate Screen +-- Buffer is being used. For example, by using 'Control.Exception.bracket_': +-- +-- > bracket_ useAlternateScreenBuffer useNormalScreenBuffer action +-- +-- @since 0.11.4 +useAlternateScreenBuffer :: IO () +useAlternateScreenBuffer = hUseAlternateScreenBuffer stdout + +-- | Use the Normal Screen Buffer. If currently using the Alternate Screen +-- Buffer, it will clear the Alternate Screen Buffer, and switch to the Normal +-- Screen Buffer. It will always restore the saved cursor position. +-- +-- @since 0.11.4 +useNormalScreenBuffer :: IO () +useNormalScreenBuffer = hUseNormalScreenBuffer stdout + +-- 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 + -> IO () +hHyperlinkWithParams h params uri link = + hPutStr h $ hyperlinkWithParamsCode params uri link + +-- | 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 +hyperlinkWithParams :: + [(String, String)] -- ^ Parameters + -> String -- ^ URI + -> String -- ^ Link text + -> IO () +hyperlinkWithParams = hHyperlinkWithParams stdout + +-- Introduce a hyperlink. +-- +-- @since 0.11.3 +hHyperlink :: + Handle + -> String -- URI + -> String -- Link text + -> IO () +hHyperlink h = hHyperlinkWithParams h [] + +-- | Introduce a hyperlink. +-- +-- @since 0.11.3 +hyperlink :: + String -- ^ URI + -> String -- ^ Link text + -> IO () +hyperlink = hHyperlink stdout + +-- 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 + -> IO () +hHyperlinkWithId h linkId = hHyperlinkWithParams h [("id", linkId)] + +-- | 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 +hyperlinkWithId :: + String -- ^ Identifier for the link + -> String -- ^ URI + -> String -- ^ Link text + -> IO () +hyperlinkWithId = hHyperlinkWithId stdout + +-- 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 + -> IO () +hSetTitle h title = hPutStr h $ setTitleCode title + +-- | Set the terminal window title and icon name (that is, the text for the +-- window in the Start bar, or similar). +setTitle :: String -- ^ New window title and icon name + -> IO () +setTitle = hSetTitle stdout + +-- | Use heuristics to determine whether the functions defined in this +-- package will work with a given handle. +-- +-- If the handle is not writable (that is, it cannot manage output - see +-- 'hIsWritable'), then @pure False@ is returned. +-- +-- For Unix-like operating systems, the current implementation checks +-- that: (1) the handle is a terminal; and (2) a @TERM@ +-- environment variable is not set to @dumb@ (which is what the GNU Emacs text +-- editor sets for its integrated terminal). +-- +-- For Windows, the current implementation performs the same checks as for +-- Unix-like operating systems and, as an alternative, checks whether the +-- handle is connected to a \'mintty\' terminal. (That is because the function +-- 'hIsTerminalDevice' is used to check if the handle is a +-- terminal. However, where a non-native Windows terminal (such as \'mintty\') +-- is implemented using redirection, that function will not identify a +-- handle to the terminal as a terminal.) +-- +-- @since 0.6.2 +hSupportsANSI :: Handle -> IO Bool +hSupportsANSI = Internal.hSupportsANSI + +-- | Some terminals (e.g. Emacs) are not fully ANSI compliant but can support +-- ANSI colors. This can be used in such cases, if colors are all that is +-- needed. +-- +-- @since 0.9 +hSupportsANSIColor :: Handle -> IO Bool +hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm + where + isEmacsTerm = (\env -> insideEmacs env && isDumb env) <$> getEnvironment + insideEmacs = any (\(k, _) -> k == "INSIDE_EMACS") + isDumb env = Just "dumb" == lookup "TERM" env + +-- | Use heuristics to determine whether a given handle will support \'ANSI\' +-- control characters in output. The function is consistent with +-- 'hSupportsANSI'. +-- +-- This function is deprecated as, from version 1.0, the package no longer +-- supports legacy versions of Windows that required emulation. +-- +-- @since 0.8.1 +{-# DEPRECATED hSupportsANSIWithoutEmulation "See Haddock documentation and hSupportsANSI." #-} +hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) +hSupportsANSIWithoutEmulation h = Just <$> hSupportsANSI h + +-- | Parses the characters emitted by 'reportCursorPosition' into the console +-- input stream. Returns the cursor row and column as a tuple. +-- +-- For example, if the characters emitted by 'reportCursorPosition' are in +-- 'String' @input@ then the parser could be applied like this: +-- +-- > let result = readP_to_S cursorPosition input +-- > case result of +-- > [] -> putStrLn $ "Error: could not parse " ++ show input +-- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row +-- > ++ " and column" ++ show column ++ "." +-- > (_:_) -> putStrLn $ "Error: parse not unique" +-- +-- @since 0.7.1 +cursorPosition :: ReadP (Int, Int) +cursorPosition = do + void $ char '\ESC' + void $ char '[' + row <- decimal -- A non-negative whole decimal number + void $ char ';' + col <- decimal -- A non-negative whole decimal number + void $ char 'R' + pure (read row, read col) + where + digit = satisfy isDigit + decimal = many1 digit + +-- | Attempts to get the reported cursor position data from the console input +-- stream. The function is intended to be called immediately after +-- 'reportCursorPosition' (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 +-- > reportCursorPosition +-- > hFlush stdout -- ensure the report cursor position code is sent to the +-- > -- operating system +-- > getReportedCursorPosition +-- +-- 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.7.1 +getReportedCursorPosition :: IO String +getReportedCursorPosition = Internal.getReportedCursorPosition + +-- | Attempts to get the reported cursor position, combining the functions +-- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. Any +-- position @(row, column)@ is translated to be 0-based (that is, the top-left +-- corner is at @(0, 0)@), consistent with `setCursorColumn` and +-- `setCursorPosition`. (Note that the information emitted into the console +-- input stream by 'reportCursorPosition' is 1-based.) Returns 'Nothing' if any +-- data emitted by 'reportCursorPosition', obtained by +-- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'. Uses +-- 'stdout'. If 'stdout' will be redirected, see 'hGetCursorPosition' 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.) +-- +-- @since 0.10.3 +getCursorPosition :: IO (Maybe (Int, Int)) +getCursorPosition = hGetCursorPosition stdout + +-- | Attempts to get the reported cursor position, combining the functions +-- 'hReportCursorPosition' (with the specified handle), +-- 'getReportedCursorPosition' and 'cursorPosition'. Any position +-- @(row, column)@ is translated to be 0-based (that is, the top-left corner is +-- at @(0, 0)@), consistent with 'hSetCursorColumn' and 'hSetCursorPosition'. +-- (Note that the information emitted into the console input stream by +-- 'hReportCursorPosition' is 1-based.) Returns 'Nothing' if any data emitted by +-- 'hReportCursorPosition', obtained by 'getReportedCursorPosition', cannot be +-- parsed by 'cursorPosition'. +-- +-- 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.10.1 +hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) +hGetCursorPosition h = fmap to0base <$> getCursorPosition' + where + to0base (row, col) = (row - 1, col - 1) + getCursorPosition' = 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 + hReportCursorPosition h + hFlush h -- ensure the report cursor position code is sent to the + -- operating system + getReportedCursorPosition + case readP_to_S cursorPosition input of + [] -> pure Nothing + [((row, col),_)] -> pure $ Just (row, col) + (_:_) -> pure Nothing + clearStdin = do + isReady <- hReady stdin + when isReady $ do + _ <-getChar + clearStdin + +-- | 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 () +hReportLayerColor h layer = hPutStr h $ reportLayerColorCode layer + +-- | 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 +getReportedLayerColor = Internal.getReportedLayerColor + +-- | 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)) +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 + [] -> pure Nothing + [(col, _)] -> pure $ Just col + (_:_) -> pure Nothing + where + clearStdin = do + isReady <- hReady stdin + when isReady $ do + _ <-getChar + clearStdin + +-- | 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 pure $ 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). +-- +-- There is no \'ANSI\' control character sequence that reports the terminal +-- size. So, it attempts to set the cursor position beyond the bottom right +-- corner of the terminal and then use 'getCursorPosition' to query the console +-- input stream. It works only on terminals that support each step and if data +-- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if +-- 'stdin' is connected to a terminal.) Uses 'stdout'. If 'stdout' will be +-- redirected, see 'System.IO.hGetTerminalSize' for a more general function. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on Windows' Console API. (Command Prompt and +-- PowerShell are based on the Console API.) +-- +-- For a different approach, one that does not use control character sequences +-- and works when 'stdin' is redirected, see the +-- package. +-- +-- @since 0.9 +getTerminalSize :: IO (Maybe (Int, Int)) +getTerminalSize = hGetTerminalSize stdout + +-- | Attempts to get the current terminal size (height in rows, width in +-- columns), by writing control character sequences to the specified handle +-- (which will typically be 'stdout' or 'stderr'). +-- +-- There is no \'ANSI\' control character sequence that reports the terminal +-- size. So, it attempts to set the cursor position beyond the bottom right +-- corner of the terminal and then use 'hGetCursorPosition' to query the console +-- input stream. It works only on terminals that support each step and if data +-- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if +-- 'stdin' is connected to a terminal.) +-- +-- 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.) +-- +-- For a different approach, one that does not use control character sequences +-- and works when 'stdin' is redirected, see the +-- package. +-- +-- @since 0.10.1 +hGetTerminalSize :: Handle -> IO (Maybe (Int, Int)) +hGetTerminalSize h = do + hSaveCursor h + hSetCursorPosition h 9999 9999 -- Attempt to set the cursor position beyond + -- the bottom right corner of the terminal. + mPos <- hGetCursorPosition h + hRestoreCursor h + hFlush h -- ensure the restore cursor position code is sent to the + -- operating system + pure $ fmap (\(r, c) -> (r + 1, c + 1)) mPos + +-- Set the Select Graphic Rendition mode +hSetSGR :: + Handle + -> [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. + -> IO () +hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs + +-- | Set the Select Graphic Rendition mode +setSGR :: + [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. + -> IO () +setSGR = hSetSGR stdout + +hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: + Handle + -> IO () +hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode +hClearFromCursorToScreenBeginning h + = hPutStr h clearFromCursorToScreenBeginningCode +hClearScreen h = hPutStr h clearScreenCode + +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO () +clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout +clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout +clearScreen = hClearScreen stdout + +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: + Handle + -> IO () +hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode +hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode +hClearLine h = hPutStr h clearLineCode + +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO () +clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout +clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout +clearLine = hClearLine stdout + +hScrollPageUp, hScrollPageDown :: + Handle + -> Int -- Number of lines to scroll by + -> IO () +hScrollPageUp h n = hPutStr h $ scrollPageUpCode n +hScrollPageDown h n = hPutStr h $ scrollPageDownCode n + +scrollPageUp, scrollPageDown :: + Int -- ^ Number of lines to scroll by + -> IO () +scrollPageUp = hScrollPageUp stdout +scrollPageDown = hScrollPageDown stdout diff --git a/src/System/Console/ANSI/Codes.hs b/src/System/Console/ANSI/Codes.hs --- a/src/System/Console/ANSI/Codes.hs +++ b/src/System/Console/ANSI/Codes.hs @@ -1,20 +1,8 @@ -#include "Common-Safe-Haskell.hs" +{-# LANGUAGE Safe #-} {-| This module exports functions that return 'String' values containing codes in accordance with the \'ANSI\' standards for control character sequences described in the documentation of module "System.Console.ANSI". - -The module "System.Console.ANSI" exports functions with the same names as those -in this module. On some versions of Windows, the terminal in use may not be -ANSI-capable. When that is the case, the same-named functions exported by module -"System.Console.ANSI" return \"\", for the reasons set out in the documentation -of that module. - -Consequently, if module "System.Console.ANSI" is also imported, this module is -intended to be imported qualified, to avoid name clashes with those functions. -For example: - -> import qualified System.Console.ANSI.Codes as ANSI -} module System.Console.ANSI.Codes ( @@ -89,9 +77,10 @@ -- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\') -- and ending with the @controlFunction@ character(s) that identifies the -- control function. -csi :: [Int] -- ^ List of parameters for the control sequence - -> String -- ^ Character(s) that identify the control function - -> String +csi :: + [Int] -- ^ List of parameters for the control sequence + -> String -- ^ Character(s) that identify the control function + -> String csi args code = "\ESC[" ++ intercalate ";" (map show args) ++ code -- | 'osc' @parameterS parametersT@, where @parameterS@ specifies the type of @@ -101,9 +90,10 @@ -- the STRING TERMINATOR (ST) @\"\\ESC\\\\\"@. -- -- @since 0.11.4 -osc :: String -- ^ Ps parameter - -> String -- ^ Pt parameter(s) - -> String +osc :: + String -- ^ Ps parameter + -> String -- ^ Pt parameter(s) + -> String osc pS pT = "\ESC]" ++ pS ++ ";" ++ pT ++ "\ESC\\" -- | 'colorToCode' @color@ returns the 0-based index of the color (one of the @@ -121,8 +111,9 @@ -- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION -- (SGR) aspect identified by @sgr@. -sgrToCode :: SGR -- ^ The SGR aspect - -> [Int] +sgrToCode :: + SGR -- ^ The SGR aspect + -> [Int] sgrToCode sgr = case sgr of Reset -> [0] SetConsoleIntensity intensity -> case intensity of @@ -157,30 +148,33 @@ toRGB color = let RGB r g b = toSRGB24 color in map fromIntegral [r, g, b] -cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode - :: Int -- ^ Number of lines or characters to move +cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: + Int -- ^ Number of lines or characters to move -> String cursorUpCode n = if n == 0 then "" else csi [n] "A" cursorDownCode n = if n == 0 then "" else csi [n] "B" cursorForwardCode n = if n == 0 then "" else csi [n] "C" cursorBackwardCode n = if n == 0 then "" else csi [n] "D" -cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move - -> String +cursorDownLineCode, cursorUpLineCode :: + Int -- ^ Number of lines to move + -> String cursorDownLineCode n = if n == 0 then csi [1] "G" else csi [n] "E" cursorUpLineCode n = if n == 0 then csi [1] "G" else csi [n] "F" -- | Code to move the cursor to the specified column. The column numbering is -- 0-based (that is, the left-most column is numbered 0). -setCursorColumnCode :: Int -- ^ 0-based column to move to - -> String +setCursorColumnCode :: + Int -- ^ 0-based column to move to + -> String setCursorColumnCode n = csi [n + 1] "G" -- | Code to move the cursor to the specified position (row and column). The -- position is 0-based (that is, the top-left corner is at row 0 column 0). -setCursorPositionCode :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> String +setCursorPositionCode :: + Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> String setCursorPositionCode n m = csi [n + 1, m + 1] "H" -- | @since 0.7.1 @@ -235,8 +229,9 @@ clearFromCursorToLineBeginningCode = csi [1] "K" clearLineCode = csi [2] "K" -scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by - -> String +scrollPageUpCode, scrollPageDownCode :: + Int -- ^ Number of lines to scroll by + -> String scrollPageUpCode n = if n == 0 then "" else csi [n] "S" scrollPageDownCode n = if n == 0 then "" else csi [n] "T" @@ -244,11 +239,12 @@ useAlternateScreenBufferCode = csi [] "?1049h" useNormalScreenBufferCode = csi [] "?1049l" -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 - -- left to right. - -> String +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 left to right. + -> String setSGRCode sgrs = csi (concatMap sgrToCode sgrs) "m" hideCursorCode, showCursorCode :: String @@ -260,13 +256,13 @@ -- are treated as connected. -- -- @since 0.11.3 -hyperlinkWithParamsCode - :: [(String, String)] - -- ^ Parameters +hyperlinkWithParamsCode :: + [(String, String)] + -- ^ Parameters -> String - -- ^ URI + -- ^ URI -> String - -- ^ Link text + -- ^ Link text -> String hyperlinkWithParamsCode params uri link = osc "8" pT ++ link ++ osc "8" ";" @@ -277,11 +273,11 @@ -- | Code to introduce a hyperlink. -- -- @since 0.11.3 -hyperlinkCode - :: String - -- ^ URI +hyperlinkCode :: + String + -- ^ URI -> String - -- ^ Link text + -- ^ Link text -> String hyperlinkCode = hyperlinkWithParamsCode [] @@ -290,13 +286,13 @@ -- are treated as connected. -- -- @since 0.11.3 -hyperlinkWithIdCode - :: String - -- ^ Identifier for the link +hyperlinkWithIdCode :: + String + -- ^ Identifier for the link -> String - -- ^ URI + -- ^ URI -> String - -- ^ Link text + -- ^ Link text -> String hyperlinkWithIdCode linkId = hyperlinkWithParamsCode [("id", linkId)] @@ -307,6 +303,8 @@ -- 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 :: + String + -- ^ New window title and icon name + -> String setTitleCode title = osc "0" (filter isPrint title) diff --git a/src/System/Console/ANSI/Unix.hs b/src/System/Console/ANSI/Unix.hs deleted file mode 100644 --- a/src/System/Console/ANSI/Unix.hs +++ /dev/null @@ -1,200 +0,0 @@ -#include "Common-Safe-Haskell.hs" -{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Unix - ( --- This file contains code that is common to modules --- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module --- exports and the associated Haddock documentation. -#include "Exports-Include.hs" - ) where - -import Control.Exception.Base (bracket) -import Control.Monad (when) -import Data.List (uncons) -import Data.Maybe (fromMaybe, mapMaybe) -import System.IO (BufferMode (..), Handle, hGetBuffering, hGetEcho, - hIsTerminalDevice, hIsWritable, hPutStr, hReady, hSetBuffering, hSetEcho, - stdin) -import System.Timeout (timeout) -import Text.ParserCombinators.ReadP (readP_to_S) - -import System.Console.ANSI.Codes - --- 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 --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, including the related Haddock --- documentation. -#include "Common-Include.hs" --- This file contains code that is common save that different code is required --- in the case of the module System.Console.ANSI.Windows.Emulator (see the file --- Common-Include-Emulator.hs in respect of the latter). -#include "Common-Include-Enabled.hs" - -hCursorUp h n = hPutStr h $ cursorUpCode n -hCursorDown h n = hPutStr h $ cursorDownCode n -hCursorForward h n = hPutStr h $ cursorForwardCode n -hCursorBackward h n = hPutStr h $ cursorBackwardCode n - -hCursorDownLine h n = hPutStr h $ cursorDownLineCode n -hCursorUpLine h n = hPutStr h $ cursorUpLineCode n - -hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n -hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m - -hSaveCursor h = hPutStr h saveCursorCode -hRestoreCursor h = hPutStr h restoreCursorCode -hReportCursorPosition h = hPutStr h reportCursorPositionCode - -hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode -hClearFromCursorToScreenBeginning h - = hPutStr h clearFromCursorToScreenBeginningCode -hClearScreen h = hPutStr h clearScreenCode - -hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode -hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode -hClearLine h = hPutStr h clearLineCode - -hScrollPageUp h n = hPutStr h $ scrollPageUpCode n -hScrollPageDown h n = hPutStr h $ scrollPageDownCode n - -hUseAlternateScreenBuffer h = hPutStr h useAlternateScreenBufferCode -hUseNormalScreenBuffer h = hPutStr h useNormalScreenBufferCode - -hReportLayerColor h layer = hPutStr h $ reportLayerColorCode layer - -hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs - -hHideCursor h = hPutStr h hideCursorCode -hShowCursor h = hPutStr h showCursorCode - -hHyperlinkWithParams h params uri link = - hPutStr h $ hyperlinkWithParamsCode params uri link - -hSetTitle h title = hPutStr h $ setTitleCode title - --- hSupportsANSI :: Handle -> IO Bool --- (See Common-Include.hs for Haddock documentation) --- --- Borrowed from an HSpec patch by Simon Hengel --- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) -hSupportsANSI h = (&&) <$> hIsTerminalDevice h <*> isNotDumb - where - -- cannot use lookupEnv since it only appeared in GHC 7.6 - isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment - --- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) --- (See Common-Include.hs for Haddock documentation) -hSupportsANSIWithoutEmulation h = - Just <$> ((&&) <$> hIsWritable h <*> hSupportsANSI h) - --- getReportedCursorPosition :: IO String --- (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 - -- 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. - fromMaybe "" <$> timeout 500000 (getStart startChars "") -- 500 milliseconds - where - endChars' = mapMaybe uncons endChars - - -- The list is built in reverse order, in order to avoid O(n^2) complexity. - -- So, getReport yields the reversed built list. - - getStart :: String -> String -> IO String - getStart "" r = getRest r - getStart (h:hs) r = do - c <- getChar - if c == h - then getStart hs (c:r) -- Try to get the rest of the start characters - else pure $ reverse (c:r) -- If the first character(s) are not the - -- expected start then give up. This provides - -- a modicom of protection against unexpected - -- data in the input stream. - getRest :: String -> IO String - getRest r = do - c <- getChar - case lookup c endChars' of - Nothing -> getRest (c:r) -- Continue building the list, until the first of - -- the end characters is obtained. - Just es -> getEnd es (c:r) -- Try to get the rest of the end characters. - - getEnd :: String -> String -> IO String - getEnd "" r = pure $ reverse r - getEnd (e:es) r = do - c <- getChar - if c /= e - then getRest (c:r) -- Continue building the list, with the original end - -- characters. - else getEnd es (c:r) -- Continue building the list, checking against the - -- remaining end characters. - --- hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) --- (See Common-Include.hs for Haddock documentation) -hGetCursorPosition h = fmap to0base <$> getCursorPosition' - where - to0base (row, col) = (row - 1, col - 1) - getCursorPosition' = 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 - hReportCursorPosition h - hFlush h -- ensure the report cursor position code is sent to the - -- operating system - getReportedCursorPosition - case readP_to_S cursorPosition input of - [] -> pure Nothing - [((row, col),_)] -> pure $ Just (row, col) - (_:_) -> pure Nothing - clearStdin = do - isReady <- hReady stdin - 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 - [] -> pure Nothing - [(col, _)] -> pure $ Just col - (_:_) -> pure 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 deleted file mode 100644 --- a/src/System/Console/ANSI/Windows.hs +++ /dev/null @@ -1,250 +0,0 @@ -#include "Common-Safe-Haskell.hs" -{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Windows - ( --- This file contains code that is common to modules --- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module --- exports and the associated Haddock documentation. -#include "Exports-Include.hs" - ) where - -import System.IO (Handle) - -import qualified System.Console.ANSI.Unix as U -import System.Console.ANSI.Windows.Detect (ANSISupport (..), - ConsoleDefaultState (..), aNSISupport) -import qualified System.Console.ANSI.Windows.Emulator as E - --- 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 --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, including the related Haddock --- documentation. -#include "Common-Include.hs" --- This file contains code that is common save that different code is required --- in the case of the module System.Console.ANSI.Windows.Emulator (see the file --- Common-Include-Emulator.hs in respect of the latter). -#include "Common-Include-Enabled.hs" - --- | A helper function which returns the native or emulated version, depending --- on `aNSISupport`. -nativeOrEmulated :: a -> a -> a -nativeOrEmulated native emulated = case aNSISupport of - Native -> native - Emulated _ -> emulated - --- | A helper function which returns the native or emulated version, depending --- on `aNSISupport`, where the emulator uses the default console state. -nativeOrEmulatedWithDefault :: a -> (ConsoleDefaultState -> a) -> a -nativeOrEmulatedWithDefault native emulated = case aNSISupport of - Native -> native - Emulated def -> emulated def - - --- * Cursor movement by character -hCursorUp = nativeOrEmulated U.hCursorUp E.hCursorUp -hCursorDown = nativeOrEmulated U.hCursorDown E.hCursorDown -hCursorForward = nativeOrEmulated U.hCursorForward E.hCursorForward -hCursorBackward = nativeOrEmulated U.hCursorBackward E.hCursorBackward - -cursorUpCode :: Int -> String -cursorUpCode = nativeOrEmulated U.cursorUpCode E.cursorUpCode - -cursorDownCode :: Int -> String -cursorDownCode = nativeOrEmulated U.cursorDownCode E.cursorDownCode - -cursorForwardCode :: Int -> String -cursorForwardCode = nativeOrEmulated U.cursorForwardCode E.cursorForwardCode - -cursorBackwardCode :: Int -> String -cursorBackwardCode = nativeOrEmulated U.cursorBackwardCode E.cursorBackwardCode - --- * Cursor movement by line -hCursorUpLine = nativeOrEmulated U.hCursorUpLine E.hCursorUpLine -hCursorDownLine = nativeOrEmulated U.hCursorDownLine E.hCursorDownLine - -cursorUpLineCode :: Int -> String -cursorUpLineCode = nativeOrEmulated U.cursorUpLineCode E.cursorUpLineCode - -cursorDownLineCode :: Int -> String -cursorDownLineCode = nativeOrEmulated U.cursorDownLineCode E.cursorDownLineCode - --- * Directly changing cursor position -hSetCursorColumn = nativeOrEmulated U.hSetCursorColumn E.hSetCursorColumn - -setCursorColumnCode :: Int -> String -setCursorColumnCode = nativeOrEmulated - U.setCursorColumnCode E.setCursorColumnCode - -hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition - -setCursorPositionCode :: Int -> Int -> String -setCursorPositionCode = nativeOrEmulated - U.setCursorPositionCode E.setCursorPositionCode - --- * Saving, restoring and reporting cursor position -hSaveCursor = nativeOrEmulated U.hSaveCursor E.hSaveCursor -hRestoreCursor = nativeOrEmulated U.hRestoreCursor E.hRestoreCursor -hReportCursorPosition = nativeOrEmulated - U.hReportCursorPosition E.hReportCursorPosition - -saveCursorCode :: String -saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode - -restoreCursorCode :: String -restoreCursorCode = nativeOrEmulated U.restoreCursorCode E.restoreCursorCode - -reportCursorPositionCode :: String -reportCursorPositionCode = nativeOrEmulated - U.reportCursorPositionCode E.reportCursorPositionCode - --- * Clearing parts of the screen -hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault - U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd -hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault - U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning -hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen - -clearFromCursorToScreenEndCode :: String -clearFromCursorToScreenEndCode = nativeOrEmulated - U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode - -clearFromCursorToScreenBeginningCode :: String -clearFromCursorToScreenBeginningCode = nativeOrEmulated - U.clearFromCursorToScreenBeginningCode E.clearFromCursorToScreenBeginningCode - -clearScreenCode :: String -clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode - -hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault - U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd -hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault - U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning -hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine - -clearFromCursorToLineEndCode :: String -clearFromCursorToLineEndCode = nativeOrEmulated - U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode - -clearFromCursorToLineBeginningCode :: String -clearFromCursorToLineBeginningCode = nativeOrEmulated - U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode - -clearLineCode :: String -clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode - --- * Scrolling the screen -hScrollPageUp = nativeOrEmulatedWithDefault U.hScrollPageUp E.hScrollPageUp -hScrollPageDown = nativeOrEmulatedWithDefault U.hScrollPageDown E.hScrollPageDown - -scrollPageUpCode :: Int -> String -scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode - -scrollPageDownCode :: Int -> String -scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode - --- * Using screen buffers -hUseAlternateScreenBuffer = nativeOrEmulated - U.hUseAlternateScreenBuffer E.hUseAlternateScreenBuffer -hUseNormalScreenBuffer = nativeOrEmulated - U.hUseNormalScreenBuffer E.hUseNormalScreenBuffer - -useAlternateScreenBufferCode :: String -useAlternateScreenBufferCode = nativeOrEmulated - U.useAlternateScreenBufferCode E.useAlternateScreenBufferCode - -useNormalScreenBufferCode :: String -useNormalScreenBufferCode = nativeOrEmulated - U.useNormalScreenBufferCode E.useNormalScreenBufferCode - --- * 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: --- 2 SetConsoleIntensity FaintIntensity --- 3 SetItalicized True --- 5 SetBlinkSpeed SlowBlink --- 6 SetBlinkSpeed RapidBlink --- 8 SetVisible False --- 21 SetUnderlining DoubleUnderline --- 23 SetItalicized False --- 25 SetBlinkSpeed NoBlink --- 28 SetVisible True - -hSetSGR = nativeOrEmulatedWithDefault U.hSetSGR E.hSetSGR - -setSGRCode :: [SGR] -> String -setSGRCode = nativeOrEmulated U.setSGRCode E.setSGRCode - --- * Cursor visibilty changes -hHideCursor = nativeOrEmulated U.hHideCursor E.hHideCursor -hShowCursor = nativeOrEmulated U.hShowCursor E.hShowCursor - -hideCursorCode :: String -hideCursorCode = nativeOrEmulated U.hideCursorCode E.hideCursorCode - -showCursorCode :: String -showCursorCode = nativeOrEmulated U.showCursorCode E.showCursorCode - --- * Hyperlinks -hHyperlinkWithParams = - nativeOrEmulated U.hHyperlinkWithParams E.hHyperlinkWithParams - -hyperlinkWithParamsCode - :: [(String, String)] - -> String - -> String - -> String -hyperlinkWithParamsCode = - nativeOrEmulated U.hyperlinkWithParamsCode E.hyperlinkWithParamsCode - -hyperlinkCode - :: String - -> String - -> String -hyperlinkCode = nativeOrEmulated U.hyperlinkCode E.hyperlinkCode - -hyperlinkWithIdCode - :: String - -> String - -> String - -> String -hyperlinkWithIdCode = - nativeOrEmulated U.hyperlinkWithIdCode E.hyperlinkWithIdCode - --- * Changing the title -hSetTitle = nativeOrEmulated U.hSetTitle E.hSetTitle - -setTitleCode :: String -> String -setTitleCode = nativeOrEmulated U.setTitleCode E.setTitleCode - --- hSupportsANSI :: Handle -> IO Bool --- (See Common-Include.hs for Haddock documentation) -hSupportsANSI = E.hSupportsANSI - --- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) --- (See Common-Include.hs for Haddock documentation) -hSupportsANSIWithoutEmulation = E.hSupportsANSIWithoutEmulation - --- getReportedCursorPosition :: IO String --- (See Common-Include.hs for Haddock documentation) -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/Detect.hs b/src/System/Console/ANSI/Windows/Detect.hs deleted file mode 100644 --- a/src/System/Console/ANSI/Windows/Detect.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Windows.Detect - ( - ANSISupport (..) - , ConsoleDefaultState (..) - , aNSISupport - , detectHandleSupportsANSI - ) where - -import Control.Exception (SomeException(..), throwIO, try) -import Data.Bits ((.&.), (.|.)) -#ifdef MIN_VERSION_mintty -import System.Console.MinTTY (isMinTTYHandle) -#else -import System.Win32.MinTTY (isMinTTYHandle) -#endif -import System.IO (Handle, hIsWritable, stdout) -import System.IO.Unsafe (unsafePerformIO) - -import System.Console.ANSI.Windows.Foreign (ConsoleException(..), - CONSOLE_SCREEN_BUFFER_INFO (..), DWORD, HANDLE, WORD, - bACKGROUND_INTENSE_WHITE, eNABLE_VIRTUAL_TERMINAL_PROCESSING, - fOREGROUND_INTENSE_WHITE, getConsoleMode, getConsoleScreenBufferInfo, - iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, withHandleToHANDLE) - --- | The default state of the console. -data ConsoleDefaultState = ConsoleDefaultState - { defaultForegroundAttributes :: WORD -- ^ Foreground attributes - , defaultBackgroundAttributes :: WORD -- ^ Background attributes - } deriving (Eq, Show) - --- | How the console is assumed to support ANSI control codes. -data ANSISupport - = Native -- ^ Assume ANSI-enabled - | Emulated ConsoleDefaultState -- ^ Not ANSI-enabled (including the state of - -- the console when that status was determined) - deriving (Eq, Show) - --- | Terminals on Windows -data Terminal - = NativeANSIEnabled -- ^ Windows 10 (Command Prompt or PowerShell) - | NativeANSIIncapable -- ^ Versions before Windows 10 (Command Prompt or - -- PowerShell) - | Mintty -- ^ ANSI-enabled - | UnknownTerminal - --- | This function assumes that once it is first established whether or not the --- Windows console requires emulation, that will not change. If the console --- requires emulation, the state of the console is considered to be its default --- state. -{-# NOINLINE aNSISupport #-} -aNSISupport :: ANSISupport -aNSISupport = unsafePerformIO $ withHandleToHANDLE stdout $ withHANDLE - (throwIO $ ConsoleException 6) -- Invalid handle or no handle - (\h -> do - terminal <- handleToTerminal h - case terminal of - NativeANSIIncapable -> Emulated <$> consoleDefaultState h - _ -> pure Native) - where - consoleDefaultState h = do - info <- getConsoleScreenBufferInfo h - let attributes = csbi_attributes info - fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE - bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE - pure ConsoleDefaultState - { defaultForegroundAttributes = fgAttributes - , defaultBackgroundAttributes = bgAttributes } - --- | This function tests that the handle is writable. If what is attached to the --- handle is not recognised as a known terminal, it returns @pure Nothing@. -detectHandleSupportsANSI :: Handle -> IO (Maybe Bool) -detectHandleSupportsANSI handle = do - isWritable <- hIsWritable handle - if isWritable - then withHandleToHANDLE handle $ withHANDLE - (pure $ Just False) -- Invalid handle or no handle - (\h -> do - terminal <- handleToTerminal h - case terminal of - NativeANSIIncapable -> pure (Just False) - UnknownTerminal -> pure Nothing -- Not sure! - _ -> pure (Just True)) - else pure (Just False) -- Not an output handle - --- | This function assumes that the Windows handle is writable. -handleToTerminal :: HANDLE -> IO Terminal -handleToTerminal h = do - tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD) - case tryMode of - Left _ -> do -- No ConHost mode - isMinTTY <- isMinTTYHandle h - if isMinTTY - then pure Mintty -- 'mintty' terminal emulator - else pure UnknownTerminal -- Not sure! - Right mode -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 - then pure NativeANSIEnabled -- VT processing already enabled - else do - let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING - trySetMode <- try (setConsoleMode h mode') - :: IO (Either SomeException ()) - case trySetMode of - Left _ -> pure NativeANSIIncapable -- Can't enable VT processing - Right () -> pure NativeANSIEnabled -- VT processing enabled - --- | This function applies another to the Windows handle, if the handle is --- valid. If it is invalid, the specified default action is returned. -withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a -withHANDLE invalid action h = - if h == iNVALID_HANDLE_VALUE || h == nullHANDLE - then invalid -- Invalid handle or no handle - else action h diff --git a/src/System/Console/ANSI/Windows/Emulator.hs b/src/System/Console/ANSI/Windows/Emulator.hs deleted file mode 100644 --- a/src/System/Console/ANSI/Windows/Emulator.hs +++ /dev/null @@ -1,564 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Windows.Emulator - ( -#include "Exports-Include.hs" - ) where - -import Control.Exception (catchJust, IOException) -import qualified Control.Exception as CE (catch) -import Control.Monad (unless) -import Data.Bits ((.&.), (.|.), complement, shiftL, shiftR) -import Data.Char (isPrint) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (foldl', minimumBy) -import Data.Maybe (mapMaybe) -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 (toSRGB) -#ifdef MIN_VERSION_mintty -import System.Console.MinTTY (isMinTTYHandle) -#else -import System.Win32.MinTTY (isMinTTYHandle) -#endif - -import qualified System.Console.ANSI.Unix as Unix -import System.Console.ANSI.Windows.Detect -import System.Console.ANSI.Windows.Emulator.Codes -import System.Console.ANSI.Windows.Foreign - --- 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 --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, including the related Haddock --- documentation. -#include "Common-Include.hs" --- This file contains code that is required in the case of the module --- System.Console.ANSI.Windows.Emulator and differs from the common code in --- file Common-Include-Enabled.hs. -#include "Common-Include-Emulator.hs" - -withHandle :: Handle -> (HANDLE -> IO a) -> IO a -withHandle handle action = do - -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API - -- call to change the console because on Windows the arrival of - -- API-initiated state changes is not necessarily synchronised with that of - -- the text they are attempting to modify. - hFlush handle - withHandleToHANDLE handle action - --- Unfortunately, the emulator is not perfect. In particular, it has a tendency --- to die with exceptions about invalid handles when it is used with certain --- Windows consoles (e.g. mintty, terminator, or cygwin sshd). --- --- This happens because in those environments the stdout family of handles are --- not actually associated with a real console. --- --- My observation is that every time I've seen this in practice, the handle we --- have instead of the actual console handle is there so that the terminal --- supports ANSI escape codes. So 99% of the time, the correct thing to do is --- just to fall back on the Unix module to output the ANSI codes and hope for --- the best. -emulatorFallback :: IO a -> IO a -> IO a -emulatorFallback fallback first_try - = catchJust invalidHandle first_try (const fallback) - where - invalidHandle (ConsoleException 6) = Just () -- 6 is the Windows error code - -- for invalid handles - invalidHandle (_) = Nothing - -adjustCursorPosition :: HANDLE - -> (SHORT -> SHORT -> SHORT) - -> (SHORT -> SHORT -> SHORT) - -> IO () -adjustCursorPosition handle change_x change_y = do - screen_buffer_info <- getConsoleScreenBufferInfo handle - let window = csbi_window screen_buffer_info - l = rect_left window - t = rect_top window - r = rect_right window - b = rect_bottom window - (COORD x y) = csbi_cursor_position screen_buffer_info - clamp mn mx = max mn . min mx - x' = clamp l r (change_x l x) - y' = clamp t b (change_y t y) - cursor_pos' = COORD x' y' - setConsoleCursorPosition handle cursor_pos' - -hCursorUp h n - = emulatorFallback (Unix.hCursorUp h n) $ withHandle h $ - \handle -> adjustCursorPosition handle (\_ x -> x) - (\_ y -> y - fromIntegral n) -hCursorDown h n - = emulatorFallback (Unix.hCursorDown h n) $ withHandle h $ - \handle -> adjustCursorPosition handle (\_ x -> x) - (\_ y -> y + fromIntegral n) -hCursorForward h n - = emulatorFallback (Unix.hCursorForward h n) $ withHandle h $ - \handle -> adjustCursorPosition handle (\_ x -> x + fromIntegral n) - (\_ y -> y) -hCursorBackward h n - = emulatorFallback (Unix.hCursorBackward h n) $ withHandle h $ - \handle -> adjustCursorPosition handle (\_ x -> x - fromIntegral n) - (\_ y -> y) - -adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO () -adjustLine handle change_y - = adjustCursorPosition handle (\window_left _ -> window_left) change_y - -hCursorDownLine h n - = emulatorFallback (Unix.hCursorDownLine h n) $ withHandle h $ - \handle -> adjustLine handle (\_ y -> y + fromIntegral n) - -hCursorUpLine h n - = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $ - \handle -> adjustLine handle (\_ y -> y - fromIntegral n) - -hSetCursorColumn h x - = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ - \handle -> adjustCursorPosition handle - (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) - -hSetCursorPosition h y x - = emulatorFallback (Unix.hSetCursorPosition h y x) $ withHandle h $ - \handle -> adjustCursorPosition handle - (\window_left _ -> window_left + fromIntegral x) - (\window_top _ -> window_top + fromIntegral y) - -clearChar :: WCHAR -clearChar = charToWCHAR ' ' - --- | The 'clear' attribute is equated with the default background attributes. -clearAttribute :: ConsoleDefaultState -> WORD -clearAttribute = defaultBackgroundAttributes - -hClearScreenFraction - :: ConsoleDefaultState - -> HANDLE - -> (SMALL_RECT -> COORD -> (SHORT, SHORT, SHORT, SHORT, SHORT, SHORT)) - -> IO () -hClearScreenFraction cds handle fraction_finder = do - screen_buffer_info <- getConsoleScreenBufferInfo handle - let window = csbi_window screen_buffer_info - cursor_pos = csbi_cursor_position screen_buffer_info - (left, top, right, bottom, start_x, end_x) - = fraction_finder window cursor_pos - mapM_ (fill_line left top right bottom start_x end_x) [top .. bottom] - where - fill_line left top right bottom start_x end_x y = do - let left' = if y == top then start_x else left - right' = if y == bottom then end_x else right - fill_cursor_pos = COORD left' y - fill_length = fromIntegral $ right' - left' + 1 - _ <- fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos - fillConsoleOutputAttribute handle (clearAttribute cds) fill_length - fill_cursor_pos - -hClearFromCursorToScreenEnd cds h - = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ - \handle -> hClearScreenFraction cds handle go - where - go window cursor_pos = (left, top, right, bottom, start_x, right) - where - SMALL_RECT (COORD left _) (COORD right bottom) = window - COORD start_x top = cursor_pos - -hClearFromCursorToScreenBeginning cds h - = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ - \handle -> hClearScreenFraction cds handle go - where - go window cursor_pos = (left, top, right, bottom, left, end_x) - where - SMALL_RECT (COORD left top) (COORD right _) = window - COORD end_x bottom = cursor_pos - -hClearScreen cds h - = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ - \handle -> hClearScreenFraction cds handle go - where - go window _ = (left, top, right, bottom, left, right) - where - SMALL_RECT (COORD left top) (COORD right bottom) = window - -hClearFromCursorToLineEnd cds h - = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ - \handle -> hClearScreenFraction cds handle go - where - go window cursor_pos = (left, y, right, y, start_x, right) - where - SMALL_RECT (COORD left _) (COORD right _) = window - COORD start_x y = cursor_pos - -hClearFromCursorToLineBeginning cds h - = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ - \handle -> hClearScreenFraction cds handle go - where - go window cursor_pos = (left, y, right, y, left, end_x) - where - SMALL_RECT (COORD left _) (COORD right _) = window - COORD end_x y = cursor_pos - -hClearLine cds h - = emulatorFallback (Unix.hClearLine h) $ withHandle h $ - \handle -> hClearScreenFraction cds handle go - where - go window cursor_pos = (left, y, right, y, left, right) - where - SMALL_RECT (COORD left _) (COORD right _) = window - COORD _ y = cursor_pos - -hScrollPage - :: ConsoleDefaultState -- ^ The default console state - -> HANDLE - -> Int - -> IO () -hScrollPage cds handle new_origin_y = do - screen_buffer_info <- getConsoleScreenBufferInfo handle - let fill = CHAR_INFO clearChar (clearAttribute cds) - window = csbi_window screen_buffer_info - origin = COORD (rect_left window) - (rect_top window + fromIntegral new_origin_y) - scrollConsoleScreenBuffer handle window Nothing origin fill - -hScrollPageUp cds h n - = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ - \handle -> hScrollPage cds handle (negate n) - -hScrollPageDown cds h n - = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ - \handle -> hScrollPage cds handle n - -hUseAlternateScreenBuffer _ = pure () -hUseNormalScreenBuffer _ = pure () - -{-# INLINE applyANSIColorToAttribute #-} -applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD -applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of - Black -> attribute' - Red -> attribute' .|. rED - Green -> attribute' .|. gREEN - Yellow -> attribute' .|. rED .|. gREEN - Blue -> attribute' .|. bLUE - Magenta -> attribute' .|. rED .|. bLUE - Cyan -> attribute' .|. gREEN .|. bLUE - White -> attribute' .|. wHITE - where - wHITE = rED .|. gREEN .|. bLUE - attribute' = attribute .&. (complement wHITE) - -applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute - :: Color - -> WORD - -> WORD -applyForegroundANSIColorToAttribute - = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE -applyBackgroundANSIColorToAttribute - = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE - -swapForegroundBackgroundColors :: WORD -> WORD -swapForegroundBackgroundColors attribute - = clean_attribute .|. foreground_attribute' .|. background_attribute' - where - foreground_attribute = attribute .&. fOREGROUND_INTENSE_WHITE - background_attribute = attribute .&. bACKGROUND_INTENSE_WHITE - clean_attribute = attribute .&. complement - (fOREGROUND_INTENSE_WHITE .|. bACKGROUND_INTENSE_WHITE) - foreground_attribute' = background_attribute `shiftR` 4 - background_attribute' = foreground_attribute `shiftL` 4 - -applyANSISGRToAttribute :: WORD -> SGR -> WORD -> WORD -applyANSISGRToAttribute def sgr attribute = case sgr of - Reset -> def - SetDefaultColor Foreground -> - (attribute .&. complement fOREGROUND_INTENSE_WHITE) .|. - (def .&. fOREGROUND_INTENSE_WHITE) - SetDefaultColor Background -> - (attribute .&. complement bACKGROUND_INTENSE_WHITE) .|. - (def .&. bACKGROUND_INTENSE_WHITE) - SetConsoleIntensity intensity -> case intensity of - BoldIntensity -> attribute .|. iNTENSITY - FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported - NormalIntensity -> attribute .&. (complement iNTENSITY) - SetItalicized _ -> attribute -- Not supported - SetUnderlining underlining -> case underlining of - NoUnderline -> attribute .&. (complement cOMMON_LVB_UNDERSCORE) - _ -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since - -- cOMMON_LVB_UNDERSCORE seems to have no effect - SetBlinkSpeed _ -> attribute -- Not supported - SetVisible _ -> attribute -- Not supported - -- The cOMMON_LVB_REVERSE_VIDEO doesn't actually appear to have any affect - -- on the colors being displayed, so the emulator just uses it to carry - -- information and implements the color-swapping behaviour itself. Bit of a - -- hack, I guess :-) - SetSwapForegroundBackground True -> - -- Check if the color-swapping flag is already set - if attribute .&. cOMMON_LVB_REVERSE_VIDEO /= 0 - then attribute - else swapForegroundBackgroundColors attribute .|. cOMMON_LVB_REVERSE_VIDEO - SetSwapForegroundBackground False -> - -- Check if the color-swapping flag is already not set - if attribute .&. cOMMON_LVB_REVERSE_VIDEO == 0 - then attribute - else swapForegroundBackgroundColors attribute .&. - (complement cOMMON_LVB_REVERSE_VIDEO) - SetColor Foreground Dull color -> applyForegroundANSIColorToAttribute color - (attribute .&. (complement fOREGROUND_INTENSITY)) - SetColor Foreground Vivid color -> applyForegroundANSIColorToAttribute color - (attribute .|. fOREGROUND_INTENSITY) - SetColor Background Dull color -> applyBackgroundANSIColorToAttribute color - (attribute .&. (complement bACKGROUND_INTENSITY)) - SetColor Background Vivid color -> applyBackgroundANSIColorToAttribute color - (attribute .|. bACKGROUND_INTENSITY) - SetRGBColor Foreground color -> - let (colorIntensity, aNSIColor) = toANSIColor color - attribute' = case colorIntensity of - Dull -> attribute .&. complement fOREGROUND_INTENSITY - Vivid -> attribute .|. fOREGROUND_INTENSITY - in applyForegroundANSIColorToAttribute aNSIColor attribute' - SetRGBColor Background color -> - let (colorIntensity, aNSIColor) = toANSIColor color - attribute' = case colorIntensity of - Dull -> attribute .&. complement bACKGROUND_INTENSITY - Vivid -> attribute .|. bACKGROUND_INTENSITY - in applyBackgroundANSIColorToAttribute aNSIColor attribute' - SetPaletteColor _ _ -> attribute -- Not supported - where - iNTENSITY = fOREGROUND_INTENSITY - -hSetSGR cds h sgr - = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do - screen_buffer_info <- getConsoleScreenBufferInfo handle - let attribute = csbi_attributes screen_buffer_info - def = defaultForegroundAttributes cds - .|. defaultBackgroundAttributes cds - attribute' = foldl' (flip $ applyANSISGRToAttribute def) attribute - -- make [] equivalent to [Reset], as documented - (if null sgr then [Reset] else sgr) - setConsoleTextAttribute handle attribute' - -hChangeCursorVisibility :: HANDLE -> Bool -> IO () -hChangeCursorVisibility handle cursor_visible = do - cursor_info <- getConsoleCursorInfo handle - setConsoleCursorInfo handle - (cursor_info { cci_cursor_visible = cursor_visible }) - -hHideCursor h - = emulatorFallback (Unix.hHideCursor h) $ withHandle h $ - \handle -> hChangeCursorVisibility handle False -hShowCursor h - = emulatorFallback (Unix.hShowCursor h) $ withHandle h $ - \handle -> hChangeCursorVisibility handle True - -hHyperlinkWithParams h _ _ = hPutStr h - --- Windows only supports setting the terminal title on a process-wide basis, so --- for now we will assume that that is what the user intended. This will fail if --- they are sending the command over e.g. a network link... but that's not --- really what I'm designing for. -hSetTitle h title - = emulatorFallback (Unix.hSetTitle h title) $ - withTString (filter isPrint title) setConsoleTitle - -cursorPositionRef :: IORef (Map.Map HANDLE COORD) -{-# NOINLINE cursorPositionRef #-} -cursorPositionRef = unsafePerformIO $ newIORef Map.empty - -hSaveCursor h - = emulatorFallback (Unix.hSaveCursor h) $ withHandle h $ \handle -> do - screen_buffer_info <- getConsoleScreenBufferInfo handle - m <- readIORef cursorPositionRef - writeIORef cursorPositionRef - (Map.insert handle (csbi_cursor_position screen_buffer_info) m) - -hRestoreCursor h - = emulatorFallback (Unix.hRestoreCursor h) $ withHandle h $ \handle -> do - m <- readIORef cursorPositionRef - let result = Map.lookup handle m - maybe (pure ()) (setConsoleCursorPosition handle) result - -hReportCursorPosition h - = emulatorFallback (Unix.hReportCursorPosition h) $ withHandle h $ - \handle -> do - result <- getConsoleScreenBufferInfo handle - let (COORD cx cy) = csbi_cursor_position result - window = csbi_window result - x = cx - rect_left window + 1 - y = cy - rect_top window + 1 - hIn <- getStdHandle sTD_INPUT_HANDLE - _ <- writeConsoleInput hIn $ keyPresses $ - "\ESC[" ++ show y ++ ";" ++ show x ++ "R" - pure () - -hReportLayerColor h layer - = emulatorFallback (Unix.hReportLayerColor h layer) $ withHandle h $ - \handle -> do - result <- getConsoleScreenBufferInfoEx handle - let attributes = csbix_attributes result - colorTable = csbix_color_table result - 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 - pure () - -keyPress :: Char -> [INPUT_RECORD] -keyPress c = [keyDown, keyUp] - where - keyDown = key True - keyUp = key False - c' = UnicodeAsciiChar $ charToWCHAR c - key isDown = INPUT_RECORD kEY_EVENT $ - InputKeyEvent (KEY_EVENT_RECORD isDown 1 0 0 c' 0) - -keyPresses :: String -> [INPUT_RECORD] -keyPresses = concatMap keyPress - -aNSIColors :: [((ColorIntensity, Color), Colour Float)] -aNSIColors = [ ((Dull, Black), black) - , ((Dull, Blue), navy) - , ((Dull, Green), green) - , ((Dull, Cyan), teal) - , ((Dull, Red), maroon) - , ((Dull, Magenta), purple) - , ((Dull, Yellow), olive) - , ((Dull, White), silver) - , ((Vivid, Black), grey) - , ((Vivid, Blue), blue) - , ((Vivid, Green), lime) - , ((Vivid, Cyan), cyan) - , ((Vivid, Red), red) - , ((Vivid, Magenta), magenta) - , ((Vivid, Yellow), yellow) - , ((Vivid, White), white) ] - -toANSIColor :: Colour Float -> (ColorIntensity, Color) -toANSIColor color = fst $ minimumBy order aNSIColors - where - RGB r g b = toSRGB color - order (_, c1) (_, c2) = compare (dist c1) (dist c2) - dist c = let RGB r' g' b' = toSRGB c - dr = r' - r - dg = g' - g - db = b' - b - in dr * dr + dg * dg + db * db - --- hSupportsANSI :: Handle -> IO Bool --- (See Common-Include.hs for Haddock documentation) -hSupportsANSI h = (||) <$> isTDNotDumb h <*> isMinTTY - where - isMinTTY = withHandleToHANDLE h isMinTTYHandle - --- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) --- (See Common-Include.hs for Haddock documentation) -hSupportsANSIWithoutEmulation handle = do - supportsANSI <- detectHandleSupportsANSI handle -- Without reference to the - -- environment - case supportsANSI of - Just isSupported -> pure (Just isSupported) - Nothing -> do -- Not sure, based on the handle alone - notDumb <- isNotDumb -- Test the environment - if notDumb - then pure Nothing -- Still not sure! - else pure (Just False) -- A dumb terminal - --- Borrowed from an HSpec patch by Simon Hengel --- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) -isTDNotDumb :: Handle -> IO Bool -isTDNotDumb h = (&&) <$> hIsTerminalDevice h <*> isNotDumb - --- Borrowed from an HSpec patch by Simon Hengel --- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) -isNotDumb :: IO Bool --- cannot use lookupEnv since it only appeared in GHC 7.6 -isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment - --- getReportedCursorPosition :: IO String --- (See Common-Include.hs for Haddock documentation) -getReportedCursorPosition = getReported - -getReported :: IO String -getReported = CE.catch getReported' getReportedExceptionHandler - where - getReported' = withHandleToHANDLE stdin action - where - action hdl = do - n <- getNumberOfConsoleInputEvents hdl - if n == 0 - then pure "" - else do - es <- readConsoleInput hdl n - pure $ stringFromInputEvents es - stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents - wCharsFromInputEvents = mapMaybe wCharFromInputEvent - wCharFromInputEvent e = if isKeyEvent && isKeyDown - then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) - else Nothing - where - eventType = inputEventType e - eventRecord = inputEvent e - isKeyEvent = eventType == 1 - keyEventRecord = case eventRecord of - InputKeyEvent keyEventRecord' -> keyEventRecord' - _ -> error "Unexpected input event, given input event type." - isKeyDown = keyEventKeyDown keyEventRecord - --- hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) --- (See Common-Include.hs for Haddock documentation) -hGetCursorPosition h = fmap to0base <$> getCursorPosition' - where - to0base (row, col) = (row - 1, col - 1) - 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 - getReport = do - withHandleToHANDLE stdin flush -- Flush the console input buffer - report h - hFlush h -- ensure the report cursor position code is sent to the - -- operating system - input <- get - case readP_to_S parse input of - [] -> pure Nothing - [(value,_)] -> pure $ Just value - (_:_) -> pure Nothing - where - flush hdl = do - n <- getNumberOfConsoleInputEvents hdl - unless (n == 0) (void $ readConsoleInput hdl n) - - --- 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 " ++ - "or PowerShell." diff --git a/src/System/Console/ANSI/Windows/Emulator/Codes.hs b/src/System/Console/ANSI/Windows/Emulator/Codes.hs deleted file mode 100644 --- a/src/System/Console/ANSI/Windows/Emulator/Codes.hs +++ /dev/null @@ -1,131 +0,0 @@ -#include "Common-Safe-Haskell.hs" -{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Windows.Emulator.Codes - ( - -- * Cursor movement by character - cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode - - -- * Cursor movement by line - , cursorUpLineCode, cursorDownLineCode - - -- * Directly changing cursor position - , setCursorColumnCode, setCursorPositionCode - - -- * Saving, restoring and reporting cursor position - , saveCursorCode, restoreCursorCode, reportCursorPositionCode - - -- * Clearing parts of the screen - , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode - , clearScreenCode, clearFromCursorToLineEndCode - , clearFromCursorToLineBeginningCode, clearLineCode - - -- * Scrolling the screen - , scrollPageUpCode, scrollPageDownCode - - -- * Using screen buffers - , useAlternateScreenBufferCode, useNormalScreenBufferCode - - -- * Reporting background and foreground colors - , reportLayerColorCode - - -- * Select Graphic Rendition mode: colors and other whizzy stuff - , setSGRCode - - -- * Cursor visibilty changes - , hideCursorCode, showCursorCode - - -- * Hyperlinks - , hyperlinkCode, hyperlinkWithIdCode, hyperlinkWithParamsCode - - -- * Changing the title - , setTitleCode - ) where - -import System.Console.ANSI.Types - -cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode - :: Int -- ^ Number of lines or characters to move - -> String -cursorUpCode _ = "" -cursorDownCode _ = "" -cursorForwardCode _ = "" -cursorBackwardCode _ = "" - -cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move - -> String -cursorDownLineCode _ = "" -cursorUpLineCode _ = "" - -setCursorColumnCode :: Int -- ^ 0-based column to move to - -> String -setCursorColumnCode _ = "" - -setCursorPositionCode :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> String -setCursorPositionCode _ _ = "" - -saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String -saveCursorCode = "" -restoreCursorCode = "" -reportCursorPositionCode = "" - -clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, - clearScreenCode :: String -clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, - clearLineCode :: String - -clearFromCursorToScreenEndCode = "" -clearFromCursorToScreenBeginningCode = "" -clearScreenCode = "" -clearFromCursorToLineEndCode = "" -clearFromCursorToLineBeginningCode = "" -clearLineCode = "" - -scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by - -> String -scrollPageUpCode _ = "" -scrollPageDownCode _ = "" - -useAlternateScreenBufferCode, useNormalScreenBufferCode :: String -useAlternateScreenBufferCode = "" -useNormalScreenBufferCode = "" - -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 - -- left to right. - -> String -setSGRCode _ = "" - -hideCursorCode, showCursorCode :: String -hideCursorCode = "" -showCursorCode = "" - -hyperlinkWithParamsCode - :: ([(String, String)]) - -> String - -> String - -> String -hyperlinkWithParamsCode _ _ _ = "" - -hyperlinkCode - :: String - -> String - -> String -hyperlinkCode _ _ = "" - -hyperlinkWithIdCode - :: String - -> String - -> String - -> String -hyperlinkWithIdCode _ _ _ = "" - -setTitleCode :: String -- ^ New title - -> String -setTitleCode _ = "" diff --git a/src/System/Console/ANSI/Windows/Foreign.hs b/src/System/Console/ANSI/Windows/Foreign.hs deleted file mode 100644 --- a/src/System/Console/ANSI/Windows/Foreign.hs +++ /dev/null @@ -1,731 +0,0 @@ -#include "Common-Safe-Haskell.hs" -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} - -{-| "System.Win32.Console" is really very impoverished, so I have had to do all -the FFI myself. --} -module System.Console.ANSI.Windows.Foreign - ( - -- Re-exports from Win32.Types - BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, - - -- 'Re-exports from System.Win32.Console.Extra' - INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT, - KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput, - getNumberOfConsoleInputEvents, readConsoleInput, - - charToWCHAR, cWcharsToChars, - - 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, - - eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, - - fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, - fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, - bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, - bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, - cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, - - getStdHandle, - getConsoleScreenBufferInfo, - getConsoleScreenBufferInfoEx, - getConsoleCursorInfo, - getConsoleMode, - - setConsoleTextAttribute, - setConsoleCursorPosition, - setConsoleCursorInfo, - setConsoleTitle, - setConsoleMode, - - fillConsoleOutputAttribute, - fillConsoleOutputCharacter, - scrollConsoleScreenBuffer, - - withTString, withHandleToHANDLE, - - ConsoleException (..) - ) where - -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, pokeArray, withArrayLen) -import Foreign.Marshal.Utils (maybeWith, with) -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, ULONG, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, - nullHANDLE, withHandleToHANDLE, withTString) - -#if defined(i386_HOST_ARCH) -#define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -#define WINDOWS_CCONV ccall -#else -#error Unknown mingw32 arch -#endif - -type WCHAR = CWchar - -charToWCHAR :: Char -> WCHAR -charToWCHAR char = fromIntegral (ord char) - --- This is a FFI hack. Some of the API calls take a Coord, but that isn't a --- built-in FFI type so I can't use it directly. Instead, I use UNPACKED_COORD --- and marshal COORDs into this manually. Note that we CAN'T just use two SHORTs --- directly because they get expanded to 4 bytes each instead of just boing 2 --- lots of 2 bytes by the stdcall convention, so linking fails. -type UNPACKED_COORD = CInt - --- Field packing order determined experimentally: I couldn't immediately find a --- specification for Windows struct layout anywhere. -unpackCOORD :: COORD -> UNPACKED_COORD -unpackCOORD (COORD x y) - = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) - - -peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) -peekAndOffset ptr = do - item <- peek ptr - pure (item, ptr `plusPtr` sizeOf item) - -pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) -pokeAndOffset ptr item = do - poke ptr item - pure (ptr `plusPtr` sizeOf item) - -data COORD = COORD - { coord_x :: SHORT - , coord_y :: SHORT - } deriving (Read, Eq) - -instance Show COORD where - show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" - -instance Storable COORD where - sizeOf ~(COORD x y) = sizeOf x + sizeOf y - alignment ~(COORD x _) = alignment x - peek ptr = do - let ptr' = castPtr ptr :: Ptr SHORT - x <- peekElemOff ptr' 0 - y <- peekElemOff ptr' 1 - pure (COORD x y) - poke ptr (COORD x y) = do - let ptr' = castPtr ptr :: Ptr SHORT - pokeElemOff ptr' 0 x - pokeElemOff ptr' 1 y - -data SMALL_RECT = SMALL_RECT - { rect_top_left :: COORD - , rect_bottom_right :: COORD - } - -rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT -rect_top = coord_y . rect_top_left -rect_left = coord_x . rect_top_left -rect_bottom = coord_y . rect_bottom_right -rect_right = coord_x . rect_bottom_right - -rect_width, rect_height :: SMALL_RECT -> SHORT -rect_width rect = rect_right rect - rect_left rect + 1 -rect_height rect = rect_bottom rect - rect_top rect + 1 - -instance Show SMALL_RECT where - show (SMALL_RECT tl br) = show tl ++ "-" ++ show br - -instance Storable SMALL_RECT where - sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br - alignment ~(SMALL_RECT tl _) = alignment tl - peek ptr = do - let ptr' = castPtr ptr :: Ptr COORD - tl <- peekElemOff ptr' 0 - br <- peekElemOff ptr' 1 - pure (SMALL_RECT tl br) - poke ptr (SMALL_RECT tl br) = do - let ptr' = castPtr ptr :: Ptr COORD - pokeElemOff ptr' 0 tl - pokeElemOff ptr' 1 br - -data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO - { cci_cursor_size :: DWORD - , cci_cursor_visible :: BOOL - } deriving (Show) - -instance Storable CONSOLE_CURSOR_INFO where - sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible - alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size - peek ptr = do - (size, ptr') <- peekAndOffset (castPtr ptr) - visible <- peek ptr' - pure (CONSOLE_CURSOR_INFO size visible) - poke ptr (CONSOLE_CURSOR_INFO size visible) = do - ptr' <- pokeAndOffset (castPtr ptr) size - poke ptr' visible - -data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO - { csbi_size :: COORD - , csbi_cursor_position :: COORD - , csbi_attributes :: WORD - , csbi_window :: SMALL_RECT - , csbi_maximum_window_size :: COORD - } deriving (Show) - -instance Storable CONSOLE_SCREEN_BUFFER_INFO where - sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO - size cursor_position attributes window maximum_window_size) - = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window - + sizeOf maximum_window_size - alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size - peek ptr = do - (size, ptr1) <- peekAndOffset (castPtr ptr) - (cursor_position, ptr2) <- peekAndOffset ptr1 - (attributes, ptr3) <- peekAndOffset ptr2 - (window, ptr4) <- peekAndOffset ptr3 - maximum_window_size <- peek ptr4 - pure (CONSOLE_SCREEN_BUFFER_INFO - size cursor_position attributes window maximum_window_size) - poke ptr (CONSOLE_SCREEN_BUFFER_INFO - size cursor_position attributes window maximum_window_size) - = do - ptr1 <- pokeAndOffset (castPtr ptr) size - ptr2 <- pokeAndOffset ptr1 cursor_position - ptr3 <- pokeAndOffset ptr2 attributes - 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 :: [COLORREF] - } deriving (Show) - --- 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 _) - = sizeOf sizeCsbix + sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window - + sizeOf maximum_window_size + sizeOf popup_attributes - + sizeOf fullscreen_supported + 16 * sizeOf (undefined :: COLORREF) - 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 <- peekArray 16 ptr7 - pure (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 - pokeArray ptr7 color_table' - where - color_table' = take 16 $ color_table ++ repeat 0 - -sizeCsbix :: ULONG -sizeCsbix = fromIntegral $ - sizeOf (undefined :: CONSOLE_SCREEN_BUFFER_INFOEX) - - -data CHAR_INFO = CHAR_INFO - { ci_char :: WCHAR - , ci_attributes :: WORD - } deriving (Show) - -instance Storable CHAR_INFO where - sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes - alignment ~(CHAR_INFO char _) = alignment char - peek ptr = do - (char, ptr') <- peekAndOffset (castPtr ptr) - attributes <- peek ptr' - pure (CHAR_INFO char attributes) - poke ptr (CHAR_INFO char attributes) = do - ptr' <- pokeAndOffset (castPtr ptr) char - poke ptr' attributes - -eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD -sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD -eNABLE_VIRTUAL_TERMINAL_INPUT = 512 -eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 -sTD_INPUT_HANDLE = 0xFFFFFFF6 -- minus 10 -sTD_OUTPUT_HANDLE = 0xFFFFFFF5 -- minus 11 -sTD_ERROR_HANDLE = 0xFFFFFFF4 -- minus 12 - -fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, - bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, - cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD -fOREGROUND_BLUE = 0x1 -fOREGROUND_GREEN = 0x2 -fOREGROUND_RED = 0x4 -fOREGROUND_INTENSITY = 0x8 -bACKGROUND_BLUE = 0x10 -bACKGROUND_GREEN = 0x20 -bACKGROUND_RED = 0x40 -bACKGROUND_INTENSITY = 0x80 -cOMMON_LVB_REVERSE_VIDEO = 0x4000 -cOMMON_LVB_UNDERSCORE = 0x8000 - -fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, - bACKGROUND_INTENSE_WHITE :: WORD -fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE -bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE -fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY -bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY - -kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, - fOCUS_EVENT :: WORD -kEY_EVENT = 1 -mOUSE_EVENT = 2 -wINDOW_BUFFER_SIZE_EVENT = 4 -mENU_EVENT = 8 -fOCUS_EVENT = 16 - -foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" - getStdHandle :: DWORD -> IO HANDLE -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" - cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute" - cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition" - cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo" - cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW" - cSetConsoleTitle :: LPCTSTR -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" - cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute" - cFillConsoleOutputAttribute :: HANDLE - -> WORD - -> DWORD - -> UNPACKED_COORD - -> Ptr DWORD - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" - cFillConsoleOutputCharacter :: HANDLE - -> TCHAR - -> DWORD - -> UNPACKED_COORD - -> Ptr DWORD - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" - cScrollConsoleScreenBuffer :: HANDLE - -> Ptr SMALL_RECT - -> Ptr SMALL_RECT - -> UNPACKED_COORD - -> Ptr CHAR_INFO - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW" - cWriteConsoleInput :: HANDLE - -> Ptr INPUT_RECORD - -> DWORD - -> LPDWORD - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents" - cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" - cReadConsoleInput :: HANDLE - -> Ptr INPUT_RECORD - -> DWORD - -> LPDWORD - -> IO BOOL - -data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) - -instance Show ConsoleException where - show (ConsoleException 6) = - "A fatal error has occurred.\n\n" ++ - "An attempt has been made to send console virtual terminal sequences\n" ++ - "(ANSI codes) to an output that has not been recognised as an\n" ++ - "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ - "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ - "Prompt or PowerShell). That may occur, for example, if output has\n" ++ - "been redirected to a file.\n\n" ++ - "If that is unexpected, please post an issue at:\n" ++ - "https://github.com/UnkindPartition/ansi-terminal/issues\n" - show (ConsoleException errCode) = "ConsoleException " ++ show errCode - -instance Exception ConsoleException - -throwIfFalse :: IO Bool -> IO () -throwIfFalse action = do - succeeded <- action - if not succeeded - then getLastError >>= throw . ConsoleException -- TODO: Check if last error - -- is zero for some instructable reason (?) - else pure () - -getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO -getConsoleScreenBufferInfo handle - = alloca $ \ptr_console_screen_buffer_info -> do - throwIfFalse $ - 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 - peek ptr_console_cursor_info - -getConsoleMode :: HANDLE -> IO DWORD -getConsoleMode handle = alloca $ \ptr_mode -> do - throwIfFalse $ cGetConsoleMode handle ptr_mode - peek ptr_mode - -setConsoleTextAttribute :: HANDLE -> WORD -> IO () -setConsoleTextAttribute handle attributes - = throwIfFalse $ cSetConsoleTextAttribute handle attributes - -setConsoleCursorPosition :: HANDLE -> COORD -> IO () -setConsoleCursorPosition handle cursor_position - = throwIfFalse $ cSetConsoleCursorPosition handle - (unpackCOORD cursor_position) - -setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () -setConsoleCursorInfo handle console_cursor_info - = with console_cursor_info $ \ptr_console_cursor_info -> do - throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info - -setConsoleTitle :: LPCTSTR -> IO () -setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title - -setConsoleMode :: HANDLE -> DWORD -> IO () -setConsoleMode handle attributes - = throwIfFalse $ cSetConsoleMode handle attributes - -fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD -fillConsoleOutputAttribute handle attribute fill_length write_origin - = alloca $ \ptr_chars_written -> do - throwIfFalse $ cFillConsoleOutputAttribute handle attribute - fill_length (unpackCOORD write_origin) ptr_chars_written - peek ptr_chars_written - -fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD -fillConsoleOutputCharacter handle char fill_length write_origin - = alloca $ \ptr_chars_written -> do - throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length - (unpackCOORD write_origin) ptr_chars_written - peek ptr_chars_written - -scrollConsoleScreenBuffer :: HANDLE - -> SMALL_RECT - -> Maybe SMALL_RECT - -> COORD - -> CHAR_INFO - -> IO () -scrollConsoleScreenBuffer - handle scroll_rectangle mb_clip_rectangle destination_origin fill - = with scroll_rectangle $ \ptr_scroll_rectangle -> - maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> - with fill $ \ptr_fill -> - throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle - ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill - --- The following is based on module System.Win32.Console.Extra from package --- Win32-console, cut down for the WCHAR version of writeConsoleInput. - -writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD -writeConsoleInput hdl evs - = writeConsoleInputWith hdl $ \act -> - withArrayLen evs $ \len ptr -> - act (ptr, toEnum len) - -writeConsoleInputWith :: HANDLE - -> InputHandler (Ptr INPUT_RECORD, DWORD) - -> IO DWORD -writeConsoleInputWith hdl withBuffer - = returnWith_ $ \ptrN -> - withBuffer $ \(ptrBuf, len) -> - failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN - -returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a -returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr - -type InputHandler i = forall a. (i -> IO a) -> IO a - -{- -typedef union _UNICODE_ASCII_CHAR { - WCHAR UnicodeChar; - CHAR AsciiChar; -} UNICODE_ASCII_CHAR; --} -newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar - { unicodeAsciiChar :: WCHAR - } deriving (Show, Read, Eq) - -instance Storable UNICODE_ASCII_CHAR where - sizeOf _ = 2 - alignment _ = 2 - peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr - poke ptr val = case val of - UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c - -{- -typedef struct _KEY_EVENT_RECORD { - BOOL bKeyDown; - WORD wRepeatCount; - WORD wVirtualKeyCode; - WORD wVirtualScanCode; - union { - WCHAR UnicodeChar; - CHAR AsciiChar; - } uChar; - DWORD dwControlKeyState; -} -#ifdef __GNUC__ -/* gcc's alignment is not what win32 expects */ - PACKED -#endif -KEY_EVENT_RECORD; --} -data KEY_EVENT_RECORD = KEY_EVENT_RECORD - { keyEventKeyDown :: BOOL - , keyEventRepeatCount :: WORD - , keyEventVirtualKeyCode :: WORD - , keyEventVirtualScanCode :: WORD - , keyEventChar :: UNICODE_ASCII_CHAR - , keyEventControlKeystate :: DWORD - } deriving (Show, Read, Eq) - -instance Storable KEY_EVENT_RECORD where - sizeOf _ = 16 - alignment _ = 4 - peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr - <*> (`peekByteOff` 4) ptr - <*> (`peekByteOff` 6) ptr - <*> (`peekByteOff` 8) ptr - <*> (`peekByteOff` 10) ptr - <*> (`peekByteOff` 12) ptr - poke ptr val = do - (`pokeByteOff` 0) ptr $ keyEventKeyDown val - (`pokeByteOff` 4) ptr $ keyEventRepeatCount val - (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val - (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val - (`pokeByteOff` 10) ptr $ keyEventChar val - (`pokeByteOff` 12) ptr $ keyEventControlKeystate val - -{- -typedef struct _MOUSE_EVENT_RECORD { - COORD dwMousePosition; - DWORD dwButtonState; - DWORD dwControlKeyState; - DWORD dwEventFlags; -} MOUSE_EVENT_RECORD; --} -data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD - { mousePosition :: COORD - , mouseButtonState :: DWORD - , mouseControlKeyState :: DWORD - , mouseEventFlags :: DWORD - } deriving (Show, Read, Eq) - -instance Storable MOUSE_EVENT_RECORD where - sizeOf _ = 16 - alignment _ = 4 - peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr - <*> (`peekByteOff` 4) ptr - <*> (`peekByteOff` 8) ptr - <*> (`peekByteOff` 12) ptr - poke ptr val = do - (`pokeByteOff` 0) ptr $ mousePosition val - (`pokeByteOff` 4) ptr $ mouseButtonState val - (`pokeByteOff` 8) ptr $ mouseControlKeyState val - (`pokeByteOff` 12) ptr $ mouseEventFlags val - -{- -typedef struct _WINDOW_BUFFER_SIZE_RECORD { - COORD dwSize; -} WINDOW_BUFFER_SIZE_RECORD; --} -data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD - { bufSizeNew :: COORD - } deriving (Show, Read, Eq) - -instance Storable WINDOW_BUFFER_SIZE_RECORD where - sizeOf _ = 4 - alignment _ = 4 - peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr - poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val - -{- -typedef struct _MENU_EVENT_RECORD { - UINT dwCommandId; -} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; --} -data MENU_EVENT_RECORD = MENU_EVENT_RECORD - { menuCommandId :: UINT - } deriving (Show, Read, Eq) - -instance Storable MENU_EVENT_RECORD where - sizeOf _ = 4 - alignment _ = 4 - peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr - poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val - -{- -typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; --} -data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD - { focusSetFocus :: BOOL - } deriving (Show, Read, Eq) - -instance Storable FOCUS_EVENT_RECORD where - sizeOf _ = 4 - alignment _ = 4 - peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr - poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val - -data INPUT_RECORD_EVENT - = InputKeyEvent KEY_EVENT_RECORD - | InputMouseEvent MOUSE_EVENT_RECORD - | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD - | InputMenuEvent MENU_EVENT_RECORD - | InputFocusEvent FOCUS_EVENT_RECORD - deriving (Show, Read, Eq) - -{- -typedef struct _INPUT_RECORD { - WORD EventType; - union { - KEY_EVENT_RECORD KeyEvent; - MOUSE_EVENT_RECORD MouseEvent; - WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; - MENU_EVENT_RECORD MenuEvent; - FOCUS_EVENT_RECORD FocusEvent; - } Event; -} INPUT_RECORD,*PINPUT_RECORD; --} -data INPUT_RECORD = INPUT_RECORD - { inputEventType :: WORD - , inputEvent :: INPUT_RECORD_EVENT - } deriving (Show, Read, Eq) - -instance Storable INPUT_RECORD where - sizeOf _ = 20 - alignment _ = 4 - peek ptr = do - evType <- (`peekByteOff` 0) ptr - event <- case evType of - _ | evType == kEY_EVENT - -> InputKeyEvent <$> (`peekByteOff` 4) ptr - _ | evType == mOUSE_EVENT - -> InputMouseEvent <$> (`peekByteOff` 4) ptr - _ | evType == wINDOW_BUFFER_SIZE_EVENT - -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr - _ | evType == mENU_EVENT - -> InputMenuEvent <$> (`peekByteOff` 4) ptr - _ | evType == fOCUS_EVENT - -> InputFocusEvent <$> (`peekByteOff` 4) ptr - _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ - show evType - pure $ INPUT_RECORD evType event - poke ptr val = do - (`pokeByteOff` 0) ptr $ inputEventType val - case inputEvent val of - InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev - InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev - InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev - InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev - InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev - --- The following is based on module System.Win32.Console.Extra from package --- Win32-console. - -getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD -getNumberOfConsoleInputEvents hdl = - returnWith_ $ \ptrN -> - failIfFalse_ "GetNumberOfConsoleInputEvents" $ - cGetNumberOfConsoleInputEvents hdl ptrN - --- The following is based on module System.Win32.Console.Extra from package --- Win32-console, cut down for the WCHAR version of readConsoleInput. - -readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] -readConsoleInput hdl len - = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr - -readConsoleInputWith :: HANDLE - -> DWORD - -> OutputHandler (Ptr INPUT_RECORD, DWORD) -readConsoleInputWith hdl len handler = - allocaArray (fromEnum len) $ \ptrBuf -> - alloca $ \ptrN -> do - failIfFalse_ "ReadConsoleInputW" $ - cReadConsoleInput hdl ptrBuf len ptrN - n <- peek ptrN - handler (ptrBuf, n) - -type OutputHandler o = forall a. (o -> IO a) -> IO a - --- Replicated from module Foreign.C.String in package base because that module --- does not export the function. -cWcharsToChars :: [CWchar] -> [Char] -cWcharsToChars = map chr . fromUTF16 . map fromIntegral - where - fromUTF16 (c1:c2:wcs) - | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = - ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs - fromUTF16 (c:wcs) = c : fromUTF16 wcs - fromUTF16 [] = [] diff --git a/src/System/Win32/Compat.hs b/src/System/Win32/Compat.hs deleted file mode 100644 --- a/src/System/Win32/Compat.hs +++ /dev/null @@ -1,178 +0,0 @@ -#include "Common-Safe-Haskell.hs" -{-# OPTIONS_HADDOCK hide #-} - -{-| The Win32 library ships with GHC. Win32-2.3.1.0 first shipped with -GHC 7.10.1 (released March 2015). Win32-2.5.4.1 first shipped with GHC 8.2.1 -(released July 2017), replacing Win32-2.3.1.1. - -The ansi-terminal library makes use of functionality in Win32-2.3.1.0 and other -functionality first added to Win32-2.5.0.0 or Win32-2.5.1.0 (from ansi-terminal -itself). - -Win32-2.9.0.0 introduced support for the Windows I/O Manager, introduced with -GHC 9.0.1. However, before Win32-2.13.2.0, this changed the behaviour of -`withHandleFromHANDLE`. - -This module provides functions available in those later versions of Win32 to a -wider range of compilers, reducing the use of CPP pragmas in other modules. --} -module System.Win32.Compat - ( - BOOL - , DWORD - , ErrCode - , HANDLE - , LPCTSTR - , LPDWORD - , SHORT -- from Win32-2.5.0.0 - , TCHAR - , UINT - , ULONG -- from Win32-2.5.0.0 - , WORD - , failIfFalse_ - , getLastError - , iNVALID_HANDLE_VALUE - , nullHANDLE - , withHandleToHANDLE -- from Win32-2.5.1.0 - , withTString - ) where - -import System.Win32.Types (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, - TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, - nullHANDLE, withTString) - --- Circumstancees in which the patching of Win32 package for the Windows I/O --- Manager is required -#if defined(__IO_MANAGER_WINIO__)&&MIN_VERSION_Win32(2,9,0)&&!MIN_VERSION_Win32(2,13,2) -#define PATCHING_WIN32_PACKAGE_FOR_WINIO -#endif - --- Circumstances in which the patching of Win32 package is required -#if !MIN_VERSION_Win32(2,5,1)||defined(PATCHING_WIN32_PACKAGE_FOR_WINIO) -#define PATCHING_WIN32_PACKAGE -#endif - -#if !defined(PATCHING_WIN32_PACKAGE) - -import System.Win32.Types (SHORT, ULONG, withHandleToHANDLE) - -#else - -import Control.Concurrent.MVar (readMVar) -import Control.Exception (bracket) -import Data.Typeable (cast) -import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) -import GHC.IO.Handle.Types (Handle (..), Handle__ (..)) - -#if defined(PATCHING_WIN32_PACKAGE_FOR_WINIO) -import GHC.IO.Exception (IOErrorType (InappropriateType), IOException (IOError), - ioException) -import GHC.IO.SubSystem (()) -import GHC.IO.Windows.Handle (ConsoleHandle, Io, NativeHandle, toHANDLE) -import System.Win32.Types (withHandleToHANDLEPosix) -#endif - -#if !MIN_VERSION_Win32(2,5,0) -import Foreign.C.Types (CShort (..)) -import Data.Word (Word32) -#else -import System.Win32.Types (SHORT, ULONG) -#endif - -#if !MIN_VERSION_Win32(2,5,1) -import Foreign.C.Types (CInt (..)) -import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 -#endif - -#endif - -#if defined(PATCHING_WIN32_PACKAGE) - -#if !MIN_VERSION_Win32(2,5,0) -type SHORT = CShort -type ULONG = Word32 -#endif - -withStablePtr :: a -> (StablePtr a -> IO b) -> IO b -withStablePtr value = bracket (newStablePtr value) freeStablePtr - -#if defined(PATCHING_WIN32_PACKAGE_FOR_WINIO) - -withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a -withHandleToHANDLE = withHandleToHANDLEPosix withHandleToHANDLENative - --- | `withHandleToHANDLENative` does not behave as expected for GHC option --- -with-rtsopts=--io-manager=native when Win32 < 2.13.2. Taken from --- package Win32-2.13.2.0 `System.Win32.Types.withHandleToHANDLENative`. - -withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a -withHandleToHANDLENative haskell_handle action = - withStablePtr haskell_handle $ const $ do - let write_handle_mvar = case haskell_handle of - FileHandle _ handle_mvar -> handle_mvar - DuplexHandle _ _ handle_mvar -> handle_mvar - windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE - action windows_handle - where - handle_ToHANDLE :: Handle__ -> IO HANDLE - handle_ToHANDLE (Handle__{haDevice = dev}) = - case ( cast dev :: Maybe (Io NativeHandle) - , cast dev :: Maybe (Io ConsoleHandle)) of - (Just hwnd, Nothing) -> pure $ toHANDLE hwnd - (Nothing, Just hwnd) -> pure $ toHANDLE hwnd - _ -> throwErr "not a known HANDLE" - - throwErr msg = ioException $ IOError (Just haskell_handle) - InappropriateType "withHandleToHANDLENative" msg Nothing Nothing - --- defined(__IO_MANAGER_WINIO__)&&!MIN_VERSION_Win32(2,13,2) -#else - --- | This bit is all highly dubious. The problem is that we want to output ANSI --- to arbitrary Handles rather than forcing people to use stdout. However, the --- Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need --- to be able to extract one of those from the Haskell Handle. --- --- This code accomplishes this, albeit at the cost of only being compatible with --- GHC. -withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a -withHandleToHANDLE haskell_handle action = - -- Create a stable pointer to the Handle. This prevents the garbage collector - -- getting to it while we are doing horrible manipulations with it, and hence - -- stops it being finalized (and closed). - withStablePtr haskell_handle $ const $ do - -- Grab the write handle variable from the Handle - let write_handle_mvar = case haskell_handle of - FileHandle _ handle_mvar -> handle_mvar - DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, - -- we could also take the "read" one - - -- Get the FD from the algebraic data type - Just fd <- fmap (\(Handle__ { haDevice = dev }) -> - fmap fdFD (cast dev)) $ readMVar write_handle_mvar - - -- Finally, turn that (C-land) FD into a HANDLE using msvcrt - windows_handle <- cget_osfhandle fd - - -- Do what the user originally wanted - action windows_handle - -#if defined(i386_HOST_ARCH) -#define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -#define WINDOWS_CCONV ccall -#else -#error Unknown mingw32 arch -#endif - --- This essential function comes from the C runtime system. It is certainly --- provided by msvcrt, and also seems to be provided by the mingw C library - --- hurrah! -foreign import WINDOWS_CCONV unsafe "_get_osfhandle" - cget_osfhandle :: CInt -> IO HANDLE - --- defined(PATCHING_WIN32_PACKAGE_FOR_WINIO) -#endif - --- defined(PATCHING_WIN32_PACKAGE) -#endif diff --git a/src/includes/Common-Include-Emulator.hs b/src/includes/Common-Include-Emulator.hs deleted file mode 100644 --- a/src/includes/Common-Include-Emulator.hs +++ /dev/null @@ -1,61 +0,0 @@ --- This file contains code that is required in the case of the module --- System.Console.ANSI.Windows.Emulator and differs from the common code in --- file Common-Include-Enabled.hs. - --- | Set the Select Graphic Rendition mode -hSetSGR - :: ConsoleDefaultState -- ^ The default console state - -> Handle - -> [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. - -> IO () - --- | Set the Select Graphic Rendition mode -setSGR - :: ConsoleDefaultState -- ^ The default console state - -> [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. - -> IO () -setSGR def = hSetSGR def stdout - -hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen - :: ConsoleDefaultState -- ^ The default console state - -> Handle - -> IO () - -clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen - :: ConsoleDefaultState -- ^ The default console state - -> IO () -clearFromCursorToScreenEnd def = hClearFromCursorToScreenEnd def stdout -clearFromCursorToScreenBeginning def - = hClearFromCursorToScreenBeginning def stdout -clearScreen def = hClearScreen def stdout - -hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine - :: ConsoleDefaultState -- ^ The default console state - -> Handle - -> IO () - -clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine - :: ConsoleDefaultState -- ^ The default console state - -> IO () -clearFromCursorToLineEnd def = hClearFromCursorToLineEnd def stdout -clearFromCursorToLineBeginning def = hClearFromCursorToLineBeginning def stdout -clearLine def = hClearLine def stdout - -hScrollPageUp, hScrollPageDown - :: ConsoleDefaultState -- ^ The default console state - -> Handle - -> Int -- ^ Number of lines to scroll by - -> IO () - -scrollPageUp, scrollPageDown - :: ConsoleDefaultState -- ^ The default console state - -> Int -- ^ Number of lines to scroll by - -> IO () -scrollPageUp def = hScrollPageUp def stdout -scrollPageDown def = hScrollPageDown def stdout diff --git a/src/includes/Common-Include-Enabled.hs b/src/includes/Common-Include-Enabled.hs deleted file mode 100644 --- a/src/includes/Common-Include-Enabled.hs +++ /dev/null @@ -1,52 +0,0 @@ --- This file contains code that is common save that different code is required --- 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 -hSetSGR - :: Handle - -> [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. - -> IO () - --- | Set the Select Graphic Rendition mode -setSGR - :: [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. - -> IO () -setSGR = hSetSGR stdout - -hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen - :: Handle - -> IO () - -clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen - :: IO () -clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout -clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout -clearScreen = hClearScreen stdout - -hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine - :: Handle - -> IO () - -clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine - :: IO () -clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout -clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout -clearLine = hClearLine stdout - -hScrollPageUp, hScrollPageDown - :: Handle - -> Int -- Number of lines to scroll by - -> IO () - -scrollPageUp, scrollPageDown - :: Int -- ^ Number of lines to scroll by - -> IO () -scrollPageUp = hScrollPageUp stdout -scrollPageDown = hScrollPageDown stdout diff --git a/src/includes/Common-Include.hs b/src/includes/Common-Include.hs deleted file mode 100644 --- a/src/includes/Common-Include.hs +++ /dev/null @@ -1,542 +0,0 @@ --- 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 --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, including the related Haddock --- documentation. - -import Control.Monad (void) -import Data.Char (digitToInt, isDigit, isHexDigit) -import Data.Word (Word16) -import System.Environment (getEnvironment) -import System.IO (hFlush, stdout) -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 - -> IO () -cursorUp, cursorDown, cursorForward, cursorBackward - :: Int -- ^ Number of lines or characters to move - -> IO () -cursorUp = hCursorUp stdout -cursorDown = hCursorDown stdout -cursorForward = hCursorForward stdout -cursorBackward = hCursorBackward stdout - -hCursorDownLine, hCursorUpLine :: Handle - -> Int -- Number of lines to move - -> IO () -cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move - -> IO () -cursorDownLine = hCursorDownLine stdout -cursorUpLine = hCursorUpLine stdout - -hSetCursorColumn :: Handle - -> Int -- 0-based column to move to - -> IO () - --- | Move the cursor to the specified column. The column numbering is 0-based --- (that is, the left-most column is numbered 0). -setCursorColumn :: Int -- ^ 0-based column to move to - -> IO () -setCursorColumn = hSetCursorColumn stdout - -hSetCursorPosition :: Handle - -> 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 --- 0-based (that is, the top-left corner is at row 0 column 0). -setCursorPosition :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> IO () -setCursorPosition = hSetCursorPosition stdout - -hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () - --- | Save the cursor position in memory. The only way to access the saved value --- is with the 'restoreCursor' command. --- --- @since 0.7.1 -saveCursor :: IO () - --- | Restore the cursor position from memory. There will be no value saved in --- memory until the first use of the 'saveCursor' command. --- --- @since 0.7.1 -restoreCursor :: IO () - --- | Looking for a way to get the cursors position? See --- 'getCursorPosition'. --- --- Emit the cursor position into the console input stream, immediately after --- being recognised on the output stream, as: --- @ESC [ \ ; \ R@ --- --- Note that the information that is emitted is 1-based (the top-left corner is --- at row 1 column 1) but 'setCursorColumn' and 'setCursorPosition' are --- 0-based. --- --- 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. --- --- @since 0.7.1 -reportCursorPosition :: IO () - -saveCursor = hSaveCursor stdout -restoreCursor = hRestoreCursor stdout -reportCursorPosition = hReportCursorPosition stdout - -hHideCursor, hShowCursor :: Handle - -> IO () -hideCursor, showCursor :: IO () -hideCursor = hHideCursor stdout -showCursor = hShowCursor stdout - -hUseAlternateScreenBuffer - :: Handle - -> IO () - -hUseNormalScreenBuffer - :: Handle - -> IO () - --- | Use the Alternate Screen Buffer. If currently using the Normal Screen --- Buffer, it will save the cursor position and switch to the Alternate Screen --- Buffer. It will always clear the Alternate Screen Buffer. The Alternate --- Screen Buffer has no scroll back facility. --- --- It is an application's responsibility to ensure that it switches back to the --- Normal Screen Buffer if an exception is raised while the Alternate Screen --- Buffer is being used. For example, by using 'Control.Exception.bracket_': --- --- > bracket_ useAlternateScreenBuffer useNormalScreenBuffer action --- --- @since 0.11.4 -useAlternateScreenBuffer - :: IO () -useAlternateScreenBuffer = hUseAlternateScreenBuffer stdout - --- | Use the Normal Screen Buffer. If currently using the Alternate Screen --- Buffer, it will clear the Alternate Screen Buffer, and switch to the Normal --- Screen Buffer. It will always restore the saved cursor position. --- --- @since 0.11.4 -useNormalScreenBuffer - :: IO () -useNormalScreenBuffer = hUseNormalScreenBuffer stdout - --- 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 - -> IO () - --- | 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 -hyperlinkWithParams - :: [(String, String)] -- ^ Parameters - -> String -- ^ URI - -> String -- ^ Link text - -> IO () -hyperlinkWithParams = hHyperlinkWithParams stdout - --- Introduce a hyperlink. --- --- @since 0.11.3 -hHyperlink - :: Handle - -> String -- URI - -> String -- Link text - -> IO () -hHyperlink h = hHyperlinkWithParams h [] - --- | Introduce a hyperlink. --- --- @since 0.11.3 -hyperlink - :: String -- ^ URI - -> String -- ^ Link text - -> IO () -hyperlink = hHyperlink stdout - --- 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 - -> IO () -hHyperlinkWithId h linkId = hHyperlinkWithParams h [("id", linkId)] - --- | 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 -hyperlinkWithId - :: String -- ^ Identifier for the link - -> String -- ^ URI - -> String -- ^ Link text - -> IO () -hyperlinkWithId = hHyperlinkWithId stdout - --- 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 - -> IO () --- | Set the terminal window title and icon name (that is, the text for the --- window in the Start bar, or similar). -setTitle :: String -- ^ New window title and icon name - -> IO () -setTitle = hSetTitle stdout - --- | Use heuristics to determine whether the functions defined in this --- package will work with a given handle. This function assumes that the handle --- is writable (that is, it manages output - see 'hIsWritable'). --- --- For Unix-like operating systems, the current implementation checks --- that: (1) the handle is a terminal; and (2) a @TERM@ --- environment variable is not set to @dumb@ (which is what the GNU Emacs text --- editor sets for its integrated terminal). --- --- For Windows, the current implementation performs the same checks as for --- Unix-like operating systems and, as an alternative, checks whether the --- handle is connected to a \'mintty\' terminal. (That is because the function --- 'hIsTerminalDevice' is used to check if the handle is a --- terminal. However, where a non-native Windows terminal (such as \'mintty\') --- is implemented using redirection, that function will not identify a --- handle to the terminal as a terminal.) On Windows 10, if the handle is --- identified as connected to a native terminal, this function does /not/ enable --- the processing of \'ANSI\' control characters in output (see --- 'hSupportsANSIWithoutEmulation'). --- --- @since 0.6.2 -hSupportsANSI :: Handle -> IO Bool - --- | Some terminals (e.g. Emacs) are not fully ANSI compliant but can support --- ANSI colors. This can be used in such cases, if colors are all that is --- needed. --- --- @since 0.9 -hSupportsANSIColor :: Handle -> IO Bool -hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm - where - isEmacsTerm = (\env -> (insideEmacs env) && (isDumb env)) <$> getEnvironment - insideEmacs env = any (\(k, _) -> k == "INSIDE_EMACS") env - isDumb env = Just "dumb" == lookup "TERM" env - --- | Use heuristics to determine whether a given handle will support \'ANSI\' --- control characters in output. (On Windows versions before Windows 10, that --- means \'support without emulation\'.) --- --- If the handle is not writable (that is, it cannot manage output - see --- 'hIsWritable'), then @pure (Just False)@ is returned. --- --- On Unix-like operating systems, with one exception, the function is --- consistent with 'hSupportsANSI'. The exception is if the handle is not --- writable. --- --- On Windows, what is returned will depend on what the handle is connected to --- and the version of the operating system. If the handle is identified as --- connected to a \'mintty\' terminal, @pure (Just True)@ is --- returned. If it is identified as connected to a native terminal, then, on --- Windows 10, the processing of \'ANSI\' control characters will be enabled and --- @pure (Just True)@ returned; and, on versions of Windows before Windows 10, --- @pure (Just False)@ is returned. Otherwise, if a @TERM@ environment --- variable is set to @dumb@, @pure (Just False)@ is returned. In all other --- cases of a writable handle, @pure Nothing@ is returned; this indicates that --- the heuristics cannot assist - the handle may be connected to a file or --- to another type of terminal. --- --- @since 0.8.1 -hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) - --- | Parses the characters emitted by 'reportCursorPosition' into the console --- input stream. Returns the cursor row and column as a tuple. --- --- For example, if the characters emitted by 'reportCursorPosition' are in --- 'String' @input@ then the parser could be applied like this: --- --- > let result = readP_to_S cursorPosition input --- > case result of --- > [] -> putStrLn $ "Error: could not parse " ++ show input --- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row --- > ++ " and column" ++ show column ++ "." --- > (_:_) -> putStrLn $ "Error: parse not unique" --- --- @since 0.7.1 -cursorPosition :: ReadP (Int, Int) -cursorPosition = do - void $ char '\ESC' - void $ char '[' - row <- decimal -- A non-negative whole decimal number - void $ char ';' - col <- decimal -- A non-negative whole decimal number - void $ char 'R' - pure (read row, read col) - where - digit = satisfy isDigit - decimal = many1 digit - --- | Attempts to get the reported cursor position data from the console input --- stream. The function is intended to be called immediately after --- 'reportCursorPosition' (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 --- > reportCursorPosition --- > hFlush stdout -- ensure the report cursor position code is sent to the --- > -- operating system --- > getReportedCursorPosition --- --- 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.7.1 -getReportedCursorPosition :: IO String - --- | Attempts to get the reported cursor position, combining the functions --- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. Any --- position @(row, column)@ is translated to be 0-based (that is, the top-left --- corner is at @(0, 0)@), consistent with `setCursorColumn` and --- `setCursorPosition`. (Note that the information emitted into the console --- input stream by 'reportCursorPosition' is 1-based.) Returns 'Nothing' if any --- data emitted by 'reportCursorPosition', obtained by --- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'. Uses --- 'stdout'. If 'stdout' will be redirected, see 'hGetCursorPosition' 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.) --- --- @since 0.10.3 -getCursorPosition :: IO (Maybe (Int, Int)) -getCursorPosition = hGetCursorPosition stdout - --- | Attempts to get the reported cursor position, combining the functions --- 'hReportCursorPosition' (with the specified handle), --- 'getReportedCursorPosition' and 'cursorPosition'. Any position --- @(row, column)@ is translated to be 0-based (that is, the top-left corner is --- at @(0, 0)@), consistent with 'hSetCursorColumn' and 'hSetCursorPosition'. --- (Note that the information emitted into the console input stream by --- 'hReportCursorPosition' is 1-based.) Returns 'Nothing' if any data emitted by --- 'hReportCursorPosition', obtained by 'getReportedCursorPosition', cannot be --- parsed by 'cursorPosition'. --- --- 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.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 pure $ 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). --- --- There is no \'ANSI\' control character sequence that reports the terminal --- size. So, it attempts to set the cursor position beyond the bottom right --- corner of the terminal and then use 'getCursorPosition' to query the console --- input stream. It works only on terminals that support each step and if data --- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if --- 'stdin' is connected to a terminal.) Uses 'stdout'. If 'stdout' will be --- redirected, see 'System.IO.hGetTerminalSize' for a more general function. --- --- On Windows operating systems, the function is not supported on consoles, such --- as mintty, that are not based on Windows' Console API. (Command Prompt and --- PowerShell are based on the Console API.) --- --- For a different approach, one that does not use control character sequences --- and works when 'stdin' is redirected, see the --- package. --- --- @since 0.9 -getTerminalSize :: IO (Maybe (Int, Int)) -getTerminalSize = hGetTerminalSize stdout - --- | Attempts to get the current terminal size (height in rows, width in --- columns), by writing control character sequences to the specified handle --- (which will typically be 'stdout' or 'stderr'). --- --- There is no \'ANSI\' control character sequence that reports the terminal --- size. So, it attempts to set the cursor position beyond the bottom right --- corner of the terminal and then use 'hGetCursorPosition' to query the console --- input stream. It works only on terminals that support each step and if data --- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if --- 'stdin' is connected to a terminal.) --- --- 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.) --- --- For a different approach, one that does not use control character sequences --- and works when 'stdin' is redirected, see the --- package. --- --- @since 0.10.1 -hGetTerminalSize :: Handle -> IO (Maybe (Int, Int)) -hGetTerminalSize h = do - hSaveCursor h - hSetCursorPosition h 9999 9999 -- Attempt to set the cursor position beyond - -- the bottom right corner of the terminal. - mPos <- hGetCursorPosition h - hRestoreCursor h - hFlush h -- ensure the restore cursor position code is sent to the - -- operating system - pure $ fmap (\(r, c) -> (r + 1, c + 1)) mPos diff --git a/src/includes/Common-Safe-Haskell.hs b/src/includes/Common-Safe-Haskell.hs deleted file mode 100644 --- a/src/includes/Common-Safe-Haskell.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# LANGUAGE Safe #-} diff --git a/src/includes/Exports-Include.hs b/src/includes/Exports-Include.hs deleted file mode 100644 --- a/src/includes/Exports-Include.hs +++ /dev/null @@ -1,182 +0,0 @@ --- This file contains code that is common to modules --- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module --- exports and the associated Haddock documentation. - - -- * Basic data types - module System.Console.ANSI.Types - - -- * Cursor movement by character - , cursorUp - , cursorDown - , cursorForward - , cursorBackward - -- ** \'h...\' variants - , hCursorUp - , hCursorDown - , hCursorForward - , hCursorBackward - -- ** \'...Code\' variants - , cursorUpCode - , cursorDownCode - , cursorForwardCode - , cursorBackwardCode - - -- * Cursor movement by line - -- | The difference between movements \"by character\" and \"by line\" is - -- that @*Line@ functions additionally move the cursor to the start of the - -- line, while functions like @cursorUp@ and @cursorDown@ keep the column - -- the same. - , cursorUpLine - , cursorDownLine - -- ** \'h...\' variants - , hCursorUpLine - , hCursorDownLine - -- ** \'...Code\' variants - , cursorUpLineCode - , cursorDownLineCode - - -- * Directly changing cursor position - , setCursorColumn - , setCursorPosition - -- ** \'h...\' variants - , hSetCursorColumn - , hSetCursorPosition - -- ** \'...Code\' variants - , setCursorColumnCode - , setCursorPositionCode - - -- * Saving, restoring and reporting cursor position - -- | These code sequences are not part of the ECMA-48 standard; they are - -- popular, but non-portable extensions. On Unix-like operating systems, - -- they correspond to @rc@ and @sc@ capabilities in the @terminfo@ database. - -- - -- Cursor positions are relative to the viewport, not to its content. - -- - , saveCursor - , restoreCursor - , 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. Some functions are based on the whole screen and others - -- are based on the line in which the cursor is located. - , clearFromCursorToScreenEnd - , clearFromCursorToScreenBeginning - , clearScreen - , clearFromCursorToLineEnd - , clearFromCursorToLineBeginning - , clearLine - -- ** \'h...\' variants - , hClearFromCursorToScreenEnd - , hClearFromCursorToScreenBeginning - , hClearScreen - , hClearFromCursorToLineEnd - , hClearFromCursorToLineBeginning - , hClearLine - -- ** \'...Code\' variants - , clearFromCursorToScreenEndCode - , clearFromCursorToScreenBeginningCode - , clearScreenCode - , clearFromCursorToLineEndCode - , clearFromCursorToLineBeginningCode - , clearLineCode - - -- * Scrolling the screen - , scrollPageUp - , scrollPageDown - -- ** \'h...\' variants - , hScrollPageUp - , hScrollPageDown - -- ** \'...Code\' variants - , scrollPageUpCode - , scrollPageDownCode - - -- * Using screen buffers - -- | These code sequences are not part of the ECMA-48 standard; they are - -- popular, but non-portable extensions. On Unix-like operating systems, - -- they correspond to the @smcup@ and @rmcup@ capabilities in the @terminfo@ - -- database. Windows Terminal supports them. On Windows, if emulation is - -- required, switching between alternate and normal screen buffers is not - -- emulated. - , useAlternateScreenBuffer - , useNormalScreenBuffer - -- ** \'h...\' variants - , hUseAlternateScreenBuffer - , hUseNormalScreenBuffer - -- ** \'...Code\' variants - , useAlternateScreenBufferCode - , useNormalScreenBufferCode - - -- * Reporting the background or foreground colors - , reportLayerColor - , hReportLayerColor - , reportLayerColorCode - - -- * Select Graphic Rendition mode: colors and other whizzy stuff - , setSGR - , hSetSGR - , setSGRCode - - -- * Cursor visibilty changes - -- | These code sequences are not part of the ECMA-48 standard; they are - -- popular, but non-portable extensions. In practice, many terminals support - -- them. - , hideCursor - , showCursor - -- ** \'h...\' variants - , hHideCursor - , hShowCursor - -- ** \'...Code\' variants - , hideCursorCode - , showCursorCode - - -- * Hyperlinks - -- | These code sequences are not part of the ECMA-48 standard or an Xterm - -- extension. However, in practice, many terminals support them, including - -- Windows Terminal. On Windows, if emulation is required, hyperlinks are - -- not emulated. - , hyperlink - , hyperlinkWithId - , hyperlinkWithParams - -- ** \'h...\' variants - , hHyperlink - , hHyperlinkWithId - , hHyperlinkWithParams - -- ** \'...Code\' variants - , hyperlinkCode - , hyperlinkWithIdCode - , hyperlinkWithParamsCode - - -- * Changing the title - , setTitle - , hSetTitle - , setTitleCode - - -- * Checking if handle supports ANSI (not portable: GHC only) - , hSupportsANSI - , hSupportsANSIColor - , hSupportsANSIWithoutEmulation - - -- * Getting the cursor position - , getCursorPosition - , hGetCursorPosition - , getReportedCursorPosition - , cursorPosition - - -- * Getting the terminal size - , getTerminalSize - , hGetTerminalSize - - -- * Getting the background or foreground colors - , getLayerColor - , hGetLayerColor - , getReportedLayerColor - , layerColor diff --git a/unix/System/Console/ANSI/Internal.hs b/unix/System/Console/ANSI/Internal.hs new file mode 100644 --- /dev/null +++ b/unix/System/Console/ANSI/Internal.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE Safe #-} + +module System.Console.ANSI.Internal + ( getReportedCursorPosition + , getReportedLayerColor + , hSupportsANSI + ) where + +import Data.List ( uncons ) +import Data.Maybe ( fromMaybe, mapMaybe ) +import System.Environment ( lookupEnv ) +import System.IO ( Handle, hIsTerminalDevice, hIsWritable ) +import System.Timeout ( timeout ) + +import System.Console.ANSI.Types ( ConsoleLayer (..) ) + +getReportedCursorPosition :: IO String +getReportedCursorPosition = getReport "\ESC[" ["R"] + +getReportedLayerColor :: ConsoleLayer -> IO String +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 + -- 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. + fromMaybe "" <$> timeout 500000 (getStart startChars "") -- 500 milliseconds + where + endChars' = mapMaybe uncons endChars + + -- The list is built in reverse order, in order to avoid O(n^2) complexity. + -- So, getReport yields the reversed built list. + + getStart :: String -> String -> IO String + getStart "" r = getRest r + getStart (h:hs) r = do + c <- getChar + if c == h + then getStart hs (c:r) -- Try to get the rest of the start characters + else pure $ reverse (c:r) -- If the first character(s) are not the + -- expected start then give up. This provides + -- a modicom of protection against unexpected + -- data in the input stream. + getRest :: String -> IO String + getRest r = do + c <- getChar + case lookup c endChars' of + Nothing -> getRest (c:r) -- Continue building the list, until the first of + -- the end characters is obtained. + Just es -> getEnd es (c:r) -- Try to get the rest of the end characters. + + getEnd :: String -> String -> IO String + getEnd "" r = pure $ reverse r + getEnd (e:es) r = do + c <- getChar + if c /= e + then getRest (c:r) -- Continue building the list, with the original end + -- characters. + else getEnd es (c:r) -- Continue building the list, checking against the + -- remaining end characters. + +hSupportsANSI :: Handle -> IO Bool +-- Borrowed from an HSpec patch by Simon Hengel +-- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) +hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI' + where + hSupportsANSI' = (&&) <$> hIsTerminalDevice h <*> isNotDumb + isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM" diff --git a/win/System/Console/ANSI/Internal.hs b/win/System/Console/ANSI/Internal.hs new file mode 100644 --- /dev/null +++ b/win/System/Console/ANSI/Internal.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE Safe #-} + +module System.Console.ANSI.Internal + ( getReportedCursorPosition + , getReportedLayerColor + , hSupportsANSI + ) where + +import Control.Exception ( IOException, catch ) +import Data.Maybe ( mapMaybe ) +import System.Environment ( lookupEnv ) +import System.IO ( Handle, hIsTerminalDevice, hIsWritable, stdin ) +import System.Console.ANSI.Types ( ConsoleLayer ) + +-- Provided by the ansi-terminal package +import System.Console.ANSI.Windows.Foreign + ( INPUT_RECORD (..), INPUT_RECORD_EVENT (..), KEY_EVENT_RECORD (..) + , cWcharsToChars, getNumberOfConsoleInputEvents, readConsoleInput + , unicodeAsciiChar + ) +import System.Console.ANSI.Windows.Win32.MinTTY ( isMinTTYHandle ) +import System.Console.ANSI.Windows.Win32.Types ( withHandleToHANDLE ) + + +getReportedCursorPosition :: IO String +getReportedCursorPosition = getReported + +getReportedLayerColor :: ConsoleLayer -> IO String +getReportedLayerColor _ = getReported + +getReported :: IO String +getReported = catch getReported' getReportedExceptionHandler + where + getReported' = withHandleToHANDLE stdin action + where + action hdl = do + n <- getNumberOfConsoleInputEvents hdl + if n == 0 + then pure "" + else do + es <- readConsoleInput hdl n + pure $ stringFromInputEvents es + stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents + wCharsFromInputEvents = mapMaybe wCharFromInputEvent + wCharFromInputEvent e = if isKeyEvent && isKeyDown + then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) + else Nothing + where + eventType = inputEventType e + eventRecord = inputEvent e + isKeyEvent = eventType == 1 + keyEventRecord = case eventRecord of + InputKeyEvent keyEventRecord' -> keyEventRecord' + _ -> error "Unexpected input event, given input event type." + isKeyDown = keyEventKeyDown keyEventRecord + +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 " ++ + "or PowerShell." + +hSupportsANSI :: Handle -> IO Bool +hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI' + where + hSupportsANSI' = (||) <$> isTDNotDumb <*> isMinTTY + -- Borrowed from an HSpec patch by Simon Hengel + -- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) + isTDNotDumb = (&&) <$> hIsTerminalDevice h <*> isNotDumb + isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM" + isMinTTY = withHandleToHANDLE h isMinTTYHandle diff --git a/win/System/Console/ANSI/Windows/Foreign.hs b/win/System/Console/ANSI/Windows/Foreign.hs new file mode 100644 --- /dev/null +++ b/win/System/Console/ANSI/Windows/Foreign.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +module System.Console.ANSI.Windows.Foreign + ( + INPUT_RECORD (..) + , INPUT_RECORD_EVENT (..) + , KEY_EVENT_RECORD (..) + , getNumberOfConsoleInputEvents + , readConsoleInput + , cWcharsToChars + , unicodeAsciiChar + ) where + +import Control.Exception ( Exception ) +import Data.Char ( chr ) +import Data.Typeable ( Typeable ) +import Data.Word ( Word32 ) +import Foreign.C.Types ( CWchar (..) ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( allocaArray, peekArray, pokeArray ) +import Foreign.Ptr ( Ptr, castPtr, plusPtr ) +import Foreign.Storable ( Storable (..) ) +import System.Console.ANSI.Windows.Win32.Types + ( BOOL, DWORD, ErrCode, HANDLE, LPDWORD, SHORT, UINT, ULONG, WCHAR + , WORD, failIfFalse_ + ) + +peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) +peekAndOffset ptr = do + item <- peek ptr + pure (item, ptr `plusPtr` sizeOf item) + +pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) +pokeAndOffset ptr item = do + poke ptr item + pure (ptr `plusPtr` sizeOf item) + +data COORD = COORD + { coord_x :: SHORT + , coord_y :: SHORT + } deriving (Read, Eq) + +instance Show COORD where + show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" + +instance Storable COORD where + sizeOf ~(COORD x y) = sizeOf x + sizeOf y + alignment ~(COORD x _) = alignment x + peek ptr = do + let ptr' = castPtr ptr :: Ptr SHORT + x <- peekElemOff ptr' 0 + y <- peekElemOff ptr' 1 + pure (COORD x y) + poke ptr (COORD x y) = do + let ptr' = castPtr ptr :: Ptr SHORT + pokeElemOff ptr' 0 x + pokeElemOff ptr' 1 y + +data SMALL_RECT = SMALL_RECT COORD COORD + +instance Show SMALL_RECT where + show (SMALL_RECT tl br) = show tl ++ "-" ++ show br + +instance Storable SMALL_RECT where + sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br + alignment ~(SMALL_RECT tl _) = alignment tl + peek ptr = do + let ptr' = castPtr ptr :: Ptr COORD + tl <- peekElemOff ptr' 0 + br <- peekElemOff ptr' 1 + pure (SMALL_RECT tl br) + poke ptr (SMALL_RECT tl br) = do + let ptr' = castPtr ptr :: Ptr COORD + pokeElemOff ptr' 0 tl + pokeElemOff ptr' 1 br + +data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO + { cci_cursor_size :: DWORD + , cci_cursor_visible :: BOOL + } deriving (Show) + +instance Storable CONSOLE_CURSOR_INFO where + sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible + alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size + peek ptr = do + (size, ptr') <- peekAndOffset (castPtr ptr) + visible <- peek ptr' + pure (CONSOLE_CURSOR_INFO size visible) + poke ptr (CONSOLE_CURSOR_INFO size visible) = do + ptr' <- pokeAndOffset (castPtr ptr) size + poke ptr' visible + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO + { csbi_size :: COORD + , csbi_cursor_position :: COORD + , csbi_attributes :: WORD + , csbi_window :: SMALL_RECT + , csbi_maximum_window_size :: COORD + } deriving (Show) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + + sizeOf maximum_window_size + alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size + peek ptr = do + (size, ptr1) <- peekAndOffset (castPtr ptr) + (cursor_position, ptr2) <- peekAndOffset ptr1 + (attributes, ptr3) <- peekAndOffset ptr2 + (window, ptr4) <- peekAndOffset ptr3 + maximum_window_size <- peek ptr4 + pure (CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + poke ptr (CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + = do + ptr1 <- pokeAndOffset (castPtr ptr) size + ptr2 <- pokeAndOffset ptr1 cursor_position + ptr3 <- pokeAndOffset ptr2 attributes + 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 :: [COLORREF] + } deriving (Show) + +-- 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 _) + = sizeOf sizeCsbix + sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + + sizeOf maximum_window_size + sizeOf popup_attributes + + sizeOf fullscreen_supported + 16 * sizeOf (undefined :: COLORREF) + 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 <- peekArray 16 ptr7 + pure (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 + pokeArray ptr7 color_table' + where + color_table' = take 16 $ color_table ++ repeat 0 + +sizeCsbix :: ULONG +sizeCsbix = fromIntegral $ + sizeOf (undefined :: CONSOLE_SCREEN_BUFFER_INFOEX) + +data CHAR_INFO = CHAR_INFO + { ci_char :: WCHAR + , ci_attributes :: WORD + } deriving (Show) + +instance Storable CHAR_INFO where + sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes + alignment ~(CHAR_INFO char _) = alignment char + peek ptr = do + (char, ptr') <- peekAndOffset (castPtr ptr) + attributes <- peek ptr' + pure (CHAR_INFO char attributes) + poke ptr (CHAR_INFO char attributes) = do + ptr' <- pokeAndOffset (castPtr ptr) char + poke ptr' attributes + +kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, + fOCUS_EVENT :: WORD +kEY_EVENT = 1 +mOUSE_EVENT = 2 +wINDOW_BUFFER_SIZE_EVENT = 4 +mENU_EVENT = 8 +fOCUS_EVENT = 16 + +foreign import ccall unsafe "windows.h GetNumberOfConsoleInputEvents" + cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL +foreign import ccall unsafe "windows.h ReadConsoleInputW" + cReadConsoleInput :: HANDLE + -> Ptr INPUT_RECORD + -> DWORD + -> LPDWORD + -> IO BOOL + +data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) + +instance Show ConsoleException where + show (ConsoleException 6) = + "A fatal error has occurred.\n\n" ++ + "An attempt has been made to send console virtual terminal sequences\n" ++ + "(ANSI codes) to an output that has not been recognised as an\n" ++ + "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ + "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ + "Prompt or PowerShell). That may occur, for example, if output has\n" ++ + "been redirected to a file.\n\n" ++ + "If that is unexpected, please post an issue at:\n" ++ + "https://github.com/UnkindPartition/ansi-terminal/issues\n" + show (ConsoleException errCode) = "ConsoleException " ++ show errCode + +instance Exception ConsoleException + +returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a +returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr + +{- +typedef union _UNICODE_ASCII_CHAR { + WCHAR UnicodeChar; + CHAR AsciiChar; +} UNICODE_ASCII_CHAR; +-} +newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar + { unicodeAsciiChar :: WCHAR + } deriving (Show, Read, Eq) + +instance Storable UNICODE_ASCII_CHAR where + sizeOf _ = 2 + alignment _ = 2 + peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr + poke ptr val = case val of + UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c + +{- +typedef struct _KEY_EVENT_RECORD { + BOOL bKeyDown; + WORD wRepeatCount; + WORD wVirtualKeyCode; + WORD wVirtualScanCode; + union { + WCHAR UnicodeChar; + CHAR AsciiChar; + } uChar; + DWORD dwControlKeyState; +} +#ifdef __GNUC__ +/* gcc's alignment is not what win32 expects */ + PACKED +#endif +KEY_EVENT_RECORD; +-} +data KEY_EVENT_RECORD = KEY_EVENT_RECORD + { keyEventKeyDown :: BOOL + , keyEventRepeatCount :: WORD + , keyEventVirtualKeyCode :: WORD + , keyEventVirtualScanCode :: WORD + , keyEventChar :: UNICODE_ASCII_CHAR + , keyEventControlKeystate :: DWORD + } deriving (Show, Read, Eq) + +instance Storable KEY_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 6) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 10) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ keyEventKeyDown val + (`pokeByteOff` 4) ptr $ keyEventRepeatCount val + (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val + (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val + (`pokeByteOff` 10) ptr $ keyEventChar val + (`pokeByteOff` 12) ptr $ keyEventControlKeystate val + +{- +typedef struct _MOUSE_EVENT_RECORD { + COORD dwMousePosition; + DWORD dwButtonState; + DWORD dwControlKeyState; + DWORD dwEventFlags; +} MOUSE_EVENT_RECORD; +-} +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD + { mousePosition :: COORD + , mouseButtonState :: DWORD + , mouseControlKeyState :: DWORD + , mouseEventFlags :: DWORD + } deriving (Show, Read, Eq) + +instance Storable MOUSE_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ mousePosition val + (`pokeByteOff` 4) ptr $ mouseButtonState val + (`pokeByteOff` 8) ptr $ mouseControlKeyState val + (`pokeByteOff` 12) ptr $ mouseEventFlags val + +{- +typedef struct _WINDOW_BUFFER_SIZE_RECORD { + COORD dwSize; +} WINDOW_BUFFER_SIZE_RECORD; +-} +data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD + { bufSizeNew :: COORD + } deriving (Show, Read, Eq) + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val + +{- +typedef struct _MENU_EVENT_RECORD { + UINT dwCommandId; +} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; +-} +data MENU_EVENT_RECORD = MENU_EVENT_RECORD + { menuCommandId :: UINT + } deriving (Show, Read, Eq) + +instance Storable MENU_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val + +{- +typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; +-} +data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD + { focusSetFocus :: BOOL + } deriving (Show, Read, Eq) + +instance Storable FOCUS_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val + +data INPUT_RECORD_EVENT + = InputKeyEvent KEY_EVENT_RECORD + | InputMouseEvent MOUSE_EVENT_RECORD + | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | InputMenuEvent MENU_EVENT_RECORD + | InputFocusEvent FOCUS_EVENT_RECORD + deriving (Show, Read, Eq) + +{- +typedef struct _INPUT_RECORD { + WORD EventType; + union { + KEY_EVENT_RECORD KeyEvent; + MOUSE_EVENT_RECORD MouseEvent; + WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; + MENU_EVENT_RECORD MenuEvent; + FOCUS_EVENT_RECORD FocusEvent; + } Event; +} INPUT_RECORD,*PINPUT_RECORD; +-} +data INPUT_RECORD = INPUT_RECORD + { inputEventType :: WORD + , inputEvent :: INPUT_RECORD_EVENT + } deriving (Show, Read, Eq) + +instance Storable INPUT_RECORD where + sizeOf _ = 20 + alignment _ = 4 + peek ptr = do + evType <- (`peekByteOff` 0) ptr + event <- case evType of + _ | evType == kEY_EVENT + -> InputKeyEvent <$> (`peekByteOff` 4) ptr + _ | evType == mOUSE_EVENT + -> InputMouseEvent <$> (`peekByteOff` 4) ptr + _ | evType == wINDOW_BUFFER_SIZE_EVENT + -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr + _ | evType == mENU_EVENT + -> InputMenuEvent <$> (`peekByteOff` 4) ptr + _ | evType == fOCUS_EVENT + -> InputFocusEvent <$> (`peekByteOff` 4) ptr + _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ + show evType + pure $ INPUT_RECORD evType event + poke ptr val = do + (`pokeByteOff` 0) ptr $ inputEventType val + case inputEvent val of + InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev + InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev + InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev + InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev + InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console. + +getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD +getNumberOfConsoleInputEvents hdl = + returnWith_ $ \ptrN -> + failIfFalse_ "GetNumberOfConsoleInputEvents" $ + cGetNumberOfConsoleInputEvents hdl ptrN + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console, cut down for the WCHAR version of readConsoleInput. + +readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] +readConsoleInput hdl len + = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr + +readConsoleInputWith :: HANDLE + -> DWORD + -> OutputHandler (Ptr INPUT_RECORD, DWORD) +readConsoleInputWith hdl len handler = + allocaArray (fromEnum len) $ \ptrBuf -> + alloca $ \ptrN -> do + failIfFalse_ "ReadConsoleInputW" $ + cReadConsoleInput hdl ptrBuf len ptrN + n <- peek ptrN + handler (ptrBuf, n) + +type OutputHandler o = forall a. (o -> IO a) -> IO a + +-- Replicated from module Foreign.C.String in package base because that module +-- does not export the function. +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] diff --git a/win/System/Console/ANSI/Windows/Win32/MinTTY.hsc b/win/System/Console/ANSI/Windows/Win32/MinTTY.hsc new file mode 100644 --- /dev/null +++ b/win/System/Console/ANSI/Windows/Win32/MinTTY.hsc @@ -0,0 +1,256 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| This module is based on the corresponding code in the mintty package and the +Win32 package, in order to avoid a dependency on those packages. +-} +module System.Console.ANSI.Windows.Win32.MinTTY + ( isMinTTYHandle + ) where + +import Control.Exception ( catch ) +import Data.Int ( Int32 ) +import Data.List ( isInfixOf ) +import Data.Word ( Word8 ) +import Foreign.C.String + ( peekCWStringLen, withCAString, withCWString, withCWStringLen ) +import Foreign.C.Types ( CInt (..) ) +import Foreign.Marshal.Alloc ( alloca, allocaBytes ) +import Foreign.Marshal.Array ( advancePtr, copyArray ) +import Foreign.Marshal.Utils ( maybeWith ) +import Foreign.Ptr ( FunPtr, Ptr, castPtr, castPtrToFunPtr, plusPtr ) +import Foreign.Storable ( Storable (..) ) + +-- Provided by the ansi-terminal package +import System.Console.ANSI.Windows.Win32.Types + ( Addr, BOOL, DWORD, FileType, HANDLE, HMODULE, LPCSTR, LPCTSTR, LPTSTR + , TCHAR, ULONG, USHORT, failIfFalse_, failIfNeg, failIfNull + ) + +-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP. +-- Since we need some structs that are only available with Vista or later, +-- we must manually set WINVER/_WIN32_WINNT accordingly. +#undef WINVER +#define WINVER 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 +#include +#include "winternl_compat.h" + +#if __GLASGOW_HASKELL__ < 800 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +type F_NtQueryObject = + HANDLE + -> CInt + -> Ptr OBJECT_NAME_INFORMATION + -> ULONG + -> Ptr ULONG + -> IO NTSTATUS +type F_GetFileInformationByHandleEx = + HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL +type NTSTATUS = #type NTSTATUS + +data FILE_NAME_INFO = FILE_NAME_INFO + { fniFileNameLength :: DWORD + , fniFileName :: String + } + +instance Storable FILE_NAME_INFO where + sizeOf _ = #size FILE_NAME_INFO + alignment _ = #alignment FILE_NAME_INFO + poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName) + end = advancePtr start len' + (#poke FILE_NAME_INFO, FileNameLength) buf len' + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf + let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR + vfniFileName <- + peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len) + pure $ FILE_NAME_INFO + { fniFileNameLength = vfniFileNameLength + , fniFileName = vfniFileName + } + +newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION + { oniName :: UNICODE_STRING } + +instance Storable OBJECT_NAME_INFORMATION where + sizeOf _ = #size OBJECT_NAME_INFORMATION + alignment _ = #alignment OBJECT_NAME_INFORMATION + poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni) + peek buf = + fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf + +data UNICODE_STRING = UNICODE_STRING + { usLength :: USHORT + , usMaximumLength :: USHORT + , usBuffer :: String + } + +instance Storable UNICODE_STRING where + sizeOf _ = #size UNICODE_STRING + alignment _ = #alignment UNICODE_STRING + poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#size UNICODE_STRING) + end = advancePtr start len' + (#poke UNICODE_STRING, Length) buf len' + (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR) + (#poke UNICODE_STRING, Buffer) buf start + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vusLength <- (#peek UNICODE_STRING, Length) buf + vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf + vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf + let len = fromIntegral vusLength `div` sizeOfTCHAR + vusBuffer <- peekTStringLen (vusBufferPtr, len) + pure $ UNICODE_STRING + { usLength = vusLength + , usMaximumLength = vusMaximumLength + , usBuffer = vusBuffer + } + +-- | Returns 'True' is the given handle is attached to a MinTTY console +-- (e.g., Cygwin or MSYS). Returns 'False' otherwise. +isMinTTYHandle :: HANDLE -> IO Bool +isMinTTYHandle h = do + fileType <- getFileType h + if fileType /= fILE_TYPE_PIPE + then pure False + else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h + -- GetFileNameByHandleEx is only available on Vista and later (hence + -- the name isMinTTYVista). If we're on an older version of Windows, + -- getProcAddress will throw an IOException when it fails to find + -- GetFileNameByHandleEx, and thus we will default to using + -- NtQueryObject (isMinTTYCompat). + +isMinTTYVista :: HANDLE -> IO Bool +isMinTTYVista h = do + fn <- getFileNameByHandle h + pure $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> pure False + +cygwinMSYSCheck :: String -> Bool +cygwinMSYSCheck fn = + ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) + && "-pty" `isInfixOf` fn +-- Note that GetFileInformationByHandleEx might return a filepath like: +-- +-- \msys-dd50a72ab4668b33-pty1-to-master +-- +-- But NtQueryObject might return something like: +-- +-- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master +-- +-- This means we can't rely on "\cygwin-" or "\msys-" being at the very start +-- of the filepath. As a result, we use `isPrefixOf` to check for "cygwin" and +-- "msys". +-- +-- It's unclear if "-master" will always appear in the filepath name. Recent +-- versions of MinTTY have been known to give filepaths like this (#186): +-- +-- \msys-dd50a72ab4668b33-pty0-to-master-nat +-- +-- Just in case MinTTY ever changes this convention, we don't bother checking +-- for the presence of "-master" in the filepath name at all. + +isMinTTYCompat :: HANDLE -> IO Bool +isMinTTYCompat h = do + fn <- ntQueryObjectNameInformation h + pure $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> pure False + +fILE_TYPE_PIPE :: FileType +fILE_TYPE_PIPE = 3 + +ntQueryObjectNameInformation :: HANDLE -> IO String +ntQueryObjectNameInformation h = do + let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION) + bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> + alloca $ \p_len -> do + hwnd <- getModuleHandle (Just "ntdll.exe") + addr <- getProcAddress hwnd "NtQueryObject" + let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr addr) + _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject + h objectNameInformation buf (fromIntegral bufSize) p_len + oni <- peek buf + pure $ usBuffer $ oniName oni + +sizeOfTCHAR :: Int +sizeOfTCHAR = sizeOf (undefined :: TCHAR) + +getFileNameByHandle :: HANDLE -> IO String +getFileNameByHandle h = do + let sizeOfDWORD = sizeOf (undefined :: DWORD) + -- note: implicitly assuming that DWORD has stronger alignment than wchar_t + bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> do + getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) + fni <- peek buf + pure $ fniFileName fni + +getFileInformationByHandleEx :: + HANDLE + -> CInt + -> Ptr FILE_NAME_INFO + -> DWORD + -> IO () +getFileInformationByHandleEx h cls buf bufSize = do + lib <- getModuleHandle (Just "kernel32.dll") + ptr <- getProcAddress lib "GetFileInformationByHandleEx" + let c_GetFileInformationByHandleEx = + mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) + failIfFalse_ "getFileInformationByHandleEx" + (c_GetFileInformationByHandleEx h cls buf bufSize) + +getModuleHandle :: Maybe String -> IO HMODULE +getModuleHandle mb_name = + maybeWith withTString mb_name $ \ c_name -> + failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name + +getProcAddress :: HMODULE -> String -> IO Addr +getProcAddress hmod procname = + withCAString procname $ \ c_procname -> + failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname + +peekTStringLen :: (LPCTSTR, Int) -> IO String +peekTStringLen = peekCWStringLen + +withTString :: String -> (LPTSTR -> IO a) -> IO a +withTString = withCWString + +withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a +withTStringLen = withCWStringLen + +fileNameInfo :: CInt +fileNameInfo = #const FileNameInfo + +mAX_PATH :: Num a => a +mAX_PATH = #const MAX_PATH + +objectNameInformation :: CInt +objectNameInformation = #const ObjectNameInformation + +foreign import ccall "dynamic" + mk_GetFileInformationByHandleEx :: + FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx + +foreign import ccall unsafe "windows.h GetFileType" + getFileType :: HANDLE -> IO FileType + +foreign import ccall unsafe "windows.h GetProcAddress" + c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr + +foreign import ccall "dynamic" + mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject + +foreign import ccall unsafe "windows.h GetModuleHandleW" + c_GetModuleHandle :: LPCTSTR -> IO HMODULE diff --git a/win/System/Console/ANSI/Windows/Win32/Types.hs b/win/System/Console/ANSI/Windows/Win32/Types.hs new file mode 100644 --- /dev/null +++ b/win/System/Console/ANSI/Windows/Win32/Types.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE Safe #-} + +{-| This module is based on the corresponding code in the Win32 package, in +order to avoid a dependency on that package. Some of that code had its origins +in earlier versions of this package. +-} +module System.Console.ANSI.Windows.Win32.Types + ( Addr + , BOOL + , DWORD + , ErrCode + , FileType + , HANDLE + , HMODULE + , LPCSTR + , LPCTSTR + , LPDWORD + , LPTSTR + , SHORT + , TCHAR + , UINT + , ULONG + , USHORT + , WCHAR + , WORD + , failIfFalse_ + , failIfNeg + , failIfNull + , withHandleToHANDLE + ) where + +import Control.Concurrent.MVar ( readMVar ) +import Control.Exception ( bracket, throwIO ) +import Control.Monad ( when ) +import Data.Char ( isSpace ) +import Data.Typeable ( cast ) +import Data.Word ( Word16, Word32 ) +import Foreign.C.Error ( Errno (..), errnoToIOError ) +import Foreign.C.String ( peekCWString ) +import Foreign.C.Types ( CChar, CInt (..), CShort (..), CWchar ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.StablePtr ( StablePtr, freeStablePtr, newStablePtr ) +import GHC.IO.Handle.Types ( Handle (..), Handle__ (..) ) +import GHC.IO.FD ( FD(..) ) -- A wrapper around an Int32 +import Numeric ( showHex ) +import System.IO.Error ( ioeSetErrorString ) + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.Exception + ( IOErrorType (InappropriateType), IOException (IOError), ioException ) +import GHC.IO.SubSystem ( () ) +import GHC.IO.Windows.Handle ( ConsoleHandle, Io, NativeHandle, toHANDLE ) +#endif + +type Addr = Ptr () +type BOOL = Bool +type DWORD = Word32 +type ErrCode = DWORD +type FileType = DWORD +type HANDLE = Ptr () +type HMODULE = Ptr () +type LPCSTR = LPSTR +type LPCTSTR = LPTSTR +type LPDWORD = Ptr DWORD +type LPSTR = Ptr CChar +type LPTSTR = Ptr TCHAR +type LPWSTR = Ptr CWchar +type SHORT = CShort +type TCHAR = CWchar +type UINT = Word32 +type ULONG = Word32 +type USHORT = Word16 +type WCHAR = CWchar +type WORD = Word16 + +withStablePtr :: a -> (StablePtr a -> IO b) -> IO b +withStablePtr value = bracket (newStablePtr value) freeStablePtr + +#if defined(__IO_MANAGER_WINIO__) + +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLE = withHandleToHANDLEPosix withHandleToHANDLENative + +withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLENative haskell_handle action = + withStablePtr haskell_handle $ const $ do + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar + windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE + action windows_handle + where + handle_ToHANDLE :: Handle__ -> IO HANDLE + handle_ToHANDLE (Handle__{haDevice = dev}) = + case ( cast dev :: Maybe (Io NativeHandle) + , cast dev :: Maybe (Io ConsoleHandle)) of + (Just hwnd, Nothing) -> pure $ toHANDLE hwnd + (Nothing, Just hwnd) -> pure $ toHANDLE hwnd + _ -> throwErr "not a known HANDLE" + + throwErr msg = ioException $ IOError (Just haskell_handle) + InappropriateType "withHandleToHANDLENative" msg Nothing Nothing + +#else + +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLE = withHandleToHANDLEPosix + +#endif + +withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLEPosix haskell_handle action = + -- Create a stable pointer to the Handle. This prevents the garbage collector + -- getting to it while we are doing horrible manipulations with it, and hence + -- stops it being finalized (and closed). + withStablePtr haskell_handle $ const $ do + -- Grab the write handle variable from the Handle + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar + -- This is "write" MVar, we could also take the "read" one + + -- Get the FD from the algebraic data type + Just fd <- (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) + <$> readMVar write_handle_mvar + + -- Finally, turn that (C-land) FD into a HANDLE using msvcrt + windows_handle <- c_get_osfhandle fd + -- Do what the user originally wanted + action windows_handle + +-- This essential function comes from the C runtime system. It is certainly +-- provided by msvcrt, and also seems to be provided by the mingw C library - +-- hurrah! +foreign import ccall unsafe "_get_osfhandle" + c_get_osfhandle :: CInt -> IO HANDLE + +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) + +failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +failIfFalse_ :: String -> IO Bool -> IO () +failIfFalse_ = failIf_ not + +failIf_ :: (a -> Bool) -> String -> IO a -> IO () +failIf_ p wh act = do + v <- act + when (p v) $ errorWin wh + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + msg <- if c_msg == nullPtr + then return $ "Error 0x" ++ Numeric.showHex err_code "" + else do + msg <- peekTString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + -- turn GetLastError() into errno, which errnoToIOError knows how to convert + -- to an IOException we can throw. + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + +peekTString :: LPCTSTR -> IO String +peekTString = peekCWString + +foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c + c_maperrno_func :: ErrCode -> IO Errno + +foreign import ccall unsafe "errors.h _ansi_terminal_getErrorMessage" + getErrorMessage :: DWORD -> IO LPWSTR + +foreign import ccall unsafe "windows.h GetLastError" + getLastError :: IO ErrCode + +foreign import ccall unsafe "windows.h LocalFree" + localFree :: Ptr a -> IO (Ptr a) diff --git a/win/c-source/errors.c b/win/c-source/errors.c new file mode 100644 --- /dev/null +++ b/win/c-source/errors.c @@ -0,0 +1,39 @@ +#define UNICODE +#include +#include +#include +#include "errors.h" + +/* Copied from the Win32-2.13.4.0 package, but renamed `getErrorMessage` to + * `_ansi_terminal_getErrorMessage`, in order to avoid problems with duplicate + * symbols in GHC's object files. See: + * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. + */ + +/* There's two ways we can generate error messages - with different tradeoffs: + * If we do a function call, we have to use a static buffer. + * If we use a macro and ANSI C's string splicing, we have to use constant + * strings - and accept a certain amount of overhead from inserting the + * boilerplate text. + * + * Why the concern about performance? Error messages are only generated + * in exceptional situations -- sof 9/98 + * + * sof 9/98 : Removed use of non-standard (and wimpy :-) snprintf(). + */ + +LPTSTR _ansi_terminal_getErrorMessage(DWORD err) +{ + LPTSTR what; + + FormatMessage( + (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER) , + NULL, + err, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */ + (LPTSTR) &what, + 0, + NULL + ); + return what; +} diff --git a/win/include/errors.h b/win/include/errors.h new file mode 100644 --- /dev/null +++ b/win/include/errors.h @@ -0,0 +1,22 @@ +#ifndef _ANSI_TERMINAL_ERRORS_H +#define _ANSI_TERMINAL_ERRORS_H + +#include + +/* Copied from the Win32-2.13.4.0 package, but renamed `getErrorMessage` to + * `_ansi_terminal_getErrorMessage`, in order to avoid problems with duplicate + * symbols in GHC's object files. See: + * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. + */ + +/* There's two ways we can generate error messages - with different tradeoffs: + * If we do a function call, we have to use a static buffer. + * If we use a macro and ANSI C's string splicing, we have to use constant + * strings - and accept a certain amount of overhead from inserting the + * boilerplate text. + */ + +/* result should be freed using LocalFree */ +extern LPTSTR _ansi_terminal_getErrorMessage(DWORD err); + +#endif /* _ANSI_TERMINAL_ERRORS_H */ diff --git a/win/include/winternl_compat.h b/win/include/winternl_compat.h new file mode 100644 --- /dev/null +++ b/win/include/winternl_compat.h @@ -0,0 +1,31 @@ +#ifndef WINTERNL_COMPAT_H +#define WINTERNL_COMPAT_H + +/* + * winternl.h is not included in MinGW, which was shipped with the 32-bit + * Windows version of GHC prior to the 7.10.3 release. + */ +#if defined(x86_64_HOST_ARCH) || \ + __GLASGOW_HASKELL__ >= 711 || \ + (__GLASGOW_HASKELL__ == 710 && \ + defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ + __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) +# include +#else +// Some declarations from winternl.h that we need +# include + +typedef LONG NTSTATUS; + +typedef struct _UNICODE_STRING { + USHORT Length; + USHORT MaximumLength; + PWSTR Buffer; +} UNICODE_STRING; + +typedef struct _OBJECT_NAME_INFORMATION { + UNICODE_STRING Name; +} OBJECT_NAME_INFORMATION; +#endif + +#endif /* WINTERNL_COMPAT_H */