diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 --------------- diff --git a/System/Console/ANSI.hs b/System/Console/ANSI.hs --- a/System/Console/ANSI.hs +++ b/System/Console/ANSI.hs @@ -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 and provide a rich range of --- functionality for terminal control, which includes: +-- The ANSI escape codes are described at +-- 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 -- 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 diff --git a/System/Console/ANSI/Codes.hs b/System/Console/ANSI/Codes.hs --- a/System/Console/ANSI/Codes.hs +++ b/System/Console/ANSI/Codes.hs @@ -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 -- . -- --- 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" diff --git a/System/Console/ANSI/Example.hs b/System/Console/ANSI/Example.hs --- a/System/Console/ANSI/Example.hs +++ b/System/Console/ANSI/Example.hs @@ -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. diff --git a/System/Console/ANSI/Types.hs b/System/Console/ANSI/Types.hs --- a/System/Console/ANSI/Types.hs +++ b/System/Console/ANSI/Types.hs @@ -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) diff --git a/System/Console/ANSI/Unix.hs b/System/Console/ANSI/Unix.hs --- a/System/Console/ANSI/Unix.hs +++ b/System/Console/ANSI/Unix.hs @@ -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 diff --git a/System/Console/ANSI/Windows.hs b/System/Console/ANSI/Windows.hs --- a/System/Console/ANSI/Windows.hs +++ b/System/Console/ANSI/Windows.hs @@ -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 diff --git a/System/Console/ANSI/Windows/Detect.hs b/System/Console/ANSI/Windows/Detect.hs --- a/System/Console/ANSI/Windows/Detect.hs +++ b/System/Console/ANSI/Windows/Detect.hs @@ -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 diff --git a/System/Console/ANSI/Windows/Emulator.hs b/System/Console/ANSI/Windows/Emulator.hs --- a/System/Console/ANSI/Windows/Emulator.hs +++ b/System/Console/ANSI/Windows/Emulator.hs @@ -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." diff --git a/System/Console/ANSI/Windows/Emulator/Codes.hs b/System/Console/ANSI/Windows/Emulator/Codes.hs --- a/System/Console/ANSI/Windows/Emulator/Codes.hs +++ b/System/Console/ANSI/Windows/Emulator/Codes.hs @@ -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 = "" diff --git a/System/Console/ANSI/Windows/Foreign.hs b/System/Console/ANSI/Windows/Foreign.hs --- a/System/Console/ANSI/Windows/Foreign.hs +++ b/System/Console/ANSI/Windows/Foreign.hs @@ -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 diff --git a/ansi-terminal.cabal b/ansi-terminal.cabal --- a/ansi-terminal.cabal +++ b/ansi-terminal.cabal @@ -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 diff --git a/includes/Common-Include-Emulator.hs b/includes/Common-Include-Emulator.hs --- a/includes/Common-Include-Emulator.hs +++ b/includes/Common-Include-Emulator.hs @@ -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 diff --git a/includes/Common-Include-Enabled.hs b/includes/Common-Include-Enabled.hs --- a/includes/Common-Include-Enabled.hs +++ b/includes/Common-Include-Enabled.hs @@ -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 diff --git a/includes/Common-Include.hs b/includes/Common-Include.hs --- a/includes/Common-Include.hs +++ b/includes/Common-Include.hs @@ -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 diff --git a/includes/Exports-Include.hs b/includes/Exports-Include.hs --- a/includes/Exports-Include.hs +++ b/includes/Exports-Include.hs @@ -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 --- 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 + -- 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