ansi-terminal 0.7.1.1 → 0.8
raw patch · 16 files changed
+1492/−1258 lines, 16 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- System.Console.ANSI.Types: SetBlinkSpeed :: BlinkSpeed -> SGR
+ System.Console.ANSI.Types: SetBlinkSpeed :: !BlinkSpeed -> SGR
- System.Console.ANSI.Types: SetColor :: ConsoleLayer -> ColorIntensity -> Color -> SGR
+ System.Console.ANSI.Types: SetColor :: !ConsoleLayer -> !ColorIntensity -> !Color -> SGR
- System.Console.ANSI.Types: SetConsoleIntensity :: ConsoleIntensity -> SGR
+ System.Console.ANSI.Types: SetConsoleIntensity :: !ConsoleIntensity -> SGR
- System.Console.ANSI.Types: SetItalicized :: Bool -> SGR
+ System.Console.ANSI.Types: SetItalicized :: !Bool -> SGR
- System.Console.ANSI.Types: SetRGBColor :: ConsoleLayer -> (Colour Float) -> SGR
+ System.Console.ANSI.Types: SetRGBColor :: !ConsoleLayer -> !(Colour Float) -> SGR
- System.Console.ANSI.Types: SetSwapForegroundBackground :: Bool -> SGR
+ System.Console.ANSI.Types: SetSwapForegroundBackground :: !Bool -> SGR
- System.Console.ANSI.Types: SetUnderlining :: Underlining -> SGR
+ System.Console.ANSI.Types: SetUnderlining :: !Underlining -> SGR
- System.Console.ANSI.Types: SetVisible :: Bool -> SGR
+ System.Console.ANSI.Types: SetVisible :: !Bool -> SGR
Files
- CHANGELOG.md +8/−0
- System/Console/ANSI.hs +34/−26
- System/Console/ANSI/Codes.hs +92/−79
- System/Console/ANSI/Example.hs +227/−230
- System/Console/ANSI/Types.hs +27/−21
- System/Console/ANSI/Unix.hs +37/−35
- System/Console/ANSI/Windows.hs +20/−18
- System/Console/ANSI/Windows/Detect.hs +67/−50
- System/Console/ANSI/Windows/Emulator.hs +339/−273
- System/Console/ANSI/Windows/Emulator/Codes.hs +29/−26
- System/Console/ANSI/Windows/Foreign.hs +445/−363
- ansi-terminal.cabal +1/−1
- includes/Common-Include-Emulator.hs +31/−31
- includes/Common-Include-Enabled.hs +22/−22
- includes/Common-Include.hs +18/−18
- includes/Exports-Include.hs +95/−65
CHANGELOG.md view
@@ -1,6 +1,14 @@ Changes ======= +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 ---------------
System/Console/ANSI.hs view
@@ -3,10 +3,12 @@ -- or on other Windows operating systems where the terminal in use is not -- ANSI-enabled. ----- The ANSI escape codes are described at <http://en.wikipedia.org/wiki/ANSI_escape_code> and provide a rich range of--- functionality for terminal control, which includes:+-- The ANSI escape codes are described at <http://en.wikipedia.org/wiki/ANSI_escape_code>+-- and provide a rich range of functionality for terminal control, which+-- includes: ----- * Colored text output, with control over both foreground and background colors+-- * Colored text output, with control over both foreground and background+-- colors -- -- * Hiding or showing the cursor --@@ -14,26 +16,30 @@ -- -- * Clearing parts of the screen ----- The most frequently used parts of this ANSI command set are exposed with a platform independent interface by--- this module. Every function exported comes in three flavours:+-- The most frequently used parts of this ANSI command set are exposed with a+-- platform independent interface by this module. Every function exported comes+-- in three flavours: ----- * Vanilla: has an @IO ()@ type and doesn't take a @Handle@. This just outputs the ANSI command directly on--- to the terminal corresponding to stdout. Commands issued like this should work as you expect on both Windows--- and Unix.+-- * Vanilla: has an @IO ()@ type and doesn't take a @Handle@. This just+-- outputs the ANSI command directly on to the terminal corresponding to+-- stdout. Commands issued like this should work as you expect on both+-- Windows and Unix. ----- * Chocolate: has an @IO ()@ type but takes a @Handle@. This outputs the ANSI command on the terminal corresponding--- to the supplied handle. Commands issued like this should also work as you expect on both Windows and Unix.+-- * Chocolate: has an @IO ()@ type but takes a @Handle@. This outputs the+-- ANSI command on the terminal corresponding to the supplied handle.+-- Commands issued like this should also work as you expect on both Windows+-- and Unix. ----- * Strawberry: has a @String@ type and just consists of an escape code 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 Windows operating systems where the terminal in use--- is not ANSI-enabled (such as those before Windows 10 Threshold 2). On--- versions of Windows where the terminal in use is not ANSI-enabled, these--- codes will always be the empty string, so it is possible to use them--- portably for e.g. coloring console output on the understanding that you--- will only see colors if you are running on an operating system that is--- Unix-like or is a version of Windows where the terminal in use is ANSI---- enabled.+-- * Strawberry: has a @String@ type and just consists of an escape code 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 Windows+-- operating systems where the terminal in use is not ANSI-enabled (such as+-- those before Windows 10 Threshold 2). On versions of Windows where the+-- terminal in use is not ANSI-enabled, these codes will always be the empty+-- string, so it is possible to use them portably for e.g. coloring console+-- output on the understanding that you will only see colors if you are+-- running on an operating system that is Unix-like or is a version of+-- Windows where the terminal in use is ANSI-enabled. -- -- Example: --@@ -49,17 +55,19 @@ -- For many more examples, see the project's extensive -- <https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/System/Console/ANSI/Example.hs Example.hs> file. #if defined(WINDOWS)-module System.Console.ANSI (- module System.Console.ANSI.Windows- ) where+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+module System.Console.ANSI+ (+ module System.Console.ANSI.Unix+ ) where import System.Console.ANSI.Unix
System/Console/ANSI/Codes.hs view
@@ -1,62 +1,72 @@--- | Functions that return 'String' values containing codes in accordance with:--- (1) standard ECMA-48 Control Functions for Coded Character Sets (5th edition,--- 1991); or (2) in the case of 'setTitleCode', the XTerm control sequence.+-- | This module exports functions that return 'String' values containing codes+-- in accordance with: (1) standard ECMA-48 Control Functions for Coded+-- Character Sets (5th edition, 1991); or (2) in the case of 'saveCursorCode',+-- 'restoreCursorCode', 'reportCursorPositionCode' and 'setTitleCode', the XTerm+-- control sequence. -- -- The reference used for the codes in this module was -- <http://en.wikipedia.org/wiki/ANSI_escape_sequences>. ----- If module "System.Console.ANSI" is also imported, this module is intended to--- be imported qualified, to avoid name clashes with functions which return \"\"--- when Windows ANSI terminal support is emulated. e.g.+-- 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+ (+ -- * Basic data types+ module System.Console.ANSI.Types - -- * Cursor movement by character- , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode+ -- * Cursor movement by character+ , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode - -- * Cursor movement by line- , cursorUpLineCode, cursorDownLineCode+ -- * Cursor movement by line+ , cursorUpLineCode, cursorDownLineCode - -- * Directly changing cursor position- , setCursorColumnCode, setCursorPositionCode+ -- * Directly changing cursor position+ , setCursorColumnCode, setCursorPositionCode - -- * Saving, restoring and reporting cursor position- , saveCursorCode, restoreCursorCode, reportCursorPositionCode+ -- * Saving, restoring and reporting cursor position+ , saveCursorCode, restoreCursorCode, reportCursorPositionCode - -- * Clearing parts of the screen- , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode- , clearScreenCode, clearFromCursorToLineEndCode- , clearFromCursorToLineBeginningCode, clearLineCode+ -- * Clearing parts of the screen+ , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode+ , clearScreenCode, clearFromCursorToLineEndCode+ , clearFromCursorToLineBeginningCode, clearLineCode - -- * Scrolling the screen- , scrollPageUpCode, scrollPageDownCode+ -- * Scrolling the screen+ , scrollPageUpCode, scrollPageDownCode - -- * Select Graphic Rendition mode: colors and other whizzy stuff- , setSGRCode+ -- * Select Graphic Rendition mode: colors and other whizzy stuff+ , setSGRCode - -- * Cursor visibilty changes- , hideCursorCode, showCursorCode+ -- * 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+ -- * 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+ -- * Utilities+ , colorToCode, csi, sgrToCode+ ) where -import Data.Colour.SRGB (toSRGB24, RGB (..)) 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',@@ -73,51 +83,52 @@ -- eight colors in the 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+ 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]- SetRGBColor Foreground color -> [38, 2] ++ toRGB color- SetRGBColor Background color -> [48, 2] ++ toRGB color- where- toRGB color = let RGB r g b = toSRGB24 color- in map fromIntegral [r, g, b]+ 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]+ SetRGBColor Foreground color -> [38, 2] ++ toRGB color+ SetRGBColor Background color -> [48, 2] ++ toRGB color+ 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, 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"@@ -142,8 +153,10 @@ restoreCursorCode = "\ESC8" reportCursorPositionCode = csi [] "6n" -clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String-clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String+clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,+ clearScreenCode :: String+clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,+ clearLineCode :: String clearFromCursorToScreenEndCode = csi [0] "J" clearFromCursorToScreenBeginningCode = csi [1] "J"
System/Console/ANSI/Example.hs view
@@ -1,14 +1,13 @@-module Main (- main- ) where--import System.Console.ANSI--import System.IO+module Main+ (+ main+ ) where -import Control.Concurrent-import Control.Monad+import Control.Concurrent (threadDelay)+import Control.Monad (forM_)+import System.IO (hFlush, stdout) +import System.Console.ANSI examples :: [IO ()] examples = [ cursorMovementExample@@ -37,282 +36,280 @@ pause :: IO () pause = do- hFlush stdout- -- 1 second pause- threadDelay 1000000+ hFlush stdout+ -- 1 second pause+ threadDelay 1000000 cursorMovementExample :: IO () cursorMovementExample = do- putStrLn "Line One"- putStr "Line Two"- pause- -- Line One- -- Line Two+ putStrLn "Line One"+ putStr "Line Two"+ pause+ -- Line One+ -- Line Two - cursorUp 1- putStr " - Extras"- pause- -- Line One - Extras- -- Line Two+ cursorUp 1+ putStr " - Extras"+ pause+ -- Line One - Extras+ -- Line Two - cursorBackward 2- putStr "zz"- pause- -- Line One - Extrzz- -- 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+ 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+ 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+ putStrLn "Line One"+ putStr "Line Two"+ pause+ -- Line One+ -- Line Two - cursorUpLine 1- putStr "New Line One"- pause- -- New 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+ 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+ putStrLn "Line One"+ putStrLn "Line Two"+ pause+ -- Line One+ -- Line Two - setCursorPosition 0 5- putStr "Foo"- pause- -- Line Foo- -- Line Two+ setCursorPosition 0 5+ putStr "Foo"+ pause+ -- Line Foo+ -- Line Two - setCursorPosition 1 5- putStr "Bar"- pause- -- Line Foo- -- Line Bar+ setCursorPosition 1 5+ putStr "Bar"+ pause+ -- Line Foo+ -- Line Bar - setCursorColumn 1- putStr "oaf"- pause- -- Line Foo- -- Loaf Bar+ setCursorColumn 1+ putStr "oaf"+ pause+ -- Line Foo+ -- Loaf Bar saveRestoreCursorExample :: IO () saveRestoreCursorExample = do- putStr "Start sentence ..."- pause- -- Start sentence ...+ putStr "Start sentence ..."+ pause+ -- Start sentence ... - saveCursor- setCursorPosition 2 3- putStr "SPLASH!"- pause- -- Start sentence ...- --- -- SPLASH!+ saveCursor+ setCursorPosition 2 3+ putStr "SPLASH!"+ pause+ -- Start sentence ...+ --+ -- SPLASH! - restoreCursor- putStr " end sentence, uninterrupted."- pause- -- Start sentence ... end sentence, uninterrupted- --- -- 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-+ putStrLn "Line One"+ putStrLn "Line Two"+ pause+ -- Line One+ -- Line Two - resetScreen- putStrLn "Line One"- putStrLn "Line Two"- pause- -- Line One- -- Line Two+ setCursorPosition 0 4+ clearFromCursorToScreenEnd+ pause+ -- Line - setCursorPosition 1 4- clearFromCursorToScreenBeginning- pause- --- -- Two+ 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+ resetScreen+ putStrLn "Line One"+ putStrLn "Line Two"+ pause+ -- Line One+ -- Line Two - setCursorPosition 0 4- clearFromCursorToLineEnd- pause- -- Line- -- Line Two+ setCursorPosition 0 4+ clearFromCursorToLineEnd+ pause+ -- Line+ -- Line Two - setCursorPosition 1 4- clearFromCursorToLineBeginning- pause- -- Line- -- Two+ setCursorPosition 1 4+ clearFromCursorToLineBeginning+ pause+ -- Line+ -- Two - clearLine- pause- -- Line+ clearLine+ pause+ -- Line - clearScreen- pause- --+ clearScreen+ pause+ -- scrollExample :: IO () scrollExample = do- putStrLn "Line One"- putStrLn "Line Two"- putStrLn "Line Three"- pause- -- Line One- -- Line Two- -- Line Three+ 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+ scrollPageDown 2+ pause+ --+ --+ -- Line One+ -- Line Two+ -- Line Three - scrollPageUp 3- pause- -- Line Two- -- Line Three+ scrollPageUp 3+ pause+ -- Line Two+ -- Line Three sgrExample :: IO () sgrExample = 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- -- All the colors, 4 times in sequence+ 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+ -- All the colors, 4 times in sequence - 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+ 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]+ 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 False]+ putStr "Red-On-Blue"+ pause+ -- Red-On-Blue - clearScreen >> setCursorPosition 0 0- setSGR [SetSwapForegroundBackground True]- putStr "Blue-On-Red"- pause- -- Blue-On-Red+ 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|+ putStr "Cursor Demo"+ pause+ -- Cursor Demo| - hideCursor- pause- -- Cursor Demo+ hideCursor+ pause+ -- Cursor Demo - showCursor- pause- -- Cursor Demo|+ showCursor+ pause+ -- Cursor Demo| titleExample :: IO () titleExample = do- putStr "Title Demo"- pause- -- ~/foo/ - ansi-terminal-ex - 83x70- ------------------------------------- -- Title Demo+ 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+ 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 ++ " and column number " ++ show col ++ ".\n"- Nothing -> putStrLn "Error: unable to get the cursor position\n"- 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.+ 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 ++ " and column number " ++ show col ++ ".\n"+ Nothing -> putStrLn "Error: unable to get the cursor position\n"+ 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.
System/Console/ANSI/Types.hs view
@@ -1,19 +1,21 @@ -- | Types used to represent SELECT GRAPHIC RENDITION (SGR) aspects. module System.Console.ANSI.Types- (- SGR (..)- , ConsoleLayer (..)- , Color (..)- , ColorIntensity (..)- , ConsoleIntensity (..)- , Underlining (..)- , BlinkSpeed (..)- ) where+ (+ SGR (..)+ , ConsoleLayer (..)+ , Color (..)+ , ColorIntensity (..)+ , ConsoleIntensity (..)+ , Underlining (..)+ , BlinkSpeed (..)+ ) where +import Data.Ix (Ix)+ import Data.Colour (Colour)-import Data.Ix --- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity'+-- | ANSI colors: come in various intensities, which are controlled by+-- 'ColorIntensity' data Color = Black | Red | Green@@ -46,20 +48,24 @@ | 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)+-- | ANSI general console intensity: usually treated as setting the font style+-- (e.g. 'BoldIntensity' causes text to be bold) data ConsoleIntensity = BoldIntensity- | FaintIntensity -- ^ Not widely supported: sometimes treated as concealing text+ | FaintIntensity -- ^ Not widely supported: sometimes+ -- treated as concealing text | NormalIntensity deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI Select Graphic Rendition command data SGR = Reset- | SetConsoleIntensity ConsoleIntensity- | SetItalicized Bool -- ^ Not widely supported: sometimes treated as swapping foreground and background- | SetUnderlining Underlining- | SetBlinkSpeed BlinkSpeed- | SetVisible Bool -- ^ Not widely supported- | SetSwapForegroundBackground Bool- | SetColor ConsoleLayer ColorIntensity Color- | SetRGBColor ConsoleLayer (Colour Float) -- ^ Supported from Windows 10 Creators Update+ | SetConsoleIntensity !ConsoleIntensity+ | SetItalicized !Bool -- ^ Not widely supported: sometimes treated as+ -- swapping foreground and background+ | SetUnderlining !Underlining+ | SetBlinkSpeed !BlinkSpeed+ | SetVisible !Bool -- ^ Not widely supported+ | SetSwapForegroundBackground !Bool+ | SetColor !ConsoleLayer !ColorIntensity !Color+ | SetRGBColor !ConsoleLayer !(Colour Float) -- ^ Supported from Windows 10+ -- Creators Update deriving (Eq, Show, Read)
System/Console/ANSI/Unix.hs view
@@ -1,19 +1,21 @@ {-# OPTIONS_HADDOCK hide #-} -module System.Console.ANSI.Unix (+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+ ) where import Control.Exception.Base (bracket)-import System.Console.ANSI.Codes-import System.Console.ANSI.Types import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho,- hIsTerminalDevice, hPutStr, hSetBuffering, hSetEcho, stdin, stdout)+ hIsTerminalDevice, hPutStr, hSetBuffering, hSetEcho, stdin, stdout) 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@@ -41,7 +43,8 @@ hReportCursorPosition h = hPutStr h reportCursorPositionCode hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode-hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode+hClearFromCursorToScreenBeginning h+ = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode@@ -63,36 +66,35 @@ getReportedCursorPosition = bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do hSetEcho stdin False -- Turn echo off get- 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.+ 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. -- getCursorPosition :: IO (Maybe (Int, Int)) -- (See Common-Include.hs for Haddock documentation) 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)- reportCursorPosition- hFlush stdout -- 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+ 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)+ reportCursorPosition+ hFlush stdout -- 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
System/Console/ANSI/Windows.hs view
@@ -1,18 +1,20 @@ {-# OPTIONS_HADDOCK hide #-} -module System.Console.ANSI.Windows (+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+ ) where +import System.IO (Handle, hIsTerminalDevice, stdout)+ import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as U import System.Console.ANSI.Windows.Detect (ANSIEnabledStatus (..),- ConsoleDefaultState (..), isANSIEnabled)+ ConsoleDefaultState (..), isANSIEnabled) import qualified System.Console.ANSI.Windows.Emulator as E-import System.IO (Handle, hIsTerminalDevice, stdout) -- 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@@ -29,15 +31,15 @@ -- on `isANSIEnabled`. nativeOrEmulated :: a -> a -> a nativeOrEmulated native emulated = case isANSIEnabled of- ANSIEnabled -> native- NotANSIEnabled _ -> emulated+ ANSIEnabled -> native+ NotANSIEnabled _ -> emulated -- | A helper function which returns the native or emulated version, depending -- on `isANSIEnabled`, where the emulator uses the default console state. nativeOrEmulatedWithDefault :: a -> (ConsoleDefaultState -> a) -> a nativeOrEmulatedWithDefault native emulated = case isANSIEnabled of- ANSIEnabled -> native- NotANSIEnabled def -> emulated def+ ANSIEnabled -> native+ NotANSIEnabled def -> emulated def -- * Cursor movement by character@@ -73,19 +75,19 @@ setCursorColumnCode :: Int -> String setCursorColumnCode = nativeOrEmulated- U.setCursorColumnCode E.setCursorColumnCode+ U.setCursorColumnCode E.setCursorColumnCode hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition setCursorPositionCode :: Int -> Int -> String setCursorPositionCode = nativeOrEmulated- U.setCursorPositionCode E.setCursorPositionCode+ 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+ U.hReportCursorPosition E.hReportCursorPosition saveCursorCode :: String saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode@@ -99,14 +101,14 @@ -- * Clearing parts of the screen hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault- U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd+ U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault- U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning+ U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen clearFromCursorToScreenEndCode :: String clearFromCursorToScreenEndCode = nativeOrEmulated- U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode+ U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode clearFromCursorToScreenBeginningCode :: String clearFromCursorToScreenBeginningCode = nativeOrEmulated@@ -116,18 +118,18 @@ clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault- U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd+ U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault- U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning+ U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine clearFromCursorToLineEndCode :: String clearFromCursorToLineEndCode = nativeOrEmulated- U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode+ U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode clearFromCursorToLineBeginningCode :: String clearFromCursorToLineBeginningCode = nativeOrEmulated- U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode+ U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode clearLineCode :: String clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode
System/Console/ANSI/Windows/Detect.hs view
@@ -1,37 +1,38 @@ {-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Detect-(- ANSIEnabledStatus (..)-, ConsoleDefaultState (..)-, isANSIEnabled-) where+ (+ ANSIEnabledStatus (..)+ , ConsoleDefaultState (..)+ , isANSIEnabled+ ) where -import Control.Exception (SomeException(..), throwIO, try)+import Control.Exception (SomeException(..), onException, throwIO, try) import Data.Bits ((.&.), (.|.))-import System.Console.ANSI.Windows.Foreign (bACKGROUND_INTENSE_WHITE,- ConsoleException(..), CONSOLE_SCREEN_BUFFER_INFO (..), DWORD,- eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_INTENSE_WHITE,- getConsoleMode, getConsoleScreenBufferInfo, getStdHandle, HANDLE,- iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE, WORD) -- 'lookupEnv' is not available until base-4.6.0.0 (GHC 7.6.1) import System.Environment.Compat (lookupEnv) import System.IO.Unsafe (unsafePerformIO) +import System.Console.ANSI.Windows.Foreign (bACKGROUND_INTENSE_WHITE,+ ConsoleException(..), CONSOLE_SCREEN_BUFFER_INFO (..), DWORD,+ eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_INTENSE_WHITE,+ getConsoleMode, getConsoleScreenBufferInfo, getStdHandle, HANDLE,+ iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE, WORD)+ -- | The default state of the console data ConsoleDefaultState = ConsoleDefaultState- { defaultForegroundAttributes :: WORD -- ^ Foreground attributes- , defaultBackgroundAttributes :: WORD -- ^ Background attributes- } deriving (Eq, Show)+ { defaultForegroundAttributes :: WORD -- ^ Foreground attributes+ , defaultBackgroundAttributes :: WORD -- ^ Background attributes+ } deriving (Eq, Show) -- | The status of the console as regards it being ANSI-enabled or not -- ANSI-enabled. data ANSIEnabledStatus- = ANSIEnabled -- ^ ANSI-enabled- | NotANSIEnabled ConsoleDefaultState -- ^ Not ANSI-enabled (including the- -- state of the console when that- -- status was determined)- deriving (Eq, Show)+ = ANSIEnabled -- ^ ANSI-enabled+ | NotANSIEnabled ConsoleDefaultState -- ^ Not ANSI-enabled (including the+ -- state of the console when that status+ -- was determined)+ deriving (Eq, Show) -- | This function assumes that once it is first established whether or not the -- Windows console is ANSI-enabled, that will not change. If the console is not@@ -39,32 +40,48 @@ {-# NOINLINE isANSIEnabled #-} isANSIEnabled :: ANSIEnabledStatus isANSIEnabled = unsafePerformIO $ do- e <- safeIsANSIEnabled- if e- then return ANSIEnabled- else do- hOut <- getValidStdHandle sTD_OUTPUT_HANDLE- info <- getConsoleScreenBufferInfo hOut- let attributes = csbi_attributes info- fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE- bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE- consoleDefaultState = ConsoleDefaultState- { defaultForegroundAttributes = fgAttributes- , defaultBackgroundAttributes = bgAttributes }- return $ NotANSIEnabled consoleDefaultState+ e <- safeIsANSIEnabled+ if e+ then return ANSIEnabled+ else onException (do+ hOut <- getValidStdHandle sTD_OUTPUT_HANDLE+ info <- getConsoleScreenBufferInfo hOut+ let attributes = csbi_attributes info+ fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE+ bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE+ consoleDefaultState = ConsoleDefaultState+ { defaultForegroundAttributes = fgAttributes+ , defaultBackgroundAttributes = bgAttributes }+ return $ NotANSIEnabled consoleDefaultState)+ (putStrLn $ "A fatal error has occurred. An attempt has been made to " +++ "send console virtual terminal sequences (ANSI codes) to an output " +++ "that has not been recognised as an ANSI-capable terminal and also " +++ "cannot be emulated as an ANSI-enabled terminal (emulation needs a " +++ "ConHost-based terminal, such as Command Prompt or PowerShell).\n\n" +++ "If that is unexpected, please post an issue at the home page of " +++ "the ansi-terminal package. See " +++ "https://hackage.haskell.org/package/ansi-terminal for the home " +++ "page location.\n") --- This function takes the following approach. If the environment variable TERM--- exists and is not set to 'dumb' or 'msys' (see below), it assumes the console--- is ANSI-enabled. Otherwise, it tries to enable virtual terminal processing.--- If that fails, it assumes the console is not ANSI-enabled.+-- This function takes the following approach. If the environment variable+-- APPVEYOR exists and is set to 'True', it assumes the code is running in the+-- Appveyor build environment and that the build console is ANSI-enabled.+-- Otherwise, if the environment variable TERM exists and is not set to 'dumb'+-- or 'msys' (see below), it assumes the console is ANSI-enabled. Otherwise, it+-- tries to enable virtual terminal processing. If that fails, it assumes the+-- console is not ANSI-enabled. -- -- In Git Shell, if Command Prompt or PowerShell are used, the environment -- variable TERM is set to 'msys'. If 'Git Bash' (mintty) is used, TERM is set -- to 'xterm' (by default). safeIsANSIEnabled :: IO Bool safeIsANSIEnabled = do- result <- lookupEnv "TERM"- case result of+ appveyor <- lookupEnv "APPVEYOR"+ case appveyor of+ Just "True" -> return True+ _ -> do+ term <- lookupEnv "TERM"+ case term of Just "dumb" -> return False Just "msys" -> doesEnableANSIOutSucceed Just _ -> return True@@ -74,25 +91,25 @@ -- processing succeeded, in the IO monad. doesEnableANSIOutSucceed :: IO Bool doesEnableANSIOutSucceed = do- result <- try enableANSIOut :: IO (Either SomeException ())- case result of- Left _ -> return False- Right () -> return True+ result <- try enableANSIOut :: IO (Either SomeException ())+ case result of+ Left _ -> return False+ Right () -> return True -- This function tries to enable virtual terminal processing on the standard -- output and throws an exception if it cannot. enableANSIOut :: IO () enableANSIOut = do- hOut <- getValidStdHandle sTD_OUTPUT_HANDLE- mOut <- getConsoleMode hOut- let mOut' = mOut .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING- setConsoleMode hOut mOut'+ hOut <- getValidStdHandle sTD_OUTPUT_HANDLE+ mOut <- getConsoleMode hOut+ let mOut' = mOut .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING+ setConsoleMode hOut mOut' -- This function tries to get a valid standard handle and throws an exception if -- it cannot. getValidStdHandle :: DWORD -> IO HANDLE getValidStdHandle nStdHandle = do- h <- getStdHandle nStdHandle- if h == iNVALID_HANDLE_VALUE || h == nullHANDLE- then throwIO $ ConsoleException 6 -- Invalid Handle- else return h+ h <- getStdHandle nStdHandle+ if h == iNVALID_HANDLE_VALUE || h == nullHANDLE+ then throwIO $ ConsoleException 6 -- Invalid Handle+ else return h
System/Console/ANSI/Windows/Emulator.hs view
@@ -1,31 +1,32 @@ {-# OPTIONS_HADDOCK hide #-} -module System.Console.ANSI.Windows.Emulator (+module System.Console.ANSI.Windows.Emulator+ ( #include "Exports-Include.hs"- ) where--import System.Console.ANSI.Types-import qualified System.Console.ANSI.Unix as Unix-import System.Console.ANSI.Windows.Detect-import System.Console.ANSI.Windows.Foreign-import System.Console.ANSI.Windows.Emulator.Codes--import System.IO-import System.IO.Unsafe (unsafePerformIO)+ ) where import Control.Exception (catch, catchJust, IOException) import Control.Monad (forM_, unless)-import Data.Colour (Colour)-import Data.Colour.Names (black, blue, cyan, green, grey, lime, magenta, maroon,- navy, olive, purple, red, silver, teal, white, yellow)-import Data.Colour.SRGB (RGB (..), toSRGB)-import Data.Bits+import Data.Bits ((.&.), (.|.), complement, shiftL, shiftR) import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.List+import Data.List (foldl', minimumBy) import Data.Maybe (mapMaybe)-import qualified Data.Map.Strict as Map+import qualified Data.Map.Strict as Map (Map, empty, insert, lookup)+import System.IO (Handle, hFlush, hIsTerminalDevice, stdin, stdout)+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.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@@ -39,52 +40,85 @@ 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-+ -- 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).+-- 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.+-- 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.+-- 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-+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+ -> (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- (COORD x y) = csbi_cursor_position screen_buffer_info- cursor_pos' = COORD (change_x (rect_left window) x) (change_y (rect_top window) y)- setConsoleCursorPosition handle cursor_pos'+ screen_buffer_info <- getConsoleScreenBufferInfo handle+ let window = csbi_window screen_buffer_info+ (COORD x y) = csbi_cursor_position screen_buffer_info+ cursor_pos'= COORD (change_x (rect_left window) x)+ (change_y (rect_top window) 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)+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+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)+hCursorDownLine h n+ = emulatorFallback (Unix.hCursorDownLine 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)+hCursorUpLine h n+ = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $+ \handle -> adjustLine handle (\_ y -> y - fromIntegral n) -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)+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 ' ' @@ -93,227 +127,258 @@ clearAttribute = defaultBackgroundAttributes hClearScreenFraction- :: ConsoleDefaultState- -> HANDLE- -> (SMALL_RECT -> COORD -> (SHORT, SHORT, SHORT, SHORT, SHORT, SHORT))- -> IO ()+ :: 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+ 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+ = 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+ = 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+ = 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+ = 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+ = 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+ = 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 ()+ :: 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+ 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)+ = 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+ = 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)+ 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+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+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- 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'- where- iNTENSITY = fOREGROUND_INTENSITY+ Reset -> def+ 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'+ 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'+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 })+ 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+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+-- 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+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- forM_ result (setConsoleCursorPosition handle)+hRestoreCursor h+ = emulatorFallback (Unix.hRestoreCursor h) $ withHandle h $ \handle -> do+ m <- readIORef cursorPositionRef+ let result = Map.lookup handle m+ forM_ result (setConsoleCursorPosition handle) -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 ()+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)+ 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@@ -338,61 +403,62 @@ 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+ 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 -- getReportedCursorPosition :: IO String -- (See Common-Include.hs for Haddock documentation)-getReportedCursorPosition = 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+getReportedCursorPosition+ = 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 -- getCursorPosition :: IO (Maybe (Int, Int)) -- (See Common-Include.hs for Haddock documentation) getCursorPosition = catch getCursorPosition' getCPExceptionHandler- where- getCursorPosition' = do- withHandleToHANDLE stdin flush -- Flush the console input buffer- reportCursorPosition- hFlush stdout -- 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)+ where+ getCursorPosition' = do+ withHandleToHANDLE stdin flush -- Flush the console input buffer+ reportCursorPosition+ hFlush stdout -- 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."+ 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."
System/Console/ANSI/Windows/Emulator/Codes.hs view
@@ -1,41 +1,42 @@ {-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Emulator.Codes- (- -- * Cursor movement by character- cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode+ (+ -- * Cursor movement by character+ cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode - -- * Cursor movement by line- , cursorUpLineCode, cursorDownLineCode+ -- * Cursor movement by line+ , cursorUpLineCode, cursorDownLineCode - -- * Directly changing cursor position- , setCursorColumnCode, setCursorPositionCode+ -- * Directly changing cursor position+ , setCursorColumnCode, setCursorPositionCode - -- * Saving, restoring and reporting cursor position- , saveCursorCode, restoreCursorCode, reportCursorPositionCode+ -- * Saving, restoring and reporting cursor position+ , saveCursorCode, restoreCursorCode, reportCursorPositionCode - -- * Clearing parts of the screen- , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode- , clearScreenCode, clearFromCursorToLineEndCode- , clearFromCursorToLineBeginningCode, clearLineCode+ -- * Clearing parts of the screen+ , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode+ , clearScreenCode, clearFromCursorToLineEndCode+ , clearFromCursorToLineBeginningCode, clearLineCode - -- * Scrolling the screen- , scrollPageUpCode, scrollPageDownCode+ -- * Scrolling the screen+ , scrollPageUpCode, scrollPageDownCode - -- * Select Graphic Rendition mode: colors and other whizzy stuff- , setSGRCode+ -- * Select Graphic Rendition mode: colors and other whizzy stuff+ , setSGRCode - -- * Cursor visibilty changes- , hideCursorCode, showCursorCode+ -- * Cursor visibilty changes+ , hideCursorCode, showCursorCode - -- * Changing the title- , setTitleCode- ) where+ -- * 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+ :: Int -- ^ Number of lines or characters to move+ -> String cursorUpCode _ = "" cursorDownCode _ = "" cursorForwardCode _ = ""@@ -60,8 +61,10 @@ restoreCursorCode = "" reportCursorPositionCode = "" -clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String-clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String+clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,+ clearScreenCode :: String+clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,+ clearLineCode :: String clearFromCursorToScreenEndCode = "" clearFromCursorToScreenBeginningCode = ""
System/Console/ANSI/Windows/Foreign.hs view
@@ -2,92 +2,104 @@ {-# 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(..),+-- | "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, - sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE,+ -- 'Re-exports from System.Win32.Console.Extra'+ INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT,+ KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput,+ getNumberOfConsoleInputEvents, readConsoleInput, - eNABLE_VIRTUAL_TERMINAL_INPUT,- eNABLE_VIRTUAL_TERMINAL_PROCESSING,+ charToWCHAR, cWcharsToChars, - 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,+ COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right,+ rect_width, rect_height, CONSOLE_CURSOR_INFO(..),+ CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), - getStdHandle,- getConsoleScreenBufferInfo,- getConsoleCursorInfo,- getConsoleMode,+ sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, - setConsoleTextAttribute,- setConsoleCursorPosition,- setConsoleCursorInfo,- setConsoleTitle,- setConsoleMode,+ eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, - fillConsoleOutputAttribute,- fillConsoleOutputCharacter,- scrollConsoleScreenBuffer,+ 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, - withTString, withHandleToHANDLE,+ getStdHandle,+ getConsoleScreenBufferInfo,+ getConsoleCursorInfo,+ getConsoleMode, - ConsoleException(..)- ) where+ setConsoleTextAttribute,+ setConsoleCursorPosition,+ setConsoleCursorInfo,+ setConsoleTitle,+ setConsoleMode, -import Foreign.C.Types-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable+ fillConsoleOutputAttribute,+ fillConsoleOutputCharacter,+ scrollConsoleScreenBuffer, -import Data.Bits-import Data.Char+ withTString, withHandleToHANDLE, -import System.Win32.Types+ ConsoleException (..)+ ) where import Control.Exception (Exception, throw)--#if __GLASGOW_HASKELL__ >= 612-import Data.Typeable+import Data.Bits ((.|.), shiftL)+import Data.Char (chr, ord)+import Data.Typeable (Typeable)+import Foreign.C.Types (CInt (..), CWchar (..))+-- Some Windows types missing from System.Win32 prior to version 2.5.0.0+#if !MIN_VERSION_Win32(2,5,0)+import Foreign.C.Types (CShort (..)) #endif+import Foreign.Marshal (alloca, allocaArray, maybeWith, peekArray, with,+ withArrayLen)+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Foreign.Storable (Storable (..)) #if !MIN_VERSION_Win32(2,5,1)-import Control.Concurrent.MVar-import Foreign.StablePtr+import Control.Concurrent.MVar (readMVar) import Control.Exception (bracket)+import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) #if __GLASGOW_HASKELL__ >= 612-import GHC.IO.Handle.Types (Handle(..), Handle__(..))+import Data.Typeable (cast) import GHC.IO.FD (FD(..)) -- A wrapper around an Int32-import Data.Typeable+import GHC.IO.Handle.Types (Handle (..), Handle__ (..)) #else-import GHC.IOBase (Handle(..), Handle__(..))-import qualified GHC.IOBase as IOBase (FD) -- Just an Int32+import GHC.IOBase (Handle (..), Handle__ (..))+import qualified GHC.IOBase as IOBase (FD) -- Just an Int32 #endif #endif +import System.Win32.Types (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD,+ TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE,+ nullHANDLE, withTString)+-- Missing from System.Win32.Types prior to version 2.5.0.0+#if MIN_VERSION_Win32(2,5,0)+import System.Win32.Types (SHORT)+#endif+-- withHandleToHANDLE added to System.Win32.Types from version 2.5.1.0+#if MIN_VERSION_Win32(2,5,1)+import System.Win32.Types (withHandleToHANDLE)+#endif+ #if defined(i386_HOST_ARCH)-# define WINDOWS_CCONV stdcall+#define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH)-# define WINDOWS_CCONV ccall+#define WINDOWS_CCONV ccall #else-# error Unknown mingw32 arch+#error Unknown mingw32 arch #endif ---import System.Console.ANSI.Windows.Foreign.Compat+-- Missing from System.Win32.Types prior to version 2.5.0.0 #if !MIN_VERSION_Win32(2,5,0)--- Some Windows types missing from System.Win32 prior version 2.5.0.0 type SHORT = CShort #endif type WCHAR = CWchar@@ -95,57 +107,55 @@ 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.+-- 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.+-- 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)+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)+ 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)-+ poke ptr item+ return (ptr `plusPtr` sizeOf item) -data COORD = COORD {- coord_x :: SHORT,- coord_y :: SHORT- }- deriving (Read, Eq)+data COORD = COORD+ { coord_x :: SHORT+ , coord_y :: SHORT+ } deriving (Read, Eq) instance Show COORD where- show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")"+ 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-+ 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- }+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@@ -158,139 +168,176 @@ rect_height rect = rect_bottom rect - rect_top rect + 1 instance Show SMALL_RECT where- show (SMALL_RECT tl br) = show tl ++ "-" ++ show br+ 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-+ 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)+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-+ 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)+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-+ 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)+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-+ 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 = -10-sTD_OUTPUT_HANDLE = -11-sTD_ERROR_HANDLE = -12+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+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+cOMMON_LVB_UNDERSCORE = 0x8000 -fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_INTENSE_WHITE :: WORD+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, 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+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 (Show, Eq, Typeable) @@ -300,97 +347,122 @@ throwIfFalse action = do succeeded <- action if not succeeded- then getLastError >>= throw . ConsoleException -- TODO: Check if last error is zero for some instructable reason (?)+ 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-+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+ 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+ throwIfFalse $ cGetConsoleMode handle ptr_mode+ peek ptr_mode setConsoleTextAttribute :: HANDLE -> WORD -> IO ()-setConsoleTextAttribute handle attributes = throwIfFalse $ cSetConsoleTextAttribute handle attributes+setConsoleTextAttribute handle attributes+ = throwIfFalse $ cSetConsoleTextAttribute handle attributes setConsoleCursorPosition :: HANDLE -> COORD -> IO ()-setConsoleCursorPosition handle cursor_position = throwIfFalse $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position)+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+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-+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+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+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+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-+ throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle+ ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill +-- withHandleToHANDLE added to System.Win32.Types from version 2.5.1.0 #if !MIN_VERSION_Win32(2,5,1)--- | 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 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 was added in Win32-2.5.1.0+-- This code accomplishes this, albeit at the cost of only being compatible with+-- GHC. withHandleToHANDLE was added in Win32-2.5.1.0 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+ -- 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+ -- Get the FD from the algebraic data type #if __GLASGOW_HASKELL__ < 612- fd <- fmap haFD $ readMVar write_handle_mvar+ fd <- fmap haFD $ readMVar write_handle_mvar #else- --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev)- Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar+ -- readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) ->+ -- print (typeOf dev)+ Just fd <- fmap (\(Handle__ { haDevice = dev }) ->+ fmap fdFD (cast dev)) $ readMVar write_handle_mvar #endif - -- Finally, turn that (C-land) FD into a HANDLE using msvcrt- windows_handle <- cget_osfhandle fd+ -- 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+ -- 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!+-- 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! #if __GLASGOW_HASKELL__ >= 612-foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE+foreign import WINDOWS_CCONV unsafe "_get_osfhandle"+ cget_osfhandle :: CInt -> IO HANDLE #else-foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE+foreign import WINDOWS_CCONV unsafe "_get_osfhandle"+ cget_osfhandle :: IOBase.FD -> IO HANDLE #endif -- withStablePtr was added in Win32-2.5.1.0@@ -402,14 +474,18 @@ -- 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)+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+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@@ -422,15 +498,16 @@ CHAR AsciiChar; } UNICODE_ASCII_CHAR; -}-newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar { unicodeAsciiChar :: WCHAR }- deriving (Show, Read, Eq)+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+ 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 {@@ -450,31 +527,31 @@ #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)+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+ 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 {@@ -484,77 +561,76 @@ DWORD dwEventFlags; } MOUSE_EVENT_RECORD; -}-data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD {- mousePosition :: COORD,- mouseButtonState :: DWORD,- mouseControlKeyState :: DWORD,- mouseEventFlags :: DWORD- } deriving (Show, Read, Eq)+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+ 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)+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+ 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)+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+ 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)+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+ 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)+ = 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 {@@ -568,59 +644,65 @@ } Event; } INPUT_RECORD,*PINPUT_RECORD; -}-data INPUT_RECORD = INPUT_RECORD {- inputEventType :: WORD,- inputEvent :: INPUT_RECORD_EVENT- } deriving (Show, Read, Eq)+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+ 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+ 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+readConsoleInput hdl len+ = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr -readConsoleInputWith :: HANDLE -> DWORD -> OutputHandler (Ptr INPUT_RECORD, DWORD)+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)+ 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
ansi-terminal.cabal view
@@ -1,5 +1,5 @@ Name: ansi-terminal-Version: 0.7.1.1+Version: 0.8 Cabal-Version: >= 1.6 Category: User Interfaces Synopsis: Simple ANSI terminal support, with Windows compatibility
includes/Common-Include-Emulator.hs view
@@ -4,45 +4,45 @@ -- | 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 ()+ :: 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 ()+ :: 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 ()+ :: ConsoleDefaultState -- ^ The default console state+ -> Handle+ -> IO () clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen- :: ConsoleDefaultState -- ^ The default console state- -> IO ()+ :: ConsoleDefaultState -- ^ The default console state+ -> IO () clearFromCursorToScreenEnd def = hClearFromCursorToScreenEnd def stdout clearFromCursorToScreenBeginning def- = hClearFromCursorToScreenBeginning def stdout+ = hClearFromCursorToScreenBeginning def stdout clearScreen def = hClearScreen def stdout hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine- :: ConsoleDefaultState -- ^ The default console state- -> Handle- -> IO ()+ :: ConsoleDefaultState -- ^ The default console state+ -> Handle+ -> IO () clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine- :: ConsoleDefaultState -- ^ The default console state- -> IO ()+ :: ConsoleDefaultState -- ^ The default console state+ -> IO () clearFromCursorToLineEnd def = hClearFromCursorToLineEnd def stdout clearFromCursorToLineBeginning def = hClearFromCursorToLineBeginning def stdout clearLine def = hClearLine def stdout@@ -50,16 +50,16 @@ -- | 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 ()+ :: 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 ()+ :: ConsoleDefaultState -- ^ The default console state+ -> Int -- ^ Number of lines to scroll by+ -> IO () scrollPageUp def = hScrollPageUp def stdout scrollPageDown def = hScrollPageDown def stdout
includes/Common-Include-Enabled.hs view
@@ -4,38 +4,38 @@ -- | 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 ()+ :: 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 ()+ :: [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 ()+ :: Handle+ -> IO () clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen- :: IO ()+ :: IO () clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout clearScreen = hClearScreen stdout hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine- :: Handle- -> IO ()+ :: Handle+ -> IO () clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine- :: IO ()+ :: IO () clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout clearLine = hClearLine stdout@@ -43,14 +43,14 @@ -- | Scroll the displayed information up or down the terminal: not widely -- supported hScrollPageUp, hScrollPageDown- :: Handle- -> Int -- ^ Number of lines to scroll by- -> IO ()+ :: 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 ()+ :: Int -- ^ Number of lines to scroll by+ -> IO () scrollPageUp = hScrollPageUp stdout scrollPageDown = hScrollPageDown stdout
includes/Common-Include.hs view
@@ -14,12 +14,12 @@ import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy) hCursorUp, hCursorDown, hCursorForward, hCursorBackward- :: Handle- -> Int -- ^ Number of lines or characters to move- -> IO ()+ :: Handle+ -> Int -- ^ Number of lines or characters to move+ -> IO () cursorUp, cursorDown, cursorForward, cursorBackward- :: Int -- ^ Number of lines or characters to move- -> IO ()+ :: Int -- ^ Number of lines or characters to move+ -> IO () cursorUp = hCursorUp stdout cursorDown = hCursorDown stdout cursorForward = hCursorForward stdout@@ -102,9 +102,9 @@ -- Borrowed from an HSpec patch by Simon Hengel -- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) hSupportsANSI h = (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)- where- -- cannot use lookupEnv since it only appeared in GHC 7.6- isDumb = maybe False (== "dumb") . lookup "TERM" <$> getEnvironment+ where+ -- cannot use lookupEnv since it only appeared in GHC 7.6+ isDumb = maybe False (== "dumb") . lookup "TERM" <$> getEnvironment -- | Parses the characters emitted by 'reportCursorPosition' into the console -- input stream. Returns the cursor row and column as a tuple.@@ -121,16 +121,16 @@ -- 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+ 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
includes/Exports-Include.hs view
@@ -2,83 +2,113 @@ -- 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,+ -- * 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 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--- <https://github.com/feuerbach/ansi-terminal/issues/10> for the details.-cursorUpLine, cursorDownLine,-hCursorUpLine, hCursorDownLine,-cursorUpLineCode, cursorDownLineCode,+ -- * 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+ -- <https://github.com/feuerbach/ansi-terminal/issues/10> for the details.+ , cursorUpLine+ , cursorDownLine+ , hCursorUpLine+ , hCursorDownLine+ , cursorUpLineCode+ , cursorDownLineCode --- * Directly changing cursor position-setCursorColumn,-hSetCursorColumn,-setCursorColumnCode,+ -- * Directly changing cursor position+ , setCursorColumn+ , hSetCursorColumn+ , setCursorColumnCode -setCursorPosition,-hSetCursorPosition,-setCursorPositionCode,+ , setCursorPosition+ , hSetCursorPosition+ , setCursorPositionCode --- * Saving, restoring and reporting cursor position-saveCursor,-hSaveCursor,-saveCursorCode,+ -- * Saving, restoring and reporting cursor position+ , saveCursor+ , hSaveCursor+ , saveCursorCode -restoreCursor,-hRestoreCursor,-restoreCursorCode,+ , restoreCursor+ , hRestoreCursor+ , restoreCursorCode -reportCursorPosition,-hReportCursorPosition,-reportCursorPositionCode,+ , 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,+ -- * 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,+ , clearFromCursorToLineEnd+ , clearFromCursorToLineBeginning+ , clearLine+ , hClearFromCursorToLineEnd+ , hClearFromCursorToLineBeginning+ , hClearLine+ , clearFromCursorToLineEndCode+ , clearFromCursorToLineBeginningCode+ , clearLineCode --- * Scrolling the screen-scrollPageUp, scrollPageDown,-hScrollPageUp, hScrollPageDown,-scrollPageUpCode, scrollPageDownCode,+ -- * Scrolling the screen+ , scrollPageUp+ , scrollPageDown+ , hScrollPageUp+ , hScrollPageDown+ , scrollPageUpCode+ , scrollPageDownCode --- * Select Graphic Rendition mode: colors and other whizzy stuff-setSGR,-hSetSGR,-setSGRCode,+ -- * Select Graphic Rendition mode: colors and other whizzy stuff+ , setSGR+ , hSetSGR+ , setSGRCode --- * Cursor visibilty changes-hideCursor, showCursor,-hHideCursor, hShowCursor,-hideCursorCode, showCursorCode,+ -- * Cursor visibilty changes+ , hideCursor+ , showCursor+ , hHideCursor+ , hShowCursor+ , hideCursorCode+ , showCursorCode --- * Changing the title-setTitle,-hSetTitle,-setTitleCode,+ -- * Changing the title+ , setTitle+ , hSetTitle+ , setTitleCode --- * Checking if handle supports ANSI-hSupportsANSI,+ -- * Checking if handle supports ANSI+ , hSupportsANSI --- * Getting the cursor position-getCursorPosition,-getReportedCursorPosition,-cursorPosition+ -- * Getting the cursor position+ , getCursorPosition+ , getReportedCursorPosition+ , cursorPosition