├── .gitattributes ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── Contributing.md ├── README.md ├── ansi-terminal-types ├── CHANGELOG.md ├── LICENSE ├── README.md ├── ansi-terminal-types.cabal ├── src │ └── System │ │ └── Console │ │ └── ANSI │ │ └── Types.hs └── stack.yaml ├── ansi-terminal ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── ansi-terminal.cabal ├── app │ └── Example.hs ├── src │ └── System │ │ └── Console │ │ ├── ANSI.hs │ │ └── ANSI │ │ └── Codes.hs ├── stack.yaml ├── unix │ └── System │ │ └── Console │ │ └── ANSI │ │ └── Internal.hs └── win │ ├── System │ └── Console │ │ └── ANSI │ │ ├── Internal.hs │ │ └── Windows │ │ ├── Foreign.hs │ │ └── Win32 │ │ ├── MinTTY.hsc │ │ └── Types.hs │ ├── c-source │ ├── HsWin32.c │ └── errors.c │ └── include │ ├── HsWin32.h │ ├── errors.h │ └── winternl_compat.h ├── cabal.project ├── example.png ├── release ├── stack-ghc-9.4.8.yaml ├── stack-ghc-9.6.6.yaml ├── stack-winio.yaml └── stack.yaml /.gitattributes: -------------------------------------------------------------------------------- 1 | README.md text eol=lf 2 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | ubuntu: 12 | runs-on: ubuntu-latest 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | cabal: ["3.8"] 17 | # no ghc-7.10.3 available 18 | ghc: 19 | - "8.0.2" 20 | - "8.2.2" 21 | - "8.4.4" 22 | - "8.6.5" 23 | - "8.8.4" 24 | - "8.10.7" 25 | - "9.0.2" 26 | - "9.2.8" 27 | - "9.4.8" 28 | include: 29 | - ghc: "9.6.6" 30 | cabal: "3.10" 31 | - ghc: "9.8.4" 32 | cabal: "3.10" 33 | - ghc: "9.10.1" 34 | cabal: "3.10" 35 | - ghc: "9.12.1" 36 | cabal: "3.14" 37 | steps: 38 | - uses: actions/checkout@v4 39 | - uses: haskell-actions/setup@v2 40 | id: setup-haskell-cabal 41 | with: 42 | ghc-version: ${{ matrix.ghc }} 43 | cabal-version: ${{ matrix.cabal }} 44 | - run: cabal v2-update 45 | - run: cabal v2-freeze 46 | - uses: actions/cache@v4 47 | with: 48 | path: | 49 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 50 | dist-newstyle 51 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 52 | restore-keys: | 53 | ${{ runner.os }}-${{ matrix.ghc }}- 54 | - run: cabal v2-build all 55 | windows: 56 | runs-on: windows-latest 57 | strategy: 58 | fail-fast: false 59 | matrix: 60 | cabal: ["3.8"] 61 | # choco install ghc --version 7.10.3 is broken 62 | ghc: 63 | - "7.10.3.2" 64 | - "8.0.2" 65 | - "8.2.2" 66 | - "8.4.4" 67 | - "8.6.5" 68 | - "8.8.4" 69 | - "8.10.7" 70 | winio: [false] 71 | include: 72 | - ghc: "9.0.2" 73 | cabal: "3.8" 74 | winio: true 75 | - ghc: "9.2.8" 76 | cabal: "3.8" 77 | winio: true 78 | - ghc: "9.4.8" 79 | cabal: "3.8" 80 | winio: true 81 | - ghc: "9.6.6" 82 | cabal: "3.10" 83 | winio: true 84 | - ghc: "9.8.4" 85 | cabal: "3.10" 86 | winio: true 87 | - ghc: "9.10.1" 88 | cabal: "3.10" 89 | winio: true 90 | - ghc: "9.12.1" 91 | cabal: "3.14" 92 | winio: true 93 | steps: 94 | - uses: actions/checkout@v4 95 | - uses: haskell-actions/setup@v2 96 | id: setup-haskell-cabal 97 | with: 98 | ghc-version: ${{ matrix.ghc }} 99 | cabal-version: ${{ matrix.cabal }} 100 | - run: cabal v2-update 101 | - run: cabal v2-freeze 102 | - uses: actions/cache@v4 103 | with: 104 | path: | 105 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 106 | dist-newstyle 107 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 108 | restore-keys: | 109 | ${{ runner.os }}-${{ matrix.ghc }}- 110 | - run: cabal v2-build all 111 | - if: matrix.winio 112 | run: cabal v2-build all --ghc-option=-with-rtsopts=--io-manager=native 113 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Build artifacts 2 | dist/ 3 | dist-newstyle/ 4 | .ghc.* 5 | *.hi 6 | *.o 7 | 8 | # Haddock documentation 9 | docs/ 10 | 11 | # Haskell Tool Stack-related 12 | .stack-work/ 13 | *.yaml.lock 14 | 15 | # Operating system rubbish 16 | .DS_Store 17 | Thumbs.db 18 | -------------------------------------------------------------------------------- /Contributing.md: -------------------------------------------------------------------------------- 1 | Many other packages depend on `ansi-terminal`. As at November 2024, over 4,800 2 | packages on [Hackage](https:https://hackage.haskell.org/) depend on it, directly 3 | or indirectly. Consider raising an 4 | [issue](https://github.com/UnkindPartition/ansi-terminal/issues) to 5 | discuss a proposed change before making a pull request. 6 | 7 | The `ansi-terminal` and `ansi-terminal-types` packages aim to have: 8 | * limited dependency on other packages, even those included with GHC; 9 | * a high degree of backwards compatibility with earlier versions of GHC; and 10 | * comprehensive and high-quality Haddock documentation. 11 | 12 | As of `ansi-terminal-1.0.1`, the package aims to be compatible with versions 13 | of GHC from GHC 7.10.1 (released March 2015). GHC 7.10.1 comes with: 14 | * `base-4.8.0.0` 15 | 16 | The `ansi-terminal` package also depends on: 17 | * `ansi-terminal-types`, which exposes module `System.Console.ANSI.Types`. The 18 | package is provided to avoid circular dependencies in some circumstances; and 19 | * `colour-2.1.0` or later, used for 24-bit colour (`Colour`, `RGB`, `toSRGB` and 20 | `toSRGB24`). 21 | 22 | The `ansi-terminal` package aims to avoid a dependency on the `Win32` package, 23 | because of its dependency on the `filepath` package. It does that by reproducing 24 | the small part of the `Win32` and `mintty` packages on which it would otherwise 25 | rely. 26 | 27 | The `ansi-terminal` and `ansi-terminal-types` packages achieve that backward 28 | compatibility by using C Pre-Processor (CPP) directives. The `CPP` GHC extension 29 | is specified for the libraries in the Cabal files. 30 | 31 | Separate 'Unix' and Windows versions of the package used to exist because, 32 | before Windows 10 version 1511, the native terminal software on Windows did not 33 | support the control sequences and emulation was required. Microsoft has not 34 | supported Windows XP since 8 April 2014 (and GHC has not supported Windows XP 35 | from GHC 8.0.1 of May 2016); Windows Server 2003 since 14 July 2015; Windows 36 | Vista since 11 April 2017; Windows 7, service pack 1 since 10 January 2023; 37 | Windows 8.1 since 10 January 2023; and Windows 10, version 1507 (which 1511 of 38 | December 2015 updated) since 9 May 2017. Consequently, there is no longer any 39 | version of Windows that both has support by Microsoft and needs emulation. 40 | 41 | The package uses GHC's 'Safe Haskell' language extension `Safe` (introduced in 42 | GHC 7.2.1 but not stable until GHC 7.4.1) to add flags explicitly to all 43 | modules. 44 | 45 | The source code generally follows 46 | [Johan Tibell's style guide](https://github.com/tibbe/haskell-style-guide), but 47 | with code blocks indented with 2 spaces (rather than 4 spaces). 48 | 49 | Pull requests should be organised into logical commits with useful commit 50 | messages. There is no need to change the package version number or update 51 | `CHANGELOG.md`. This will be done by the package maintainers when a further 52 | version is published on Hackage. 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ansi-terminal and ansi-terminal-types [![GitHub CI](https://github.com/UnkindPartition/ansi-terminal/workflows/CI/badge.svg)](https://github.com/UnkindPartition/ansi-terminal/actions) 2 | ===================================== 3 | 4 | Haskell packages together providing support for 'ANSI' control character 5 | sequences for terminals on Unix-like operating systems and Windows 6 | 7 | Description 8 | ----------- 9 | 10 | ['ANSI' terminal escape code](http://en.wikipedia.org/wiki/ANSI_escape_sequences) 11 | support for Haskell, which allows: 12 | - Colored text output, with control over foreground, background and (where 13 | supported) underlining colors 14 | - Clearing parts of a line or the screen 15 | - Hiding or showing the cursor 16 | - Moving the cursor around 17 | - Reporting the position of the cursor 18 | - Enabling and disabling automatic line wrapping 19 | - Scrolling the screen up or down 20 | - Switching between the Alternate and Normal Screen Buffers 21 | - Clickable hyperlinks to URIs 22 | - Changing the title of the terminal 23 | 24 | If you like this, you may be interested in 25 | [ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which 26 | provides a pretty-printer that can construct strings containing 'ANSI' 27 | colorisation. 28 | 29 | Not all 'ANSI' escape codes are suported by this library but most (if not 30 | all) of the popular ones that are well-supported by terminal software are, 31 | including: 32 | - Select Graphic Rendition mode (colors and other attributes): `setSGR` 33 | - Clearing parts of the screen: `clearFromCursorToScreenEnd`, 34 | `clearFromCursorToScreenBeginning`, `clearScreen`, 35 | `clearFromCursorToLineEnd`, `clearFromCursorToLineBeginning` and 36 | `clearLine` 37 | - Cursor visibility changes: `hideCursor` and `showCursor` 38 | - Cursor movement by character: `cursorUp`, `cursorDown`, `cursorForward` and 39 | `cursorBackward` 40 | - Cursor movement by line: `cursorUpLine` and `cursorDownLine` 41 | - Directly changing cursor position: `setCursorColumn` and `setCursorPosition` 42 | - Saving, restoring and reporting cursor position: `saveCursor`, 43 | `restoreCursor` and `reportCursorPosition` 44 | - Automatic line wrapping: `enableLineWrap` and `disableLineWrap` 45 | - Scrolling the screen: `scrollPageUp` and `scrollPageDown` 46 | - Changing the title: `setTitle` 47 | 48 | Each supported escape code or family of codes has a corresponding 49 | function that comes in three variants: 50 | 51 | - A straight `IO` variant that doesn't take a `Handle` and just applies the 52 | escape code to `stdout` and any terminal attached to it 53 | - An `IO` variant similar to above, but which takes a `Handle` to which the 54 | escape code should be applied 55 | - A `String` variant that returns a literal string that should be 56 | included to get the effect of the code. 57 | 58 | Example 59 | ------- 60 | 61 | A full example is 62 | [available](https://github.com/UnkindPartition/ansi-terminal/blob/master/ansi-terminal/app/Example.hs), 63 | but for a taste of how the library works try the following code: 64 | 65 | ``` haskell 66 | import System.Console.ANSI 67 | import System.IO (stdout) 68 | 69 | main :: IO () 70 | main = do 71 | stdoutSupportsANSI <- hNowSupportsANSI stdout 72 | if stdoutSupportsANSI 73 | then do 74 | setCursorPosition 5 0 75 | setTitle "ANSI Terminal Short Example" 76 | 77 | setSGR [ SetConsoleIntensity BoldIntensity 78 | , SetColor Foreground Vivid Red 79 | ] 80 | putStr "Hello" 81 | 82 | setSGR [ SetConsoleIntensity NormalIntensity 83 | , SetColor Foreground Vivid White 84 | , SetColor Background Dull Blue 85 | ] 86 | putStrLn "World!" 87 | else 88 | putStrLn "Standard output does not support 'ANSI' escape codes." 89 | ``` 90 | 91 | ![](https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/example.png) 92 | 93 | Documentation 94 | ------------- 95 | 96 | Haddock documentation is available at Hackage 97 | ([`ansi-terminal`](http://hackage.haskell.org/packages/archive/ansi-terminal/latest/doc/html/System-Console-ANSI.html)) 98 | and 99 | ([`ansi-terminal-types`](http://hackage.haskell.org/packages/archive/ansi-terminal-types/latest/doc/html/System-Console-ANSI-Types.html)). 100 | 101 | Credits 102 | ------- 103 | 104 | The library was originally written by [Max Bolingbroke](https://github.com/batterseapower) 105 | 106 | Maintainers 107 | ----------- 108 | 109 | [Mike Pilgrem](https://github.com/mpilgrem) and [Roman Cheplyaka](https://github.com/UnkindPartition) are the primary maintainers. 110 | 111 | [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please 112 | get in touch with him if the primary maintainers cannot be reached. 113 | -------------------------------------------------------------------------------- /ansi-terminal-types/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changes 2 | ======= 3 | 4 | Version 1.1 5 | -------------- 6 | 7 | * Add `Underlining` constructor to type `ConsoleLayer`. 8 | * Add `CurlyUnderline`, `DottedUnderline`, and `DashedUnderline` constructors to 9 | type `Underlining`. 10 | 11 | Version 0.11.5 12 | -------------- 13 | 14 | * Initial version, spun out of the `ansi-terminal-0.11.4` package. 15 | -------------------------------------------------------------------------------- /ansi-terminal-types/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors 13 | may be used to endorse or promote products derived from this software without 14 | specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 17 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 23 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /ansi-terminal-types/README.md: -------------------------------------------------------------------------------- 1 | ansi-terminal-types 2 | [![GitHub CI](https://github.com/UnkindPartition/ansi-terminal/workflows/CI/badge.svg)](https://github.com/UnkindPartition/ansi-terminal/actions) 3 | =================== 4 | 5 | A Haskell package providing types and functions used to represent SGR 6 | (SELECT GRAPHIC RENDITION) aspects of 'ANSI' control character sequences for 7 | terminals. 8 | 9 | Documentation 10 | ------------- 11 | 12 | Haddock documentation is available at 13 | [Hackage](http://hackage.haskell.org/packages/archive/ansi-terminal-types/latest/doc/html/System-Console-ANSI-Types.html). 14 | 15 | Credits 16 | ------- 17 | 18 | This package was spun out of the `ansi-terminal` package, a library originally 19 | written by [Max Bolingbroke](https://github.com/batterseapower) 20 | 21 | Maintainers 22 | ----------- 23 | 24 | [Mike Pilgrem](https://github.com/mpilgrem) and 25 | [Roman Cheplyaka](https://github.com/UnkindPartition) are the primary 26 | maintainers. 27 | 28 | [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please 29 | get in touch with him if the primary maintainers cannot be reached. 30 | -------------------------------------------------------------------------------- /ansi-terminal-types/ansi-terminal-types.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: 1.22 2 | Name: ansi-terminal-types 3 | Version: 1.1 4 | Category: User Interfaces 5 | Synopsis: Types and functions used to represent SGR aspects 6 | Description: The \'ANSI\' standards refer to the visual style of 7 | displaying characters as their \'graphic rendition\'. The 8 | \'ANSI\' codes to establish the graphic rendition for 9 | subsequent text are referred to as SELECT GRAPHIC RENDITION 10 | (SGR). This package exposes modules that export types and 11 | functions used to represent SGR aspects. 12 | License: BSD3 13 | License-File: LICENSE 14 | Author: Max Bolingbroke 15 | Maintainer: Mike Pilgrem , Roman Cheplyaka 16 | Homepage: https://github.com/UnkindPartition/ansi-terminal 17 | Build-Type: Simple 18 | 19 | Extra-Source-Files: CHANGELOG.md 20 | README.md 21 | 22 | Source-repository head 23 | type: git 24 | location: git://github.com/UnkindPartition/ansi-terminal.git 25 | 26 | Library 27 | Hs-Source-Dirs: src 28 | Exposed-Modules: System.Console.ANSI.Types 29 | Build-Depends: base >= 4.8.0.0 && < 5 30 | , colour >= 2.1.0 31 | Default-Extensions: CPP 32 | Ghc-Options: -Wall 33 | Default-Language: Haskell2010 34 | -------------------------------------------------------------------------------- /ansi-terminal-types/src/System/Console/ANSI/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | {-| The \'ANSI\' standards refer to the visual style of displaying characters as 4 | their \'graphic rendition\'. The style includes the color of a character, its 5 | background, or (where supported) its underlining; the intensity (bold, normal or 6 | faint) of a character; or whether the character is italic or underlined (single, 7 | double, curly, dotted or dashed), blinking (slowly or rapidly) or visible or 8 | not. The \'ANSI\' codes to establish the graphic rendition for subsequent text 9 | are referred to as SELECT GRAPHIC RENDITION (SGR). 10 | 11 | This module exports types and functions used to represent SGR aspects. See also 12 | 'System.Console.ANSI.setSGR' and related functions provided by the 13 | @ansi-terminal@ package. 14 | -} 15 | module System.Console.ANSI.Types 16 | ( 17 | -- * Types used to represent SGR aspects 18 | SGR (..) 19 | , ConsoleLayer (..) 20 | , Color (..) 21 | , ColorIntensity (..) 22 | , ConsoleIntensity (..) 23 | , Underlining (..) 24 | , BlinkSpeed (..) 25 | -- * Constructors of xterm 256-color palette indices 26 | , xterm6LevelRGB 27 | , xterm24LevelGray 28 | , xtermSystem 29 | ) where 30 | 31 | import Data.Ix (Ix) 32 | import Data.Word (Word8) 33 | 34 | import Data.Colour (Colour) 35 | 36 | -- | ANSI's eight standard colors. They come in two intensities, which are 37 | -- controlled by 'ColorIntensity'. Many terminals allow the colors of the 38 | -- standard palette to be customised, so that, for example, 39 | -- @setSGR [ SetColor Foreground Vivid Green ]@ may not result in bright green 40 | -- characters. 41 | data Color 42 | = Black 43 | | Red 44 | | Green 45 | | Yellow 46 | | Blue 47 | | Magenta 48 | | Cyan 49 | | White 50 | deriving (Bounded, Enum, Eq, Ix, Ord, Read, Show) 51 | 52 | -- | ANSI's standard colors come in two intensities 53 | data ColorIntensity 54 | = Dull 55 | | Vivid 56 | deriving (Bounded, Eq, Enum, Ix, Ord, Read, Show) 57 | 58 | -- | ANSI colors can be set on three different layers 59 | data ConsoleLayer 60 | = Foreground 61 | | Background 62 | | Underlining 63 | -- ^ Not widely supported. 64 | -- 65 | -- @since 1.1 66 | deriving (Bounded, Eq, Enum, Ix, Ord, Read, Show) 67 | 68 | -- | ANSI blink speeds: values other than 'NoBlink' are not widely supported 69 | data BlinkSpeed 70 | = SlowBlink -- ^ Less than 150 blinks per minute 71 | | RapidBlink -- ^ More than 150 blinks per minute 72 | | NoBlink 73 | deriving (Bounded, Eq, Enum, Ix, Ord, Read, Show) 74 | 75 | -- | ANSI text underlining 76 | data Underlining 77 | = SingleUnderline 78 | | DoubleUnderline 79 | -- ^ Not widely supported. 80 | | CurlyUnderline 81 | -- ^ Not widely supported. 82 | -- 83 | -- @since 1.1 84 | | DottedUnderline 85 | -- ^ Not widely supported. 86 | -- 87 | -- @since 1.1 88 | | DashedUnderline 89 | -- ^ Not widely supported. 90 | -- 91 | -- @since 1.1 92 | | NoUnderline 93 | deriving (Bounded, Eq, Enum, Ix, Ord, Read, Show) 94 | 95 | -- | ANSI general console intensity: usually treated as setting the font style 96 | -- (e.g. 'BoldIntensity' causes text to be bold) 97 | data ConsoleIntensity 98 | = BoldIntensity 99 | -- | Not widely supported: sometimes treated as concealing text. Not supported 100 | -- natively on Windows 10 101 | | FaintIntensity 102 | | NormalIntensity 103 | deriving (Bounded, Eq, Enum, Ix, Ord, Read, Show) 104 | 105 | -- | ANSI Select Graphic Rendition (SGR) command 106 | -- 107 | -- In respect of colors, there are three alternative commands: 108 | -- 109 | -- (1) the \'ANSI\' standards allow for eight standard colors (with two 110 | -- intensities). Windows and many other terminals (including xterm) allow the 111 | -- user to redefine the standard colors (so, for example 'Vivid' 'Green' may not 112 | -- correspond to bright green; 113 | -- 114 | -- (2) an extension of the standard that allows true colors (24 bit color depth) 115 | -- in RGB space. This is usually the best alternative for more colors; and 116 | -- 117 | -- (3) another extension that allows a palette of 256 colors, each color 118 | -- specified by an index. Xterm provides a protocol for a palette of 256 colors 119 | -- that many other terminals, including Windows 10, follow. Some terminals 120 | -- (including xterm) allow the user to redefine some or all of the palette 121 | -- colors. 122 | data SGR 123 | -- | Default rendition, cancels the effect of any preceding occurrence of SGR 124 | -- (implementation-defined) 125 | = Reset 126 | -- | Set the character intensity. Partially supported natively on Windows 10 127 | | SetConsoleIntensity !ConsoleIntensity 128 | -- | Set italicized. Not widely supported: sometimes treated as swapping 129 | -- foreground and background. Not supported natively on Windows 10 130 | | SetItalicized !Bool 131 | -- | Set or clear underlining. Partially supported natively on Windows 10 132 | | SetUnderlining !Underlining 133 | -- | Set or clear character blinking. Not supported natively on Windows 10 134 | | SetBlinkSpeed !BlinkSpeed 135 | -- | Set revealed or concealed. Not widely supported. Not supported natively 136 | -- on Windows 10 137 | | SetVisible !Bool 138 | -- | Set negative or positive image. Supported natively on Windows 10 139 | | SetSwapForegroundBackground !Bool 140 | -- | Set a color from the standard palette of 16 colors (8 colors by 2 141 | -- color intensities). Many terminals allow the palette colors to be 142 | -- customised 143 | | SetColor !ConsoleLayer !ColorIntensity !Color 144 | -- | Set a true color (24 bit color depth). Supported natively on Windows 10 145 | -- from the Creators Update (April 2017) 146 | -- 147 | -- @since 0.7 148 | | SetRGBColor !ConsoleLayer !(Colour Float) 149 | -- | Set a color from a palette of 256 colors using a numerical index 150 | -- (0-based). Supported natively on Windows 10 from the Creators Update (April 151 | -- 2017) but not on legacy Windows native terminals. See 'xtermSystem', 152 | -- 'xterm6LevelRGB' and 'xterm24LevelGray' to construct indices based on 153 | -- xterm's standard protocol for a 256-color palette. 154 | -- 155 | -- @since 0.9 156 | | SetPaletteColor !ConsoleLayer !Word8 157 | -- | Set a color to the default (implementation-defined) 158 | -- 159 | -- @since 0.10 160 | | SetDefaultColor !ConsoleLayer 161 | deriving (Eq, Read, Show) 162 | 163 | -- | Given xterm's standard protocol for a 256-color palette, returns the index 164 | -- to that part of the palette which is a 6 level (6x6x6) color cube of 216 RGB 165 | -- colors. Throws an error if any of the red, green or blue channels is outside 166 | -- the range 0 to 5. An example of use is: 167 | -- 168 | -- >>> setSGR [ SetPaletteColor $ xterm6LevelRGB 5 2 0 ] -- Dark Orange 169 | -- 170 | -- @since 0.9 171 | xterm6LevelRGB :: Int -> Int -> Int -> Word8 172 | xterm6LevelRGB r g b 173 | -- RGB colors are represented by index: 174 | -- 16 + 36 × r + 6 × g + b (0 ≤ r, g, b ≤ 5) 175 | | r >= 0 && r < 6 && g >= 0 && g < 6 && b >= 0 && b < 6 176 | = fromIntegral $ 16 + 36 * r + 6 * g + b 177 | | otherwise 178 | = error $ show r ++ " " ++ show g ++ " " ++ show b ++ " (r g b) is " ++ 179 | "outside of a 6 level (6x6x6) color cube." 180 | 181 | -- | Given xterm's standard protocol for a 256-color palette, returns the index 182 | -- to that part of the palette which is a spectrum of 24 grays, from dark 183 | -- gray (0) to near white (23) (black and white are themselves excluded). Throws 184 | -- an error if the gray is outside of the range 0 to 23. An example of use is: 185 | -- 186 | -- >>> setSGR [ SetPaletteColor $ xterm24LevelGray 12 ] -- Gray50 187 | -- 188 | -- @since 0.9 189 | xterm24LevelGray :: Int -> Word8 190 | xterm24LevelGray y 191 | -- Grayscale colors are represented by index: 192 | -- 232 + g (0 ≤ g ≤ 23) 193 | | y >= 0 && y < 24 = fromIntegral $ 232 + y 194 | | otherwise 195 | = error $ show y ++ " (gray) is outside of the range 0 to 23." 196 | 197 | -- | Given xterm's standard protocol for a 256-color palette, returns the index 198 | -- to that part of the palette which corresponds to the \'ANSI\' standards' 16 199 | -- standard, or \'system\', colors (eight colors in two intensities). An example 200 | -- of use is: 201 | -- 202 | -- >>> setSGR [ SetPaletteColor $ xtermSystem Vivid Green ] 203 | -- 204 | -- @since 0.9 205 | xtermSystem :: ColorIntensity -> Color -> Word8 206 | xtermSystem intensity color 207 | | intensity == Dull = index 208 | | otherwise = index + 8 209 | where 210 | index = fromIntegral $ fromEnum color 211 | -------------------------------------------------------------------------------- /ansi-terminal-types/stack.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-23.2 # GHC 9.8.4 2 | -------------------------------------------------------------------------------- /ansi-terminal/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changes 2 | ======= 3 | 4 | Version 1.1.2 5 | ------------- 6 | 7 | * Add `enableLineWrap` and `disableLineWrap`, and support for enabling and 8 | disabling automatic line wrapping. 9 | 10 | Version 1.1.1 11 | ------------- 12 | 13 | * Use of C function `setenv()` in one thread can cause other threads calling C 14 | functions that query environment variables to crash. On Unix-like operating 15 | systems, where such functions are used, the implementations of 16 | `hSupportsANSI` and `hSupportsANSIColor` now avoid unnecessary calls of 17 | `System.Environment.lookupEnv`. 18 | 19 | * Improvements to Haddock documentation. 20 | 21 | Version 1.1 22 | ----------- 23 | 24 | * Add support for console layer `Underlining` and underlining styles 25 | `CurlyUnderline`, `DottedUnderline` and `DashedUnderline`. 26 | * Add type synonyms `Parameter`, `SubParam`, and `ParamWithSubs` to represent 27 | SGR parameter values with and without following parameter substrings comprised 28 | of one or more parameter elements (including empty elements). 29 | * Add `csi'` and `sgrToCode'`, corresponding to `csi` and `sgrToCode` but 30 | capable of handling a parameter value followed by a parameter substring. 31 | 32 | Version 1.0.2 33 | ------------- 34 | 35 | * On Windows, fix linker error about a duplicate symbol `castUINTPtrToPtr`. 36 | 37 | Version 1.0.1 38 | ------------- 39 | 40 | * On Windows, the processing of \'ANSI\' control characters in output is enabled 41 | by default in Windows Terminal but is not enabled by default in ConHost 42 | terminals. Additions have been made to allow support of users of ConHost 43 | terminals. 44 | * Add `hNowSupportsANSI`. On Unix, the function is equivalent to 45 | `hSupportsANSI`. On Windows, in Windows Terminal and ConHost terminals, the 46 | action can try to enable the processing of \'ANSI\' control characters in 47 | output. 48 | * In Windows Terminal and ConHost terminals, `hSupportsANSI` will yield `False` 49 | if the processing of \'ANSI\' control characters in output is not enabled. 50 | * Deprecated `hSupportsANSIWithoutEmulation` is now consistent with 51 | `hNowSupportsANSI`. 52 | * Improvements to Haddock documentation. 53 | Version 1.0 54 | ----------- 55 | 56 | * On Windows, drop support for legacy Windows requiring emulation. The package 57 | assumes Windows Terminal has replaced ConHost terminals on supported versions 58 | of Windows. Functions that yield actions no longer enable (re-enable) the 59 | processing of \'ANSI\' control characters in output. 60 | * On Windows, the package no longer depends (directly or indirectly) on the 61 | `Win32`, `array`,`containers`, `deepseq`, `filepath`, `ghc-boot-th`, `mintty`, 62 | `pretty` or `template-haskell` packages. 63 | * `hSupportsANSI` no longer assumes that the given handle is writeable. 64 | * `hSupportsANSIWithoutEmulation` is deprecated. 65 | 66 | Version 0.11.5 67 | -------------- 68 | 69 | * Module `System.Console.ANSI.Types` spun out to new dependency package 70 | `ansi-terminal-types-0.11.5`. 71 | * Drop support for GHC versions before GHC 7.10.1 (released March 2015). 72 | * Improvements to Haddock documentation. 73 | 74 | Version 0.11.4 75 | -------------- 76 | 77 | * Add `reportLayerColor`, `getReportedLayerColor` and `getLayerColor` for 78 | querying the layer color on terminals that support the functionality. 79 | * Add `useAlternateScreenBuffer` and `useNormalScreenBuffer`, and support for 80 | switching between the Alternate and Normal Screen Buffers. 81 | * When the argument is `0`, `cursorUpCode`, `cursorDownCode`, 82 | `cursorForwardCode`, `cursorBackwardCode`,`scrollPageUpCode` and 83 | `scrollPageDownCode` now yield `""`, and `cursorUpLineCode` and 84 | `cursorDownLineCode` now yield the equivalent of `setCursorColumnCode 0`. This 85 | is because, on some terminals, a `0` parameter for the underlying 'ANSI' code 86 | specifies a default parameter of `1`. 87 | * Add `osc` as a utility function, for OSC sequences. 88 | * `setTitle` now uses the recommended STRING TERMINATOR (ST) of `\ESC\\`, rather 89 | than the legacy `\BEL` (`\007`), and filters the title of all non-printable 90 | characters, not just `\BEL`. 91 | * Improvements to Haddock documentation. 92 | 93 | Version 0.11.3 94 | -------------- 95 | 96 | * Add `hyperlink`, `hyperlinkWithId` and `hyperlinkWithParams`, and support for 97 | clickable hyperlinks. 98 | 99 | Version 0.11.2 100 | -------------- 101 | 102 | * On Windows, fix compatability with the Windows I/O Manager (WinIO) when 103 | GHC >= 9.0.1 but `Win32` < 2.9.0.0. 104 | * Improvements to Haddock documentation. 105 | 106 | Version 0.11.1 107 | -------------- 108 | 109 | * On Windows, fix compatability with the Windows I/O Manager (WinIO) introduced 110 | in GHC 9.0.1, by incorporating changes made in package `Win32-2.13.2.0` in 111 | that regard. 112 | * Improvements to Haddock documentation. 113 | 114 | Version 0.11 115 | ------------ 116 | 117 | * Remove deprecated `getCursorPosition0`. (Use `getCursorPosition` instead.) 118 | * On Unix-like operating systems, the temporary turning off of echoing is moved 119 | from `getReportedCursorPosition` to `hGetCursorPositon`. 120 | * On Unix-like operating systems, fix a bug in `getCursorPosition` and 121 | `hGetCursorPosition`, where the console input stream was was not always 122 | clear before the cursor position was emitted into it. 123 | 124 | Version 0.10.3 125 | -------------- 126 | 127 | * Add `getCursorPosition` as a synonym of `getCursorPosition0` and deprecate the 128 | latter. 129 | 130 | Version 0.10.2 131 | -------------- 132 | 133 | * `hGetTerminalSize` now assumes a terminal is no bigger than 9,999 by 9,999 134 | (previously, no bigger than 999 by 999). 135 | * On Windows, fix a bug where emulated cursor movement functions differed from 136 | Windows 10 (movement bounded by the current viewport). 137 | 138 | Version 0.10.1 139 | -------------- 140 | 141 | * Add `hGetCursorPosition` and `hGetTerminalSize`. 142 | * On Unix-like operating systems, fix a bug where `getReportedCursorPosition` 143 | could block indefinitely if no information was forthcoming on the console 144 | input stream. 145 | * Improvements to Haddock documentation. 146 | 147 | Version 0.10 148 | ------------ 149 | 150 | * Add support for setting the default color with new `SetDefaultColor` 151 | constructor of the `SGR` type. 152 | * `getTerminalSize` now flushes the `stdout` channel, to ensure the cursor 153 | position is unaffected. 154 | 155 | Version 0.9.1 156 | ------------- 157 | 158 | * Flag modules with GHC's 'Safe Haskell' language extensions (from GHC 7.2.1). 159 | * Improvements and corrections to Haddock documentation. 160 | 161 | Version 0.9 162 | ----------- 163 | 164 | * Add support for 256-color palettes with new `SetPaletteColor` constructor of 165 | the `SGR` type, and `xterm6LevelRGB`, `xterm24LevelGray` and `xtermSystem`. 166 | * Remove deprecated `getCursorPosition`. (Use `getCursorPosition0` instead.) 167 | * Add `hSupportsANSIColor`. 168 | * Add `getTerminalSize`. 169 | * Improvements to Haddock documentation. 170 | 171 | Version 0.8.2 172 | ------------- 173 | 174 | * Add `getCursorPosition0` and deprecate `getCursorPosition`. Any position 175 | provided by the latter is 1-based. Any position provided by the former is 176 | 0-based, consistent with `setCursorColumn` and `setCursorPosition`. 177 | * Improvements to Haddock documentation in respect of 0-based and 1-based 178 | cursor positions. 179 | 180 | Version 0.8.1 181 | ------------- 182 | 183 | * Add `hSupportsANSIWithoutEmulation`. On Windows 10, if the handle is 184 | identified as connected to a native terminal ('Command Prompt' or 185 | 'PowerShell'), the processing of 'ANSI' control characters will be enabled. 186 | 187 | Version 0.8.0.4 188 | --------------- 189 | 190 | * On Windows, `hSupportsANSI` now recognises if the handle is connected to a 191 | 'mintty' terminal. 192 | * Drop support for GHC versions before GHC 7.0.1 (released November 2010) 193 | 194 | Version 0.8.0.3 195 | --------------- 196 | 197 | * On Windows, try to enable ANSI on ConHost terminals even if a TERM environment 198 | variable exits (such as with the Hyper 2 terminal) 199 | * Minor improvements to Haddock documentation 200 | 201 | Version 0.8.0.2 202 | --------------- 203 | 204 | * Improve README and Haddock documentation 205 | * On Windows, fix compatability with earlier GHC versions 206 | * Drop support for GHC versions before 6.12.1 (released December 2009) 207 | 208 | Version 0.8.0.1 209 | --------------- 210 | 211 | * On Windows, if the standard output channel is valid but not a ConHost 212 | terminal, assume it is ANSI-enabled rather than failing 213 | * On Windows, output the improved error message to the standard error channel 214 | rather than the standard output channel 215 | 216 | Version 0.8 217 | ----------- 218 | 219 | * Make the fields of `SGR` strict 220 | * Make compatible with GHC 8.2.2 221 | * Improve the error message on Windows when not ANSI-capable or ConHost 222 | * Recognise Appveyor build environment as ANSI-enabled 223 | 224 | Version 0.7.1.1 225 | --------------- 226 | 227 | `getReportedCursorPosition`: don't let the cursor reporting code be echo'd 228 | 229 | Version 0.7.1 230 | ------------- 231 | 232 | * Allow saving, restoring, and querying the current cursor position 233 | * Fix a couple of issues with the Reset emulation on Windows 234 | 235 | Version 0.7 236 | ----------- 237 | 238 | Add 24-bit RGB color support 239 | 240 | Version 0.6.3.1 241 | --------------- 242 | 243 | Fix Windows + ghc 7.8 compatibility 244 | 245 | Version 0.6.3 246 | ------------- 247 | 248 | * Add ANSI support for Windows 249 | * Add compatibility with Win32-2.5.0.0 and above 250 | 251 | Version 0.6.2.3 252 | --------------- 253 | 254 | Add an example to the haddocks 255 | 256 | Version 0.6.2.2 257 | --------------- 258 | 259 | Fix a GHC 7.10 warning 260 | 261 | Version 0.6.2.1 262 | --------------- 263 | 264 | Restore compatibility with GHC 7.4 and older 265 | 266 | Version 0.6.2 267 | ------------- 268 | 269 | * Add `hSupportsANSI` 270 | * Drop support for `base < 4` 271 | 272 | Version 0.6.1.1 273 | --------------- 274 | 275 | Fix to build with GHC 7.8 on Windows 276 | 277 | Version 0.6.1 278 | ------------- 279 | 280 | * `BoldIntensity` no longer changes background color on Windows 281 | * `setSGR []` was not equivalent to `setSGR [Reset]` on Windows, even though it 282 | should be according to the documentation. This is now fixed. 283 | -------------------------------------------------------------------------------- /ansi-terminal/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this 10 | list of conditions and the following disclaimer in the documentation and/or 11 | other materials provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors 13 | may be used to endorse or promote products derived from this software without 14 | specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 17 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 23 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /ansi-terminal/README.md: -------------------------------------------------------------------------------- 1 | ansi-terminal [![GitHub CI](https://github.com/UnkindPartition/ansi-terminal/workflows/CI/badge.svg)](https://github.com/UnkindPartition/ansi-terminal/actions) 2 | ============= 3 | 4 | A Haskell package providing support for 'ANSI' control character sequences for 5 | terminals on Unix-like operating systems and Windows 6 | 7 | Description 8 | ----------- 9 | 10 | ['ANSI' terminal escape code](http://en.wikipedia.org/wiki/ANSI_escape_sequences) 11 | support for Haskell, which allows: 12 | - Colored text output, with control over foreground, background and (where 13 | supported) underlining colors 14 | - Clearing parts of a line or the screen 15 | - Hiding or showing the cursor 16 | - Moving the cursor around 17 | - Reporting the position of the cursor 18 | - Enabling and disabling automatic line wrapping 19 | - Scrolling the screen up or down 20 | - Switching between the Alternate and Normal Screen Buffers 21 | - Clickable hyperlinks to URIs 22 | - Changing the title of the terminal 23 | 24 | If you like this, you may be interested in 25 | [ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which 26 | provides a pretty-printer that can construct strings containing 'ANSI' 27 | colorisation. 28 | 29 | Not all 'ANSI' escape codes are suported by this library but most (if not 30 | all) of the popular ones that are well-supported by terminal software are, 31 | including: 32 | - Select Graphic Rendition mode (colors and other attributes): `setSGR` 33 | - Clearing parts of the screen: `clearFromCursorToScreenEnd`, 34 | `clearFromCursorToScreenBeginning`, `clearScreen`, 35 | `clearFromCursorToLineEnd`, `clearFromCursorToLineBeginning` and 36 | `clearLine` 37 | - Cursor visibility changes: `hideCursor` and `showCursor` 38 | - Cursor movement by character: `cursorUp`, `cursorDown`, `cursorForward` and 39 | `cursorBackward` 40 | - Cursor movement by line: `cursorUpLine` and `cursorDownLine` 41 | - Directly changing cursor position: `setCursorColumn` and `setCursorPosition` 42 | - Saving, restoring and reporting cursor position: `saveCursor`, 43 | `restoreCursor` and `reportCursorPosition` 44 | - Automatic line wrapping: `enableLineWrap` and `disableLineWrap` 45 | - Scrolling the screen: `scrollPageUp` and `scrollPageDown` 46 | - Changing the title: `setTitle` 47 | 48 | Each supported escape code or family of codes has a corresponding 49 | function that comes in three variants: 50 | 51 | - A straight `IO` variant that doesn't take a `Handle` and just applies the 52 | escape code to `stdout` and any terminal attached to it 53 | - An `IO` variant similar to above, but which takes a `Handle` to which the 54 | escape code should be applied 55 | - A `String` variant that returns a literal string that should be 56 | included to get the effect of the code. 57 | 58 | Example 59 | ------- 60 | 61 | A full example is 62 | [available](https://github.com/UnkindPartition/ansi-terminal/blob/master/ansi-terminal/app/Example.hs), 63 | but for a taste of how the library works try the following code: 64 | 65 | ``` haskell 66 | import System.Console.ANSI 67 | import System.IO (stdout) 68 | 69 | main :: IO () 70 | main = do 71 | stdoutSupportsANSI <- hNowSupportsANSI stdout 72 | if stdoutSupportsANSI 73 | then do 74 | setCursorPosition 5 0 75 | setTitle "ANSI Terminal Short Example" 76 | 77 | setSGR [ SetConsoleIntensity BoldIntensity 78 | , SetColor Foreground Vivid Red 79 | ] 80 | putStr "Hello" 81 | 82 | setSGR [ SetConsoleIntensity NormalIntensity 83 | , SetColor Foreground Vivid White 84 | , SetColor Background Dull Blue 85 | ] 86 | putStrLn "World!" 87 | else 88 | putStrLn "Standard output does not support 'ANSI' escape codes." 89 | ``` 90 | 91 | ![](https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/example.png) 92 | 93 | Documentation 94 | ------------- 95 | 96 | Haddock documentation is [available at 97 | Hackage](http://hackage.haskell.org/packages/archive/ansi-terminal/latest/doc/html/System-Console-ANSI.html). 98 | 99 | Credits 100 | ------- 101 | 102 | The library is originally written by [Max Bolingbroke](https://github.com/batterseapower) 103 | 104 | Maintainers 105 | ----------- 106 | 107 | [Mike Pilgrem](https://github.com/mpilgrem) and [Roman Cheplyaka](https://github.com/UnkindPartition) are the primary maintainers. 108 | 109 | [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please 110 | get in touch with him if the primary maintainers cannot be reached. 111 | -------------------------------------------------------------------------------- /ansi-terminal/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ansi-terminal/ansi-terminal.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: 1.22 2 | Name: ansi-terminal 3 | Version: 1.1.2 4 | Category: User Interfaces 5 | Synopsis: Simple ANSI terminal support 6 | Description: ANSI terminal support for Haskell: allows cursor movement, 7 | screen clearing, color output, showing or hiding the 8 | cursor, and changing the title. Works on UNIX and Windows. 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Max Bolingbroke 12 | Maintainer: Mike Pilgrem , Roman Cheplyaka 13 | Homepage: https://github.com/UnkindPartition/ansi-terminal 14 | Build-Type: Simple 15 | 16 | Extra-Source-Files: CHANGELOG.md 17 | README.md 18 | win/include/errors.h 19 | win/include/HsWin32.h 20 | win/include/winternl_compat.h 21 | 22 | Source-repository head 23 | type: git 24 | location: git://github.com/UnkindPartition/ansi-terminal.git 25 | 26 | Flag Example 27 | Description: Build the example application 28 | Default: False 29 | 30 | Library 31 | Hs-Source-Dirs: src 32 | Exposed-Modules: System.Console.ANSI 33 | System.Console.ANSI.Codes 34 | 35 | -- We re-export all of ansi-terminal-types to aid compatibility for 36 | -- downstream users. 37 | Reexported-Modules: System.Console.ANSI.Types 38 | 39 | Other-Modules: System.Console.ANSI.Internal 40 | 41 | Build-Depends: base >= 4.8.0.0 && < 5 42 | , ansi-terminal-types == 1.1 43 | , colour >= 2.1.0 44 | if os(windows) 45 | Hs-Source-Dirs: win 46 | Other-Modules: System.Console.ANSI.Windows.Foreign 47 | System.Console.ANSI.Windows.Win32.Types 48 | System.Console.ANSI.Windows.Win32.MinTTY 49 | Include-Dirs: win/include 50 | Install-Includes: HsWin32.h 51 | C-Sources: win/c-source/errors.c 52 | win/c-source/HsWin32.c 53 | else 54 | Hs-Source-Dirs: unix 55 | 56 | Default-Extensions: CPP 57 | 58 | Ghc-Options: -Wall 59 | Default-Language: Haskell2010 60 | 61 | Executable ansi-terminal-example 62 | Hs-Source-Dirs: app 63 | Main-Is: Example.hs 64 | Build-Depends: base >= 4.8.0.0 && < 5 65 | , ansi-terminal 66 | , colour 67 | Ghc-Options: -Wall 68 | if !flag(example) 69 | Buildable: False 70 | Default-Language: Haskell2010 71 | -------------------------------------------------------------------------------- /ansi-terminal/app/Example.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( 3 | main 4 | ) where 5 | 6 | import Control.Concurrent (threadDelay) 7 | import Control.Monad (forM_, replicateM_) 8 | import System.IO (hFlush, stdout) 9 | import Text.Printf(printf) 10 | 11 | import Data.Colour.SRGB (sRGB24) 12 | 13 | import System.Console.ANSI 14 | 15 | examples :: [IO ()] 16 | examples = [ cursorMovementExample 17 | , lineChangeExample 18 | , setCursorPositionExample 19 | , saveRestoreCursorExample 20 | , clearExample 21 | , lineWrapExample 22 | , scrollExample 23 | , screenBuffersExample 24 | , sgrColorExample 25 | , sgrOtherExample 26 | , cursorVisibilityExample 27 | , hyperlinkExample 28 | , titleExample 29 | , getCursorPositionExample 30 | , getTerminalSizeExample 31 | , getLayerColorExample 32 | ] 33 | 34 | main :: IO () 35 | main = do 36 | stdoutSupportsANSI <- hNowSupportsANSI stdout 37 | if stdoutSupportsANSI 38 | then 39 | mapM_ (resetScreen >>) examples 40 | else 41 | putStrLn "Standard output does not support 'ANSI' escape codes." 42 | 43 | -- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation 44 | -- of an erased state is implementation-dependent. There may or may not be a 45 | -- distinction between a character position in the erased state and one imaging 46 | -- SPACE. Consequently, to reset the screen, the default graphic rendition must 47 | -- be selected (setSGR [Reset]) before all character positions are put into the 48 | -- erased state (clearScreen). 49 | resetScreen :: IO () 50 | resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 51 | 52 | pause :: IO () 53 | pause = do 54 | hFlush stdout 55 | -- 1 second pause 56 | threadDelay 1000000 57 | 58 | cursorMovementExample :: IO () 59 | cursorMovementExample = do 60 | putStrLn "Line One" 61 | putStr "Line Two" 62 | pause 63 | -- Line One 64 | -- Line Two 65 | 66 | cursorUp 1 67 | putStr " - Extras" 68 | pause 69 | -- Line One - Extras 70 | -- Line Two 71 | 72 | cursorBackward 2 73 | putStr "zz" 74 | pause 75 | -- Line One - Extrzz 76 | -- Line Two 77 | 78 | cursorForward 2 79 | putStr "- And More" 80 | pause 81 | -- Line One - Extrzz - And More 82 | -- Line Two 83 | 84 | cursorDown 1 85 | putStr "Disconnected" 86 | pause 87 | -- Line One - Extrzz - And More 88 | -- Line Two Disconnected 89 | 90 | lineChangeExample :: IO () 91 | lineChangeExample = do 92 | putStrLn "Line One" 93 | putStr "Line Two" 94 | pause 95 | -- Line One 96 | -- Line Two 97 | 98 | cursorUpLine 1 99 | putStr "New Line One" 100 | pause 101 | -- New Line One 102 | -- Line Two 103 | 104 | cursorDownLine 1 105 | putStr "New Line Two" 106 | pause 107 | -- New Line One 108 | -- New Line Two 109 | 110 | setCursorPositionExample :: IO () 111 | setCursorPositionExample = do 112 | putStrLn "Line One" 113 | putStrLn "Line Two" 114 | pause 115 | -- Line One 116 | -- Line Two 117 | 118 | setCursorPosition 0 5 119 | putStr "Foo" 120 | pause 121 | -- Line Foo 122 | -- Line Two 123 | 124 | setCursorPosition 1 5 125 | putStr "Bar" 126 | pause 127 | -- Line Foo 128 | -- Line Bar 129 | 130 | setCursorColumn 1 131 | putStr "oaf" 132 | pause 133 | -- Line Foo 134 | -- Loaf Bar 135 | 136 | saveRestoreCursorExample :: IO () 137 | saveRestoreCursorExample = do 138 | putStr "Start sentence ..." 139 | pause 140 | -- Start sentence ... 141 | 142 | saveCursor 143 | setCursorPosition 2 3 144 | putStr "SPLASH!" 145 | pause 146 | -- Start sentence ... 147 | -- 148 | -- SPLASH! 149 | 150 | restoreCursor 151 | putStr " end sentence, uninterrupted." 152 | pause 153 | -- Start sentence ... end sentence, uninterrupted 154 | -- 155 | -- SPLASH! 156 | 157 | clearExample :: IO () 158 | clearExample = do 159 | putStrLn "Line One" 160 | putStrLn "Line Two" 161 | pause 162 | -- Line One 163 | -- Line Two 164 | 165 | setCursorPosition 0 4 166 | clearFromCursorToScreenEnd 167 | pause 168 | -- Line 169 | 170 | resetScreen 171 | putStrLn "Line One" 172 | putStrLn "Line Two" 173 | pause 174 | -- Line One 175 | -- Line Two 176 | 177 | setCursorPosition 1 4 178 | clearFromCursorToScreenBeginning 179 | pause 180 | -- 181 | -- Two 182 | 183 | resetScreen 184 | putStrLn "Line One" 185 | putStrLn "Line Two" 186 | pause 187 | -- Line One 188 | -- Line Two 189 | 190 | setCursorPosition 0 4 191 | clearFromCursorToLineEnd 192 | pause 193 | -- Line 194 | -- Line Two 195 | 196 | setCursorPosition 1 4 197 | clearFromCursorToLineBeginning 198 | pause 199 | -- Line 200 | -- Two 201 | 202 | clearLine 203 | pause 204 | -- Line 205 | 206 | clearScreen 207 | pause 208 | -- 209 | 210 | lineWrapExample :: IO () 211 | lineWrapExample = do 212 | putStrLn $ take 240 $ cycle "Default-line-wrap|" 213 | pause 214 | -- Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Def 215 | -- ault-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Defaul 216 | -- t-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-l 217 | disableLineWrap 218 | putStrLn $ take 240 $ cycle "Disable-line-wrap|" 219 | pause 220 | -- Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Dis 221 | enableLineWrap 222 | putStrLn $ take 240 $ cycle "Enable-line-wrap|" 223 | pause 224 | -- Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable- 225 | -- line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wr 226 | -- ap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enab 227 | 228 | scrollExample :: IO () 229 | scrollExample = do 230 | putStrLn "Line One" 231 | putStrLn "Line Two" 232 | putStrLn "Line Three" 233 | pause 234 | -- Line One 235 | -- Line Two 236 | -- Line Three 237 | 238 | scrollPageDown 2 239 | pause 240 | -- 241 | -- 242 | -- Line One 243 | -- Line Two 244 | -- Line Three 245 | 246 | scrollPageUp 3 247 | pause 248 | -- Line Two 249 | -- Line Three 250 | 251 | screenBuffersExample :: IO () 252 | screenBuffersExample = do 253 | replicateM_ 5 $ putStrLn "This message is on the Normal Screen Bufffer" 254 | replicateM_ 5 pause 255 | useAlternateScreenBuffer 256 | replicateM_ 5 $ putStrLn "This message is on the Alternate Screen Bufffer" 257 | replicateM_ 5 pause 258 | useNormalScreenBuffer 259 | replicateM_ 5 $ putStrLn "This message is continuing where we left off" 260 | replicateM_ 5 pause 261 | 262 | sgrColorExample :: IO () 263 | sgrColorExample = do 264 | let colors = enumFromTo minBound maxBound :: [Color] 265 | forM_ [Foreground, Background, Underlining] $ \layer -> do 266 | forM_ [Dull, Vivid] $ \intensity -> do 267 | resetScreen 268 | forM_ colors $ \color -> do 269 | setSGR [Reset] 270 | setSGR [SetColor layer intensity color] 271 | setSGR [SetUnderlining SingleUnderline] 272 | print color 273 | pause 274 | -- The ANSI eight standard colors, 6 times in sequence (three layers and two 275 | -- intensities) 276 | 277 | resetScreen 278 | putStrLn "True color (24 bit color depth)" 279 | putStrLn "-------------------------------" 280 | putStrLn "" 281 | setSGR [SetRGBColor Foreground $ sRGB24 0 0 0] 282 | forM_ [0 .. 23] $ \row -> do 283 | forM_ [0 .. 47] $ \col -> do 284 | let r = row * 11 285 | g = 255 - r 286 | b = col * 5 287 | setSGR [SetRGBColor Background $ sRGB24 r g b] 288 | putStr "-" 289 | putStrLn "" 290 | replicateM_ 5 pause 291 | -- True colors, a swatch of 24 rows and 48 columns 292 | 293 | resetScreen 294 | putStrLn "A 256-color palette" 295 | putStrLn "-------------------" 296 | putStrLn "" 297 | 298 | -- First 16 colors ('system' colors in xterm protocol), in a row 299 | -- 300 | -- 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 301 | forM_ [Dull .. Vivid] $ \intensity -> do 302 | forM_ [Black .. White] $ \color -> do 303 | let i = fromEnum intensity * 8 + fromEnum color 304 | eol = i == 15 305 | setSGR [SetPaletteColor Background $ xtermSystem intensity color] 306 | setSGR [SetPaletteColor Foreground $ xtermSystem Dull Black] 307 | printf "%X " i 308 | setSGR [SetPaletteColor Foreground $ xtermSystem Vivid White] 309 | printf "%X" i 310 | if eol 311 | then putStrLn "" 312 | else do 313 | setSGR [Reset] 314 | putStr " " 315 | putStrLn "" 316 | 317 | -- Next 216 colors (6 level RGB in xterm protocol), in 12 rows of 18 318 | -- 319 | -- 000 001 002 003 004 005 010 011 012 013 014 015 020 021 022 023 024 025 320 | -- 030 031 032 033 034 035 040 041 042 043 044 045 050 051 052 053 054 055 321 | -- 100 101 102 103 104 105 110 111 112 113 114 115 120 121 122 123 124 125 322 | -- ... and so on ... 323 | forM_ [0 .. 5] $ \r -> do 324 | forM_ [0 .. 5] $ \g -> do 325 | forM_ [0 .. 5] $ \b -> do 326 | let i = 16 + b + g * 6 + r * 36 327 | eol = i `mod` 18 == 15 328 | r' = (r + 3) `mod` 6 329 | g' = (g + 3) `mod` 6 330 | b' = (b + 3) `mod` 6 331 | setSGR [SetPaletteColor Foreground $ xterm6LevelRGB r' g' b'] 332 | setSGR [SetPaletteColor Background $ xterm6LevelRGB r g b] 333 | putStr $ show r ++ show g ++ show b 334 | if eol 335 | then putStrLn "" 336 | else do 337 | setSGR [Reset] 338 | putStr " " 339 | putStrLn "" 340 | 341 | -- Final 24 colors (24 levels of gray in xterm protocol), in two rows 342 | -- 343 | -- 0 1 2 3 4 5 6 7 8 9 10 11 344 | -- 12 13 14 15 16 17 18 19 20 21 22 23 345 | forM_ [0 .. 23] $ \y -> do 346 | setSGR [SetPaletteColor Foreground $ xterm24LevelGray $ (y + 12) `mod` 24] 347 | setSGR [SetPaletteColor Background $ xterm24LevelGray y] 348 | printf "%3d" y 349 | if y == 11 350 | then putStrLn "" 351 | else do 352 | setSGR [Reset] 353 | putStr " " 354 | replicateM_ 5 pause 355 | 356 | resetScreen 357 | setSGR [Reset] 358 | setSGR [SetUnderlining SingleUnderline] 359 | forM_ 360 | (zip "Underlining: True color (24 bit color depth)" (cycle [0, 10 .. 255])) $ 361 | \(c, i) -> do 362 | setSGR [SetRGBColor Underlining $ sRGB24 i 0 0] 363 | putChar c 364 | putChar '\n' 365 | putChar '\n' 366 | setSGR [Reset] 367 | setSGR [SetUnderlining SingleUnderline] 368 | forM_ (zip "Underlining: A 256-color palette" (cycle [0 .. 5])) $ 369 | \(c, i) -> do 370 | setSGR [SetPaletteColor Underlining $ xterm6LevelRGB i 0 0] 371 | putChar c 372 | putChar '\n' 373 | replicateM_ 5 pause 374 | 375 | sgrOtherExample :: IO () 376 | sgrOtherExample = do 377 | let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") 378 | , (SetConsoleIntensity FaintIntensity, "Faint") 379 | , (SetConsoleIntensity NormalIntensity, "Normal") 380 | , (SetItalicized True, "Italic") 381 | , (SetItalicized False, "No Italics") 382 | , (SetUnderlining SingleUnderline, "Single Underline") 383 | , (SetUnderlining DoubleUnderline, "Double Underline") 384 | , (SetUnderlining CurlyUnderline, "Curly Underline") 385 | , (SetUnderlining DottedUnderline, "Dotted Underline") 386 | , (SetUnderlining DashedUnderline, "Dashed Underline") 387 | , (SetUnderlining NoUnderline, "No Underline") 388 | , (SetBlinkSpeed SlowBlink, "Slow Blink") 389 | , (SetBlinkSpeed RapidBlink, "Rapid Blink") 390 | , (SetBlinkSpeed NoBlink, "No Blink") 391 | , (SetVisible False, "Conceal") 392 | , (SetVisible True, "Reveal") 393 | ] 394 | forM_ named_styles $ \(style, name) -> do 395 | resetScreen 396 | setSGR [style] 397 | putStrLn name 398 | pause 399 | -- Text describing a style displayed in that style in sequence 400 | 401 | setSGR [SetColor Foreground Vivid Red] 402 | setSGR [SetColor Background Vivid Blue] 403 | 404 | clearScreen >> setCursorPosition 0 0 405 | setSGR [SetSwapForegroundBackground False] 406 | putStr "Red-On-Blue" 407 | pause 408 | -- Red-On-Blue 409 | 410 | clearScreen >> setCursorPosition 0 0 411 | setSGR [SetSwapForegroundBackground True] 412 | putStr "Blue-On-Red" 413 | pause 414 | -- Blue-On-Red 415 | 416 | cursorVisibilityExample :: IO () 417 | cursorVisibilityExample = do 418 | putStr "Cursor Demo" 419 | pause 420 | -- Cursor Demo| 421 | 422 | hideCursor 423 | pause 424 | -- Cursor Demo 425 | 426 | showCursor 427 | pause 428 | -- Cursor Demo| 429 | 430 | hyperlinkExample :: IO () 431 | hyperlinkExample = do 432 | putStr "Hyperlink demo: " 433 | hyperlink "https://example.com" "Example hyperlink\n" 434 | putStrLn "" 435 | putStrLn "Linked hyperlinks demo:" 436 | hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink one\n" 437 | hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink two\n" 438 | 439 | replicateM_ 5 pause 440 | -- Hyperlink demo: Example hyperlink 441 | -- 442 | -- Linked hyperlinks demo: 443 | -- Example linked hyperlink one 444 | -- Example linked hyperlink two 445 | 446 | titleExample :: IO () 447 | titleExample = do 448 | putStr "Title Demo" 449 | pause 450 | -- ~/foo/ - ansi-terminal-ex - 83x70 451 | ------------------------------------ 452 | -- Title Demo 453 | 454 | setTitle "Yup, I'm a new title!" 455 | pause 456 | -- Yup, I'm a new title! - ansi-terminal-ex - 83x70 457 | --------------------------------------------------- 458 | -- Title Demo 459 | 460 | getCursorPositionExample :: IO () 461 | getCursorPositionExample = do 462 | putStrLn " 11111111112222222222" 463 | putStrLn "12345678901234567890123456789" 464 | putStr "Report cursor position here:" 465 | pause 466 | -- 11111111112222222222 467 | -- 12345678901234567890123456789 468 | -- Report cursor position here:| 469 | result <- getCursorPosition 470 | putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n" 471 | case result of 472 | Just (row, col) -> putStrLn $ "The cursor was at row number " ++ 473 | show (row + 1) ++ " and column number " ++ show (col + 1) ++ ".\n" 474 | Nothing -> putStrLn "Error: unable to get the cursor position\n" 475 | replicateM_ 3 pause 476 | -- 11111111112222222222 477 | -- 12345678901234567890123456789 478 | -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R. 479 | -- 480 | -- The cursor was at row number 3 and column number 29. 481 | 482 | getTerminalSizeExample :: IO () 483 | getTerminalSizeExample = do 484 | result <- getTerminalSize 485 | case result of 486 | Just (h, w) -> putStrLn $ "The size of the terminal is " ++ show h ++ 487 | " rows by " ++ show w ++ " columns.\n" 488 | Nothing -> putStrLn "Error: unable to get the terminal size\n" 489 | pause 490 | -- The size of the terminal is 25 rows by 80 columns. 491 | 492 | getLayerColorExample :: IO () 493 | getLayerColorExample = do 494 | fgResult <- getLayerColor Foreground 495 | case fgResult of 496 | Just fgCol -> putStrLn $ "The reported foreground color is:\n" ++ 497 | show fgCol ++ "\n" 498 | Nothing -> putStrLn "Error: unable to get the foreground color\n" 499 | bgResult <- getLayerColor Background 500 | case bgResult of 501 | Just bgCol -> putStrLn $ "The reported background color is:\n" ++ 502 | show bgCol ++ "\n" 503 | Nothing -> putStrLn "Error: unable to get the background color\n" 504 | -------------------------------------------------------------------------------- /ansi-terminal/src/System/Console/ANSI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | {-| == Introduction 4 | Through this module, this library provides platform-independent support for 5 | control character sequences following the \'ANSI\' standards (see further below) 6 | for terminal software that supports those sequences, running on a Unix-like 7 | operating system or on Windows (see further below). 8 | 9 | The sequences of control characters (also referred to as \'escape\' sequences or 10 | codes) provide a rich range of functionality for terminal control, which 11 | includes: 12 | 13 | * Colored text output, with control over foreground, background and (where 14 | supported) underlining colors 15 | 16 | * Clearing parts of a line or the screen 17 | 18 | * Hiding or showing the cursor 19 | 20 | * Moving the cursor around 21 | 22 | * Reporting the position of the cursor 23 | 24 | * Enabling or disabling automatic line wrapping 25 | 26 | * Scrolling the screen up or down 27 | 28 | * Switching between the Alternate and Normal Screen Buffers 29 | 30 | * Clickable hyperlinks to URIs 31 | 32 | * Changing the title of the terminal 33 | 34 | A terminal that supports control character sequences acts on them when they 35 | are flushed from the output buffer (with a newline character @\"\\n\"@ or, for 36 | the standard output channel, @hFlush stdout@). 37 | 38 | == \'ANSI\' standards 39 | The \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for 40 | Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T 41 | Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information 42 | Technology – Open Document Architecture (ODA) and Interchange Format: Character 43 | Content Architectures\` (also published as ISO/IEC International Standard 44 | 8613-6); and (3) further extensions used by \'XTerm\', a terminal emulator for 45 | the X Window System. The escape codes are described in a 46 | [Wikipedia article](http://en.wikipedia.org/wiki/ANSI_escape_code) and those 47 | codes supported on current versions of Windows are descibed in 48 | [Microsoft's documentation](https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences). 49 | 50 | The whole of the \'ANSI\' standards are not supported by this library but most 51 | (if not all) of the parts that are popular and well-supported by terminal 52 | software are supported (see further below). 53 | 54 | == Cursor positions 55 | The functions moving the cursor to an absolute position are 0-based (the 56 | top-left corner is considered to be at row 0 column 0) (see 'setCursorPosition') 57 | and so is 'getCursorPosition'. The \'ANSI\' standards themselves are 1-based 58 | (that is, the top-left corner is considered to be at row 1 column 1) and some 59 | functions reporting the position of the cursor are too (see 60 | 'reportCursorPosition'). 61 | 62 | == Windows and control character sequences 63 | The native terminal software on Windows has developed over time. Before 64 | Windows 10 version 1511 (known as the \'November [2015] Update\' or 65 | \'Threshold 2\') that software did not support control character sequences. From 66 | 2018, Microsoft introduced the Windows Pseudo Console (\'ConPTY\') API and then 67 | Windows Terminal, with the objective of replacing most of the Windows Console 68 | API with the use of control character sequences and retiring the historical 69 | user-interface role of Windows Console Host (\'ConHost\'). 70 | 71 | Windows Terminal is supported on Windows 10 version 19041.0 or higher and 72 | provided with Windows 11. It can be downloaded from the Microsoft Store. Windows 73 | Terminal can be set as the default terminal application on Windows 10 (from 74 | the 22H2 update) and is the default application on Windows 11 (from the 22H2 75 | update). 76 | 77 | Despite the above developments, some Windows users may continue to use ConHost. 78 | ConHost does not enable the processing of \'ANSI\' control characters in output 79 | by default. See 'hNowSupportsANSI' for a function that can try to enable such 80 | processing. 81 | 82 | Terminal software other than the native software exists for Windows. One example 83 | is the \'mintty\' terminal emulator for \'Cygwin\', \'MSYS\' or \'MSYS2\', and 84 | dervied projects, and for \'WSL\' (Windows Subsystem for Linux). 85 | 86 | GHC's management of input and output (IO) on Windows has also developed over 87 | time. If they are supported by the terminal software, some control character 88 | sequences cause data to be emitted into the console input stream. For GHC's 89 | historical and default IO manager, the function 'System.IO.hGetBufNonBlocking' 90 | in module "System.IO" does not work on Windows. This has been attributed to the 91 | lack of non-blocking primatives in the operating system (see 92 | [GHC bug report #806](https://ghc.haskell.org/trac/ghc/ticket/806). GHC's 93 | native IO manager on Windows (\'WinIO\'), introduced as a preview in 94 | [GHC 9.0.1](https://downloads.haskell.org/ghc/9.0.1/docs/html/users_guide/9.0.1-notes.html#highlights), 95 | has not yet provided a solution. On Windows, this library uses emulation based 96 | on the Windows Console API to try to read data emitted into the console input 97 | stream. Functions that use that emulation are not supported on consoles, such 98 | as mintty, that are not based on that API. 99 | 100 | == Function variants provided 101 | Every function exported by this module comes in three variants, namely: 102 | 103 | * A variant that has an @IO ()@ type and doesn't take a @Handle@ (for example, 104 | @clearScreen :: IO ()@). This variant just outputs the \`ANSI\` command 105 | directly to the standard output channel ('stdout') and any terminal 106 | corresponding to it. Commands issued like this should work as you expect on 107 | both Unix-like operating systems and Windows (unless exceptions on Windows 108 | are stated). 109 | 110 | * An \'@h@...\' variant that has an @IO ()@ type but takes a @Handle@ (for 111 | example, @hClearScreen :: Handle -> IO ()@). This variant outputs the 112 | \`ANSI\` command to the supplied handle and any terminal corresponding to it. 113 | Commands issued like this should also work as you expect on both Unix-like 114 | operating systems and Windows (unless exceptions on Windows are stated). 115 | 116 | * A \'...@Code@\' variant that has a @String@ type (for example, 117 | @clearScreenCode :: String@). This variant outputs the sequence of control 118 | characters as a 'String', which can be added to any other bit of text before 119 | being output. If a high degree of backwards compatability is rewuired, the 120 | use of these codes is discouraged because they will not work on legacy 121 | versions of Windows where the terminal in use is not ANSI-enabled (see 122 | further above). On Windows, where emulation has been necessary, these 123 | variants will always output the empty string. That is done so that it is 124 | possible to use them portably; for example, coloring console output on the 125 | understanding that you will see colors only if you are running on a Unix-like 126 | operating system or a version of Windows where emulation has not been 127 | necessary. If the control characters are always required, see module 128 | "System.Console.ANSI.Codes". 129 | 130 | == Examples of use 131 | 132 | A simple example is below: 133 | 134 | > module Main where 135 | > 136 | > import System.Console.ANSI 137 | > import System.IO (stdout) 138 | > 139 | > -- Set colors and write some text in those colors. 140 | > main :: IO () 141 | > main = do 142 | > stdoutSupportsANSI <- hNowSupportsANSI stdout 143 | > if stdoutSupportsANSI 144 | > then do 145 | > setSGR [SetColor Foreground Vivid Red] 146 | > setSGR [SetColor Background Vivid Blue] 147 | > putStrLn "Red-On-Blue" 148 | > setSGR [Reset] -- Reset to default colour scheme 149 | > putStrLn "Default colors." 150 | > else 151 | > putStrLn "Standard output does not support 'ANSI' escape codes." 152 | 153 | Another example is below: 154 | 155 | > module Main where 156 | > 157 | > import System.IO (hFlush, stdout) 158 | > import System.Console.ANSI 159 | > 160 | > main :: IO () 161 | > main = do 162 | > stdoutSupportsANSI <- hNowSupportsANSI stdout 163 | > if stdoutSupportsANSI 164 | > then do 165 | > setSGR [SetColor Foreground Dull Blue] 166 | > putStr "Enter your name: " 167 | > setSGR [SetColor Foreground Dull Yellow] 168 | > hFlush stdout -- flush the output buffer before getLine 169 | > name <- getLine 170 | > setSGR [SetColor Foreground Dull Blue] 171 | > putStrLn $ "Hello, " ++ name ++ "!" 172 | > setSGR [Reset] -- reset to default colour scheme 173 | > else 174 | > putStrLn "Standard output does not support 'ANSI' escape codes." 175 | 176 | For many more examples, see the project's extensive 177 | file. 178 | -} 179 | 180 | module System.Console.ANSI 181 | ( 182 | -- * Basic data types 183 | module System.Console.ANSI.Types 184 | 185 | -- * Cursor movement by character 186 | , cursorUp 187 | , cursorDown 188 | , cursorForward 189 | , cursorBackward 190 | -- ** \'h...\' variants 191 | , hCursorUp 192 | , hCursorDown 193 | , hCursorForward 194 | , hCursorBackward 195 | -- ** \'...Code\' variants 196 | , cursorUpCode 197 | , cursorDownCode 198 | , cursorForwardCode 199 | , cursorBackwardCode 200 | 201 | -- * Cursor movement by line 202 | -- 203 | -- | The difference between movements \"by character\" and \"by line\" is 204 | -- that @*Line@ functions additionally move the cursor to the start of the 205 | -- line, while functions like @cursorUp@ and @cursorDown@ keep the column 206 | -- the same. 207 | , cursorUpLine 208 | , cursorDownLine 209 | -- ** \'h...\' variants 210 | , hCursorUpLine 211 | , hCursorDownLine 212 | -- ** \'...Code\' variants 213 | , cursorUpLineCode 214 | , cursorDownLineCode 215 | 216 | -- * Directly changing cursor position 217 | , setCursorColumn 218 | , setCursorPosition 219 | -- ** \'h...\' variants 220 | , hSetCursorColumn 221 | , hSetCursorPosition 222 | -- ** \'...Code\' variants 223 | , setCursorColumnCode 224 | , setCursorPositionCode 225 | 226 | -- * Saving, restoring and reporting cursor position 227 | -- 228 | -- | These code sequences are not part of ECMA-48 standard; they are popular, 229 | -- but non-portable extensions. E. g., Terminal.app on MacOS 230 | -- . 231 | -- A more portable way would be to query @terminfo@ database 232 | -- for @rc@ and @sc@ capabilities. 233 | -- 234 | -- Cursor positions 235 | -- . 236 | -- 237 | , saveCursor 238 | , restoreCursor 239 | , reportCursorPosition 240 | -- ** \'h...\' variants 241 | , hSaveCursor 242 | , hRestoreCursor 243 | , hReportCursorPosition 244 | -- ** \'...Code\' variants 245 | , saveCursorCode 246 | , restoreCursorCode 247 | , reportCursorPositionCode 248 | 249 | -- * Clearing parts of the screen 250 | -- 251 | -- | Note that these functions only clear parts of the screen. They do not 252 | -- move the cursor. Some functions are based on the whole screen and others 253 | -- are based on the line in which the cursor is located. 254 | , clearFromCursorToScreenEnd 255 | , clearFromCursorToScreenBeginning 256 | , clearScreen 257 | , clearFromCursorToLineEnd 258 | , clearFromCursorToLineBeginning 259 | , clearLine 260 | -- ** \'h...\' variants 261 | , hClearFromCursorToScreenEnd 262 | , hClearFromCursorToScreenBeginning 263 | , hClearScreen 264 | , hClearFromCursorToLineEnd 265 | , hClearFromCursorToLineBeginning 266 | , hClearLine 267 | -- ** \'...Code\' variants 268 | , clearFromCursorToScreenEndCode 269 | , clearFromCursorToScreenBeginningCode 270 | , clearScreenCode 271 | , clearFromCursorToLineEndCode 272 | , clearFromCursorToLineBeginningCode 273 | , clearLineCode 274 | 275 | -- * Enabling and disabling automatic line wrapping 276 | -- 277 | -- | These functions control whether or not characters automatically wrap to 278 | -- the next line when the cursor reaches the right border. 279 | , enableLineWrap 280 | , disableLineWrap 281 | -- ** \'h...\' variants 282 | , hEnableLineWrap 283 | , hDisableLineWrap 284 | -- ** \'...Code\' variants 285 | , enableLineWrapCode 286 | , disableLineWrapCode 287 | 288 | -- * Scrolling the screen 289 | , scrollPageUp 290 | , scrollPageDown 291 | -- ** \'h...\' variants 292 | , hScrollPageUp 293 | , hScrollPageDown 294 | -- ** \'...Code\' variants 295 | , scrollPageUpCode 296 | , scrollPageDownCode 297 | 298 | -- * Using screen buffers 299 | -- 300 | -- | These code sequences are not part of ECMA-48 standard; they are popular, 301 | -- but non-portable extensions, corresponding to @smcup@ and @rmcup@ capabilities 302 | -- in @terminfo@ database. 303 | -- On Windows, if emulation is required, switching between alternate and 304 | -- normal screen buffers is not emulated. 305 | , useAlternateScreenBuffer 306 | , useNormalScreenBuffer 307 | -- ** \'h...\' variants 308 | , hUseAlternateScreenBuffer 309 | , hUseNormalScreenBuffer 310 | -- ** \'...Code\' variants 311 | , useAlternateScreenBufferCode 312 | , useNormalScreenBufferCode 313 | 314 | -- * Reporting the background or foreground colors 315 | , reportLayerColor 316 | , hReportLayerColor 317 | , reportLayerColorCode 318 | 319 | -- * Select Graphic Rendition mode: colors and other whizzy stuff 320 | , setSGR 321 | , hSetSGR 322 | , setSGRCode 323 | 324 | -- * Cursor visibilty changes 325 | -- 326 | -- | Strictly speaking, these code sequences are not part of ECMA-48 standard; 327 | -- they are popular, but non-portable extensions. However, in practice they seem 328 | -- to work pretty much everywhere. 329 | , hideCursor 330 | , showCursor 331 | -- ** \'h...\' variants 332 | , hHideCursor 333 | , hShowCursor 334 | -- ** \'...Code\' variants 335 | , hideCursorCode 336 | , showCursorCode 337 | 338 | -- * Hyperlinks 339 | -- 340 | -- | These code sequences are not part of ECMA-48 standard and not even an 341 | -- @xterm@ extension. Nevertheless 342 | -- 343 | -- support them. On Windows, if emulation is required, 344 | -- hyperlinks are not emulated. 345 | , hyperlink 346 | , hyperlinkWithId 347 | , hyperlinkWithParams 348 | -- ** \'h...\' variants 349 | , hHyperlink 350 | , hHyperlinkWithId 351 | , hHyperlinkWithParams 352 | -- ** \'...Code\' variants 353 | , hyperlinkCode 354 | , hyperlinkWithIdCode 355 | , hyperlinkWithParamsCode 356 | 357 | -- * Changing the title 358 | , setTitle 359 | , hSetTitle 360 | , setTitleCode 361 | 362 | -- * Checking if handle supports ANSI (not portable: GHC only) 363 | , hSupportsANSI 364 | , hNowSupportsANSI 365 | , hSupportsANSIColor 366 | 367 | -- * Getting the cursor position 368 | , getCursorPosition 369 | , hGetCursorPosition 370 | , getReportedCursorPosition 371 | , cursorPosition 372 | 373 | -- * Getting the terminal size 374 | , getTerminalSize 375 | , hGetTerminalSize 376 | 377 | -- * Getting the background or foreground colors 378 | , getLayerColor 379 | , hGetLayerColor 380 | , getReportedLayerColor 381 | , layerColor 382 | 383 | -- * Deprecated 384 | , hSupportsANSIWithoutEmulation 385 | ) where 386 | 387 | import Control.Exception.Base ( bracket ) 388 | import Control.Monad ( when, void ) 389 | import Data.Char ( digitToInt, isDigit, isHexDigit ) 390 | import Data.Colour.SRGB ( RGB (..) ) 391 | import Data.Word ( Word16 ) 392 | import System.IO 393 | ( BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, hPutStr 394 | , hReady, hSetBuffering, hSetEcho, stdin, stdout 395 | ) 396 | import Text.ParserCombinators.ReadP 397 | ( ReadP, (<++), char, many1, readP_to_S, satisfy, string ) 398 | 399 | import System.Console.ANSI.Codes 400 | import qualified System.Console.ANSI.Internal as Internal 401 | import System.Console.ANSI.Types 402 | 403 | hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: 404 | Handle 405 | -> Int -- Number of lines or characters to move 406 | -> IO () 407 | hCursorUp h n = hPutStr h $ cursorUpCode n 408 | hCursorDown h n = hPutStr h $ cursorDownCode n 409 | hCursorForward h n = hPutStr h $ cursorForwardCode n 410 | hCursorBackward h n = hPutStr h $ cursorBackwardCode n 411 | 412 | cursorUp, cursorDown, cursorForward, cursorBackward :: 413 | Int -- ^ Number of lines or characters to move 414 | -> IO () 415 | cursorUp = hCursorUp stdout 416 | cursorDown = hCursorDown stdout 417 | cursorForward = hCursorForward stdout 418 | cursorBackward = hCursorBackward stdout 419 | 420 | hCursorDownLine, hCursorUpLine :: 421 | Handle 422 | -> Int -- Number of lines to move 423 | -> IO () 424 | hCursorDownLine h n = hPutStr h $ cursorDownLineCode n 425 | hCursorUpLine h n = hPutStr h $ cursorUpLineCode n 426 | 427 | cursorDownLine, cursorUpLine :: 428 | Int -- ^ Number of lines to move 429 | -> IO () 430 | cursorDownLine = hCursorDownLine stdout 431 | cursorUpLine = hCursorUpLine stdout 432 | 433 | hSetCursorColumn :: 434 | Handle 435 | -> Int -- 0-based column to move to 436 | -> IO () 437 | hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n 438 | 439 | -- | Move the cursor to the specified column. The column numbering is 0-based 440 | -- (that is, the left-most column is numbered 0). 441 | setCursorColumn :: 442 | Int -- ^ 0-based column to move to 443 | -> IO () 444 | setCursorColumn = hSetCursorColumn stdout 445 | 446 | hSetCursorPosition :: 447 | Handle 448 | -> Int -- 0-based row to move to 449 | -> Int -- 0-based column to move to 450 | -> IO () 451 | hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m 452 | 453 | -- | Move the cursor to the specified position (row and column). The position is 454 | -- 0-based (that is, the top-left corner is at row 0 column 0). 455 | setCursorPosition :: 456 | Int -- ^ 0-based row to move to 457 | -> Int -- ^ 0-based column to move to 458 | -> IO () 459 | setCursorPosition = hSetCursorPosition stdout 460 | 461 | hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () 462 | hSaveCursor h = hPutStr h saveCursorCode 463 | hRestoreCursor h = hPutStr h restoreCursorCode 464 | hReportCursorPosition h = hPutStr h reportCursorPositionCode 465 | 466 | -- | Save the cursor position in memory. The only way to access the saved value 467 | -- is with the 'restoreCursor' command. 468 | -- 469 | -- @since 0.7.1 470 | saveCursor :: IO () 471 | saveCursor = hSaveCursor stdout 472 | 473 | -- | Restore the cursor position from memory. There will be no value saved in 474 | -- memory until the first use of the 'saveCursor' command. 475 | -- 476 | -- @since 0.7.1 477 | restoreCursor :: IO () 478 | restoreCursor = hRestoreCursor stdout 479 | 480 | -- | Looking for a way to get the cursors position? See 481 | -- 'getCursorPosition'. 482 | -- 483 | -- Emit the cursor position into the console input stream, immediately after 484 | -- being recognised on the output stream, as: 485 | -- @ESC [ \ ; \ R@ 486 | -- 487 | -- Note that the information that is emitted is 1-based (the top-left corner is 488 | -- at row 1 column 1) but 'setCursorColumn' and 'setCursorPosition' are 489 | -- 0-based. 490 | -- 491 | -- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this 492 | -- function may be of limited use on Windows operating systems because of 493 | -- difficulties in obtaining the data emitted into the console input stream. 494 | -- 495 | -- @since 0.7.1 496 | reportCursorPosition :: IO () 497 | reportCursorPosition = hReportCursorPosition stdout 498 | 499 | hHideCursor, hShowCursor :: Handle -> IO () 500 | hHideCursor h = hPutStr h hideCursorCode 501 | hShowCursor h = hPutStr h showCursorCode 502 | 503 | hideCursor, showCursor :: IO () 504 | hideCursor = hHideCursor stdout 505 | showCursor = hShowCursor stdout 506 | 507 | hUseAlternateScreenBuffer :: Handle -> IO () 508 | hUseAlternateScreenBuffer h = hPutStr h useAlternateScreenBufferCode 509 | 510 | hUseNormalScreenBuffer :: Handle -> IO () 511 | hUseNormalScreenBuffer h = hPutStr h useNormalScreenBufferCode 512 | 513 | -- | Use the Alternate Screen Buffer. If currently using the Normal Screen 514 | -- Buffer, it will save the cursor position and switch to the Alternate Screen 515 | -- Buffer. It will always clear the Alternate Screen Buffer. The Alternate 516 | -- Screen Buffer has no scroll back facility. 517 | -- 518 | -- It is an application's responsibility to ensure that it switches back to the 519 | -- Normal Screen Buffer if an exception is raised while the Alternate Screen 520 | -- Buffer is being used. For example, by using 'Control.Exception.bracket_': 521 | -- 522 | -- > bracket_ useAlternateScreenBuffer useNormalScreenBuffer action 523 | -- 524 | -- @since 0.11.4 525 | useAlternateScreenBuffer :: IO () 526 | useAlternateScreenBuffer = hUseAlternateScreenBuffer stdout 527 | 528 | -- | Use the Normal Screen Buffer. If currently using the Alternate Screen 529 | -- Buffer, it will clear the Alternate Screen Buffer, and switch to the Normal 530 | -- Screen Buffer. It will always restore the saved cursor position. 531 | -- 532 | -- @since 0.11.4 533 | useNormalScreenBuffer :: IO () 534 | useNormalScreenBuffer = hUseNormalScreenBuffer stdout 535 | 536 | -- Introduce a hyperlink with (key, value) parameters. Some terminals support 537 | -- an @id@ parameter key, so that hyperlinks with the same @id@ value are 538 | -- treated as connected. 539 | -- 540 | -- @since 0.11.3 541 | hHyperlinkWithParams:: 542 | Handle 543 | -> [(String, String)] -- Parameters 544 | -> String -- URI 545 | -> String -- Link text 546 | -> IO () 547 | hHyperlinkWithParams h params uri link = 548 | hPutStr h $ hyperlinkWithParamsCode params uri link 549 | 550 | -- | Introduce a hyperlink with (key, value) parameters. Some terminals support 551 | -- an @id@ parameter key, so that hyperlinks with the same @id@ value are 552 | -- treated as connected. 553 | -- 554 | -- @since 0.11.3 555 | hyperlinkWithParams :: 556 | [(String, String)] -- ^ Parameters 557 | -> String -- ^ URI 558 | -> String -- ^ Link text 559 | -> IO () 560 | hyperlinkWithParams = hHyperlinkWithParams stdout 561 | 562 | -- Introduce a hyperlink. 563 | -- 564 | -- @since 0.11.3 565 | hHyperlink :: 566 | Handle 567 | -> String -- URI 568 | -> String -- Link text 569 | -> IO () 570 | hHyperlink h = hHyperlinkWithParams h [] 571 | 572 | -- | Introduce a hyperlink. 573 | -- 574 | -- @since 0.11.3 575 | hyperlink :: 576 | String -- ^ URI 577 | -> String -- ^ Link text 578 | -> IO () 579 | hyperlink = hHyperlink stdout 580 | 581 | -- Introduce a hyperlink with an identifier for the link. Some terminals 582 | -- support an identifier, so that hyperlinks with the same identifier are 583 | -- treated as connected. 584 | -- 585 | -- @since 0.11.3 586 | hHyperlinkWithId :: 587 | Handle 588 | -> String -- Identifier for the link 589 | -> String -- URI 590 | -> String -- Link text 591 | -> IO () 592 | hHyperlinkWithId h linkId = hHyperlinkWithParams h [("id", linkId)] 593 | 594 | -- | Introduce a hyperlink with an identifier for the link. Some terminals 595 | -- support an identifier, so that hyperlinks with the same identifier are 596 | -- treated as connected. 597 | -- 598 | -- @since 0.11.3 599 | hyperlinkWithId :: 600 | String -- ^ Identifier for the link 601 | -> String -- ^ URI 602 | -> String -- ^ Link text 603 | -> IO () 604 | hyperlinkWithId = hHyperlinkWithId stdout 605 | 606 | -- Set the terminal window title and icon name (that is, the text for the 607 | -- window in the Start bar, or similar). 608 | hSetTitle :: 609 | Handle 610 | -> String -- New window title and icon name 611 | -> IO () 612 | hSetTitle h title = hPutStr h $ setTitleCode title 613 | 614 | -- | Set the terminal window title and icon name (that is, the text for the 615 | -- window in the Start bar, or similar). 616 | setTitle :: String -- ^ New window title and icon name 617 | -> IO () 618 | setTitle = hSetTitle stdout 619 | 620 | -- | Use heuristics to determine whether the functions defined in this package 621 | -- will work with a given handle. 622 | -- 623 | -- If the handle is not writable (that is, it cannot manage output - see 624 | -- 'System.IO.hIsWritable'), then @pure False@ is returned. 625 | -- 626 | -- For Unix-like operating systems, the current implementation checks 627 | -- that: (1) the handle is a terminal; and (2) a @TERM@ environment variable is 628 | -- not set to @dumb@ (which is what the GNU Emacs text editor sets for its 629 | -- integrated terminal). 630 | -- 631 | -- For Windows, the current implementation checks: first that (1) the handle is 632 | -- a terminal, (2) a @TERM@ environment variable is not set to @dumb@, and (3) 633 | -- the processing of \'ANSI\' control characters in output is enabled; and 634 | -- second, as an alternative, whether the handle is connected to a \'mintty\' 635 | -- terminal. (That is because the function 'System.IO.hIsTerminalDevice' is used 636 | -- to check if the handle is a terminal. However, where a non-native Windows 637 | -- terminal (such as \'mintty\') is implemented using redirection, that function 638 | -- will not identify a handle to the terminal as a terminal.) If it is not 639 | -- already enabled, this function does *not* enable the processing of \'ANSI\' 640 | -- control characters in output (see 'hNowSupportsANSI'). 641 | -- 642 | -- @since 0.6.2 643 | hSupportsANSI :: Handle -> IO Bool 644 | hSupportsANSI = Internal.hSupportsANSI 645 | 646 | -- | With one exception, equivalent to 'hSupportsANSI'. The exception is that, 647 | -- on Windows only, if a @TERM@ environment variable is not set to @dumb@ and 648 | -- the processing of \'ANSI\' control characters in output is not enabled, this 649 | -- function first tries to enable such processing. 650 | -- 651 | -- @Since 1.0.1 652 | hNowSupportsANSI :: Handle -> IO Bool 653 | hNowSupportsANSI = Internal.hNowSupportsANSI 654 | 655 | -- | Some terminals (e.g. Emacs) are not fully ANSI compliant but can support 656 | -- ANSI colors. This can be used in such cases, if colors are all that is 657 | -- needed. 658 | -- 659 | -- @since 0.9 660 | hSupportsANSIColor :: Handle -> IO Bool 661 | hSupportsANSIColor = Internal.hSupportsANSIColor 662 | 663 | -- | Use heuristics to determine whether a given handle will support \'ANSI\' 664 | -- control characters in output. The function is consistent with 665 | -- 'hNowSupportsANSI'. 666 | -- 667 | -- This function is deprecated as, from version 1.0, the package no longer 668 | -- supports legacy versions of Windows that required emulation. 669 | -- 670 | -- @since 0.8.1 671 | {-# DEPRECATED hSupportsANSIWithoutEmulation "See Haddock documentation and hNowSupportsANSI." #-} 672 | hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) 673 | hSupportsANSIWithoutEmulation h = Just <$> hNowSupportsANSI h 674 | 675 | -- | Parses the characters emitted by 'reportCursorPosition' into the console 676 | -- input stream. Returns the cursor row and column as a tuple. 677 | -- 678 | -- For example, if the characters emitted by 'reportCursorPosition' are in 679 | -- 'String' @input@ then the parser could be applied like this: 680 | -- 681 | -- > let result = readP_to_S cursorPosition input 682 | -- > case result of 683 | -- > [] -> putStrLn $ "Error: could not parse " ++ show input 684 | -- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row 685 | -- > ++ " and column" ++ show column ++ "." 686 | -- > (_:_) -> putStrLn $ "Error: parse not unique" 687 | -- 688 | -- @since 0.7.1 689 | cursorPosition :: ReadP (Int, Int) 690 | cursorPosition = do 691 | void $ char '\ESC' 692 | void $ char '[' 693 | row <- decimal -- A non-negative whole decimal number 694 | void $ char ';' 695 | col <- decimal -- A non-negative whole decimal number 696 | void $ char 'R' 697 | pure (read row, read col) 698 | where 699 | digit = satisfy isDigit 700 | decimal = many1 digit 701 | 702 | -- | Attempts to get the reported cursor position data from the console input 703 | -- stream. The function is intended to be called immediately after 704 | -- 'reportCursorPosition' (or related functions) have caused characters to be 705 | -- emitted into the stream. 706 | -- 707 | -- For example, on a Unix-like operating system: 708 | -- 709 | -- > -- set no buffering (if 'no buffering' is not already set, the contents of 710 | -- > -- the buffer will be discarded, so this needs to be done before the cursor 711 | -- > -- positon is emitted) 712 | -- > hSetBuffering stdin NoBuffering 713 | -- > -- ensure that echoing is off 714 | -- > input <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do 715 | -- > hSetEcho stdin False 716 | -- > reportCursorPosition 717 | -- > hFlush stdout -- ensure the report cursor position code is sent to the 718 | -- > -- operating system 719 | -- > getReportedCursorPosition 720 | -- 721 | -- On Windows operating systems, the function is not supported on consoles, such 722 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 723 | -- and PowerShell are based on the Console API.) 724 | -- 725 | -- @since 0.7.1 726 | getReportedCursorPosition :: IO String 727 | getReportedCursorPosition = Internal.getReportedCursorPosition 728 | 729 | -- | Attempts to get the reported cursor position, combining the functions 730 | -- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. Any 731 | -- position @(row, column)@ is translated to be 0-based (that is, the top-left 732 | -- corner is at @(0, 0)@), consistent with `setCursorColumn` and 733 | -- `setCursorPosition`. (Note that the information emitted into the console 734 | -- input stream by 'reportCursorPosition' is 1-based.) Returns 'Nothing' if any 735 | -- data emitted by 'reportCursorPosition', obtained by 736 | -- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'. Uses 737 | -- 'stdout'. If 'stdout' will be redirected, see 'hGetCursorPosition' for a more 738 | -- general function. 739 | -- 740 | -- On Windows operating systems, the function is not supported on consoles, such 741 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 742 | -- and PowerShell are based on the Console API.) 743 | -- 744 | -- @since 0.10.3 745 | getCursorPosition :: IO (Maybe (Int, Int)) 746 | getCursorPosition = hGetCursorPosition stdout 747 | 748 | -- | Attempts to get the reported cursor position, combining the functions 749 | -- 'hReportCursorPosition' (with the specified handle), 750 | -- 'getReportedCursorPosition' and 'cursorPosition'. Any position 751 | -- @(row, column)@ is translated to be 0-based (that is, the top-left corner is 752 | -- at @(0, 0)@), consistent with 'hSetCursorColumn' and 'hSetCursorPosition'. 753 | -- (Note that the information emitted into the console input stream by 754 | -- 'hReportCursorPosition' is 1-based.) Returns 'Nothing' if any data emitted by 755 | -- 'hReportCursorPosition', obtained by 'getReportedCursorPosition', cannot be 756 | -- parsed by 'cursorPosition'. 757 | -- 758 | -- On Windows operating systems, the function is not supported on consoles, such 759 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 760 | -- and PowerShell are based on the Console API.) 761 | -- 762 | -- @since 0.10.1 763 | hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) 764 | hGetCursorPosition h = fmap to0base <$> getCursorPosition' 765 | where 766 | to0base (row, col) = (row - 1, col - 1) 767 | getCursorPosition' = do 768 | input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do 769 | -- set no buffering (if 'no buffering' is not already set, the contents of 770 | -- the buffer will be discarded, so this needs to be done before the 771 | -- cursor positon is emitted) 772 | hSetBuffering stdin NoBuffering 773 | -- ensure that echoing is off 774 | bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do 775 | hSetEcho stdin False 776 | clearStdin 777 | hReportCursorPosition h 778 | hFlush h -- ensure the report cursor position code is sent to the 779 | -- operating system 780 | getReportedCursorPosition 781 | case readP_to_S cursorPosition input of 782 | [] -> pure Nothing 783 | [((row, col),_)] -> pure $ Just (row, col) 784 | (_:_) -> pure Nothing 785 | clearStdin = do 786 | isReady <- hReady stdin 787 | when isReady $ do 788 | _ <-getChar 789 | clearStdin 790 | 791 | -- | Looking for a way to get layer colors? See 'getLayerColor'. 792 | -- 793 | -- Emit the layerColor into the console input stream, immediately after 794 | -- being recognised on the output stream, as: 795 | -- @ESC ] \ ; rgb: \ ; \ ; \ \@ 796 | -- where @\@ is @10@ for 'Foreground' and @11@ for 'Background'; @\@, 797 | -- @\@ and @\@ are the color channel values in hexadecimal (4, 8, 798 | -- 12 and 16 bit values are possible, although 16 bit values are most common); 799 | -- and @\@ is the STRING TERMINATOR (ST). ST depends on the terminal 800 | -- software and may be the @BEL@ character or @ESC \\@ characters. 801 | -- 802 | -- This function may be of limited, or no, use on Windows operating systems 803 | -- because (1) the function is not supported on native terminals and is 804 | -- emulated, but the emulation does not work on Windows Terminal and (2) of 805 | -- difficulties in obtaining the data emitted into the console input stream. 806 | -- 807 | -- Underlining is not supported. 808 | -- 809 | -- @since 0.11.4 810 | reportLayerColor :: ConsoleLayer -> IO () 811 | reportLayerColor = hReportLayerColor stdout 812 | 813 | -- @since 0.11.4 814 | hReportLayerColor :: Handle -> ConsoleLayer -> IO () 815 | hReportLayerColor h layer = hPutStr h $ reportLayerColorCode layer 816 | 817 | -- | Attempts to get the reported layer color data from the console input 818 | -- stream. The function is intended to be called immediately after 819 | -- 'reportLayerColor' (or related functions) have caused characters to be 820 | -- emitted into the stream. 821 | -- 822 | -- For example, on a Unix-like operating system: 823 | -- 824 | -- > -- set no buffering (if 'no buffering' is not already set, the contents of 825 | -- > -- the buffer will be discarded, so this needs to be done before the cursor 826 | -- > -- positon is emitted) 827 | -- > hSetBuffering stdin NoBuffering 828 | -- > -- ensure that echoing is off 829 | -- > input <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do 830 | -- > hSetEcho stdin False 831 | -- > reportLayerColor Foreground 832 | -- > hFlush stdout -- ensure the report cursor position code is sent to the 833 | -- > -- operating system 834 | -- > getReportedLayerColor Foreground 835 | -- 836 | -- On Windows operating systems, the function is not supported on consoles, such 837 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 838 | -- and PowerShell are based on the Console API.) 839 | -- 840 | -- Underlining is not supported. 841 | -- 842 | -- @since 0.11.4 843 | getReportedLayerColor :: ConsoleLayer -> IO String 844 | getReportedLayerColor = Internal.getReportedLayerColor 845 | 846 | -- | Attempts to get the reported layer color, combining the functions 847 | -- 'reportLayerColor', 'getReportedLayerColor' and 'layerColor'. Any RGB color 848 | -- is scaled to be 16 bits per channel, the most common format reported by 849 | -- terminal software. Returns 'Nothing' if any data emitted by 850 | -- 'reportLayerColor', obtained by 'getReportedLayerColor', cannot be parsed by 851 | -- 'layerColor'. Uses 'stdout'. If 'stdout' will be redirected, see 852 | -- 'hGetLayerColor' for a more general function. 853 | -- 854 | -- On Windows operating systems, the function is not supported on consoles, such 855 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 856 | -- and PowerShell are based on the Console API.) This function also relies on 857 | -- emulation that does not work on Windows Terminal. 858 | -- 859 | -- Underlining is not supported. 860 | -- 861 | -- @since 0.11.4 862 | getLayerColor :: ConsoleLayer -> IO (Maybe(RGB Word16)) 863 | getLayerColor = hGetLayerColor stdout 864 | 865 | -- | Attempts to get the reported layer color, combining the functions 866 | -- 'hReportLayerColor', 'getReportedLayerColor' and 'layerColor'. Any RGB color 867 | -- is scaled to be 16 bits per channel, the most common format reported by 868 | -- terminal software. Returns 'Nothing' if any data emitted by 869 | -- 'hReportLayerColor', obtained by 'getReportedLayerColor', cannot be parsed by 870 | -- 'layerColor'. 871 | -- 872 | -- On Windows operating systems, the function is not supported on consoles, such 873 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 874 | -- and PowerShell are based on the Console API.) This function also relies on 875 | -- emulation that does not work on Windows Terminal. 876 | -- 877 | -- Underlining is not supported. 878 | -- 879 | -- @since 0.11.4 880 | hGetLayerColor :: Handle -> ConsoleLayer -> IO (Maybe (RGB Word16)) 881 | hGetLayerColor h layer = do 882 | input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do 883 | -- set no buffering (if 'no buffering' is not already set, the contents of 884 | -- the buffer will be discarded, so this needs to be done before the 885 | -- cursor positon is emitted) 886 | hSetBuffering stdin NoBuffering 887 | -- ensure that echoing is off 888 | bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do 889 | hSetEcho stdin False 890 | clearStdin 891 | hReportLayerColor h layer 892 | hFlush h -- ensure the report cursor position code is sent to the 893 | -- operating system 894 | getReportedLayerColor layer 895 | case readP_to_S (layerColor layer) input of 896 | [] -> pure Nothing 897 | [(col, _)] -> pure $ Just col 898 | (_:_) -> pure Nothing 899 | where 900 | clearStdin = do 901 | isReady <- hReady stdin 902 | when isReady $ do 903 | _ <-getChar 904 | clearStdin 905 | 906 | -- | Parses the characters emitted by 'reportLayerColor' into the console input 907 | -- stream. 908 | -- 909 | -- For example, if the characters emitted by 'reportLayerColor' are in 'String' 910 | -- @input@ then the parser could be applied like this: 911 | -- 912 | -- > let result = readP_to_S (layerColor layer) input 913 | -- > case result of 914 | -- > [] -> putStrLn $ "Error: could not parse " ++ show input 915 | -- > [(col, _)] -> putStrLn $ "The color was " ++ show col ++ "." 916 | -- > (_:_) -> putStrLn $ "Error: parse not unique" 917 | -- 918 | -- Underlining is not supported. 919 | -- 920 | -- @since 0.11.4 921 | layerColor :: ConsoleLayer -> ReadP (RGB Word16) 922 | layerColor layer = do 923 | void $ string "\ESC]" 924 | void $ string $ case layer of 925 | Foreground -> "10" 926 | Background -> "11" 927 | Underlining -> fail "reportLayerColor does not support underlining" 928 | void $ string ";rgb:" 929 | redHex <- hexadecimal -- A non-negative whole hexadecimal number 930 | void $ char '/' 931 | greenHex <- hexadecimal -- A non-negative whole hexadecimal number 932 | void $ char '/' 933 | blueHex <- hexadecimal -- A non-negative whole hexadecimal number 934 | void $ string "\BEL" <++ string "\ESC\\" 935 | let lenRed = length redHex 936 | lenGreen = length greenHex 937 | lenBlue = length blueHex 938 | if lenRed == lenGreen && lenGreen == lenBlue 939 | then 940 | if lenRed == 0 || lenRed > 4 941 | then fail "Color format not recognised" 942 | else 943 | let m = 16 ^ (4 - lenRed) 944 | r = fromIntegral $ m * hexToInt redHex 945 | g = fromIntegral $ m * hexToInt greenHex 946 | b = fromIntegral $ m * hexToInt blueHex 947 | in pure $ RGB r g b 948 | else fail "Color format not recognised" 949 | where 950 | hexDigit = satisfy isHexDigit 951 | hexadecimal = many1 hexDigit 952 | hexToInt hex = foldl (\d a -> d * 16 + a) 0 (map digitToInt hex) 953 | 954 | -- | Attempts to get the current terminal size (height in rows, width in 955 | -- columns). 956 | -- 957 | -- There is no \'ANSI\' control character sequence that reports the terminal 958 | -- size. So, it attempts to set the cursor position beyond the bottom right 959 | -- corner of the terminal and then use 'getCursorPosition' to query the console 960 | -- input stream. It works only on terminals that support each step and if data 961 | -- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if 962 | -- 'stdin' is connected to a terminal.) Uses 'stdout'. If 'stdout' will be 963 | -- redirected, see 'System.IO.hGetTerminalSize' for a more general function. 964 | -- 965 | -- On Windows operating systems, the function is not supported on consoles, such 966 | -- as mintty, that are not based on Windows' Console API. (Command Prompt and 967 | -- PowerShell are based on the Console API.) 968 | -- 969 | -- For a different approach, one that does not use control character sequences 970 | -- and works when 'stdin' is redirected, see the 971 | -- package. 972 | -- 973 | -- @since 0.9 974 | getTerminalSize :: IO (Maybe (Int, Int)) 975 | getTerminalSize = hGetTerminalSize stdout 976 | 977 | -- | Attempts to get the current terminal size (height in rows, width in 978 | -- columns), by writing control character sequences to the specified handle 979 | -- (which will typically be 'stdout' or 'System.IO.stderr'). 980 | -- 981 | -- There is no \'ANSI\' control character sequence that reports the terminal 982 | -- size. So, it attempts to set the cursor position beyond the bottom right 983 | -- corner of the terminal and then use 'hGetCursorPosition' to query the console 984 | -- input stream. It works only on terminals that support each step and if data 985 | -- can be emitted to 'stdin'. (Use 'System.IO.hIsTerminalDevice' to test if 986 | -- 'stdin' is connected to a terminal.) 987 | -- 988 | -- On Windows operating systems, the function is not supported on consoles, such 989 | -- as mintty, that are not based on the Windows' Console API. (Command Prompt 990 | -- and PowerShell are based on the Console API.) 991 | -- 992 | -- For a different approach, one that does not use control character sequences 993 | -- and works when 'stdin' is redirected, see the 994 | -- package. 995 | -- 996 | -- @since 0.10.1 997 | hGetTerminalSize :: Handle -> IO (Maybe (Int, Int)) 998 | hGetTerminalSize h = do 999 | hSaveCursor h 1000 | hSetCursorPosition h 9999 9999 -- Attempt to set the cursor position beyond 1001 | -- the bottom right corner of the terminal. 1002 | mPos <- hGetCursorPosition h 1003 | hRestoreCursor h 1004 | hFlush h -- ensure the restore cursor position code is sent to the 1005 | -- operating system 1006 | pure $ fmap (\(r, c) -> (r + 1, c + 1)) mPos 1007 | 1008 | -- Set the Select Graphic Rendition mode 1009 | hSetSGR :: 1010 | Handle 1011 | -> [SGR] -- Commands: these will typically be applied on top of the 1012 | -- current console SGR mode. An empty list of commands is 1013 | -- equivalent to the list @[Reset]@. Commands are applied left to 1014 | -- right. 1015 | -> IO () 1016 | hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs 1017 | 1018 | -- | Set the Select Graphic Rendition mode 1019 | setSGR :: 1020 | [SGR] -- ^ Commands: these will typically be applied on top of the 1021 | -- current console SGR mode. An empty list of commands is 1022 | -- equivalent to the list @[Reset]@. Commands are applied left to 1023 | -- right. 1024 | -> IO () 1025 | setSGR = hSetSGR stdout 1026 | 1027 | hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: 1028 | Handle 1029 | -> IO () 1030 | hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode 1031 | hClearFromCursorToScreenBeginning h 1032 | = hPutStr h clearFromCursorToScreenBeginningCode 1033 | hClearScreen h = hPutStr h clearScreenCode 1034 | 1035 | clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO () 1036 | clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout 1037 | clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout 1038 | clearScreen = hClearScreen stdout 1039 | 1040 | hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: 1041 | Handle 1042 | -> IO () 1043 | hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode 1044 | hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode 1045 | hClearLine h = hPutStr h clearLineCode 1046 | 1047 | clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO () 1048 | clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout 1049 | clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout 1050 | clearLine = hClearLine stdout 1051 | 1052 | hEnableLineWrap, hDisableLineWrap :: 1053 | Handle 1054 | -> IO () 1055 | hEnableLineWrap h = hPutStr h enableLineWrapCode 1056 | hDisableLineWrap h = hPutStr h disableLineWrapCode 1057 | 1058 | enableLineWrap, disableLineWrap :: IO () 1059 | enableLineWrap = hEnableLineWrap stdout 1060 | disableLineWrap = hDisableLineWrap stdout 1061 | 1062 | hScrollPageUp, hScrollPageDown :: 1063 | Handle 1064 | -> Int -- Number of lines to scroll by 1065 | -> IO () 1066 | hScrollPageUp h n = hPutStr h $ scrollPageUpCode n 1067 | hScrollPageDown h n = hPutStr h $ scrollPageDownCode n 1068 | 1069 | scrollPageUp, scrollPageDown :: 1070 | Int -- ^ Number of lines to scroll by 1071 | -> IO () 1072 | scrollPageUp = hScrollPageUp stdout 1073 | scrollPageDown = hScrollPageDown stdout 1074 | -------------------------------------------------------------------------------- /ansi-terminal/src/System/Console/ANSI/Codes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | {-| This module exports functions that return 'String' values containing codes 5 | in accordance with the \'ANSI\' standards for control character sequences 6 | described in the documentation of module "System.Console.ANSI". 7 | -} 8 | module System.Console.ANSI.Codes 9 | ( 10 | -- * Basic data types 11 | module System.Console.ANSI.Types 12 | 13 | -- * Cursor movement by character 14 | -- 15 | -- | These functions yield @\"\"@ when the number is @0@ as, on some 16 | -- terminals, a @0@ parameter for the underlying \'ANSI\' code specifies a 17 | -- default parameter of @1@. 18 | , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode 19 | 20 | -- * Cursor movement by line 21 | -- 22 | -- | These functions yield the equivalent of @setCursorColumnCode 0@ when 23 | -- the number is @0@ as, on some terminals, a @0@ parameter for the 24 | -- underlying \'ANSI\' code specifies a default parameter of @1@. 25 | , cursorUpLineCode, cursorDownLineCode 26 | 27 | -- * Directly changing cursor position 28 | , setCursorColumnCode, setCursorPositionCode 29 | 30 | -- * Saving, restoring and reporting cursor position 31 | , saveCursorCode, restoreCursorCode, reportCursorPositionCode 32 | 33 | -- * Clearing parts of the screen 34 | , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode 35 | , clearScreenCode, clearFromCursorToLineEndCode 36 | , clearFromCursorToLineBeginningCode, clearLineCode 37 | 38 | -- * Enabling and disabling automatic line wrapping 39 | -- 40 | -- | These functions control whether or not characters automatically wrap to 41 | -- the next line when the cursor reaches the right border. 42 | , enableLineWrapCode, disableLineWrapCode 43 | 44 | -- * Scrolling the screen 45 | -- 46 | -- | These functions yield @\"\"@ when the number is @0@ as, on some 47 | -- terminals, a @0@ parameter for the underlying \'ANSI\' code specifies a 48 | -- default parameter of @1@. 49 | , scrollPageUpCode, scrollPageDownCode 50 | 51 | -- * Using screen buffers 52 | , useAlternateScreenBufferCode, useNormalScreenBufferCode 53 | 54 | -- * Reporting background or foreground colors 55 | , reportLayerColorCode 56 | 57 | -- * Select Graphic Rendition mode: colors and other whizzy stuff 58 | , setSGRCode 59 | 60 | -- * Cursor visibilty changes 61 | , hideCursorCode, showCursorCode 62 | 63 | -- * Hyperlinks 64 | -- 65 | -- | Some, but not all, terminals support hyperlinks - that is, clickable 66 | -- text that points to a URI. 67 | , hyperlinkCode, hyperlinkWithIdCode, hyperlinkWithParamsCode 68 | 69 | -- * Changing the title 70 | , setTitleCode 71 | 72 | -- * Utilities 73 | , colorToCode 74 | , Parameter 75 | , SubParam 76 | , ParamWithSubs 77 | , csi 78 | , csi' 79 | , osc 80 | , sgrToCode 81 | , sgrToCode' 82 | ) where 83 | 84 | import Data.Char (isPrint) 85 | import Data.List (intercalate) 86 | 87 | import Data.Colour.SRGB (toSRGB24, RGB (..)) 88 | 89 | import System.Console.ANSI.Types 90 | 91 | -- | Type synonym representing parameter values (without parameter substrings). 92 | -- To represent a paramater value followed by a parameter substring, see 93 | -- 'ParamWithSubs'. 94 | -- 95 | -- @since 1.1 96 | type Parameter = Int 97 | 98 | -- | Type synonym representing parameter elements of a parameter 99 | -- substring. An empty parameter element (which represents a default value for 100 | -- the parameter element) has value 'Nothing'. 101 | -- 102 | -- @since 1.1 103 | type SubParam = Maybe Int 104 | 105 | -- | Type synonym representing parameter values optionally followed by a 106 | -- parameter substring. Parameter substrings were introduced by 13.1.8 of T.416 107 | -- (03/93) for SGR parameter values 38 and 48 and have subsequently been adapted 108 | -- for other uses. 109 | -- 110 | -- @since 1.1 111 | type ParamWithSubs = (Parameter, [SubParam]) 112 | 113 | -- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int', 114 | -- returns the control sequence comprising the control function CONTROL 115 | -- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \'@;@\') 116 | -- and ending with the @controlFunction@ character(s) that identifies the 117 | -- control function. See 'csi'' for a function that handles parameter values 118 | -- that may be followed by a parameter substring. 119 | csi :: 120 | [Parameter] -- ^ List of parameters for the control sequence. 121 | -> String -- ^ Character(s) that identify the control function. 122 | -> String 123 | csi = renderCsi show 124 | 125 | -- | Like 'csi' but extended to parameters that may be followed by a parameter 126 | -- substring. The parameter elements of a parameter substring are separated from 127 | -- the parameter value and each other by \'@:@\'. 128 | -- 129 | -- @since 1.1 130 | csi' :: 131 | [ParamWithSubs] 132 | -- ^ List of parameters (each of which may be followed by a parameter 133 | -- substring). 134 | -> String -- ^ Characters(s) that identify the control function. 135 | -> String 136 | csi' = renderCsi render 137 | where 138 | render (p, []) = show p 139 | render (p, pes) = intercalate ":" (show p : map (maybe [] show) pes) 140 | 141 | -- | Helper function to render different types of parameters. 142 | renderCsi :: (a -> String) -> [a] -> String -> String 143 | renderCsi render args code = 144 | "\ESC[" ++ intercalate ";" (map render args) ++ code 145 | 146 | -- | 'osc' @parameterS parametersT@, where @parameterS@ specifies the type of 147 | -- operation to perform and @parametersT@ is the other parameter(s) (if any), 148 | -- returns the control sequence comprising the control function OPERATING SYSTEM 149 | -- COMMAND (OSC) followed by the parameters (separated by \';\') and ending with 150 | -- the STRING TERMINATOR (ST) @\"\\ESC\\\\\"@. 151 | -- 152 | -- @since 0.11.4 153 | osc :: 154 | String -- ^ Ps parameter 155 | -> String -- ^ Pt parameter(s) 156 | -> String 157 | osc pS pT = "\ESC]" ++ pS ++ ";" ++ pT ++ "\ESC\\" 158 | 159 | -- | 'colorToCode' @color@ returns the 0-based index of the color (one of the 160 | -- eight colors in the ANSI standard). 161 | colorToCode :: Color -> Int 162 | colorToCode color = case color of 163 | Black -> 0 164 | Red -> 1 165 | Green -> 2 166 | Yellow -> 3 167 | Blue -> 4 168 | Magenta -> 5 169 | Cyan -> 6 170 | White -> 7 171 | 172 | -- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION 173 | -- (SGR) aspect identified by @sgr@. If the parameter is followed by a parameter 174 | -- substring returns an empty list. See 'sgrToCode'' for a function that handles 175 | -- also parameter values that are followed by a parameter substring. 176 | sgrToCode :: 177 | SGR -- ^ The SGR aspect 178 | -> [Parameter] 179 | sgrToCode sgr = case sgrToCode' sgr of 180 | Right args -> args 181 | Left _ -> [] 182 | 183 | -- | 'sgrToCode'' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION 184 | -- (SGR) aspect identified by @sgr@. 185 | -- 186 | -- @since 1.1 187 | sgrToCode' :: 188 | SGR -- ^ The SGR aspect 189 | -> Either ParamWithSubs [Parameter] 190 | sgrToCode' sgr = case sgr of 191 | Reset -> Right [0] 192 | SetConsoleIntensity intensity -> case intensity of 193 | BoldIntensity -> Right [1] 194 | FaintIntensity -> Right [2] 195 | NormalIntensity -> Right [22] 196 | SetItalicized True -> Right [3] 197 | SetItalicized False -> Right [23] 198 | SetUnderlining underlining -> case underlining of 199 | SingleUnderline -> Right [4] 200 | DoubleUnderline -> Right [21] 201 | CurlyUnderline -> Left (4, [Just 3]) 202 | DottedUnderline -> Left (4, [Just 4]) 203 | DashedUnderline -> Left (4, [Just 5]) 204 | NoUnderline -> Right [24] 205 | SetBlinkSpeed blink_speed -> case blink_speed of 206 | SlowBlink -> Right [5] 207 | RapidBlink -> Right [6] 208 | NoBlink -> Right [25] 209 | SetVisible False -> Right [8] 210 | SetVisible True -> Right [28] 211 | SetSwapForegroundBackground True -> Right [7] 212 | SetSwapForegroundBackground False -> Right [27] 213 | SetColor Foreground Dull color -> Right [30 + colorToCode color] 214 | SetColor Foreground Vivid color -> Right [90 + colorToCode color] 215 | SetColor Background Dull color -> Right [40 + colorToCode color] 216 | SetColor Background Vivid color -> Right [100 + colorToCode color] 217 | SetColor Underlining Dull color -> Left (58, [Just 5, Just $ colorToCode color]) 218 | SetColor Underlining Vivid color -> Left (58, [Just 5, Just $ 8 + colorToCode color]) 219 | SetPaletteColor Foreground index -> Right [38, 5, fromIntegral index] 220 | SetPaletteColor Background index -> Right [48, 5, fromIntegral index] 221 | SetPaletteColor Underlining index -> Left (58, [Just 5, Just $ fromIntegral index]) 222 | SetRGBColor Foreground color -> Right $ [38, 2] ++ toRGB color 223 | SetRGBColor Background color -> Right $ [48, 2] ++ toRGB color 224 | SetRGBColor Underlining color -> Left (58, [Just 2, Nothing] ++ toRGB' color) 225 | SetDefaultColor Foreground -> Right [39] 226 | SetDefaultColor Background -> Right [49] 227 | SetDefaultColor Underlining -> Right [59] 228 | where 229 | toRGB color = let RGB r g b = toSRGB24 color 230 | in map fromIntegral [r, g, b] 231 | toRGB' = map Just . toRGB 232 | 233 | cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: 234 | Int -- ^ Number of lines or characters to move 235 | -> String 236 | cursorUpCode n = if n == 0 then "" else csi [n] "A" 237 | cursorDownCode n = if n == 0 then "" else csi [n] "B" 238 | cursorForwardCode n = if n == 0 then "" else csi [n] "C" 239 | cursorBackwardCode n = if n == 0 then "" else csi [n] "D" 240 | 241 | cursorDownLineCode, cursorUpLineCode :: 242 | Int -- ^ Number of lines to move 243 | -> String 244 | cursorDownLineCode n = if n == 0 then csi [1] "G" else csi [n] "E" 245 | cursorUpLineCode n = if n == 0 then csi [1] "G" else csi [n] "F" 246 | 247 | -- | Code to move the cursor to the specified column. The column numbering is 248 | -- 0-based (that is, the left-most column is numbered 0). 249 | setCursorColumnCode :: 250 | Int -- ^ 0-based column to move to 251 | -> String 252 | setCursorColumnCode n = csi [n + 1] "G" 253 | 254 | -- | Code to move the cursor to the specified position (row and column). The 255 | -- position is 0-based (that is, the top-left corner is at row 0 column 0). 256 | setCursorPositionCode :: 257 | Int -- ^ 0-based row to move to 258 | -> Int -- ^ 0-based column to move to 259 | -> String 260 | setCursorPositionCode n m = csi [n + 1, m + 1] "H" 261 | 262 | -- | @since 0.7.1 263 | saveCursorCode, restoreCursorCode :: String 264 | saveCursorCode = "\ESC7" 265 | restoreCursorCode = "\ESC8" 266 | 267 | -- | Code to emit the cursor position into the console input stream, immediately 268 | -- after being recognised on the output stream, as: 269 | -- @ESC [ \ ; \ R@ 270 | -- 271 | -- Note that the information that is emitted is 1-based (the top-left corner is 272 | -- at row 1 column 1) but 'setCursorPositionCode' is 0-based. 273 | -- 274 | -- In isolation of 'System.Console.ANSI.getReportedCursorPosition' or 275 | -- 'System.Console.ANSI.getCursorPosition', this function may be of limited use 276 | -- on Windows operating systems because of difficulties in obtaining the data 277 | -- emitted into the console input stream. 278 | -- 279 | -- @since 0.7.1 280 | reportCursorPositionCode :: String 281 | reportCursorPositionCode = csi [] "6n" 282 | 283 | -- | Code to emit the foreground or backgrond layer color into the console input 284 | -- stream, immediately after being recognised on the output stream, as: 285 | -- 286 | -- @ESC ] \ ; rgb: \ ; \ ; \ \@ 287 | -- 288 | -- where @\@ is @10@ for 'Foreground' and @11@ for 'Background'; @\@, 289 | -- @\@ and @\@ are the color channel values in hexadecimal (4, 8, 290 | -- 12 and 16 bit values are possible, although 16 bit values are most common); 291 | -- and @\@ is the STRING TERMINATOR (ST). ST depends on the terminal 292 | -- software and may be the @BEL@ character or @ESC \\@ characters. 293 | -- 294 | -- This function may be of limited, or no, use on Windows operating systems 295 | -- because (1) the control character sequence is not supported on native 296 | -- terminals (2) of difficulties in obtaining the data emitted into the 297 | -- console input stream. See 'System.Console.ANSI.getReportedLayerColor'. 298 | -- 299 | -- Underlining is not supported. 300 | -- 301 | -- @since 0.11.4 302 | reportLayerColorCode :: ConsoleLayer -> String 303 | reportLayerColorCode Foreground = osc "10" "?" 304 | reportLayerColorCode Background = osc "11" "?" 305 | reportLayerColorCode Underlining = [] -- Not supported. 306 | 307 | clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, 308 | clearScreenCode :: String 309 | clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, 310 | clearLineCode :: String 311 | 312 | clearFromCursorToScreenEndCode = csi [0] "J" 313 | clearFromCursorToScreenBeginningCode = csi [1] "J" 314 | clearScreenCode = csi [2] "J" 315 | clearFromCursorToLineEndCode = csi [0] "K" 316 | clearFromCursorToLineBeginningCode = csi [1] "K" 317 | clearLineCode = csi [2] "K" 318 | 319 | enableLineWrapCode, disableLineWrapCode :: String 320 | enableLineWrapCode = csi [] "?7h" 321 | disableLineWrapCode = csi [] "?7l" 322 | 323 | scrollPageUpCode, scrollPageDownCode :: 324 | Int -- ^ Number of lines to scroll by 325 | -> String 326 | scrollPageUpCode n = if n == 0 then "" else csi [n] "S" 327 | scrollPageDownCode n = if n == 0 then "" else csi [n] "T" 328 | 329 | useAlternateScreenBufferCode, useNormalScreenBufferCode :: String 330 | useAlternateScreenBufferCode = csi [] "?1049h" 331 | useNormalScreenBufferCode = csi [] "?1049l" 332 | 333 | setSGRCode :: 334 | [SGR] 335 | -- ^ Commands: these will typically be applied on top of the current 336 | -- console SGR mode. An empty list of commands is equivalent to the list 337 | -- @[Reset]@. Commands are applied left to right. 338 | -> String 339 | setSGRCode sgrs = csi' (concatMap sgrToCode'' sgrs) "m" 340 | where 341 | sgrToCode'' = either (:[]) (map (,[] :: [SubParam])) . sgrToCode' 342 | 343 | hideCursorCode, showCursorCode :: String 344 | hideCursorCode = csi [] "?25l" 345 | showCursorCode = csi [] "?25h" 346 | 347 | -- | Code to introduce a hyperlink with (key, value) parameters. Some terminals 348 | -- support an @id@ parameter key, so that hyperlinks with the same @id@ value 349 | -- are treated as connected. 350 | -- 351 | -- @since 0.11.3 352 | hyperlinkWithParamsCode :: 353 | [(String, String)] 354 | -- ^ Parameters 355 | -> String 356 | -- ^ URI 357 | -> String 358 | -- ^ Link text 359 | -> String 360 | hyperlinkWithParamsCode params uri link = 361 | osc "8" pT ++ link ++ osc "8" ";" 362 | where 363 | pT = params' ++ ";" ++ uri 364 | params' = intercalate ":" $ map (\(k, v) -> k ++ "=" ++ v) params 365 | 366 | -- | Code to introduce a hyperlink. 367 | -- 368 | -- @since 0.11.3 369 | hyperlinkCode :: 370 | String 371 | -- ^ URI 372 | -> String 373 | -- ^ Link text 374 | -> String 375 | hyperlinkCode = hyperlinkWithParamsCode [] 376 | 377 | -- | Code to introduce a hyperlink with an identifier for the link. Some 378 | -- terminals support an identifier, so that hyperlinks with the same identifier 379 | -- are treated as connected. 380 | -- 381 | -- @since 0.11.3 382 | hyperlinkWithIdCode :: 383 | String 384 | -- ^ Identifier for the link 385 | -> String 386 | -- ^ URI 387 | -> String 388 | -- ^ Link text 389 | -> String 390 | hyperlinkWithIdCode linkId = hyperlinkWithParamsCode [("id", linkId)] 391 | 392 | -- | Code to set the terminal window title and the icon name (that is, the text 393 | -- for the window in the Start bar, or similar). 394 | 395 | -- Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the right 396 | -- direction on xterm title setting on haskell-cafe. The "0" signifies that both 397 | -- the title and "icon" text should be set. This is chosen for consistent 398 | -- behaviour between Unixes and Windows. 399 | setTitleCode :: 400 | String 401 | -- ^ New window title and icon name 402 | -> String 403 | setTitleCode title = osc "0" (filter isPrint title) 404 | -------------------------------------------------------------------------------- /ansi-terminal/stack.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-23.2 # GHC 9.8.4 2 | flags: 3 | ansi-terminal: 4 | example: false 5 | -------------------------------------------------------------------------------- /ansi-terminal/unix/System/Console/ANSI/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | 3 | module System.Console.ANSI.Internal 4 | ( getReportedCursorPosition 5 | , getReportedLayerColor 6 | , hSupportsANSI 7 | , hNowSupportsANSI 8 | , hSupportsANSIColor 9 | ) where 10 | 11 | import Data.List ( uncons ) 12 | import Data.Maybe ( fromMaybe, isJust, mapMaybe ) 13 | import System.Environment ( lookupEnv ) 14 | import System.IO ( Handle, hIsTerminalDevice, hIsWritable ) 15 | import System.IO.Unsafe ( unsafePerformIO ) 16 | import System.Timeout ( timeout ) 17 | 18 | import System.Console.ANSI.Types ( ConsoleLayer (..) ) 19 | 20 | getReportedCursorPosition :: IO String 21 | getReportedCursorPosition = getReport "\ESC[" ["R"] 22 | 23 | getReportedLayerColor :: ConsoleLayer -> IO String 24 | getReportedLayerColor Underlining = 25 | error "getReportedLayerColor does not support underlining." 26 | getReportedLayerColor layer = 27 | getReport ("\ESC]" ++ pS ++ ";rgb:") ["\BEL", "\ESC\\"] 28 | where 29 | pS = case layer of 30 | Foreground -> "10" 31 | Background -> "11" 32 | 33 | getReport :: String -> [String] -> IO String 34 | getReport _ [] = error "getReport requires a list of terminating sequences." 35 | getReport startChars endChars = do 36 | -- If, unexpectedly, no data is available on the console input stream then 37 | -- the timeout will prevent the getChar blocking. For consistency with the 38 | -- Windows equivalent, returns "" if the expected information is unavailable. 39 | fromMaybe "" <$> timeout 500000 (getStart startChars "") -- 500 milliseconds 40 | where 41 | endChars' = mapMaybe uncons endChars 42 | 43 | -- The list is built in reverse order, in order to avoid O(n^2) complexity. 44 | -- So, getReport yields the reversed built list. 45 | 46 | getStart :: String -> String -> IO String 47 | getStart "" r = getRest r 48 | getStart (h:hs) r = do 49 | c <- getChar 50 | if c == h 51 | then getStart hs (c:r) -- Try to get the rest of the start characters 52 | else pure $ reverse (c:r) -- If the first character(s) are not the 53 | -- expected start then give up. This provides 54 | -- a modicom of protection against unexpected 55 | -- data in the input stream. 56 | getRest :: String -> IO String 57 | getRest r = do 58 | c <- getChar 59 | case lookup c endChars' of 60 | Nothing -> getRest (c:r) -- Continue building the list, until the first of 61 | -- the end characters is obtained. 62 | Just es -> getEnd es (c:r) -- Try to get the rest of the end characters. 63 | 64 | getEnd :: String -> String -> IO String 65 | getEnd "" r = pure $ reverse r 66 | getEnd (e:es) r = do 67 | c <- getChar 68 | if c /= e 69 | then getRest (c:r) -- Continue building the list, with the original end 70 | -- characters. 71 | else getEnd es (c:r) -- Continue building the list, checking against the 72 | -- remaining end characters. 73 | 74 | hSupportsANSI :: Handle -> IO Bool 75 | -- Borrowed from an HSpec patch by Simon Hengel 76 | -- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) 77 | hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI' 78 | where 79 | hSupportsANSI' = (&& isNotDumb) <$> hIsTerminalDevice h 80 | 81 | hNowSupportsANSI :: Handle -> IO Bool 82 | hNowSupportsANSI = hSupportsANSI 83 | 84 | hSupportsANSIColor :: Handle -> IO Bool 85 | hSupportsANSIColor h = (|| isEmacsTerm) <$> hSupportsANSI h 86 | where 87 | isEmacsTerm = insideEmacs && isDumb 88 | isDumb = not isNotDumb 89 | 90 | -- | This function assumes that once it is first established whether or not the 91 | -- TERM environment variable exists with contents dumb, that will not change. 92 | -- This approach is taken because the use of C function setenv() in one thread 93 | -- can cause other threads calling C function getenv() to crash. On Unix-like 94 | -- operating systems, System.Environment.lookupEnv is implemented using C 95 | -- function getenv(). 96 | isNotDumb :: Bool 97 | isNotDumb = unsafePerformIO (lookupEnv "TERM") /= Just "dumb" 98 | 99 | {-# NOINLINE isNotDumb #-} 100 | 101 | -- | This function assumes that once it is first established whether or not the 102 | -- INSIDE_EMACS environment variable exists, that will not change. This approach 103 | -- is taken because the use of C function setenv() in one thread can cause other 104 | -- threads calling C function getenv() to crash. On Unix-like operating systems, 105 | -- System.Environment.lookupEnv is implemented using C function getenv(). 106 | insideEmacs :: Bool 107 | insideEmacs = isJust $ unsafePerformIO (lookupEnv "INSIDE_EMACS") 108 | 109 | {-# NOINLINE insideEmacs #-} 110 | -------------------------------------------------------------------------------- /ansi-terminal/win/System/Console/ANSI/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module System.Console.ANSI.Internal 4 | ( getReportedCursorPosition 5 | , getReportedLayerColor 6 | , hNowSupportsANSI 7 | , hSupportsANSI 8 | , hSupportsANSIColor 9 | ) where 10 | 11 | import Control.Exception ( IOException, SomeException, catch, try ) 12 | import Data.Bits ( (.&.), (.|.) ) 13 | import Data.Maybe ( mapMaybe ) 14 | import System.Environment ( getEnvironment, lookupEnv ) 15 | import System.IO ( Handle, hIsTerminalDevice, hIsWritable, stdin ) 16 | import System.Console.ANSI.Types ( ConsoleLayer ) 17 | 18 | -- Provided by the ansi-terminal package 19 | import System.Console.ANSI.Windows.Foreign 20 | ( INPUT_RECORD (..), INPUT_RECORD_EVENT (..), KEY_EVENT_RECORD (..) 21 | , cWcharsToChars, eNABLE_VIRTUAL_TERMINAL_PROCESSING 22 | , getConsoleMode, getNumberOfConsoleInputEvents, iNVALID_HANDLE_VALUE 23 | , nullHANDLE, readConsoleInput, setConsoleMode, unicodeAsciiChar 24 | ) 25 | import System.Console.ANSI.Windows.Win32.MinTTY ( isMinTTYHandle ) 26 | import System.Console.ANSI.Windows.Win32.Types 27 | ( DWORD, HANDLE, withHandleToHANDLE ) 28 | 29 | getReportedCursorPosition :: IO String 30 | getReportedCursorPosition = getReported 31 | 32 | getReportedLayerColor :: ConsoleLayer -> IO String 33 | getReportedLayerColor _ = getReported 34 | 35 | getReported :: IO String 36 | getReported = catch getReported' getReportedExceptionHandler 37 | where 38 | getReported' = withHandleToHANDLE stdin action 39 | where 40 | action hdl = do 41 | n <- getNumberOfConsoleInputEvents hdl 42 | if n == 0 43 | then pure "" 44 | else do 45 | es <- readConsoleInput hdl n 46 | pure $ stringFromInputEvents es 47 | stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents 48 | wCharsFromInputEvents = mapMaybe wCharFromInputEvent 49 | wCharFromInputEvent e = if isKeyEvent && isKeyDown 50 | then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) 51 | else Nothing 52 | where 53 | eventType = inputEventType e 54 | eventRecord = inputEvent e 55 | isKeyEvent = eventType == 1 56 | keyEventRecord = case eventRecord of 57 | InputKeyEvent keyEventRecord' -> keyEventRecord' 58 | _ -> error "Unexpected input event, given input event type." 59 | isKeyDown = keyEventKeyDown keyEventRecord 60 | 61 | getReportedExceptionHandler :: IOException -> IO a 62 | getReportedExceptionHandler e = error msg 63 | where 64 | msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " ++ 65 | "console based on the Windows' Console API, such as Command Prompt " ++ 66 | "or PowerShell." 67 | 68 | hSupportsANSI :: Handle -> IO Bool 69 | hSupportsANSI = hSupportsANSI' False 70 | 71 | hNowSupportsANSI :: Handle -> IO Bool 72 | hNowSupportsANSI = hSupportsANSI' True 73 | 74 | hSupportsANSI' :: Bool -> Handle -> IO Bool 75 | hSupportsANSI' tryToEnable handle = do 76 | isWritable <- hIsWritable handle 77 | if isWritable 78 | then withHandleToHANDLE handle $ withHANDLE 79 | (pure False) -- Invalid handle or no handle 80 | ( \h -> do 81 | tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD) 82 | case tryMode of 83 | Left _ -> isMinTTYHandle h -- No ConHost mode 84 | Right mode -> do 85 | let isVTEnabled = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 86 | isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM" 87 | isTDNotDumb <- (&&) <$> hIsTerminalDevice handle <*> isNotDumb 88 | if isTDNotDumb && not isVTEnabled && tryToEnable 89 | then do 90 | let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING 91 | trySetMode <- try (setConsoleMode h mode') 92 | :: IO (Either SomeException ()) 93 | case trySetMode of 94 | Left _ -> pure False -- Can't enable VT processing 95 | Right () -> pure True -- VT processing enabled 96 | else pure $ isTDNotDumb && isVTEnabled 97 | ) 98 | else pure False 99 | 100 | -- | This function applies another to the Windows handle, if the handle is 101 | -- valid. If it is invalid, the specified default action is returned. 102 | withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a 103 | withHANDLE invalid action h = 104 | if h == iNVALID_HANDLE_VALUE || h == nullHANDLE 105 | then invalid -- Invalid handle or no handle 106 | else action h 107 | 108 | hSupportsANSIColor :: Handle -> IO Bool 109 | hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm 110 | where 111 | isEmacsTerm = (\env -> insideEmacs env && isDumb env) <$> getEnvironment 112 | insideEmacs = any (\(k, _) -> k == "INSIDE_EMACS") 113 | isDumb env = Just "dumb" == lookup "TERM" env 114 | -------------------------------------------------------------------------------- /ansi-terminal/win/System/Console/ANSI/Windows/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | 5 | module System.Console.ANSI.Windows.Foreign 6 | ( 7 | INPUT_RECORD (..) 8 | , INPUT_RECORD_EVENT (..) 9 | , KEY_EVENT_RECORD (..) 10 | , getNumberOfConsoleInputEvents 11 | , readConsoleInput 12 | , cWcharsToChars 13 | , unicodeAsciiChar 14 | , eNABLE_VIRTUAL_TERMINAL_PROCESSING 15 | , iNVALID_HANDLE_VALUE 16 | , nullHANDLE 17 | , getConsoleMode 18 | , setConsoleMode 19 | ) where 20 | 21 | import Control.Exception ( Exception ) 22 | import Data.Char ( chr ) 23 | import Data.Typeable ( Typeable ) 24 | import Data.Word ( Word32 ) 25 | import Foreign.C.Types ( CWchar (..) ) 26 | import Foreign.Marshal.Alloc ( alloca ) 27 | import Foreign.Marshal.Array ( allocaArray, peekArray, pokeArray ) 28 | import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr ) 29 | import Foreign.Storable ( Storable (..) ) 30 | import System.Console.ANSI.Windows.Win32.Types 31 | ( BOOL, DWORD, ErrCode, HANDLE, LPDWORD, SHORT, UINT, UINT_PTR, ULONG 32 | , WCHAR, WORD, failIfFalse_ 33 | ) 34 | 35 | peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) 36 | peekAndOffset ptr = do 37 | item <- peek ptr 38 | pure (item, ptr `plusPtr` sizeOf item) 39 | 40 | pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) 41 | pokeAndOffset ptr item = do 42 | poke ptr item 43 | pure (ptr `plusPtr` sizeOf item) 44 | 45 | data COORD = COORD 46 | { coord_x :: SHORT 47 | , coord_y :: SHORT 48 | } deriving (Read, Eq) 49 | 50 | instance Show COORD where 51 | show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" 52 | 53 | instance Storable COORD where 54 | sizeOf ~(COORD x y) = sizeOf x + sizeOf y 55 | alignment ~(COORD x _) = alignment x 56 | peek ptr = do 57 | let ptr' = castPtr ptr :: Ptr SHORT 58 | x <- peekElemOff ptr' 0 59 | y <- peekElemOff ptr' 1 60 | pure (COORD x y) 61 | poke ptr (COORD x y) = do 62 | let ptr' = castPtr ptr :: Ptr SHORT 63 | pokeElemOff ptr' 0 x 64 | pokeElemOff ptr' 1 y 65 | 66 | data SMALL_RECT = SMALL_RECT COORD COORD 67 | 68 | instance Show SMALL_RECT where 69 | show (SMALL_RECT tl br) = show tl ++ "-" ++ show br 70 | 71 | instance Storable SMALL_RECT where 72 | sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br 73 | alignment ~(SMALL_RECT tl _) = alignment tl 74 | peek ptr = do 75 | let ptr' = castPtr ptr :: Ptr COORD 76 | tl <- peekElemOff ptr' 0 77 | br <- peekElemOff ptr' 1 78 | pure (SMALL_RECT tl br) 79 | poke ptr (SMALL_RECT tl br) = do 80 | let ptr' = castPtr ptr :: Ptr COORD 81 | pokeElemOff ptr' 0 tl 82 | pokeElemOff ptr' 1 br 83 | 84 | data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO 85 | { cci_cursor_size :: DWORD 86 | , cci_cursor_visible :: BOOL 87 | } deriving (Show) 88 | 89 | instance Storable CONSOLE_CURSOR_INFO where 90 | sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible 91 | alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size 92 | peek ptr = do 93 | (size, ptr') <- peekAndOffset (castPtr ptr) 94 | visible <- peek ptr' 95 | pure (CONSOLE_CURSOR_INFO size visible) 96 | poke ptr (CONSOLE_CURSOR_INFO size visible) = do 97 | ptr' <- pokeAndOffset (castPtr ptr) size 98 | poke ptr' visible 99 | 100 | data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO 101 | { csbi_size :: COORD 102 | , csbi_cursor_position :: COORD 103 | , csbi_attributes :: WORD 104 | , csbi_window :: SMALL_RECT 105 | , csbi_maximum_window_size :: COORD 106 | } deriving (Show) 107 | 108 | instance Storable CONSOLE_SCREEN_BUFFER_INFO where 109 | sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO 110 | size cursor_position attributes window maximum_window_size) 111 | = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window 112 | + sizeOf maximum_window_size 113 | alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size 114 | peek ptr = do 115 | (size, ptr1) <- peekAndOffset (castPtr ptr) 116 | (cursor_position, ptr2) <- peekAndOffset ptr1 117 | (attributes, ptr3) <- peekAndOffset ptr2 118 | (window, ptr4) <- peekAndOffset ptr3 119 | maximum_window_size <- peek ptr4 120 | pure (CONSOLE_SCREEN_BUFFER_INFO 121 | size cursor_position attributes window maximum_window_size) 122 | poke ptr (CONSOLE_SCREEN_BUFFER_INFO 123 | size cursor_position attributes window maximum_window_size) 124 | = do 125 | ptr1 <- pokeAndOffset (castPtr ptr) size 126 | ptr2 <- pokeAndOffset ptr1 cursor_position 127 | ptr3 <- pokeAndOffset ptr2 attributes 128 | ptr4 <- pokeAndOffset ptr3 window 129 | poke ptr4 maximum_window_size 130 | 131 | data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX 132 | { csbix_size :: COORD 133 | , csbix_cursor_position :: COORD 134 | , csbix_attributes :: WORD 135 | , csbix_window :: SMALL_RECT 136 | , csbix_maximum_window_size :: COORD 137 | , csbix_popup_attributes :: WORD 138 | , csbix_fullscreen_supported :: BOOL 139 | , csbix_color_table :: [COLORREF] 140 | } deriving (Show) 141 | 142 | -- When specifying an explicit RGB color, the COLORREF value has the following 143 | -- hexadecimal form: 144 | -- 0x00bbggrr 145 | -- The low-order byte contains a value for the relative intensity of red; the 146 | -- second byte contains a value for green; and the third byte contains a value 147 | -- for blue. The high-order byte must be zero. The maximum value for a single 148 | -- byte is 0xFF. 149 | type COLORREF = Word32 150 | 151 | instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where 152 | sizeOf ~(CONSOLE_SCREEN_BUFFER_INFOEX 153 | size cursor_position attributes window maximum_window_size popup_attributes 154 | fullscreen_supported _) 155 | = sizeOf sizeCsbix + sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window 156 | + sizeOf maximum_window_size + sizeOf popup_attributes 157 | + sizeOf fullscreen_supported + 16 * sizeOf (undefined :: COLORREF) 158 | alignment ~(CONSOLE_SCREEN_BUFFER_INFOEX _ _ _ _ _ _ _ _) = alignment sizeCsbix 159 | peek ptr = do 160 | let ptr0 = castPtr ptr `plusPtr` sizeOf sizeCsbix 161 | (size, ptr1) <- peekAndOffset ptr0 162 | (cursor_position, ptr2) <- peekAndOffset ptr1 163 | (attributes, ptr3) <- peekAndOffset ptr2 164 | (window, ptr4) <- peekAndOffset ptr3 165 | (maximum_window_size, ptr5) <- peekAndOffset ptr4 166 | (popup_attributes, ptr6) <- peekAndOffset ptr5 167 | (fullscreen_supported, ptr7) <- peekAndOffset ptr6 168 | color_table <- peekArray 16 ptr7 169 | pure (CONSOLE_SCREEN_BUFFER_INFOEX 170 | size cursor_position attributes window maximum_window_size 171 | popup_attributes fullscreen_supported color_table) 172 | poke ptr (CONSOLE_SCREEN_BUFFER_INFOEX 173 | size cursor_position attributes window maximum_window_size popup_attributes 174 | fullscreen_supported color_table) 175 | = do 176 | ptr0 <- pokeAndOffset (castPtr ptr) sizeCsbix 177 | ptr1 <- pokeAndOffset ptr0 size 178 | ptr2 <- pokeAndOffset ptr1 cursor_position 179 | ptr3 <- pokeAndOffset ptr2 attributes 180 | ptr4 <- pokeAndOffset ptr3 window 181 | ptr5 <- pokeAndOffset ptr4 maximum_window_size 182 | ptr6 <- pokeAndOffset ptr5 popup_attributes 183 | ptr7 <- pokeAndOffset ptr6 fullscreen_supported 184 | pokeArray ptr7 color_table' 185 | where 186 | color_table' = take 16 $ color_table ++ repeat 0 187 | 188 | sizeCsbix :: ULONG 189 | sizeCsbix = fromIntegral $ 190 | sizeOf (undefined :: CONSOLE_SCREEN_BUFFER_INFOEX) 191 | 192 | data CHAR_INFO = CHAR_INFO 193 | { ci_char :: WCHAR 194 | , ci_attributes :: WORD 195 | } deriving (Show) 196 | 197 | instance Storable CHAR_INFO where 198 | sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes 199 | alignment ~(CHAR_INFO char _) = alignment char 200 | peek ptr = do 201 | (char, ptr') <- peekAndOffset (castPtr ptr) 202 | attributes <- peek ptr' 203 | pure (CHAR_INFO char attributes) 204 | poke ptr (CHAR_INFO char attributes) = do 205 | ptr' <- pokeAndOffset (castPtr ptr) char 206 | poke ptr' attributes 207 | 208 | kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, 209 | fOCUS_EVENT :: WORD 210 | kEY_EVENT = 1 211 | mOUSE_EVENT = 2 212 | wINDOW_BUFFER_SIZE_EVENT = 4 213 | mENU_EVENT = 8 214 | fOCUS_EVENT = 16 215 | 216 | foreign import ccall unsafe "windows.h GetNumberOfConsoleInputEvents" 217 | cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL 218 | foreign import ccall unsafe "windows.h ReadConsoleInputW" 219 | cReadConsoleInput :: HANDLE 220 | -> Ptr INPUT_RECORD 221 | -> DWORD 222 | -> LPDWORD 223 | -> IO BOOL 224 | 225 | data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) 226 | 227 | instance Show ConsoleException where 228 | show (ConsoleException 6) = 229 | "A fatal error has occurred.\n\n" ++ 230 | "An attempt has been made to send console virtual terminal sequences\n" ++ 231 | "(ANSI codes) to an output that has not been recognised as an\n" ++ 232 | "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ 233 | "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ 234 | "Prompt or PowerShell). That may occur, for example, if output has\n" ++ 235 | "been redirected to a file.\n\n" ++ 236 | "If that is unexpected, please post an issue at:\n" ++ 237 | "https://github.com/UnkindPartition/ansi-terminal/issues\n" 238 | show (ConsoleException errCode) = "ConsoleException " ++ show errCode 239 | 240 | instance Exception ConsoleException 241 | 242 | returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a 243 | returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr 244 | 245 | {- 246 | typedef union _UNICODE_ASCII_CHAR { 247 | WCHAR UnicodeChar; 248 | CHAR AsciiChar; 249 | } UNICODE_ASCII_CHAR; 250 | -} 251 | newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar 252 | { unicodeAsciiChar :: WCHAR 253 | } deriving (Show, Read, Eq) 254 | 255 | instance Storable UNICODE_ASCII_CHAR where 256 | sizeOf _ = 2 257 | alignment _ = 2 258 | peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr 259 | poke ptr val = case val of 260 | UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c 261 | 262 | {- 263 | typedef struct _KEY_EVENT_RECORD { 264 | BOOL bKeyDown; 265 | WORD wRepeatCount; 266 | WORD wVirtualKeyCode; 267 | WORD wVirtualScanCode; 268 | union { 269 | WCHAR UnicodeChar; 270 | CHAR AsciiChar; 271 | } uChar; 272 | DWORD dwControlKeyState; 273 | } 274 | #ifdef __GNUC__ 275 | /* gcc's alignment is not what win32 expects */ 276 | PACKED 277 | #endif 278 | KEY_EVENT_RECORD; 279 | -} 280 | data KEY_EVENT_RECORD = KEY_EVENT_RECORD 281 | { keyEventKeyDown :: BOOL 282 | , keyEventRepeatCount :: WORD 283 | , keyEventVirtualKeyCode :: WORD 284 | , keyEventVirtualScanCode :: WORD 285 | , keyEventChar :: UNICODE_ASCII_CHAR 286 | , keyEventControlKeystate :: DWORD 287 | } deriving (Show, Read, Eq) 288 | 289 | instance Storable KEY_EVENT_RECORD where 290 | sizeOf _ = 16 291 | alignment _ = 4 292 | peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr 293 | <*> (`peekByteOff` 4) ptr 294 | <*> (`peekByteOff` 6) ptr 295 | <*> (`peekByteOff` 8) ptr 296 | <*> (`peekByteOff` 10) ptr 297 | <*> (`peekByteOff` 12) ptr 298 | poke ptr val = do 299 | (`pokeByteOff` 0) ptr $ keyEventKeyDown val 300 | (`pokeByteOff` 4) ptr $ keyEventRepeatCount val 301 | (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val 302 | (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val 303 | (`pokeByteOff` 10) ptr $ keyEventChar val 304 | (`pokeByteOff` 12) ptr $ keyEventControlKeystate val 305 | 306 | {- 307 | typedef struct _MOUSE_EVENT_RECORD { 308 | COORD dwMousePosition; 309 | DWORD dwButtonState; 310 | DWORD dwControlKeyState; 311 | DWORD dwEventFlags; 312 | } MOUSE_EVENT_RECORD; 313 | -} 314 | data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD 315 | { mousePosition :: COORD 316 | , mouseButtonState :: DWORD 317 | , mouseControlKeyState :: DWORD 318 | , mouseEventFlags :: DWORD 319 | } deriving (Show, Read, Eq) 320 | 321 | instance Storable MOUSE_EVENT_RECORD where 322 | sizeOf _ = 16 323 | alignment _ = 4 324 | peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr 325 | <*> (`peekByteOff` 4) ptr 326 | <*> (`peekByteOff` 8) ptr 327 | <*> (`peekByteOff` 12) ptr 328 | poke ptr val = do 329 | (`pokeByteOff` 0) ptr $ mousePosition val 330 | (`pokeByteOff` 4) ptr $ mouseButtonState val 331 | (`pokeByteOff` 8) ptr $ mouseControlKeyState val 332 | (`pokeByteOff` 12) ptr $ mouseEventFlags val 333 | 334 | {- 335 | typedef struct _WINDOW_BUFFER_SIZE_RECORD { 336 | COORD dwSize; 337 | } WINDOW_BUFFER_SIZE_RECORD; 338 | -} 339 | data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD 340 | { bufSizeNew :: COORD 341 | } deriving (Show, Read, Eq) 342 | 343 | instance Storable WINDOW_BUFFER_SIZE_RECORD where 344 | sizeOf _ = 4 345 | alignment _ = 4 346 | peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr 347 | poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val 348 | 349 | {- 350 | typedef struct _MENU_EVENT_RECORD { 351 | UINT dwCommandId; 352 | } MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; 353 | -} 354 | data MENU_EVENT_RECORD = MENU_EVENT_RECORD 355 | { menuCommandId :: UINT 356 | } deriving (Show, Read, Eq) 357 | 358 | instance Storable MENU_EVENT_RECORD where 359 | sizeOf _ = 4 360 | alignment _ = 4 361 | peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr 362 | poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val 363 | 364 | {- 365 | typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; 366 | -} 367 | data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD 368 | { focusSetFocus :: BOOL 369 | } deriving (Show, Read, Eq) 370 | 371 | instance Storable FOCUS_EVENT_RECORD where 372 | sizeOf _ = 4 373 | alignment _ = 4 374 | peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr 375 | poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val 376 | 377 | data INPUT_RECORD_EVENT 378 | = InputKeyEvent KEY_EVENT_RECORD 379 | | InputMouseEvent MOUSE_EVENT_RECORD 380 | | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD 381 | | InputMenuEvent MENU_EVENT_RECORD 382 | | InputFocusEvent FOCUS_EVENT_RECORD 383 | deriving (Show, Read, Eq) 384 | 385 | {- 386 | typedef struct _INPUT_RECORD { 387 | WORD EventType; 388 | union { 389 | KEY_EVENT_RECORD KeyEvent; 390 | MOUSE_EVENT_RECORD MouseEvent; 391 | WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; 392 | MENU_EVENT_RECORD MenuEvent; 393 | FOCUS_EVENT_RECORD FocusEvent; 394 | } Event; 395 | } INPUT_RECORD,*PINPUT_RECORD; 396 | -} 397 | data INPUT_RECORD = INPUT_RECORD 398 | { inputEventType :: WORD 399 | , inputEvent :: INPUT_RECORD_EVENT 400 | } deriving (Show, Read, Eq) 401 | 402 | instance Storable INPUT_RECORD where 403 | sizeOf _ = 20 404 | alignment _ = 4 405 | peek ptr = do 406 | evType <- (`peekByteOff` 0) ptr 407 | event <- case evType of 408 | _ | evType == kEY_EVENT 409 | -> InputKeyEvent <$> (`peekByteOff` 4) ptr 410 | _ | evType == mOUSE_EVENT 411 | -> InputMouseEvent <$> (`peekByteOff` 4) ptr 412 | _ | evType == wINDOW_BUFFER_SIZE_EVENT 413 | -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr 414 | _ | evType == mENU_EVENT 415 | -> InputMenuEvent <$> (`peekByteOff` 4) ptr 416 | _ | evType == fOCUS_EVENT 417 | -> InputFocusEvent <$> (`peekByteOff` 4) ptr 418 | _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ 419 | show evType 420 | pure $ INPUT_RECORD evType event 421 | poke ptr val = do 422 | (`pokeByteOff` 0) ptr $ inputEventType val 423 | case inputEvent val of 424 | InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev 425 | InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev 426 | InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev 427 | InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev 428 | InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev 429 | 430 | -- The following is based on module System.Win32.Console.Extra from package 431 | -- Win32-console. 432 | 433 | getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD 434 | getNumberOfConsoleInputEvents hdl = 435 | returnWith_ $ \ptrN -> 436 | failIfFalse_ "GetNumberOfConsoleInputEvents" $ 437 | cGetNumberOfConsoleInputEvents hdl ptrN 438 | 439 | -- The following is based on module System.Win32.Console.Extra from package 440 | -- Win32-console, cut down for the WCHAR version of readConsoleInput. 441 | 442 | readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] 443 | readConsoleInput hdl len 444 | = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr 445 | 446 | readConsoleInputWith :: HANDLE 447 | -> DWORD 448 | -> OutputHandler (Ptr INPUT_RECORD, DWORD) 449 | readConsoleInputWith hdl len handler = 450 | allocaArray (fromEnum len) $ \ptrBuf -> 451 | alloca $ \ptrN -> do 452 | failIfFalse_ "ReadConsoleInputW" $ 453 | cReadConsoleInput hdl ptrBuf len ptrN 454 | n <- peek ptrN 455 | handler (ptrBuf, n) 456 | 457 | type OutputHandler o = forall a. (o -> IO a) -> IO a 458 | 459 | -- Replicated from module Foreign.C.String in package base because that module 460 | -- does not export the function. 461 | cWcharsToChars :: [CWchar] -> [Char] 462 | cWcharsToChars = map chr . fromUTF16 . map fromIntegral 463 | where 464 | fromUTF16 (c1:c2:wcs) 465 | | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = 466 | ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs 467 | fromUTF16 (c:wcs) = c : fromUTF16 wcs 468 | fromUTF16 [] = [] 469 | 470 | eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD 471 | eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 472 | 473 | iNVALID_HANDLE_VALUE :: HANDLE 474 | iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound 475 | 476 | nullHANDLE :: HANDLE 477 | nullHANDLE = nullPtr 478 | 479 | foreign import ccall unsafe "HsWin32.h _ansi_terminal_castUINTPtrToPtr" 480 | castUINTPtrToPtr :: UINT_PTR -> Ptr a 481 | 482 | foreign import ccall unsafe "windows.h GetConsoleMode" 483 | c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL 484 | 485 | foreign import ccall unsafe "windows.h SetConsoleMode" 486 | c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL 487 | 488 | getConsoleMode :: HANDLE -> IO DWORD 489 | getConsoleMode h = alloca $ \ptr -> do 490 | failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr 491 | peek ptr 492 | 493 | setConsoleMode :: HANDLE -> DWORD -> IO () 494 | setConsoleMode h mode = failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h mode 495 | -------------------------------------------------------------------------------- /ansi-terminal/win/System/Console/ANSI/Windows/Win32/MinTTY.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-| This module is based on the corresponding code in the mintty package and the 5 | Win32 package, in order to avoid a dependency on those packages. 6 | -} 7 | module System.Console.ANSI.Windows.Win32.MinTTY 8 | ( isMinTTYHandle 9 | ) where 10 | 11 | import Control.Exception ( catch ) 12 | import Data.Int ( Int32 ) 13 | import Data.List ( isInfixOf ) 14 | import Data.Word ( Word8 ) 15 | import Foreign.C.String 16 | ( peekCWStringLen, withCAString, withCWString, withCWStringLen ) 17 | import Foreign.C.Types ( CInt (..) ) 18 | import Foreign.Marshal.Alloc ( alloca, allocaBytes ) 19 | import Foreign.Marshal.Array ( advancePtr, copyArray ) 20 | import Foreign.Marshal.Utils ( maybeWith ) 21 | import Foreign.Ptr ( FunPtr, Ptr, castPtr, castPtrToFunPtr, plusPtr ) 22 | import Foreign.Storable ( Storable (..) ) 23 | 24 | -- Provided by the ansi-terminal package 25 | import System.Console.ANSI.Windows.Win32.Types 26 | ( Addr, BOOL, DWORD, FileType, HANDLE, HMODULE, LPCSTR, LPCTSTR, LPTSTR 27 | , TCHAR, ULONG, USHORT, failIfFalse_, failIfNeg, failIfNull 28 | ) 29 | 30 | -- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP. 31 | -- Since we need some structs that are only available with Vista or later, 32 | -- we must manually set WINVER/_WIN32_WINNT accordingly. 33 | #undef WINVER 34 | #define WINVER 0x0600 35 | #undef _WIN32_WINNT 36 | #define _WIN32_WINNT 0x0600 37 | #include 38 | #include "winternl_compat.h" 39 | 40 | #if __GLASGOW_HASKELL__ < 800 41 | #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) 42 | #endif 43 | 44 | type F_NtQueryObject = 45 | HANDLE 46 | -> CInt 47 | -> Ptr OBJECT_NAME_INFORMATION 48 | -> ULONG 49 | -> Ptr ULONG 50 | -> IO NTSTATUS 51 | type F_GetFileInformationByHandleEx = 52 | HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL 53 | type NTSTATUS = #type NTSTATUS 54 | 55 | data FILE_NAME_INFO = FILE_NAME_INFO 56 | { fniFileNameLength :: DWORD 57 | , fniFileName :: String 58 | } 59 | 60 | instance Storable FILE_NAME_INFO where 61 | sizeOf _ = #size FILE_NAME_INFO 62 | alignment _ = #alignment FILE_NAME_INFO 63 | poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do 64 | let len' = (min mAX_PATH len) * sizeOfTCHAR 65 | start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName) 66 | end = advancePtr start len' 67 | (#poke FILE_NAME_INFO, FileNameLength) buf len' 68 | copyArray start (castPtr str :: Ptr Word8) len' 69 | poke (castPtr end) (0 :: TCHAR) 70 | peek buf = do 71 | vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf 72 | let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR 73 | vfniFileName <- 74 | peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len) 75 | pure $ FILE_NAME_INFO 76 | { fniFileNameLength = vfniFileNameLength 77 | , fniFileName = vfniFileName 78 | } 79 | 80 | newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION 81 | { oniName :: UNICODE_STRING } 82 | 83 | instance Storable OBJECT_NAME_INFORMATION where 84 | sizeOf _ = #size OBJECT_NAME_INFORMATION 85 | alignment _ = #alignment OBJECT_NAME_INFORMATION 86 | poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni) 87 | peek buf = 88 | fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf 89 | 90 | data UNICODE_STRING = UNICODE_STRING 91 | { usLength :: USHORT 92 | , usMaximumLength :: USHORT 93 | , usBuffer :: String 94 | } 95 | 96 | instance Storable UNICODE_STRING where 97 | sizeOf _ = #size UNICODE_STRING 98 | alignment _ = #alignment UNICODE_STRING 99 | poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do 100 | let len' = (min mAX_PATH len) * sizeOfTCHAR 101 | start = advancePtr (castPtr buf) (#size UNICODE_STRING) 102 | end = advancePtr start len' 103 | (#poke UNICODE_STRING, Length) buf len' 104 | (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR) 105 | (#poke UNICODE_STRING, Buffer) buf start 106 | copyArray start (castPtr str :: Ptr Word8) len' 107 | poke (castPtr end) (0 :: TCHAR) 108 | peek buf = do 109 | vusLength <- (#peek UNICODE_STRING, Length) buf 110 | vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf 111 | vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf 112 | let len = fromIntegral vusLength `div` sizeOfTCHAR 113 | vusBuffer <- peekTStringLen (vusBufferPtr, len) 114 | pure $ UNICODE_STRING 115 | { usLength = vusLength 116 | , usMaximumLength = vusMaximumLength 117 | , usBuffer = vusBuffer 118 | } 119 | 120 | -- | Returns 'True' is the given handle is attached to a MinTTY console 121 | -- (e.g., Cygwin or MSYS). Returns 'False' otherwise. 122 | isMinTTYHandle :: HANDLE -> IO Bool 123 | isMinTTYHandle h = do 124 | fileType <- getFileType h 125 | if fileType /= fILE_TYPE_PIPE 126 | then pure False 127 | else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h 128 | -- GetFileNameByHandleEx is only available on Vista and later (hence 129 | -- the name isMinTTYVista). If we're on an older version of Windows, 130 | -- getProcAddress will throw an IOException when it fails to find 131 | -- GetFileNameByHandleEx, and thus we will default to using 132 | -- NtQueryObject (isMinTTYCompat). 133 | 134 | isMinTTYVista :: HANDLE -> IO Bool 135 | isMinTTYVista h = do 136 | fn <- getFileNameByHandle h 137 | pure $ cygwinMSYSCheck fn 138 | `catch` \(_ :: IOError) -> pure False 139 | 140 | cygwinMSYSCheck :: String -> Bool 141 | cygwinMSYSCheck fn = 142 | ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) 143 | && "-pty" `isInfixOf` fn 144 | -- Note that GetFileInformationByHandleEx might return a filepath like: 145 | -- 146 | -- \msys-dd50a72ab4668b33-pty1-to-master 147 | -- 148 | -- But NtQueryObject might return something like: 149 | -- 150 | -- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master 151 | -- 152 | -- This means we can't rely on "\cygwin-" or "\msys-" being at the very start 153 | -- of the filepath. As a result, we use `isPrefixOf` to check for "cygwin" and 154 | -- "msys". 155 | -- 156 | -- It's unclear if "-master" will always appear in the filepath name. Recent 157 | -- versions of MinTTY have been known to give filepaths like this (#186): 158 | -- 159 | -- \msys-dd50a72ab4668b33-pty0-to-master-nat 160 | -- 161 | -- Just in case MinTTY ever changes this convention, we don't bother checking 162 | -- for the presence of "-master" in the filepath name at all. 163 | 164 | isMinTTYCompat :: HANDLE -> IO Bool 165 | isMinTTYCompat h = do 166 | fn <- ntQueryObjectNameInformation h 167 | pure $ cygwinMSYSCheck fn 168 | `catch` \(_ :: IOError) -> pure False 169 | 170 | fILE_TYPE_PIPE :: FileType 171 | fILE_TYPE_PIPE = 3 172 | 173 | ntQueryObjectNameInformation :: HANDLE -> IO String 174 | ntQueryObjectNameInformation h = do 175 | let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION) 176 | bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR 177 | allocaBytes bufSize $ \buf -> 178 | alloca $ \p_len -> do 179 | hwnd <- getModuleHandle (Just "ntdll.exe") 180 | addr <- getProcAddress hwnd "NtQueryObject" 181 | let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr addr) 182 | _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject 183 | h objectNameInformation buf (fromIntegral bufSize) p_len 184 | oni <- peek buf 185 | pure $ usBuffer $ oniName oni 186 | 187 | sizeOfTCHAR :: Int 188 | sizeOfTCHAR = sizeOf (undefined :: TCHAR) 189 | 190 | getFileNameByHandle :: HANDLE -> IO String 191 | getFileNameByHandle h = do 192 | let sizeOfDWORD = sizeOf (undefined :: DWORD) 193 | -- note: implicitly assuming that DWORD has stronger alignment than wchar_t 194 | bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR 195 | allocaBytes bufSize $ \buf -> do 196 | getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) 197 | fni <- peek buf 198 | pure $ fniFileName fni 199 | 200 | getFileInformationByHandleEx :: 201 | HANDLE 202 | -> CInt 203 | -> Ptr FILE_NAME_INFO 204 | -> DWORD 205 | -> IO () 206 | getFileInformationByHandleEx h cls buf bufSize = do 207 | lib <- getModuleHandle (Just "kernel32.dll") 208 | ptr <- getProcAddress lib "GetFileInformationByHandleEx" 209 | let c_GetFileInformationByHandleEx = 210 | mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) 211 | failIfFalse_ "getFileInformationByHandleEx" 212 | (c_GetFileInformationByHandleEx h cls buf bufSize) 213 | 214 | getModuleHandle :: Maybe String -> IO HMODULE 215 | getModuleHandle mb_name = 216 | maybeWith withTString mb_name $ \ c_name -> 217 | failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name 218 | 219 | getProcAddress :: HMODULE -> String -> IO Addr 220 | getProcAddress hmod procname = 221 | withCAString procname $ \ c_procname -> 222 | failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname 223 | 224 | peekTStringLen :: (LPCTSTR, Int) -> IO String 225 | peekTStringLen = peekCWStringLen 226 | 227 | withTString :: String -> (LPTSTR -> IO a) -> IO a 228 | withTString = withCWString 229 | 230 | withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a 231 | withTStringLen = withCWStringLen 232 | 233 | fileNameInfo :: CInt 234 | fileNameInfo = #const FileNameInfo 235 | 236 | mAX_PATH :: Num a => a 237 | mAX_PATH = #const MAX_PATH 238 | 239 | objectNameInformation :: CInt 240 | objectNameInformation = #const ObjectNameInformation 241 | 242 | foreign import ccall "dynamic" 243 | mk_GetFileInformationByHandleEx :: 244 | FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx 245 | 246 | foreign import ccall unsafe "windows.h GetFileType" 247 | getFileType :: HANDLE -> IO FileType 248 | 249 | foreign import ccall unsafe "windows.h GetProcAddress" 250 | c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr 251 | 252 | foreign import ccall "dynamic" 253 | mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject 254 | 255 | foreign import ccall unsafe "windows.h GetModuleHandleW" 256 | c_GetModuleHandle :: LPCTSTR -> IO HMODULE 257 | -------------------------------------------------------------------------------- /ansi-terminal/win/System/Console/ANSI/Windows/Win32/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | {-| This module is based on the corresponding code in the Win32 package, in 4 | order to avoid a dependency on that package. Some of that code had its origins 5 | in earlier versions of this package. 6 | -} 7 | module System.Console.ANSI.Windows.Win32.Types 8 | ( Addr 9 | , BOOL 10 | , DWORD 11 | , ErrCode 12 | , FileType 13 | , HANDLE 14 | , HMODULE 15 | , LPCSTR 16 | , LPCTSTR 17 | , LPDWORD 18 | , LPTSTR 19 | , SHORT 20 | , TCHAR 21 | , UINT 22 | , UINT_PTR 23 | , ULONG 24 | , USHORT 25 | , WCHAR 26 | , WORD 27 | , failIfFalse_ 28 | , failIfNeg 29 | , failIfNull 30 | , withHandleToHANDLE 31 | ) where 32 | 33 | import Control.Concurrent.MVar ( readMVar ) 34 | import Control.Exception ( bracket, throwIO ) 35 | import Control.Monad ( when ) 36 | import Data.Char ( isSpace ) 37 | import Data.Typeable ( cast ) 38 | import Data.Word ( Word16, Word32 ) 39 | import Foreign.C.Error ( Errno (..), errnoToIOError ) 40 | import Foreign.C.String ( peekCWString ) 41 | import Foreign.C.Types ( CChar, CInt (..), CShort (..), CWchar ) 42 | import Foreign.Ptr ( Ptr, nullPtr ) 43 | import Foreign.StablePtr ( StablePtr, freeStablePtr, newStablePtr ) 44 | import GHC.IO.Handle.Types ( Handle (..), Handle__ (..) ) 45 | import GHC.IO.FD ( FD(..) ) -- A wrapper around an Int32 46 | import Numeric ( showHex ) 47 | import System.IO.Error ( ioeSetErrorString ) 48 | 49 | #if defined(__IO_MANAGER_WINIO__) 50 | import GHC.IO.Exception 51 | ( IOErrorType (InappropriateType), IOException (IOError), ioException ) 52 | import GHC.IO.SubSystem ( () ) 53 | import GHC.IO.Windows.Handle ( ConsoleHandle, Io, NativeHandle, toHANDLE ) 54 | #endif 55 | 56 | type Addr = Ptr () 57 | type BOOL = Bool 58 | type DWORD = Word32 59 | type ErrCode = DWORD 60 | type FileType = DWORD 61 | type HANDLE = Ptr () 62 | type HMODULE = Ptr () 63 | type LPCSTR = LPSTR 64 | type LPCTSTR = LPTSTR 65 | type LPDWORD = Ptr DWORD 66 | type LPSTR = Ptr CChar 67 | type LPTSTR = Ptr TCHAR 68 | type LPWSTR = Ptr CWchar 69 | type SHORT = CShort 70 | type TCHAR = CWchar 71 | type UINT = Word32 72 | type UINT_PTR = Word 73 | type ULONG = Word32 74 | type USHORT = Word16 75 | type WCHAR = CWchar 76 | type WORD = Word16 77 | 78 | withStablePtr :: a -> (StablePtr a -> IO b) -> IO b 79 | withStablePtr value = bracket (newStablePtr value) freeStablePtr 80 | 81 | #if defined(__IO_MANAGER_WINIO__) 82 | 83 | withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a 84 | withHandleToHANDLE = withHandleToHANDLEPosix withHandleToHANDLENative 85 | 86 | withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a 87 | withHandleToHANDLENative haskell_handle action = 88 | withStablePtr haskell_handle $ const $ do 89 | let write_handle_mvar = case haskell_handle of 90 | FileHandle _ handle_mvar -> handle_mvar 91 | DuplexHandle _ _ handle_mvar -> handle_mvar 92 | windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE 93 | action windows_handle 94 | where 95 | handle_ToHANDLE :: Handle__ -> IO HANDLE 96 | handle_ToHANDLE (Handle__{haDevice = dev}) = 97 | case ( cast dev :: Maybe (Io NativeHandle) 98 | , cast dev :: Maybe (Io ConsoleHandle)) of 99 | (Just hwnd, Nothing) -> pure $ toHANDLE hwnd 100 | (Nothing, Just hwnd) -> pure $ toHANDLE hwnd 101 | _ -> throwErr "not a known HANDLE" 102 | 103 | throwErr msg = ioException $ IOError (Just haskell_handle) 104 | InappropriateType "withHandleToHANDLENative" msg Nothing Nothing 105 | 106 | #else 107 | 108 | withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a 109 | withHandleToHANDLE = withHandleToHANDLEPosix 110 | 111 | #endif 112 | 113 | withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a 114 | withHandleToHANDLEPosix haskell_handle action = 115 | -- Create a stable pointer to the Handle. This prevents the garbage collector 116 | -- getting to it while we are doing horrible manipulations with it, and hence 117 | -- stops it being finalized (and closed). 118 | withStablePtr haskell_handle $ const $ do 119 | -- Grab the write handle variable from the Handle 120 | let write_handle_mvar = case haskell_handle of 121 | FileHandle _ handle_mvar -> handle_mvar 122 | DuplexHandle _ _ handle_mvar -> handle_mvar 123 | -- This is "write" MVar, we could also take the "read" one 124 | 125 | -- Get the FD from the algebraic data type 126 | Just fd <- (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) 127 | <$> readMVar write_handle_mvar 128 | 129 | -- Finally, turn that (C-land) FD into a HANDLE using msvcrt 130 | windows_handle <- c_get_osfhandle fd 131 | -- Do what the user originally wanted 132 | action windows_handle 133 | 134 | -- This essential function comes from the C runtime system. It is certainly 135 | -- provided by msvcrt, and also seems to be provided by the mingw C library - 136 | -- hurrah! 137 | foreign import ccall unsafe "_get_osfhandle" 138 | c_get_osfhandle :: CInt -> IO HANDLE 139 | 140 | failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a 141 | failIfNeg = failIf (< 0) 142 | 143 | failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) 144 | failIfNull = failIf (== nullPtr) 145 | 146 | failIf :: (a -> Bool) -> String -> IO a -> IO a 147 | failIf p wh act = do 148 | v <- act 149 | if p v then errorWin wh else return v 150 | 151 | failIfFalse_ :: String -> IO Bool -> IO () 152 | failIfFalse_ = failIf_ not 153 | 154 | failIf_ :: (a -> Bool) -> String -> IO a -> IO () 155 | failIf_ p wh act = do 156 | v <- act 157 | when (p v) $ errorWin wh 158 | 159 | errorWin :: String -> IO a 160 | errorWin fn_name = do 161 | err_code <- getLastError 162 | failWith fn_name err_code 163 | 164 | failWith :: String -> ErrCode -> IO a 165 | failWith fn_name err_code = do 166 | c_msg <- getErrorMessage err_code 167 | msg <- if c_msg == nullPtr 168 | then return $ "Error 0x" ++ Numeric.showHex err_code "" 169 | else do 170 | msg <- peekTString c_msg 171 | -- We ignore failure of freeing c_msg, given we're already failing 172 | _ <- localFree c_msg 173 | return msg 174 | -- turn GetLastError() into errno, which errnoToIOError knows how to convert 175 | -- to an IOException we can throw. 176 | errno <- c_maperrno_func err_code 177 | let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n 178 | ioerror = errnoToIOError fn_name errno Nothing Nothing 179 | `ioeSetErrorString` msg' 180 | throwIO ioerror 181 | 182 | peekTString :: LPCTSTR -> IO String 183 | peekTString = peekCWString 184 | 185 | foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c 186 | c_maperrno_func :: ErrCode -> IO Errno 187 | 188 | foreign import ccall unsafe "errors.h _ansi_terminal_getErrorMessage" 189 | getErrorMessage :: DWORD -> IO LPWSTR 190 | 191 | foreign import ccall unsafe "windows.h GetLastError" 192 | getLastError :: IO ErrCode 193 | 194 | foreign import ccall unsafe "windows.h LocalFree" 195 | localFree :: Ptr a -> IO (Ptr a) 196 | -------------------------------------------------------------------------------- /ansi-terminal/win/c-source/HsWin32.c: -------------------------------------------------------------------------------- 1 | // Out-of-line versions of all the inline functions from HsWin32.h 2 | #define INLINE /* nothing */ 3 | #include "HsWin32.h" 4 | -------------------------------------------------------------------------------- /ansi-terminal/win/c-source/errors.c: -------------------------------------------------------------------------------- 1 | #define UNICODE 2 | #include 3 | #include 4 | #include 5 | #include "errors.h" 6 | 7 | /* Copied from the Win32-2.13.4.0 package, but renamed `getErrorMessage` to 8 | * `_ansi_terminal_getErrorMessage`, in order to avoid problems with duplicate 9 | * symbols in GHC's object files. See: 10 | * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. 11 | */ 12 | 13 | /* There's two ways we can generate error messages - with different tradeoffs: 14 | * If we do a function call, we have to use a static buffer. 15 | * If we use a macro and ANSI C's string splicing, we have to use constant 16 | * strings - and accept a certain amount of overhead from inserting the 17 | * boilerplate text. 18 | * 19 | * Why the concern about performance? Error messages are only generated 20 | * in exceptional situations -- sof 9/98 21 | * 22 | * sof 9/98 : Removed use of non-standard (and wimpy :-) snprintf(). 23 | */ 24 | 25 | LPTSTR _ansi_terminal_getErrorMessage(DWORD err) 26 | { 27 | LPTSTR what; 28 | 29 | FormatMessage( 30 | (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER) , 31 | NULL, 32 | err, 33 | MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */ 34 | (LPTSTR) &what, 35 | 0, 36 | NULL 37 | ); 38 | return what; 39 | } 40 | -------------------------------------------------------------------------------- /ansi-terminal/win/include/HsWin32.h: -------------------------------------------------------------------------------- 1 | #ifndef _ANSI_TERMINAL_HSWIN32_H 2 | #define _ANSI_TERMINAL_HSWIN32_H 3 | 4 | #define UNICODE 5 | #include 6 | 7 | /* Copied from the Win32-2.13.4.0 package, but renamed `castUINTPtrToPtr` to 8 | * `_ansi_terminal_castUINTPtrToPtr`, in order to avoid problems with duplicate 9 | * symbols in GHC's object files. See: 10 | * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. 11 | */ 12 | 13 | #ifndef INLINE 14 | # if defined(_MSC_VER) 15 | # define INLINE extern __inline 16 | # else 17 | # define INLINE extern inline 18 | # endif 19 | #endif 20 | 21 | INLINE void *_ansi_terminal_castUINTPtrToPtr(UINT_PTR n) { return (void *)n; } 22 | 23 | #endif /* _ANSI_TERMINAL_HSWIN32_H */ 24 | -------------------------------------------------------------------------------- /ansi-terminal/win/include/errors.h: -------------------------------------------------------------------------------- 1 | #ifndef _ANSI_TERMINAL_ERRORS_H 2 | #define _ANSI_TERMINAL_ERRORS_H 3 | 4 | #include 5 | 6 | /* Copied from the Win32-2.13.4.0 package, but renamed `getErrorMessage` to 7 | * `_ansi_terminal_getErrorMessage`, in order to avoid problems with duplicate 8 | * symbols in GHC's object files. See: 9 | * https://gitlab.haskell.org/ghc/ghc/-/issues/23365. 10 | */ 11 | 12 | /* There's two ways we can generate error messages - with different tradeoffs: 13 | * If we do a function call, we have to use a static buffer. 14 | * If we use a macro and ANSI C's string splicing, we have to use constant 15 | * strings - and accept a certain amount of overhead from inserting the 16 | * boilerplate text. 17 | */ 18 | 19 | /* result should be freed using LocalFree */ 20 | extern LPTSTR _ansi_terminal_getErrorMessage(DWORD err); 21 | 22 | #endif /* _ANSI_TERMINAL_ERRORS_H */ 23 | -------------------------------------------------------------------------------- /ansi-terminal/win/include/winternl_compat.h: -------------------------------------------------------------------------------- 1 | #ifndef WINTERNL_COMPAT_H 2 | #define WINTERNL_COMPAT_H 3 | 4 | /* 5 | * winternl.h is not included in MinGW, which was shipped with the 32-bit 6 | * Windows version of GHC prior to the 7.10.3 release. 7 | */ 8 | #if defined(x86_64_HOST_ARCH) || \ 9 | __GLASGOW_HASKELL__ >= 711 || \ 10 | (__GLASGOW_HASKELL__ == 710 && \ 11 | defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ 12 | __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) 13 | # include 14 | #else 15 | // Some declarations from winternl.h that we need 16 | # include 17 | 18 | typedef LONG NTSTATUS; 19 | 20 | typedef struct _UNICODE_STRING { 21 | USHORT Length; 22 | USHORT MaximumLength; 23 | PWSTR Buffer; 24 | } UNICODE_STRING; 25 | 26 | typedef struct _OBJECT_NAME_INFORMATION { 27 | UNICODE_STRING Name; 28 | } OBJECT_NAME_INFORMATION; 29 | #endif 30 | 31 | #endif /* WINTERNL_COMPAT_H */ 32 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ansi-terminal 3 | ansi-terminal-types 4 | -------------------------------------------------------------------------------- /example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UnkindPartition/ansi-terminal/83170d427cbdfa2cd975e37b34410f133c84047a/example.png -------------------------------------------------------------------------------- /release: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | 4 | echo "Have you updated the version number? Type 'yes' if you have!" 5 | read version_response 6 | 7 | if [ "$version_response" != "yes" ]; then 8 | echo "Go and update the version number" 9 | exit 1 10 | fi 11 | 12 | sdist_output=`runghc Setup.lhs sdist` 13 | 14 | if [ "$?" != "0" ]; then 15 | echo "Cabal sdist failed, aborting" 16 | exit 1 17 | fi 18 | 19 | # Want to find a line like: 20 | # Source tarball created: dist/ansi-terminal-0.1.tar.gz 21 | 22 | # Test this with: 23 | # runghc Setup.lhs sdist | grep ... 24 | filename=`echo $sdist_output | sed 's/.*Source tarball created: \([^ ]*\).*/\1/'` 25 | echo "Filename: $filename" 26 | 27 | if [ "$filename" = "$sdist_output" ]; then 28 | echo "Could not find filename, aborting" 29 | exit 1 30 | fi 31 | 32 | # Test this with: 33 | # echo dist/ansi-terminal-0.1.tar.gz | sed ... 34 | version=`echo $filename | sed 's/^[^0-9]*\([0-9\.]*\).tar.gz$/\1/'` 35 | echo "Version: $version" 36 | 37 | if [ "$version" = "$filename" ]; then 38 | echo "Could not find version, aborting" 39 | exit 1 40 | fi 41 | 42 | echo "This is your last chance to abort! I'm going to upload in 10 seconds" 43 | sleep 10 44 | 45 | git tag "v$version" 46 | 47 | if [ "$?" != "0" ]; then 48 | echo "Git tag failed, aborting" 49 | exit 1 50 | fi 51 | 52 | # You need to have stored your Hackage username and password as directed by cabal-upload 53 | # I use -v3 because otherwise the error messages can be cryptic :-) 54 | cabal upload -v3 $filename 55 | 56 | if [ "$?" != "0" ]; then 57 | echo "Hackage upload failed, aborting" 58 | exit 1 59 | fi 60 | 61 | # Success! 62 | exit 0 63 | -------------------------------------------------------------------------------- /stack-ghc-9.4.8.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-21.25 # GHC 9.4.8 2 | flags: 3 | ansi-terminal: 4 | example: false 5 | packages: 6 | - ansi-terminal 7 | - ansi-terminal-types 8 | -------------------------------------------------------------------------------- /stack-ghc-9.6.6.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-22.43 # GHC 9.6.6 2 | flags: 3 | ansi-terminal: 4 | example: false 5 | packages: 6 | - ansi-terminal 7 | - ansi-terminal-types 8 | -------------------------------------------------------------------------------- /stack-winio.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-23.2 # GHC 9.8.4 2 | flags: 3 | ansi-terminal: 4 | example: false 5 | packages: 6 | - ansi-terminal 7 | - ansi-terminal-types 8 | ghc-options: 9 | $targets: -with-rtsopts=--io-manager=native 10 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-23.2 # GHC 9.8.4 2 | flags: 3 | ansi-terminal: 4 | example: false 5 | packages: 6 | - ansi-terminal 7 | - ansi-terminal-types 8 | --------------------------------------------------------------------------------