ansi-terminal-0.10.3/app/0000755000000000000000000000000013617613120013304 5ustar0000000000000000ansi-terminal-0.10.3/src/0000755000000000000000000000000013245072176013322 5ustar0000000000000000ansi-terminal-0.10.3/src/System/0000755000000000000000000000000013245075431014603 5ustar0000000000000000ansi-terminal-0.10.3/src/System/Console/0000755000000000000000000000000013617613120016201 5ustar0000000000000000ansi-terminal-0.10.3/src/System/Console/ANSI/0000755000000000000000000000000013617613120016733 5ustar0000000000000000ansi-terminal-0.10.3/src/System/Console/ANSI/Windows/0000755000000000000000000000000013617613120020365 5ustar0000000000000000ansi-terminal-0.10.3/src/System/Console/ANSI/Windows/Emulator/0000755000000000000000000000000013534270137022162 5ustar0000000000000000ansi-terminal-0.10.3/src/System/Win32/0000755000000000000000000000000013534270137015506 5ustar0000000000000000ansi-terminal-0.10.3/src/includes/0000755000000000000000000000000013617613120015121 5ustar0000000000000000ansi-terminal-0.10.3/src/System/Console/ANSI.hs0000644000000000000000000001345013617613120017272 0ustar0000000000000000#include "Common-Safe-Haskell.hs" {-| Through this module, this library provides platform-independent support for control character sequences following the \'ANSI\' standards (see further below) for terminal software that supports those sequences, running on a Unix-like operating system or Windows. 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 * 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@). The functions moving the cursor to an absolute position are 0-based (the top-left corner is considered to be at row 0 column 0) (see 'setCursorPosition') and so is 'getCursorPosition'. The \'ANSI\' standards themselves are 1-based (that is, the top-left corner is considered to be at row 1 column 1) and some functions reporting the position of the cursor are too (see 'reportCursorPosition'). The native terminal software on Windows is \'Command Prompt\' or \`PowerShell\`. Before Windows 10 version 1511 (known as the \'November [2015] Update\' or \'Threshold 2\') that software did not support such control sequences. For that software, this library also provides support for such sequences by using emulation. Terminal software other than the native software exists for Windows. One example is the \'mintty\' terminal emulator for \'Cygwin\', \'MSYS\' or \'MSYS2\', and dervied projects, and for \'WSL\' (Windows Subsystem for Linux). 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. 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. * 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. * A \'...@Code@\' variant that has a @String@ type (for example, @clearScreenCode :: String@). This variant outputs the sequence of control characters as a 'String', which can be added to any other bit of text before being output. The use of these codes is generally discouraged because they will not work on legacy versions of Windows where the terminal in use is not ANSI-enabled (see further above). On Windows, where emulation has been necessary, these variants will always output the empty string. That is done so that it is possible to use them portably; for example, coloring console output on the understanding that you will see colors only if you are running on a Unix-like operating system or a version of Windows where emulation has not been necessary. If the control characters are always required, see module "System.Console.ANSI.Codes". Example: > 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: > 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.10.3/src/System/Console/ANSI/Types.hs0000644000000000000000000001674613534274752020425 0ustar0000000000000000#include "Common-Safe-Haskell.hs" {-| The \'ANSI\' standards refer to the visual style of displaying characters as their \'graphic rendition\'. The style includes the color of a character or its background, the intensity (bold, normal or faint) of a character, or whether the character is italic or underlined (single or double), blinking (slowly or rapidly) or visible or not. The \'ANSI\' codes to establish the graphic rendition for subsequent text are referred to as SELECT GRAPHIC RENDITION (SGR). This module exports types and functions used to represent SGR aspects. See also 'System.Console.ANSI.setSGR' and related functions. -} module System.Console.ANSI.Types ( -- * Types used to represent SGR aspects SGR (..) , ConsoleLayer (..) , Color (..) , ColorIntensity (..) , ConsoleIntensity (..) , Underlining (..) , BlinkSpeed (..) -- * Constructors of xterm 256-color palette indices , xterm6LevelRGB , xterm24LevelGray , xtermSystem ) where import Data.Ix (Ix) import Data.Word (Word8) import Data.Colour (Colour) -- | ANSI's eight standard colors. They come in two intensities, which are -- controlled by 'ColorIntensity'. Many terminals allow the colors of the -- standard palette to be customised, so that, for example, -- @setSGR [ SetColor Foreground Vivid Green ]@ may not result in bright green -- characters. data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI's standard colors come in two intensities data ColorIntensity = Dull | Vivid deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI colors can be set on two different layers data ConsoleLayer = Foreground | Background deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI blink speeds: values other than 'NoBlink' are not widely supported data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute | RapidBlink -- ^ More than 150 blinks per minute | NoBlink deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI text underlining data Underlining = SingleUnderline -- | Not widely supported. Not supported natively on Windows 10 | DoubleUnderline | NoUnderline deriving (Eq, Ord, Bounded ,Enum, Show, Read, Ix) -- | ANSI general console intensity: usually treated as setting the font style -- (e.g. 'BoldIntensity' causes text to be bold) data ConsoleIntensity = BoldIntensity -- | Not widely supported: sometimes treated as concealing text. Not supported -- natively on Windows 10 | FaintIntensity | NormalIntensity deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI Select Graphic Rendition (SGR) command -- -- In respect of colors, there are three alternative commands: -- -- (1) the \'ANSI\' standards allow for eight standard colors (with two -- intensities). Windows and many other terminals (including xterm) allow the -- user to redefine the standard colors (so, for example 'Vivid' 'Green' may not -- correspond to bright green; -- -- (2) an extension of the standard that allows true colors (24 bit color depth) -- in RGB space. This is usually the best alternative for more colors; and -- -- (3) another extension that allows a palette of 256 colors, each color -- specified by an index. Xterm provides a protocol for a palette of 256 colors -- that many other terminals, including Windows 10, follow. Some terminals -- (including xterm) allow the user to redefine some or all of the palette -- colors. data SGR -- | Default rendition, cancels the effect of any preceding occurrence of SGR -- (implementation-defined) = Reset -- | Set the character intensity. Partially supported natively on Windows 10 | SetConsoleIntensity !ConsoleIntensity -- | Set italicized. Not widely supported: sometimes treated as swapping -- foreground and background. Not supported natively on Windows 10 | SetItalicized !Bool -- | Set or clear underlining. Partially supported natively on Windows 10 | SetUnderlining !Underlining -- | Set or clear character blinking. Not supported natively on Windows 10 | SetBlinkSpeed !BlinkSpeed -- | Set revealed or concealed. Not widely supported. Not supported natively -- on Windows 10 | SetVisible !Bool -- | Set negative or positive image. Supported natively on Windows 10 | SetSwapForegroundBackground !Bool -- | Set a color from the standard palette of 16 colors (8 colors by 2 -- color intensities). Many terminals allow the palette colors to be -- customised | SetColor !ConsoleLayer !ColorIntensity !Color -- | Set a true color (24 bit color depth). Supported natively on Windows 10 -- from the Creators Update (April 2017) -- -- @since 0.7 | SetRGBColor !ConsoleLayer !(Colour Float) -- | Set a color from a palette of 256 colors using a numerical index -- (0-based). Supported natively on Windows 10 from the Creators Update (April -- 2017) but not on legacy Windows native terminals. See 'xtermSystem', -- 'xterm6LevelRGB' and 'xterm24LevelGray' to construct indices based on -- xterm's standard protocol for a 256-color palette. -- -- @since 0.9 | SetPaletteColor !ConsoleLayer !Word8 -- | Set a color to the default (implementation-defined) -- -- @since 0.10 | SetDefaultColor !ConsoleLayer deriving (Eq, Show, Read) -- | Given xterm's standard protocol for a 256-color palette, returns the index -- to that part of the palette which is a 6 level (6x6x6) color cube of 216 RGB -- colors. Throws an error if any of the red, green or blue channels is outside -- the range 0 to 5. An example of use is: -- -- >>> setSGR [ SetPaletteColor $ xterm6LevelRGB 5 2 0 ] -- Dark Orange -- -- @since 0.9 xterm6LevelRGB :: Int -> Int -> Int -> Word8 xterm6LevelRGB r g b -- RGB colors are represented by index: -- 16 + 36 × r + 6 × g + b (0 ≤ r, g, b ≤ 5) | r >= 0 && r < 6 && g >= 0 && g < 6 && b >= 0 && b < 6 = fromIntegral $ 16 + 36 * r + 6 * g + b | otherwise = error $ show r ++ " " ++ show g ++ " " ++ show b ++ " (r g b) is " ++ "outside of a 6 level (6x6x6) color cube." -- | Given xterm's standard protocol for a 256-color palette, returns the index -- to that part of the palette which is a spectrum of 24 grays, from dark -- gray (0) to near white (23) (black and white are themselves excluded). Throws -- an error if the gray is outside of the range 0 to 23. An example of use is: -- -- >>> setSGR [ SetPaletteColor $ xterm24LevelGray 12 ] -- Gray50 -- -- @since 0.9 xterm24LevelGray :: Int -> Word8 xterm24LevelGray y -- Grayscale colors are represented by index: -- 232 + g (0 ≤ g ≤ 23) | y >= 0 && y < 24 = fromIntegral $ 232 + y | otherwise = error $ show y ++ " (gray) is outside of the range 0 to 23." -- | Given xterm's standard protocol for a 256-color palette, returns the index -- to that part of the palette which corresponds to the \'ANSI\' standards' 16 -- standard, or \'system\', colors (eight colors in two intensities). An example -- of use is: -- -- >>> setSGR [ SetPaletteColor $ xtermSystem Vivid Green ] -- -- @since 0.9 xtermSystem :: ColorIntensity -> Color -> Word8 xtermSystem intensity color | intensity == Dull = index | otherwise = index + 8 where index = fromIntegral $ fromEnum color ansi-terminal-0.10.3/src/System/Console/ANSI/Codes.hs0000644000000000000000000002020413617613120020322 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 , 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 -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * Changing the title -- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the -- right direction on xterm title setting on haskell-cafe. The "0" -- signifies that both the title and "icon" text should be set: i.e. the -- text for the window in the Start bar (or similar) as well as that in -- the actual window title. This is chosen for consistent behaviour -- between Unixes and Windows. , setTitleCode -- * Utilities , colorToCode, csi, sgrToCode ) where import Data.List (intersperse) 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[" ++ concat (intersperse ";" (map show args)) ++ code -- | '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 = csi [n] "A" cursorDownCode n = csi [n] "B" cursorForwardCode n = csi [n] "C" cursorBackwardCode n = csi [n] "D" cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move -> String cursorDownLineCode n = csi [n] "E" cursorUpLineCode n = 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 'getReportedCursorPosition' or 'getCursorPosition', this -- function may be of limited use on Windows operating systems because of -- difficulties in obtaining the data emitted into the console input stream. -- The function 'hGetBufNonBlocking' in module "System.IO" does not work on -- Windows. This has been attributed to the lack of non-blocking primatives in -- the operating system (see the GHC bug report #806 at -- ). -- -- @since 0.7.1 reportCursorPositionCode :: String reportCursorPositionCode = csi [] "6n" 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 = csi [n] "S" scrollPageDownCode n = csi [n] "T" 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" -- | XTerm control sequence to set the Icon Name and Window Title. setTitleCode :: String -- ^ New Icon Name and Window Title -> String setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007" ansi-terminal-0.10.3/src/System/Console/ANSI/Windows.hs0000644000000000000000000001722013564577510020740 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 System.Console.ANSI.Types 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, inclduding 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 -- * 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 -- * 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 ansi-terminal-0.10.3/src/System/Console/ANSI/Windows/Detect.hs0000644000000000000000000001125613534270137022143 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Detect ( ANSISupport (..) , ConsoleDefaultState (..) , aNSISupport , detectHandleSupportsANSI ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Exception (SomeException(..), throwIO, try) import Data.Bits ((.&.), (.|.)) import System.Console.MinTTY (isMinTTYHandle) 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 _ -> return Native) where consoleDefaultState h = do info <- getConsoleScreenBufferInfo h let attributes = csbi_attributes info fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE return 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 @return Nothing@. detectHandleSupportsANSI :: Handle -> IO (Maybe Bool) detectHandleSupportsANSI handle = do isWritable <- hIsWritable handle if isWritable then withHandleToHANDLE handle $ withHANDLE (return $ Just False) -- Invalid handle or no handle (\h -> do terminal <- handleToTerminal h case terminal of NativeANSIIncapable -> return (Just False) UnknownTerminal -> return Nothing -- Not sure! _ -> return (Just True)) else return (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 return Mintty -- 'mintty' terminal emulator else return UnknownTerminal -- Not sure! Right mode -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 then return 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 _ -> return NativeANSIIncapable -- Can't enable VT processing Right () -> return 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.10.3/src/System/Console/ANSI/Windows/Emulator.hs0000644000000000000000000005224413617613120022520 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.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, stdin) import System.IO.Unsafe (unsafePerformIO) import Text.ParserCombinators.ReadP (readP_to_S) import Data.Colour (Colour) import Data.Colour.Names (black, blue, cyan, green, grey, lime, magenta, maroon, navy, olive, purple, red, silver, teal, white, yellow) import Data.Colour.SRGB (RGB (..), toSRGB) import System.Console.MinTTY (isMinTTYHandle) import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as Unix import System.Console.ANSI.Windows.Detect import System.Console.ANSI.Windows.Emulator.Codes 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, inclduding 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 {-# 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 -- 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 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 (return ()) (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" return () 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 -> return (Just isSupported) Nothing -> do -- Not sure, based on the handle alone notDumb <- isNotDumb -- Test the environment if notDumb then return Nothing -- Still not sure! else return (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 = CE.catch getReportedCursorPosition' getCPExceptionHandler where getReportedCursorPosition' = withHandleToHANDLE stdin action where action hdl = do n <- getNumberOfConsoleInputEvents hdl if n == 0 then return "" else do es <- readConsoleInput hdl n return $ stringFromInputEvents es stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents wCharsFromInputEvents = mapMaybe wCharFromInputEvent wCharFromInputEvent e = if isKeyDownEvent then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) else Nothing where eventType = inputEventType e InputKeyEvent keyEventRecord = inputEvent e isKeyDown = keyEventKeyDown keyEventRecord isKeyDownEvent = eventType == 1 && isKeyDown -- 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' = CE.catch getCursorPosition'' getCPExceptionHandler where getCursorPosition'' = do withHandleToHANDLE stdin flush -- Flush the console input buffer hReportCursorPosition h hFlush h -- ensure the report cursor position code is sent to the -- operating system input <- getReportedCursorPosition case readP_to_S cursorPosition input of [] -> return Nothing [((row, col),_)] -> return $ Just (row, col) (_:_) -> return Nothing where flush hdl = do n <- getNumberOfConsoleInputEvents hdl unless (n == 0) (void $ readConsoleInput hdl n) getCPExceptionHandler :: IOException -> IO a getCPExceptionHandler e = error msg where msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " ++ "console based on the Win32 console of the Windows API, such as " ++ "Command Prompt or PowerShell." ansi-terminal-0.10.3/src/System/Console/ANSI/Windows/Emulator/Codes.hs0000644000000000000000000000603113534270137023553 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 -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * 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 _ = "" 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 = "" setTitleCode :: String -- ^ New title -> String setTitleCode _ = "" ansi-terminal-0.10.3/src/System/Console/ANSI/Windows/Foreign.hs0000644000000000000000000005754713534270137022341 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, COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), 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, getConsoleCursorInfo, getConsoleMode, setConsoleTextAttribute, setConsoleCursorPosition, setConsoleCursorInfo, setConsoleTitle, setConsoleMode, fillConsoleOutputAttribute, fillConsoleOutputCharacter, scrollConsoleScreenBuffer, withTString, withHandleToHANDLE, ConsoleException (..) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception (Exception, throw) import Data.Bits ((.|.), shiftL) import Data.Char (chr, ord) import Data.Typeable (Typeable) import Foreign.C.Types (CInt (..), CWchar (..)) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray, peekArray, 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, 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 return (item, ptr `plusPtr` sizeOf item) pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) pokeAndOffset ptr item = do poke ptr item return (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 return (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 return (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' return (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 return (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 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' return (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 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/feuerbach/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 return () 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 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 return $ 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.10.3/src/System/Console/ANSI/Unix.hs0000644000000000000000000001242613617613120020217 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 Data.Maybe (fromMaybe) import Control.Exception.Base (bracket) import System.IO (BufferMode (..), Handle, hGetBuffering, hGetEcho, hIsTerminalDevice, hIsWritable, hPutStr, hSetBuffering, hSetEcho, stdin) import System.Timeout (timeout) import Text.ParserCombinators.ReadP (readP_to_S) import System.Console.ANSI.Codes import System.Console.ANSI.Types -- This file contains code that is common to modules System.Console.ANSI.Unix, -- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as -- type signatures and the definition of functions specific to stdout in terms -- of the corresponding more general functions, inclduding 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 hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs hHideCursor h = hPutStr h hideCursorCode hShowCursor h = hPutStr h showCursorCode 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 = bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do hSetEcho stdin False -- Turn echo off -- 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 get -- 500 milliseconds where get = do c <- getChar if c == '\ESC' then get' [c] else return [c] -- If the first character is not the expected \ESC then -- give up. This provides a modicom of protection against -- unexpected data in the input stream. get' s = do c <- getChar if c /= 'R' then get' (c:s) -- Continue building the list, until the expected 'R' -- character is obtained. Build the list in reverse order, -- in order to avoid O(n^2) complexity. else return $ reverse (c:s) -- Reverse the order of the built list. -- 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 hSetBuffering stdin NoBuffering -- set no buffering (the contents of the -- buffer will be discarded, so this needs -- to be done before the cursor positon is -- emitted) hReportCursorPosition h hFlush h -- ensure the report cursor position code is sent to the -- operating system getReportedCursorPosition case readP_to_S cursorPosition input of [] -> return Nothing [((row, col),_)] -> return $ Just (row, col) (_:_) -> return Nothing ansi-terminal-0.10.3/src/System/Win32/Compat.hs0000644000000000000000000000726313534270137017275 0ustar0000000000000000#include "Common-Safe-Haskell.hs" {-# OPTIONS_HADDOCK hide #-} {-| The Win32 library ships with GHC. Win32-2.1 first shipped with GHC 6.6 (released October 2006). 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.1 and other functionality first added to Win32-2.5.0.0 or Win32-2.5.1.0 (from ansi-terminal itself). 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 , WORD , failIfFalse_ , getLastError , iNVALID_HANDLE_VALUE , nullHANDLE , withHandleToHANDLE -- from Win32-2.5.1.0 , withTString ) where #if !MIN_VERSION_Win32(2,5,0) import Foreign.C.Types (CShort (..)) #endif #if !MIN_VERSION_Win32(2,5,1) import Control.Concurrent.MVar (readMVar) import Control.Exception (bracket) import Foreign.C.Types (CInt (..)) import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Data.Typeable (cast) import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 import GHC.IO.Handle.Types (Handle (..), Handle__ (..)) #endif import System.Win32.Types (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, nullHANDLE, withTString) #if MIN_VERSION_Win32(2,5,0) import System.Win32.Types (SHORT) #endif #if MIN_VERSION_Win32(2,5,1) import System.Win32.Types (withHandleToHANDLE) #endif #if !MIN_VERSION_Win32(2,5,0) type SHORT = CShort #endif #if !MIN_VERSION_Win32(2,5,1) #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 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 -- 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 withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtr #endif ansi-terminal-0.10.3/app/Example.hs0000644000000000000000000002445213617613120015242 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 , sgrColorExample , sgrOtherExample , cursorVisibilityExample , titleExample , getCursorPositionExample , getTerminalSizeExample ] main :: IO () main = mapM_ (\example -> resetScreen >> example) 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 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] putStrLn (show 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| 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. ansi-terminal-0.10.3/LICENSE0000644000000000000000000000301313233166765013542 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.10.3/Setup.hs0000644000000000000000000000006013274146713014164 0ustar0000000000000000import Distribution.Simple main = defaultMain ansi-terminal-0.10.3/ansi-terminal.cabal0000644000000000000000000000623213617613677016277 0ustar0000000000000000Name: ansi-terminal Version: 0.10.3 Cabal-Version: >= 1.8 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/feuerbach/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/feuerbach/ansi-terminal.git Flag Example Description: Build the example application Default: False Library Hs-Source-Dirs: src Exposed-Modules: System.Console.ANSI System.Console.ANSI.Types System.Console.ANSI.Codes Include-Dirs: src/includes Build-Depends: base >= 4.3.0.0 && < 5 , colour >=2.1.0 if os(windows) Build-Depends: containers >= 0.5.0.0 , mintty , Win32 >= 2.0 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 Extensions: CPP ForeignFunctionInterface Ghc-Options: -Wall Executable ansi-terminal-example Hs-Source-Dirs: app Main-Is: Example.hs Build-Depends: base >= 4.3.0.0 && < 5 , ansi-terminal , colour Ghc-Options: -Wall if !flag(example) Buildable: False ansi-terminal-0.10.3/src/includes/Common-Include.hs0000644000000000000000000003207313617613120020273 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, inclduding the related Haddock -- documentation. #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<*>)) import Data.Functor ((<$>)) #endif import Control.Monad (void) import Data.Char (isDigit) import System.Environment (getEnvironment) import System.IO (hFlush, stdout) import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy) 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. -- The function 'hGetBufNonBlocking' in module "System.IO" does not work on -- Windows. This has been attributed to the lack of non-blocking primatives in -- the operating system (see the GHC bug report #806 at -- ). -- -- @since 0.7.1 reportCursorPosition :: IO () saveCursor = hSaveCursor stdout restoreCursor = hRestoreCursor stdout reportCursorPosition = hReportCursorPosition stdout hHideCursor, hShowCursor :: Handle -> IO () hideCursor, showCursor :: IO () hideCursor = hHideCursor stdout showCursor = hShowCursor stdout -- | Set the terminal window title hSetTitle :: Handle -> String -- ^ New title -> IO () -- | Set the terminal window title setTitle :: String -- ^ New title -> 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 @return (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, @return (Just True)@ is -- returned. If it is identifed as connected to a native terminal, then, on -- Windows 10, the processing of \'ANSI\' control characters will be enabled and -- @return (Just True)@ returned; and, on versions of Windows before Windows 10, -- @return (Just False)@ is returned. Otherwise, if a @TERM@ environment -- variable is set to @dumb@, @return (Just False)@ is returned. In all other -- cases of a writable handle, @return 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' return (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: -- -- > hSetBuffering stdin NoBuffering -- set no buffering (the contents of the -- > -- buffer will be discarded, so this needs -- > -- to be done before the cursor positon is -- > -- emitted) -- > reportCursorPosition -- > hFlush stdout -- ensure the report cursor position code is sent to the -- > -- operating system -- > input <- getReportedCursorPosition -- -- On Windows operating systems, the function is not supported on consoles, such -- as mintty, that are not based on the Win32 console of the Windows API. -- (Command Prompt and PowerShell are based on the Win32 console.) -- -- @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 Win32 console of the Windows API. -- (Command Prompt and PowerShell are based on the Win32 console.) -- -- @since 0.10.3 getCursorPosition :: IO (Maybe (Int, Int)) getCursorPosition = hGetCursorPosition stdout -- | A synonym for 'getCursorPosition'. -- -- @since 0.8.2 {-# DEPRECATED getCursorPosition0 "Use getCursorPosition instead." #-} getCursorPosition0 :: IO (Maybe (Int, Int)) getCursorPosition0 = getCursorPosition -- | 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 Win32 console of the Windows API. -- (Command Prompt and PowerShell are based on the Win32 console.) -- -- @since 0.10.1 hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) -- | Attempts to get the current terminal size (height in rows, width in -- columns), by using 'getCursorPosition' to query the console input stream -- after attempting to set the cursor position beyond the bottom right corner of -- the terminal. Uses 'stdout'. If 'stdout' will be redirected, see -- '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 the Win32 console of the Windows API. -- (Command Prompt and PowerShell are based on the Win32 console.) -- -- @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') and using 'hGetCursorPosition' -- to query the console input stream after attempting to set the cursor position -- beyond the bottom right corner of the terminal. -- -- On Windows operating systems, the function is not supported on consoles, such -- as mintty, that are not based on the Win32 console of the Windows API. -- (Command Prompt and PowerShell are based on the Win32 console.) -- -- @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 return $ fmap (\(r, c) -> (r + 1, c + 1)) mPos ansi-terminal-0.10.3/src/includes/Common-Include-Emulator.hs0000644000000000000000000000475113233166765022077 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 -- | Scroll the displayed information up or down the terminal: not widely -- supported hScrollPageUp, hScrollPageDown :: ConsoleDefaultState -- ^ The default console state -> Handle -> Int -- ^ Number of lines to scroll by -> IO () -- | Scroll the displayed information up or down the terminal: not widely -- supported 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.10.3/src/includes/Common-Include-Enabled.hs0000644000000000000000000000377113233166765021642 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 -- | Scroll the displayed information up or down the terminal: not widely -- supported hScrollPageUp, hScrollPageDown :: Handle -> Int -- ^ Number of lines to scroll by -> IO () -- | Scroll the displayed information up or down the terminal: not widely -- supported scrollPageUp, scrollPageDown :: Int -- ^ Number of lines to scroll by -> IO () scrollPageUp = hScrollPageUp stdout scrollPageDown = hScrollPageDown stdout ansi-terminal-0.10.3/src/includes/Common-Safe-Haskell.hs0000644000000000000000000000017713534270137021154 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ansi-terminal-0.10.3/src/includes/Exports-Include.hs0000644000000000000000000000610513617613120020504 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 , hCursorUp , hCursorDown , hCursorForward , hCursorBackward , 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. -- -- Also keep in mind that @*Line@ functions are not as portable. See -- for the details. , cursorUpLine , cursorDownLine , hCursorUpLine , hCursorDownLine , cursorUpLineCode , cursorDownLineCode -- * Directly changing cursor position , setCursorColumn , hSetCursorColumn , setCursorColumnCode , setCursorPosition , hSetCursorPosition , setCursorPositionCode -- * Saving, restoring and reporting cursor position , saveCursor , hSaveCursor , saveCursorCode , restoreCursor , hRestoreCursor , restoreCursorCode , reportCursorPosition , hReportCursorPosition , reportCursorPositionCode -- * Clearing parts of the screen -- | Note that these functions only clear parts of the screen. They do not move the -- cursor. , clearFromCursorToScreenEnd , clearFromCursorToScreenBeginning , clearScreen , hClearFromCursorToScreenEnd , hClearFromCursorToScreenBeginning , hClearScreen , clearFromCursorToScreenEndCode , clearFromCursorToScreenBeginningCode , clearScreenCode , clearFromCursorToLineEnd , clearFromCursorToLineBeginning , clearLine , hClearFromCursorToLineEnd , hClearFromCursorToLineBeginning , hClearLine , clearFromCursorToLineEndCode , clearFromCursorToLineBeginningCode , clearLineCode -- * Scrolling the screen , scrollPageUp , scrollPageDown , hScrollPageUp , hScrollPageDown , scrollPageUpCode , scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGR , hSetSGR , setSGRCode -- * Cursor visibilty changes , hideCursor , showCursor , hHideCursor , hShowCursor , hideCursorCode , showCursorCode -- * 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 -- * Deprecated , getCursorPosition0 ansi-terminal-0.10.3/CHANGELOG.md0000644000000000000000000001054113617613120014336 0ustar0000000000000000Changes ======= 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 identifed 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.10.3/README.md0000644000000000000000000000735613250572561014024 0ustar0000000000000000ansi-terminal ============= 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 - 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/feuerbach/ansi-terminal/blob/master/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/feuerbach) 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.