ansi-terminal-0.11.5/app/0000755000000000000000000000000014405320467013314 5ustar0000000000000000ansi-terminal-0.11.5/src/0000755000000000000000000000000014406127063013321 5ustar0000000000000000ansi-terminal-0.11.5/src/System/0000755000000000000000000000000014406127063014605 5ustar0000000000000000ansi-terminal-0.11.5/src/System/Console/0000755000000000000000000000000014406127063016207 5ustar0000000000000000ansi-terminal-0.11.5/src/System/Console/ANSI/0000755000000000000000000000000014406127063016741 5ustar0000000000000000ansi-terminal-0.11.5/src/System/Console/ANSI/Windows/0000755000000000000000000000000014406127063020373 5ustar0000000000000000ansi-terminal-0.11.5/src/System/Console/ANSI/Windows/Emulator/0000755000000000000000000000000014406127063022163 5ustar0000000000000000ansi-terminal-0.11.5/src/System/Win32/0000755000000000000000000000000014406127063015507 5ustar0000000000000000ansi-terminal-0.11.5/src/includes/0000755000000000000000000000000014406127063015127 5ustar0000000000000000ansi-terminal-0.11.5/src/System/Console/ANSI.hs0000644000000000000000000001704314406127063017302 0ustar0000000000000000#include "Common-Safe-Haskell.hs" {-| == Introduction Through this module, this library provides platform-independent support for control character sequences following the \'ANSI\' standards (see further below) for terminal software that supports those sequences, running on a Unix-like operating system or on Windows (see further below). The sequences of control characters (also referred to as \'escape\' sequences or codes) provide a rich range of functionality for terminal control, which includes: * Colored text output, with control over both foreground and background colors * Clearing parts of a line or the screen * Hiding or showing the cursor * Moving the cursor around * Reporting the position of the cursor * Scrolling the screen up or down * Switching between the Alternate and Normal Screen Buffers * Clickable hyperlinks to URIs * Changing the title of the terminal A terminal that supports control character sequences acts on them when they are flushed from the output buffer (with a newline character @\"\\n\"@ or, for the standard output channel, @hFlush stdout@). == \'ANSI\' standards The \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information 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 whole of the \'ANSI\' standards are not supported by this library but most (if not all) of the parts that are popular and well-supported by terminal software are supported (see further below). == Cursor positions The functions moving the cursor to an absolute position are 0-based (the top-left corner is considered to be at row 0 column 0) (see 'setCursorPosition') and so is 'getCursorPosition'. The \'ANSI\' standards themselves are 1-based (that is, the top-left corner is considered to be at row 1 column 1) and some functions reporting the position of the cursor are too (see 'reportCursorPosition'). == Windows and control character sequences The native terminal software on Windows has developed over time. Before Windows 10 version 1511 (known as the \'November [2015] Update\' or \'Threshold 2\') that software did not support control character sequences. For that software, this library also provides support for such sequences by using emulation based on the Windows Console API. From 2018, Microsoft introduced the Windows Pseudo Console (\'ConPTY\') API and then Windows Terminal, with the objective of replacing most of the Windows Console API with the use of control character sequences and retiring the historical user-interface role of Windows Console Host (\'ConHost\'). Terminal software other than the native software exists for Windows. One example is the \'mintty\' terminal emulator for \'Cygwin\', \'MSYS\' or \'MSYS2\', and dervied projects, and for \'WSL\' (Windows Subsystem for Linux). GHC's management of input and output (IO) on Windows has also developed over time. If they are supported by the terminal software, some control character sequences cause data to be emitted into the console input stream. For GHC's historical and default IO manager, the function 'hGetBufNonBlocking' in module "System.IO" does not work on Windows. This has been attributed to the lack of non-blocking primatives in the operating system (see the GHC bug report #806 at ). GHC's native IO manager on Windows (\'WinIO\'), introduced as a preview in [GHC 9.0.1](https://downloads.haskell.org/ghc/9.0.1/docs/html/users_guide/9.0.1-notes.html#highlights), has not yet provided a solution. On Windows, this library uses emulation based on the Windows Console API to try to read data emitted into the console input stream. Functions that use that emulation are not supported on consoles, such as mintty, that are not based on that API. == Function variants provided Every function exported by this module comes in three variants, namely: * A variant that has an @IO ()@ type and doesn't take a @Handle@ (for example, @clearScreen :: IO ()@). This variant just outputs the \`ANSI\` command directly to the standard output channel ('stdout') and any terminal corresponding to it. Commands issued like this should work as you expect on both Unix-like operating systems and Windows (unless exceptions on Windows are stated). * An \'@h@...\' variant that has an @IO ()@ type but takes a @Handle@ (for example, @hClearScreen :: Handle -> IO ()@). This variant outputs the \`ANSI\` command to the supplied handle and any terminal corresponding to it. Commands issued like this should also work as you expect on both Unix-like operating systems and Windows (unless exceptions on Windows are stated). * A \'...@Code@\' variant that has a @String@ type (for example, @clearScreenCode :: String@). This variant outputs the sequence of control characters as a 'String', which can be added to any other bit of text before being output. If a high degree of backwards compatability is rewuired, the use of these codes is discouraged because they will not work on legacy versions of Windows where the terminal in use is not ANSI-enabled (see further above). On Windows, where emulation has been necessary, these variants will always output the empty string. That is done so that it is possible to use them portably; for example, coloring console output on the understanding that you will see colors only if you are running on a Unix-like operating system or a version of Windows where emulation has not been necessary. If the control characters are always required, see module "System.Console.ANSI.Codes". == Examples of use A simple example is below: > module Main where > > import System.Console.ANSI > > -- Set colors and write some text in those colors. > main :: IO () > main = do > setSGR [SetColor Foreground Vivid Red] > setSGR [SetColor Background Vivid Blue] > putStrLn "Red-On-Blue" > setSGR [Reset] -- Reset to default colour scheme > putStrLn "Default colors." Another example is below: > module Main where > > import System.IO (hFlush, stdout) > import System.Console.ANSI > > main :: IO () > main = do > setSGR [SetColor Foreground Dull Blue] > putStr "Enter your name: " > setSGR [SetColor Foreground Dull Yellow] > hFlush stdout -- flush the output buffer before getLine > name <- getLine > setSGR [SetColor Foreground Dull Blue] > putStrLn $ "Hello, " ++ name ++ "!" > setSGR [Reset] -- reset to default colour scheme For many more examples, see the project's extensive file. -} #if defined(WINDOWS) module System.Console.ANSI ( module System.Console.ANSI.Windows ) where import System.Console.ANSI.Windows #elif defined(UNIX) module System.Console.ANSI ( module System.Console.ANSI.Unix ) where import System.Console.ANSI.Unix #else #error Unsupported platform for the ansi-terminal package #endif ansi-terminal-0.11.5/src/System/Console/ANSI/Codes.hs0000644000000000000000000002752014406127722020342 0ustar0000000000000000#include "Common-Safe-Haskell.hs" {-| 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 ( -- * Basic data types module System.Console.ANSI.Types -- * Cursor movement by character -- -- | These functions yield @\"\"@ when the number is @0@ as, on some -- terminals, a @0@ parameter for the underlying \'ANSI\' code specifies a -- default parameter of @1@. , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode -- * Cursor movement by line -- -- | These functions yield the equivalent of @setCursorColumnCode 0@ when -- the number is @0@ as, on some terminals, a @0@ parameter for the -- underlying \'ANSI\' code specifies a default parameter of @1@. , 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 -- -- | These functions yield @\"\"@ when the number is @0@ as, on some -- terminals, a @0@ parameter for the underlying \'ANSI\' code specifies a -- default parameter of @1@. , scrollPageUpCode, scrollPageDownCode -- * Using screen buffers , useAlternateScreenBufferCode, useNormalScreenBufferCode -- * Reporting background or foreground colors , reportLayerColorCode -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * Hyperlinks -- | Some, but not all, terminals support hyperlinks - that is, clickable -- text that points to a URI. , hyperlinkCode, hyperlinkWithIdCode, hyperlinkWithParamsCode -- * Changing the title , setTitleCode -- * Utilities , colorToCode, csi, osc, sgrToCode ) where import Data.Char (isPrint) import Data.List (intercalate) import Data.Colour.SRGB (toSRGB24, RGB (..)) import System.Console.ANSI.Types -- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int', -- returns the control sequence comprising the control function CONTROL -- 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 args code = "\ESC[" ++ intercalate ";" (map show args) ++ code -- | 'osc' @parameterS parametersT@, where @parameterS@ specifies the type of -- operation to perform and @parametersT@ is the other parameter(s) (if any), -- returns the control sequence comprising the control function OPERATING SYSTEM -- COMMAND (OSC) followed by the parameters (separated by \';\') and ending with -- the STRING TERMINATOR (ST) @\"\\ESC\\\\\"@. -- -- @since 0.11.4 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 -- eight colors in the ANSI standard). colorToCode :: Color -> Int colorToCode color = case color of Black -> 0 Red -> 1 Green -> 2 Yellow -> 3 Blue -> 4 Magenta -> 5 Cyan -> 6 White -> 7 -- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION -- (SGR) aspect identified by @sgr@. sgrToCode :: SGR -- ^ The SGR aspect -> [Int] sgrToCode sgr = case sgr of Reset -> [0] SetConsoleIntensity intensity -> case intensity of BoldIntensity -> [1] FaintIntensity -> [2] NormalIntensity -> [22] SetItalicized True -> [3] SetItalicized False -> [23] SetUnderlining underlining -> case underlining of SingleUnderline -> [4] DoubleUnderline -> [21] NoUnderline -> [24] SetBlinkSpeed blink_speed -> case blink_speed of SlowBlink -> [5] RapidBlink -> [6] NoBlink -> [25] SetVisible False -> [8] SetVisible True -> [28] SetSwapForegroundBackground True -> [7] SetSwapForegroundBackground False -> [27] SetColor Foreground Dull color -> [30 + colorToCode color] SetColor Foreground Vivid color -> [90 + colorToCode color] SetColor Background Dull color -> [40 + colorToCode color] SetColor Background Vivid color -> [100 + colorToCode color] SetPaletteColor Foreground index -> [38, 5, fromIntegral index] SetPaletteColor Background index -> [48, 5, fromIntegral index] SetRGBColor Foreground color -> [38, 2] ++ toRGB color SetRGBColor Background color -> [48, 2] ++ toRGB color SetDefaultColor Foreground -> [39] SetDefaultColor Background -> [49] where 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 -> 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 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 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 n m = csi [n + 1, m + 1] "H" -- | @since 0.7.1 saveCursorCode, restoreCursorCode :: String saveCursorCode = "\ESC7" restoreCursorCode = "\ESC8" -- | Code to 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 'setCursorPositionCode' is 0-based. -- -- In isolation of 'System.Console.ANSI.getReportedCursorPosition' or -- 'System.Console.ANSI.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 reportCursorPositionCode :: String reportCursorPositionCode = csi [] "6n" -- | Code to emit the layer color into the console input stream, immediately -- after being recognised on the output stream, as: -- @ESC ] \ ; rgb: \ ; \ ; \ \@ -- where @\@ is @10@ for 'Foreground' and @11@ for 'Background'; @\@, -- @\@ and @\@ are the color channel values in hexadecimal (4, 8, -- 12 and 16 bit values are possible, although 16 bit values are most common); -- and @\@ is the STRING TERMINATOR (ST). ST depends on the terminal -- software and may be the @BEL@ character or @ESC \\@ characters. -- -- This function may be of limited, or no, use on Windows operating systems -- because (1) the control character sequence is not supported on native -- terminals (2) of difficulties in obtaining the data emitted into the -- console input stream. See 'System.Console.ANSI.getReportedLayerColor'. -- -- @since 0.11.4 reportLayerColorCode :: ConsoleLayer -> String reportLayerColorCode Foreground = osc "10" "?" reportLayerColorCode Background = osc "11" "?" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String clearFromCursorToScreenEndCode = csi [0] "J" clearFromCursorToScreenBeginningCode = csi [1] "J" clearScreenCode = csi [2] "J" clearFromCursorToLineEndCode = csi [0] "K" clearFromCursorToLineBeginningCode = csi [1] "K" clearLineCode = csi [2] "K" 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" useAlternateScreenBufferCode, useNormalScreenBufferCode :: String 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 sgrs = csi (concatMap sgrToCode sgrs) "m" hideCursorCode, showCursorCode :: String hideCursorCode = csi [] "?25l" showCursorCode = csi [] "?25h" -- | Code to 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 hyperlinkWithParamsCode :: [(String, String)] -- ^ Parameters -> String -- ^ URI -> String -- ^ Link text -> String hyperlinkWithParamsCode params uri link = osc "8" pT ++ link ++ osc "8" ";" where pT = params' ++ ";" ++ uri params' = intercalate ":" $ map (\(k, v) -> k ++ "=" ++ v) params -- | Code to introduce a hyperlink. -- -- @since 0.11.3 hyperlinkCode :: String -- ^ URI -> String -- ^ Link text -> String hyperlinkCode = hyperlinkWithParamsCode [] -- | Code to 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 hyperlinkWithIdCode :: String -- ^ Identifier for the link -> String -- ^ URI -> String -- ^ Link text -> String hyperlinkWithIdCode linkId = hyperlinkWithParamsCode [("id", linkId)] -- | Code to set the terminal window title and the icon name (that is, the text -- for the window in the Start bar, or similar). -- Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the right -- direction on xterm title setting on haskell-cafe. The "0" signifies that both -- the title and "icon" text should be set. This is chosen for consistent -- behaviour between Unixes and Windows. setTitleCode :: String -- ^ New window title and icon name -> String setTitleCode title = osc "0" (filter isPrint title) ansi-terminal-0.11.5/src/System/Console/ANSI/Windows.hs0000644000000000000000000002235214406127063020733 0ustar0000000000000000#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 ansi-terminal-0.11.5/src/System/Console/ANSI/Windows/Detect.hs0000644000000000000000000001123714406130026022134 0ustar0000000000000000{-# 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 ansi-terminal-0.11.5/src/System/Console/ANSI/Windows/Emulator.hs0000644000000000000000000005566214406132644022536 0ustar0000000000000000{-# 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." ansi-terminal-0.11.5/src/System/Console/ANSI/Windows/Emulator/Codes.hs0000644000000000000000000000747014406127063023564 0ustar0000000000000000#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 _ = "" ansi-terminal-0.11.5/src/System/Console/ANSI/Windows/Foreign.hs0000644000000000000000000006654514406130026022331 0ustar0000000000000000#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 [] = [] ansi-terminal-0.11.5/src/System/Console/ANSI/Unix.hs0000644000000000000000000001770014406130026020216 0ustar0000000000000000#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 ansi-terminal-0.11.5/src/System/Win32/Compat.hs0000644000000000000000000001423714406130715017273 0ustar0000000000000000#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 ansi-terminal-0.11.5/app/Example.hs0000644000000000000000000002746114405320467015255 0ustar0000000000000000module Main ( main ) where import Control.Concurrent (threadDelay) import Control.Monad (forM_, replicateM_) import System.IO (hFlush, stdout) import Text.Printf(printf) import Data.Colour.SRGB (sRGB24) import System.Console.ANSI examples :: [IO ()] examples = [ cursorMovementExample , lineChangeExample , setCursorPositionExample , saveRestoreCursorExample , clearExample , scrollExample , screenBuffersExample , sgrColorExample , sgrOtherExample , cursorVisibilityExample , hyperlinkExample , titleExample , getCursorPositionExample , getTerminalSizeExample , getLayerColorExample ] main :: IO () main = mapM_ (resetScreen >>) examples -- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation -- of an erased state is implementation-dependent. There may or may not be a -- distinction between a character position in the erased state and one imaging -- SPACE. Consequently, to reset the screen, the default graphic rendition must -- be selected (setSGR [Reset]) before all character positions are put into the -- erased state (clearScreen). resetScreen :: IO () resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 pause :: IO () pause = do hFlush stdout -- 1 second pause threadDelay 1000000 cursorMovementExample :: IO () cursorMovementExample = do putStrLn "Line One" putStr "Line Two" pause -- Line One -- Line Two cursorUp 1 putStr " - Extras" pause -- Line One - Extras -- Line Two cursorBackward 2 putStr "zz" pause -- Line One - Extrzz -- Line Two cursorForward 2 putStr "- And More" pause -- Line One - Extrzz - And More -- Line Two cursorDown 1 putStr "Disconnected" pause -- Line One - Extrzz - And More -- Line Two Disconnected lineChangeExample :: IO () lineChangeExample = do putStrLn "Line One" putStr "Line Two" pause -- Line One -- Line Two cursorUpLine 1 putStr "New Line One" pause -- New Line One -- Line Two cursorDownLine 1 putStr "New Line Two" pause -- New Line One -- New Line Two setCursorPositionExample :: IO () setCursorPositionExample = do putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 0 5 putStr "Foo" pause -- Line Foo -- Line Two setCursorPosition 1 5 putStr "Bar" pause -- Line Foo -- Line Bar setCursorColumn 1 putStr "oaf" pause -- Line Foo -- Loaf Bar saveRestoreCursorExample :: IO () saveRestoreCursorExample = do putStr "Start sentence ..." pause -- Start sentence ... saveCursor setCursorPosition 2 3 putStr "SPLASH!" pause -- Start sentence ... -- -- SPLASH! restoreCursor putStr " end sentence, uninterrupted." pause -- Start sentence ... end sentence, uninterrupted -- -- SPLASH! clearExample :: IO () clearExample = do putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 0 4 clearFromCursorToScreenEnd pause -- Line resetScreen putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 1 4 clearFromCursorToScreenBeginning pause -- -- Two resetScreen putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 0 4 clearFromCursorToLineEnd pause -- Line -- Line Two setCursorPosition 1 4 clearFromCursorToLineBeginning pause -- Line -- Two clearLine pause -- Line clearScreen pause -- scrollExample :: IO () scrollExample = do putStrLn "Line One" putStrLn "Line Two" putStrLn "Line Three" pause -- Line One -- Line Two -- Line Three scrollPageDown 2 pause -- -- -- Line One -- Line Two -- Line Three scrollPageUp 3 pause -- Line Two -- Line Three screenBuffersExample :: IO () screenBuffersExample = do replicateM_ 5 $ putStrLn "This message is on the Normal Screen Bufffer" replicateM_ 5 pause useAlternateScreenBuffer replicateM_ 5 $ putStrLn "This message is on the Alternate Screen Bufffer" replicateM_ 5 pause useNormalScreenBuffer replicateM_ 5 $ putStrLn "This message is continuing where we left off" replicateM_ 5 pause sgrColorExample :: IO () sgrColorExample = do let colors = enumFromTo minBound maxBound :: [Color] forM_ [Foreground, Background] $ \layer -> do forM_ [Dull, Vivid] $ \intensity -> do resetScreen forM_ colors $ \color -> do setSGR [Reset] setSGR [SetColor layer intensity color] print color pause -- The ANSI eight standard colors, 4 times in sequence (two layers and two -- intensities) resetScreen putStrLn "True color (24 bit color depth)" putStrLn "-------------------------------" putStrLn "" setSGR [SetRGBColor Foreground $ sRGB24 0 0 0] forM_ [0 .. 23] $ \row -> do forM_ [0 .. 47] $ \col -> do let r = row * 11 g = 255 - r b = col * 5 setSGR [SetRGBColor Background $ sRGB24 r g b] putStr "-" putStrLn "" replicateM_ 5 pause -- True colors, a swatch of 24 rows and 48 columns resetScreen putStrLn "A 256-color palette" putStrLn "-------------------" putStrLn "" -- First 16 colors ('system' colors in xterm protocol), in a row -- -- 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 A A B B C C D D E E F F forM_ [Dull .. Vivid] $ \intensity -> do forM_ [Black .. White] $ \color -> do let i = fromEnum intensity * 8 + fromEnum color eol = i == 15 setSGR [SetPaletteColor Background $ xtermSystem intensity color] setSGR [SetPaletteColor Foreground $ xtermSystem Dull Black] printf "%X " i setSGR [SetPaletteColor Foreground $ xtermSystem Vivid White] printf "%X" i if eol then putStrLn "" else do setSGR [Reset] putStr " " putStrLn "" -- Next 216 colors (6 level RGB in xterm protocol), in 12 rows of 18 -- -- 000 001 002 003 004 005 010 011 012 013 014 015 020 021 022 023 024 025 -- 030 031 032 033 034 035 040 041 042 043 044 045 050 051 052 053 054 055 -- 100 101 102 103 104 105 110 111 112 113 114 115 120 121 122 123 124 125 -- ... and so on ... forM_ [0 .. 5] $ \r -> do forM_ [0 .. 5] $ \g -> do forM_ [0 .. 5] $ \b -> do let i = 16 + b + g * 6 + r * 36 eol = i `mod` 18 == 15 r' = (r + 3) `mod` 6 g' = (g + 3) `mod` 6 b' = (b + 3) `mod` 6 setSGR [SetPaletteColor Foreground $ xterm6LevelRGB r' g' b'] setSGR [SetPaletteColor Background $ xterm6LevelRGB r g b] putStr $ show r ++ show g ++ show b if eol then putStrLn "" else do setSGR [Reset] putStr " " putStrLn "" -- Final 24 colors (24 levels of gray in xterm protocol), in two rows -- -- 0 1 2 3 4 5 6 7 8 9 10 11 -- 12 13 14 15 16 17 18 19 20 21 22 23 forM_ [0 .. 23] $ \y -> do setSGR [SetPaletteColor Foreground $ xterm24LevelGray $ (y + 12) `mod` 24] setSGR [SetPaletteColor Background $ xterm24LevelGray y] printf "%3d" y if y == 11 then putStrLn "" else do setSGR [Reset] putStr " " replicateM_ 5 pause sgrOtherExample :: IO () sgrOtherExample = do let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") , (SetConsoleIntensity FaintIntensity, "Faint") , (SetConsoleIntensity NormalIntensity, "Normal") , (SetItalicized True, "Italic") , (SetItalicized False, "No Italics") , (SetUnderlining SingleUnderline, "Single Underline") , (SetUnderlining DoubleUnderline, "Double Underline") , (SetUnderlining NoUnderline, "No Underline") , (SetBlinkSpeed SlowBlink, "Slow Blink") , (SetBlinkSpeed RapidBlink, "Rapid Blink") , (SetBlinkSpeed NoBlink, "No Blink") , (SetVisible False, "Conceal") , (SetVisible True, "Reveal") ] forM_ named_styles $ \(style, name) -> do resetScreen setSGR [style] putStrLn name pause -- Text describing a style displayed in that style in sequence setSGR [SetColor Foreground Vivid Red] setSGR [SetColor Background Vivid Blue] clearScreen >> setCursorPosition 0 0 setSGR [SetSwapForegroundBackground False] putStr "Red-On-Blue" pause -- Red-On-Blue clearScreen >> setCursorPosition 0 0 setSGR [SetSwapForegroundBackground True] putStr "Blue-On-Red" pause -- Blue-On-Red cursorVisibilityExample :: IO () cursorVisibilityExample = do putStr "Cursor Demo" pause -- Cursor Demo| hideCursor pause -- Cursor Demo showCursor pause -- Cursor Demo| hyperlinkExample :: IO () hyperlinkExample = do putStr "Hyperlink demo: " hyperlink "https://example.com" "Example hyperlink\n" putStrLn "" putStrLn "Linked hyperlinks demo:" hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink one\n" hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink two\n" replicateM_ 5 pause -- Hyperlink demo: Example hyperlink -- -- Linked hyperlinks demo: -- Example linked hyperlink one -- Example linked hyperlink two titleExample :: IO () titleExample = do putStr "Title Demo" pause -- ~/foo/ - ansi-terminal-ex - 83x70 ------------------------------------ -- Title Demo setTitle "Yup, I'm a new title!" pause -- Yup, I'm a new title! - ansi-terminal-ex - 83x70 --------------------------------------------------- -- Title Demo getCursorPositionExample :: IO () getCursorPositionExample = do putStrLn " 11111111112222222222" putStrLn "12345678901234567890123456789" putStr "Report cursor position here:" pause -- 11111111112222222222 -- 12345678901234567890123456789 -- Report cursor position here:| result <- getCursorPosition putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n" case result of Just (row, col) -> putStrLn $ "The cursor was at row number " ++ show (row + 1) ++ " and column number " ++ show (col + 1) ++ ".\n" Nothing -> putStrLn "Error: unable to get the cursor position\n" replicateM_ 3 pause -- 11111111112222222222 -- 12345678901234567890123456789 -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R. -- -- The cursor was at row number 3 and column number 29. getTerminalSizeExample :: IO () getTerminalSizeExample = do result <- getTerminalSize case result of Just (h, w) -> putStrLn $ "The size of the terminal is " ++ show h ++ " rows by " ++ show w ++ " columns.\n" Nothing -> putStrLn "Error: unable to get the terminal size\n" pause -- The size of the terminal is 25 rows by 80 columns. getLayerColorExample :: IO () getLayerColorExample = do fgResult <- getLayerColor Foreground case fgResult of Just fgCol -> putStrLn $ "The reported foreground color is:\n" ++ show fgCol ++ "\n" Nothing -> putStrLn "Error: unable to get the foreground color\n" bgResult <- getLayerColor Background case bgResult of Just bgCol -> putStrLn $ "The reported background color is:\n" ++ show bgCol ++ "\n" Nothing -> putStrLn "Error: unable to get the background color\n" ansi-terminal-0.11.5/src/includes/Common-Include.hs0000644000000000000000000005435614406130026020302 0ustar0000000000000000-- 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 ansi-terminal-0.11.5/src/includes/Common-Include-Emulator.hs0000644000000000000000000000446714406127063022075 0ustar0000000000000000-- 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 ansi-terminal-0.11.5/src/includes/Common-Include-Enabled.hs0000644000000000000000000000350114406127063021623 0ustar0000000000000000-- 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 ansi-terminal-0.11.5/src/includes/Common-Safe-Haskell.hs0000644000000000000000000000002714406130026021140 0ustar0000000000000000{-# LANGUAGE Safe #-} ansi-terminal-0.11.5/src/includes/Exports-Include.hs0000644000000000000000000001253614406140430020510 0ustar0000000000000000-- 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 ansi-terminal-0.11.5/CHANGELOG.md0000644000000000000000000001516114406140716014347 0ustar0000000000000000Changes ======= Version 0.11.5 -------------- * Module `System.Console.ANSI.Types` spun out to new dependency package `ansi-terminal-types-0.11.5`. * Drop support for GHC versions before GHC 7.10.1 (released March 2015). * Improvements to Haddock documentation. Version 0.11.4 -------------- * Add `reportLayerColor`, `getReportedLayerColor` and `getLayerColor` for querying the layer color on terminals that support the functionality. * Add `useAlternateScreenBuffer` and `useNormalScreenBuffer`, and support for switching between the Alternate and Normal Screen Buffers. * When the argument is `0`, `cursorUpCode`, `cursorDownCode`, `cursorForwardCode`, `cursorBackwardCode`,`scrollPageUpCode` and `scrollPageDownCode` now yield `""`, and `cursorUpLineCode` and `cursorDownLineCode` now yield the equivalent of `setCursorColumnCode 0`. This is because, on some terminals, a `0` parameter for the underlying 'ANSI' code specifies a default parameter of `1`. * Add `osc` as a utility function, for OSC sequences. * `setTitle` now uses the recommended STRING TERMINATOR (ST) of `\ESC\\`, rather than the legacy `\BEL` (`\007`), and filters the title of all non-printable characters, not just `\BEL`. * Improvements to Haddock documentation. Version 0.11.3 -------------- * Add `hyperlink`, `hyperlinkWithId` and `hyperlinkWithParams`, and support for clickable hyperlinks. Version 0.11.2 -------------- * On Windows, fix compatability with the Windows I/O Manager (WinIO) when GHC >= 9.0.1 but `Win32` < 2.9.0.0. * Improvements to Haddock documentation. Version 0.11.1 -------------- * On Windows, fix compatability with the Windows I/O Manager (WinIO) introduced in GHC 9.0.1, by incorporating changes made in package `Win32-2.13.2.0` in that regard. * Improvements to Haddock documentation. Version 0.11 ------------ * Remove deprecated `getCursorPosition0`. (Use `getCursorPosition` instead.) * On Unix-like operating systems, the temporary turning off of echoing is moved from `getReportedCursorPosition` to `hGetCursorPositon`. * On Unix-like operating systems, fix a bug in `getCursorPosition` and `hGetCursorPosition`, where the console input stream was was not always clear before the cursor position was emitted into it. Version 0.10.3 -------------- * Add `getCursorPosition` as a synonym of `getCursorPosition0` and deprecate the latter. Version 0.10.2 -------------- * `hGetTerminalSize` now assumes a terminal is no bigger than 9,999 by 9,999 (previously, no bigger than 999 by 999). * On Windows, fix a bug where emulated cursor movement functions differed from Windows 10 (movement bounded by the current viewport). Version 0.10.1 -------------- * Add `hGetCursorPosition` and `hGetTerminalSize`. * On Unix-like operating systems, fix a bug where `getReportedCursorPosition` could block indefinitely if no information was forthcoming on the console input stream. * Improvements to Haddock documentation. Version 0.10 ------------ * Add support for setting the default color with new `SetDefaultColor` constructor of the `SGR` type. * `getTerminalSize` now flushes the `stdout` channel, to ensure the cursor position is unaffected. Version 0.9.1 ------------- * Flag modules with GHC's 'Safe Haskell' language extensions (from GHC 7.2.1). * Improvements and corrections to Haddock documentation. Version 0.9 ----------- * Add support for 256-color palettes with new `SetPaletteColor` constructor of the `SGR` type, and `xterm6LevelRGB`, `xterm24LevelGray` and `xtermSystem`. * Remove deprecated `getCursorPosition`. (Use `getCursorPosition0` instead.) * Add `hSupportsANSIColor`. * Add `getTerminalSize`. * Improvements to Haddock documentation. Version 0.8.2 ------------- * Add `getCursorPosition0` and deprecate `getCursorPosition`. Any position provided by the latter is 1-based. Any position provided by the former is 0-based, consistent with `setCursorColumn` and `setCursorPosition`. * Improvements to Haddock documentation in respect of 0-based and 1-based cursor positions. Version 0.8.1 ------------- * Add `hSupportsANSIWithoutEmulation`. On Windows 10, if the handle is identified as connected to a native terminal ('Command Prompt' or 'PowerShell'), the processing of 'ANSI' control characters will be enabled. Version 0.8.0.4 --------------- * On Windows, `hSupportsANSI` now recognises if the handle is connected to a 'mintty' terminal. * Drop support for GHC versions before GHC 7.0.1 (released November 2010) Version 0.8.0.3 --------------- * On Windows, try to enable ANSI on ConHost terminals even if a TERM environment variable exits (such as with the Hyper 2 terminal) * Minor improvements to Haddock documentation Version 0.8.0.2 --------------- * Improve README and Haddock documentation * On Windows, fix compatability with earlier GHC versions * Drop support for GHC versions before 6.12.1 (released December 2009) Version 0.8.0.1 --------------- * On Windows, if the standard output channel is valid but not a ConHost terminal, assume it is ANSI-enabled rather than failing * On Windows, output the improved error message to the standard error channel rather than the standard output channel Version 0.8 ----------- * Make the fields of `SGR` strict * Make compatible with GHC 8.2.2 * Improve the error message on Windows when not ANSI-capable or ConHost * Recognise Appveyor build environment as ANSI-enabled Version 0.7.1.1 --------------- `getReportedCursorPosition`: don't let the cursor reporting code be echo'd Version 0.7.1 ------------- * Allow saving, restoring, and querying the current cursor position * Fix a couple of issues with the Reset emulation on Windows Version 0.7 ----------- Add 24-bit RGB color support Version 0.6.3.1 --------------- Fix Windows + ghc 7.8 compatibility Version 0.6.3 ------------- * Add ANSI support for Windows * Add compatibility with Win32-2.5.0.0 and above Version 0.6.2.3 --------------- Add an example to the haddocks Version 0.6.2.2 --------------- Fix a GHC 7.10 warning Version 0.6.2.1 --------------- Restore compatibility with GHC 7.4 and older Version 0.6.2 ------------- * Add `hSupportsANSI` * Drop support for `base < 4` Version 0.6.1.1 --------------- Fix to build with GHC 7.8 on Windows Version 0.6.1 ------------- * `BoldIntensity` no longer changes background color on Windows * `setSGR []` was not equivalent to `setSGR [Reset]` on Windows, even though it should be according to the documentation. This is now fixed. ansi-terminal-0.11.5/README.md0000644000000000000000000000777114406127063014025 0ustar0000000000000000ansi-terminal [![GitHub CI](https://github.com/UnkindPartition/ansi-terminal/workflows/CI/badge.svg)](https://github.com/UnkindPartition/ansi-terminal/actions) ============= A Haskell package providing support for 'ANSI' control character sequences for terminals on Unix-like operating systems and Windows Description ----------- ['ANSI' terminal escape code](http://en.wikipedia.org/wiki/ANSI_escape_sequences) support for Haskell, which allows: - Colored text output, with control over both foreground and background colors - Clearing parts of a line or the screen - Hiding or showing the cursor - Moving the cursor around - Reporting the position of the cursor - Scrolling the screen up or down - Switching between the Alternate and Normal Screen Buffers - 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' colorisation. Not all 'ANSI' escape codes are suported by this library but most (if not all) of the popular ones that are well-supported by terminal software are, including: - Select Graphic Rendition mode (colors and other attributes): `setSGR` - Clearing parts of the screen: `clearFromCursorToScreenEnd`, `clearFromCursorToScreenBeginning`, `clearScreen`, `clearFromCursorToLineEnd`, `clearFromCursorToLineBeginning` and `clearLine` - Cursor visibility changes: `hideCursor` and `showCursor` - Cursor movement by character: `cursorUp`, `cursorDown`, `cursorForward` and `cursorBackward` - Cursor movement by line: `cursorUpLine` and `cursorDownLine` - Directly changing cursor position: `setCursorColumn` and `setCursorPosition` - Saving, restoring and reporting cursor position: `saveCursor`, `restoreCursor` and `reportCursorPosition` - Scrolling the screen: `scrollPageUp` and `scrollPageDown` - Changing the title: `setTitle` Each supported escape code or family of codes has a corresponding function that comes in three variants: - A straight `IO` variant that doesn't take a `Handle` and just applies the escape code to `stdout` and any terminal attached to it - 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! Example ------- A full example is [available](https://github.com/UnkindPartition/ansi-terminal/blob/master/ansi-terminal/app/Example.hs), but for a taste of how the library works try the following code: ``` haskell import System.Console.ANSI main = do setCursorPosition 5 0 setTitle "ANSI Terminal Short Example" setSGR [ SetConsoleIntensity BoldIntensity , SetColor Foreground Vivid Red ] putStr "Hello" setSGR [ SetConsoleIntensity NormalIntensity , SetColor Foreground Vivid White , SetColor Background Dull Blue ] putStrLn "World!" ``` ![](https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/example.png) Documentation ------------- Haddock documentation is [available at Hackage](http://hackage.haskell.org/packages/archive/ansi-terminal/latest/doc/html/System-Console-ANSI.html). Credits ------- The library is originally written by [Max Bolingbroke](https://github.com/batterseapower) Maintainers ----------- [Mike Pilgrem](https://github.com/mpilgrem) and [Roman Cheplyaka](https://github.com/UnkindPartition) are the primary maintainers. [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please get in touch with him if the primary maintainers cannot be reached. ansi-terminal-0.11.5/LICENSE0000644000000000000000000000301314406127063013534 0ustar0000000000000000Copyright (c) 2008, Maximilian Bolingbroke All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 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.ansi-terminal-0.11.5/Setup.hs0000644000000000000000000000006014405320467014164 0ustar0000000000000000import Distribution.Simple main = defaultMain ansi-terminal-0.11.5/ansi-terminal.cabal0000644000000000000000000000725014406127063016265 0ustar0000000000000000Cabal-Version: 1.22 Name: ansi-terminal Version: 0.11.5 Category: User Interfaces Synopsis: Simple ANSI terminal support, with Windows compatibility 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. License: BSD3 License-File: LICENSE Author: Max Bolingbroke Maintainer: Mike Pilgrem , Roman Cheplyaka 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 README.md Source-repository head type: git location: git://github.com/UnkindPartition/ansi-terminal.git Flag Example 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 System.Console.ANSI.Codes -- We re-export all of ansi-terminal-types to aid compatibility for -- downstream users. Reexported-Modules: System.Console.ANSI.Types Include-Dirs: src/includes Build-Depends: base >= 4.8.0.0 && < 5 , 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 else -- We assume any non-Windows platform is Unix Cpp-Options: -DUNIX Other-Modules: System.Console.ANSI.Unix Default-Extensions: CPP ForeignFunctionInterface Ghc-Options: -Wall Default-Language: Haskell2010 Executable ansi-terminal-example Hs-Source-Dirs: app Main-Is: Example.hs Build-Depends: base >= 4.8.0.0 && < 5 , ansi-terminal , colour Ghc-Options: -Wall if !flag(example) Buildable: False Default-Language: Haskell2010