ansi-terminal 0.8.2 → 1.1.5
raw patch · 29 files changed
Files
- CHANGELOG.md +192/−3
- LICENSE +20/−17
- README.md +28/−22
- ansi-terminal.cabal +44/−36
- app/Example.hs +231/−21
- src/System/Console/ANSI.hs +1095/−121
- src/System/Console/ANSI/Codes.hs +0/−207
- src/System/Console/ANSI/Types.hs +0/−71
- src/System/Console/ANSI/Unix.hs +0/−118
- src/System/Console/ANSI/Windows.hs +0/−196
- src/System/Console/ANSI/Windows/Detect.hs +0/−113
- src/System/Console/ANSI/Windows/Emulator.hs +0/−497
- src/System/Console/ANSI/Windows/Emulator/Codes.hs +0/−94
- src/System/Console/ANSI/Windows/Foreign.hs +0/−651
- src/System/Win32/Compat.hs +0/−111
- src/includes/Common-Include-Emulator.hs +0/−65
- src/includes/Common-Include-Enabled.hs +0/−56
- src/includes/Common-Include.hs +0/−232
- src/includes/Exports-Include.hs +0/−118
- unix/System/Console/ANSI/Internal.hs +109/−0
- win/System/Console/ANSI/Internal.hs +113/−0
- win/System/Console/ANSI/Windows/Foreign.hs +494/−0
- win/System/Console/ANSI/Windows/Win32/MinTTY.hsc +256/−0
- win/System/Console/ANSI/Windows/Win32/Types.hs +195/−0
- win/c-source/HsWin32.c +3/−0
- win/c-source/errors.c +39/−0
- win/include/HsWin32.h +23/−0
- win/include/errors.h +22/−0
- win/include/winternl_compat.h +31/−0
CHANGELOG.md view
@@ -1,6 +1,195 @@ Changes ======= +Version 1.1.5 +------------- + +* On Windows, smothers a C compiler's warnings about `macro-undefined`, + `missing-definitions` and `pragma-pack`, which can be triggered by Windows + C headers. + +Version 1.1.4 +------------- + +* Fixes `hGetCursorPosition` and `hGetLayerColor` on Windows, allowing time for + reported information to reach the standard input channel. +* Improvements to Haddock documentation. +* The executable `ansi-terminal-example` allows individual examples to be + selected. + +Version 1.1.3 +------------- + +* Module `System.Console.ANSI.Codes` spun out to dependency package + `ansi-terminal-types-1.1.3`. + +Version 1.1.2 +------------- + +* Add `enableLineWrap` and `disableLineWrap`, and support for enabling and + disabling automatic line wrapping. + +Version 1.1.1 +------------- + +* Use of C function `setenv()` in one thread can cause other threads calling C + functions that query environment variables to crash. On Unix-like operating + systems, where such functions are used, the implementations of + `hSupportsANSI` and `hSupportsANSIColor` now avoid unnecessary calls of + `System.Environment.lookupEnv`. + +* Improvements to Haddock documentation. + +Version 1.1 +----------- + +* Add support for console layer `Underlining` and underlining styles + `CurlyUnderline`, `DottedUnderline` and `DashedUnderline`. +* Add type synonyms `Parameter`, `SubParam`, and `ParamWithSubs` to represent + SGR parameter values with and without following parameter substrings comprised + of one or more parameter elements (including empty elements). +* Add `csi'` and `sgrToCode'`, corresponding to `csi` and `sgrToCode` but + capable of handling a parameter value followed by a parameter substring. + +Version 1.0.2 +------------- + +* On Windows, fix linker error about a duplicate symbol `castUINTPtrToPtr`. + +Version 1.0.1 +------------- + +* On Windows, the processing of \'ANSI\' control characters in output is enabled + by default in Windows Terminal but is not enabled by default in ConHost + terminals. Additions have been made to allow support of users of ConHost + terminals. +* Add `hNowSupportsANSI`. On Unix, the function is equivalent to + `hSupportsANSI`. On Windows, in Windows Terminal and ConHost terminals, the + action can try to enable the processing of \'ANSI\' control characters in + output. +* In Windows Terminal and ConHost terminals, `hSupportsANSI` will yield `False` + if the processing of \'ANSI\' control characters in output is not enabled. +* Deprecated `hSupportsANSIWithoutEmulation` is now consistent with + `hNowSupportsANSI`. +* Improvements to Haddock documentation. +Version 1.0 +----------- + +* On Windows, drop support for legacy Windows requiring emulation. The package + assumes Windows Terminal has replaced ConHost terminals on supported versions + of Windows. Functions that yield actions no longer enable (re-enable) the + processing of \'ANSI\' control characters in output. +* On Windows, the package no longer depends (directly or indirectly) on the + `Win32`, `array`,`containers`, `deepseq`, `filepath`, `ghc-boot-th`, `mintty`, + `pretty` or `template-haskell` packages. +* `hSupportsANSI` no longer assumes that the given handle is writeable. +* `hSupportsANSIWithoutEmulation` is deprecated. + +Version 0.11.5 +-------------- + +* Module `System.Console.ANSI.Types` spun out to new dependency package + `ansi-terminal-types-0.11.5`. +* Drop support for GHC versions before GHC 7.10.1 (released March 2015). +* Improvements to Haddock documentation. + +Version 0.11.4 +-------------- + +* Add `reportLayerColor`, `getReportedLayerColor` and `getLayerColor` for + querying the layer color on terminals that support the functionality. +* Add `useAlternateScreenBuffer` and `useNormalScreenBuffer`, and support for + switching between the Alternate and Normal Screen Buffers. +* When the argument is `0`, `cursorUpCode`, `cursorDownCode`, + `cursorForwardCode`, `cursorBackwardCode`,`scrollPageUpCode` and + `scrollPageDownCode` now yield `""`, and `cursorUpLineCode` and + `cursorDownLineCode` now yield the equivalent of `setCursorColumnCode 0`. This + is because, on some terminals, a `0` parameter for the underlying 'ANSI' code + specifies a default parameter of `1`. +* Add `osc` as a utility function, for OSC sequences. +* `setTitle` now uses the recommended STRING TERMINATOR (ST) of `\ESC\\`, rather + than the legacy `\BEL` (`\007`), and filters the title of all non-printable + characters, not just `\BEL`. +* Improvements to Haddock documentation. + +Version 0.11.3 +-------------- + +* Add `hyperlink`, `hyperlinkWithId` and `hyperlinkWithParams`, and support for + clickable hyperlinks. + +Version 0.11.2 +-------------- + +* On Windows, fix compatability with the Windows I/O Manager (WinIO) when + GHC >= 9.0.1 but `Win32` < 2.9.0.0. +* Improvements to Haddock documentation. + +Version 0.11.1 +-------------- + +* On Windows, fix compatability with the Windows I/O Manager (WinIO) introduced + in GHC 9.0.1, by incorporating changes made in package `Win32-2.13.2.0` in + that regard. +* Improvements to Haddock documentation. + +Version 0.11 +------------ + +* Remove deprecated `getCursorPosition0`. (Use `getCursorPosition` instead.) +* On Unix-like operating systems, the temporary turning off of echoing is moved + from `getReportedCursorPosition` to `hGetCursorPositon`. +* On Unix-like operating systems, fix a bug in `getCursorPosition` and + `hGetCursorPosition`, where the console input stream was was not always + clear before the cursor position was emitted into it. + +Version 0.10.3 +-------------- + +* Add `getCursorPosition` as a synonym of `getCursorPosition0` and deprecate the + latter. + +Version 0.10.2 +-------------- + +* `hGetTerminalSize` now assumes a terminal is no bigger than 9,999 by 9,999 + (previously, no bigger than 999 by 999). +* On Windows, fix a bug where emulated cursor movement functions differed from + Windows 10 (movement bounded by the current viewport). + +Version 0.10.1 +-------------- + +* Add `hGetCursorPosition` and `hGetTerminalSize`. +* On Unix-like operating systems, fix a bug where `getReportedCursorPosition` + could block indefinitely if no information was forthcoming on the console + input stream. +* Improvements to Haddock documentation. + +Version 0.10 +------------ + +* Add support for setting the default color with new `SetDefaultColor` + constructor of the `SGR` type. +* `getTerminalSize` now flushes the `stdout` channel, to ensure the cursor + position is unaffected. + +Version 0.9.1 +------------- + +* Flag modules with GHC's 'Safe Haskell' language extensions (from GHC 7.2.1). +* Improvements and corrections to Haddock documentation. + +Version 0.9 +----------- + +* Add support for 256-color palettes with new `SetPaletteColor` constructor of + the `SGR` type, and `xterm6LevelRGB`, `xterm24LevelGray` and `xtermSystem`. +* Remove deprecated `getCursorPosition`. (Use `getCursorPosition0` instead.) +* Add `hSupportsANSIColor`. +* Add `getTerminalSize`. +* Improvements to Haddock documentation. + Version 0.8.2 ------------- @@ -13,9 +202,9 @@ Version 0.8.1 ------------- -* Add `hSupportsANSIWithoutEmulation`. On Windows 10, if the handle is identifed - as connected to a native terminal ('Command Prompt' or 'PowerShell'), the - processing of 'ANSI' control characters will be enabled. +* Add `hSupportsANSIWithoutEmulation`. On Windows 10, if the handle is + identified as connected to a native terminal ('Command Prompt' or + 'PowerShell'), the processing of 'ANSI' control characters will be enabled. Version 0.8.0.4 ---------------
LICENSE view
@@ -1,22 +1,25 @@ 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: +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. +* 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.+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,4 +1,4 @@-ansi-terminal+ansi-terminal [](https://github.com/UnkindPartition/ansi-terminal/actions) ============= A Haskell package providing support for 'ANSI' control character sequences for@@ -9,19 +9,18 @@ ['ANSI' terminal escape code](http://en.wikipedia.org/wiki/ANSI_escape_sequences) support for Haskell, which allows:-- Colored text output, with control over both foreground and background- colors+- Colored text output, with control over foreground, background and (where+ supported) underlining colors - Clearing parts of a line or the screen - Hiding or showing the cursor - Moving the cursor around - Reporting the position of the cursor+- Enabling and disabling automatic line wrapping - Scrolling the screen up or down+- Switching between the Alternate and Normal Screen Buffers+- Clickable hyperlinks to URIs - Changing the title of the terminal -By using emulation, it is compatible with versions of 'Command Prompt' and-'PowerShell' on Windows that did not recognise 'ANSI' escape codes before-Windows 10 version 1511 was released in November 2015.- If you like this, you may be interested in [ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which provides a pretty-printer that can construct strings containing 'ANSI'@@ -42,6 +41,7 @@ - Directly changing cursor position: `setCursorColumn` and `setCursorPosition` - Saving, restoring and reporting cursor position: `saveCursor`, `restoreCursor` and `reportCursorPosition`+- Automatic line wrapping: `enableLineWrap` and `disableLineWrap` - Scrolling the screen: `scrollPageUp` and `scrollPageDown` - Changing the title: `setTitle` @@ -53,33 +53,39 @@ - An `IO` variant similar to above, but which takes a `Handle` to which the escape code should be applied - A `String` variant that returns a literal string that should be- included to get the effect of the code. However, on Windows systems where- emulation has been necessary, these strings will always be blank!+ included to get the effect of the code. Example ------- A full example is-[available](https://github.com/feuerbach/ansi-terminal/blob/master/app/Example.hs),+[available](https://github.com/UnkindPartition/ansi-terminal/blob/master/ansi-terminal/app/Example.hs), but for a taste of how the library works try the following code: ``` haskell import System.Console.ANSI+import System.IO (stdout) +main :: IO () main = do- setCursorPosition 5 0- setTitle "ANSI Terminal Short Example"+ stdoutSupportsANSI <- hNowSupportsANSI stdout+ if stdoutSupportsANSI+ then do+ setCursorPosition 5 0+ setTitle "ANSI Terminal Short Example" - setSGR [ SetConsoleIntensity BoldIntensity- , SetColor Foreground Vivid Red- ]- putStr "Hello"+ setSGR [ SetConsoleIntensity BoldIntensity+ , SetColor Foreground Vivid Red+ ]+ putStr "Hello" - setSGR [ SetConsoleIntensity NormalIntensity- , SetColor Foreground Vivid White- , SetColor Background Dull Blue- ]- putStrLn "World!"+ setSGR [ SetConsoleIntensity NormalIntensity+ , SetColor Foreground Vivid White+ , SetColor Background Dull Blue+ ]+ putStrLn "World!"+ else+ putStrLn "Standard output does not support 'ANSI' escape codes." ``` @@ -98,7 +104,7 @@ Maintainers ----------- -[Mike Pilgrem](https://github.com/mpilgrem) and [Roman Cheplyaka](https://github.com/feuerbach) are the primary maintainers.+[Mike Pilgrem](https://github.com/mpilgrem) and [Roman Cheplyaka](https://github.com/UnkindPartition) are the primary maintainers. [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please get in touch with him if the primary maintainers cannot be reached.
ansi-terminal.cabal view
@@ -1,8 +1,8 @@+Cabal-Version: 1.22 Name: ansi-terminal -Version: 0.8.2 -Cabal-Version: >= 1.8 +Version: 1.1.5 Category: User Interfaces -Synopsis: Simple ANSI terminal support, with Windows compatibility +Synopsis: Simple ANSI terminal support 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. @@ -10,62 +10,70 @@ 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 +Homepage: https://github.com/UnkindPartition/ansi-terminal Build-Type: Simple -Extra-Source-Files: src/includes/Common-Include.hs - src/includes/Common-Include-Emulator.hs - src/includes/Common-Include-Enabled.hs - src/includes/Exports-Include.hs - CHANGELOG.md +Extra-Source-Files: CHANGELOG.md README.md + win/include/errors.h + win/include/HsWin32.h + win/include/winternl_compat.h Source-repository head type: git - location: git://github.com/feuerbach/ansi-terminal.git + location: git://github.com/UnkindPartition/ansi-terminal.git -Flag Example +Flag example Description: Build the example application Default: False Library Hs-Source-Dirs: src Exposed-Modules: System.Console.ANSI - System.Console.ANSI.Types - System.Console.ANSI.Codes - Include-Dirs: src/includes + -- We re-export all of ansi-terminal-types to aid compatibility for + -- downstream users. + Reexported-Modules: System.Console.ANSI.Codes + , System.Console.ANSI.Types - Build-Depends: base >= 4.3.0.0 && < 5 - , colour + Other-Modules: System.Console.ANSI.Internal + + Build-Depends: base >= 4.8.0.0 && < 5 + , ansi-terminal-types == 1.1.3 + , colour >= 2.1.0 if os(windows) - Build-Depends: containers >= 0.5.0.0 - , mintty - , Win32 >= 2.0 - Cpp-Options: -DWINDOWS - Other-Modules: System.Console.ANSI.Windows - System.Console.ANSI.Windows.Detect - System.Console.ANSI.Windows.Emulator - System.Console.ANSI.Windows.Emulator.Codes - System.Console.ANSI.Windows.Foreign - -- NB: used for fallback by the emulator - System.Console.ANSI.Unix - System.Win32.Compat + Hs-Source-Dirs: win + Other-Modules: System.Console.ANSI.Windows.Foreign + System.Console.ANSI.Windows.Win32.Types + System.Console.ANSI.Windows.Win32.MinTTY + Include-Dirs: win/include + Install-Includes: HsWin32.h + C-Sources: win/c-source/errors.c + win/c-source/HsWin32.c + -- The MSYS2 UCRT64 environment is stricter than the MINGW64 + -- environment about these C compiler diagnostics: + -- (1) macro-redefined, (2) missing-declarations, and + -- (3) pragma-pack. Windows C headers are not warning-clean under + -- -Wmacro-redefined, -Wmissing-declarations and -Wpragma-pack. We + -- smother those warnings: + Cc-Options: -Wno-macro-redefined + -Wno-missing-declarations + -Wno-pragma-pack else - -- We assume any non-Windows platform is Unix - Cpp-Options: -DUNIX - Other-Modules: System.Console.ANSI.Unix + Hs-Source-Dirs: unix - Extensions: CPP - ForeignFunctionInterface + Default-Extensions: CPP - Ghc-Options: -Wall + Ghc-Options: -Wall + Default-Language: Haskell2010 Executable ansi-terminal-example Hs-Source-Dirs: app Main-Is: Example.hs - Build-Depends: base >= 4.3.0.0 && < 5 + Build-Depends: base >= 4.8.0.0 && < 5 , ansi-terminal + , colour Ghc-Options: -Wall if !flag(example) - Buildable: False + Buildable: False + Default-Language: Haskell2010
app/Example.hs view
@@ -4,27 +4,64 @@ ) where import Control.Concurrent (threadDelay) -import Control.Monad (forM_) +import Control.Monad (forM_, replicateM_) import System.IO (hFlush, stdout) +import Text.Printf(printf) +import Data.Colour.SRGB (sRGB24) + import System.Console.ANSI +import System.Environment ( getArgs ) -examples :: [IO ()] -examples = [ cursorMovementExample - , lineChangeExample - , setCursorPositionExample - , saveRestoreCursorExample - , clearExample - , scrollExample - , sgrExample - , cursorVisibilityExample - , titleExample - , getCursorPositionExample - ] +examples :: [(String, IO ())] +examples = + [ ( "Cursor movement", cursorMovementExample ) + , ( "Line change", lineChangeExample ) + , ( "Set cursor position", setCursorPositionExample ) + , ( "Save restore cursor", saveRestoreCursorExample ) + , ( "Clear", clearExample ) + , ( "Line wrap", lineWrapExample ) + , ( "Scroll", scrollExample ) + , ( "Screen buffers", screenBuffersExample ) + , ( "SGR color", sgrColorExample ) + , ( "SGR other", sgrOtherExample ) + , ( "Cursor visibility", cursorVisibilityExample ) + , ( "Hyperlink", hyperlinkExample ) + , ( "Title", titleExample ) + , ( "Get cursor position", getCursorPositionExample ) + , ( "Get terminal size", getTerminalSizeExample ) + , ( "Get layer color", getLayerColorExample ) + ] main :: IO () -main = mapM_ (\example -> resetScreen >> example) examples +main = do + args <- getArgs + let numExamples = zip [1 ..] examples + if wantHelp args + then + listExamples numExamples + else do + let wantedNumExamples = filter (isExample args) numExamples + wantedExamples = map getExample wantedNumExamples + stdoutSupportsANSI <- hNowSupportsANSI stdout + if stdoutSupportsANSI + then + mapM_ (resetScreen >>) wantedExamples + else + putStrLn "Standard output does not support 'ANSI' escape codes." + where + wantHelp :: [String] -> Bool + wantHelp args = "-h" `elem` args || "--help" `elem` args + listExamples :: [(Int, (String, IO ()))] -> IO () + listExamples = mapM_ (\(n, (d, _)) -> putStrLn $ show n ++ ": " ++ d) + + isExample :: [String] -> (Int, (String, IO ())) -> Bool + isExample args (n, _) = show n `elem` args + + getExample :: (Int, (String, IO ())) -> IO () + getExample (_, (_, example)) = example + -- 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 @@ -192,6 +229,24 @@ pause -- +lineWrapExample :: IO () +lineWrapExample = do + putStrLn $ take 240 $ cycle "Default-line-wrap|" + pause + -- Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Def + -- ault-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Defaul + -- t-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-l + disableLineWrap + putStrLn $ take 240 $ cycle "Disable-line-wrap|" + pause + -- Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Dis + enableLineWrap + putStrLn $ take 240 $ cycle "Enable-line-wrap|" + pause + -- Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable- + -- line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wr + -- ap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enab + scrollExample :: IO () scrollExample = do putStrLn "Line One" @@ -215,19 +270,132 @@ -- Line Two -- Line Three -sgrExample :: IO () -sgrExample = do +screenBuffersExample :: IO () +screenBuffersExample = do + replicateM_ 5 $ putStrLn "This message is on the Normal Screen Bufffer" + replicateM_ 5 pause + useAlternateScreenBuffer + replicateM_ 5 $ putStrLn "This message is on the Alternate Screen Bufffer" + replicateM_ 5 pause + useNormalScreenBuffer + replicateM_ 5 $ putStrLn "This message is continuing where we left off" + replicateM_ 5 pause + +sgrColorExample :: IO () +sgrColorExample = do let colors = enumFromTo minBound maxBound :: [Color] - forM_ [Foreground, Background] $ \layer -> do + forM_ [Foreground, Background, Underlining] $ \layer -> do forM_ [Dull, Vivid] $ \intensity -> do resetScreen forM_ colors $ \color -> do setSGR [Reset] setSGR [SetColor layer intensity color] - putStrLn (show color) + setSGR [SetUnderlining SingleUnderline] + print color pause - -- All the colors, 4 times in sequence + -- The ANSI eight standard colors, 6 times in sequence (three layers and two + -- intensities) + resetScreen + putStrLn "True color (24 bit color depth)" + putStrLn "-------------------------------" + putStrLn "" + setSGR [SetRGBColor Foreground $ sRGB24 0 0 0] + forM_ [0 .. 23] $ \row -> do + forM_ [0 .. 47] $ \col -> do + let r = row * 11 + g = 255 - r + b = col * 5 + setSGR [SetRGBColor Background $ sRGB24 r g b] + putStr "-" + putStrLn "" + replicateM_ 5 pause + -- True colors, a swatch of 24 rows and 48 columns + + resetScreen + putStrLn "A 256-color palette" + putStrLn "-------------------" + putStrLn "" + + -- First 16 colors ('system' colors in xterm protocol), in a row + -- + -- 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 A A B B C C D D E E F F + forM_ [Dull .. Vivid] $ \intensity -> do + forM_ [Black .. White] $ \color -> do + let i = fromEnum intensity * 8 + fromEnum color + eol = i == 15 + setSGR [SetPaletteColor Background $ xtermSystem intensity color] + setSGR [SetPaletteColor Foreground $ xtermSystem Dull Black] + printf "%X " i + setSGR [SetPaletteColor Foreground $ xtermSystem Vivid White] + printf "%X" i + if eol + then putStrLn "" + else do + setSGR [Reset] + putStr " " + putStrLn "" + + -- Next 216 colors (6 level RGB in xterm protocol), in 12 rows of 18 + -- + -- 000 001 002 003 004 005 010 011 012 013 014 015 020 021 022 023 024 025 + -- 030 031 032 033 034 035 040 041 042 043 044 045 050 051 052 053 054 055 + -- 100 101 102 103 104 105 110 111 112 113 114 115 120 121 122 123 124 125 + -- ... and so on ... + forM_ [0 .. 5] $ \r -> do + forM_ [0 .. 5] $ \g -> do + forM_ [0 .. 5] $ \b -> do + let i = 16 + b + g * 6 + r * 36 + eol = i `mod` 18 == 15 + r' = (r + 3) `mod` 6 + g' = (g + 3) `mod` 6 + b' = (b + 3) `mod` 6 + setSGR [SetPaletteColor Foreground $ xterm6LevelRGB r' g' b'] + setSGR [SetPaletteColor Background $ xterm6LevelRGB r g b] + putStr $ show r ++ show g ++ show b + if eol + then putStrLn "" + else do + setSGR [Reset] + putStr " " + putStrLn "" + + -- Final 24 colors (24 levels of gray in xterm protocol), in two rows + -- + -- 0 1 2 3 4 5 6 7 8 9 10 11 + -- 12 13 14 15 16 17 18 19 20 21 22 23 + forM_ [0 .. 23] $ \y -> do + setSGR [SetPaletteColor Foreground $ xterm24LevelGray $ (y + 12) `mod` 24] + setSGR [SetPaletteColor Background $ xterm24LevelGray y] + printf "%3d" y + if y == 11 + then putStrLn "" + else do + setSGR [Reset] + putStr " " + replicateM_ 5 pause + + resetScreen + setSGR [Reset] + setSGR [SetUnderlining SingleUnderline] + forM_ + (zip "Underlining: True color (24 bit color depth)" (cycle [0, 10 .. 255])) $ + \(c, i) -> do + setSGR [SetRGBColor Underlining $ sRGB24 i 0 0] + putChar c + putChar '\n' + putChar '\n' + setSGR [Reset] + setSGR [SetUnderlining SingleUnderline] + forM_ (zip "Underlining: A 256-color palette" (cycle [0 .. 5])) $ + \(c, i) -> do + setSGR [SetPaletteColor Underlining $ xterm6LevelRGB i 0 0] + putChar c + putChar '\n' + replicateM_ 5 pause + +sgrOtherExample :: IO () +sgrOtherExample = do let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") , (SetConsoleIntensity FaintIntensity, "Faint") , (SetConsoleIntensity NormalIntensity, "Normal") @@ -235,6 +403,9 @@ , (SetItalicized False, "No Italics") , (SetUnderlining SingleUnderline, "Single Underline") , (SetUnderlining DoubleUnderline, "Double Underline") + , (SetUnderlining CurlyUnderline, "Curly Underline") + , (SetUnderlining DottedUnderline, "Dotted Underline") + , (SetUnderlining DashedUnderline, "Dashed Underline") , (SetUnderlining NoUnderline, "No Underline") , (SetBlinkSpeed SlowBlink, "Slow Blink") , (SetBlinkSpeed RapidBlink, "Rapid Blink") @@ -278,6 +449,22 @@ pause -- Cursor Demo| +hyperlinkExample :: IO () +hyperlinkExample = do + putStr "Hyperlink demo: " + hyperlink "https://example.com" "Example hyperlink\n" + putStrLn "" + putStrLn "Linked hyperlinks demo:" + hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink one\n" + hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink two\n" + + replicateM_ 5 pause + -- Hyperlink demo: Example hyperlink + -- + -- Linked hyperlinks demo: + -- Example linked hyperlink one + -- Example linked hyperlink two + titleExample :: IO () titleExample = do putStr "Title Demo" @@ -301,15 +488,38 @@ -- 11111111112222222222 -- 12345678901234567890123456789 -- Report cursor position here:| - result <- getCursorPosition0 + result <- getCursorPosition putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n" case result of Just (row, col) -> putStrLn $ "The cursor was at row number " ++ show (row + 1) ++ " and column number " ++ show (col + 1) ++ ".\n" Nothing -> putStrLn "Error: unable to get the cursor position\n" - pause + replicateM_ 3 pause -- 11111111112222222222 -- 12345678901234567890123456789 -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R. -- -- The cursor was at row number 3 and column number 29. + +getTerminalSizeExample :: IO () +getTerminalSizeExample = do + result <- getTerminalSize + case result of + Just (h, w) -> putStrLn $ "The size of the terminal is " ++ show h ++ + " rows by " ++ show w ++ " columns.\n" + Nothing -> putStrLn "Error: unable to get the terminal size\n" + pause + -- The size of the terminal is 25 rows by 80 columns. + +getLayerColorExample :: IO () +getLayerColorExample = do + fgResult <- getLayerColor Foreground + case fgResult of + Just fgCol -> putStrLn $ "The reported foreground color is:\n" ++ + show fgCol ++ "\n" + Nothing -> putStrLn "Error: unable to get the foreground color\n" + bgResult <- getLayerColor Background + case bgResult of + Just bgCol -> putStrLn $ "The reported background color is:\n" ++ + show bgCol ++ "\n" + Nothing -> putStrLn "Error: unable to get the background color\n"
src/System/Console/ANSI.hs view
@@ -1,121 +1,1095 @@--- | Through this module, this library provides platform-independent support --- for control character sequences following the \'ANSI\' standards (see further --- below) for terminal software that supports those sequences, running on a --- Unix-like operating system or Windows. --- --- The sequences of control characters (also referred to as \'escape\' sequences --- or codes) provide a rich range of functionality for terminal control, which --- includes: --- --- * Colored text output, with control over both foreground and background --- colors --- --- * Clearing parts of a line or the screen --- --- * Hiding or showing the cursor --- --- * Moving the cursor around --- --- * Reporting the position of the cursor --- --- * Scrolling the screen up or down --- --- * Changing the title of the terminal --- --- The functions moving the cursor to an absolute position are 0-based (the --- top-left corner is considered to be at row 0 column 0) (see --- 'setCursorPosition') and so is 'getCursorPosition0'. The \'ANSI\' standards --- themselves are 1-based (that is, the top-left corner is considered to be at --- row 1 column 1) and some functions reporting the position of the cursor are --- too (see 'reportCursorPosition'). --- --- The native terminal software on Windows is \'Command Prompt\' or --- \`PowerShell\`. Before Windows 10 version 1511 (known as the \'November --- [2015] Update\' or \'Threshold 2\') that software did not support such --- control sequences. For that software, this library also provides support for --- such sequences by using emulation. --- --- Terminal software other than the native software exists for Windows. One --- example is the \'mintty\' terminal emulator for \'Cygwin\', \'MSYS\' or --- \'MSYS2\', and dervied projects, and for \'WSL\' (Windows Subsystem for --- Linux). --- --- The \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for --- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T --- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information --- Technology – Open Document Architecture (ODA) and Interchange Format: --- Character Content Architectures\` (also published as ISO/IEC International --- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal --- emulator for the X Window System. The escape codes are described in a --- Wikipedia article at <http://en.wikipedia.org/wiki/ANSI_escape_code> and --- those codes supported on current versions of Windows at --- <https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences>. --- --- The whole of the \'ANSI\' standards are not supported by this library but --- most (if not all) of the parts that are popular and well-supported by --- terminal software are supported. Every function exported by this module comes --- in three variants, namely: --- --- * A variant that has an @IO ()@ type and doesn't take a @Handle@ (for --- example, @clearScreen :: IO ()@). This variant just outputs the \`ANSI\` --- command directly to the standard output channel ('stdout') and any --- terminal corresponding to it. Commands issued like this should work as you --- expect on both Unix-like operating systems and Windows. --- --- * An \'@h@...\' variant that has an @IO ()@ type but takes a @Handle@ (for --- example, @hClearScreen :: Handle -> IO ()@). This variant outputs the --- \`ANSI\` command to the supplied handle and any terminal corresponding to --- it. Commands issued like this should also work as you expect on both --- Unix-like operating systems and Windows. --- --- * A \'...@Code@\' variant that has a @String@ type (for example, --- @clearScreenCode :: String@). This variant outputs the sequence of control --- characters as a 'String', which can be added to any other bit of text --- before being output. The use of these codes is generally discouraged --- because they will not work on legacy versions of Windows where the --- terminal in use is not ANSI-enabled (see further above). On Windows, where --- emulation has been necessary, these variants will always output the empty --- string. That is done so that it is possible to use them portably; for --- example, coloring console output on the understanding that you will see --- colors only if you are running on a Unix-like operating system or a --- version of Windows where emulation has not been necessary. If the control --- characters are always required, see module "System.Console.ANSI.Codes". --- --- Example: --- --- > module Main where --- > --- > import System.Console.ANSI --- > --- > -- Set colors and write some text in those colors. --- > main = do --- > setSGR [SetColor Foreground Vivid Red] --- > setSGR [SetColor Background Vivid Blue] --- > putStrLn "Red-On-Blue" --- > setSGR [Reset] -- Reset to default colour scheme --- > putStrLn "Default colors." --- --- For many more examples, see the project's extensive --- <https://github.com/feuerbach/ansi-terminal/blob/master/app/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 +{-# LANGUAGE Safe #-} + +{-| == Introduction +Through this module, this library provides platform-independent support for +control character sequences following the \'ANSI\' standards (see further below) +for terminal software that supports those sequences, running on a Unix-like +operating system or on Windows (see further below). + +The sequences of control characters (also referred to as \'escape\' sequences or +codes) provide a rich range of functionality for terminal control, which +includes: + + * Colored text output, with control over foreground, background and (where + supported) underlining colors + + * Clearing parts of a line or the screen + + * Hiding or showing the cursor + + * Moving the cursor around + + * Reporting the position of the cursor + + * Enabling or disabling automatic line wrapping + + * Scrolling the screen up or down + + * Switching between the Alternate and Normal Screen Buffers + + * Clickable hyperlinks to URIs + + * Changing the title of the terminal + +A terminal that supports control character sequences acts on them when they +are flushed from the output buffer (with a newline character @\"\\n\"@ or, for +the standard output channel, @hFlush stdout@). + +== \'ANSI\' standards +The \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for +Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T +Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information +Technology – Open Document Architecture (ODA) and Interchange Format: Character +Content Architectures\` (also published as ISO/IEC International Standard +8613-6); and (3) further extensions used by \'XTerm\', a terminal emulator for +the X Window System. The escape codes are described in a + [Wikipedia article](http://en.wikipedia.org/wiki/ANSI_escape_code) and those +codes supported on current versions of Windows are descibed in + [Microsoft's documentation](https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences). + +The whole of the \'ANSI\' standards are not supported by this library but most +(if not all) of the parts that are popular and well-supported by terminal +software are supported (see further below). + +== Cursor positions +The functions moving the cursor to an absolute position are 0-based (the +top-left corner is considered to be at row 0 column 0) (see 'setCursorPosition') +and so is 'getCursorPosition'. The \'ANSI\' standards themselves are 1-based +(that is, the top-left corner is considered to be at row 1 column 1) and some +functions reporting the position of the cursor are too (see +'reportCursorPosition'). + +== Windows and control character sequences +The native terminal software on Windows has developed over time. Before +Windows 10 version 1511 (known as the \'November [2015] Update\' or +\'Threshold 2\') that software did not support control character sequences. From +2018, Microsoft introduced the Windows Pseudo Console (\'ConPTY\') API and then +Windows Terminal, with the objective of replacing most of the Windows Console +API with the use of control character sequences and retiring the historical +user-interface role of Windows Console Host (\'ConHost\'). + +Windows Terminal is supported on Windows 10 version 19041.0 or higher and +provided with Windows 11. It can be downloaded from the Microsoft Store. Windows +Terminal can be set as the default terminal application on Windows 10 (from +the 22H2 update) and is the default application on Windows 11 (from the 22H2 +update). + +Despite the above developments, some Windows users may continue to use ConHost. +ConHost does not enable the processing of \'ANSI\' control characters in output +by default. See 'hNowSupportsANSI' for a function that can try to enable such +processing. + +Terminal software other than the native software exists for Windows. One example +is the \'mintty\' terminal emulator for \'Cygwin\', \'MSYS\' or \'MSYS2\', and +dervied projects, and for \'WSL\' (Windows Subsystem for Linux). + +GHC's management of input and output (IO) on Windows has also developed over +time. If they are supported by the terminal software, some control character +sequences cause data to be emitted into the console input stream. For GHC's +historical and default IO manager, the function 'System.IO.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 + [GHC bug report #806](https://ghc.haskell.org/trac/ghc/ticket/806). GHC's +native IO manager on Windows (\'WinIO\'), introduced as a preview in + [GHC 9.0.1](https://downloads.haskell.org/ghc/9.0.1/docs/html/users_guide/9.0.1-notes.html#highlights), +has not yet provided a solution. On Windows, this library uses emulation based +on the Windows Console API to try to read data emitted into the console input +stream. Functions that use that emulation are not supported on consoles, such +as mintty, that are not based on that API. + +== Function variants provided +Every function exported by this module comes in three variants, namely: + + * A variant that has an @IO ()@ type and doesn't take a @Handle@ (for example, + @clearScreen :: IO ()@). This variant just outputs the \`ANSI\` command + directly to the standard output channel ('stdout') and any terminal + corresponding to it. Commands issued like this should work as you expect on + both Unix-like operating systems and Windows (unless exceptions on Windows + are stated). + + * An \'@h@...\' variant that has an @IO ()@ type but takes a @Handle@ (for + example, @hClearScreen :: Handle -> IO ()@). This variant outputs the + \`ANSI\` command to the supplied handle and any terminal corresponding to it. + Commands issued like this should also work as you expect on both Unix-like + operating systems and Windows (unless exceptions on Windows are stated). + + * A \'...@Code@\' variant that has a @String@ type (for example, + @clearScreenCode :: String@). This variant outputs the sequence of control + characters as a 'String', which can be added to any other bit of text before + being output. If a high degree of backwards compatability is rewuired, the + use of these codes is discouraged because they will not work on legacy + versions of Windows where the terminal in use is not ANSI-enabled (see + further above). On Windows, where emulation has been necessary, these + variants will always output the empty string. That is done so that it is + possible to use them portably; for example, coloring console output on the + understanding that you will see colors only if you are running on a Unix-like + operating system or a version of Windows where emulation has not been + necessary. If the control characters are always required, see module + "System.Console.ANSI.Codes". + +== Examples of use + +A simple example is below: + +> module Main where +> +> import System.Console.ANSI +> import System.IO (stdout) +> +> -- Set colors and write some text in those colors. +> main :: IO () +> main = do +> stdoutSupportsANSI <- hNowSupportsANSI stdout +> if stdoutSupportsANSI +> then do +> setSGR [SetColor Foreground Vivid Red] +> setSGR [SetColor Background Vivid Blue] +> putStrLn "Red-On-Blue" +> setSGR [Reset] -- Reset to default colour scheme +> putStrLn "Default colors." +> else +> putStrLn "Standard output does not support 'ANSI' escape codes." + +Another example is below: + +> module Main where +> +> import System.IO (hFlush, stdout) +> import System.Console.ANSI +> +> main :: IO () +> main = do +> stdoutSupportsANSI <- hNowSupportsANSI stdout +> if stdoutSupportsANSI +> then do +> setSGR [SetColor Foreground Dull Blue] +> putStr "Enter your name: " +> setSGR [SetColor Foreground Dull Yellow] +> hFlush stdout -- flush the output buffer before getLine +> name <- getLine +> setSGR [SetColor Foreground Dull Blue] +> putStrLn $ "Hello, " ++ name ++ "!" +> setSGR [Reset] -- reset to default colour scheme +> else +> putStrLn "Standard output does not support 'ANSI' escape codes." + +For many more examples, see the project's extensive +<https://github.com/UnkindPartition/ansi-terminal/blob/master/app/Example.hs Example.hs> file. +-} + +module System.Console.ANSI + ( + -- * Basic data types + module System.Console.ANSI.Types + + -- * Cursor movement by character + , cursorUp + , cursorDown + , cursorForward + , cursorBackward + -- ** \'h...\' variants + , hCursorUp + , hCursorDown + , hCursorForward + , hCursorBackward + -- ** \'...Code\' variants + , cursorUpCode + , cursorDownCode + , cursorForwardCode + , cursorBackwardCode + + -- * Cursor movement by line + -- + -- | The difference between movements \"by character\" and \"by line\" is + -- that @*Line@ functions additionally move the cursor to the start of the + -- line, while functions like @cursorUp@ and @cursorDown@ keep the column + -- the same. + , cursorUpLine + , cursorDownLine + -- ** \'h...\' variants + , hCursorUpLine + , hCursorDownLine + -- ** \'...Code\' variants + , cursorUpLineCode + , cursorDownLineCode + + -- * Directly changing cursor position + , setCursorColumn + , setCursorPosition + -- ** \'h...\' variants + , hSetCursorColumn + , hSetCursorPosition + -- ** \'...Code\' variants + , setCursorColumnCode + , setCursorPositionCode + + -- * Saving, restoring and reporting cursor position + -- + -- | These code sequences are not part of ECMA-48 standard; they are popular, + -- but non-portable extensions. E. g., Terminal.app on MacOS + -- <https://stackoverflow.com/questions/25879183 does not support them>. + -- A more portable way would be to query @terminfo@ database + -- for @rc@ and @sc@ capabilities. + -- + -- Cursor positions + -- <https://unix.stackexchange.com/questions/565597 are relative to the viewport, not to its content>. + -- + , saveCursor + , restoreCursor + , reportCursorPosition + -- ** \'h...\' variants + , hSaveCursor + , hRestoreCursor + , hReportCursorPosition + -- ** \'...Code\' variants + , saveCursorCode + , restoreCursorCode + , reportCursorPositionCode + + -- * Clearing parts of the screen + -- + -- | Note that these functions only clear parts of the screen. They do not + -- move the cursor. Some functions are based on the whole screen and others + -- are based on the line in which the cursor is located. + , clearFromCursorToScreenEnd + , clearFromCursorToScreenBeginning + , clearScreen + , clearFromCursorToLineEnd + , clearFromCursorToLineBeginning + , clearLine + -- ** \'h...\' variants + , hClearFromCursorToScreenEnd + , hClearFromCursorToScreenBeginning + , hClearScreen + , hClearFromCursorToLineEnd + , hClearFromCursorToLineBeginning + , hClearLine + -- ** \'...Code\' variants + , clearFromCursorToScreenEndCode + , clearFromCursorToScreenBeginningCode + , clearScreenCode + , clearFromCursorToLineEndCode + , clearFromCursorToLineBeginningCode + , clearLineCode + + -- * Enabling and disabling automatic line wrapping + -- + -- | These functions control whether or not characters automatically wrap to + -- the next line when the cursor reaches the right border. + , enableLineWrap + , disableLineWrap + -- ** \'h...\' variants + , hEnableLineWrap + , hDisableLineWrap + -- ** \'...Code\' variants + , enableLineWrapCode + , disableLineWrapCode + + -- * Scrolling the screen + , scrollPageUp + , scrollPageDown + -- ** \'h...\' variants + , hScrollPageUp + , hScrollPageDown + -- ** \'...Code\' variants + , scrollPageUpCode + , scrollPageDownCode + + -- * Using screen buffers + -- + -- | These code sequences are not part of ECMA-48 standard; they are popular, + -- but non-portable extensions, corresponding to @smcup@ and @rmcup@ capabilities + -- in @terminfo@ database. + -- On Windows, if emulation is required, switching between alternate and + -- normal screen buffers is not emulated. + , useAlternateScreenBuffer + , useNormalScreenBuffer + -- ** \'h...\' variants + , hUseAlternateScreenBuffer + , hUseNormalScreenBuffer + -- ** \'...Code\' variants + , useAlternateScreenBufferCode + , useNormalScreenBufferCode + + -- * Reporting the background or foreground colors + , reportLayerColor + , hReportLayerColor + , reportLayerColorCode + + -- * Select Graphic Rendition mode: colors and other whizzy stuff + , setSGR + , hSetSGR + , setSGRCode + + -- * Cursor visibilty changes + -- + -- | Strictly speaking, these code sequences are not part of ECMA-48 standard; + -- they are popular, but non-portable extensions. However, in practice they seem + -- to work pretty much everywhere. + , hideCursor + , showCursor + -- ** \'h...\' variants + , hHideCursor + , hShowCursor + -- ** \'...Code\' variants + , hideCursorCode + , showCursorCode + + -- * Hyperlinks + -- + -- | These code sequences are not part of ECMA-48 standard and not even an + -- @xterm@ extension. Nevertheless + -- <https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda many terminals> + -- support them. On Windows, if emulation is required, + -- hyperlinks are not emulated. + , hyperlink + , hyperlinkWithId + , hyperlinkWithParams + -- ** \'h...\' variants + , hHyperlink + , hHyperlinkWithId + , hHyperlinkWithParams + -- ** \'...Code\' variants + , hyperlinkCode + , hyperlinkWithIdCode + , hyperlinkWithParamsCode + + -- * Changing the title + , setTitle + , hSetTitle + , setTitleCode + + -- * Checking if handle supports ANSI (not portable: GHC only) + , hSupportsANSI + , hNowSupportsANSI + , hSupportsANSIColor + + -- * Getting the cursor position + , getCursorPosition + , hGetCursorPosition + , getReportedCursorPosition + , cursorPosition + + -- * Getting the terminal size + , getTerminalSize + , hGetTerminalSize + + -- * Getting the background or foreground colors + , getLayerColor + , hGetLayerColor + , getReportedLayerColor + , layerColor + + -- * Deprecated + , hSupportsANSIWithoutEmulation + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception.Base ( bracket ) +import Control.Monad ( when, void ) +import Data.Char ( digitToInt, isDigit, isHexDigit ) +import Data.Colour.SRGB ( RGB (..) ) +import Data.Word ( Word16 ) +import System.IO + ( BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, hPutStr + , hReady, hSetBuffering, hSetEcho, stdin, stdout + ) +import Text.ParserCombinators.ReadP + ( ReadP, (<++), char, many1, readP_to_S, satisfy, string ) + +import System.Console.ANSI.Codes +import qualified System.Console.ANSI.Internal as Internal +import System.Console.ANSI.Types + +hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: + Handle + -> Int -- Number of lines or characters to move + -> IO () +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 + +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 () +hCursorDownLine h n = hPutStr h $ cursorDownLineCode n +hCursorUpLine h n = hPutStr h $ cursorUpLineCode n + +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 () +hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n + +-- | Move the cursor to the specified column. The column numbering is 0-based +-- (that is, the left-most column is numbered 0). +setCursorColumn :: + Int -- ^ 0-based column to move to + -> IO () +setCursorColumn = hSetCursorColumn stdout + +hSetCursorPosition :: + Handle + -> Int -- 0-based row to move to + -> Int -- 0-based column to move to + -> IO () +hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m + +-- | Move the cursor to the specified position (row and column). The position is +-- 0-based (that is, the top-left corner is at row 0 column 0). +setCursorPosition :: + Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPosition = hSetCursorPosition stdout + +hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () +hSaveCursor h = hPutStr h saveCursorCode +hRestoreCursor h = hPutStr h restoreCursorCode +hReportCursorPosition h = hPutStr h reportCursorPositionCode + +-- | Save the cursor position in memory. The only way to access the saved value +-- is with the 'restoreCursor' command. +-- +-- @since 0.7.1 +saveCursor :: IO () +saveCursor = hSaveCursor stdout + +-- | Restore the cursor position from memory. There will be no value saved in +-- memory until the first use of the 'saveCursor' command. +-- +-- @since 0.7.1 +restoreCursor :: IO () +restoreCursor = hRestoreCursor stdout + +-- | 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@ +-- +-- Note that the information that is emitted is 1-based (the top-left corner is +-- at row 1 column 1) but 'setCursorColumn' and 'setCursorPosition' are +-- 0-based. +-- +-- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this +-- function may be of limited use on Windows operating systems because of +-- difficulties in obtaining the data emitted into the console input stream. +-- +-- @since 0.7.1 +reportCursorPosition :: IO () +reportCursorPosition = hReportCursorPosition stdout + +hHideCursor, hShowCursor :: Handle -> IO () +hHideCursor h = hPutStr h hideCursorCode +hShowCursor h = hPutStr h showCursorCode + +hideCursor, showCursor :: IO () +hideCursor = hHideCursor stdout +showCursor = hShowCursor stdout + +hUseAlternateScreenBuffer :: Handle -> IO () +hUseAlternateScreenBuffer h = hPutStr h useAlternateScreenBufferCode + +hUseNormalScreenBuffer :: Handle -> IO () +hUseNormalScreenBuffer h = hPutStr h useNormalScreenBufferCode + +-- | Use the Alternate Screen Buffer. If currently using the Normal Screen +-- Buffer, it will save the cursor position and switch to the Alternate Screen +-- Buffer. It will always clear the Alternate Screen Buffer. The Alternate +-- Screen Buffer has no scroll back facility. +-- +-- It is an application's responsibility to ensure that it switches back to the +-- Normal Screen Buffer if an exception is raised while the Alternate Screen +-- Buffer is being used. For example, by using 'Control.Exception.bracket_': +-- +-- > bracket_ useAlternateScreenBuffer useNormalScreenBuffer action +-- +-- @since 0.11.4 +useAlternateScreenBuffer :: IO () +useAlternateScreenBuffer = hUseAlternateScreenBuffer stdout + +-- | Use the Normal Screen Buffer. If currently using the Alternate Screen +-- Buffer, it will clear the Alternate Screen Buffer, and switch to the Normal +-- Screen Buffer. It will always restore the saved cursor position. +-- +-- @since 0.11.4 +useNormalScreenBuffer :: IO () +useNormalScreenBuffer = hUseNormalScreenBuffer stdout + +-- Introduce a hyperlink with (key, value) parameters. Some terminals support +-- an @id@ parameter key, so that hyperlinks with the same @id@ value are +-- treated as connected. +-- +-- @since 0.11.3 +hHyperlinkWithParams:: + Handle + -> [(String, String)] -- Parameters + -> String -- URI + -> String -- Link text + -> IO () +hHyperlinkWithParams h params uri link = + hPutStr h $ hyperlinkWithParamsCode params uri link + +-- | Introduce a hyperlink with (key, value) parameters. Some terminals support +-- an @id@ parameter key, so that hyperlinks with the same @id@ value are +-- treated as connected. +-- +-- @since 0.11.3 +hyperlinkWithParams :: + [(String, String)] -- ^ Parameters + -> String -- ^ URI + -> String -- ^ Link text + -> IO () +hyperlinkWithParams = hHyperlinkWithParams stdout + +-- Introduce a hyperlink. +-- +-- @since 0.11.3 +hHyperlink :: + Handle + -> String -- URI + -> String -- Link text + -> IO () +hHyperlink h = hHyperlinkWithParams h [] + +-- | Introduce a hyperlink. +-- +-- @since 0.11.3 +hyperlink :: + String -- ^ URI + -> String -- ^ Link text + -> IO () +hyperlink = hHyperlink stdout + +-- Introduce a hyperlink with an identifier for the link. Some terminals +-- support an identifier, so that hyperlinks with the same identifier are +-- treated as connected. +-- +-- @since 0.11.3 +hHyperlinkWithId :: + Handle + -> String -- Identifier for the link + -> String -- URI + -> String -- Link text + -> IO () +hHyperlinkWithId h linkId = hHyperlinkWithParams h [("id", linkId)] + +-- | Introduce a hyperlink with an identifier for the link. Some terminals +-- support an identifier, so that hyperlinks with the same identifier are +-- treated as connected. +-- +-- @since 0.11.3 +hyperlinkWithId :: + String -- ^ Identifier for the link + -> String -- ^ URI + -> String -- ^ Link text + -> IO () +hyperlinkWithId = hHyperlinkWithId stdout + +-- Set the terminal window title and icon name (that is, the text for the +-- window in the Start bar, or similar). +hSetTitle :: + Handle + -> String -- New window title and icon name + -> IO () +hSetTitle h title = hPutStr h $ setTitleCode title + +-- | Set the terminal window title and icon name (that is, the text for the +-- window in the Start bar, or similar). +setTitle :: String -- ^ New window title and icon name + -> IO () +setTitle = hSetTitle stdout + +-- | Use heuristics to determine whether the functions defined in this package +-- will work with a given handle. +-- +-- If the handle is not writable (that is, it cannot manage output - see +-- 'System.IO.hIsWritable'), then @pure False@ is returned. +-- +-- For Unix-like operating systems, the current implementation checks +-- that: (1) the handle is a terminal; and (2) a @TERM@ environment variable is +-- not set to @dumb@ (which is what the GNU Emacs text editor sets for its +-- integrated terminal). +-- +-- For Windows, the current implementation checks: first that (1) the handle is +-- a terminal, (2) a @TERM@ environment variable is not set to @dumb@, and (3) +-- the processing of \'ANSI\' control characters in output is enabled; and +-- second, as an alternative, whether the handle is connected to a \'mintty\' +-- terminal. (That is because the function 'System.IO.hIsTerminalDevice' is used +-- to check if the handle is a terminal. However, where a non-native Windows +-- terminal (such as \'mintty\') is implemented using redirection, that function +-- will not identify a handle to the terminal as a terminal.) If it is not +-- already enabled, this function does *not* enable the processing of \'ANSI\' +-- control characters in output (see 'hNowSupportsANSI'). +-- +-- @since 0.6.2 +hSupportsANSI :: Handle -> IO Bool +hSupportsANSI = Internal.hSupportsANSI + +-- | With one exception, equivalent to 'hSupportsANSI'. The exception is that, +-- on Windows only, if a @TERM@ environment variable is not set to @dumb@ and +-- the processing of \'ANSI\' control characters in output is not enabled, this +-- function first tries to enable such processing. +-- +-- @since 1.0.1 +hNowSupportsANSI :: Handle -> IO Bool +hNowSupportsANSI = Internal.hNowSupportsANSI + +-- | Some terminals (e.g. Emacs) are not fully ANSI compliant but can support +-- ANSI colors. This can be used in such cases, if colors are all that is +-- needed. +-- +-- @since 0.9 +hSupportsANSIColor :: Handle -> IO Bool +hSupportsANSIColor = Internal.hSupportsANSIColor + +-- | Use heuristics to determine whether a given handle will support \'ANSI\' +-- control characters in output. The function is consistent with +-- 'hNowSupportsANSI'. +-- +-- This function is deprecated as, from version 1.0, the package no longer +-- supports legacy versions of Windows that required emulation. +-- +-- @since 0.8.1 +{-# DEPRECATED hSupportsANSIWithoutEmulation "See Haddock documentation and hNowSupportsANSI." #-} +hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) +hSupportsANSIWithoutEmulation h = Just <$> hNowSupportsANSI h + +-- | Parses the characters emitted by 'reportCursorPosition' into the console +-- input stream. Returns the cursor row and column as a tuple. +-- +-- For example, if the characters emitted by 'reportCursorPosition' are in +-- 'String' @input@ then the parser could be applied like this: +-- +-- > let result = readP_to_S cursorPosition input +-- > case result of +-- > [] -> putStrLn $ "Error: could not parse " ++ show input +-- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row +-- > ++ " and column" ++ show column ++ "." +-- > (_:_) -> putStrLn $ "Error: parse not unique" +-- +-- @since 0.7.1 +cursorPosition :: ReadP (Int, Int) +cursorPosition = do + void $ char '\ESC' + void $ char '[' + row <- decimal -- A non-negative whole decimal number + void $ char ';' + col <- decimal -- A non-negative whole decimal number + void $ char 'R' + pure (read row, read col) + where + digit = satisfy isDigit + decimal = many1 digit + +-- | Attempts to get the reported cursor position data from the console input +-- stream. The function is intended to be called immediately after +-- 'reportCursorPosition' (or related functions) have caused characters to be +-- emitted into the stream. +-- +-- For example, on a Unix-like operating system: +-- +-- > -- set no buffering (if 'no buffering' is not already set, the contents of +-- > -- the buffer will be discarded, so this needs to be done before the cursor +-- > -- positon is emitted) +-- > hSetBuffering stdin NoBuffering +-- > -- ensure that echoing is off +-- > input <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do +-- > hSetEcho stdin False +-- > reportCursorPosition +-- > hFlush stdout -- ensure the report cursor position code is sent to the +-- > -- operating system +-- > getReportedCursorPosition +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) +-- +-- @since 0.7.1 +getReportedCursorPosition :: IO String +getReportedCursorPosition = Internal.getReportedCursorPosition + +-- | Attempts to get the reported cursor position, combining the functions +-- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. Any +-- position @(row, column)@ is translated to be 0-based (that is, the top-left +-- corner is at @(0, 0)@), consistent with `setCursorColumn` and +-- `setCursorPosition`. (Note that the information emitted into the console +-- input stream by 'reportCursorPosition' is 1-based.) Returns 'Nothing' if any +-- data emitted by 'reportCursorPosition', obtained by +-- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'. Uses +-- 'stdout'. If 'stdout' will be redirected, see 'hGetCursorPosition' for a more +-- general function. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) +-- +-- This operation may fail with an error if 'stdin' has been redirected. +-- +-- @since 0.10.3 +getCursorPosition :: IO (Maybe (Int, Int)) +getCursorPosition = hGetCursorPosition stdout + +-- | Attempts to get the reported cursor position, combining the functions +-- 'hReportCursorPosition' (with the specified handle), +-- 'getReportedCursorPosition' and 'cursorPosition'. Any position +-- @(row, column)@ is translated to be 0-based (that is, the top-left corner is +-- at @(0, 0)@), consistent with 'hSetCursorColumn' and 'hSetCursorPosition'. +-- (Note that the information emitted into the console input stream by +-- 'hReportCursorPosition' is 1-based.) Returns 'Nothing' if any data emitted by +-- 'hReportCursorPosition', obtained by 'getReportedCursorPosition', cannot be +-- parsed by 'cursorPosition'. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) +-- +-- This operation may fail with an error if 'stdin' has been redirected. +-- +-- @since 0.10.1 +hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) +hGetCursorPosition h = fmap to0base <$> getCursorPosition' + where + to0base (row, col) = (row - 1, col - 1) + getCursorPosition' = do + input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do + -- set no buffering (if 'no buffering' is not already set, the contents of + -- the buffer will be discarded, so this needs to be done before the + -- cursor positon is emitted) + hSetBuffering stdin NoBuffering + -- ensure that echoing is off + bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False + clearStdin + hReportCursorPosition h + -- Ensure the report cursor position code is sent to the operating + -- system: + hFlush h + -- On Windows and in Windows Terminal v1.22.12111.0 (at least), it seems + -- that a moment's delay is required in order to allow sufficient time + -- for the reported information to reach the standard input channel: + threadDelay 1 + getReportedCursorPosition + case readP_to_S cursorPosition input of + [] -> pure Nothing + [((row, col),_)] -> pure $ Just (row, col) + (_:_) -> pure Nothing + clearStdin = do + isReady <- hReady stdin + when isReady $ do + _ <-getChar + clearStdin + +-- | Looking for a way to get layer colors? See 'getLayerColor'. +-- +-- Emit the layerColor into the console input stream, immediately after +-- being recognised on the output stream, as: +-- @ESC ] \<Ps> ; rgb: \<red> ; \<green> ; \<blue> \<ST>@ +-- where @\<Ps>@ is @10@ for 'Foreground' and @11@ for 'Background'; @\<red>@, +-- @\<green>@ and @\<blue>@ are the color channel values in hexadecimal (4, 8, +-- 12 and 16 bit values are possible, although 16 bit values are most common); +-- and @\<ST>@ is the STRING TERMINATOR (ST). ST depends on the terminal +-- software and may be the @BEL@ character or @ESC \\@ characters. +-- +-- This function may be of limited, or no, use on Windows operating systems +-- because (1) the function is not supported on native terminals and is +-- emulated, but the emulation does not work on Windows Terminal and (2) of +-- difficulties in obtaining the data emitted into the console input stream. +-- +-- Underlining is not supported. +-- +-- @since 0.11.4 +reportLayerColor :: ConsoleLayer -> IO () +reportLayerColor = hReportLayerColor stdout + +-- @since 0.11.4 +hReportLayerColor :: Handle -> ConsoleLayer -> IO () +hReportLayerColor h layer = hPutStr h $ reportLayerColorCode layer + +-- | Attempts to get the reported layer color data from the console input +-- stream. The function is intended to be called immediately after +-- 'reportLayerColor' (or related functions) have caused characters to be +-- emitted into the stream. +-- +-- For example, on a Unix-like operating system: +-- +-- > -- set no buffering (if 'no buffering' is not already set, the contents of +-- > -- the buffer will be discarded, so this needs to be done before the cursor +-- > -- positon is emitted) +-- > hSetBuffering stdin NoBuffering +-- > -- ensure that echoing is off +-- > input <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do +-- > hSetEcho stdin False +-- > reportLayerColor Foreground +-- > hFlush stdout -- ensure the report cursor position code is sent to the +-- > -- operating system +-- > getReportedLayerColor Foreground +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) +-- +-- Underlining is not supported. +-- +-- @since 0.11.4 +getReportedLayerColor :: ConsoleLayer -> IO String +getReportedLayerColor = Internal.getReportedLayerColor + +-- | Attempts to get the reported layer color, combining the functions +-- 'reportLayerColor', 'getReportedLayerColor' and 'layerColor'. Any RGB color +-- is scaled to be 16 bits per channel, the most common format reported by +-- terminal software. Returns 'Nothing' if any data emitted by +-- 'reportLayerColor', obtained by 'getReportedLayerColor', cannot be parsed by +-- 'layerColor'. Uses 'stdout'. If 'stdout' will be redirected, see +-- 'hGetLayerColor' for a more general function. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) This function also relies on +-- emulation that does not work on Windows Terminal. +-- +-- Underlining is not supported. +-- +-- This operation may fail with an error if 'stdin' has been redirected. +-- +-- @since 0.11.4 +getLayerColor :: ConsoleLayer -> IO (Maybe(RGB Word16)) +getLayerColor = hGetLayerColor stdout + +-- | Attempts to get the reported layer color, combining the functions +-- 'hReportLayerColor', 'getReportedLayerColor' and 'layerColor'. Any RGB color +-- is scaled to be 16 bits per channel, the most common format reported by +-- terminal software. Returns 'Nothing' if any data emitted by +-- 'hReportLayerColor', obtained by 'getReportedLayerColor', cannot be parsed by +-- 'layerColor'. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) This function also relies on +-- emulation that does not work on Windows Terminal. +-- +-- Underlining is not supported. +-- +-- This operation may fail with an error if 'stdin' has been redirected. +-- +-- @since 0.11.4 +hGetLayerColor :: Handle -> ConsoleLayer -> IO (Maybe (RGB Word16)) +hGetLayerColor h layer = do + input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do + -- set no buffering (if 'no buffering' is not already set, the contents of + -- the buffer will be discarded, so this needs to be done before the + -- cursor positon is emitted) + hSetBuffering stdin NoBuffering + -- ensure that echoing is off + bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False + clearStdin + hReportLayerColor h layer + -- Ensure the report cursor position code is sent to the operating system: + hFlush h + -- On Windows and in Windows Terminal v1.22.12111.0 (at least), it seems + -- that a moment's delay is required in order to allow sufficient time for + -- the reported information to reach the standard input channel: + threadDelay 1 + getReportedLayerColor layer + case readP_to_S (layerColor layer) input of + [] -> pure Nothing + [(col, _)] -> pure $ Just col + (_:_) -> pure Nothing + where + clearStdin = do + isReady <- hReady stdin + when isReady $ do + _ <-getChar + clearStdin + +-- | Parses the characters emitted by 'reportLayerColor' into the console input +-- stream. +-- +-- For example, if the characters emitted by 'reportLayerColor' are in 'String' +-- @input@ then the parser could be applied like this: +-- +-- > let result = readP_to_S (layerColor layer) input +-- > case result of +-- > [] -> putStrLn $ "Error: could not parse " ++ show input +-- > [(col, _)] -> putStrLn $ "The color was " ++ show col ++ "." +-- > (_:_) -> putStrLn $ "Error: parse not unique" +-- +-- Underlining is not supported. +-- +-- @since 0.11.4 +layerColor :: ConsoleLayer -> ReadP (RGB Word16) +layerColor layer = do + void $ string "\ESC]" + void $ string $ case layer of + Foreground -> "10" + Background -> "11" + Underlining -> fail "reportLayerColor does not support underlining" + void $ string ";rgb:" + redHex <- hexadecimal -- A non-negative whole hexadecimal number + void $ char '/' + greenHex <- hexadecimal -- A non-negative whole hexadecimal number + void $ char '/' + blueHex <- hexadecimal -- A non-negative whole hexadecimal number + void $ string "\BEL" <++ string "\ESC\\" + let lenRed = length redHex + lenGreen = length greenHex + lenBlue = length blueHex + if lenRed == lenGreen && lenGreen == lenBlue + then + if lenRed == 0 || lenRed > 4 + then fail "Color format not recognised" + else + let m = 16 ^ (4 - lenRed) + r = fromIntegral $ m * hexToInt redHex + g = fromIntegral $ m * hexToInt greenHex + b = fromIntegral $ m * hexToInt blueHex + in pure $ RGB r g b + else fail "Color format not recognised" + where + hexDigit = satisfy isHexDigit + hexadecimal = many1 hexDigit + hexToInt hex = foldl (\d a -> d * 16 + a) 0 (map digitToInt hex) + +-- | Attempts to get the current terminal size (height in rows, width in +-- columns). +-- +-- There is no \'ANSI\' control character sequence that reports the terminal +-- size. So, it attempts to set the cursor position beyond the bottom right +-- corner of the terminal and then use 'getCursorPosition' to query the console +-- input stream. It works only on terminals that support each step and if data +-- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if +-- 'stdin' is connected to a terminal.) Uses 'stdout'. If 'stdout' will be +-- redirected, see 'System.IO.hGetTerminalSize' for a more general function. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on Windows' Console API. (Command Prompt and +-- PowerShell are based on the Console API.) +-- +-- This operation may fail with an error if 'stdin' has been redirected. +-- +-- For a different approach, one that does not use control character sequences +-- and works when 'stdin' is redirected, see the +-- <https://hackage.haskell.org/package/terminal-size terminal-size> package. +-- +-- @since 0.9 +getTerminalSize :: IO (Maybe (Int, Int)) +getTerminalSize = hGetTerminalSize stdout + +-- | Attempts to get the current terminal size (height in rows, width in +-- columns), by writing control character sequences to the specified handle +-- (which will typically be 'stdout' or 'System.IO.stderr'). +-- +-- There is no \'ANSI\' control character sequence that reports the terminal +-- size. So, it attempts to set the cursor position beyond the bottom right +-- corner of the terminal and then use 'hGetCursorPosition' to query the console +-- input stream. It works only on terminals that support each step and if data +-- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if +-- 'stdin' is connected to a terminal.) +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Windows' Console API. (Command Prompt +-- and PowerShell are based on the Console API.) +-- +-- This operation may fail with an error if 'stdin' has been redirected. +-- +-- For a different approach, one that does not use control character sequences +-- and works when 'stdin' is redirected, see the +-- <https://hackage.haskell.org/package/terminal-size terminal-size> package. +-- +-- @since 0.10.1 +hGetTerminalSize :: Handle -> IO (Maybe (Int, Int)) +hGetTerminalSize h = do + hSaveCursor h + hSetCursorPosition h 9999 9999 -- Attempt to set the cursor position beyond + -- the bottom right corner of the terminal. + mPos <- hGetCursorPosition h + hRestoreCursor h + hFlush h -- ensure the restore cursor position code is sent to the + -- operating system + pure $ fmap (\(r, c) -> (r + 1, c + 1)) mPos + +-- 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 () +hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs + +-- | 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 () +hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode +hClearFromCursorToScreenBeginning h + = hPutStr h clearFromCursorToScreenBeginningCode +hClearScreen h = hPutStr h clearScreenCode + +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO () +clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout +clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout +clearScreen = hClearScreen stdout + +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: + Handle + -> IO () +hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode +hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode +hClearLine h = hPutStr h clearLineCode + +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO () +clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout +clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout +clearLine = hClearLine stdout + +hEnableLineWrap, hDisableLineWrap :: + Handle + -> IO () +hEnableLineWrap h = hPutStr h enableLineWrapCode +hDisableLineWrap h = hPutStr h disableLineWrapCode + +enableLineWrap, disableLineWrap :: IO () +enableLineWrap = hEnableLineWrap stdout +disableLineWrap = hDisableLineWrap stdout + +hScrollPageUp, hScrollPageDown :: + Handle + -> Int -- Number of lines to scroll by + -> IO () +hScrollPageUp h n = hPutStr h $ scrollPageUpCode n +hScrollPageDown h n = hPutStr h $ scrollPageDownCode n + +scrollPageUp, scrollPageDown :: + Int -- ^ Number of lines to scroll by + -> IO () +scrollPageUp = hScrollPageUp stdout +scrollPageDown = hScrollPageDown stdout
− src/System/Console/ANSI/Codes.hs
@@ -1,207 +0,0 @@--- | This module exports functions that return 'String' values containing codes --- in accordance with the \'ANSI\' standards for control character sequences --- described in the documentation of module "System.Console.ANSI". --- --- The module "System.Console.ANSI" exports functions with the same names as --- those in this module. On some versions of Windows, the terminal in use may --- not be ANSI-capable. When that is the case, the same-named functions exported --- by module "System.Console.ANSI" return \"\", for the reasons set out in the --- documentation of that module. --- --- Consequently, if module "System.Console.ANSI" is also imported, this module --- is intended to be imported qualified, to avoid name clashes with those --- functions. For example: --- --- > import qualified System.Console.ANSI.Codes as ANSI --- -module System.Console.ANSI.Codes - ( - -- * Basic data types - module System.Console.ANSI.Types - - -- * Cursor movement by character - , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode - - -- * Cursor movement by line - , cursorUpLineCode, cursorDownLineCode - - -- * Directly changing cursor position - , setCursorColumnCode, setCursorPositionCode - - -- * Saving, restoring and reporting cursor position - , saveCursorCode, restoreCursorCode, reportCursorPositionCode - - -- * Clearing parts of the screen - , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode - , clearScreenCode, clearFromCursorToLineEndCode - , clearFromCursorToLineBeginningCode, clearLineCode - - -- * Scrolling the screen - , scrollPageUpCode, scrollPageDownCode - - -- * Select Graphic Rendition mode: colors and other whizzy stuff - , setSGRCode - - -- * Cursor visibilty changes - , hideCursorCode, showCursorCode - - -- * Changing the title - -- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the - -- right direction on xterm title setting on haskell-cafe. The "0" - -- signifies that both the title and "icon" text should be set: i.e. the - -- text for the window in the Start bar (or similar) as well as that in - -- the actual window title. This is chosen for consistent behaviour - -- between Unixes and Windows. - , setTitleCode - - -- * Utilities - , colorToCode, csi, sgrToCode - ) where - -import Data.List (intersperse) - -import Data.Colour.SRGB (toSRGB24, RGB (..)) - -import System.Console.ANSI.Types - --- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int', --- returns the control sequence comprising the control function CONTROL --- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\') --- and ending with the @controlFunction@ character(s) that identifies the --- control function. -csi :: [Int] -- ^ List of parameters for the control sequence - -> String -- ^ Character(s) that identify the control function - -> String -csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code - --- | 'colorToCode' @color@ returns the 0-based index of the color (one of the --- eight colors in the 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" - --- | Code to move the cursor to the specified column. The column numbering is --- 0-based (that is, the left-most column is numbered 0). -setCursorColumnCode :: Int -- ^ 0-based column to move to - -> String -setCursorColumnCode n = csi [n + 1] "G" - --- | Code to move the cursor to the specified position (row and column). The --- position is 0-based (that is, the top-left corner is at row 0 column 0). -setCursorPositionCode :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> String -setCursorPositionCode n m = csi [n + 1, m + 1] "H" - --- | @since 0.7.1 -saveCursorCode, restoreCursorCode :: String -saveCursorCode = "\ESC7" -restoreCursorCode = "\ESC8" - --- | Code to emit the cursor position into the console input stream, immediately --- after being recognised on the output stream, as: --- @ESC [ \<cursor row> ; \<cursor column> R@ --- --- Note that the information that is emitted is 1-based (the top-left corner is --- at row 1 column 1) but 'setCursorPositionCode' is 0-based. --- --- In isolation of 'getReportedCursorPosition' or 'getCursorPosition0', 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>). --- --- @since 0.7.1 -reportCursorPositionCode :: String - -reportCursorPositionCode = csi [] "6n" - -clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, - clearScreenCode :: String -clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, - clearLineCode :: String - -clearFromCursorToScreenEndCode = csi [0] "J" -clearFromCursorToScreenBeginningCode = csi [1] "J" -clearScreenCode = csi [2] "J" -clearFromCursorToLineEndCode = csi [0] "K" -clearFromCursorToLineBeginningCode = csi [1] "K" -clearLineCode = csi [2] "K" - -scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by - -> String -scrollPageUpCode n = csi [n] "S" -scrollPageDownCode n = csi [n] "T" - -setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the - -- current console SGR mode. An empty list of commands is - -- equivalent to the list @[Reset]@. Commands are applied - -- left to right. - -> String -setSGRCode sgrs = csi (concatMap sgrToCode sgrs) "m" - -hideCursorCode, showCursorCode :: String -hideCursorCode = csi [] "?25l" -showCursorCode = csi [] "?25h" - - --- | XTerm control sequence to set the Icon Name and Window Title. -setTitleCode :: String -- ^ New Icon Name and Window Title - -> String -setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007"
− src/System/Console/ANSI/Types.hs
@@ -1,71 +0,0 @@--- | 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)
− src/System/Console/ANSI/Unix.hs
@@ -1,118 +0,0 @@-{-# 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.Environment (getEnvironment) -import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, - hIsTerminalDevice, hIsWritable, 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 - --- hSupportsANSI :: Handle -> IO Bool --- (See Common-Include.hs for Haddock documentation) --- --- Borrowed from an HSpec patch by Simon Hengel --- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) -hSupportsANSI h = (&&) <$> hIsTerminalDevice h <*> isNotDumb - where - -- cannot use lookupEnv since it only appeared in GHC 7.6 - isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment - --- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) --- (See Common-Include.hs for Haddock documentation) -hSupportsANSIWithoutEmulation h = - Just <$> ((&&) <$> hIsWritable h <*> hSupportsANSI h) - --- getReportedCursorPosition :: IO String --- (See Common-Include.hs for Haddock documentation) -getReportedCursorPosition = bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- Turn echo off - 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) -{-# DEPRECATED getCursorPosition "Use getCursorPosition0 instead." #-} -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
− src/System/Console/ANSI/Windows.hs
@@ -1,196 +0,0 @@-{-# 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, stdout) - -import System.Console.ANSI.Types -import qualified System.Console.ANSI.Unix as U -import System.Console.ANSI.Windows.Detect (ANSISupport (..), - ConsoleDefaultState (..), aNSISupport) -import qualified System.Console.ANSI.Windows.Emulator as E - --- This file contains code that is common to modules System.Console.ANSI.Unix, --- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, inclduding the related Haddock --- documentation. -#include "Common-Include.hs" --- This file contains code that is common save that different code is required --- in the case of the module System.Console.ANSI.Windows.Emulator (see the file --- Common-Include-Emulator.hs in respect of the latter). -#include "Common-Include-Enabled.hs" - --- | A helper function which returns the native or emulated version, depending --- on `aNSISupport`. -nativeOrEmulated :: a -> a -> a -nativeOrEmulated native emulated = case aNSISupport of - Native -> native - Emulated _ -> emulated - --- | A helper function which returns the native or emulated version, depending --- on `aNSISupport`, where the emulator uses the default console state. -nativeOrEmulatedWithDefault :: a -> (ConsoleDefaultState -> a) -> a -nativeOrEmulatedWithDefault native emulated = case aNSISupport of - Native -> native - Emulated def -> emulated def - - --- * Cursor movement by character -hCursorUp = nativeOrEmulated U.hCursorUp E.hCursorUp -hCursorDown = nativeOrEmulated U.hCursorDown E.hCursorDown -hCursorForward = nativeOrEmulated U.hCursorForward E.hCursorForward -hCursorBackward = nativeOrEmulated U.hCursorBackward E.hCursorBackward - -cursorUpCode :: Int -> String -cursorUpCode = nativeOrEmulated U.cursorUpCode E.cursorUpCode - -cursorDownCode :: Int -> String -cursorDownCode = nativeOrEmulated U.cursorDownCode E.cursorDownCode - -cursorForwardCode :: Int -> String -cursorForwardCode = nativeOrEmulated U.cursorForwardCode E.cursorForwardCode - -cursorBackwardCode :: Int -> String -cursorBackwardCode = nativeOrEmulated U.cursorBackwardCode E.cursorBackwardCode - --- * Cursor movement by line -hCursorUpLine = nativeOrEmulated U.hCursorUpLine E.hCursorUpLine -hCursorDownLine = nativeOrEmulated U.hCursorDownLine E.hCursorDownLine - -cursorUpLineCode :: Int -> String -cursorUpLineCode = nativeOrEmulated U.cursorUpLineCode E.cursorUpLineCode - -cursorDownLineCode :: Int -> String -cursorDownLineCode = nativeOrEmulated U.cursorDownLineCode E.cursorDownLineCode - --- * Directly changing cursor position -hSetCursorColumn = nativeOrEmulated U.hSetCursorColumn E.hSetCursorColumn - -setCursorColumnCode :: Int -> String -setCursorColumnCode = nativeOrEmulated - U.setCursorColumnCode E.setCursorColumnCode - -hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition - -setCursorPositionCode :: Int -> Int -> String -setCursorPositionCode = nativeOrEmulated - U.setCursorPositionCode E.setCursorPositionCode - --- * Saving, restoring and reporting cursor position -hSaveCursor = nativeOrEmulated U.hSaveCursor E.hSaveCursor -hRestoreCursor = nativeOrEmulated U.hRestoreCursor E.hRestoreCursor -hReportCursorPosition = nativeOrEmulated - U.hReportCursorPosition E.hReportCursorPosition - -saveCursorCode :: String -saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode - -restoreCursorCode :: String -restoreCursorCode = nativeOrEmulated U.restoreCursorCode E.restoreCursorCode - -reportCursorPositionCode :: String -reportCursorPositionCode = nativeOrEmulated - U.reportCursorPositionCode E.reportCursorPositionCode - --- * Clearing parts of the screen -hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault - U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd -hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault - U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning -hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen - -clearFromCursorToScreenEndCode :: String -clearFromCursorToScreenEndCode = nativeOrEmulated - U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode - -clearFromCursorToScreenBeginningCode :: String -clearFromCursorToScreenBeginningCode = nativeOrEmulated - U.clearFromCursorToScreenBeginningCode E.clearFromCursorToScreenBeginningCode - -clearScreenCode :: String -clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode - -hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault - U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd -hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault - U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning -hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine - -clearFromCursorToLineEndCode :: String -clearFromCursorToLineEndCode = nativeOrEmulated - U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode - -clearFromCursorToLineBeginningCode :: String -clearFromCursorToLineBeginningCode = nativeOrEmulated - U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode - -clearLineCode :: String -clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode - --- * Scrolling the screen -hScrollPageUp = nativeOrEmulatedWithDefault U.hScrollPageUp E.hScrollPageUp -hScrollPageDown = nativeOrEmulatedWithDefault U.hScrollPageDown E.hScrollPageDown - -scrollPageUpCode :: Int -> String -scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode - -scrollPageDownCode :: Int -> String -scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode - --- * Select Graphic Rendition mode: colors and other whizzy stuff --- --- The following SGR codes are NOT implemented by Windows 10 Threshold 2: --- 2 SetConsoleIntensity FaintIntensity --- 3 SetItalicized True --- 5 SetBlinkSpeed SlowBlink --- 6 SetBlinkSpeed RapidBlink --- 8 SetVisible False --- 21 SetUnderlining DoubleUnderline --- 23 SetItalicized False --- 25 SetBlinkSpeed NoBlink --- 28 SetVisible True - -hSetSGR = nativeOrEmulatedWithDefault U.hSetSGR E.hSetSGR - -setSGRCode :: [SGR] -> String -setSGRCode = nativeOrEmulated U.setSGRCode E.setSGRCode - --- * Cursor visibilty changes -hHideCursor = nativeOrEmulated U.hHideCursor E.hHideCursor -hShowCursor = nativeOrEmulated U.hShowCursor E.hShowCursor - -hideCursorCode :: String -hideCursorCode = nativeOrEmulated U.hideCursorCode E.hideCursorCode - -showCursorCode :: String -showCursorCode = nativeOrEmulated U.showCursorCode E.showCursorCode - --- * Changing the title -hSetTitle = nativeOrEmulated U.hSetTitle E.hSetTitle - -setTitleCode :: String -> String -setTitleCode = nativeOrEmulated U.setTitleCode E.setTitleCode - --- hSupportsANSI :: Handle -> IO Bool --- (See Common-Include.hs for Haddock documentation) -hSupportsANSI = E.hSupportsANSI - --- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) --- (See Common-Include.hs for Haddock documentation) -hSupportsANSIWithoutEmulation = E.hSupportsANSIWithoutEmulation - --- getReportedCursorPosition :: IO String --- (See Common-Include.hs for Haddock documentation) -getReportedCursorPosition = E.getReportedCursorPosition - --- getCursorPosition :: IO (Maybe (Int, Int)) --- (See Common-Include.hs for Haddock documentation) -{-# DEPRECATED getCursorPosition "Use getCursorPosition0 instead." #-} -getCursorPosition = E.getCursorPosition
− src/System/Console/ANSI/Windows/Detect.hs
@@ -1,113 +0,0 @@-{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Windows.Detect - ( - ANSISupport (..) - , ConsoleDefaultState (..) - , aNSISupport - , detectHandleSupportsANSI - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif - -import Control.Exception (SomeException(..), throwIO, try) -import Data.Bits ((.&.), (.|.)) -import System.Console.MinTTY (isMinTTYHandle) -import System.IO (Handle, hIsWritable, stdout) -import System.IO.Unsafe (unsafePerformIO) - -import System.Console.ANSI.Windows.Foreign (ConsoleException(..), - CONSOLE_SCREEN_BUFFER_INFO (..), DWORD, HANDLE, WORD, - bACKGROUND_INTENSE_WHITE, eNABLE_VIRTUAL_TERMINAL_PROCESSING, - fOREGROUND_INTENSE_WHITE, getConsoleMode, getConsoleScreenBufferInfo, - iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, withHandleToHANDLE) - --- | The default state of the console. -data ConsoleDefaultState = ConsoleDefaultState - { defaultForegroundAttributes :: WORD -- ^ Foreground attributes - , defaultBackgroundAttributes :: WORD -- ^ Background attributes - } deriving (Eq, Show) - --- | How the console is assumed to support ANSI control codes. -data ANSISupport - = Native -- ^ Assume ANSI-enabled - | Emulated ConsoleDefaultState -- ^ Not ANSI-enabled (including the state of - -- the console when that status was determined) - deriving (Eq, Show) - --- | Terminals on Windows -data Terminal - = NativeANSIEnabled -- ^ Windows 10 (Command Prompt or PowerShell) - | NativeANSIIncapable -- ^ Versions before Windows 10 (Command Prompt or - -- PowerShell) - | Mintty -- ^ ANSI-enabled - | UnknownTerminal - --- | This function assumes that once it is first established whether or not the --- Windows console requires emulation, that will not change. If the console --- requires emulation, the state of the console is considered to be its default --- state. -{-# NOINLINE aNSISupport #-} -aNSISupport :: ANSISupport -aNSISupport = unsafePerformIO $ withHandleToHANDLE stdout $ withHANDLE - (throwIO $ ConsoleException 6) -- Invalid handle or no handle - (\h -> do - terminal <- handleToTerminal h - case terminal of - NativeANSIIncapable -> Emulated <$> consoleDefaultState h - _ -> return Native) - where - consoleDefaultState h = do - info <- getConsoleScreenBufferInfo h - let attributes = csbi_attributes info - fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE - bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE - return ConsoleDefaultState - { defaultForegroundAttributes = fgAttributes - , defaultBackgroundAttributes = bgAttributes } - --- | This function tests that the handle is writable. If what is attached to the --- handle is not recognised as a known terminal, it returns @return Nothing@. -detectHandleSupportsANSI :: Handle -> IO (Maybe Bool) -detectHandleSupportsANSI handle = do - isWritable <- hIsWritable handle - if isWritable - then withHandleToHANDLE handle $ withHANDLE - (return $ Just False) -- Invalid handle or no handle - (\h -> do - terminal <- handleToTerminal h - case terminal of - NativeANSIIncapable -> return (Just False) - UnknownTerminal -> return Nothing -- Not sure! - _ -> return (Just True)) - else return (Just False) -- Not an output handle - --- | This function assumes that the Windows handle is writable. -handleToTerminal :: HANDLE -> IO Terminal -handleToTerminal h = do - tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD) - case tryMode of - Left _ -> do -- No ConHost mode - isMinTTY <- isMinTTYHandle h - if isMinTTY - then return Mintty -- 'mintty' terminal emulator - else return UnknownTerminal -- Not sure! - Right mode -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 - then return NativeANSIEnabled -- VT processing already enabled - else do - let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING - trySetMode <- try (setConsoleMode h mode') - :: IO (Either SomeException ()) - case trySetMode of - Left _ -> return NativeANSIIncapable -- Can't enable VT processing - Right () -> return NativeANSIEnabled -- VT processing enabled - --- | This function applies another to the Windows handle, if the handle is --- valid. If it is invalid, the specified default action is returned. -withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a -withHANDLE invalid action h = - if h == iNVALID_HANDLE_VALUE || h == nullHANDLE - then invalid -- Invalid handle or no handle - else action h
− src/System/Console/ANSI/Windows/Emulator.hs
@@ -1,497 +0,0 @@-{-# OPTIONS_HADDOCK hide #-} - -module System.Console.ANSI.Windows.Emulator - ( -#include "Exports-Include.hs" - ) where - -import Control.Exception (catchJust, IOException) -import qualified Control.Exception as CE (catch) -import Control.Monad (unless) -import Data.Bits ((.&.), (.|.), complement, shiftL, shiftR) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (foldl', minimumBy) -import Data.Maybe (mapMaybe) -import qualified Data.Map.Strict as Map (Map, empty, insert, lookup) -import System.Environment (getEnvironment) -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.MinTTY (isMinTTYHandle) - -import System.Console.ANSI.Types -import qualified System.Console.ANSI.Unix as Unix -import System.Console.ANSI.Windows.Detect -import System.Console.ANSI.Windows.Emulator.Codes -import System.Console.ANSI.Windows.Foreign - --- This file contains code that is common to modules System.Console.ANSI.Unix, --- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, inclduding the related Haddock --- documentation. -#include "Common-Include.hs" --- This file contains code that is required in the case of the module --- System.Console.ANSI.Windows.Emulator and differs from the common code in --- file Common-Include-Enabled.hs. -#include "Common-Include-Emulator.hs" - -withHandle :: Handle -> (HANDLE -> IO a) -> IO a -withHandle handle action = do - -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API - -- call to change the console because on Windows the arrival of - -- API-initiated state changes is not necessarily synchronised with that of - -- the text they are attempting to modify. - hFlush handle - withHandleToHANDLE handle action - --- Unfortunately, the emulator is not perfect. In particular, it has a tendency --- to die with exceptions about invalid handles when it is used with certain --- Windows consoles (e.g. mintty, terminator, or cygwin sshd). --- --- This happens because in those environments the stdout family of handles are --- not actually associated with a real console. --- --- My observation is that every time I've seen this in practice, the handle we --- have instead of the actual console handle is there so that the terminal --- supports ANSI escape codes. So 99% of the time, the correct thing to do is --- just to fall back on the Unix module to output the ANSI codes and hope for --- the best. -emulatorFallback :: IO a -> IO a -> IO a -emulatorFallback fallback first_try - = catchJust invalidHandle first_try (const fallback) - where - invalidHandle (ConsoleException 6) = Just () -- 6 is the Windows error code - -- for invalid handles - invalidHandle (_) = Nothing - -adjustCursorPosition :: HANDLE - -> (SHORT -> SHORT -> SHORT) - -> (SHORT -> SHORT -> SHORT) - -> IO () -adjustCursorPosition handle change_x change_y = do - screen_buffer_info <- getConsoleScreenBufferInfo handle - let window = csbi_window screen_buffer_info - (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 - maybe (return ()) (setConsoleCursorPosition handle) result - -hReportCursorPosition h - = emulatorFallback (Unix.hReportCursorPosition h) $ withHandle h $ - \handle -> do - result <- getConsoleScreenBufferInfo handle - let (COORD cx cy) = csbi_cursor_position result - window = csbi_window result - x = cx - rect_left window + 1 - y = cy - rect_top window + 1 - hIn <- getStdHandle sTD_INPUT_HANDLE - _ <- writeConsoleInput hIn $ keyPresses $ - "\ESC[" ++ show y ++ ";" ++ show x ++ "R" - return () - -keyPress :: Char -> [INPUT_RECORD] -keyPress c = [keyDown, keyUp] - where - keyDown = key True - keyUp = key False - c' = UnicodeAsciiChar $ charToWCHAR c - key isDown = INPUT_RECORD kEY_EVENT $ - InputKeyEvent (KEY_EVENT_RECORD isDown 1 0 0 c' 0) - -keyPresses :: String -> [INPUT_RECORD] -keyPresses = concatMap keyPress - -aNSIColors :: [((ColorIntensity, Color), Colour Float)] -aNSIColors = [ ((Dull, Black), black) - , ((Dull, Blue), navy) - , ((Dull, Green), green) - , ((Dull, Cyan), teal) - , ((Dull, Red), maroon) - , ((Dull, Magenta), purple) - , ((Dull, Yellow), olive) - , ((Dull, White), silver) - , ((Vivid, Black), grey) - , ((Vivid, Blue), blue) - , ((Vivid, Green), lime) - , ((Vivid, Cyan), cyan) - , ((Vivid, Red), red) - , ((Vivid, Magenta), magenta) - , ((Vivid, Yellow), yellow) - , ((Vivid, White), white) ] - -toANSIColor :: Colour Float -> (ColorIntensity, Color) -toANSIColor color = fst $ minimumBy order aNSIColors - where - RGB r g b = toSRGB color - order (_, c1) (_, c2) = compare (dist c1) (dist c2) - dist c = let RGB r' g' b' = toSRGB c - dr = r' - r - dg = g' - g - db = b' - b - in dr * dr + dg * dg + db * db - --- hSupportsANSI :: Handle -> IO Bool --- (See Common-Include.hs for Haddock documentation) -hSupportsANSI h = (||) <$> isTDNotDumb h <*> isMinTTY - where - isMinTTY = withHandleToHANDLE h isMinTTYHandle - --- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) --- (See Common-Include.hs for Haddock documentation) -hSupportsANSIWithoutEmulation handle = do - supportsANSI <- detectHandleSupportsANSI handle -- Without reference to the - -- environment - case supportsANSI of - Just isSupported -> return (Just isSupported) - Nothing -> do -- Not sure, based on the handle alone - notDumb <- isNotDumb -- Test the environment - if notDumb - then return Nothing -- Still not sure! - else return (Just False) -- A dumb terminal - --- Borrowed from an HSpec patch by Simon Hengel --- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) -isTDNotDumb :: Handle -> IO Bool -isTDNotDumb h = (&&) <$> hIsTerminalDevice h <*> isNotDumb - --- Borrowed from an HSpec patch by Simon Hengel --- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) -isNotDumb :: IO Bool --- cannot use lookupEnv since it only appeared in GHC 7.6 -isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment - --- getReportedCursorPosition :: IO String --- (See Common-Include.hs for Haddock documentation) -getReportedCursorPosition - = CE.catch getReportedCursorPosition' getCPExceptionHandler - where - getReportedCursorPosition' = withHandleToHANDLE stdin action - where - action hdl = do - n <- getNumberOfConsoleInputEvents hdl - if n == 0 - then return "" - else do - es <- readConsoleInput hdl n - return $ stringFromInputEvents es - stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents - wCharsFromInputEvents = mapMaybe wCharFromInputEvent - wCharFromInputEvent e = if isKeyDownEvent - then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) - else Nothing - where - eventType = inputEventType e - InputKeyEvent keyEventRecord = inputEvent e - isKeyDown = keyEventKeyDown keyEventRecord - isKeyDownEvent = eventType == 1 && isKeyDown - --- getCursorPosition :: IO (Maybe (Int, Int)) --- (See Common-Include.hs for Haddock documentation) -getCursorPosition = CE.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."
− src/System/Console/ANSI/Windows/Emulator/Codes.hs
@@ -1,94 +0,0 @@-{-# 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 _ = ""
− src/System/Console/ANSI/Windows/Foreign.hs
@@ -1,651 +0,0 @@-{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | "System.Win32.Console" is really very impoverished, so I have had to do all --- the FFI myself. -module System.Console.ANSI.Windows.Foreign - ( - -- Re-exports from Win32.Types - BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, - - -- 'Re-exports from System.Win32.Console.Extra' - INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT, - KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput, - getNumberOfConsoleInputEvents, readConsoleInput, - - charToWCHAR, cWcharsToChars, - - COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, - rect_width, rect_height, CONSOLE_CURSOR_INFO(..), - CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), - - sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, - - eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, - - fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, - fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, - bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, - bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, - cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, - - getStdHandle, - getConsoleScreenBufferInfo, - getConsoleCursorInfo, - getConsoleMode, - - setConsoleTextAttribute, - setConsoleCursorPosition, - setConsoleCursorInfo, - setConsoleTitle, - setConsoleMode, - - fillConsoleOutputAttribute, - fillConsoleOutputCharacter, - scrollConsoleScreenBuffer, - - withTString, withHandleToHANDLE, - - ConsoleException (..) - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) -#endif -import Control.Exception (Exception, throw) -import Data.Bits ((.|.), shiftL) -import Data.Char (chr, ord) -import Data.Typeable (Typeable) -import Foreign.C.Types (CInt (..), CWchar (..)) -import Foreign.Marshal (alloca, allocaArray, maybeWith, peekArray, with, - withArrayLen) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (Storable (..)) --- `SHORT` and `withHandleToHANDLE` are not both available before Win32-2.5.1.0 -import System.Win32.Compat (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, - SHORT, TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, - nullHANDLE, withHandleToHANDLE, withTString) - -#if defined(i386_HOST_ARCH) -#define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -#define WINDOWS_CCONV ccall -#else -#error Unknown mingw32 arch -#endif - -type WCHAR = CWchar - -charToWCHAR :: Char -> WCHAR -charToWCHAR char = fromIntegral (ord char) - --- This is a FFI hack. Some of the API calls take a Coord, but that isn't a --- built-in FFI type so I can't use it directly. Instead, I use UNPACKED_COORD --- and marshal COORDs into this manually. Note that we CAN'T just use two SHORTs --- directly because they get expanded to 4 bytes each instead of just boing 2 --- lots of 2 bytes by the stdcall convention, so linking fails. -type UNPACKED_COORD = CInt - --- Field packing order determined experimentally: I couldn't immediately find a --- specification for Windows struct layout anywhere. -unpackCOORD :: COORD -> UNPACKED_COORD -unpackCOORD (COORD x y) - = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) - - -peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) -peekAndOffset ptr = do - item <- peek ptr - return (item, ptr `plusPtr` sizeOf item) - -pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) -pokeAndOffset ptr item = do - poke ptr item - return (ptr `plusPtr` sizeOf item) - -data COORD = COORD - { coord_x :: SHORT - , coord_y :: SHORT - } deriving (Read, Eq) - -instance Show COORD where - show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" - -instance Storable COORD where - sizeOf ~(COORD x y) = sizeOf x + sizeOf y - alignment ~(COORD x _) = alignment x - peek ptr = do - let ptr' = castPtr ptr :: Ptr SHORT - x <- peekElemOff ptr' 0 - y <- peekElemOff ptr' 1 - return (COORD x y) - poke ptr (COORD x y) = do - let ptr' = castPtr ptr :: Ptr SHORT - pokeElemOff ptr' 0 x - pokeElemOff ptr' 1 y - -data SMALL_RECT = SMALL_RECT - { rect_top_left :: COORD - , rect_bottom_right :: COORD - } - -rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT -rect_top = coord_y . rect_top_left -rect_left = coord_x . rect_top_left -rect_bottom = coord_y . rect_bottom_right -rect_right = coord_x . rect_bottom_right - -rect_width, rect_height :: SMALL_RECT -> SHORT -rect_width rect = rect_right rect - rect_left rect + 1 -rect_height rect = rect_bottom rect - rect_top rect + 1 - -instance Show SMALL_RECT where - show (SMALL_RECT tl br) = show tl ++ "-" ++ show br - -instance Storable SMALL_RECT where - sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br - alignment ~(SMALL_RECT tl _) = alignment tl - peek ptr = do - let ptr' = castPtr ptr :: Ptr COORD - tl <- peekElemOff ptr' 0 - br <- peekElemOff ptr' 1 - return (SMALL_RECT tl br) - poke ptr (SMALL_RECT tl br) = do - let ptr' = castPtr ptr :: Ptr COORD - pokeElemOff ptr' 0 tl - pokeElemOff ptr' 1 br - -data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO - { cci_cursor_size :: DWORD - , cci_cursor_visible :: BOOL - } deriving (Show) - -instance Storable CONSOLE_CURSOR_INFO where - sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible - alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size - peek ptr = do - (size, ptr') <- peekAndOffset (castPtr ptr) - visible <- peek ptr' - return (CONSOLE_CURSOR_INFO size visible) - poke ptr (CONSOLE_CURSOR_INFO size visible) = do - ptr' <- pokeAndOffset (castPtr ptr) size - poke ptr' visible - -data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO - { csbi_size :: COORD - , csbi_cursor_position :: COORD - , csbi_attributes :: WORD - , csbi_window :: SMALL_RECT - , csbi_maximum_window_size :: COORD - } deriving (Show) - -instance Storable CONSOLE_SCREEN_BUFFER_INFO where - sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO - size cursor_position attributes window maximum_window_size) - = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window - + sizeOf maximum_window_size - alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size - peek ptr = do - (size, ptr1) <- peekAndOffset (castPtr ptr) - (cursor_position, ptr2) <- peekAndOffset ptr1 - (attributes, ptr3) <- peekAndOffset ptr2 - (window, ptr4) <- peekAndOffset ptr3 - maximum_window_size <- peek ptr4 - return (CONSOLE_SCREEN_BUFFER_INFO - size cursor_position attributes window maximum_window_size) - poke ptr (CONSOLE_SCREEN_BUFFER_INFO - size cursor_position attributes window maximum_window_size) - = do - ptr1 <- pokeAndOffset (castPtr ptr) size - ptr2 <- pokeAndOffset ptr1 cursor_position - ptr3 <- pokeAndOffset ptr2 attributes - ptr4 <- pokeAndOffset ptr3 window - poke ptr4 maximum_window_size - -data CHAR_INFO = CHAR_INFO - { ci_char :: WCHAR - , ci_attributes :: WORD - } deriving (Show) - -instance Storable CHAR_INFO where - sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes - alignment ~(CHAR_INFO char _) = alignment char - peek ptr = do - (char, ptr') <- peekAndOffset (castPtr ptr) - attributes <- peek ptr' - return (CHAR_INFO char attributes) - poke ptr (CHAR_INFO char attributes) = do - ptr' <- pokeAndOffset (castPtr ptr) char - poke ptr' attributes - -eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD -sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD -eNABLE_VIRTUAL_TERMINAL_INPUT = 512 -eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 -sTD_INPUT_HANDLE = 0xFFFFFFF6 -- minus 10 -sTD_OUTPUT_HANDLE = 0xFFFFFFF5 -- minus 11 -sTD_ERROR_HANDLE = 0xFFFFFFF4 -- minus 12 - -fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, - bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, - cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD -fOREGROUND_BLUE = 0x1 -fOREGROUND_GREEN = 0x2 -fOREGROUND_RED = 0x4 -fOREGROUND_INTENSITY = 0x8 -bACKGROUND_BLUE = 0x10 -bACKGROUND_GREEN = 0x20 -bACKGROUND_RED = 0x40 -bACKGROUND_INTENSITY = 0x80 -cOMMON_LVB_REVERSE_VIDEO = 0x4000 -cOMMON_LVB_UNDERSCORE = 0x8000 - -fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, - bACKGROUND_INTENSE_WHITE :: WORD -fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE -bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE -fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY -bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY - -kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, - fOCUS_EVENT :: WORD -kEY_EVENT = 1 -mOUSE_EVENT = 2 -wINDOW_BUFFER_SIZE_EVENT = 4 -mENU_EVENT = 8 -fOCUS_EVENT = 16 - -foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" - getStdHandle :: DWORD -> IO HANDLE -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" - cGetConsoleScreenBufferInfo :: HANDLE - -> Ptr CONSOLE_SCREEN_BUFFER_INFO - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" - cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" - cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute" - cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition" - cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo" - cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW" - cSetConsoleTitle :: LPCTSTR -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" - cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute" - cFillConsoleOutputAttribute :: HANDLE - -> WORD - -> DWORD - -> UNPACKED_COORD - -> Ptr DWORD - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" - cFillConsoleOutputCharacter :: HANDLE - -> TCHAR - -> DWORD - -> UNPACKED_COORD - -> Ptr DWORD - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" - cScrollConsoleScreenBuffer :: HANDLE - -> Ptr SMALL_RECT - -> Ptr SMALL_RECT - -> UNPACKED_COORD - -> Ptr CHAR_INFO - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW" - cWriteConsoleInput :: HANDLE - -> Ptr INPUT_RECORD - -> DWORD - -> LPDWORD - -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents" - cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" - cReadConsoleInput :: HANDLE - -> Ptr INPUT_RECORD - -> DWORD - -> LPDWORD - -> IO BOOL - -data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) - -instance Show ConsoleException where - show (ConsoleException 6) = - "A fatal error has occurred.\n\n" ++ - "An attempt has been made to send console virtual terminal sequences\n" ++ - "(ANSI codes) to an output that has not been recognised as an\n" ++ - "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ - "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ - "Prompt or PowerShell). That may occur, for example, if output has\n" ++ - "been redirected to a file.\n\n" ++ - "If that is unexpected, please post an issue at:\n" ++ - "https://github.com/feuerbach/ansi-terminal/issues\n" - show (ConsoleException errCode) = "ConsoleException " ++ show errCode - -instance Exception ConsoleException - -throwIfFalse :: IO Bool -> IO () -throwIfFalse action = do - succeeded <- action - if not succeeded - then getLastError >>= throw . ConsoleException -- TODO: Check if last error - -- is zero for some instructable reason (?) - else return () - -getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO -getConsoleScreenBufferInfo handle - = alloca $ \ptr_console_screen_buffer_info -> do - throwIfFalse $ - cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info - peek ptr_console_screen_buffer_info - -getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO -getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do - throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info - peek ptr_console_cursor_info - -getConsoleMode :: HANDLE -> IO DWORD -getConsoleMode handle = alloca $ \ptr_mode -> do - throwIfFalse $ cGetConsoleMode handle ptr_mode - peek ptr_mode - -setConsoleTextAttribute :: HANDLE -> WORD -> IO () -setConsoleTextAttribute handle attributes - = throwIfFalse $ cSetConsoleTextAttribute handle attributes - -setConsoleCursorPosition :: HANDLE -> COORD -> IO () -setConsoleCursorPosition handle cursor_position - = throwIfFalse $ cSetConsoleCursorPosition handle - (unpackCOORD cursor_position) - -setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () -setConsoleCursorInfo handle console_cursor_info - = with console_cursor_info $ \ptr_console_cursor_info -> do - throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info - -setConsoleTitle :: LPCTSTR -> IO () -setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title - -setConsoleMode :: HANDLE -> DWORD -> IO () -setConsoleMode handle attributes - = throwIfFalse $ cSetConsoleMode handle attributes - -fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD -fillConsoleOutputAttribute handle attribute fill_length write_origin - = alloca $ \ptr_chars_written -> do - throwIfFalse $ cFillConsoleOutputAttribute handle attribute - fill_length (unpackCOORD write_origin) ptr_chars_written - peek ptr_chars_written - -fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD -fillConsoleOutputCharacter handle char fill_length write_origin - = alloca $ \ptr_chars_written -> do - throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length - (unpackCOORD write_origin) ptr_chars_written - peek ptr_chars_written - -scrollConsoleScreenBuffer :: HANDLE - -> SMALL_RECT - -> Maybe SMALL_RECT - -> COORD - -> CHAR_INFO - -> IO () -scrollConsoleScreenBuffer - handle scroll_rectangle mb_clip_rectangle destination_origin fill - = with scroll_rectangle $ \ptr_scroll_rectangle -> - maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> - with fill $ \ptr_fill -> - throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle - ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill - --- The following is based on module System.Win32.Console.Extra from package --- Win32-console, cut down for the WCHAR version of writeConsoleInput. - -writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD -writeConsoleInput hdl evs - = writeConsoleInputWith hdl $ \act -> - withArrayLen evs $ \len ptr -> - act (ptr, toEnum len) - -writeConsoleInputWith :: HANDLE - -> InputHandler (Ptr INPUT_RECORD, DWORD) - -> IO DWORD -writeConsoleInputWith hdl withBuffer - = returnWith_ $ \ptrN -> - withBuffer $ \(ptrBuf, len) -> - failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN - -returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a -returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr - -type InputHandler i = forall a. (i -> IO a) -> IO a - -{- -typedef union _UNICODE_ASCII_CHAR { - WCHAR UnicodeChar; - CHAR AsciiChar; -} UNICODE_ASCII_CHAR; --} -newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar - { unicodeAsciiChar :: WCHAR - } deriving (Show, Read, Eq) - -instance Storable UNICODE_ASCII_CHAR where - sizeOf _ = 2 - alignment _ = 2 - peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr - poke ptr val = case val of - UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c - -{- -typedef struct _KEY_EVENT_RECORD { - BOOL bKeyDown; - WORD wRepeatCount; - WORD wVirtualKeyCode; - WORD wVirtualScanCode; - union { - WCHAR UnicodeChar; - CHAR AsciiChar; - } uChar; - DWORD dwControlKeyState; -} -#ifdef __GNUC__ -/* gcc's alignment is not what win32 expects */ - PACKED -#endif -KEY_EVENT_RECORD; --} -data KEY_EVENT_RECORD = KEY_EVENT_RECORD - { keyEventKeyDown :: BOOL - , keyEventRepeatCount :: WORD - , keyEventVirtualKeyCode :: WORD - , keyEventVirtualScanCode :: WORD - , keyEventChar :: UNICODE_ASCII_CHAR - , keyEventControlKeystate :: DWORD - } deriving (Show, Read, Eq) - -instance Storable KEY_EVENT_RECORD where - sizeOf _ = 16 - alignment _ = 4 - peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr - <*> (`peekByteOff` 4) ptr - <*> (`peekByteOff` 6) ptr - <*> (`peekByteOff` 8) ptr - <*> (`peekByteOff` 10) ptr - <*> (`peekByteOff` 12) ptr - poke ptr val = do - (`pokeByteOff` 0) ptr $ keyEventKeyDown val - (`pokeByteOff` 4) ptr $ keyEventRepeatCount val - (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val - (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val - (`pokeByteOff` 10) ptr $ keyEventChar val - (`pokeByteOff` 12) ptr $ keyEventControlKeystate val - -{- -typedef struct _MOUSE_EVENT_RECORD { - COORD dwMousePosition; - DWORD dwButtonState; - DWORD dwControlKeyState; - DWORD dwEventFlags; -} MOUSE_EVENT_RECORD; --} -data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD - { mousePosition :: COORD - , mouseButtonState :: DWORD - , mouseControlKeyState :: DWORD - , mouseEventFlags :: DWORD - } deriving (Show, Read, Eq) - -instance Storable MOUSE_EVENT_RECORD where - sizeOf _ = 16 - alignment _ = 4 - peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr - <*> (`peekByteOff` 4) ptr - <*> (`peekByteOff` 8) ptr - <*> (`peekByteOff` 12) ptr - poke ptr val = do - (`pokeByteOff` 0) ptr $ mousePosition val - (`pokeByteOff` 4) ptr $ mouseButtonState val - (`pokeByteOff` 8) ptr $ mouseControlKeyState val - (`pokeByteOff` 12) ptr $ mouseEventFlags val - -{- -typedef struct _WINDOW_BUFFER_SIZE_RECORD { - COORD dwSize; -} WINDOW_BUFFER_SIZE_RECORD; --} -data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD - { bufSizeNew :: COORD - } deriving (Show, Read, Eq) - -instance Storable WINDOW_BUFFER_SIZE_RECORD where - sizeOf _ = 4 - alignment _ = 4 - peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr - poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val - -{- -typedef struct _MENU_EVENT_RECORD { - UINT dwCommandId; -} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; --} -data MENU_EVENT_RECORD = MENU_EVENT_RECORD - { menuCommandId :: UINT - } deriving (Show, Read, Eq) - -instance Storable MENU_EVENT_RECORD where - sizeOf _ = 4 - alignment _ = 4 - peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr - poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val - -{- -typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; --} -data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD - { focusSetFocus :: BOOL - } deriving (Show, Read, Eq) - -instance Storable FOCUS_EVENT_RECORD where - sizeOf _ = 4 - alignment _ = 4 - peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr - poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val - -data INPUT_RECORD_EVENT - = InputKeyEvent KEY_EVENT_RECORD - | InputMouseEvent MOUSE_EVENT_RECORD - | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD - | InputMenuEvent MENU_EVENT_RECORD - | InputFocusEvent FOCUS_EVENT_RECORD - deriving (Show, Read, Eq) - -{- -typedef struct _INPUT_RECORD { - WORD EventType; - union { - KEY_EVENT_RECORD KeyEvent; - MOUSE_EVENT_RECORD MouseEvent; - WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; - MENU_EVENT_RECORD MenuEvent; - FOCUS_EVENT_RECORD FocusEvent; - } Event; -} INPUT_RECORD,*PINPUT_RECORD; --} -data INPUT_RECORD = INPUT_RECORD - { inputEventType :: WORD - , inputEvent :: INPUT_RECORD_EVENT - } deriving (Show, Read, Eq) - -instance Storable INPUT_RECORD where - sizeOf _ = 20 - alignment _ = 4 - peek ptr = do - evType <- (`peekByteOff` 0) ptr - event <- case evType of - _ | evType == kEY_EVENT - -> InputKeyEvent <$> (`peekByteOff` 4) ptr - _ | evType == mOUSE_EVENT - -> InputMouseEvent <$> (`peekByteOff` 4) ptr - _ | evType == wINDOW_BUFFER_SIZE_EVENT - -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr - _ | evType == mENU_EVENT - -> InputMenuEvent <$> (`peekByteOff` 4) ptr - _ | evType == fOCUS_EVENT - -> InputFocusEvent <$> (`peekByteOff` 4) ptr - _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ - show evType - return $ INPUT_RECORD evType event - poke ptr val = do - (`pokeByteOff` 0) ptr $ inputEventType val - case inputEvent val of - InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev - InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev - InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev - InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev - InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev - --- The following is based on module System.Win32.Console.Extra from package --- Win32-console. - -getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD -getNumberOfConsoleInputEvents hdl = - returnWith_ $ \ptrN -> - failIfFalse_ "GetNumberOfConsoleInputEvents" $ - cGetNumberOfConsoleInputEvents hdl ptrN - --- The following is based on module System.Win32.Console.Extra from package --- Win32-console, cut down for the WCHAR version of readConsoleInput. - -readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] -readConsoleInput hdl len - = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr - -readConsoleInputWith :: HANDLE - -> DWORD - -> OutputHandler (Ptr INPUT_RECORD, DWORD) -readConsoleInputWith hdl len handler = - allocaArray (fromEnum len) $ \ptrBuf -> - alloca $ \ptrN -> do - failIfFalse_ "ReadConsoleInputW" $ - cReadConsoleInput hdl ptrBuf len ptrN - n <- peek ptrN - handler (ptrBuf, n) - -type OutputHandler o = forall a. (o -> IO a) -> IO a - --- Replicated from module Foreign.C.String in package base because that module --- does not export the function. -cWcharsToChars :: [CWchar] -> [Char] -cWcharsToChars = map chr . fromUTF16 . map fromIntegral - where - fromUTF16 (c1:c2:wcs) - | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = - ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs - fromUTF16 (c:wcs) = c : fromUTF16 wcs - fromUTF16 [] = []
− src/System/Win32/Compat.hs
@@ -1,111 +0,0 @@-{-# OPTIONS_HADDOCK hide #-} - -{-| The Win32 library ships with GHC. Win32-2.1 first shipped with GHC 6.6 -(released October 2006). Win32-2.5.4.1 first shipped with GHC 8.2.1 -(released July 2017), replacing Win32-2.3.1.1. - -The ansi-terminal library makes use of functionality in Win32-2.1 and other -functionality first added to Win32-2.5.0.0 or Win32-2.5.1.0 (from ansi-terminal -itself). - -This module provides functions available in those later versions of Win32 to a -wider range of compilers, reducing the use of CPP pragmas in other modules. --} -module System.Win32.Compat - ( - BOOL - , DWORD - , ErrCode - , HANDLE - , LPCTSTR - , LPDWORD - , SHORT -- from Win32-2.5.0.0 - , TCHAR - , UINT - , WORD - , failIfFalse_ - , getLastError - , iNVALID_HANDLE_VALUE - , nullHANDLE - , withHandleToHANDLE -- from Win32-2.5.1.0 - , withTString - ) where - -#if !MIN_VERSION_Win32(2,5,0) -import Foreign.C.Types (CShort (..)) -#endif - -#if !MIN_VERSION_Win32(2,5,1) -import Control.Concurrent.MVar (readMVar) -import Control.Exception (bracket) -import Foreign.C.Types (CInt (..)) -import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) -import Data.Typeable (cast) -import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 -import GHC.IO.Handle.Types (Handle (..), Handle__ (..)) -#endif - -import System.Win32.Types (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, - TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, - nullHANDLE, withTString) - -#if MIN_VERSION_Win32(2,5,0) -import System.Win32.Types (SHORT) -#endif - -#if MIN_VERSION_Win32(2,5,1) -import System.Win32.Types (withHandleToHANDLE) -#endif - -#if !MIN_VERSION_Win32(2,5,0) -type SHORT = CShort -#endif - -#if !MIN_VERSION_Win32(2,5,1) - -#if defined(i386_HOST_ARCH) -#define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -#define WINDOWS_CCONV ccall -#else -#error Unknown mingw32 arch -#endif - --- | This bit is all highly dubious. The problem is that we want to output ANSI --- to arbitrary Handles rather than forcing people to use stdout. However, the --- Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need --- to be able to extract one of those from the Haskell Handle. --- --- This code accomplishes this, albeit at the cost of only being compatible with --- GHC. -withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a -withHandleToHANDLE haskell_handle action = - -- Create a stable pointer to the Handle. This prevents the garbage collector - -- getting to it while we are doing horrible manipulations with it, and hence - -- stops it being finalized (and closed). - withStablePtr haskell_handle $ const $ do - -- Grab the write handle variable from the Handle - let write_handle_mvar = case haskell_handle of - FileHandle _ handle_mvar -> handle_mvar - DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, - -- we could also take the "read" one - - -- Get the FD from the algebraic data type - Just fd <- fmap (\(Handle__ { haDevice = dev }) -> - fmap fdFD (cast dev)) $ readMVar write_handle_mvar - - -- Finally, turn that (C-land) FD into a HANDLE using msvcrt - windows_handle <- cget_osfhandle fd - - -- Do what the user originally wanted - action windows_handle - --- This essential function comes from the C runtime system. It is certainly --- provided by msvcrt, and also seems to be provided by the mingw C library - --- hurrah! -foreign import WINDOWS_CCONV unsafe "_get_osfhandle" - cget_osfhandle :: CInt -> IO HANDLE - -withStablePtr :: a -> (StablePtr a -> IO b) -> IO b -withStablePtr value = bracket (newStablePtr value) freeStablePtr -#endif
− src/includes/Common-Include-Emulator.hs
@@ -1,65 +0,0 @@--- 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
− src/includes/Common-Include-Enabled.hs
@@ -1,56 +0,0 @@--- 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
− src/includes/Common-Include.hs
@@ -1,232 +0,0 @@--- This file contains code that is common to modules System.Console.ANSI.Unix, --- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as --- type signatures and the definition of functions specific to stdout in terms --- of the corresponding more general functions, inclduding the related Haddock --- documentation. - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#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 () - --- | Move the cursor to the specified column. The column numbering is 0-based --- (that is, the left-most column is numbered 0). -setCursorColumn :: Int -- ^ 0-based column to move to - -> IO () -setCursorColumn = hSetCursorColumn stdout - -hSetCursorPosition :: Handle - -> Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> IO () - --- | Move the cursor to the specified position (row and column). The position is --- 0-based (that is, the top-left corner is at row 0 column 0). -setCursorPosition :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> IO () -setCursorPosition = hSetCursorPosition stdout - -hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () - --- | Save the cursor position in memory. The only way to access the saved value --- is with the 'restoreCursor' command. --- --- @since 0.7.1 -saveCursor :: IO () - --- | Restore the cursor position from memory. There will be no value saved in --- memory until the first use of the 'saveCursor' command. --- --- @since 0.7.1 -restoreCursor :: IO () - --- | Looking for a way to get the cursors position? See --- 'getCursorPosition0'. --- --- Emit the cursor position into the console input stream, immediately after --- being recognised on the output stream, as: --- @ESC [ \<cursor row> ; \<cursor column> R@ --- --- Note that the information that is emitted is 1-based (the top-left corner is --- at row 1 column 1) but 'setCursorColumn' and 'setCursorPosition' are --- 0-based. --- --- In isolation of 'getReportedCursorPosition' or 'getCursorPosition0', 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>). --- --- @since 0.7.1 -reportCursorPosition :: IO () - -saveCursor = hSaveCursor stdout -restoreCursor = hRestoreCursor stdout -reportCursorPosition = hReportCursorPosition stdout - -hHideCursor, hShowCursor :: Handle - -> IO () -hideCursor, showCursor :: IO () -hideCursor = hHideCursor stdout -showCursor = hShowCursor stdout - --- | Set the terminal window title -hSetTitle :: Handle - -> String -- ^ New title - -> IO () --- | Set the terminal window title -setTitle :: String -- ^ New title - -> IO () -setTitle = hSetTitle stdout - --- | Use heuristics to determine whether the functions defined in this --- package will work with a given handle. This function assumes that the handle --- is writable (that is, it manages output - see 'hIsWritable'). --- --- For Unix-like operating systems, the current implementation checks --- that: (1) the handle is a terminal; and (2) a @TERM@ --- environment variable is not set to @dumb@ (which is what the GNU Emacs text --- editor sets for its integrated terminal). --- --- For Windows, the current implementation performs the same checks as for --- Unix-like operating systems and, as an alternative, checks whether the --- handle is connected to a \'mintty\' terminal. (That is because the function --- 'hIsTerminalDevice' is used to check if the handle is a --- terminal. However, where a non-native Windows terminal (such as \'mintty\') --- is implemented using redirection, that function will not identify a --- handle to the terminal as a terminal.) On Windows 10, if the handle is --- identified as connected to a native terminal, this function does /not/ enable --- the processing of \'ANSI\' control characters in output (see --- 'hSupportsANSIWithoutEmulation'). -hSupportsANSI :: Handle -> IO Bool - --- | Use heuristics to determine whether a given handle will support \'ANSI\' --- control characters in output. (On Windows versions before Windows 10, that --- means \'support without emulation\'.) --- --- If the handle is not writable (that is, it cannot manage output - see --- 'hIsWritable'), then @return (Just False)@ is returned. --- --- On Unix-like operating systems, with one exception, the function is --- consistent with 'hSupportsANSI'. The exception is if the handle is not --- writable. --- --- On Windows, what is returned will depend on what the handle is connected to --- and the version of the operating system. If the handle is identified as --- connected to a \'mintty\' terminal, @return (Just True)@ is --- returned. If it is identifed as connected to a native terminal, then, on --- Windows 10, the processing of \'ANSI\' control characters will be enabled and --- @return (Just True)@ returned; and, on versions of Windows before Windows 10, --- @return (Just False)@ is returned. Otherwise, if a @TERM@ environment --- variable is set to @dumb@, @return (Just False)@ is returned. In all other --- cases of a writable handle, @return Nothing@ is returned; this indicates that --- the heuristics cannot assist - the handle may be connected to a file or --- to another type of terminal. --- --- @since 0.8.1 -hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) - --- | Parses the characters emitted by 'reportCursorPosition' into the console --- input stream. Returns the cursor row and column as a tuple. --- --- For example, if the characters emitted by 'reportCursorPosition' are in --- 'String' @input@ then the parser could be applied like this: --- --- > let result = readP_to_S cursorPosition input --- > case result of --- > [] -> putStrLn $ "Error: could not parse " ++ show input --- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row --- > ++ " and column" ++ show column ++ "." --- > (_:_) -> putStrLn $ "Error: parse not unique" --- --- @since 0.7.1 -cursorPosition :: ReadP (Int, Int) -cursorPosition = do - void $ char '\ESC' - void $ char '[' - row <- decimal -- A non-negative whole decimal number - void $ char ';' - col <- decimal -- A non-negative whole decimal number - void $ char 'R' - return (read row, read col) - where - digit = satisfy isDigit - decimal = many1 digit - --- | Attempts to get the reported cursor position data from the console input --- stream. The function is intended to be called immediately after --- 'reportCursorPosition' (or related functions) have caused characters to be --- emitted into the stream. --- --- For example, on a Unix-like operating system: --- --- > hSetBuffering stdin NoBuffering -- set no buffering (the contents of the --- > -- buffer will be discarded, so this needs --- > -- to be done before the cursor positon is --- > -- emitted) --- > reportCursorPosition --- > hFlush stdout -- ensure the report cursor position code is sent to the --- > -- operating system --- > input <- getReportedCursorPosition --- --- On Windows operating systems, the function is not supported on consoles, such --- as mintty, that are not based on the Win32 console of the Windows API. --- (Command Prompt and PowerShell are based on the Win32 console.) --- --- @since 0.7.1 -getReportedCursorPosition :: IO String - --- | Attempts to get the reported cursor position, combining the functions --- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. Any --- position @(row, column)@ is translated to be 0-based (that is, the top-left --- corner is at @(0, 0)@), consistent with `setCursorColumn` and --- `setCursorPosition`. (Note that the information emitted by --- 'reportCursorPosition' is 1-based.) 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.) --- --- @since 0.8.2 -getCursorPosition0 :: IO (Maybe (Int, Int)) -getCursorPosition0 = fmap to0base <$> getCursorPosition - where - to0base (row, col) = (row - 1, col - 1) - --- | Similar to 'getCursorPosition0', but does not translate the 1-based data --- emitted by 'reportCursorPosition' to be 0-based. --- --- @since 0.7.1 -getCursorPosition :: IO (Maybe (Int, Int))
− src/includes/Exports-Include.hs
@@ -1,118 +0,0 @@--- 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 (not portable: GHC only) - , hSupportsANSI - , hSupportsANSIWithoutEmulation - - -- * Getting the cursor position - , getCursorPosition0 - , getReportedCursorPosition - , cursorPosition - - -- * Deprecated - , getCursorPosition
+ unix/System/Console/ANSI/Internal.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE Trustworthy #-} + +module System.Console.ANSI.Internal + ( getReportedCursorPosition + , getReportedLayerColor + , hSupportsANSI + , hNowSupportsANSI + , hSupportsANSIColor + ) where + +import Data.List ( uncons ) +import Data.Maybe ( fromMaybe, isJust, mapMaybe ) +import System.Environment ( lookupEnv ) +import System.IO ( Handle, hIsTerminalDevice, hIsWritable ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Timeout ( timeout ) + +import System.Console.ANSI.Types ( ConsoleLayer (..) ) + +getReportedCursorPosition :: IO String +getReportedCursorPosition = getReport "\ESC[" ["R"] + +getReportedLayerColor :: ConsoleLayer -> IO String +getReportedLayerColor Underlining = + error "getReportedLayerColor does not support underlining." +getReportedLayerColor layer = + getReport ("\ESC]" ++ pS ++ ";rgb:") ["\BEL", "\ESC\\"] + where + pS = case layer of + Foreground -> "10" + Background -> "11" + +getReport :: String -> [String] -> IO String +getReport _ [] = error "getReport requires a list of terminating sequences." +getReport startChars endChars = do + -- If, unexpectedly, no data is available on the console input stream then + -- the timeout will prevent the getChar blocking. For consistency with the + -- Windows equivalent, returns "" if the expected information is unavailable. + fromMaybe "" <$> timeout 500000 (getStart startChars "") -- 500 milliseconds + where + endChars' = mapMaybe uncons endChars + + -- The list is built in reverse order, in order to avoid O(n^2) complexity. + -- So, getReport yields the reversed built list. + + getStart :: String -> String -> IO String + getStart "" r = getRest r + getStart (h:hs) r = do + c <- getChar + if c == h + then getStart hs (c:r) -- Try to get the rest of the start characters + else pure $ reverse (c:r) -- If the first character(s) are not the + -- expected start then give up. This provides + -- a modicom of protection against unexpected + -- data in the input stream. + getRest :: String -> IO String + getRest r = do + c <- getChar + case lookup c endChars' of + Nothing -> getRest (c:r) -- Continue building the list, until the first of + -- the end characters is obtained. + Just es -> getEnd es (c:r) -- Try to get the rest of the end characters. + + getEnd :: String -> String -> IO String + getEnd "" r = pure $ reverse r + getEnd (e:es) r = do + c <- getChar + if c /= e + then getRest (c:r) -- Continue building the list, with the original end + -- characters. + else getEnd es (c:r) -- Continue building the list, checking against the + -- remaining end characters. + +hSupportsANSI :: Handle -> IO Bool +-- Borrowed from an HSpec patch by Simon Hengel +-- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) +hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI' + where + hSupportsANSI' = (&& isNotDumb) <$> hIsTerminalDevice h + +hNowSupportsANSI :: Handle -> IO Bool +hNowSupportsANSI = hSupportsANSI + +hSupportsANSIColor :: Handle -> IO Bool +hSupportsANSIColor h = (|| isEmacsTerm) <$> hSupportsANSI h + where + isEmacsTerm = insideEmacs && isDumb + isDumb = not isNotDumb + +-- | This function assumes that once it is first established whether or not the +-- TERM environment variable exists with contents dumb, that will not change. +-- This approach is taken because the use of C function setenv() in one thread +-- can cause other threads calling C function getenv() to crash. On Unix-like +-- operating systems, System.Environment.lookupEnv is implemented using C +-- function getenv(). +isNotDumb :: Bool +isNotDumb = unsafePerformIO (lookupEnv "TERM") /= Just "dumb" + +{-# NOINLINE isNotDumb #-} + +-- | This function assumes that once it is first established whether or not the +-- INSIDE_EMACS environment variable exists, that will not change. This approach +-- is taken because the use of C function setenv() in one thread can cause other +-- threads calling C function getenv() to crash. On Unix-like operating systems, +-- System.Environment.lookupEnv is implemented using C function getenv(). +insideEmacs :: Bool +insideEmacs = isJust $ unsafePerformIO (lookupEnv "INSIDE_EMACS") + +{-# NOINLINE insideEmacs #-}
+ win/System/Console/ANSI/Internal.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE Safe #-} + +module System.Console.ANSI.Internal + ( getReportedCursorPosition + , getReportedLayerColor + , hNowSupportsANSI + , hSupportsANSI + , hSupportsANSIColor + ) where + +import Control.Exception ( IOException, SomeException, catch, try ) +import Data.Bits ( (.&.), (.|.) ) +import Data.Maybe ( mapMaybe ) +import System.Environment ( getEnvironment, lookupEnv ) +import System.IO ( Handle, hIsTerminalDevice, hIsWritable, stdin ) +import System.Console.ANSI.Types ( ConsoleLayer ) + +-- Provided by the ansi-terminal package +import System.Console.ANSI.Windows.Foreign + ( INPUT_RECORD (..), INPUT_RECORD_EVENT (..), KEY_EVENT_RECORD (..) + , cWcharsToChars, eNABLE_VIRTUAL_TERMINAL_PROCESSING + , getConsoleMode, getNumberOfConsoleInputEvents, iNVALID_HANDLE_VALUE + , nullHANDLE, readConsoleInput, setConsoleMode, unicodeAsciiChar + ) +import System.Console.ANSI.Windows.Win32.MinTTY ( isMinTTYHandle ) +import System.Console.ANSI.Windows.Win32.Types + ( DWORD, HANDLE, withHandleToHANDLE ) + +getReportedCursorPosition :: IO String +getReportedCursorPosition = getReported + +getReportedLayerColor :: ConsoleLayer -> IO String +getReportedLayerColor _ = getReported + +getReported :: IO String +getReported = catch getReported' getReportedExceptionHandler + where + getReported' = withHandleToHANDLE stdin action + where + action hdl = do + n <- getNumberOfConsoleInputEvents hdl + if n == 0 + then pure "" + else do + es <- readConsoleInput hdl n + pure $ stringFromInputEvents es + stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents + wCharsFromInputEvents = mapMaybe wCharFromInputEvent + wCharFromInputEvent e = if isKeyEvent && isKeyDown + then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) + else Nothing + where + eventType = inputEventType e + eventRecord = inputEvent e + isKeyEvent = eventType == 1 + keyEventRecord = case eventRecord of + InputKeyEvent keyEventRecord' -> keyEventRecord' + _ -> error "Unexpected input event, given input event type." + isKeyDown = keyEventKeyDown keyEventRecord + +getReportedExceptionHandler :: IOException -> IO a +getReportedExceptionHandler e = error msg + where + msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " ++ + "console based on the Windows' Console API, such as Command Prompt " ++ + "or PowerShell." + +hSupportsANSI :: Handle -> IO Bool +hSupportsANSI = hSupportsANSI' False + +hNowSupportsANSI :: Handle -> IO Bool +hNowSupportsANSI = hSupportsANSI' True + +hSupportsANSI' :: Bool -> Handle -> IO Bool +hSupportsANSI' tryToEnable handle = do + isWritable <- hIsWritable handle + if isWritable + then withHandleToHANDLE handle $ withHANDLE + (pure False) -- Invalid handle or no handle + ( \h -> do + tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD) + case tryMode of + Left _ -> isMinTTYHandle h -- No ConHost mode + Right mode -> do + let isVTEnabled = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 + isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM" + isTDNotDumb <- (&&) <$> hIsTerminalDevice handle <*> isNotDumb + if isTDNotDumb && not isVTEnabled && tryToEnable + then do + let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING + trySetMode <- try (setConsoleMode h mode') + :: IO (Either SomeException ()) + case trySetMode of + Left _ -> pure False -- Can't enable VT processing + Right () -> pure True -- VT processing enabled + else pure $ isTDNotDumb && isVTEnabled + ) + else pure False + +-- | This function applies another to the Windows handle, if the handle is +-- valid. If it is invalid, the specified default action is returned. +withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a +withHANDLE invalid action h = + if h == iNVALID_HANDLE_VALUE || h == nullHANDLE + then invalid -- Invalid handle or no handle + else action h + +hSupportsANSIColor :: Handle -> IO Bool +hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm + where + isEmacsTerm = (\env -> insideEmacs env && isDumb env) <$> getEnvironment + insideEmacs = any (\(k, _) -> k == "INSIDE_EMACS") + isDumb env = Just "dumb" == lookup "TERM" env
+ win/System/Console/ANSI/Windows/Foreign.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +module System.Console.ANSI.Windows.Foreign + ( + INPUT_RECORD (..) + , INPUT_RECORD_EVENT (..) + , KEY_EVENT_RECORD (..) + , getNumberOfConsoleInputEvents + , readConsoleInput + , cWcharsToChars + , unicodeAsciiChar + , eNABLE_VIRTUAL_TERMINAL_PROCESSING + , iNVALID_HANDLE_VALUE + , nullHANDLE + , getConsoleMode + , setConsoleMode + ) where + +import Control.Exception ( Exception ) +import Data.Char ( chr ) +import Data.Typeable ( Typeable ) +import Data.Word ( Word32 ) +import Foreign.C.Types ( CWchar (..) ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( allocaArray, peekArray, pokeArray ) +import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr ) +import Foreign.Storable ( Storable (..) ) +import System.Console.ANSI.Windows.Win32.Types + ( BOOL, DWORD, ErrCode, HANDLE, LPDWORD, SHORT, UINT, UINT_PTR, ULONG + , WCHAR, WORD, failIfFalse_ + ) + +peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) +peekAndOffset ptr = do + item <- peek ptr + pure (item, ptr `plusPtr` sizeOf item) + +pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) +pokeAndOffset ptr item = do + poke ptr item + pure (ptr `plusPtr` sizeOf item) + +data COORD = COORD + { coord_x :: SHORT + , coord_y :: SHORT + } deriving (Read, Eq) + +instance Show COORD where + show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" + +instance Storable COORD where + sizeOf ~(COORD x y) = sizeOf x + sizeOf y + alignment ~(COORD x _) = alignment x + peek ptr = do + let ptr' = castPtr ptr :: Ptr SHORT + x <- peekElemOff ptr' 0 + y <- peekElemOff ptr' 1 + pure (COORD x y) + poke ptr (COORD x y) = do + let ptr' = castPtr ptr :: Ptr SHORT + pokeElemOff ptr' 0 x + pokeElemOff ptr' 1 y + +data SMALL_RECT = SMALL_RECT COORD COORD + +instance Show SMALL_RECT where + show (SMALL_RECT tl br) = show tl ++ "-" ++ show br + +instance Storable SMALL_RECT where + sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br + alignment ~(SMALL_RECT tl _) = alignment tl + peek ptr = do + let ptr' = castPtr ptr :: Ptr COORD + tl <- peekElemOff ptr' 0 + br <- peekElemOff ptr' 1 + pure (SMALL_RECT tl br) + poke ptr (SMALL_RECT tl br) = do + let ptr' = castPtr ptr :: Ptr COORD + pokeElemOff ptr' 0 tl + pokeElemOff ptr' 1 br + +data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO + { cci_cursor_size :: DWORD + , cci_cursor_visible :: BOOL + } deriving (Show) + +instance Storable CONSOLE_CURSOR_INFO where + sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible + alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size + peek ptr = do + (size, ptr') <- peekAndOffset (castPtr ptr) + visible <- peek ptr' + pure (CONSOLE_CURSOR_INFO size visible) + poke ptr (CONSOLE_CURSOR_INFO size visible) = do + ptr' <- pokeAndOffset (castPtr ptr) size + poke ptr' visible + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO + { csbi_size :: COORD + , csbi_cursor_position :: COORD + , csbi_attributes :: WORD + , csbi_window :: SMALL_RECT + , csbi_maximum_window_size :: COORD + } deriving (Show) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + + sizeOf maximum_window_size + alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size + peek ptr = do + (size, ptr1) <- peekAndOffset (castPtr ptr) + (cursor_position, ptr2) <- peekAndOffset ptr1 + (attributes, ptr3) <- peekAndOffset ptr2 + (window, ptr4) <- peekAndOffset ptr3 + maximum_window_size <- peek ptr4 + pure (CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + poke ptr (CONSOLE_SCREEN_BUFFER_INFO + size cursor_position attributes window maximum_window_size) + = do + ptr1 <- pokeAndOffset (castPtr ptr) size + ptr2 <- pokeAndOffset ptr1 cursor_position + ptr3 <- pokeAndOffset ptr2 attributes + ptr4 <- pokeAndOffset ptr3 window + poke ptr4 maximum_window_size + +data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX + { csbix_size :: COORD + , csbix_cursor_position :: COORD + , csbix_attributes :: WORD + , csbix_window :: SMALL_RECT + , csbix_maximum_window_size :: COORD + , csbix_popup_attributes :: WORD + , csbix_fullscreen_supported :: BOOL + , csbix_color_table :: [COLORREF] + } deriving (Show) + +-- When specifying an explicit RGB color, the COLORREF value has the following +-- hexadecimal form: +-- 0x00bbggrr +-- The low-order byte contains a value for the relative intensity of red; the +-- second byte contains a value for green; and the third byte contains a value +-- for blue. The high-order byte must be zero. The maximum value for a single +-- byte is 0xFF. +type COLORREF = Word32 + +instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where + sizeOf ~(CONSOLE_SCREEN_BUFFER_INFOEX + size cursor_position attributes window maximum_window_size popup_attributes + fullscreen_supported _) + = sizeOf sizeCsbix + sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + + sizeOf maximum_window_size + sizeOf popup_attributes + + sizeOf fullscreen_supported + 16 * sizeOf (undefined :: COLORREF) + alignment ~(CONSOLE_SCREEN_BUFFER_INFOEX _ _ _ _ _ _ _ _) = alignment sizeCsbix + peek ptr = do + let ptr0 = castPtr ptr `plusPtr` sizeOf sizeCsbix + (size, ptr1) <- peekAndOffset ptr0 + (cursor_position, ptr2) <- peekAndOffset ptr1 + (attributes, ptr3) <- peekAndOffset ptr2 + (window, ptr4) <- peekAndOffset ptr3 + (maximum_window_size, ptr5) <- peekAndOffset ptr4 + (popup_attributes, ptr6) <- peekAndOffset ptr5 + (fullscreen_supported, ptr7) <- peekAndOffset ptr6 + color_table <- peekArray 16 ptr7 + pure (CONSOLE_SCREEN_BUFFER_INFOEX + size cursor_position attributes window maximum_window_size + popup_attributes fullscreen_supported color_table) + poke ptr (CONSOLE_SCREEN_BUFFER_INFOEX + size cursor_position attributes window maximum_window_size popup_attributes + fullscreen_supported color_table) + = do + ptr0 <- pokeAndOffset (castPtr ptr) sizeCsbix + ptr1 <- pokeAndOffset ptr0 size + ptr2 <- pokeAndOffset ptr1 cursor_position + ptr3 <- pokeAndOffset ptr2 attributes + ptr4 <- pokeAndOffset ptr3 window + ptr5 <- pokeAndOffset ptr4 maximum_window_size + ptr6 <- pokeAndOffset ptr5 popup_attributes + ptr7 <- pokeAndOffset ptr6 fullscreen_supported + pokeArray ptr7 color_table' + where + color_table' = take 16 $ color_table ++ repeat 0 + +sizeCsbix :: ULONG +sizeCsbix = fromIntegral $ + sizeOf (undefined :: CONSOLE_SCREEN_BUFFER_INFOEX) + +data CHAR_INFO = CHAR_INFO + { ci_char :: WCHAR + , ci_attributes :: WORD + } deriving (Show) + +instance Storable CHAR_INFO where + sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes + alignment ~(CHAR_INFO char _) = alignment char + peek ptr = do + (char, ptr') <- peekAndOffset (castPtr ptr) + attributes <- peek ptr' + pure (CHAR_INFO char attributes) + poke ptr (CHAR_INFO char attributes) = do + ptr' <- pokeAndOffset (castPtr ptr) char + poke ptr' attributes + +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 ccall unsafe "windows.h GetNumberOfConsoleInputEvents" + cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL +foreign import ccall unsafe "windows.h ReadConsoleInputW" + cReadConsoleInput :: HANDLE + -> Ptr INPUT_RECORD + -> DWORD + -> LPDWORD + -> IO BOOL + +data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) + +instance Show ConsoleException where + show (ConsoleException 6) = + "A fatal error has occurred.\n\n" ++ + "An attempt has been made to send console virtual terminal sequences\n" ++ + "(ANSI codes) to an output that has not been recognised as an\n" ++ + "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ + "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ + "Prompt or PowerShell). That may occur, for example, if output has\n" ++ + "been redirected to a file.\n\n" ++ + "If that is unexpected, please post an issue at:\n" ++ + "https://github.com/UnkindPartition/ansi-terminal/issues\n" + show (ConsoleException errCode) = "ConsoleException " ++ show errCode + +instance Exception ConsoleException + +returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a +returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr + +{- +typedef union _UNICODE_ASCII_CHAR { + WCHAR UnicodeChar; + CHAR AsciiChar; +} UNICODE_ASCII_CHAR; +-} +newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar + { unicodeAsciiChar :: WCHAR + } deriving (Show, Read, Eq) + +instance Storable UNICODE_ASCII_CHAR where + sizeOf _ = 2 + alignment _ = 2 + peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr + poke ptr val = case val of + UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c + +{- +typedef struct _KEY_EVENT_RECORD { + BOOL bKeyDown; + WORD wRepeatCount; + WORD wVirtualKeyCode; + WORD wVirtualScanCode; + union { + WCHAR UnicodeChar; + CHAR AsciiChar; + } uChar; + DWORD dwControlKeyState; +} +#ifdef __GNUC__ +/* gcc's alignment is not what win32 expects */ + PACKED +#endif +KEY_EVENT_RECORD; +-} +data KEY_EVENT_RECORD = KEY_EVENT_RECORD + { keyEventKeyDown :: BOOL + , keyEventRepeatCount :: WORD + , keyEventVirtualKeyCode :: WORD + , keyEventVirtualScanCode :: WORD + , keyEventChar :: UNICODE_ASCII_CHAR + , keyEventControlKeystate :: DWORD + } deriving (Show, Read, Eq) + +instance Storable KEY_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 6) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 10) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ keyEventKeyDown val + (`pokeByteOff` 4) ptr $ keyEventRepeatCount val + (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val + (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val + (`pokeByteOff` 10) ptr $ keyEventChar val + (`pokeByteOff` 12) ptr $ keyEventControlKeystate val + +{- +typedef struct _MOUSE_EVENT_RECORD { + COORD dwMousePosition; + DWORD dwButtonState; + DWORD dwControlKeyState; + DWORD dwEventFlags; +} MOUSE_EVENT_RECORD; +-} +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD + { mousePosition :: COORD + , mouseButtonState :: DWORD + , mouseControlKeyState :: DWORD + , mouseEventFlags :: DWORD + } deriving (Show, Read, Eq) + +instance Storable MOUSE_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ mousePosition val + (`pokeByteOff` 4) ptr $ mouseButtonState val + (`pokeByteOff` 8) ptr $ mouseControlKeyState val + (`pokeByteOff` 12) ptr $ mouseEventFlags val + +{- +typedef struct _WINDOW_BUFFER_SIZE_RECORD { + COORD dwSize; +} WINDOW_BUFFER_SIZE_RECORD; +-} +data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD + { bufSizeNew :: COORD + } deriving (Show, Read, Eq) + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val + +{- +typedef struct _MENU_EVENT_RECORD { + UINT dwCommandId; +} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; +-} +data MENU_EVENT_RECORD = MENU_EVENT_RECORD + { menuCommandId :: UINT + } deriving (Show, Read, Eq) + +instance Storable MENU_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val + +{- +typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; +-} +data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD + { focusSetFocus :: BOOL + } deriving (Show, Read, Eq) + +instance Storable FOCUS_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val + +data INPUT_RECORD_EVENT + = InputKeyEvent KEY_EVENT_RECORD + | InputMouseEvent MOUSE_EVENT_RECORD + | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | InputMenuEvent MENU_EVENT_RECORD + | InputFocusEvent FOCUS_EVENT_RECORD + deriving (Show, Read, Eq) + +{- +typedef struct _INPUT_RECORD { + WORD EventType; + union { + KEY_EVENT_RECORD KeyEvent; + MOUSE_EVENT_RECORD MouseEvent; + WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; + MENU_EVENT_RECORD MenuEvent; + FOCUS_EVENT_RECORD FocusEvent; + } Event; +} INPUT_RECORD,*PINPUT_RECORD; +-} +data INPUT_RECORD = INPUT_RECORD + { inputEventType :: WORD + , inputEvent :: INPUT_RECORD_EVENT + } deriving (Show, Read, Eq) + +instance Storable INPUT_RECORD where + sizeOf _ = 20 + alignment _ = 4 + peek ptr = do + evType <- (`peekByteOff` 0) ptr + event <- case evType of + _ | evType == kEY_EVENT + -> InputKeyEvent <$> (`peekByteOff` 4) ptr + _ | evType == mOUSE_EVENT + -> InputMouseEvent <$> (`peekByteOff` 4) ptr + _ | evType == wINDOW_BUFFER_SIZE_EVENT + -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr + _ | evType == mENU_EVENT + -> InputMenuEvent <$> (`peekByteOff` 4) ptr + _ | evType == fOCUS_EVENT + -> InputFocusEvent <$> (`peekByteOff` 4) ptr + _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ + show evType + pure $ INPUT_RECORD evType event + poke ptr val = do + (`pokeByteOff` 0) ptr $ inputEventType val + case inputEvent val of + InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev + InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev + InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev + InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev + InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console. + +getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD +getNumberOfConsoleInputEvents hdl = + returnWith_ $ \ptrN -> + failIfFalse_ "GetNumberOfConsoleInputEvents" $ + cGetNumberOfConsoleInputEvents hdl ptrN + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console, cut down for the WCHAR version of readConsoleInput. + +readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] +readConsoleInput hdl len + = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr + +readConsoleInputWith :: HANDLE + -> DWORD + -> OutputHandler (Ptr INPUT_RECORD, DWORD) +readConsoleInputWith hdl len handler = + allocaArray (fromEnum len) $ \ptrBuf -> + alloca $ \ptrN -> do + failIfFalse_ "ReadConsoleInputW" $ + cReadConsoleInput hdl ptrBuf len ptrN + n <- peek ptrN + handler (ptrBuf, n) + +type OutputHandler o = forall a. (o -> IO a) -> IO a + +-- Replicated from module Foreign.C.String in package base because that module +-- does not export the function. +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] + +eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD +eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 + +iNVALID_HANDLE_VALUE :: HANDLE +iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound + +nullHANDLE :: HANDLE +nullHANDLE = nullPtr + +foreign import ccall unsafe "HsWin32.h _ansi_terminal_castUINTPtrToPtr" + castUINTPtrToPtr :: UINT_PTR -> Ptr a + +foreign import ccall unsafe "windows.h GetConsoleMode" + c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL + +foreign import ccall unsafe "windows.h SetConsoleMode" + c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL + +getConsoleMode :: HANDLE -> IO DWORD +getConsoleMode h = alloca $ \ptr -> do + failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr + peek ptr + +setConsoleMode :: HANDLE -> DWORD -> IO () +setConsoleMode h mode = failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h mode
+ win/System/Console/ANSI/Windows/Win32/MinTTY.hsc view
@@ -0,0 +1,256 @@+{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| This module is based on the corresponding code in the mintty package and the +Win32 package, in order to avoid a dependency on those packages. +-} +module System.Console.ANSI.Windows.Win32.MinTTY + ( isMinTTYHandle + ) where + +import Control.Exception ( catch ) +import Data.Int ( Int32 ) +import Data.List ( isInfixOf ) +import Data.Word ( Word8 ) +import Foreign.C.String + ( peekCWStringLen, withCAString, withCWString, withCWStringLen ) +import Foreign.C.Types ( CInt (..) ) +import Foreign.Marshal.Alloc ( alloca, allocaBytes ) +import Foreign.Marshal.Array ( advancePtr, copyArray ) +import Foreign.Marshal.Utils ( maybeWith ) +import Foreign.Ptr ( FunPtr, Ptr, castPtr, castPtrToFunPtr, plusPtr ) +import Foreign.Storable ( Storable (..) ) + +-- Provided by the ansi-terminal package +import System.Console.ANSI.Windows.Win32.Types + ( Addr, BOOL, DWORD, FileType, HANDLE, HMODULE, LPCSTR, LPCTSTR, LPTSTR + , TCHAR, ULONG, USHORT, failIfFalse_, failIfNeg, failIfNull + ) + +-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP. +-- Since we need some structs that are only available with Vista or later, +-- we must manually set WINVER/_WIN32_WINNT accordingly. +#undef WINVER +#define WINVER 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 +#include <windows.h> +#include "winternl_compat.h" + +#if __GLASGOW_HASKELL__ < 800 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +type F_NtQueryObject = + HANDLE + -> CInt + -> Ptr OBJECT_NAME_INFORMATION + -> ULONG + -> Ptr ULONG + -> IO NTSTATUS +type F_GetFileInformationByHandleEx = + HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL +type NTSTATUS = #type NTSTATUS + +data FILE_NAME_INFO = FILE_NAME_INFO + { fniFileNameLength :: DWORD + , fniFileName :: String + } + +instance Storable FILE_NAME_INFO where + sizeOf _ = #size FILE_NAME_INFO + alignment _ = #alignment FILE_NAME_INFO + poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName) + end = advancePtr start len' + (#poke FILE_NAME_INFO, FileNameLength) buf len' + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf + let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR + vfniFileName <- + peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len) + pure $ FILE_NAME_INFO + { fniFileNameLength = vfniFileNameLength + , fniFileName = vfniFileName + } + +newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION + { oniName :: UNICODE_STRING } + +instance Storable OBJECT_NAME_INFORMATION where + sizeOf _ = #size OBJECT_NAME_INFORMATION + alignment _ = #alignment OBJECT_NAME_INFORMATION + poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni) + peek buf = + fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf + +data UNICODE_STRING = UNICODE_STRING + { usLength :: USHORT + , usMaximumLength :: USHORT + , usBuffer :: String + } + +instance Storable UNICODE_STRING where + sizeOf _ = #size UNICODE_STRING + alignment _ = #alignment UNICODE_STRING + poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#size UNICODE_STRING) + end = advancePtr start len' + (#poke UNICODE_STRING, Length) buf len' + (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR) + (#poke UNICODE_STRING, Buffer) buf start + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vusLength <- (#peek UNICODE_STRING, Length) buf + vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf + vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf + let len = fromIntegral vusLength `div` sizeOfTCHAR + vusBuffer <- peekTStringLen (vusBufferPtr, len) + pure $ UNICODE_STRING + { usLength = vusLength + , usMaximumLength = vusMaximumLength + , usBuffer = vusBuffer + } + +-- | Returns 'True' is the given handle is attached to a MinTTY console +-- (e.g., Cygwin or MSYS). Returns 'False' otherwise. +isMinTTYHandle :: HANDLE -> IO Bool +isMinTTYHandle h = do + fileType <- getFileType h + if fileType /= fILE_TYPE_PIPE + then pure False + else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h + -- GetFileNameByHandleEx is only available on Vista and later (hence + -- the name isMinTTYVista). If we're on an older version of Windows, + -- getProcAddress will throw an IOException when it fails to find + -- GetFileNameByHandleEx, and thus we will default to using + -- NtQueryObject (isMinTTYCompat). + +isMinTTYVista :: HANDLE -> IO Bool +isMinTTYVista h = do + fn <- getFileNameByHandle h + pure $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> pure False + +cygwinMSYSCheck :: String -> Bool +cygwinMSYSCheck fn = + ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) + && "-pty" `isInfixOf` fn +-- Note that GetFileInformationByHandleEx might return a filepath like: +-- +-- \msys-dd50a72ab4668b33-pty1-to-master +-- +-- But NtQueryObject might return something like: +-- +-- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master +-- +-- This means we can't rely on "\cygwin-" or "\msys-" being at the very start +-- of the filepath. As a result, we use `isPrefixOf` to check for "cygwin" and +-- "msys". +-- +-- It's unclear if "-master" will always appear in the filepath name. Recent +-- versions of MinTTY have been known to give filepaths like this (#186): +-- +-- \msys-dd50a72ab4668b33-pty0-to-master-nat +-- +-- Just in case MinTTY ever changes this convention, we don't bother checking +-- for the presence of "-master" in the filepath name at all. + +isMinTTYCompat :: HANDLE -> IO Bool +isMinTTYCompat h = do + fn <- ntQueryObjectNameInformation h + pure $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> pure False + +fILE_TYPE_PIPE :: FileType +fILE_TYPE_PIPE = 3 + +ntQueryObjectNameInformation :: HANDLE -> IO String +ntQueryObjectNameInformation h = do + let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION) + bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> + alloca $ \p_len -> do + hwnd <- getModuleHandle (Just "ntdll.exe") + addr <- getProcAddress hwnd "NtQueryObject" + let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr addr) + _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject + h objectNameInformation buf (fromIntegral bufSize) p_len + oni <- peek buf + pure $ usBuffer $ oniName oni + +sizeOfTCHAR :: Int +sizeOfTCHAR = sizeOf (undefined :: TCHAR) + +getFileNameByHandle :: HANDLE -> IO String +getFileNameByHandle h = do + let sizeOfDWORD = sizeOf (undefined :: DWORD) + -- note: implicitly assuming that DWORD has stronger alignment than wchar_t + bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> do + getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) + fni <- peek buf + pure $ fniFileName fni + +getFileInformationByHandleEx :: + HANDLE + -> CInt + -> Ptr FILE_NAME_INFO + -> DWORD + -> IO () +getFileInformationByHandleEx h cls buf bufSize = do + lib <- getModuleHandle (Just "kernel32.dll") + ptr <- getProcAddress lib "GetFileInformationByHandleEx" + let c_GetFileInformationByHandleEx = + mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) + failIfFalse_ "getFileInformationByHandleEx" + (c_GetFileInformationByHandleEx h cls buf bufSize) + +getModuleHandle :: Maybe String -> IO HMODULE +getModuleHandle mb_name = + maybeWith withTString mb_name $ \ c_name -> + failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name + +getProcAddress :: HMODULE -> String -> IO Addr +getProcAddress hmod procname = + withCAString procname $ \ c_procname -> + failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname + +peekTStringLen :: (LPCTSTR, Int) -> IO String +peekTStringLen = peekCWStringLen + +withTString :: String -> (LPTSTR -> IO a) -> IO a +withTString = withCWString + +withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a +withTStringLen = withCWStringLen + +fileNameInfo :: CInt +fileNameInfo = #const FileNameInfo + +mAX_PATH :: Num a => a +mAX_PATH = #const MAX_PATH + +objectNameInformation :: CInt +objectNameInformation = #const ObjectNameInformation + +foreign import ccall "dynamic" + mk_GetFileInformationByHandleEx :: + FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx + +foreign import ccall unsafe "windows.h GetFileType" + getFileType :: HANDLE -> IO FileType + +foreign import ccall unsafe "windows.h GetProcAddress" + c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr + +foreign import ccall "dynamic" + mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject + +foreign import ccall unsafe "windows.h GetModuleHandleW" + c_GetModuleHandle :: LPCTSTR -> IO HMODULE
+ win/System/Console/ANSI/Windows/Win32/Types.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE Safe #-} + +{-| This module is based on the corresponding code in the Win32 package, in +order to avoid a dependency on that package. Some of that code had its origins +in earlier versions of this package. +-} +module System.Console.ANSI.Windows.Win32.Types + ( Addr + , BOOL + , DWORD + , ErrCode + , FileType + , HANDLE + , HMODULE + , LPCSTR + , LPCTSTR + , LPDWORD + , LPTSTR + , SHORT + , TCHAR + , UINT + , UINT_PTR + , ULONG + , USHORT + , WCHAR + , WORD + , failIfFalse_ + , failIfNeg + , failIfNull + , withHandleToHANDLE + ) where + +import Control.Concurrent.MVar ( readMVar ) +import Control.Exception ( bracket, throwIO ) +import Control.Monad ( when ) +import Data.Char ( isSpace ) +import Data.Typeable ( cast ) +import Data.Word ( Word16, Word32 ) +import Foreign.C.Error ( Errno (..), errnoToIOError ) +import Foreign.C.String ( peekCWString ) +import Foreign.C.Types ( CChar, CInt (..), CShort (..), CWchar ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.StablePtr ( StablePtr, freeStablePtr, newStablePtr ) +import GHC.IO.Handle.Types ( Handle (..), Handle__ (..) ) +import GHC.IO.FD ( FD(..) ) -- A wrapper around an Int32 +import Numeric ( showHex ) +import System.IO.Error ( ioeSetErrorString ) + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.Exception + ( IOErrorType (InappropriateType), IOException (IOError), ioException ) +import GHC.IO.SubSystem ( (<!>) ) +import GHC.IO.Windows.Handle ( ConsoleHandle, Io, NativeHandle, toHANDLE ) +#endif + +type Addr = Ptr () +type BOOL = Bool +type DWORD = Word32 +type ErrCode = DWORD +type FileType = DWORD +type HANDLE = Ptr () +type HMODULE = Ptr () +type LPCSTR = LPSTR +type LPCTSTR = LPTSTR +type LPDWORD = Ptr DWORD +type LPSTR = Ptr CChar +type LPTSTR = Ptr TCHAR +type LPWSTR = Ptr CWchar +type SHORT = CShort +type TCHAR = CWchar +type UINT = Word32 +type UINT_PTR = Word +type ULONG = Word32 +type USHORT = Word16 +type WCHAR = CWchar +type WORD = Word16 + +withStablePtr :: a -> (StablePtr a -> IO b) -> IO b +withStablePtr value = bracket (newStablePtr value) freeStablePtr + +#if defined(__IO_MANAGER_WINIO__) + +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLE = withHandleToHANDLEPosix <!> withHandleToHANDLENative + +withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLENative haskell_handle action = + withStablePtr haskell_handle $ const $ do + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar + windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE + action windows_handle + where + handle_ToHANDLE :: Handle__ -> IO HANDLE + handle_ToHANDLE (Handle__{haDevice = dev}) = + case ( cast dev :: Maybe (Io NativeHandle) + , cast dev :: Maybe (Io ConsoleHandle)) of + (Just hwnd, Nothing) -> pure $ toHANDLE hwnd + (Nothing, Just hwnd) -> pure $ toHANDLE hwnd + _ -> throwErr "not a known HANDLE" + + throwErr msg = ioException $ IOError (Just haskell_handle) + InappropriateType "withHandleToHANDLENative" msg Nothing Nothing + +#else + +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLE = withHandleToHANDLEPosix + +#endif + +withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLEPosix haskell_handle action = + -- Create a stable pointer to the Handle. This prevents the garbage collector + -- getting to it while we are doing horrible manipulations with it, and hence + -- stops it being finalized (and closed). + withStablePtr haskell_handle $ const $ do + -- Grab the write handle variable from the Handle + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar + -- This is "write" MVar, we could also take the "read" one + + -- Get the FD from the algebraic data type + Just fd <- (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) + <$> readMVar write_handle_mvar + + -- Finally, turn that (C-land) FD into a HANDLE using msvcrt + windows_handle <- c_get_osfhandle fd + -- Do what the user originally wanted + action windows_handle + +-- This essential function comes from the C runtime system. It is certainly +-- provided by msvcrt, and also seems to be provided by the mingw C library - +-- hurrah! +foreign import ccall unsafe "_get_osfhandle" + c_get_osfhandle :: CInt -> IO HANDLE + +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) + +failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +failIfFalse_ :: String -> IO Bool -> IO () +failIfFalse_ = failIf_ not + +failIf_ :: (a -> Bool) -> String -> IO a -> IO () +failIf_ p wh act = do + v <- act + when (p v) $ errorWin wh + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + msg <- if c_msg == nullPtr + then return $ "Error 0x" ++ Numeric.showHex err_code "" + else do + msg <- peekTString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + -- turn GetLastError() into errno, which errnoToIOError knows how to convert + -- to an IOException we can throw. + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + +peekTString :: LPCTSTR -> IO String +peekTString = peekCWString + +foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c + c_maperrno_func :: ErrCode -> IO Errno + +foreign import ccall unsafe "errors.h _ansi_terminal_getErrorMessage" + getErrorMessage :: DWORD -> IO LPWSTR + +foreign import ccall unsafe "windows.h GetLastError" + getLastError :: IO ErrCode + +foreign import ccall unsafe "windows.h LocalFree" + localFree :: Ptr a -> IO (Ptr a)
+ win/c-source/HsWin32.c view
@@ -0,0 +1,3 @@+// Out-of-line versions of all the inline functions from HsWin32.h +#define INLINE /* nothing */ +#include "HsWin32.h"
+ win/c-source/errors.c view
@@ -0,0 +1,39 @@+#define UNICODE +#include <stdio.h> +#include <stdlib.h> +#include <windows.h> +#include "errors.h" + +/* Copied from the Win32-2.13.4.0 package, but renamed `getErrorMessage` to + * `_ansi_terminal_getErrorMessage`, in order to avoid problems with duplicate + * symbols in GHC's object files. See: + * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. + */ + +/* There's two ways we can generate error messages - with different tradeoffs: + * If we do a function call, we have to use a static buffer. + * If we use a macro and ANSI C's string splicing, we have to use constant + * strings - and accept a certain amount of overhead from inserting the + * boilerplate text. + * + * Why the concern about performance? Error messages are only generated + * in exceptional situations -- sof 9/98 + * + * sof 9/98 : Removed use of non-standard (and wimpy :-) snprintf(). + */ + +LPTSTR _ansi_terminal_getErrorMessage(DWORD err) +{ + LPTSTR what; + + FormatMessage( + (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER) , + NULL, + err, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */ + (LPTSTR) &what, + 0, + NULL + ); + return what; +}
+ win/include/HsWin32.h view
@@ -0,0 +1,23 @@+#ifndef _ANSI_TERMINAL_HSWIN32_H +#define _ANSI_TERMINAL_HSWIN32_H + +#define UNICODE +#include <windows.h> + +/* Copied from the Win32-2.13.4.0 package, but renamed `castUINTPtrToPtr` to + * `_ansi_terminal_castUINTPtrToPtr`, in order to avoid problems with duplicate + * symbols in GHC's object files. See: + * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. + */ + +#ifndef INLINE +# if defined(_MSC_VER) +# define INLINE extern __inline +# else +# define INLINE extern inline +# endif +#endif + +INLINE void *_ansi_terminal_castUINTPtrToPtr(UINT_PTR n) { return (void *)n; } + +#endif /* _ANSI_TERMINAL_HSWIN32_H */
+ win/include/errors.h view
@@ -0,0 +1,22 @@+#ifndef _ANSI_TERMINAL_ERRORS_H +#define _ANSI_TERMINAL_ERRORS_H + +#include <windows.h> + +/* Copied from the Win32-2.13.4.0 package, but renamed `getErrorMessage` to + * `_ansi_terminal_getErrorMessage`, in order to avoid problems with duplicate + * symbols in GHC's object files. See: + * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. + */ + +/* There's two ways we can generate error messages - with different tradeoffs: + * If we do a function call, we have to use a static buffer. + * If we use a macro and ANSI C's string splicing, we have to use constant + * strings - and accept a certain amount of overhead from inserting the + * boilerplate text. + */ + +/* result should be freed using LocalFree */ +extern LPTSTR _ansi_terminal_getErrorMessage(DWORD err); + +#endif /* _ANSI_TERMINAL_ERRORS_H */
+ win/include/winternl_compat.h view
@@ -0,0 +1,31 @@+#ifndef WINTERNL_COMPAT_H +#define WINTERNL_COMPAT_H + +/* + * winternl.h is not included in MinGW, which was shipped with the 32-bit + * Windows version of GHC prior to the 7.10.3 release. + */ +#if defined(x86_64_HOST_ARCH) || \ + __GLASGOW_HASKELL__ >= 711 || \ + (__GLASGOW_HASKELL__ == 710 && \ + defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ + __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) +# include <winternl.h> +#else +// Some declarations from winternl.h that we need +# include <windows.h> + +typedef LONG NTSTATUS; + +typedef struct _UNICODE_STRING { + USHORT Length; + USHORT MaximumLength; + PWSTR Buffer; +} UNICODE_STRING; + +typedef struct _OBJECT_NAME_INFORMATION { + UNICODE_STRING Name; +} OBJECT_NAME_INFORMATION; +#endif + +#endif /* WINTERNL_COMPAT_H */