ansi-terminal 0.8 → 0.8.0.1
raw patch · 19 files changed
+3034/−3005 lines, 19 filessetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +78/−70
- LICENSE +21/−21
- README.md +88/−88
- Setup.lhs +3/−3
- System/Console/ANSI.hs +78/−78
- System/Console/ANSI/Codes.hs +188/−188
- System/Console/ANSI/Example.hs +315/−315
- System/Console/ANSI/Types.hs +71/−71
- System/Console/ANSI/Unix.hs +100/−100
- System/Console/ANSI/Windows.hs +187/−187
- System/Console/ANSI/Windows/Detect.hs +123/−115
- System/Console/ANSI/Windows/Emulator.hs +464/−464
- System/Console/ANSI/Windows/Emulator/Codes.hs +94/−94
- System/Console/ANSI/Windows/Foreign.hs +731/−718
- ansi-terminal.cabal +94/−94
- includes/Common-Include-Emulator.hs +65/−65
- includes/Common-Include-Enabled.hs +56/−56
- includes/Common-Include.hs +164/−164
- includes/Exports-Include.hs +114/−114
CHANGELOG.md view
@@ -1,70 +1,78 @@-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------------------`getReportedCursorPosition`: don't let the cursor reporting code be echo'd--Version 0.7.1----------------* Allow saving, restoring, and querying the current cursor position-* Fix a couple of issues with the Reset emulation on Windows--Version 0.7--------------Add 24-bit RGB color support--Version 0.6.3.1------------------Fix Windows + ghc 7.8 compatibility--Version 0.6.3----------------* Add ANSI support for Windows-* Add compatibility with Win32-2.5.0.0 and above--Version 0.6.2.3------------------Add an example to the haddocks--Version 0.6.2.2------------------Fix a GHC 7.10 warning--Version 0.6.2.1------------------Restore compatibility with GHC 7.4 and older--Version 0.6.2----------------* Add `hSupportsANSI`-* Drop support for `base < 4`--Version 0.6.1.1------------------Fix to build with GHC 7.8 on Windows--Version 0.6.1----------------* `BoldIntensity` no longer changes background color on Windows-* `setSGR []` was not equivalent to `setSGR [Reset]` on Windows, even though it- should be according to the documentation. This is now fixed.+Changes +======= + +Version 0.8.0.1 +--------------- + +* On Windows, if the standard output channel is valid but not a ConHost + terminal, assume it is ANSI-enabled rather than failing +* On Windows, output the improved error message to the standard error channel + rather than the standard output channel + +Version 0.8 +----------- + +* Make the fields of `SGR` strict +* Make compatible with GHC 8.2.2 +* Improve the error message on Windows when not ANSI-capable or ConHost +* Recognise Appveyor build environment as ANSI-enabled + +Version 0.7.1.1 +--------------- + +`getReportedCursorPosition`: don't let the cursor reporting code be echo'd + +Version 0.7.1 +------------- + +* Allow saving, restoring, and querying the current cursor position +* Fix a couple of issues with the Reset emulation on Windows + +Version 0.7 +----------- + +Add 24-bit RGB color support + +Version 0.6.3.1 +--------------- + +Fix Windows + ghc 7.8 compatibility + +Version 0.6.3 +------------- + +* Add ANSI support for Windows +* Add compatibility with Win32-2.5.0.0 and above + +Version 0.6.2.3 +--------------- + +Add an example to the haddocks + +Version 0.6.2.2 +--------------- + +Fix a GHC 7.10 warning + +Version 0.6.2.1 +--------------- + +Restore compatibility with GHC 7.4 and older + +Version 0.6.2 +------------- + +* Add `hSupportsANSI` +* Drop support for `base < 4` + +Version 0.6.1.1 +--------------- + +Fix to build with GHC 7.8 on Windows + +Version 0.6.1 +------------- + +* `BoldIntensity` no longer changes background color on Windows +* `setSGR []` was not equivalent to `setSGR [Reset]` on Windows, even though it + should be according to the documentation. This is now fixed.
LICENSE view
@@ -1,22 +1,22 @@-Copyright (c) 2008, Maximilian Bolingbroke-All rights reserved.--Redistribution and use in source and binary forms, with or without modification, are permitted-provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright notice, this list of- conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright notice, this list of- conditions and the following disclaimer in the documentation and/or other materials- provided with the distribution.- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to- endorse or promote products derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR-CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER-IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT+Copyright (c) 2008, Maximilian Bolingbroke +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,88 +1,88 @@-ansi-terminal-=============--Haskell ANSI Terminal Package For Windows, OS X and Linux--Description--------------[ANSI](http://en.wikipedia.org/wiki/ANSI_escape_sequences) terminal-support for Haskell, which allows:--- Cursor movement-- Screen and line clearing-- Color output-- Showing or hiding the cursor-- Changing the console title (though this is not strictly part of- ANSI, it is widely supported in Unix)--It is compatible with Windows (via an emulation layer) and those Unixes-with ANSI terminals.--If you like this, you may be interested in-[ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which-provides a pretty-printer that can construct strings containing ANSI-colorisation.--Not all of the ANSI escape codes are provided by this module, but most-(if not all) of the popular and well supported ones are. For a full-list, have a look at the [current version of the-API](http://github.com/feuerbach/ansi-terminal/tree/master/includes/Common-Include.hs).-Each supported escape code or family of codes has a corresponding-function that comes in three variants:--- A straight `IO` variant that doesn't take a `Handle` and just- applies the ANSI escape code to the terminal attached to stdout-- An `IO` variant similar to above, but which takes a `Handle` to- which the ANSI escape should be applied-- A `String` variant that returns a literal string that should be- included to get the effect of the code. This is the only one of the- three API variants that only works on Unix-like operating systems:- on Windows these strings will always be blank!--Example----------A full example is-[available](http://github.com/feuerbach/ansi-terminal/tree/master/System/Console/ANSI/Example.hs),-but for a taste of how the library works try the following code:--``` haskell-import System.Console.ANSI--main = do- setCursorPosition 5 0- setTitle "ANSI Terminal Short Example"-- setSGR [ SetConsoleIntensity BoldIntensity- , SetColor Foreground Vivid Red- ]- putStr "Hello"-- setSGR [ SetConsoleIntensity NormalIntensity- , SetColor Foreground Vivid White- , SetColor Background Dull Blue- ]- putStrLn "World!"-```----Documentation----------------Haddock documentation is [available at-Hackage](http://hackage.haskell.org/packages/archive/ansi-terminal/latest/doc/html/System-Console-ANSI.html).--Credits----------The library is originally written by [Max Bolingbroke](https://github.com/batterseapower)--Maintainers--------------[Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer.--[Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please-get in touch with him if the primary maintainer cannot be reached.+ansi-terminal +============= + +Haskell ANSI Terminal Package For Windows, OS X and Linux + +Description +----------- + +[ANSI](http://en.wikipedia.org/wiki/ANSI_escape_sequences) terminal +support for Haskell, which allows: + +- Cursor movement +- Screen and line clearing +- Color output +- Showing or hiding the cursor +- Changing the console title (though this is not strictly part of + ANSI, it is widely supported in Unix) + +It is compatible with Windows (via an emulation layer) and those Unixes +with ANSI terminals. + +If you like this, you may be interested in +[ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which +provides a pretty-printer that can construct strings containing ANSI +colorisation. + +Not all of the ANSI escape codes are provided by this module, but most +(if not all) of the popular and well supported ones are. For a full +list, have a look at the [current version of the +API](http://github.com/feuerbach/ansi-terminal/tree/master/includes/Common-Include.hs). +Each supported escape code or family of codes has a corresponding +function that comes in three variants: + +- A straight `IO` variant that doesn't take a `Handle` and just + applies the ANSI escape code to the terminal attached to stdout +- An `IO` variant similar to above, but which takes a `Handle` to + which the ANSI escape should be applied +- A `String` variant that returns a literal string that should be + included to get the effect of the code. This is the only one of the + three API variants that only works on Unix-like operating systems: + on Windows these strings will always be blank! + +Example +------- + +A full example is +[available](http://github.com/feuerbach/ansi-terminal/tree/master/System/Console/ANSI/Example.hs), +but for a taste of how the library works try the following code: + +``` haskell +import System.Console.ANSI + +main = do + setCursorPosition 5 0 + setTitle "ANSI Terminal Short Example" + + setSGR [ SetConsoleIntensity BoldIntensity + , SetColor Foreground Vivid Red + ] + putStr "Hello" + + setSGR [ SetConsoleIntensity NormalIntensity + , SetColor Foreground Vivid White + , SetColor Background Dull Blue + ] + putStrLn "World!" +``` + + + +Documentation +------------- + +Haddock documentation is [available at +Hackage](http://hackage.haskell.org/packages/archive/ansi-terminal/latest/doc/html/System-Console-ANSI.html). + +Credits +------- + +The library is originally written by [Max Bolingbroke](https://github.com/batterseapower) + +Maintainers +----------- + +[Mike Pilgrem](https://github.com/mpilgrem) and [Roman Cheplyaka](https://github.com/feuerbach) are the primary maintainers. + +[Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please +get in touch with him if the primary maintainers cannot be reached.
Setup.lhs view
@@ -1,4 +1,4 @@-#! /usr/bin/env runhaskell--> import Distribution.Simple+#! /usr/bin/env runhaskell + +> import Distribution.Simple > main = defaultMain
System/Console/ANSI.hs view
@@ -1,78 +1,78 @@--- | Provides ANSI terminal support for ANSI terminal software running on a--- Unix-like operating system or on a Windows operating system (where supported)--- or on other Windows operating systems where the terminal in use is not--- ANSI-enabled.------ The ANSI escape codes are described at <http://en.wikipedia.org/wiki/ANSI_escape_code>--- and provide a rich range of functionality for terminal control, which--- includes:------ * Colored text output, with control over both foreground and background--- colors------ * Hiding or showing the cursor------ * Moving the cursor around------ * 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:------ * 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.------ * 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:------ > -- Set colors and write some text in those colors.--- > sgrExample :: IO ()--- > sgrExample = do--- > setSGR [SetColor Foreground Vivid Red]--- > setSGR [SetColor Background Vivid Blue]--- > putStr "Red-On-Blue"--- > setSGR [Reset]--- > putStr "White-On-Black"------ For many more examples, see the project's extensive--- <https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/System/Console/ANSI/Example.hs Example.hs> file.-#if defined(WINDOWS)-module System.Console.ANSI- (- module System.Console.ANSI.Windows- ) where--import System.Console.ANSI.Windows--#elif defined(UNIX)--module System.Console.ANSI- (- module System.Console.ANSI.Unix- ) where--import System.Console.ANSI.Unix--#else--#error Unsupported platform for the ansi-terminal package--#endif+-- | Provides ANSI terminal support for ANSI terminal software running on a +-- Unix-like operating system or on a Windows operating system (where supported) +-- or on other Windows operating systems where the terminal in use is not +-- ANSI-enabled. +-- +-- The ANSI escape codes are described at <http://en.wikipedia.org/wiki/ANSI_escape_code> +-- and provide a rich range of functionality for terminal control, which +-- includes: +-- +-- * Colored text output, with control over both foreground and background +-- colors +-- +-- * Hiding or showing the cursor +-- +-- * Moving the cursor around +-- +-- * 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: +-- +-- * 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. +-- +-- * 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: +-- +-- > -- Set colors and write some text in those colors. +-- > sgrExample :: IO () +-- > sgrExample = do +-- > setSGR [SetColor Foreground Vivid Red] +-- > setSGR [SetColor Background Vivid Blue] +-- > putStr "Red-On-Blue" +-- > setSGR [Reset] +-- > putStr "White-On-Black" +-- +-- For many more examples, see the project's extensive +-- <https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/System/Console/ANSI/Example.hs Example.hs> file. +#if defined(WINDOWS) +module System.Console.ANSI + ( + module System.Console.ANSI.Windows + ) where + +import System.Console.ANSI.Windows + +#elif defined(UNIX) + +module System.Console.ANSI + ( + module System.Console.ANSI.Unix + ) where + +import System.Console.ANSI.Unix + +#else + +#error Unsupported platform for the ansi-terminal package + +#endif
System/Console/ANSI/Codes.hs view
@@ -1,188 +1,188 @@--- | This module exports functions that return 'String' values containing codes--- in accordance with: (1) standard ECMA-48 Control Functions for Coded--- Character Sets (5th edition, 1991); or (2) in the case of 'saveCursorCode',--- 'restoreCursorCode', 'reportCursorPositionCode' and 'setTitleCode', the XTerm--- control sequence.------ The reference used for the codes in this module was--- <http://en.wikipedia.org/wiki/ANSI_escape_sequences>.------ The module "System.Console.ANSI" exports functions with the same names as--- those in this module. On some versions of Windows, the terminal in use may--- not be ANSI-capable. When that is the case, the same-named functions exported--- by module "System.Console.ANSI" return \"\", for the reasons set out in the--- documentation of that module.------ Consequently, if module "System.Console.ANSI" is also imported, this module--- is intended to be imported qualified, to avoid name clashes with those--- functions. For example:------ > import qualified System.Console.ANSI.Codes as ANSI----module System.Console.ANSI.Codes- (- -- * Basic data types- module System.Console.ANSI.Types-- -- * Cursor movement by character- , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode-- -- * Cursor movement by line- , cursorUpLineCode, cursorDownLineCode-- -- * Directly changing cursor position- , setCursorColumnCode, setCursorPositionCode-- -- * Saving, restoring and reporting cursor position- , saveCursorCode, restoreCursorCode, reportCursorPositionCode-- -- * Clearing parts of the screen- , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode- , clearScreenCode, clearFromCursorToLineEndCode- , clearFromCursorToLineBeginningCode, clearLineCode-- -- * Scrolling the screen- , scrollPageUpCode, scrollPageDownCode-- -- * Select Graphic Rendition mode: colors and other whizzy stuff- , setSGRCode-- -- * Cursor visibilty changes- , hideCursorCode, showCursorCode-- -- * Changing the title- -- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the- -- right direction on xterm title setting on haskell-cafe. The "0"- -- signifies that both the title and "icon" text should be set: i.e. the- -- text for the window in the Start bar (or similar) as well as that in- -- the actual window title. This is chosen for consistent behaviour- -- between Unixes and Windows.- , setTitleCode-- -- * Utilities- , colorToCode, csi, sgrToCode- ) where--import Data.List (intersperse)--import Data.Colour.SRGB (toSRGB24, RGB (..))--import System.Console.ANSI.Types---- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int',--- returns the control sequence comprising the control function CONTROL--- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\')--- and ending with the @controlFunction@ character(s) that identifies the--- control function.-csi :: [Int] -- ^ List of parameters for the control sequence- -> String -- ^ Character(s) that identify the control function- -> String-csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code---- | 'colorToCode' @color@ returns the 0-based index of the color (one of the--- eight colors in the standard).-colorToCode :: Color -> Int-colorToCode color = case color of- Black -> 0- Red -> 1- Green -> 2- Yellow -> 3- Blue -> 4- Magenta -> 5- Cyan -> 6- White -> 7---- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION--- (SGR) aspect identified by @sgr@.-sgrToCode :: SGR -- ^ The SGR aspect- -> [Int]-sgrToCode sgr = case sgr of- Reset -> [0]- SetConsoleIntensity intensity -> case intensity of- BoldIntensity -> [1]- FaintIntensity -> [2]- NormalIntensity -> [22]- SetItalicized True -> [3]- SetItalicized False -> [23]- SetUnderlining underlining -> case underlining of- SingleUnderline -> [4]- DoubleUnderline -> [21]- NoUnderline -> [24]- SetBlinkSpeed blink_speed -> case blink_speed of- SlowBlink -> [5]- RapidBlink -> [6]- NoBlink -> [25]- SetVisible False -> [8]- SetVisible True -> [28]- SetSwapForegroundBackground True -> [7]- SetSwapForegroundBackground False -> [27]- SetColor Foreground Dull color -> [30 + colorToCode color]- SetColor Foreground Vivid color -> [90 + colorToCode color]- SetColor Background Dull color -> [40 + colorToCode color]- SetColor Background Vivid color -> [100 + colorToCode color]- 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 n = csi [n] "A"-cursorDownCode n = csi [n] "B"-cursorForwardCode n = csi [n] "C"-cursorBackwardCode n = csi [n] "D"--cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move- -> String-cursorDownLineCode n = csi [n] "E"-cursorUpLineCode n = csi [n] "F"--setCursorColumnCode :: Int -- ^ 0-based column to move to- -> String-setCursorColumnCode n = csi [n + 1] "G"--setCursorPositionCode :: Int -- ^ 0-based row to move to- -> Int -- ^ 0-based column to move to- -> String-setCursorPositionCode n m = csi [n + 1, m + 1] "H"--saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String-saveCursorCode = "\ESC7"-restoreCursorCode = "\ESC8"-reportCursorPositionCode = csi [] "6n"--clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,- clearScreenCode :: String-clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,- clearLineCode :: String--clearFromCursorToScreenEndCode = csi [0] "J"-clearFromCursorToScreenBeginningCode = csi [1] "J"-clearScreenCode = csi [2] "J"-clearFromCursorToLineEndCode = csi [0] "K"-clearFromCursorToLineBeginningCode = csi [1] "K"-clearLineCode = csi [2] "K"--scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by- -> String-scrollPageUpCode n = csi [n] "S"-scrollPageDownCode n = csi [n] "T"--setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the- -- current console SGR mode. An empty list of commands is- -- equivalent to the list @[Reset]@. Commands are applied- -- left to right.- -> String-setSGRCode sgrs = csi (concatMap sgrToCode sgrs) "m"--hideCursorCode, showCursorCode :: String-hideCursorCode = csi [] "?25l"-showCursorCode = csi [] "?25h"----- | XTerm control sequence to set the Icon Name and Window Title.-setTitleCode :: String -- ^ New Icon Name and Window Title- -> String-setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007"+-- | This module exports functions that return 'String' values containing codes +-- in accordance with: (1) standard ECMA-48 Control Functions for Coded +-- Character Sets (5th edition, 1991); or (2) in the case of 'saveCursorCode', +-- 'restoreCursorCode', 'reportCursorPositionCode' and 'setTitleCode', the XTerm +-- control sequence. +-- +-- The reference used for the codes in this module was +-- <http://en.wikipedia.org/wiki/ANSI_escape_sequences>. +-- +-- The module "System.Console.ANSI" exports functions with the same names as +-- those in this module. On some versions of Windows, the terminal in use may +-- not be ANSI-capable. When that is the case, the same-named functions exported +-- by module "System.Console.ANSI" return \"\", for the reasons set out in the +-- documentation of that module. +-- +-- Consequently, if module "System.Console.ANSI" is also imported, this module +-- is intended to be imported qualified, to avoid name clashes with those +-- functions. For example: +-- +-- > import qualified System.Console.ANSI.Codes as ANSI +-- +module System.Console.ANSI.Codes + ( + -- * Basic data types + module System.Console.ANSI.Types + + -- * Cursor movement by character + , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode + + -- * Cursor movement by line + , cursorUpLineCode, cursorDownLineCode + + -- * Directly changing cursor position + , setCursorColumnCode, setCursorPositionCode + + -- * Saving, restoring and reporting cursor position + , saveCursorCode, restoreCursorCode, reportCursorPositionCode + + -- * Clearing parts of the screen + , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode + , clearScreenCode, clearFromCursorToLineEndCode + , clearFromCursorToLineBeginningCode, clearLineCode + + -- * Scrolling the screen + , scrollPageUpCode, scrollPageDownCode + + -- * Select Graphic Rendition mode: colors and other whizzy stuff + , setSGRCode + + -- * Cursor visibilty changes + , hideCursorCode, showCursorCode + + -- * Changing the title + -- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the + -- right direction on xterm title setting on haskell-cafe. The "0" + -- signifies that both the title and "icon" text should be set: i.e. the + -- text for the window in the Start bar (or similar) as well as that in + -- the actual window title. This is chosen for consistent behaviour + -- between Unixes and Windows. + , setTitleCode + + -- * Utilities + , colorToCode, csi, sgrToCode + ) where + +import Data.List (intersperse) + +import Data.Colour.SRGB (toSRGB24, RGB (..)) + +import System.Console.ANSI.Types + +-- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int', +-- returns the control sequence comprising the control function CONTROL +-- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\') +-- and ending with the @controlFunction@ character(s) that identifies the +-- control function. +csi :: [Int] -- ^ List of parameters for the control sequence + -> String -- ^ Character(s) that identify the control function + -> String +csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code + +-- | 'colorToCode' @color@ returns the 0-based index of the color (one of the +-- eight colors in the standard). +colorToCode :: Color -> Int +colorToCode color = case color of + Black -> 0 + Red -> 1 + Green -> 2 + Yellow -> 3 + Blue -> 4 + Magenta -> 5 + Cyan -> 6 + White -> 7 + +-- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION +-- (SGR) aspect identified by @sgr@. +sgrToCode :: SGR -- ^ The SGR aspect + -> [Int] +sgrToCode sgr = case sgr of + Reset -> [0] + SetConsoleIntensity intensity -> case intensity of + BoldIntensity -> [1] + FaintIntensity -> [2] + NormalIntensity -> [22] + SetItalicized True -> [3] + SetItalicized False -> [23] + SetUnderlining underlining -> case underlining of + SingleUnderline -> [4] + DoubleUnderline -> [21] + NoUnderline -> [24] + SetBlinkSpeed blink_speed -> case blink_speed of + SlowBlink -> [5] + RapidBlink -> [6] + NoBlink -> [25] + SetVisible False -> [8] + SetVisible True -> [28] + SetSwapForegroundBackground True -> [7] + SetSwapForegroundBackground False -> [27] + SetColor Foreground Dull color -> [30 + colorToCode color] + SetColor Foreground Vivid color -> [90 + colorToCode color] + SetColor Background Dull color -> [40 + colorToCode color] + SetColor Background Vivid color -> [100 + colorToCode color] + 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 n = csi [n] "A" +cursorDownCode n = csi [n] "B" +cursorForwardCode n = csi [n] "C" +cursorBackwardCode n = csi [n] "D" + +cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move + -> String +cursorDownLineCode n = csi [n] "E" +cursorUpLineCode n = csi [n] "F" + +setCursorColumnCode :: Int -- ^ 0-based column to move to + -> String +setCursorColumnCode n = csi [n + 1] "G" + +setCursorPositionCode :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> String +setCursorPositionCode n m = csi [n + 1, m + 1] "H" + +saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String +saveCursorCode = "\ESC7" +restoreCursorCode = "\ESC8" +reportCursorPositionCode = csi [] "6n" + +clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, + clearScreenCode :: String +clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, + clearLineCode :: String + +clearFromCursorToScreenEndCode = csi [0] "J" +clearFromCursorToScreenBeginningCode = csi [1] "J" +clearScreenCode = csi [2] "J" +clearFromCursorToLineEndCode = csi [0] "K" +clearFromCursorToLineBeginningCode = csi [1] "K" +clearLineCode = csi [2] "K" + +scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by + -> String +scrollPageUpCode n = csi [n] "S" +scrollPageDownCode n = csi [n] "T" + +setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the + -- current console SGR mode. An empty list of commands is + -- equivalent to the list @[Reset]@. Commands are applied + -- left to right. + -> String +setSGRCode sgrs = csi (concatMap sgrToCode sgrs) "m" + +hideCursorCode, showCursorCode :: String +hideCursorCode = csi [] "?25l" +showCursorCode = csi [] "?25h" + + +-- | XTerm control sequence to set the Icon Name and Window Title. +setTitleCode :: String -- ^ New Icon Name and Window Title + -> String +setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007"
System/Console/ANSI/Example.hs view
@@ -1,315 +1,315 @@-module Main- (- main- ) where--import Control.Concurrent (threadDelay)-import Control.Monad (forM_)-import System.IO (hFlush, stdout)--import System.Console.ANSI--examples :: [IO ()]-examples = [ cursorMovementExample- , lineChangeExample- , setCursorPositionExample- , saveRestoreCursorExample- , clearExample- , scrollExample- , sgrExample- , cursorVisibilityExample- , titleExample- , getCursorPositionExample- ]--main :: IO ()-main = mapM_ (\example -> resetScreen >> example) examples---- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation--- of an erased state is implementation-dependent. There may or may not be a--- distinction between a character position in the erased state and one imaging--- SPACE. Consequently, to reset the screen, the default graphic rendition must--- be selected (setSGR [Reset]) before all character positions are put into the--- erased state (clearScreen).-resetScreen :: IO ()-resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0--pause :: IO ()-pause = do- hFlush stdout- -- 1 second pause- threadDelay 1000000--cursorMovementExample :: IO ()-cursorMovementExample = do- putStrLn "Line One"- putStr "Line Two"- pause- -- Line One- -- Line Two-- cursorUp 1- putStr " - Extras"- pause- -- Line One - Extras- -- Line Two-- cursorBackward 2- putStr "zz"- pause- -- Line One - Extrzz- -- Line Two-- cursorForward 2- putStr "- And More"- pause- -- Line One - Extrzz - And More- -- Line Two-- cursorDown 1- putStr "Disconnected"- pause- -- Line One - Extrzz - And More- -- Line Two Disconnected--lineChangeExample :: IO ()-lineChangeExample = do- putStrLn "Line One"- putStr "Line Two"- pause- -- Line One- -- Line Two-- cursorUpLine 1- putStr "New Line One"- pause- -- New Line One- -- Line Two-- cursorDownLine 1- putStr "New Line Two"- pause- -- New Line One- -- New Line Two--setCursorPositionExample :: IO ()-setCursorPositionExample = do- putStrLn "Line One"- putStrLn "Line Two"- pause- -- Line One- -- Line Two-- setCursorPosition 0 5- putStr "Foo"- pause- -- Line Foo- -- Line Two-- setCursorPosition 1 5- putStr "Bar"- pause- -- Line Foo- -- Line Bar-- setCursorColumn 1- putStr "oaf"- pause- -- Line Foo- -- Loaf Bar--saveRestoreCursorExample :: IO ()-saveRestoreCursorExample = do- putStr "Start sentence ..."- pause- -- Start sentence ...-- saveCursor- setCursorPosition 2 3- putStr "SPLASH!"- pause- -- Start sentence ...- --- -- SPLASH!-- restoreCursor- putStr " end sentence, uninterrupted."- pause- -- Start sentence ... end sentence, uninterrupted- --- -- SPLASH!--clearExample :: IO ()-clearExample = do- putStrLn "Line One"- putStrLn "Line Two"- pause- -- Line One- -- Line Two-- setCursorPosition 0 4- clearFromCursorToScreenEnd- pause- -- Line-- resetScreen- putStrLn "Line One"- putStrLn "Line Two"- pause- -- Line One- -- Line Two-- setCursorPosition 1 4- clearFromCursorToScreenBeginning- pause- --- -- Two-- resetScreen- putStrLn "Line One"- putStrLn "Line Two"- pause- -- Line One- -- Line Two-- setCursorPosition 0 4- clearFromCursorToLineEnd- pause- -- Line- -- Line Two-- setCursorPosition 1 4- clearFromCursorToLineBeginning- pause- -- Line- -- Two-- clearLine- pause- -- Line-- clearScreen- pause- ----scrollExample :: IO ()-scrollExample = do- putStrLn "Line One"- putStrLn "Line Two"- putStrLn "Line Three"- pause- -- Line One- -- Line Two- -- Line Three-- scrollPageDown 2- pause- --- --- -- Line One- -- Line Two- -- Line Three-- scrollPageUp 3- pause- -- Line Two- -- Line Three--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 named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold")- , (SetConsoleIntensity FaintIntensity, "Faint")- , (SetConsoleIntensity NormalIntensity, "Normal")- , (SetItalicized True, "Italic")- , (SetItalicized False, "No Italics")- , (SetUnderlining SingleUnderline, "Single Underline")- , (SetUnderlining DoubleUnderline, "Double Underline")- , (SetUnderlining NoUnderline, "No Underline")- , (SetBlinkSpeed SlowBlink, "Slow Blink")- , (SetBlinkSpeed RapidBlink, "Rapid Blink")- , (SetBlinkSpeed NoBlink, "No Blink")- , (SetVisible False, "Conceal")- , (SetVisible True, "Reveal")- ]- forM_ named_styles $ \(style, name) -> do- resetScreen- setSGR [style]- putStrLn name- pause- -- Text describing a style displayed in that style in sequence-- setSGR [SetColor Foreground Vivid Red]- setSGR [SetColor Background Vivid Blue]-- clearScreen >> setCursorPosition 0 0- setSGR [SetSwapForegroundBackground False]- putStr "Red-On-Blue"- pause- -- Red-On-Blue-- clearScreen >> setCursorPosition 0 0- setSGR [SetSwapForegroundBackground True]- putStr "Blue-On-Red"- pause- -- Blue-On-Red--cursorVisibilityExample :: IO ()-cursorVisibilityExample = do- putStr "Cursor Demo"- pause- -- Cursor Demo|-- hideCursor- pause- -- Cursor Demo-- showCursor- pause- -- Cursor Demo|--titleExample :: IO ()-titleExample = do- putStr "Title Demo"- pause- -- ~/foo/ - ansi-terminal-ex - 83x70- ------------------------------------- -- Title Demo-- setTitle "Yup, I'm a new title!"- pause- -- Yup, I'm a new title! - ansi-terminal-ex - 83x70- ---------------------------------------------------- -- Title Demo--getCursorPositionExample :: IO ()-getCursorPositionExample = do- putStrLn " 11111111112222222222"- putStrLn "12345678901234567890123456789"- putStr "Report cursor position here:"- pause- -- 11111111112222222222- -- 12345678901234567890123456789- -- Report cursor position here:|- result <- getCursorPosition- putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n"- case result of- Just (row, col) -> putStrLn $ "The cursor was at row number " ++- show row ++ " 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.+module Main + ( + main + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_) +import System.IO (hFlush, stdout) + +import System.Console.ANSI + +examples :: [IO ()] +examples = [ cursorMovementExample + , lineChangeExample + , setCursorPositionExample + , saveRestoreCursorExample + , clearExample + , scrollExample + , sgrExample + , cursorVisibilityExample + , titleExample + , getCursorPositionExample + ] + +main :: IO () +main = mapM_ (\example -> resetScreen >> example) examples + +-- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation +-- of an erased state is implementation-dependent. There may or may not be a +-- distinction between a character position in the erased state and one imaging +-- SPACE. Consequently, to reset the screen, the default graphic rendition must +-- be selected (setSGR [Reset]) before all character positions are put into the +-- erased state (clearScreen). +resetScreen :: IO () +resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 + +pause :: IO () +pause = do + hFlush stdout + -- 1 second pause + threadDelay 1000000 + +cursorMovementExample :: IO () +cursorMovementExample = do + putStrLn "Line One" + putStr "Line Two" + pause + -- Line One + -- Line Two + + cursorUp 1 + putStr " - Extras" + pause + -- Line One - Extras + -- Line Two + + cursorBackward 2 + putStr "zz" + pause + -- Line One - Extrzz + -- Line Two + + cursorForward 2 + putStr "- And More" + pause + -- Line One - Extrzz - And More + -- Line Two + + cursorDown 1 + putStr "Disconnected" + pause + -- Line One - Extrzz - And More + -- Line Two Disconnected + +lineChangeExample :: IO () +lineChangeExample = do + putStrLn "Line One" + putStr "Line Two" + pause + -- Line One + -- Line Two + + cursorUpLine 1 + putStr "New Line One" + pause + -- New Line One + -- Line Two + + cursorDownLine 1 + putStr "New Line Two" + pause + -- New Line One + -- New Line Two + +setCursorPositionExample :: IO () +setCursorPositionExample = do + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 0 5 + putStr "Foo" + pause + -- Line Foo + -- Line Two + + setCursorPosition 1 5 + putStr "Bar" + pause + -- Line Foo + -- Line Bar + + setCursorColumn 1 + putStr "oaf" + pause + -- Line Foo + -- Loaf Bar + +saveRestoreCursorExample :: IO () +saveRestoreCursorExample = do + putStr "Start sentence ..." + pause + -- Start sentence ... + + saveCursor + setCursorPosition 2 3 + putStr "SPLASH!" + pause + -- Start sentence ... + -- + -- SPLASH! + + restoreCursor + putStr " end sentence, uninterrupted." + pause + -- Start sentence ... end sentence, uninterrupted + -- + -- SPLASH! + +clearExample :: IO () +clearExample = do + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 0 4 + clearFromCursorToScreenEnd + pause + -- Line + + resetScreen + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 1 4 + clearFromCursorToScreenBeginning + pause + -- + -- Two + + resetScreen + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 0 4 + clearFromCursorToLineEnd + pause + -- Line + -- Line Two + + setCursorPosition 1 4 + clearFromCursorToLineBeginning + pause + -- Line + -- Two + + clearLine + pause + -- Line + + clearScreen + pause + -- + +scrollExample :: IO () +scrollExample = do + putStrLn "Line One" + putStrLn "Line Two" + putStrLn "Line Three" + pause + -- Line One + -- Line Two + -- Line Three + + scrollPageDown 2 + pause + -- + -- + -- Line One + -- Line Two + -- Line Three + + scrollPageUp 3 + pause + -- Line Two + -- Line Three + +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 named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") + , (SetConsoleIntensity FaintIntensity, "Faint") + , (SetConsoleIntensity NormalIntensity, "Normal") + , (SetItalicized True, "Italic") + , (SetItalicized False, "No Italics") + , (SetUnderlining SingleUnderline, "Single Underline") + , (SetUnderlining DoubleUnderline, "Double Underline") + , (SetUnderlining NoUnderline, "No Underline") + , (SetBlinkSpeed SlowBlink, "Slow Blink") + , (SetBlinkSpeed RapidBlink, "Rapid Blink") + , (SetBlinkSpeed NoBlink, "No Blink") + , (SetVisible False, "Conceal") + , (SetVisible True, "Reveal") + ] + forM_ named_styles $ \(style, name) -> do + resetScreen + setSGR [style] + putStrLn name + pause + -- Text describing a style displayed in that style in sequence + + setSGR [SetColor Foreground Vivid Red] + setSGR [SetColor Background Vivid Blue] + + clearScreen >> setCursorPosition 0 0 + setSGR [SetSwapForegroundBackground False] + putStr "Red-On-Blue" + pause + -- Red-On-Blue + + clearScreen >> setCursorPosition 0 0 + setSGR [SetSwapForegroundBackground True] + putStr "Blue-On-Red" + pause + -- Blue-On-Red + +cursorVisibilityExample :: IO () +cursorVisibilityExample = do + putStr "Cursor Demo" + pause + -- Cursor Demo| + + hideCursor + pause + -- Cursor Demo + + showCursor + pause + -- Cursor Demo| + +titleExample :: IO () +titleExample = do + putStr "Title Demo" + pause + -- ~/foo/ - ansi-terminal-ex - 83x70 + ------------------------------------ + -- Title Demo + + setTitle "Yup, I'm a new title!" + pause + -- Yup, I'm a new title! - ansi-terminal-ex - 83x70 + --------------------------------------------------- + -- Title Demo + +getCursorPositionExample :: IO () +getCursorPositionExample = do + putStrLn " 11111111112222222222" + putStrLn "12345678901234567890123456789" + putStr "Report cursor position here:" + pause + -- 11111111112222222222 + -- 12345678901234567890123456789 + -- Report cursor position here:| + result <- getCursorPosition + putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n" + case result of + Just (row, col) -> putStrLn $ "The cursor was at row number " ++ + show row ++ " and column number " ++ show col ++ ".\n" + Nothing -> putStrLn "Error: unable to get the cursor position\n" + pause + -- 11111111112222222222 + -- 12345678901234567890123456789 + -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R. + -- + -- The cursor was at row number 3 and column number 29.
System/Console/ANSI/Types.hs view
@@ -1,71 +1,71 @@--- | Types used to represent SELECT GRAPHIC RENDITION (SGR) aspects.-module System.Console.ANSI.Types- (- SGR (..)- , ConsoleLayer (..)- , Color (..)- , ColorIntensity (..)- , ConsoleIntensity (..)- , Underlining (..)- , BlinkSpeed (..)- ) where--import Data.Ix (Ix)--import Data.Colour (Colour)---- | ANSI colors: come in various intensities, which are controlled by--- 'ColorIntensity'-data Color = Black- | Red- | Green- | Yellow- | Blue- | Magenta- | Cyan- | White- deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix)---- | ANSI colors come in two intensities-data ColorIntensity = Dull- | Vivid- deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix)---- | ANSI colors can be set on two different layers-data ConsoleLayer = Foreground- | Background- deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix)---- | ANSI blink speeds: values other than 'NoBlink' are not widely supported-data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute- | RapidBlink -- ^ More than 150 blinks per minute- | NoBlink- deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix)---- | ANSI text underlining-data Underlining = SingleUnderline- | DoubleUnderline -- ^ Not widely supported- | NoUnderline- deriving (Eq, Ord, Bounded ,Enum, Show, Read, Ix)---- | ANSI general console intensity: usually treated as setting the font style--- (e.g. 'BoldIntensity' causes text to be bold)-data ConsoleIntensity = BoldIntensity- | 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- deriving (Eq, Show, Read)+-- | Types used to represent SELECT GRAPHIC RENDITION (SGR) aspects. +module System.Console.ANSI.Types + ( + SGR (..) + , ConsoleLayer (..) + , Color (..) + , ColorIntensity (..) + , ConsoleIntensity (..) + , Underlining (..) + , BlinkSpeed (..) + ) where + +import Data.Ix (Ix) + +import Data.Colour (Colour) + +-- | ANSI colors: come in various intensities, which are controlled by +-- 'ColorIntensity' +data Color = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI colors come in two intensities +data ColorIntensity = Dull + | Vivid + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI colors can be set on two different layers +data ConsoleLayer = Foreground + | Background + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI blink speeds: values other than 'NoBlink' are not widely supported +data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute + | RapidBlink -- ^ More than 150 blinks per minute + | NoBlink + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI text underlining +data Underlining = SingleUnderline + | DoubleUnderline -- ^ Not widely supported + | NoUnderline + deriving (Eq, Ord, Bounded ,Enum, Show, Read, Ix) + +-- | ANSI general console intensity: usually treated as setting the font style +-- (e.g. 'BoldIntensity' causes text to be bold) +data ConsoleIntensity = BoldIntensity + | 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 + deriving (Eq, Show, Read)
System/Console/ANSI/Unix.hs view
@@ -1,100 +1,100 @@-{-# OPTIONS_HADDOCK hide #-}--module System.Console.ANSI.Unix- (--- This file contains code that is common to modules--- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module--- exports and the associated Haddock documentation.-#include "Exports-Include.hs"- ) where--import Control.Exception.Base (bracket)-import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho,- 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--- of the corresponding more general functions, inclduding the related Haddock--- documentation.-#include "Common-Include.hs"--- This file contains code that is common save that different code is required--- in the case of the module System.Console.ANSI.Windows.Emulator (see the file--- Common-Include-Emulator.hs in respect of the latter).-#include "Common-Include-Enabled.hs"--hCursorUp h n = hPutStr h $ cursorUpCode n-hCursorDown h n = hPutStr h $ cursorDownCode n-hCursorForward h n = hPutStr h $ cursorForwardCode n-hCursorBackward h n = hPutStr h $ cursorBackwardCode n--hCursorDownLine h n = hPutStr h $ cursorDownLineCode n-hCursorUpLine h n = hPutStr h $ cursorUpLineCode n--hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n-hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m--hSaveCursor h = hPutStr h saveCursorCode-hRestoreCursor h = hPutStr h restoreCursorCode-hReportCursorPosition h = hPutStr h reportCursorPositionCode--hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode-hClearFromCursorToScreenBeginning h- = hPutStr h clearFromCursorToScreenBeginningCode-hClearScreen h = hPutStr h clearScreenCode--hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode-hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode-hClearLine h = hPutStr h clearLineCode--hScrollPageUp h n = hPutStr h $ scrollPageUpCode n-hScrollPageDown h n = hPutStr h $ scrollPageDownCode n--hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs--hHideCursor h = hPutStr h hideCursorCode-hShowCursor h = hPutStr h showCursorCode--hSetTitle h title = hPutStr h $ setTitleCode title---- getReportedCursorPosition :: IO String--- (See Common-Include.hs for Haddock documentation)-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.---- 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+{-# OPTIONS_HADDOCK hide #-} + +module System.Console.ANSI.Unix + ( +-- This file contains code that is common to modules +-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module +-- exports and the associated Haddock documentation. +#include "Exports-Include.hs" + ) where + +import Control.Exception.Base (bracket) +import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, + 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 +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. +#include "Common-Include.hs" +-- This file contains code that is common save that different code is required +-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file +-- Common-Include-Emulator.hs in respect of the latter). +#include "Common-Include-Enabled.hs" + +hCursorUp h n = hPutStr h $ cursorUpCode n +hCursorDown h n = hPutStr h $ cursorDownCode n +hCursorForward h n = hPutStr h $ cursorForwardCode n +hCursorBackward h n = hPutStr h $ cursorBackwardCode n + +hCursorDownLine h n = hPutStr h $ cursorDownLineCode n +hCursorUpLine h n = hPutStr h $ cursorUpLineCode n + +hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n +hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m + +hSaveCursor h = hPutStr h saveCursorCode +hRestoreCursor h = hPutStr h restoreCursorCode +hReportCursorPosition h = hPutStr h reportCursorPositionCode + +hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode +hClearFromCursorToScreenBeginning h + = hPutStr h clearFromCursorToScreenBeginningCode +hClearScreen h = hPutStr h clearScreenCode + +hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode +hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode +hClearLine h = hPutStr h clearLineCode + +hScrollPageUp h n = hPutStr h $ scrollPageUpCode n +hScrollPageDown h n = hPutStr h $ scrollPageDownCode n + +hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs + +hHideCursor h = hPutStr h hideCursorCode +hShowCursor h = hPutStr h showCursorCode + +hSetTitle h title = hPutStr h $ setTitleCode title + +-- getReportedCursorPosition :: IO String +-- (See Common-Include.hs for Haddock documentation) +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. + +-- 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
System/Console/ANSI/Windows.hs view
@@ -1,187 +1,187 @@-{-# OPTIONS_HADDOCK hide #-}--module System.Console.ANSI.Windows- (--- This file contains code that is common to modules--- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module--- exports and the associated Haddock documentation.-#include "Exports-Include.hs"- ) where--import System.IO (Handle, hIsTerminalDevice, stdout)--import System.Console.ANSI.Types-import qualified System.Console.ANSI.Unix as U-import System.Console.ANSI.Windows.Detect (ANSIEnabledStatus (..),- ConsoleDefaultState (..), isANSIEnabled)-import qualified System.Console.ANSI.Windows.Emulator as E---- This file contains code that is common to modules System.Console.ANSI.Unix,--- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as--- type signatures and the definition of functions specific to stdout in terms--- of the corresponding more general functions, inclduding the related Haddock--- documentation.-#include "Common-Include.hs"--- This file contains code that is common save that different code is required--- in the case of the module System.Console.ANSI.Windows.Emulator (see the file--- Common-Include-Emulator.hs in respect of the latter).-#include "Common-Include-Enabled.hs"---- | A helper function which returns the native or emulated version, depending--- on `isANSIEnabled`.-nativeOrEmulated :: a -> a -> a-nativeOrEmulated native emulated = case isANSIEnabled of- 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----- * Cursor movement by character-hCursorUp = nativeOrEmulated U.hCursorUp E.hCursorUp-hCursorDown = nativeOrEmulated U.hCursorDown E.hCursorDown-hCursorForward = nativeOrEmulated U.hCursorForward E.hCursorForward-hCursorBackward = nativeOrEmulated U.hCursorBackward E.hCursorBackward--cursorUpCode :: Int -> String-cursorUpCode = nativeOrEmulated U.cursorUpCode E.cursorUpCode--cursorDownCode :: Int -> String-cursorDownCode = nativeOrEmulated U.cursorDownCode E.cursorDownCode--cursorForwardCode :: Int -> String-cursorForwardCode = nativeOrEmulated U.cursorForwardCode E.cursorForwardCode--cursorBackwardCode :: Int -> String-cursorBackwardCode = nativeOrEmulated U.cursorBackwardCode E.cursorBackwardCode---- * Cursor movement by line-hCursorUpLine = nativeOrEmulated U.hCursorUpLine E.hCursorUpLine-hCursorDownLine = nativeOrEmulated U.hCursorDownLine E.hCursorDownLine--cursorUpLineCode :: Int -> String-cursorUpLineCode = nativeOrEmulated U.cursorUpLineCode E.cursorUpLineCode--cursorDownLineCode :: Int -> String-cursorDownLineCode = nativeOrEmulated U.cursorDownLineCode E.cursorDownLineCode---- * Directly changing cursor position-hSetCursorColumn = nativeOrEmulated U.hSetCursorColumn E.hSetCursorColumn--setCursorColumnCode :: Int -> String-setCursorColumnCode = nativeOrEmulated- U.setCursorColumnCode E.setCursorColumnCode--hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition--setCursorPositionCode :: Int -> Int -> String-setCursorPositionCode = nativeOrEmulated- U.setCursorPositionCode E.setCursorPositionCode---- * Saving, restoring and reporting cursor position-hSaveCursor = nativeOrEmulated U.hSaveCursor E.hSaveCursor-hRestoreCursor = nativeOrEmulated U.hRestoreCursor E.hRestoreCursor-hReportCursorPosition = nativeOrEmulated- U.hReportCursorPosition E.hReportCursorPosition--saveCursorCode :: String-saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode--restoreCursorCode :: String-restoreCursorCode = nativeOrEmulated U.restoreCursorCode E.restoreCursorCode--reportCursorPositionCode :: String-reportCursorPositionCode = nativeOrEmulated- U.reportCursorPositionCode E.reportCursorPositionCode---- * Clearing parts of the screen-hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault- U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd-hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault- U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning-hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen--clearFromCursorToScreenEndCode :: String-clearFromCursorToScreenEndCode = nativeOrEmulated- U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode--clearFromCursorToScreenBeginningCode :: String-clearFromCursorToScreenBeginningCode = nativeOrEmulated- U.clearFromCursorToScreenBeginningCode E.clearFromCursorToScreenBeginningCode--clearScreenCode :: String-clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode--hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault- U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd-hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault- U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning-hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine--clearFromCursorToLineEndCode :: String-clearFromCursorToLineEndCode = nativeOrEmulated- U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode--clearFromCursorToLineBeginningCode :: String-clearFromCursorToLineBeginningCode = nativeOrEmulated- U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode--clearLineCode :: String-clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode---- * Scrolling the screen-hScrollPageUp = nativeOrEmulatedWithDefault U.hScrollPageUp E.hScrollPageUp-hScrollPageDown = nativeOrEmulatedWithDefault U.hScrollPageDown E.hScrollPageDown--scrollPageUpCode :: Int -> String-scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode--scrollPageDownCode :: Int -> String-scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode---- * Select Graphic Rendition mode: colors and other whizzy stuff------ The following SGR codes are NOT implemented by Windows 10 Threshold 2:--- 2 SetConsoleIntensity FaintIntensity--- 3 SetItalicized True--- 5 SetBlinkSpeed SlowBlink--- 6 SetBlinkSpeed RapidBlink--- 8 SetVisible False--- 21 SetUnderlining DoubleUnderline--- 23 SetItalicized False--- 25 SetBlinkSpeed NoBlink--- 28 SetVisible True--hSetSGR = nativeOrEmulatedWithDefault U.hSetSGR E.hSetSGR--setSGRCode :: [SGR] -> String-setSGRCode = nativeOrEmulated U.setSGRCode E.setSGRCode---- * Cursor visibilty changes-hHideCursor = nativeOrEmulated U.hHideCursor E.hHideCursor-hShowCursor = nativeOrEmulated U.hShowCursor E.hShowCursor--hideCursorCode :: String-hideCursorCode = nativeOrEmulated U.hideCursorCode E.hideCursorCode--showCursorCode :: String-showCursorCode = nativeOrEmulated U.showCursorCode E.showCursorCode---- * Changing the title-hSetTitle = nativeOrEmulated U.hSetTitle E.hSetTitle--setTitleCode :: String -> String-setTitleCode = nativeOrEmulated U.setTitleCode E.setTitleCode---- getReportedCursorPosition :: IO String--- (See Common-Include.hs for Haddock documentation)-getReportedCursorPosition = E.getReportedCursorPosition---- getCursorPosition :: IO (Maybe (Int, Int))--- (See Common-Include.hs for Haddock documentation)-getCursorPosition = E.getCursorPosition+{-# OPTIONS_HADDOCK hide #-} + +module System.Console.ANSI.Windows + ( +-- This file contains code that is common to modules +-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module +-- exports and the associated Haddock documentation. +#include "Exports-Include.hs" + ) where + +import System.IO (Handle, hIsTerminalDevice, stdout) + +import System.Console.ANSI.Types +import qualified System.Console.ANSI.Unix as U +import System.Console.ANSI.Windows.Detect (ANSIEnabledStatus (..), + ConsoleDefaultState (..), isANSIEnabled) +import qualified System.Console.ANSI.Windows.Emulator as E + +-- This file contains code that is common to modules System.Console.ANSI.Unix, +-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as +-- type signatures and the definition of functions specific to stdout in terms +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. +#include "Common-Include.hs" +-- This file contains code that is common save that different code is required +-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file +-- Common-Include-Emulator.hs in respect of the latter). +#include "Common-Include-Enabled.hs" + +-- | A helper function which returns the native or emulated version, depending +-- on `isANSIEnabled`. +nativeOrEmulated :: a -> a -> a +nativeOrEmulated native emulated = case isANSIEnabled of + 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 + + +-- * Cursor movement by character +hCursorUp = nativeOrEmulated U.hCursorUp E.hCursorUp +hCursorDown = nativeOrEmulated U.hCursorDown E.hCursorDown +hCursorForward = nativeOrEmulated U.hCursorForward E.hCursorForward +hCursorBackward = nativeOrEmulated U.hCursorBackward E.hCursorBackward + +cursorUpCode :: Int -> String +cursorUpCode = nativeOrEmulated U.cursorUpCode E.cursorUpCode + +cursorDownCode :: Int -> String +cursorDownCode = nativeOrEmulated U.cursorDownCode E.cursorDownCode + +cursorForwardCode :: Int -> String +cursorForwardCode = nativeOrEmulated U.cursorForwardCode E.cursorForwardCode + +cursorBackwardCode :: Int -> String +cursorBackwardCode = nativeOrEmulated U.cursorBackwardCode E.cursorBackwardCode + +-- * Cursor movement by line +hCursorUpLine = nativeOrEmulated U.hCursorUpLine E.hCursorUpLine +hCursorDownLine = nativeOrEmulated U.hCursorDownLine E.hCursorDownLine + +cursorUpLineCode :: Int -> String +cursorUpLineCode = nativeOrEmulated U.cursorUpLineCode E.cursorUpLineCode + +cursorDownLineCode :: Int -> String +cursorDownLineCode = nativeOrEmulated U.cursorDownLineCode E.cursorDownLineCode + +-- * Directly changing cursor position +hSetCursorColumn = nativeOrEmulated U.hSetCursorColumn E.hSetCursorColumn + +setCursorColumnCode :: Int -> String +setCursorColumnCode = nativeOrEmulated + U.setCursorColumnCode E.setCursorColumnCode + +hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition + +setCursorPositionCode :: Int -> Int -> String +setCursorPositionCode = nativeOrEmulated + U.setCursorPositionCode E.setCursorPositionCode + +-- * Saving, restoring and reporting cursor position +hSaveCursor = nativeOrEmulated U.hSaveCursor E.hSaveCursor +hRestoreCursor = nativeOrEmulated U.hRestoreCursor E.hRestoreCursor +hReportCursorPosition = nativeOrEmulated + U.hReportCursorPosition E.hReportCursorPosition + +saveCursorCode :: String +saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode + +restoreCursorCode :: String +restoreCursorCode = nativeOrEmulated U.restoreCursorCode E.restoreCursorCode + +reportCursorPositionCode :: String +reportCursorPositionCode = nativeOrEmulated + U.reportCursorPositionCode E.reportCursorPositionCode + +-- * Clearing parts of the screen +hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault + U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd +hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault + U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning +hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen + +clearFromCursorToScreenEndCode :: String +clearFromCursorToScreenEndCode = nativeOrEmulated + U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode + +clearFromCursorToScreenBeginningCode :: String +clearFromCursorToScreenBeginningCode = nativeOrEmulated + U.clearFromCursorToScreenBeginningCode E.clearFromCursorToScreenBeginningCode + +clearScreenCode :: String +clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode + +hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault + U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd +hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault + U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning +hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine + +clearFromCursorToLineEndCode :: String +clearFromCursorToLineEndCode = nativeOrEmulated + U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode + +clearFromCursorToLineBeginningCode :: String +clearFromCursorToLineBeginningCode = nativeOrEmulated + U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode + +clearLineCode :: String +clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode + +-- * Scrolling the screen +hScrollPageUp = nativeOrEmulatedWithDefault U.hScrollPageUp E.hScrollPageUp +hScrollPageDown = nativeOrEmulatedWithDefault U.hScrollPageDown E.hScrollPageDown + +scrollPageUpCode :: Int -> String +scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode + +scrollPageDownCode :: Int -> String +scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode + +-- * Select Graphic Rendition mode: colors and other whizzy stuff +-- +-- The following SGR codes are NOT implemented by Windows 10 Threshold 2: +-- 2 SetConsoleIntensity FaintIntensity +-- 3 SetItalicized True +-- 5 SetBlinkSpeed SlowBlink +-- 6 SetBlinkSpeed RapidBlink +-- 8 SetVisible False +-- 21 SetUnderlining DoubleUnderline +-- 23 SetItalicized False +-- 25 SetBlinkSpeed NoBlink +-- 28 SetVisible True + +hSetSGR = nativeOrEmulatedWithDefault U.hSetSGR E.hSetSGR + +setSGRCode :: [SGR] -> String +setSGRCode = nativeOrEmulated U.setSGRCode E.setSGRCode + +-- * Cursor visibilty changes +hHideCursor = nativeOrEmulated U.hHideCursor E.hHideCursor +hShowCursor = nativeOrEmulated U.hShowCursor E.hShowCursor + +hideCursorCode :: String +hideCursorCode = nativeOrEmulated U.hideCursorCode E.hideCursorCode + +showCursorCode :: String +showCursorCode = nativeOrEmulated U.showCursorCode E.showCursorCode + +-- * Changing the title +hSetTitle = nativeOrEmulated U.hSetTitle E.hSetTitle + +setTitleCode :: String -> String +setTitleCode = nativeOrEmulated U.setTitleCode E.setTitleCode + +-- getReportedCursorPosition :: IO String +-- (See Common-Include.hs for Haddock documentation) +getReportedCursorPosition = E.getReportedCursorPosition + +-- getCursorPosition :: IO (Maybe (Int, Int)) +-- (See Common-Include.hs for Haddock documentation) +getCursorPosition = E.getCursorPosition
System/Console/ANSI/Windows/Detect.hs view
@@ -1,115 +1,123 @@-{-# OPTIONS_HADDOCK hide #-}--module System.Console.ANSI.Windows.Detect- (- ANSIEnabledStatus (..)- , ConsoleDefaultState (..)- , isANSIEnabled- ) where--import Control.Exception (SomeException(..), onException, throwIO, try)-import Data.Bits ((.&.), (.|.))--- '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)---- | 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)---- | 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--- ANSI-enabled, the state of the console is considered to be its default state.-{-# NOINLINE isANSIEnabled #-}-isANSIEnabled :: ANSIEnabledStatus-isANSIEnabled = unsafePerformIO $ do- 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--- 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- 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- Nothing -> doesEnableANSIOutSucceed---- This function returns whether or not an attempt to enable virtual terminal--- 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---- 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'---- 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+{-# OPTIONS_HADDOCK hide #-} + +module System.Console.ANSI.Windows.Detect + ( + ANSIEnabledStatus (..) + , ConsoleDefaultState (..) + , isANSIEnabled + ) where + +import Control.Exception (SomeException(..), onException, throwIO, try) +import Data.Bits ((.&.), (.|.)) +-- '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) + +-- | 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) + +-- | 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 +-- ANSI-enabled, the state of the console is considered to be its default state. +{-# 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 + +-- 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 get a valid standard output handle. If that does not fail, it +-- tried to get a ConHost console mode. If that fails, it assumes that the +-- handle 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 + 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 + Nothing -> doesEnableANSIOutSucceed + +-- This function returns whether or not an attempt to enable virtual terminal +-- processing succeeded, or was deemed to succeed, in the IO monad. +doesEnableANSIOutSucceed :: IO Bool +doesEnableANSIOutSucceed = do + result <- try enableANSIOut :: IO (Either SomeException ()) + case result of + Left _ -> return False + Right () -> return True + +-- This function tries to get a valid handle on the standard output and throws +-- an exception if it cannot. It then tries to get a ConHost console mode for +-- that handle. If it can not, it assumes that the standard output handle is +-- ANSI-enabled. If it can, it tries to enable virtual terminal processing and +-- throws an exception if it can not. +enableANSIOut :: IO () +enableANSIOut = do + hOut <- getValidStdHandle sTD_OUTPUT_HANDLE + result <- conHostConsoleMode hOut + case result of + Nothing -> return () -- assume hOut is ANSI-enabled + Just mOut -> do + 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 or no handle + else return h + +-- The function tries to get a ConHost console mode from a handle that is +-- assumed to be a valid standard handle (see getValidStdHandle) +conHostConsoleMode :: HANDLE -> IO (Maybe DWORD) +conHostConsoleMode h = do + result <- try (getConsoleMode h) :: IO (Either SomeException DWORD) + case result of + Left _ -> return Nothing + Right mode -> return (Just mode)
System/Console/ANSI/Windows/Emulator.hs view
@@ -1,464 +1,464 @@-{-# OPTIONS_HADDOCK hide #-}--module System.Console.ANSI.Windows.Emulator- (-#include "Exports-Include.hs"- ) where--import Control.Exception (catch, catchJust, IOException)-import Control.Monad (forM_, unless)-import Data.Bits ((.&.), (.|.), complement, shiftL, shiftR)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.List (foldl', minimumBy)-import Data.Maybe (mapMaybe)-import qualified Data.Map.Strict as Map (Map, empty, insert, lookup)-import System.IO (Handle, 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--- of the corresponding more general functions, inclduding the related Haddock--- documentation.-#include "Common-Include.hs"--- This file contains code that is required in the case of the module--- System.Console.ANSI.Windows.Emulator and differs from the common code in--- file Common-Include-Enabled.hs.-#include "Common-Include-Emulator.hs"--withHandle :: Handle -> (HANDLE -> IO a) -> IO a-withHandle handle action = do- -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API- -- call to change the console because on Windows the arrival of- -- API-initiated state changes is not necessarily synchronised with that of- -- the text they are attempting to modify.- hFlush handle- withHandleToHANDLE handle action---- Unfortunately, the emulator is not perfect. In particular, it has a tendency--- to die with exceptions about invalid handles when it is used with certain--- Windows consoles (e.g. mintty, terminator, or cygwin sshd).------ This happens because in those environments the stdout family of handles are--- not actually associated with a real console.------ My observation is that every time I've seen this in practice, the handle we--- have instead of the actual console handle is there so that the terminal--- supports ANSI escape codes. So 99% of the time, the correct thing to do is--- just to fall back on the Unix module to output the ANSI codes and hope for--- the best.-emulatorFallback :: IO a -> IO a -> IO a-emulatorFallback fallback first_try- = catchJust invalidHandle first_try (const fallback)- where- invalidHandle (ConsoleException 6) = Just () -- 6 is the Windows error code- -- for invalid handles- invalidHandle (_) = Nothing--adjustCursorPosition :: HANDLE- -> (SHORT -> SHORT -> SHORT)- -> (SHORT -> SHORT -> SHORT)- -> IO ()-adjustCursorPosition handle change_x change_y = do- screen_buffer_info <- getConsoleScreenBufferInfo handle- let window = csbi_window screen_buffer_info- (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)--adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO ()-adjustLine handle change_y- = adjustCursorPosition handle (\window_left _ -> window_left) change_y--hCursorDownLine h n- = emulatorFallback (Unix.hCursorDownLine h n) $ withHandle h $- \handle -> adjustLine handle (\_ y -> y + fromIntegral n)--hCursorUpLine h n- = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $- \handle -> adjustLine handle (\_ y -> y - fromIntegral n)--hSetCursorColumn h x- = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $- \handle -> adjustCursorPosition handle- (\window_left _ -> window_left + fromIntegral x) (\_ y -> y)--hSetCursorPosition h y x- = emulatorFallback (Unix.hSetCursorPosition h y x) $ withHandle h $- \handle -> adjustCursorPosition handle- (\window_left _ -> window_left + fromIntegral x)- (\window_top _ -> window_top + fromIntegral y)--clearChar :: WCHAR-clearChar = charToWCHAR ' '---- | The 'clear' attribute is equated with the default background attributes.-clearAttribute :: ConsoleDefaultState -> WORD-clearAttribute = defaultBackgroundAttributes--hClearScreenFraction- :: ConsoleDefaultState- -> HANDLE- -> (SMALL_RECT -> COORD -> (SHORT, SHORT, SHORT, SHORT, SHORT, SHORT))- -> IO ()-hClearScreenFraction cds handle fraction_finder = do- screen_buffer_info <- getConsoleScreenBufferInfo handle- let window = csbi_window screen_buffer_info- cursor_pos = csbi_cursor_position screen_buffer_info- (left, top, right, bottom, start_x, end_x)- = fraction_finder window cursor_pos- mapM_ (fill_line left top right bottom start_x end_x) [top .. bottom]- where- fill_line left top right bottom start_x end_x y = do- let left' = if y == top then start_x else left- right' = if y == bottom then end_x else right- fill_cursor_pos = COORD left' y- fill_length = fromIntegral $ right' - left' + 1- _ <- fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos- fillConsoleOutputAttribute handle (clearAttribute cds) fill_length- fill_cursor_pos--hClearFromCursorToScreenEnd cds h- = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $- \handle -> hClearScreenFraction cds handle go- where- go window cursor_pos = (left, top, right, bottom, start_x, right)- where- SMALL_RECT (COORD left _) (COORD right bottom) = window- COORD start_x top = cursor_pos--hClearFromCursorToScreenBeginning cds h- = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $- \handle -> hClearScreenFraction cds handle go- where- go window cursor_pos = (left, top, right, bottom, left, end_x)- where- SMALL_RECT (COORD left top) (COORD right _) = window- COORD end_x bottom = cursor_pos--hClearScreen cds h- = emulatorFallback (Unix.hClearScreen h) $ withHandle h $- \handle -> hClearScreenFraction cds handle go- where- go window _ = (left, top, right, bottom, left, right)- where- SMALL_RECT (COORD left top) (COORD right bottom) = window--hClearFromCursorToLineEnd cds h- = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $- \handle -> hClearScreenFraction cds handle go- where- go window cursor_pos = (left, y, right, y, start_x, right)- where- SMALL_RECT (COORD left _) (COORD right _) = window- COORD start_x y = cursor_pos--hClearFromCursorToLineBeginning cds h- = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $- \handle -> hClearScreenFraction cds handle go- where- go window cursor_pos = (left, y, right, y, left, end_x)- where- SMALL_RECT (COORD left _) (COORD right _) = window- COORD end_x y = cursor_pos--hClearLine cds h- = emulatorFallback (Unix.hClearLine h) $ withHandle h $- \handle -> hClearScreenFraction cds handle go- where- go window cursor_pos = (left, y, right, y, left, right)- where- SMALL_RECT (COORD left _) (COORD right _) = window- COORD _ y = cursor_pos--hScrollPage- :: ConsoleDefaultState -- ^ The default console state- -> HANDLE- -> Int- -> IO ()-hScrollPage cds handle new_origin_y = do- screen_buffer_info <- getConsoleScreenBufferInfo handle- let fill = CHAR_INFO clearChar (clearAttribute cds)- window = csbi_window screen_buffer_info- origin = COORD (rect_left window)- (rect_top window + fromIntegral new_origin_y)- scrollConsoleScreenBuffer handle window Nothing origin fill--hScrollPageUp cds h n- = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $- \handle -> hScrollPage cds handle (negate n)--hScrollPageDown cds h n- = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $- \handle -> hScrollPage cds handle n--{-# INLINE applyANSIColorToAttribute #-}-applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD-applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of- Black -> attribute'- Red -> attribute' .|. rED- Green -> attribute' .|. gREEN- Yellow -> attribute' .|. rED .|. gREEN- Blue -> attribute' .|. bLUE- Magenta -> attribute' .|. rED .|. bLUE- Cyan -> attribute' .|. gREEN .|. bLUE- White -> attribute' .|. wHITE- where- wHITE = rED .|. gREEN .|. bLUE- attribute' = attribute .&. (complement wHITE)--applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute- :: Color- -> WORD- -> WORD-applyForegroundANSIColorToAttribute- = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE-applyBackgroundANSIColorToAttribute- = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE--swapForegroundBackgroundColors :: WORD -> WORD-swapForegroundBackgroundColors attribute- = clean_attribute .|. foreground_attribute' .|. background_attribute'- where- foreground_attribute = attribute .&. fOREGROUND_INTENSE_WHITE- background_attribute = attribute .&. bACKGROUND_INTENSE_WHITE- clean_attribute = attribute .&. complement- (fOREGROUND_INTENSE_WHITE .|. bACKGROUND_INTENSE_WHITE)- foreground_attribute' = background_attribute `shiftR` 4- background_attribute' = foreground_attribute `shiftL` 4--applyANSISGRToAttribute :: WORD -> SGR -> WORD -> WORD-applyANSISGRToAttribute def sgr attribute = case sgr of- Reset -> def- 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'--hChangeCursorVisibility :: HANDLE -> Bool -> IO ()-hChangeCursorVisibility handle cursor_visible = do- cursor_info <- getConsoleCursorInfo handle- setConsoleCursorInfo handle- (cursor_info { cci_cursor_visible = cursor_visible })--hHideCursor h- = emulatorFallback (Unix.hHideCursor h) $ withHandle h $- \handle -> hChangeCursorVisibility handle False-hShowCursor h- = emulatorFallback (Unix.hShowCursor h) $ withHandle h $- \handle -> hChangeCursorVisibility handle True---- Windows only supports setting the terminal title on a process-wide basis, so--- for now we will assume that that is what the user intended. This will fail if--- they are sending the command over e.g. a network link... but that's not--- really what I'm designing for.-hSetTitle h title- = emulatorFallback (Unix.hSetTitle h title) $- withTString title $ setConsoleTitle--cursorPositionRef :: IORef (Map.Map HANDLE COORD)-{-# NOINLINE cursorPositionRef #-}-cursorPositionRef = unsafePerformIO $ newIORef Map.empty--hSaveCursor h- = emulatorFallback (Unix.hSaveCursor h) $ withHandle h $ \handle -> do- screen_buffer_info <- getConsoleScreenBufferInfo handle- m <- readIORef cursorPositionRef- writeIORef cursorPositionRef- (Map.insert handle (csbi_cursor_position screen_buffer_info) m)--hRestoreCursor h- = emulatorFallback (Unix.hRestoreCursor h) $ withHandle h $ \handle -> do- m <- readIORef cursorPositionRef- let result = Map.lookup handle m- 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 ()--keyPress :: Char -> [INPUT_RECORD]-keyPress c = [keyDown, keyUp]- where- keyDown = key True- keyUp = key False- c' = UnicodeAsciiChar $ charToWCHAR c- key isDown = INPUT_RECORD kEY_EVENT $- InputKeyEvent (KEY_EVENT_RECORD isDown 1 0 0 c' 0)--keyPresses :: String -> [INPUT_RECORD]-keyPresses = concatMap keyPress--aNSIColors :: [((ColorIntensity, Color), Colour Float)]-aNSIColors = [ ((Dull, Black), black)- , ((Dull, Blue), navy)- , ((Dull, Green), green)- , ((Dull, Cyan), teal)- , ((Dull, Red), maroon)- , ((Dull, Magenta), purple)- , ((Dull, Yellow), olive)- , ((Dull, White), silver)- , ((Vivid, Black), grey)- , ((Vivid, Blue), blue)- , ((Vivid, Green), lime)- , ((Vivid, Cyan), cyan)- , ((Vivid, Red), red)- , ((Vivid, Magenta), magenta)- , ((Vivid, Yellow), yellow)- , ((Vivid, White), white) ]--toANSIColor :: Colour Float -> (ColorIntensity, Color)-toANSIColor color = fst $ minimumBy order aNSIColors- where- RGB r g b = toSRGB color- order (_, c1) (_, c2) = compare (dist c1) (dist c2)- dist c = let RGB r' g' b' = toSRGB c- dr = r' - r- dg = g' - g- db = b' - b- in dr * dr + dg * dg + db * db---- 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---- 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)--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."+{-# OPTIONS_HADDOCK hide #-} + +module System.Console.ANSI.Windows.Emulator + ( +#include "Exports-Include.hs" + ) where + +import Control.Exception (catch, catchJust, IOException) +import Control.Monad (forM_, unless) +import Data.Bits ((.&.), (.|.), complement, shiftL, shiftR) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (foldl', minimumBy) +import Data.Maybe (mapMaybe) +import qualified Data.Map.Strict as Map (Map, empty, insert, lookup) +import System.IO (Handle, 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 +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. +#include "Common-Include.hs" +-- This file contains code that is required in the case of the module +-- System.Console.ANSI.Windows.Emulator and differs from the common code in +-- file Common-Include-Enabled.hs. +#include "Common-Include-Emulator.hs" + +withHandle :: Handle -> (HANDLE -> IO a) -> IO a +withHandle handle action = do + -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API + -- call to change the console because on Windows the arrival of + -- API-initiated state changes is not necessarily synchronised with that of + -- the text they are attempting to modify. + hFlush handle + withHandleToHANDLE handle action + +-- Unfortunately, the emulator is not perfect. In particular, it has a tendency +-- to die with exceptions about invalid handles when it is used with certain +-- Windows consoles (e.g. mintty, terminator, or cygwin sshd). +-- +-- This happens because in those environments the stdout family of handles are +-- not actually associated with a real console. +-- +-- My observation is that every time I've seen this in practice, the handle we +-- have instead of the actual console handle is there so that the terminal +-- supports ANSI escape codes. So 99% of the time, the correct thing to do is +-- just to fall back on the Unix module to output the ANSI codes and hope for +-- the best. +emulatorFallback :: IO a -> IO a -> IO a +emulatorFallback fallback first_try + = catchJust invalidHandle first_try (const fallback) + where + invalidHandle (ConsoleException 6) = Just () -- 6 is the Windows error code + -- for invalid handles + invalidHandle (_) = Nothing + +adjustCursorPosition :: HANDLE + -> (SHORT -> SHORT -> SHORT) + -> (SHORT -> SHORT -> SHORT) + -> IO () +adjustCursorPosition handle change_x change_y = do + screen_buffer_info <- getConsoleScreenBufferInfo handle + let window = csbi_window screen_buffer_info + (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) + +adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO () +adjustLine handle change_y + = adjustCursorPosition handle (\window_left _ -> window_left) change_y + +hCursorDownLine h n + = emulatorFallback (Unix.hCursorDownLine h n) $ withHandle h $ + \handle -> adjustLine handle (\_ y -> y + fromIntegral n) + +hCursorUpLine h n + = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $ + \handle -> adjustLine handle (\_ y -> y - fromIntegral n) + +hSetCursorColumn h x + = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ + \handle -> adjustCursorPosition handle + (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) + +hSetCursorPosition h y x + = emulatorFallback (Unix.hSetCursorPosition h y x) $ withHandle h $ + \handle -> adjustCursorPosition handle + (\window_left _ -> window_left + fromIntegral x) + (\window_top _ -> window_top + fromIntegral y) + +clearChar :: WCHAR +clearChar = charToWCHAR ' ' + +-- | The 'clear' attribute is equated with the default background attributes. +clearAttribute :: ConsoleDefaultState -> WORD +clearAttribute = defaultBackgroundAttributes + +hClearScreenFraction + :: ConsoleDefaultState + -> HANDLE + -> (SMALL_RECT -> COORD -> (SHORT, SHORT, SHORT, SHORT, SHORT, SHORT)) + -> IO () +hClearScreenFraction cds handle fraction_finder = do + screen_buffer_info <- getConsoleScreenBufferInfo handle + let window = csbi_window screen_buffer_info + cursor_pos = csbi_cursor_position screen_buffer_info + (left, top, right, bottom, start_x, end_x) + = fraction_finder window cursor_pos + mapM_ (fill_line left top right bottom start_x end_x) [top .. bottom] + where + fill_line left top right bottom start_x end_x y = do + let left' = if y == top then start_x else left + right' = if y == bottom then end_x else right + fill_cursor_pos = COORD left' y + fill_length = fromIntegral $ right' - left' + 1 + _ <- fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos + fillConsoleOutputAttribute handle (clearAttribute cds) fill_length + fill_cursor_pos + +hClearFromCursorToScreenEnd cds h + = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go + where + go window cursor_pos = (left, top, right, bottom, start_x, right) + where + SMALL_RECT (COORD left _) (COORD right bottom) = window + COORD start_x top = cursor_pos + +hClearFromCursorToScreenBeginning cds h + = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go + where + go window cursor_pos = (left, top, right, bottom, left, end_x) + where + SMALL_RECT (COORD left top) (COORD right _) = window + COORD end_x bottom = cursor_pos + +hClearScreen cds h + = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go + where + go window _ = (left, top, right, bottom, left, right) + where + SMALL_RECT (COORD left top) (COORD right bottom) = window + +hClearFromCursorToLineEnd cds h + = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go + where + go window cursor_pos = (left, y, right, y, start_x, right) + where + SMALL_RECT (COORD left _) (COORD right _) = window + COORD start_x y = cursor_pos + +hClearFromCursorToLineBeginning cds h + = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go + where + go window cursor_pos = (left, y, right, y, left, end_x) + where + SMALL_RECT (COORD left _) (COORD right _) = window + COORD end_x y = cursor_pos + +hClearLine cds h + = emulatorFallback (Unix.hClearLine h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go + where + go window cursor_pos = (left, y, right, y, left, right) + where + SMALL_RECT (COORD left _) (COORD right _) = window + COORD _ y = cursor_pos + +hScrollPage + :: ConsoleDefaultState -- ^ The default console state + -> HANDLE + -> Int + -> IO () +hScrollPage cds handle new_origin_y = do + screen_buffer_info <- getConsoleScreenBufferInfo handle + let fill = CHAR_INFO clearChar (clearAttribute cds) + window = csbi_window screen_buffer_info + origin = COORD (rect_left window) + (rect_top window + fromIntegral new_origin_y) + scrollConsoleScreenBuffer handle window Nothing origin fill + +hScrollPageUp cds h n + = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ + \handle -> hScrollPage cds handle (negate n) + +hScrollPageDown cds h n + = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ + \handle -> hScrollPage cds handle n + +{-# INLINE applyANSIColorToAttribute #-} +applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD +applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of + Black -> attribute' + Red -> attribute' .|. rED + Green -> attribute' .|. gREEN + Yellow -> attribute' .|. rED .|. gREEN + Blue -> attribute' .|. bLUE + Magenta -> attribute' .|. rED .|. bLUE + Cyan -> attribute' .|. gREEN .|. bLUE + White -> attribute' .|. wHITE + where + wHITE = rED .|. gREEN .|. bLUE + attribute' = attribute .&. (complement wHITE) + +applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute + :: Color + -> WORD + -> WORD +applyForegroundANSIColorToAttribute + = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE +applyBackgroundANSIColorToAttribute + = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE + +swapForegroundBackgroundColors :: WORD -> WORD +swapForegroundBackgroundColors attribute + = clean_attribute .|. foreground_attribute' .|. background_attribute' + where + foreground_attribute = attribute .&. fOREGROUND_INTENSE_WHITE + background_attribute = attribute .&. bACKGROUND_INTENSE_WHITE + clean_attribute = attribute .&. complement + (fOREGROUND_INTENSE_WHITE .|. bACKGROUND_INTENSE_WHITE) + foreground_attribute' = background_attribute `shiftR` 4 + background_attribute' = foreground_attribute `shiftL` 4 + +applyANSISGRToAttribute :: WORD -> SGR -> WORD -> WORD +applyANSISGRToAttribute def sgr attribute = case sgr of + Reset -> def + 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' + +hChangeCursorVisibility :: HANDLE -> Bool -> IO () +hChangeCursorVisibility handle cursor_visible = do + cursor_info <- getConsoleCursorInfo handle + setConsoleCursorInfo handle + (cursor_info { cci_cursor_visible = cursor_visible }) + +hHideCursor h + = emulatorFallback (Unix.hHideCursor h) $ withHandle h $ + \handle -> hChangeCursorVisibility handle False +hShowCursor h + = emulatorFallback (Unix.hShowCursor h) $ withHandle h $ + \handle -> hChangeCursorVisibility handle True + +-- Windows only supports setting the terminal title on a process-wide basis, so +-- for now we will assume that that is what the user intended. This will fail if +-- they are sending the command over e.g. a network link... but that's not +-- really what I'm designing for. +hSetTitle h title + = emulatorFallback (Unix.hSetTitle h title) $ + withTString title $ setConsoleTitle + +cursorPositionRef :: IORef (Map.Map HANDLE COORD) +{-# NOINLINE cursorPositionRef #-} +cursorPositionRef = unsafePerformIO $ newIORef Map.empty + +hSaveCursor h + = emulatorFallback (Unix.hSaveCursor h) $ withHandle h $ \handle -> do + screen_buffer_info <- getConsoleScreenBufferInfo handle + m <- readIORef cursorPositionRef + writeIORef cursorPositionRef + (Map.insert handle (csbi_cursor_position screen_buffer_info) m) + +hRestoreCursor h + = emulatorFallback (Unix.hRestoreCursor h) $ withHandle h $ \handle -> do + m <- readIORef cursorPositionRef + let result = Map.lookup handle m + 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 () + +keyPress :: Char -> [INPUT_RECORD] +keyPress c = [keyDown, keyUp] + where + keyDown = key True + keyUp = key False + c' = UnicodeAsciiChar $ charToWCHAR c + key isDown = INPUT_RECORD kEY_EVENT $ + InputKeyEvent (KEY_EVENT_RECORD isDown 1 0 0 c' 0) + +keyPresses :: String -> [INPUT_RECORD] +keyPresses = concatMap keyPress + +aNSIColors :: [((ColorIntensity, Color), Colour Float)] +aNSIColors = [ ((Dull, Black), black) + , ((Dull, Blue), navy) + , ((Dull, Green), green) + , ((Dull, Cyan), teal) + , ((Dull, Red), maroon) + , ((Dull, Magenta), purple) + , ((Dull, Yellow), olive) + , ((Dull, White), silver) + , ((Vivid, Black), grey) + , ((Vivid, Blue), blue) + , ((Vivid, Green), lime) + , ((Vivid, Cyan), cyan) + , ((Vivid, Red), red) + , ((Vivid, Magenta), magenta) + , ((Vivid, Yellow), yellow) + , ((Vivid, White), white) ] + +toANSIColor :: Colour Float -> (ColorIntensity, Color) +toANSIColor color = fst $ minimumBy order aNSIColors + where + RGB r g b = toSRGB color + order (_, c1) (_, c2) = compare (dist c1) (dist c2) + dist c = let RGB r' g' b' = toSRGB c + dr = r' - r + dg = g' - g + db = b' - b + in dr * dr + dg * dg + db * db + +-- 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 + +-- 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) + +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."
System/Console/ANSI/Windows/Emulator/Codes.hs view
@@ -1,94 +1,94 @@-{-# OPTIONS_HADDOCK hide #-}--module System.Console.ANSI.Windows.Emulator.Codes- (- -- * Cursor movement by character- cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode-- -- * Cursor movement by line- , cursorUpLineCode, cursorDownLineCode-- -- * Directly changing cursor position- , setCursorColumnCode, setCursorPositionCode-- -- * Saving, restoring and reporting cursor position- , saveCursorCode, restoreCursorCode, reportCursorPositionCode-- -- * Clearing parts of the screen- , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode- , clearScreenCode, clearFromCursorToLineEndCode- , clearFromCursorToLineBeginningCode, clearLineCode-- -- * Scrolling the screen- , scrollPageUpCode, scrollPageDownCode-- -- * Select Graphic Rendition mode: colors and other whizzy stuff- , setSGRCode-- -- * Cursor visibilty changes- , hideCursorCode, showCursorCode-- -- * Changing the title- , setTitleCode- ) where--import System.Console.ANSI.Types--cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode- :: Int -- ^ Number of lines or characters to move- -> String-cursorUpCode _ = ""-cursorDownCode _ = ""-cursorForwardCode _ = ""-cursorBackwardCode _ = ""--cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move- -> String-cursorDownLineCode _ = ""-cursorUpLineCode _ = ""--setCursorColumnCode :: Int -- ^ 0-based column to move to- -> String-setCursorColumnCode _ = ""--setCursorPositionCode :: Int -- ^ 0-based row to move to- -> Int -- ^ 0-based column to move to- -> String-setCursorPositionCode _ _ = ""--saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String-saveCursorCode = ""-restoreCursorCode = ""-reportCursorPositionCode = ""--clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,- clearScreenCode :: String-clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,- clearLineCode :: String--clearFromCursorToScreenEndCode = ""-clearFromCursorToScreenBeginningCode = ""-clearScreenCode = ""-clearFromCursorToLineEndCode = ""-clearFromCursorToLineBeginningCode = ""-clearLineCode = ""--scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by- -> String-scrollPageUpCode _ = ""-scrollPageDownCode _ = ""--setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the- -- current console SGR mode. An empty list of commands is- -- equivalent to the list @[Reset]@. Commands are applied- -- left to right.- -> String-setSGRCode _ = ""--hideCursorCode, showCursorCode :: String-hideCursorCode = ""-showCursorCode = ""--setTitleCode :: String -- ^ New title- -> String-setTitleCode _ = ""+{-# OPTIONS_HADDOCK hide #-} + +module System.Console.ANSI.Windows.Emulator.Codes + ( + -- * Cursor movement by character + cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode + + -- * Cursor movement by line + , cursorUpLineCode, cursorDownLineCode + + -- * Directly changing cursor position + , setCursorColumnCode, setCursorPositionCode + + -- * Saving, restoring and reporting cursor position + , saveCursorCode, restoreCursorCode, reportCursorPositionCode + + -- * Clearing parts of the screen + , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode + , clearScreenCode, clearFromCursorToLineEndCode + , clearFromCursorToLineBeginningCode, clearLineCode + + -- * Scrolling the screen + , scrollPageUpCode, scrollPageDownCode + + -- * Select Graphic Rendition mode: colors and other whizzy stuff + , setSGRCode + + -- * Cursor visibilty changes + , hideCursorCode, showCursorCode + + -- * Changing the title + , setTitleCode + ) where + +import System.Console.ANSI.Types + +cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode + :: Int -- ^ Number of lines or characters to move + -> String +cursorUpCode _ = "" +cursorDownCode _ = "" +cursorForwardCode _ = "" +cursorBackwardCode _ = "" + +cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move + -> String +cursorDownLineCode _ = "" +cursorUpLineCode _ = "" + +setCursorColumnCode :: Int -- ^ 0-based column to move to + -> String +setCursorColumnCode _ = "" + +setCursorPositionCode :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> String +setCursorPositionCode _ _ = "" + +saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String +saveCursorCode = "" +restoreCursorCode = "" +reportCursorPositionCode = "" + +clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, + clearScreenCode :: String +clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, + clearLineCode :: String + +clearFromCursorToScreenEndCode = "" +clearFromCursorToScreenBeginningCode = "" +clearScreenCode = "" +clearFromCursorToLineEndCode = "" +clearFromCursorToLineBeginningCode = "" +clearLineCode = "" + +scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by + -> String +scrollPageUpCode _ = "" +scrollPageDownCode _ = "" + +setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the + -- current console SGR mode. An empty list of commands is + -- equivalent to the list @[Reset]@. Commands are applied + -- left to right. + -> String +setSGRCode _ = "" + +hideCursorCode, showCursorCode :: String +hideCursorCode = "" +showCursorCode = "" + +setTitleCode :: String -- ^ New title + -> String +setTitleCode _ = ""
System/Console/ANSI/Windows/Foreign.hs view
@@ -1,718 +1,731 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | "System.Win32.Console" is really very impoverished, so I have had to do all--- the FFI myself.-module System.Console.ANSI.Windows.Foreign- (- -- Re-exports from Win32.Types- BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT,-- -- 'Re-exports from System.Win32.Console.Extra'- INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT,- KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput,- getNumberOfConsoleInputEvents, readConsoleInput,-- charToWCHAR, cWcharsToChars,-- COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right,- rect_width, rect_height, CONSOLE_CURSOR_INFO(..),- CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..),-- sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE,-- eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING,-- fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY,- fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE,- bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY,- bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE,- cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE,-- getStdHandle,- getConsoleScreenBufferInfo,- getConsoleCursorInfo,- getConsoleMode,-- setConsoleTextAttribute,- setConsoleCursorPosition,- setConsoleCursorInfo,- setConsoleTitle,- setConsoleMode,-- fillConsoleOutputAttribute,- fillConsoleOutputCharacter,- scrollConsoleScreenBuffer,-- withTString, withHandleToHANDLE,-- ConsoleException (..)- ) where--import Control.Exception (Exception, throw)-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 (readMVar)-import Control.Exception (bracket)-import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr)-#if __GLASGOW_HASKELL__ >= 612-import Data.Typeable (cast)-import GHC.IO.FD (FD(..)) -- A wrapper around an Int32-import GHC.IO.Handle.Types (Handle (..), Handle__ (..))-#else-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-#elif defined(x86_64_HOST_ARCH)-#define WINDOWS_CCONV ccall-#else-#error Unknown mingw32 arch-#endif---- Missing from System.Win32.Types prior to version 2.5.0.0-#if !MIN_VERSION_Win32(2,5,0)-type SHORT = CShort-#endif-type WCHAR = CWchar--charToWCHAR :: Char -> WCHAR-charToWCHAR char = fromIntegral (ord char)---- This is a FFI hack. Some of the API calls take a Coord, but that isn't a--- built-in FFI type so I can't use it directly. Instead, I use UNPACKED_COORD--- and marshal COORDs into this manually. Note that we CAN'T just use two SHORTs--- directly because they get expanded to 4 bytes each instead of just boing 2--- lots of 2 bytes by the stdcall convention, so linking fails.-type UNPACKED_COORD = CInt---- Field packing order determined experimentally: I couldn't immediately find a--- specification for Windows struct layout anywhere.-unpackCOORD :: COORD -> UNPACKED_COORD-unpackCOORD (COORD x y)- = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x)---peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b)-peekAndOffset ptr = do- item <- peek ptr- return (item, ptr `plusPtr` sizeOf item)--pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b)-pokeAndOffset ptr item = do- poke ptr item- return (ptr `plusPtr` sizeOf item)--data COORD = COORD- { coord_x :: SHORT- , coord_y :: SHORT- } deriving (Read, Eq)--instance Show COORD where- show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")"--instance Storable COORD where- sizeOf ~(COORD x y) = sizeOf x + sizeOf y- alignment ~(COORD x _) = alignment x- peek ptr = do- let ptr' = castPtr ptr :: Ptr SHORT- x <- peekElemOff ptr' 0- y <- peekElemOff ptr' 1- return (COORD x y)- poke ptr (COORD x y) = do- let ptr' = castPtr ptr :: Ptr SHORT- pokeElemOff ptr' 0 x- pokeElemOff ptr' 1 y--data SMALL_RECT = SMALL_RECT- { rect_top_left :: COORD- , rect_bottom_right :: COORD- }--rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT-rect_top = coord_y . rect_top_left-rect_left = coord_x . rect_top_left-rect_bottom = coord_y . rect_bottom_right-rect_right = coord_x . rect_bottom_right--rect_width, rect_height :: SMALL_RECT -> SHORT-rect_width rect = rect_right rect - rect_left rect + 1-rect_height rect = rect_bottom rect - rect_top rect + 1--instance Show SMALL_RECT where- show (SMALL_RECT tl br) = show tl ++ "-" ++ show br--instance Storable SMALL_RECT where- sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br- alignment ~(SMALL_RECT tl _) = alignment tl- peek ptr = do- let ptr' = castPtr ptr :: Ptr COORD- tl <- peekElemOff ptr' 0- br <- peekElemOff ptr' 1- return (SMALL_RECT tl br)- poke ptr (SMALL_RECT tl br) = do- let ptr' = castPtr ptr :: Ptr COORD- pokeElemOff ptr' 0 tl- pokeElemOff ptr' 1 br--data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO- { cci_cursor_size :: DWORD- , cci_cursor_visible :: BOOL- } deriving (Show)--instance Storable CONSOLE_CURSOR_INFO where- sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible- alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size- peek ptr = do- (size, ptr') <- peekAndOffset (castPtr ptr)- visible <- peek ptr'- return (CONSOLE_CURSOR_INFO size visible)- poke ptr (CONSOLE_CURSOR_INFO size visible) = do- ptr' <- pokeAndOffset (castPtr ptr) size- poke ptr' visible--data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO- { csbi_size :: COORD- , csbi_cursor_position :: COORD- , csbi_attributes :: WORD- , csbi_window :: SMALL_RECT- , csbi_maximum_window_size :: COORD- } deriving (Show)--instance Storable CONSOLE_SCREEN_BUFFER_INFO where- sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO- size cursor_position attributes window maximum_window_size)- = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window- + sizeOf maximum_window_size- alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size- peek ptr = do- (size, ptr1) <- peekAndOffset (castPtr ptr)- (cursor_position, ptr2) <- peekAndOffset ptr1- (attributes, ptr3) <- peekAndOffset ptr2- (window, ptr4) <- peekAndOffset ptr3- maximum_window_size <- peek ptr4- return (CONSOLE_SCREEN_BUFFER_INFO- size cursor_position attributes window maximum_window_size)- poke ptr (CONSOLE_SCREEN_BUFFER_INFO- size cursor_position attributes window maximum_window_size)- = do- ptr1 <- pokeAndOffset (castPtr ptr) size- ptr2 <- pokeAndOffset ptr1 cursor_position- ptr3 <- pokeAndOffset ptr2 attributes- ptr4 <- pokeAndOffset ptr3 window- poke ptr4 maximum_window_size--data CHAR_INFO = CHAR_INFO- { ci_char :: WCHAR- , ci_attributes :: WORD- } deriving (Show)--instance Storable CHAR_INFO where- sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes- alignment ~(CHAR_INFO char _) = alignment char- peek ptr = do- (char, ptr') <- peekAndOffset (castPtr ptr)- attributes <- peek ptr'- return (CHAR_INFO char attributes)- poke ptr (CHAR_INFO char attributes) = do- ptr' <- pokeAndOffset (castPtr ptr) char- poke ptr' attributes--eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD-sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD-eNABLE_VIRTUAL_TERMINAL_INPUT = 512-eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4-sTD_INPUT_HANDLE = 0xFFFFFFF6 -- minus 10-sTD_OUTPUT_HANDLE = 0xFFFFFFF5 -- minus 11-sTD_ERROR_HANDLE = 0xFFFFFFF4 -- minus 12--fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY,- bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY,- cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD-fOREGROUND_BLUE = 0x1-fOREGROUND_GREEN = 0x2-fOREGROUND_RED = 0x4-fOREGROUND_INTENSITY = 0x8-bACKGROUND_BLUE = 0x10-bACKGROUND_GREEN = 0x20-bACKGROUND_RED = 0x40-bACKGROUND_INTENSITY = 0x80-cOMMON_LVB_REVERSE_VIDEO = 0x4000-cOMMON_LVB_UNDERSCORE = 0x8000--fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE,- bACKGROUND_INTENSE_WHITE :: WORD-fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE-bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE-fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY-bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY--kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT,- fOCUS_EVENT :: WORD-kEY_EVENT = 1-mOUSE_EVENT = 2-wINDOW_BUFFER_SIZE_EVENT = 4-mENU_EVENT = 8-fOCUS_EVENT = 16--foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle"- getStdHandle :: DWORD -> IO HANDLE-foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo"- cGetConsoleScreenBufferInfo :: HANDLE- -> Ptr CONSOLE_SCREEN_BUFFER_INFO- -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo"- cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode"- cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute"- cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition"- cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo"- cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW"- cSetConsoleTitle :: LPCTSTR -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode"- cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute"- cFillConsoleOutputAttribute :: HANDLE- -> WORD- -> DWORD- -> UNPACKED_COORD- -> Ptr DWORD- -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW"- cFillConsoleOutputCharacter :: HANDLE- -> TCHAR- -> DWORD- -> UNPACKED_COORD- -> Ptr DWORD- -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW"- cScrollConsoleScreenBuffer :: HANDLE- -> Ptr SMALL_RECT- -> Ptr SMALL_RECT- -> UNPACKED_COORD- -> Ptr CHAR_INFO- -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW"- cWriteConsoleInput :: HANDLE- -> Ptr INPUT_RECORD- -> DWORD- -> LPDWORD- -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents"- cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL-foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW"- cReadConsoleInput :: HANDLE- -> Ptr INPUT_RECORD- -> DWORD- -> LPDWORD- -> IO BOOL--data ConsoleException = ConsoleException !ErrCode deriving (Show, Eq, Typeable)--instance Exception ConsoleException--throwIfFalse :: IO Bool -> IO ()-throwIfFalse action = do- succeeded <- action- if not succeeded- then getLastError >>= throw . ConsoleException -- TODO: Check if last error- -- is zero for some instructable reason (?)- else return ()--getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO-getConsoleScreenBufferInfo handle- = alloca $ \ptr_console_screen_buffer_info -> do- throwIfFalse $- cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info- peek ptr_console_screen_buffer_info--getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO-getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do- throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info- peek ptr_console_cursor_info--getConsoleMode :: HANDLE -> IO DWORD-getConsoleMode handle = alloca $ \ptr_mode -> do- throwIfFalse $ cGetConsoleMode handle ptr_mode- peek ptr_mode--setConsoleTextAttribute :: HANDLE -> WORD -> IO ()-setConsoleTextAttribute handle attributes- = throwIfFalse $ cSetConsoleTextAttribute handle attributes--setConsoleCursorPosition :: HANDLE -> COORD -> IO ()-setConsoleCursorPosition handle cursor_position- = throwIfFalse $ cSetConsoleCursorPosition handle- (unpackCOORD cursor_position)--setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO ()-setConsoleCursorInfo handle console_cursor_info- = with console_cursor_info $ \ptr_console_cursor_info -> do- throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info--setConsoleTitle :: LPCTSTR -> IO ()-setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title--setConsoleMode :: HANDLE -> DWORD -> IO ()-setConsoleMode handle attributes- = throwIfFalse $ cSetConsoleMode handle attributes--fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD-fillConsoleOutputAttribute handle attribute fill_length write_origin- = alloca $ \ptr_chars_written -> do- throwIfFalse $ cFillConsoleOutputAttribute handle attribute- fill_length (unpackCOORD write_origin) ptr_chars_written- peek ptr_chars_written--fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD-fillConsoleOutputCharacter handle char fill_length write_origin- = alloca $ \ptr_chars_written -> do- throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length- (unpackCOORD write_origin) ptr_chars_written- peek ptr_chars_written--scrollConsoleScreenBuffer :: HANDLE- -> SMALL_RECT- -> Maybe SMALL_RECT- -> COORD- -> CHAR_INFO- -> IO ()-scrollConsoleScreenBuffer- handle scroll_rectangle mb_clip_rectangle destination_origin fill- = with scroll_rectangle $ \ptr_scroll_rectangle ->- maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle ->- with fill $ \ptr_fill ->- throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle- ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill---- 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 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-- -- Get the FD from the algebraic data type-#if __GLASGOW_HASKELL__ < 612- 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-#endif-- -- Finally, turn that (C-land) FD into a HANDLE using msvcrt- windows_handle <- cget_osfhandle fd-- -- Do what the user originally wanted- action windows_handle---- This essential function comes from the C runtime system. It is certainly--- provided by msvcrt, and also seems to be provided by the mingw C library ---- hurrah!-#if __GLASGOW_HASKELL__ >= 612-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-#endif---- withStablePtr was added in Win32-2.5.1.0-withStablePtr :: a -> (StablePtr a -> IO b) -> IO b-withStablePtr value = bracket (newStablePtr value) freeStablePtr-#endif---- The following is based on module System.Win32.Console.Extra from package--- Win32-console, cut down for the WCHAR version of writeConsoleInput.--writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD-writeConsoleInput hdl evs- = writeConsoleInputWith hdl $ \act ->- withArrayLen evs $ \len ptr ->- act (ptr, toEnum len)--writeConsoleInputWith :: HANDLE- -> InputHandler (Ptr INPUT_RECORD, DWORD)- -> IO DWORD-writeConsoleInputWith hdl withBuffer- = returnWith_ $ \ptrN ->- withBuffer $ \(ptrBuf, len) ->- failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN--returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a-returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr--type InputHandler i = forall a. (i -> IO a) -> IO a--{--typedef union _UNICODE_ASCII_CHAR {- WCHAR UnicodeChar;- CHAR AsciiChar;-} UNICODE_ASCII_CHAR;--}-newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar- { unicodeAsciiChar :: WCHAR- } deriving (Show, Read, Eq)--instance Storable UNICODE_ASCII_CHAR where- sizeOf _ = 2- alignment _ = 2- peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr- poke ptr val = case val of- UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c--{--typedef struct _KEY_EVENT_RECORD {- BOOL bKeyDown;- WORD wRepeatCount;- WORD wVirtualKeyCode;- WORD wVirtualScanCode;- union {- WCHAR UnicodeChar;- CHAR AsciiChar;- } uChar;- DWORD dwControlKeyState;-}-#ifdef __GNUC__-/* gcc's alignment is not what win32 expects */- PACKED-#endif-KEY_EVENT_RECORD;--}-data KEY_EVENT_RECORD = KEY_EVENT_RECORD- { keyEventKeyDown :: BOOL- , keyEventRepeatCount :: WORD- , keyEventVirtualKeyCode :: WORD- , keyEventVirtualScanCode :: WORD- , keyEventChar :: UNICODE_ASCII_CHAR- , keyEventControlKeystate :: DWORD- } deriving (Show, Read, Eq)--instance Storable KEY_EVENT_RECORD where- sizeOf _ = 16- alignment _ = 4- peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr- <*> (`peekByteOff` 4) ptr- <*> (`peekByteOff` 6) ptr- <*> (`peekByteOff` 8) ptr- <*> (`peekByteOff` 10) ptr- <*> (`peekByteOff` 12) ptr- poke ptr val = do- (`pokeByteOff` 0) ptr $ keyEventKeyDown val- (`pokeByteOff` 4) ptr $ keyEventRepeatCount val- (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val- (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val- (`pokeByteOff` 10) ptr $ keyEventChar val- (`pokeByteOff` 12) ptr $ keyEventControlKeystate val--{--typedef struct _MOUSE_EVENT_RECORD {- COORD dwMousePosition;- DWORD dwButtonState;- DWORD dwControlKeyState;- DWORD dwEventFlags;-} MOUSE_EVENT_RECORD;--}-data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD- { mousePosition :: COORD- , mouseButtonState :: DWORD- , mouseControlKeyState :: DWORD- , mouseEventFlags :: DWORD- } deriving (Show, Read, Eq)--instance Storable MOUSE_EVENT_RECORD where- sizeOf _ = 16- alignment _ = 4- peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr- <*> (`peekByteOff` 4) ptr- <*> (`peekByteOff` 8) ptr- <*> (`peekByteOff` 12) ptr- poke ptr val = do- (`pokeByteOff` 0) ptr $ mousePosition val- (`pokeByteOff` 4) ptr $ mouseButtonState val- (`pokeByteOff` 8) ptr $ mouseControlKeyState val- (`pokeByteOff` 12) ptr $ mouseEventFlags val--{--typedef struct _WINDOW_BUFFER_SIZE_RECORD {- COORD dwSize;-} WINDOW_BUFFER_SIZE_RECORD;--}-data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD- { bufSizeNew :: COORD- } deriving (Show, Read, Eq)--instance Storable WINDOW_BUFFER_SIZE_RECORD where- sizeOf _ = 4- alignment _ = 4- peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr- poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val--{--typedef struct _MENU_EVENT_RECORD {- UINT dwCommandId;-} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD;--}-data MENU_EVENT_RECORD = MENU_EVENT_RECORD- { menuCommandId :: UINT- } deriving (Show, Read, Eq)--instance Storable MENU_EVENT_RECORD where- sizeOf _ = 4- alignment _ = 4- peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr- poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val--{--typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD;--}-data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD- { focusSetFocus :: BOOL- } deriving (Show, Read, Eq)--instance Storable FOCUS_EVENT_RECORD where- sizeOf _ = 4- alignment _ = 4- peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr- poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val--data INPUT_RECORD_EVENT- = InputKeyEvent KEY_EVENT_RECORD- | InputMouseEvent MOUSE_EVENT_RECORD- | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD- | InputMenuEvent MENU_EVENT_RECORD- | InputFocusEvent FOCUS_EVENT_RECORD- deriving (Show, Read, Eq)--{--typedef struct _INPUT_RECORD {- WORD EventType;- union {- KEY_EVENT_RECORD KeyEvent;- MOUSE_EVENT_RECORD MouseEvent;- WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent;- MENU_EVENT_RECORD MenuEvent;- FOCUS_EVENT_RECORD FocusEvent;- } Event;-} INPUT_RECORD,*PINPUT_RECORD;--}-data INPUT_RECORD = INPUT_RECORD- { inputEventType :: WORD- , inputEvent :: INPUT_RECORD_EVENT- } deriving (Show, Read, Eq)--instance Storable INPUT_RECORD where- sizeOf _ = 20- alignment _ = 4- peek ptr = do- evType <- (`peekByteOff` 0) ptr- event <- case evType of- _ | evType == kEY_EVENT- -> InputKeyEvent <$> (`peekByteOff` 4) ptr- _ | evType == mOUSE_EVENT- -> InputMouseEvent <$> (`peekByteOff` 4) ptr- _ | evType == wINDOW_BUFFER_SIZE_EVENT- -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr- _ | evType == mENU_EVENT- -> InputMenuEvent <$> (`peekByteOff` 4) ptr- _ | evType == fOCUS_EVENT- -> InputFocusEvent <$> (`peekByteOff` 4) ptr- _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++- show evType- return $ INPUT_RECORD evType event- poke ptr val = do- (`pokeByteOff` 0) ptr $ inputEventType val- case inputEvent val of- InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev- InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev- InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev- InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev- InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev---- The following is based on module System.Win32.Console.Extra from package--- Win32-console.--getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD-getNumberOfConsoleInputEvents hdl =- returnWith_ $ \ptrN ->- failIfFalse_ "GetNumberOfConsoleInputEvents" $- cGetNumberOfConsoleInputEvents hdl ptrN---- The following is based on module System.Win32.Console.Extra from package--- Win32-console, cut down for the WCHAR version of readConsoleInput.--readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD]-readConsoleInput hdl len- = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr--readConsoleInputWith :: HANDLE- -> DWORD- -> OutputHandler (Ptr INPUT_RECORD, DWORD)-readConsoleInputWith hdl len handler =- allocaArray (fromEnum len) $ \ptrBuf ->- alloca $ \ptrN -> do- failIfFalse_ "ReadConsoleInputW" $- cReadConsoleInput hdl ptrBuf len ptrN- n <- peek ptrN- handler (ptrBuf, n)--type OutputHandler o = forall a. (o -> IO a) -> IO a---- Replicated from module Foreign.C.String in package base because that module--- does not export the function.-cWcharsToChars :: [CWchar] -> [Char]-cWcharsToChars = map chr . fromUTF16 . map fromIntegral- where- fromUTF16 (c1:c2:wcs)- | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =- ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs- fromUTF16 (c:wcs) = c : fromUTF16 wcs- fromUTF16 [] = []+{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | "System.Win32.Console" is really very impoverished, so I have had to do all +-- the FFI myself. +module System.Console.ANSI.Windows.Foreign + ( + -- Re-exports from Win32.Types + BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, + + -- 'Re-exports from System.Win32.Console.Extra' + INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT, + KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput, + getNumberOfConsoleInputEvents, readConsoleInput, + + charToWCHAR, cWcharsToChars, + + COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, + rect_width, rect_height, CONSOLE_CURSOR_INFO(..), + CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), + + sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, + + eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, + + fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, + fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, + bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, + bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, + cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, + + getStdHandle, + getConsoleScreenBufferInfo, + getConsoleCursorInfo, + getConsoleMode, + + setConsoleTextAttribute, + setConsoleCursorPosition, + setConsoleCursorInfo, + setConsoleTitle, + setConsoleMode, + + fillConsoleOutputAttribute, + fillConsoleOutputCharacter, + scrollConsoleScreenBuffer, + + withTString, withHandleToHANDLE, + + ConsoleException (..) + ) where + +import Control.Exception (Exception, throw) +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 (readMVar) +import Control.Exception (bracket) +import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) +#if __GLASGOW_HASKELL__ >= 612 +import Data.Typeable (cast) +import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 +import GHC.IO.Handle.Types (Handle (..), Handle__ (..)) +#else +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 +#elif defined(x86_64_HOST_ARCH) +#define WINDOWS_CCONV ccall +#else +#error Unknown mingw32 arch +#endif + +-- Missing from System.Win32.Types prior to version 2.5.0.0 +#if !MIN_VERSION_Win32(2,5,0) +type SHORT = CShort +#endif +type WCHAR = CWchar + +charToWCHAR :: Char -> WCHAR +charToWCHAR char = fromIntegral (ord char) + +-- This is a FFI hack. Some of the API calls take a Coord, but that isn't a +-- built-in FFI type so I can't use it directly. Instead, I use UNPACKED_COORD +-- and marshal COORDs into this manually. Note that we CAN'T just use two SHORTs +-- directly because they get expanded to 4 bytes each instead of just boing 2 +-- lots of 2 bytes by the stdcall convention, so linking fails. +type UNPACKED_COORD = CInt + +-- Field packing order determined experimentally: I couldn't immediately find a +-- specification for Windows struct layout anywhere. +unpackCOORD :: COORD -> UNPACKED_COORD +unpackCOORD (COORD x y) + = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) + + +peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) +peekAndOffset ptr = do + item <- peek ptr + return (item, ptr `plusPtr` sizeOf item) + +pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) +pokeAndOffset ptr item = do + poke ptr item + return (ptr `plusPtr` sizeOf item) + +data COORD = COORD + { coord_x :: SHORT + , coord_y :: SHORT + } deriving (Read, Eq) + +instance Show COORD where + show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" + +instance Storable COORD where + sizeOf ~(COORD x y) = sizeOf x + sizeOf y + alignment ~(COORD x _) = alignment x + peek ptr = do + let ptr' = castPtr ptr :: Ptr SHORT + x <- peekElemOff ptr' 0 + y <- peekElemOff ptr' 1 + return (COORD x y) + poke ptr (COORD x y) = do + let ptr' = castPtr ptr :: Ptr SHORT + pokeElemOff ptr' 0 x + pokeElemOff ptr' 1 y + +data SMALL_RECT = SMALL_RECT + { rect_top_left :: COORD + , rect_bottom_right :: COORD + } + +rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT +rect_top = coord_y . rect_top_left +rect_left = coord_x . rect_top_left +rect_bottom = coord_y . rect_bottom_right +rect_right = coord_x . rect_bottom_right + +rect_width, rect_height :: SMALL_RECT -> SHORT +rect_width rect = rect_right rect - rect_left rect + 1 +rect_height rect = rect_bottom rect - rect_top rect + 1 + +instance Show SMALL_RECT where + show (SMALL_RECT tl br) = show tl ++ "-" ++ show br + +instance Storable SMALL_RECT where + sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br + alignment ~(SMALL_RECT tl _) = alignment tl + peek ptr = do + let ptr' = castPtr ptr :: Ptr COORD + tl <- peekElemOff ptr' 0 + br <- peekElemOff ptr' 1 + return (SMALL_RECT tl br) + poke ptr (SMALL_RECT tl br) = do + let ptr' = castPtr ptr :: Ptr COORD + pokeElemOff ptr' 0 tl + pokeElemOff ptr' 1 br + +data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO + { cci_cursor_size :: DWORD + , cci_cursor_visible :: BOOL + } deriving (Show) + +instance Storable CONSOLE_CURSOR_INFO where + sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible + alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size + peek ptr = do + (size, ptr') <- peekAndOffset (castPtr ptr) + visible <- peek ptr' + return (CONSOLE_CURSOR_INFO size visible) + poke ptr (CONSOLE_CURSOR_INFO size visible) = do + ptr' <- pokeAndOffset (castPtr ptr) size + poke ptr' visible + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO + { csbi_size :: COORD + , csbi_cursor_position :: COORD + , csbi_attributes :: WORD + , csbi_window :: SMALL_RECT + , csbi_maximum_window_size :: COORD + } deriving (Show) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + + sizeOf maximum_window_size + alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size + peek ptr = do + (size, ptr1) <- peekAndOffset (castPtr ptr) + (cursor_position, ptr2) <- peekAndOffset ptr1 + (attributes, ptr3) <- peekAndOffset ptr2 + (window, ptr4) <- peekAndOffset ptr3 + maximum_window_size <- peek ptr4 + return (CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + poke ptr (CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + = do + ptr1 <- pokeAndOffset (castPtr ptr) size + ptr2 <- pokeAndOffset ptr1 cursor_position + ptr3 <- pokeAndOffset ptr2 attributes + ptr4 <- pokeAndOffset ptr3 window + poke ptr4 maximum_window_size + +data CHAR_INFO = CHAR_INFO + { ci_char :: WCHAR + , ci_attributes :: WORD + } deriving (Show) + +instance Storable CHAR_INFO where + sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes + alignment ~(CHAR_INFO char _) = alignment char + peek ptr = do + (char, ptr') <- peekAndOffset (castPtr ptr) + attributes <- peek ptr' + return (CHAR_INFO char attributes) + poke ptr (CHAR_INFO char attributes) = do + ptr' <- pokeAndOffset (castPtr ptr) char + poke ptr' attributes + +eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD +sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD +eNABLE_VIRTUAL_TERMINAL_INPUT = 512 +eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 +sTD_INPUT_HANDLE = 0xFFFFFFF6 -- minus 10 +sTD_OUTPUT_HANDLE = 0xFFFFFFF5 -- minus 11 +sTD_ERROR_HANDLE = 0xFFFFFFF4 -- minus 12 + +fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, + bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, + cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD +fOREGROUND_BLUE = 0x1 +fOREGROUND_GREEN = 0x2 +fOREGROUND_RED = 0x4 +fOREGROUND_INTENSITY = 0x8 +bACKGROUND_BLUE = 0x10 +bACKGROUND_GREEN = 0x20 +bACKGROUND_RED = 0x40 +bACKGROUND_INTENSITY = 0x80 +cOMMON_LVB_REVERSE_VIDEO = 0x4000 +cOMMON_LVB_UNDERSCORE = 0x8000 + +fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, + bACKGROUND_INTENSE_WHITE :: WORD +fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE +bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE +fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY +bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY + +kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, + fOCUS_EVENT :: WORD +kEY_EVENT = 1 +mOUSE_EVENT = 2 +wINDOW_BUFFER_SIZE_EVENT = 4 +mENU_EVENT = 8 +fOCUS_EVENT = 16 + +foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" + getStdHandle :: DWORD -> IO HANDLE +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" + cGetConsoleScreenBufferInfo :: HANDLE + -> Ptr CONSOLE_SCREEN_BUFFER_INFO + -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" + cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" + cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute" + cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition" + cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo" + cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW" + cSetConsoleTitle :: LPCTSTR -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" + cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute" + cFillConsoleOutputAttribute :: HANDLE + -> WORD + -> DWORD + -> UNPACKED_COORD + -> Ptr DWORD + -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" + cFillConsoleOutputCharacter :: HANDLE + -> TCHAR + -> DWORD + -> UNPACKED_COORD + -> Ptr DWORD + -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" + cScrollConsoleScreenBuffer :: HANDLE + -> Ptr SMALL_RECT + -> Ptr SMALL_RECT + -> UNPACKED_COORD + -> Ptr CHAR_INFO + -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW" + cWriteConsoleInput :: HANDLE + -> Ptr INPUT_RECORD + -> DWORD + -> LPDWORD + -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents" + cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" + cReadConsoleInput :: HANDLE + -> Ptr INPUT_RECORD + -> DWORD + -> LPDWORD + -> IO BOOL + +data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) + +instance Show ConsoleException where + show (ConsoleException 6) = + "A fatal error has occurred.\n\n" ++ + "An attempt has been made to send console virtual terminal sequences\n" ++ + "(ANSI codes) to an output that has not been recognised as an\n" ++ + "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ + "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ + "Prompt or PowerShell). That may occur, for example, if output has\n" ++ + "been redirected to a file.\n\n" ++ + "If that is unexpected, please post an issue at:\n" ++ + "https://github.com/feuerbach/ansi-terminal/issues\n" + show (ConsoleException errCode) = "ConsoleException " ++ show errCode + +instance Exception ConsoleException + +throwIfFalse :: IO Bool -> IO () +throwIfFalse action = do + succeeded <- action + if not succeeded + then getLastError >>= throw . ConsoleException -- TODO: Check if last error + -- is zero for some instructable reason (?) + else return () + +getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO +getConsoleScreenBufferInfo handle + = alloca $ \ptr_console_screen_buffer_info -> do + throwIfFalse $ + cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info + peek ptr_console_screen_buffer_info + +getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO +getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do + throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info + peek ptr_console_cursor_info + +getConsoleMode :: HANDLE -> IO DWORD +getConsoleMode handle = alloca $ \ptr_mode -> do + throwIfFalse $ cGetConsoleMode handle ptr_mode + peek ptr_mode + +setConsoleTextAttribute :: HANDLE -> WORD -> IO () +setConsoleTextAttribute handle attributes + = throwIfFalse $ cSetConsoleTextAttribute handle attributes + +setConsoleCursorPosition :: HANDLE -> COORD -> IO () +setConsoleCursorPosition handle cursor_position + = throwIfFalse $ cSetConsoleCursorPosition handle + (unpackCOORD cursor_position) + +setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () +setConsoleCursorInfo handle console_cursor_info + = with console_cursor_info $ \ptr_console_cursor_info -> do + throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info + +setConsoleTitle :: LPCTSTR -> IO () +setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title + +setConsoleMode :: HANDLE -> DWORD -> IO () +setConsoleMode handle attributes + = throwIfFalse $ cSetConsoleMode handle attributes + +fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD +fillConsoleOutputAttribute handle attribute fill_length write_origin + = alloca $ \ptr_chars_written -> do + throwIfFalse $ cFillConsoleOutputAttribute handle attribute + fill_length (unpackCOORD write_origin) ptr_chars_written + peek ptr_chars_written + +fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD +fillConsoleOutputCharacter handle char fill_length write_origin + = alloca $ \ptr_chars_written -> do + throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length + (unpackCOORD write_origin) ptr_chars_written + peek ptr_chars_written + +scrollConsoleScreenBuffer :: HANDLE + -> SMALL_RECT + -> Maybe SMALL_RECT + -> COORD + -> CHAR_INFO + -> IO () +scrollConsoleScreenBuffer + handle scroll_rectangle mb_clip_rectangle destination_origin fill + = with scroll_rectangle $ \ptr_scroll_rectangle -> + maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> + with fill $ \ptr_fill -> + throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle + ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill + +-- 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 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 + + -- Get the FD from the algebraic data type +#if __GLASGOW_HASKELL__ < 612 + 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 +#endif + + -- Finally, turn that (C-land) FD into a HANDLE using msvcrt + windows_handle <- cget_osfhandle fd + + -- Do what the user originally wanted + action windows_handle + +-- This essential function comes from the C runtime system. It is certainly +-- provided by msvcrt, and also seems to be provided by the mingw C library - +-- hurrah! +#if __GLASGOW_HASKELL__ >= 612 +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 +#endif + +-- withStablePtr was added in Win32-2.5.1.0 +withStablePtr :: a -> (StablePtr a -> IO b) -> IO b +withStablePtr value = bracket (newStablePtr value) freeStablePtr +#endif + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console, cut down for the WCHAR version of writeConsoleInput. + +writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD +writeConsoleInput hdl evs + = writeConsoleInputWith hdl $ \act -> + withArrayLen evs $ \len ptr -> + act (ptr, toEnum len) + +writeConsoleInputWith :: HANDLE + -> InputHandler (Ptr INPUT_RECORD, DWORD) + -> IO DWORD +writeConsoleInputWith hdl withBuffer + = returnWith_ $ \ptrN -> + withBuffer $ \(ptrBuf, len) -> + failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN + +returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a +returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr + +type InputHandler i = forall a. (i -> IO a) -> IO a + +{- +typedef union _UNICODE_ASCII_CHAR { + WCHAR UnicodeChar; + CHAR AsciiChar; +} UNICODE_ASCII_CHAR; +-} +newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar + { unicodeAsciiChar :: WCHAR + } deriving (Show, Read, Eq) + +instance Storable UNICODE_ASCII_CHAR where + sizeOf _ = 2 + alignment _ = 2 + peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr + poke ptr val = case val of + UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c + +{- +typedef struct _KEY_EVENT_RECORD { + BOOL bKeyDown; + WORD wRepeatCount; + WORD wVirtualKeyCode; + WORD wVirtualScanCode; + union { + WCHAR UnicodeChar; + CHAR AsciiChar; + } uChar; + DWORD dwControlKeyState; +} +#ifdef __GNUC__ +/* gcc's alignment is not what win32 expects */ + PACKED +#endif +KEY_EVENT_RECORD; +-} +data KEY_EVENT_RECORD = KEY_EVENT_RECORD + { keyEventKeyDown :: BOOL + , keyEventRepeatCount :: WORD + , keyEventVirtualKeyCode :: WORD + , keyEventVirtualScanCode :: WORD + , keyEventChar :: UNICODE_ASCII_CHAR + , keyEventControlKeystate :: DWORD + } deriving (Show, Read, Eq) + +instance Storable KEY_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 6) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 10) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ keyEventKeyDown val + (`pokeByteOff` 4) ptr $ keyEventRepeatCount val + (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val + (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val + (`pokeByteOff` 10) ptr $ keyEventChar val + (`pokeByteOff` 12) ptr $ keyEventControlKeystate val + +{- +typedef struct _MOUSE_EVENT_RECORD { + COORD dwMousePosition; + DWORD dwButtonState; + DWORD dwControlKeyState; + DWORD dwEventFlags; +} MOUSE_EVENT_RECORD; +-} +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD + { mousePosition :: COORD + , mouseButtonState :: DWORD + , mouseControlKeyState :: DWORD + , mouseEventFlags :: DWORD + } deriving (Show, Read, Eq) + +instance Storable MOUSE_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ mousePosition val + (`pokeByteOff` 4) ptr $ mouseButtonState val + (`pokeByteOff` 8) ptr $ mouseControlKeyState val + (`pokeByteOff` 12) ptr $ mouseEventFlags val + +{- +typedef struct _WINDOW_BUFFER_SIZE_RECORD { + COORD dwSize; +} WINDOW_BUFFER_SIZE_RECORD; +-} +data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD + { bufSizeNew :: COORD + } deriving (Show, Read, Eq) + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val + +{- +typedef struct _MENU_EVENT_RECORD { + UINT dwCommandId; +} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; +-} +data MENU_EVENT_RECORD = MENU_EVENT_RECORD + { menuCommandId :: UINT + } deriving (Show, Read, Eq) + +instance Storable MENU_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val + +{- +typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; +-} +data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD + { focusSetFocus :: BOOL + } deriving (Show, Read, Eq) + +instance Storable FOCUS_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val + +data INPUT_RECORD_EVENT + = InputKeyEvent KEY_EVENT_RECORD + | InputMouseEvent MOUSE_EVENT_RECORD + | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | InputMenuEvent MENU_EVENT_RECORD + | InputFocusEvent FOCUS_EVENT_RECORD + deriving (Show, Read, Eq) + +{- +typedef struct _INPUT_RECORD { + WORD EventType; + union { + KEY_EVENT_RECORD KeyEvent; + MOUSE_EVENT_RECORD MouseEvent; + WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; + MENU_EVENT_RECORD MenuEvent; + FOCUS_EVENT_RECORD FocusEvent; + } Event; +} INPUT_RECORD,*PINPUT_RECORD; +-} +data INPUT_RECORD = INPUT_RECORD + { inputEventType :: WORD + , inputEvent :: INPUT_RECORD_EVENT + } deriving (Show, Read, Eq) + +instance Storable INPUT_RECORD where + sizeOf _ = 20 + alignment _ = 4 + peek ptr = do + evType <- (`peekByteOff` 0) ptr + event <- case evType of + _ | evType == kEY_EVENT + -> InputKeyEvent <$> (`peekByteOff` 4) ptr + _ | evType == mOUSE_EVENT + -> InputMouseEvent <$> (`peekByteOff` 4) ptr + _ | evType == wINDOW_BUFFER_SIZE_EVENT + -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr + _ | evType == mENU_EVENT + -> InputMenuEvent <$> (`peekByteOff` 4) ptr + _ | evType == fOCUS_EVENT + -> InputFocusEvent <$> (`peekByteOff` 4) ptr + _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ + show evType + return $ INPUT_RECORD evType event + poke ptr val = do + (`pokeByteOff` 0) ptr $ inputEventType val + case inputEvent val of + InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev + InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev + InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev + InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev + InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console. + +getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD +getNumberOfConsoleInputEvents hdl = + returnWith_ $ \ptrN -> + failIfFalse_ "GetNumberOfConsoleInputEvents" $ + cGetNumberOfConsoleInputEvents hdl ptrN + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console, cut down for the WCHAR version of readConsoleInput. + +readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] +readConsoleInput hdl len + = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr + +readConsoleInputWith :: HANDLE + -> DWORD + -> OutputHandler (Ptr INPUT_RECORD, DWORD) +readConsoleInputWith hdl len handler = + allocaArray (fromEnum len) $ \ptrBuf -> + alloca $ \ptrN -> do + failIfFalse_ "ReadConsoleInputW" $ + cReadConsoleInput hdl ptrBuf len ptrN + n <- peek ptrN + handler (ptrBuf, n) + +type OutputHandler o = forall a. (o -> IO a) -> IO a + +-- Replicated from module Foreign.C.String in package base because that module +-- does not export the function. +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = []
ansi-terminal.cabal view
@@ -1,94 +1,94 @@-Name: ansi-terminal-Version: 0.8-Cabal-Version: >= 1.6-Category: User Interfaces-Synopsis: Simple ANSI terminal support, with Windows compatibility-Description: ANSI terminal support for Haskell: allows cursor movement,- screen clearing, color output, showing or hiding the- cursor, and changing the title. Works on UNIX and Windows.-License: BSD3-License-File: LICENSE-Author: Max Bolingbroke-Maintainer: Roman Cheplyaka <roma@ro-che.info>-Homepage: https://github.com/feuerbach/ansi-terminal-Build-Type: Simple--Extra-Source-Files: includes/Common-Include.hs- includes/Common-Include-Emulator.hs- includes/Common-Include-Enabled.hs- includes/Exports-Include.hs- CHANGELOG.md- README.md--Source-repository head- type: git- location: git://github.com/feuerbach/ansi-terminal.git--Flag Example- Description: Build the example application- Default: False--Library- Exposed-Modules: System.Console.ANSI- System.Console.ANSI.Types- System.Console.ANSI.Codes-- Include-Dirs: includes-- Build-Depends: base >= 4 && < 5- , colour- if os(windows)- Build-Depends: base-compat >= 0.9.1- , containers- , Win32 >= 2.0- , process- Cpp-Options: -DWINDOWS- Other-Modules: System.Console.ANSI.Windows- System.Console.ANSI.Windows.Detect- System.Console.ANSI.Windows.Emulator- System.Console.ANSI.Windows.Emulator.Codes- System.Console.ANSI.Windows.Foreign- -- NB: used for fallback by the emulator- System.Console.ANSI.Unix- else- -- We assume any non-Windows platform is Unix- Cpp-Options: -DUNIX- Other-Modules: System.Console.ANSI.Unix-- Extensions: CPP- ForeignFunctionInterface-- Ghc-Options: -Wall--Executable ansi-terminal-example- Main-Is: System/Console/ANSI/Example.hs-- Include-Dirs: includes-- Other-Modules: System.Console.ANSI- System.Console.ANSI.Codes- System.Console.ANSI.Types- System.Console.ANSI.Unix-- if os(windows)- Build-Depends: base-compat >= 0.9.1- , containers- , Win32 >= 2.0- Cpp-Options: -DWINDOWS- Other-Modules: System.Console.ANSI.Windows- System.Console.ANSI.Windows.Detect- System.Console.ANSI.Windows.Emulator- System.Console.ANSI.Windows.Emulator.Codes- System.Console.ANSI.Windows.Foreign- else- -- We assume any non-Windows platform is Unix- Cpp-Options: -DUNIX-- Build-Depends: base >= 4 && < 5- Extensions: CPP- ForeignFunctionInterface-- Ghc-Options: -Wall-- if !flag(example)- Buildable: False+Name: ansi-terminal +Version: 0.8.0.1 +Cabal-Version: >= 1.6 +Category: User Interfaces +Synopsis: Simple ANSI terminal support, with Windows compatibility +Description: ANSI terminal support for Haskell: allows cursor movement, + screen clearing, color output, showing or hiding the + cursor, and changing the title. Works on UNIX and Windows. +License: BSD3 +License-File: LICENSE +Author: Max Bolingbroke +Maintainer: Mike Pilgrem <public@pilgrem.com>, Roman Cheplyaka <roma@ro-che.info> +Homepage: https://github.com/feuerbach/ansi-terminal +Build-Type: Simple + +Extra-Source-Files: includes/Common-Include.hs + includes/Common-Include-Emulator.hs + includes/Common-Include-Enabled.hs + includes/Exports-Include.hs + CHANGELOG.md + README.md + +Source-repository head + type: git + location: git://github.com/feuerbach/ansi-terminal.git + +Flag Example + Description: Build the example application + Default: False + +Library + Exposed-Modules: System.Console.ANSI + System.Console.ANSI.Types + System.Console.ANSI.Codes + + Include-Dirs: includes + + Build-Depends: base >= 4 && < 5 + , colour + if os(windows) + Build-Depends: base-compat >= 0.9.1 + , containers + , Win32 >= 2.0 + , process + Cpp-Options: -DWINDOWS + Other-Modules: System.Console.ANSI.Windows + System.Console.ANSI.Windows.Detect + System.Console.ANSI.Windows.Emulator + System.Console.ANSI.Windows.Emulator.Codes + System.Console.ANSI.Windows.Foreign + -- NB: used for fallback by the emulator + System.Console.ANSI.Unix + else + -- We assume any non-Windows platform is Unix + Cpp-Options: -DUNIX + Other-Modules: System.Console.ANSI.Unix + + Extensions: CPP + ForeignFunctionInterface + + Ghc-Options: -Wall + +Executable ansi-terminal-example + Main-Is: System/Console/ANSI/Example.hs + + Include-Dirs: includes + + Other-Modules: System.Console.ANSI + System.Console.ANSI.Codes + System.Console.ANSI.Types + System.Console.ANSI.Unix + + if os(windows) + Build-Depends: base-compat >= 0.9.1 + , containers + , Win32 >= 2.0 + Cpp-Options: -DWINDOWS + Other-Modules: System.Console.ANSI.Windows + System.Console.ANSI.Windows.Detect + System.Console.ANSI.Windows.Emulator + System.Console.ANSI.Windows.Emulator.Codes + System.Console.ANSI.Windows.Foreign + else + -- We assume any non-Windows platform is Unix + Cpp-Options: -DUNIX + + Build-Depends: base >= 4 && < 5 + Extensions: CPP + ForeignFunctionInterface + + Ghc-Options: -Wall + + if !flag(example) + Buildable: False
includes/Common-Include-Emulator.hs view
@@ -1,65 +1,65 @@--- This file contains code that is required in the case of the module--- System.Console.ANSI.Windows.Emulator and differs from the common code in--- file Common-Include-Enabled.hs.---- | Set the Select Graphic Rendition mode-hSetSGR- :: ConsoleDefaultState -- ^ The default console state- -> Handle- -> [SGR] -- ^ Commands: these will typically be applied on top of the- -- current console SGR mode. An empty list of commands is- -- equivalent to the list @[Reset]@. Commands are applied left to- -- right.- -> IO ()---- | Set the Select Graphic Rendition mode-setSGR- :: ConsoleDefaultState -- ^ The default console state- -> [SGR] -- ^ Commands: these will typically be applied on top of the- -- current console SGR mode. An empty list of commands is- -- equivalent to the list @[Reset]@. Commands are applied left to- -- right.- -> IO ()-setSGR def = hSetSGR def stdout--hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen- :: ConsoleDefaultState -- ^ The default console state- -> Handle- -> IO ()--clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen- :: ConsoleDefaultState -- ^ The default console state- -> IO ()-clearFromCursorToScreenEnd def = hClearFromCursorToScreenEnd def stdout-clearFromCursorToScreenBeginning def- = hClearFromCursorToScreenBeginning def stdout-clearScreen def = hClearScreen def stdout--hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine- :: ConsoleDefaultState -- ^ The default console state- -> Handle- -> IO ()--clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine- :: ConsoleDefaultState -- ^ The default console state- -> IO ()-clearFromCursorToLineEnd def = hClearFromCursorToLineEnd def stdout-clearFromCursorToLineBeginning def = hClearFromCursorToLineBeginning def stdout-clearLine def = hClearLine def stdout---- | Scroll the displayed information up or down the terminal: not widely--- supported-hScrollPageUp, hScrollPageDown- :: ConsoleDefaultState -- ^ The default console state- -> Handle- -> Int -- ^ Number of lines to scroll by- -> IO ()---- | Scroll the displayed information up or down the terminal: not widely--- supported-scrollPageUp, scrollPageDown- :: ConsoleDefaultState -- ^ The default console state- -> Int -- ^ Number of lines to scroll by- -> IO ()-scrollPageUp def = hScrollPageUp def stdout-scrollPageDown def = hScrollPageDown def stdout+-- This file contains code that is required in the case of the module +-- System.Console.ANSI.Windows.Emulator and differs from the common code in +-- file Common-Include-Enabled.hs. + +-- | Set the Select Graphic Rendition mode +hSetSGR + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> [SGR] -- ^ Commands: these will typically be applied on top of the + -- current console SGR mode. An empty list of commands is + -- equivalent to the list @[Reset]@. Commands are applied left to + -- right. + -> IO () + +-- | Set the Select Graphic Rendition mode +setSGR + :: ConsoleDefaultState -- ^ The default console state + -> [SGR] -- ^ Commands: these will typically be applied on top of the + -- current console SGR mode. An empty list of commands is + -- equivalent to the list @[Reset]@. Commands are applied left to + -- right. + -> IO () +setSGR def = hSetSGR def stdout + +hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> IO () + +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen + :: ConsoleDefaultState -- ^ The default console state + -> IO () +clearFromCursorToScreenEnd def = hClearFromCursorToScreenEnd def stdout +clearFromCursorToScreenBeginning def + = hClearFromCursorToScreenBeginning def stdout +clearScreen def = hClearScreen def stdout + +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> IO () + +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine + :: ConsoleDefaultState -- ^ The default console state + -> IO () +clearFromCursorToLineEnd def = hClearFromCursorToLineEnd def stdout +clearFromCursorToLineBeginning def = hClearFromCursorToLineBeginning def stdout +clearLine def = hClearLine def stdout + +-- | Scroll the displayed information up or down the terminal: not widely +-- supported +hScrollPageUp, hScrollPageDown + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> Int -- ^ Number of lines to scroll by + -> IO () + +-- | Scroll the displayed information up or down the terminal: not widely +-- supported +scrollPageUp, scrollPageDown + :: ConsoleDefaultState -- ^ The default console state + -> Int -- ^ Number of lines to scroll by + -> IO () +scrollPageUp def = hScrollPageUp def stdout +scrollPageDown def = hScrollPageDown def stdout
includes/Common-Include-Enabled.hs view
@@ -1,56 +1,56 @@--- This file contains code that is common save that different code is required--- in the case of the module System.Console.ANSI.Windows.Emulator (see the file--- Common-Include-Emulator.hs in respect of the latter).---- | Set the Select Graphic Rendition mode-hSetSGR- :: Handle- -> [SGR] -- ^ Commands: these will typically be applied on top of the- -- current console SGR mode. An empty list of commands is- -- equivalent to the list @[Reset]@. Commands are applied left to- -- right.- -> IO ()---- | Set the Select Graphic Rendition mode-setSGR- :: [SGR] -- ^ Commands: these will typically be applied on top of the- -- current console SGR mode. An empty list of commands is- -- equivalent to the list @[Reset]@. Commands are applied left to- -- right.- -> IO ()-setSGR = hSetSGR stdout--hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen- :: Handle- -> IO ()--clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen- :: IO ()-clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout-clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout-clearScreen = hClearScreen stdout--hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine- :: Handle- -> IO ()--clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine- :: IO ()-clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout-clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout-clearLine = hClearLine stdout---- | Scroll the displayed information up or down the terminal: not widely--- supported-hScrollPageUp, hScrollPageDown- :: Handle- -> Int -- ^ Number of lines to scroll by- -> IO ()---- | Scroll the displayed information up or down the terminal: not widely--- supported-scrollPageUp, scrollPageDown- :: Int -- ^ Number of lines to scroll by- -> IO ()-scrollPageUp = hScrollPageUp stdout-scrollPageDown = hScrollPageDown stdout+-- This file contains code that is common save that different code is required +-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file +-- Common-Include-Emulator.hs in respect of the latter). + +-- | Set the Select Graphic Rendition mode +hSetSGR + :: Handle + -> [SGR] -- ^ Commands: these will typically be applied on top of the + -- current console SGR mode. An empty list of commands is + -- equivalent to the list @[Reset]@. Commands are applied left to + -- right. + -> IO () + +-- | Set the Select Graphic Rendition mode +setSGR + :: [SGR] -- ^ Commands: these will typically be applied on top of the + -- current console SGR mode. An empty list of commands is + -- equivalent to the list @[Reset]@. Commands are applied left to + -- right. + -> IO () +setSGR = hSetSGR stdout + +hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen + :: Handle + -> IO () + +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen + :: IO () +clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout +clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout +clearScreen = hClearScreen stdout + +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine + :: Handle + -> IO () + +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine + :: IO () +clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout +clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout +clearLine = hClearLine stdout + +-- | Scroll the displayed information up or down the terminal: not widely +-- supported +hScrollPageUp, hScrollPageDown + :: Handle + -> Int -- ^ Number of lines to scroll by + -> IO () + +-- | Scroll the displayed information up or down the terminal: not widely +-- supported +scrollPageUp, scrollPageDown + :: Int -- ^ Number of lines to scroll by + -> IO () +scrollPageUp = hScrollPageUp stdout +scrollPageDown = hScrollPageDown stdout
includes/Common-Include.hs view
@@ -1,164 +1,164 @@--- This file contains code that is common to modules System.Console.ANSI.Unix,--- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as--- type signatures and the definition of functions specific to stdout in terms--- of the corresponding more general functions, inclduding the related Haddock--- documentation.--import System.Environment-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--import Control.Monad (void)-import Data.Char (isDigit)-import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy)--hCursorUp, hCursorDown, hCursorForward, hCursorBackward- :: Handle- -> Int -- ^ Number of lines or characters to move- -> IO ()-cursorUp, cursorDown, cursorForward, cursorBackward- :: Int -- ^ Number of lines or characters to move- -> IO ()-cursorUp = hCursorUp stdout-cursorDown = hCursorDown stdout-cursorForward = hCursorForward stdout-cursorBackward = hCursorBackward stdout--hCursorDownLine, hCursorUpLine :: Handle- -> Int -- ^ Number of lines to move- -> IO ()-cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move- -> IO ()-cursorDownLine = hCursorDownLine stdout-cursorUpLine = hCursorUpLine stdout--hSetCursorColumn :: Handle- -> Int -- ^ 0-based column to move to- -> IO ()-setCursorColumn :: Int -- ^ 0-based column to move to- -> IO ()-setCursorColumn = hSetCursorColumn stdout--hSetCursorPosition :: Handle- -> Int -- ^ 0-based row to move to- -> Int -- ^ 0-based column to move to- -> IO ()-setCursorPosition :: Int -- ^ 0-based row to move to- -> Int -- ^ 0-based column to move to- -> IO ()-setCursorPosition = hSetCursorPosition stdout--hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO ()---- | Save the cursor position in memory. The only way to access the saved value--- is with the 'restoreCursor' command.-saveCursor :: IO ()--- | Restore the cursor position from memory. There will be no value saved in--- memory until the first use of the 'saveCursor' command.-restoreCursor :: IO ()--- | Looking for a way to get the cursors position? See--- 'getCursorPosition'.------ Emit the cursor position into the console input stream, immediately after--- being recognised on the output stream, as:--- @ESC [ \<cursor row> ; \<cursor column> R@------ In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this--- function may be of limited use on Windows operating systems because of--- difficulties in obtaining the data emitted into the console input stream.--- The function 'hGetBufNonBlocking' in module "System.IO" does not work on--- Windows. This has been attributed to the lack of non-blocking primatives in--- the operating system (see the GHC bug report #806 at--- <https://ghc.haskell.org/trac/ghc/ticket/806>).-reportCursorPosition :: IO ()--saveCursor = hSaveCursor stdout-restoreCursor = hRestoreCursor stdout-reportCursorPosition = hReportCursorPosition stdout--hHideCursor, hShowCursor :: Handle- -> IO ()-hideCursor, showCursor :: IO ()-hideCursor = hHideCursor stdout-showCursor = hShowCursor stdout---- | Set the terminal window title-hSetTitle :: Handle- -> String -- ^ New title- -> IO ()--- | Set the terminal window title-setTitle :: String -- ^ New title- -> IO ()-setTitle = hSetTitle stdout---- | Use heuristics to determine whether the functions defined in this--- package will work with a given handle.------ The current implementation checks that the handle is a terminal, and--- that the @TERM@ environment variable doesn't say @dumb@ (which is what--- Emacs sets for its own terminal).-hSupportsANSI :: Handle -> IO Bool--- 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---- | Parses the characters emitted by 'reportCursorPosition' into the console--- input stream. Returns the cursor row and column as a tuple.------ For example, if the characters emitted by 'reportCursorPosition' are in--- 'String' @input@ then the parser could be applied like this:------ > let result = readP_to_S cursorPosition input--- > case result of--- > [] -> putStrLn $ "Error: could not parse " ++ show input--- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row--- > ++ " and column" ++ show column ++ "."--- > (_:_) -> putStrLn $ "Error: parse not unique"----cursorPosition :: ReadP (Int, Int)-cursorPosition = do- void $ char '\ESC'- void $ char '['- row <- decimal -- A non-negative whole decimal number- void $ char ';'- col <- decimal -- A non-negative whole decimal number- void $ char 'R'- return (read row, read col)- where- digit = satisfy isDigit- decimal = many1 digit---- | Attempts to get the reported cursor position data from the console input--- stream. The function is intended to be called immediately after--- 'reportCursorPosition' (or related functions) have caused characters to be--- emitted into the stream.------ For example, on a Unix-like operating system:------ > hSetBuffering stdin NoBuffering -- set no buffering (the contents of the--- > -- buffer will be discarded, so this needs--- > -- to be done before the cursor positon is--- > -- emitted)--- > reportCursorPosition--- > hFlush stdout -- ensure the report cursor position code is sent to the--- > -- operating system--- > input <- getReportedCursorPosition------ On Windows operating systems, the function is not supported on consoles, such--- as mintty, that are not based on the Win32 console of the Windows API.--- (Command Prompt and PowerShell are based on the Win32 console.)-getReportedCursorPosition :: IO String---- | Attempts to get the reported cursor position, combining the functions--- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'.--- Returns 'Nothing' if any data emitted by 'reportCursorPosition', obtained by--- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'.------ On Windows operating systems, the function is not supported on consoles, such--- as mintty, that are not based on the Win32 console of the Windows API.--- (Command Prompt and PowerShell are based on the Win32 console.)-getCursorPosition :: IO (Maybe (Int, Int))+-- This file contains code that is common to modules System.Console.ANSI.Unix, +-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as +-- type signatures and the definition of functions specific to stdout in terms +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. + +import System.Environment +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Control.Monad (void) +import Data.Char (isDigit) +import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy) + +hCursorUp, hCursorDown, hCursorForward, hCursorBackward + :: Handle + -> Int -- ^ Number of lines or characters to move + -> IO () +cursorUp, cursorDown, cursorForward, cursorBackward + :: Int -- ^ Number of lines or characters to move + -> IO () +cursorUp = hCursorUp stdout +cursorDown = hCursorDown stdout +cursorForward = hCursorForward stdout +cursorBackward = hCursorBackward stdout + +hCursorDownLine, hCursorUpLine :: Handle + -> Int -- ^ Number of lines to move + -> IO () +cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move + -> IO () +cursorDownLine = hCursorDownLine stdout +cursorUpLine = hCursorUpLine stdout + +hSetCursorColumn :: Handle + -> Int -- ^ 0-based column to move to + -> IO () +setCursorColumn :: Int -- ^ 0-based column to move to + -> IO () +setCursorColumn = hSetCursorColumn stdout + +hSetCursorPosition :: Handle + -> Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPosition :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPosition = hSetCursorPosition stdout + +hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () + +-- | Save the cursor position in memory. The only way to access the saved value +-- is with the 'restoreCursor' command. +saveCursor :: IO () +-- | Restore the cursor position from memory. There will be no value saved in +-- memory until the first use of the 'saveCursor' command. +restoreCursor :: IO () +-- | Looking for a way to get the cursors position? See +-- 'getCursorPosition'. +-- +-- Emit the cursor position into the console input stream, immediately after +-- being recognised on the output stream, as: +-- @ESC [ \<cursor row> ; \<cursor column> R@ +-- +-- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this +-- function may be of limited use on Windows operating systems because of +-- difficulties in obtaining the data emitted into the console input stream. +-- The function 'hGetBufNonBlocking' in module "System.IO" does not work on +-- Windows. This has been attributed to the lack of non-blocking primatives in +-- the operating system (see the GHC bug report #806 at +-- <https://ghc.haskell.org/trac/ghc/ticket/806>). +reportCursorPosition :: IO () + +saveCursor = hSaveCursor stdout +restoreCursor = hRestoreCursor stdout +reportCursorPosition = hReportCursorPosition stdout + +hHideCursor, hShowCursor :: Handle + -> IO () +hideCursor, showCursor :: IO () +hideCursor = hHideCursor stdout +showCursor = hShowCursor stdout + +-- | Set the terminal window title +hSetTitle :: Handle + -> String -- ^ New title + -> IO () +-- | Set the terminal window title +setTitle :: String -- ^ New title + -> IO () +setTitle = hSetTitle stdout + +-- | Use heuristics to determine whether the functions defined in this +-- package will work with a given handle. +-- +-- The current implementation checks that the handle is a terminal, and +-- that the @TERM@ environment variable doesn't say @dumb@ (which is what +-- Emacs sets for its own terminal). +hSupportsANSI :: Handle -> IO Bool +-- 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 + +-- | Parses the characters emitted by 'reportCursorPosition' into the console +-- input stream. Returns the cursor row and column as a tuple. +-- +-- For example, if the characters emitted by 'reportCursorPosition' are in +-- 'String' @input@ then the parser could be applied like this: +-- +-- > let result = readP_to_S cursorPosition input +-- > case result of +-- > [] -> putStrLn $ "Error: could not parse " ++ show input +-- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row +-- > ++ " and column" ++ show column ++ "." +-- > (_:_) -> putStrLn $ "Error: parse not unique" +-- +cursorPosition :: ReadP (Int, Int) +cursorPosition = do + void $ char '\ESC' + void $ char '[' + row <- decimal -- A non-negative whole decimal number + void $ char ';' + col <- decimal -- A non-negative whole decimal number + void $ char 'R' + return (read row, read col) + where + digit = satisfy isDigit + decimal = many1 digit + +-- | Attempts to get the reported cursor position data from the console input +-- stream. The function is intended to be called immediately after +-- 'reportCursorPosition' (or related functions) have caused characters to be +-- emitted into the stream. +-- +-- For example, on a Unix-like operating system: +-- +-- > hSetBuffering stdin NoBuffering -- set no buffering (the contents of the +-- > -- buffer will be discarded, so this needs +-- > -- to be done before the cursor positon is +-- > -- emitted) +-- > reportCursorPosition +-- > hFlush stdout -- ensure the report cursor position code is sent to the +-- > -- operating system +-- > input <- getReportedCursorPosition +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Win32 console of the Windows API. +-- (Command Prompt and PowerShell are based on the Win32 console.) +getReportedCursorPosition :: IO String + +-- | Attempts to get the reported cursor position, combining the functions +-- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. +-- Returns 'Nothing' if any data emitted by 'reportCursorPosition', obtained by +-- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Win32 console of the Windows API. +-- (Command Prompt and PowerShell are based on the Win32 console.) +getCursorPosition :: IO (Maybe (Int, Int))
includes/Exports-Include.hs view
@@ -1,114 +1,114 @@--- This file contains code that is common to modules--- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module--- exports and the associated Haddock documentation.-- -- * Basic data types- module System.Console.ANSI.Types-- -- * Cursor movement by character- , cursorUp- , cursorDown- , cursorForward- , cursorBackward- , hCursorUp- , hCursorDown- , hCursorForward- , hCursorBackward- , cursorUpCode- , cursorDownCode- , cursorForwardCode- , cursorBackwardCode-- -- * Cursor movement by line- -- | The difference between movements \"by character\" and \"by line\" is- -- that @*Line@ functions additionally move the cursor to the start of the- -- line, while functions like @cursorUp@ and @cursorDown@ keep the column- -- the same.- --- -- Also keep in mind that @*Line@ functions are not as portable. See- -- <https://github.com/feuerbach/ansi-terminal/issues/10> for the details.- , cursorUpLine- , cursorDownLine- , hCursorUpLine- , hCursorDownLine- , cursorUpLineCode- , cursorDownLineCode-- -- * Directly changing cursor position- , setCursorColumn- , hSetCursorColumn- , setCursorColumnCode-- , setCursorPosition- , hSetCursorPosition- , setCursorPositionCode-- -- * Saving, restoring and reporting cursor position- , saveCursor- , hSaveCursor- , saveCursorCode-- , restoreCursor- , hRestoreCursor- , restoreCursorCode-- , reportCursorPosition- , hReportCursorPosition- , reportCursorPositionCode-- -- * Clearing parts of the screen- -- | Note that these functions only clear parts of the screen. They do not move the- -- cursor.- , clearFromCursorToScreenEnd- , clearFromCursorToScreenBeginning- , clearScreen- , hClearFromCursorToScreenEnd- , hClearFromCursorToScreenBeginning- , hClearScreen- , clearFromCursorToScreenEndCode- , clearFromCursorToScreenBeginningCode- , clearScreenCode-- , clearFromCursorToLineEnd- , clearFromCursorToLineBeginning- , clearLine- , hClearFromCursorToLineEnd- , hClearFromCursorToLineBeginning- , hClearLine- , clearFromCursorToLineEndCode- , clearFromCursorToLineBeginningCode- , clearLineCode-- -- * Scrolling the screen- , scrollPageUp- , scrollPageDown- , hScrollPageUp- , hScrollPageDown- , scrollPageUpCode- , scrollPageDownCode-- -- * Select Graphic Rendition mode: colors and other whizzy stuff- , setSGR- , hSetSGR- , setSGRCode-- -- * Cursor visibilty changes- , hideCursor- , showCursor- , hHideCursor- , hShowCursor- , hideCursorCode- , showCursorCode-- -- * Changing the title- , setTitle- , hSetTitle- , setTitleCode-- -- * Checking if handle supports ANSI- , hSupportsANSI-- -- * Getting the cursor position- , getCursorPosition- , getReportedCursorPosition- , cursorPosition+-- This file contains code that is common to modules +-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module +-- exports and the associated Haddock documentation. + + -- * Basic data types + module System.Console.ANSI.Types + + -- * Cursor movement by character + , cursorUp + , cursorDown + , cursorForward + , cursorBackward + , hCursorUp + , hCursorDown + , hCursorForward + , hCursorBackward + , cursorUpCode + , cursorDownCode + , cursorForwardCode + , cursorBackwardCode + + -- * Cursor movement by line + -- | The difference between movements \"by character\" and \"by line\" is + -- that @*Line@ functions additionally move the cursor to the start of the + -- line, while functions like @cursorUp@ and @cursorDown@ keep the column + -- the same. + -- + -- Also keep in mind that @*Line@ functions are not as portable. See + -- <https://github.com/feuerbach/ansi-terminal/issues/10> for the details. + , cursorUpLine + , cursorDownLine + , hCursorUpLine + , hCursorDownLine + , cursorUpLineCode + , cursorDownLineCode + + -- * Directly changing cursor position + , setCursorColumn + , hSetCursorColumn + , setCursorColumnCode + + , setCursorPosition + , hSetCursorPosition + , setCursorPositionCode + + -- * Saving, restoring and reporting cursor position + , saveCursor + , hSaveCursor + , saveCursorCode + + , restoreCursor + , hRestoreCursor + , restoreCursorCode + + , reportCursorPosition + , hReportCursorPosition + , reportCursorPositionCode + + -- * Clearing parts of the screen + -- | Note that these functions only clear parts of the screen. They do not move the + -- cursor. + , clearFromCursorToScreenEnd + , clearFromCursorToScreenBeginning + , clearScreen + , hClearFromCursorToScreenEnd + , hClearFromCursorToScreenBeginning + , hClearScreen + , clearFromCursorToScreenEndCode + , clearFromCursorToScreenBeginningCode + , clearScreenCode + + , clearFromCursorToLineEnd + , clearFromCursorToLineBeginning + , clearLine + , hClearFromCursorToLineEnd + , hClearFromCursorToLineBeginning + , hClearLine + , clearFromCursorToLineEndCode + , clearFromCursorToLineBeginningCode + , clearLineCode + + -- * Scrolling the screen + , scrollPageUp + , scrollPageDown + , hScrollPageUp + , hScrollPageDown + , scrollPageUpCode + , scrollPageDownCode + + -- * Select Graphic Rendition mode: colors and other whizzy stuff + , setSGR + , hSetSGR + , setSGRCode + + -- * Cursor visibilty changes + , hideCursor + , showCursor + , hHideCursor + , hShowCursor + , hideCursorCode + , showCursorCode + + -- * Changing the title + , setTitle + , hSetTitle + , setTitleCode + + -- * Checking if handle supports ANSI + , hSupportsANSI + + -- * Getting the cursor position + , getCursorPosition + , getReportedCursorPosition + , cursorPosition