vty 5.28.2 → 6.6
raw patch · 72 files changed
Files
- CHANGELOG.md +391/−0
- LICENSE +2/−0
- README.md +45/−73
- cbits/get_tty_erase.c +0/−18
- cbits/gwinsz.c +0/−9
- cbits/mk_wcwidth.c +19/−6
- cbits/set_term_timing.c +0/−13
- demos/Demo.hs +0/−82
- demos/ModeDemo.hs +0/−55
- src/Codec/Binary/UTF8/Debug.hs +0/−18
- src/Data/Terminfo/Eval.hs +0/−132
- src/Data/Terminfo/Parse.hs +0/−348
- src/Graphics/Vty.hs +97/−74
- src/Graphics/Vty/Attributes.hs +8/−46
- src/Graphics/Vty/Attributes/Color.hs +59/−13
- src/Graphics/Vty/Attributes/Color240.hs +14/−219
- src/Graphics/Vty/Config.hs +122/−163
- src/Graphics/Vty/Debug.hs +8/−3
- src/Graphics/Vty/Debug/Image.hs +0/−32
- src/Graphics/Vty/DisplayAttributes.hs +12/−1
- src/Graphics/Vty/Error.hs +4/−1
- src/Graphics/Vty/Image.hs +29/−33
- src/Graphics/Vty/Image/Internal.hs +23/−64
- src/Graphics/Vty/Inline.hs +7/−11
- src/Graphics/Vty/Inline/Unsafe.hs +0/−59
- src/Graphics/Vty/Input.hs +26/−181
- src/Graphics/Vty/Input/Classify.hs +0/−86
- src/Graphics/Vty/Input/Classify/Parse.hs +0/−58
- src/Graphics/Vty/Input/Classify/Types.hs +0/−19
- src/Graphics/Vty/Input/Events.hs +47/−12
- src/Graphics/Vty/Input/Focus.hs +0/−47
- src/Graphics/Vty/Input/Loop.hs +0/−229
- src/Graphics/Vty/Input/Mouse.hs +0/−161
- src/Graphics/Vty/Input/Paste.hs +0/−49
- src/Graphics/Vty/Input/Terminfo.hs +0/−184
- src/Graphics/Vty/Input/Terminfo/ANSIVT.hs +0/−88
- src/Graphics/Vty/Output.hs +324/−63
- src/Graphics/Vty/Output/Interface.hs +0/−302
- src/Graphics/Vty/Output/Mock.hs +8/−4
- src/Graphics/Vty/Output/TerminfoBased.hs +0/−539
- src/Graphics/Vty/Output/XTermColor.hs +0/−122
- src/Graphics/Vty/Picture.hs +11/−7
- src/Graphics/Vty/PictureToSpans.hs +47/−44
- src/Graphics/Vty/Span.hs +19/−6
- src/Graphics/Vty/UnicodeWidthTable/Main.hs +180/−0
- src/Graphics/Vty/UnicodeWidthTable/Query.hs +12/−21
- test/Verify.hs +0/−89
- test/Verify/Data/Terminfo/Parse.hs +0/−112
- test/Verify/Graphics/Vty/Attributes.hs +0/−73
- test/Verify/Graphics/Vty/DisplayAttributes.hs +0/−8
- test/Verify/Graphics/Vty/Image.hs +0/−218
- test/Verify/Graphics/Vty/Output.hs +0/−59
- test/Verify/Graphics/Vty/Picture.hs +0/−52
- test/Verify/Graphics/Vty/Prelude.hs +0/−24
- test/Verify/Graphics/Vty/Span.hs +0/−37
- test/VerifyConfig.hs +0/−44
- test/VerifyCropSpanGeneration.hs +0/−92
- test/VerifyDisplayAttributes.hs +0/−9
- test/VerifyEmptyImageProps.hs +0/−13
- test/VerifyEvalTerminfoCaps.hs +0/−91
- test/VerifyImageOps.hs +0/−173
- test/VerifyImageTrans.hs +0/−34
- test/VerifyInline.hs +0/−31
- test/VerifyLayersSpanGeneration.hs +0/−130
- test/VerifyOutput.hs +0/−53
- test/VerifyParseTerminfoCaps.hs +0/−100
- test/VerifySimpleSpanGeneration.hs +0/−188
- test/VerifyUsingMockInput.hs +0/−220
- test/VerifyUsingMockTerminal.hs +0/−108
- test/VerifyUtf8Width.hs +0/−30
- tools/BuildWidthTable.hs +0/−144
- vty.cabal +31/−570
CHANGELOG.md view
@@ -1,4 +1,395 @@ +6.6+---++* Added support for horizontal scrolling inputs. The `Button` type in+ `Graphics.Vty.Input.Events` got new constructors `BScrollLeft` and+ `BScrollRight` for Vty backend implementations that support horizontal+ scrolling inputs.++6.5+---++* Raised upper bound on `microlens` dependency to permit builds against+ 0.5.+* Fixed the `utf8-string` dependency lower bound to account for an added+ module in 0.3.1. (#279)+* Improved the allocation behavior of `swapSkipsForSingleColumnCharSpan`.++6.4+---++* Updated the behavior of character width computations when a custom+ character width table has been installed. Now when a custom character+ width table doesn't provide a width for a character, rather than+ defaulting to 1 column, the built-in table is consulted. This change+ shouldn't affect users using width tables generated by `vty-unix`'s+ table-building tool since that tool generates tables that will provide+ widths for all supported characters.++6.3+---++* Raise microlens upper bound to build with 0.4.14 (#278)+* Updated other bounds to permit building with GHC 9.12 (thanks Erik de+ Catro Lopo)+* Removed defunct examples from project++6.2+---++Package changes:+* Update version bounds to support building with GHC 9.8++Bug fixes:+* Updated `PictureToSpans` module to implement its lenses manually to+ avoid template haskell which has trouble on Windows and GHC 9.2 (#271)++6.1+---++API changes:+* `ColorMode` got a `Read` instance.+* The `Config` type got a new `configPreferredColorMode` field for+ specifying a preferred `ColorMode`. Backend packages should respect+ this field, but note that `vty` itself does not (and cannot) enact+ this preference since it's up to the backend driver to configure the+ color mode.+* The Vty configuration file got a new `colorMode` field whose value is+ a string literal compatible with the `ColorMode` `Read` instance.++6.0+---++This release marks the beginning of multi-platform support in Vty.+Getting to this point involved removing Unix-specific functionality+from Vty and moving it to a new package, `vty-unix`. Windows support+is now provided via a `vty-windows` package. Another new package,+`vty-crossplatform`, is provided as a convenience for applications that+want to support both Unix and Windows platforms automatically at build+time. See the migration guide below for details on how to upgrade.++**Migration guide for 6.0**++To upgrade to this version of Vty, most people will only need to take a+few steps:++1. Add a package dependency on `vty-unix`, `vty-windows,` or+ `vty-crossplatform`, depending on the desired level of platform+ support. For example, if an application only supports Unix systems,+ it should depend on `vty-unix`. But if an application is intended to+ work anywhere Vty works, then `vty-crossplatform` is the best choice.+2. Import `mkVty` from the platform package in step (1). (`mkVty` was+ removed from the `vty` package and is now the responsibility of each+ platform package.) Imports are as follows:+ * `vty-unix`: `Graphics.Vty.Platform.Unix`+ * `vty-windows`: `Graphics.Vty.Platform.Windows`+ * `vty-crossplatform`: `Graphics.Vty.CrossPlatform`+3. Maintain any existing package dependency on `vty`; the core library+ abstractions, types, and functions are still obtained from `vty`+ itself. The platform packages do not re-export the core library's+ modules.+4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty+ user configuration since this step is no longer automatic.+5. Some configurations have been moved to `Graphics.Vty.Output`. For + example, `mouseMode` is no longer a field in `VtyUserConfig`. + Instead, use `setMode` to enable it.++For applications using more of Vty's API than just the basic+initialization and rendering API, the full change list is provided+below. For people who want to write their own Vty platform package like+`vty-unix`, see `PLATFORM-HOWTO.md`.++**Detailed change list for 6.0**++* Package changes:+ * The following modules got added to the `vty` library:+ * `Graphics.Vty.UnicodeWidthTable.Main`+ * The following modules got moved to `vty-unix`:+ * `Data.Terminfo.Eval`+ * `Data.Terminfo.Parse`+ * The following modules got moved to `vty-unix` into the+ `Graphics.Vty.Platform.Unix` module namespace (previously+ `Graphics.Vty`):+ * `Graphics.Vty.Input.Classify`+ * `Graphics.Vty.Input.Classify.Parse`+ * `Graphics.Vty.Input.Classify.Types`+ * `Graphics.Vty.Input.Focus`+ * `Graphics.Vty.Input.Loop`+ * `Graphics.Vty.Input.Mouse`+ * `Graphics.Vty.Input.Paste`+ * `Graphics.Vty.Input.Terminfo`+ * `Graphics.Vty.Output.TerminfoBased`+ * `Graphics.Vty.Output.XTermColor`+ * The following modules were removed entirely (with contents migrated+ elsewhere as needed):+ * `Graphics.Vty.Inline.Unsafe`+ * `Graphics.Vty.Output.Interface` (migrated to+ `Graphics.Vty.Output`)+ * Removed library dependencies on the following packages:+ * `ansi-terminal`+ * `containers`+ * `terminfo`+ * `transformers`+ * `unix`+ * The following executables were moved to other packages:+ * `vty-build-width-table` (moved to `vty-unix` as+ `vty-unix-build-width-table`)+ * `vty-mode-demo` (moved to `vty-crossplatform`)+* API changes:+ * `Graphics.Vty.mkVty` moved to the `vty-unix` package's+ `Graphics.Vty.Platform.Unix` module.+ * Added `Graphics.Vty.mkVtyFromPair` for platform packages to+ construct `Vty` handles.+ * The contents of the `Graphics.Vty.Output.Interface` module were+ merged into `Graphics.Vty.Output`.+ * The `vty-build-width-table` tool was removed from the `vty` package,+ but its core functionality is now exposed as a library for+ platform packages to use to provide platform-specific tools using+ `Graphics.Vty.UnicodeWidthTable.Main` and a new tool by the same+ name was added to the `vty-unix` package.+ * `Graphics.Vty.Events`: the `InternalEvent` type's+ `ResumeAfterSignal` constructor was renamed to+ `ResumeAfterInterrupt` to be a bit more abstract and+ platform-agnostic.+ * Removed the following lenses for fields of the `Input` type:+ * `eventChannel` (was for `_eventChannel` which was then renamed to+ `eventChannel`)+ * `configRef` (was for `_configRef` which was then renamed to+ `configRef`)+ * The `Output` record type got a new field, `setOutputWindowTitle`.+ * The `Input` record type got a new field, `inputLogMsg :: String ->+ IO ()`, for logging to the Vty log.+ * `Graphics.Vty.Config` now exposes `VtyUserConfig` instead of+ `Config`. Many of its fields were Unix-specific and were+ consequently moved to the `UnixSettings` type in `vty-unix` and+ given a `settings` prefix. This includes `outputFd`, `inputFd`,+ `vmin`, `vtime`, and `termName`.+ * The `VtyUserConfig` type's fields got a `config` field name prefix.+ * `inputForConfig` was moved to `vty-unix` as `buildInput` but+ generally should not be needed and is exposed only for testing.+ * `outputForConfig` was moved to `vty-unix` as `buildOutput` but+ generally should not be needed and is exposed only for testing.+* Behavior changes:+ * Since `vty` no longer implements `mkVty`, the Vty user configuration+ is no longer implicitly loaded by Vty-based applications.+ Instead, it is now up to the applications to call+ `Graphics.Vty.Config.userConfig` to load any user-provided+ configuration.+ * Vty no longer implicitly attempts to load configured Unicode+ width tables. It is now the responsibility of the platform packages+ (such as `vty-unix`) and/or applications to load tables via+ `Graphics.Vty.UnicodeWidthTable.IO` and install them via+ `Graphics.Vty.UnicodeWidthTable.Install`.+* Changes to demonstration programs:+ * `EventEcho`, `ModeDemo`, and `Rogue` demo programs moved to the+ `vty-crossplatform` package.+* Changes to tests:+ * Where appropriate, some test programs and test cases were moved to+ `vty-unix` or `vty-crossplatform`.++5.39+----++Package changes:+* Now builds with `mtl-2.3.*`.++Bug fixes:+* Fixed a long-standing issue where unused input on stdin could cause a+ memory error and a crash when Vty was being initialized. (#266)++5.38+----++This release includes numerous API changes, although none of them should+break your programs. If so, please open a ticket on the Vty issue+tracker.++Package changes:+* Support mtl 2.3 (thanks Daniel Firth)+* The test and example collections got completely overhauled to clean up+ bit rot.+ * Moved example programs into examples/ under a new vty-examples+ package.+ * Moved test suite programs out of vty.cabal and into tests/ under a+ new vty-tests package.+ * Cleaned up all build-depends lists in all three packages to remove+ unused deps.+ * Consolidated the test suite library modules into the vty-tests+ library to avoid redundant compilation.+ * Added build.sh to build everything in the development process to+ help ensure that examples and tests don't get forgotten.+ * Removeed lots of stale/unused modules in old test/ directory.+* Got vty-examples building again and resolved various warnings and+ issues.++API changes:+* All modules got explicit export lists. Prior to this release, many+ modules exported everything they contained, making it difficult to+ know what was really intended to be part of the public API. The new+ export lists should contain everything that applications need; the+ risk of breakage exists but should be minor. Please open a ticket if+ you were using something that is no longer exported. It might be that+ it was never supposed to be exported to begin with, or it might be+ just something we need to export once again.+* Moved the `attributeControl` function from `Graphics.Vty.Input.Loop`+ to `Graphics.Vty.Input`.+* Removed the `Graphics.Vty.Image.DisplayText` alias for `Text`.+* Unified the `Image` cropping constructors (thanks Fraser Tweedale)++5.37+----++* The Xterm backend is now used when `TERM` matches `rxvt` or `tmux`.+* PictureToSpans now uses `error`, not `fail`, to avoid dependence on+ soon-to-be-removed `MonadFail` instance for `ST` (#248)++5.36+----++ * Raised `microlens` upper bound to allow building with 0.4.13.+ * Replaced incomplete `Show` output for `Picture` with a derived+ instance; derived `Show` for `Cursor` and `Background`, too.++5.35.1+------++Bug fixes:+ * Fixed a build issue with a test program.++5.35+----++New features:+ * Add support for 24-bit color (thanks @u-quark). This change+ updates Vty to look at the `COLORTERM` environment variable that is+ conventionally used to advertise support for truecolor escape+ sequences. The change also updates the Vty demo to demonstrate+ 24-bit colors. This change also adds a new data type, `ColorMode`,+ to represent the color mode in use, as well as an `Output` interface+ field, `outputColorMode`, to track the active color mode and use it+ to clamp emitted color escape sequences to the active color range.++API changes:+ * All types in `Graphics.Vty.Input.Events` now have strict constructor+ fields.+ * Internal events are now wrapped in a new `InternalEvent` type to+ improve how signal handling is done. This change modifies the `Input`+ type's event channel API to produce `InternalEvents`, not `Events`.+ The new `InternalEvent` either wraps `Event` with the `InputEvent`+ constructor (the previous behavior) or indicates that Vty resumed+ after handling a signal using the `ResumeAfterSignal` constructor.+ This change avoids the previous use of `EvResize` with lazy exception+ arguments as a sentinel value for `ResumeAfterSignal`.++Other enhancements:+ * Bracketed paste parsing performance has been greatly improved thanks+ to benchmarking and optimization work by @iphydf. As part of that+ work, Vty now uses bytestrings rather than Strings internally when+ parsing input to look for events.+ * The `\b` value is now interpreted as `KBS` (thanks @vglfr)++5.34+----++API changes:+ * Added an `NFData` instance for `Event` (thanks Mario Lang)+ * Removed `Monoid` and `Semigroup` instances for `Attr` and+ `MaybeDefault`. This change removed the instances because they were+ misbehaved; merging `Attr` and `MaybeDefault` values with these+ instances resulted in field value losses. For example, before this+ change,+```+(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)+```+ would result in just+```+ (defAttr `withBackColor` green)+```+ because the instances were designed to favor the right-hand+ arguments' fields even if they had not been explicitly set+ (a consequence of the `MaybeDefault` `Semigroup` instance).+ While that behavior was sensible specifically in the context of+ `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made+ for surprising instance behavior. Since there is actually no good way+ to handle this in a `Semigroup` instance for `Attr` -- some choices+ have to be made about how to merge two attributes' foreground colors,+ and that won't be much better than what we had -- the instance was+ just removed.+++5.33+----++API changes:+* The `Cursor` type got a new `PositionOnly` constructor for cursor+ placement without visibility.++Package changes:+* Relaxed upper bound for `random`+* Updated `microlens` bounds to allow 0.4.12++Other improvements:+* Various hlint-driven improvements (thanks Willem Van Onsem)+* The implementation of `color240` was improved (thanks (Willem Van+ Onsem)++5.32+----++New features:+ * Meta-PageUp and Meta-PageDown are now supported (#193)+ * Added `supportsItalics` and `supportsStrikethrough` functions to+ check for feature support in terminfo++Bug fixes:+ * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka+ Nkurumeh)++5.31+----++New features and API changes:+ * Added support for strikethrough mode. This change adds a new+ `strikethrough` `Style` value and uses the `smxx` and `rmxx`+ Terminfo capabilities to activate and deactivate strikethrough mode,+ respectively. If the terminfo does not report those capabilities,+ this style is ignored.+ * `Output`: added the `setDisplayBounds` field to set the output+ dimensions of the output handle; added an implementation of this for+ the `TerminfoBased` backend.++Other changes:+ * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.++5.30+----++New features:+ * Added `Graphics.Vty.setWindowTitle` to emit an escape+ sequence to set the window title, provide the terminal emulator+ accepts Xterm-style title sequences. For details, see:+ https://tldp.org/HOWTO/Xterm-Title-3.html++5.29+----++API changes:+ * The Input type got a new field, 'restoreInputState'. This field+ allows the end user to have direct access to the logic needed to+ restore the terminal's input state flags. Prior to having this field,+ this state restoration logic could only be invoked as part of calling+ 'shutdownInput', but since that function does other things (like+ killing threads) it is not advisable to call it repeatedly (which is+ necessary in the use case this change is intended to support). This+ can be called directly to restore the input state flags as needed,+ although this is not required if 'shutdown' (or 'shutdownInput') is+ called.++Other changes:+ * attributeControl: explicitly enable the ICRNL terminal mode flag (see+ #187 and c572ad).+ 5.28.2 ------
LICENSE view
@@ -1,3 +1,5 @@+BSD 3-Clause License+ Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved.
README.md view
@@ -4,49 +4,61 @@ interface for doing terminal I/O. Vty is supported on GHC versions 7.10.1 and up. -Install via `git` with:+`vty` and its partner packages are published on+[Hackage](https://hackage.haskell.org/). The `vty` package works in+concert with one or more *platform packages* to do terminal I/O. Each+platform package provides support for terminal I/O on a specific+platform. Known platform packages are: -```-git clone git://github.com/jtdaugherty/vty.git-```+* [vty-unix](https://github.com/jtdaugherty/vty-unix) - the Unix+ terminal backend for Vty+* [vty-windows](https://github.com/chhackett/vty-windows) - the Windows+ terminal backend for Vty+* [vty-crossplatform](https://github.com/jtdaugherty/vty-crossplatform) -+ a package that builds `vty-unix` or `vty-windows` based on the build+ environment -Install via `cabal` with:+# How to use Vty -```-cabal install vty-```+1. Add a package dependency on `vty-unix`, `vty-windows,` or+ `vty-crossplatform`, depending on the desired level of platform+ support. For example, if an application only supports Unix systems,+ it should depend on `vty-unix`. But if an application is intended to+ work anywhere Vty works, then `vty-crossplatform` is the best choice.+2. Add a package dependency on `vty`; the core library abstractions,+ types, and functions are obtained from `vty` itself. The platform+ packages do not re-export the core library's modules.+3. Import `mkVty` from the platform package in step (1) and use that to+ construct a `Vty` handle and initialize the terminal.+4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty+ user configuration since this step is not automatic. -# Features+Once you've initialized the terminal and have a `Vty` value, all of the+`vty` package's API is now ready to use to do terminal I/O. -* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux,- `screen`, etc., or anything with a sufficient terminfo entry.+# Implementing support for a new platform -* Automatically handles window resizes.+Although this shouldn't be necessary to do very often (if ever!), if+you would like to implement support for a new platform for Vty, see+`PLATFORM-HOWTO.md`. -* Supports Unicode output on terminals with UTF-8 support.+# Features * Provides an efficient output algorithm. Output buffering and terminal state changes are minimized. +* Automatically handles window resizes.+ * Minimizes repaint area, which virtually eliminates the flicker problems that plague ncurses programs. * Provides a pure, compositional interface for efficiently constructing display images. -* Automatically decodes keyboard keys into (key,[modifier]) tuples.- * Automatically supports refresh on Ctrl-L. -* Supports a keypress timeout after for lone ESC. The timeout is- customizable.- * Provides extensible input and output interfaces. -* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`)- with a type-safe interface and graceful fallback for terminals- with limited or nonexistent support for such modes.- * Properly handles cleanup (but not due to signals). * Provides a comprehensive test suite.@@ -68,17 +80,6 @@ Vty uses threads internally, so programs made with Vty need to be compiled with the threaded runtime using the GHC `-threaded` option. -# Platform Support--## Posix Terminals--For the most part, Vty uses `terminfo` to determine terminal protocol-with some special rules to handle some omissions from `terminfo`.--## Windows--Windows is not supported.- # Multi-Column Character Support Vty supports rendering of multi-column characters such as two-column@@ -104,13 +105,11 @@ disagree with your terminal, Vty provides an API and a command-line tool to generate and install custom tables. -Custom Unicode width tables based on your terminal emulator can be-built by running Vty's built-in tool, `vty-build-width-table`. The tool-works by querying the current terminal emulator to obtain its width-measurements for the entire supported Unicode range. The-results are then saved to a disk file. These custom tables-can also be generated programmatically by using the API in-`Graphics.Vty.UnicodeWidthTable.Query`.+Custom Unicode width tables based on your terminal emulator can+be built by using the API in `Graphics.Vty.UnicodeWidthTable`.+The process works by querying the current terminal environment to+obtain its width measurements for the entire supported Unicode+range. The results are then saved to a disk file. Saved width tables can then be loaded in one of two ways: @@ -144,50 +143,23 @@ program. Once a custom table has been loaded, it cannot be replaced or removed. -Without using a custom width table, users of Vty-based applications-are likely to eventually experience rendering problems with with wide-characters. We recommend that developers of Vty-based applications either:--* Provide the `vty-build-width-table` tool and documentation for running- it and updating the Vty configuration, or-* Have the application invoke the Vty library's table-building- functionality and load the table at startup without using the Vty- configuration.--The best option will depend on a number of factors: the user audience,-the amount of risk posed by wide character rendering, the terminal-emulators in use, etc.- # Contributing If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - Patches written completely or partially by AI are unlikely to be+ accepted. Please disclose any AI use. - If you want to take on big things, talk to me first; let's have a design/vision discussion before you start coding. Create a GitHub issue and we can use that as the place to hash things out. - If you make changes, make them consistent with the syntactic conventions already used in the codebase. - Please provide Haddock documentation for any changes you make.--# Known Issues--* Terminals have numerous quirks and bugs, so mileage may vary. Please- report issues as you encounter them and provide details on your- terminal emulator, operating system, etc.--* STOP, TERM and INT signals are not handled.--* The character encoding of the terminal is assumed to be UTF-8 if- unicode is used.--* Terminfo is assumed to be correct unless there is an override- configured. Some terminals will not have correct special key support- (shifted F10 etc). See `Config` for customizing vty's behavior for a- particular terminal.--* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which- appears to be limited to Linux and BSD.+ - Please do NOT include package version changes in your patches.+ Package version changes are only done at release time when the full+ scope of a release's changes can be evaluated to determine the+ appropriate version change. # Further Reading
− cbits/get_tty_erase.c
@@ -1,18 +0,0 @@-#include <termios.h>-#include <stdio.h>-#include <unistd.h>-#include <stdlib.h>--// Given a file descriptor for a terminal, get the ERASE character for-// the terminal. If the terminal info cannot be obtained, this returns-// zero.-char vty_get_tty_erase(int fd)-{- struct termios trm;-- if (0 == tcgetattr(fd, &trm)) {- return (char) trm.c_cc[VERASE];- } else {- return (char) 0;- }-}
− cbits/gwinsz.c
@@ -1,9 +0,0 @@-#include <sys/ioctl.h>--unsigned long vty_c_get_window_size(int fd) {- struct winsize w;- if (ioctl (fd, TIOCGWINSZ, &w) >= 0)- return (w.ws_row << 16) + w.ws_col;- else- return 0x190050;-}
cbits/mk_wcwidth.c view
@@ -72,6 +72,9 @@ // built-in tree search logic is used. static uint8_t* custom_table = NULL; +// Unused table cell value.+static uint8_t UNUSED_CELL = 0xff;+ // The size of the custom table, in entries. This should only be set // if custom_table is not NULL. Its value should be the size of the // custom_table array.@@ -228,14 +231,24 @@ // Return the width, in terminal cells, of the specified character. // // If the global custom width table is present, that table will be-// consulted for the character's width. If the character is not in-// the table, zero will be returned. If the custom width table is not-// present, the built-in width table will be used.+// consulted for the character's width. If the character is not in the+// table, this will fall back to the built-in table. If the character is+// in neither table, zero will be returned. If the custom width table is+// not present, the built-in width table will be used. HsInt vty_mk_wcwidth(HsChar ch) { if (custom_table_ready) { if ((ch >= 0) && (ch < custom_table_size)) {- return custom_table[ch];+ uint8_t result = custom_table[ch];++ // The table is filled with UNUSED_CELL values for+ // uninitialized ranges so we can defer to the built-in+ // table in those cases.+ if (result == UNUSED_CELL) {+ return builtin_wcwidth(ch);+ } else {+ return result;+ } } else { return -1; }@@ -249,7 +262,7 @@ // This allocates a new character width table of the specified size // (in characters). If a custom table has already been allocated, this // returns 1. Otherwise it allocates a new table, initializes all of its-// entries to 1, and returns zero.+// entries to UNUSED_CELL, and returns zero. // // Note that this does *not* mark the table as ready for use. Until the // table is marked ready, it will not be used by vty_mk_wcwidth. To mark@@ -261,7 +274,7 @@ if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) { custom_table_ready = 0; custom_table = malloc(size);- memset(custom_table, 1, size);+ memset(custom_table, UNUSED_CELL, size); custom_table_size = size; return 0; } else {
− cbits/set_term_timing.c
@@ -1,13 +0,0 @@-#include <termios.h>-#include <stdio.h>-#include <unistd.h>-#include <stdlib.h>--void vty_set_term_timing(int fd, int vmin, int vtime)-{- struct termios trm;- tcgetattr(fd, &trm);- trm.c_cc[VMIN] = vmin;- trm.c_cc[VTIME] = vtime;- tcsetattr(fd, TCSANOW, &trm);-}
− demos/Demo.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Main where--import Graphics.Vty--import Control.Applicative hiding ((<|>))-import Control.Arrow-import Control.Monad.RWS--import Data.Sequence (Seq, (<|) )-import qualified Data.Sequence as Seq-import Data.Foldable--eventBufferSize = 1000--type App = RWST Vty () (Seq String) IO--main = do- vty <- if True -- change to false for emacs-like input processing- then mkVty defaultConfig- else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } )- _ <- execRWST (vtyInteract False) vty Seq.empty- shutdown vty--vtyInteract :: Bool -> App ()-vtyInteract shouldExit = do- updateDisplay- unless shouldExit $ handleNextEvent >>= vtyInteract--introText = vertCat $ map (string defAttr)- [ "this line is hidden by the top layer"- , "The vty demo program will echo the events generated by the pressed keys."- , "Below there is a 240 color box."- , "Followed by a description of the 16 color pallete."- , "If the 240 color box is not visible then the terminal"- , "claims 240 colors are not supported."- , "Try setting TERM to xterm-256color"- , "This text is on a lower layer than the event list."- , "Which means it'll be hidden soon."- , "Bye!"- , "Great Faith in the ¯\\_(ツ)_/¯"- , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"- ]--colorbox_240 :: Image-colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages- where- colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]- splitColorImages [] = []- splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))--colorbox_16 :: Image-colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border- where- column0 = vertCat $ map lineWithColor normal- column1 = vertCat $ map lineWithColor bright- border = vertCat $ replicate (length normal) $ string defAttr " | "- column2 = vertCat $ map (string defAttr . snd) normal- lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName- normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ]- [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]- bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue- , brightMagenta, brightCyan, brightWhite ]- [ "bright black", "bright red", "bright green", "bright yellow"- , "bright blue", "bright magenta", "bright cyan", "bright white" ]--updateDisplay :: App ()-updateDisplay = do- let info = string (defAttr `withForeColor` black `withBackColor` green)- "Press ESC to exit. Events for keys below."- eventLog <- foldMap (string defAttr) <$> get- let pic = picForImage (info <-> eventLog)- `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)- vty <- ask- liftIO $ update vty pic--handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent- where- handleEvent e = do- modify $ (<|) (show e) >>> Seq.take eventBufferSize- return $ e == EvKey KEsc []-
− demos/ModeDemo.hs
@@ -1,55 +0,0 @@-module Main where--import Control.Applicative-import Data.Monoid-import Foreign.C.Types (CInt(..), CChar(..))-import System.Posix.Types (Fd(..))--import Graphics.Vty--mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image-mkUI (m, ms, p, ps) e =- vertCat [ string defAttr $ "Mouse mode supported: " <> show m- , string defAttr $ "Mouse mode status: " <> show ms- , string defAttr " "- , string defAttr $ "Paste mode supported: " <> show p- , string defAttr $ "Paste mode status: " <> show ps- , string defAttr " "- , string defAttr $ "Last event: " <> show e- , string defAttr " "- , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit."- ]--main :: IO ()-main = do- cfg <- standardIOConfig- vty <- mkVty cfg-- let renderUI lastE = do- let output = outputIface vty- info <- (,,,) <$> (pure $ supportsMode output Mouse)- <*> getModeStatus output Mouse- <*> (pure $ supportsMode output BracketedPaste)- <*> getModeStatus output BracketedPaste- return $ picForImage $ mkUI info lastE-- let go lastE = do- pic <- renderUI lastE- update vty pic- e <- nextEvent vty- case e of- EvKey (KChar 'q') [] -> return ()- EvKey (KChar 'm') [] -> do- let output = outputIface vty- enabled <- getModeStatus output Mouse- setMode output Mouse (not enabled)- go (Just e)- EvKey (KChar 'p') [] -> do- let output = outputIface vty- enabled <- getModeStatus output BracketedPaste- setMode output BracketedPaste (not enabled)- go (Just e)- _ -> go (Just e)-- go Nothing- shutdown vty
− src/Codec/Binary/UTF8/Debug.hs
@@ -1,18 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- Copyright 2009 Corey O'Connor-module Codec.Binary.UTF8.Debug where--import Codec.Binary.UTF8.String ( encode )--import Data.Word--import Numeric---- | Converts an array of ISO-10646 characters (Char type) to an array--- of Word8 bytes that is the corresponding UTF8 byte sequence-utf8FromIso :: [Int] -> [Word8]-utf8FromIso = encode . map toEnum--ppUtf8 :: [Int] -> IO ()-ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso-
− src/Data/Terminfo/Eval.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK hide #-}---- | Evaluates the paramaterized terminfo string capability with the--- given parameters.-module Data.Terminfo.Eval- ( writeCapExpr- )-where--import Blaze.ByteString.Builder.Word-import Blaze.ByteString.Builder-import Data.Terminfo.Parse--import Control.Monad.Identity-import Control.Monad.State.Strict-import Control.Monad.Writer--import Data.Bits ((.|.), (.&.), xor)-import Data.List--import qualified Data.Vector.Unboxed as Vector---- | capability evaluator state-data EvalState = EvalState- { evalStack :: ![CapParam]- , evalExpression :: !CapExpression- , evalParams :: ![CapParam]- }--type Eval a = StateT EvalState (Writer Write) a--pop :: Eval CapParam-pop = do- s <- get- let v : stack' = evalStack s- s' = s { evalStack = stack' }- put s'- return v--readParam :: Word -> Eval CapParam-readParam pn = do- !params <- get >>= return . evalParams- return $! genericIndex params pn--push :: CapParam -> Eval ()-push !v = do- s <- get- let s' = s { evalStack = v : evalStack s }- put s'--applyParamOps :: CapExpression -> [CapParam] -> [CapParam]-applyParamOps cap params = foldl applyParamOp params (paramOps cap)--applyParamOp :: [CapParam] -> ParamOp -> [CapParam]-applyParamOp params IncFirstTwo = map (+ 1) params--writeCapExpr :: CapExpression -> [CapParam] -> Write-writeCapExpr cap params =- let params' = applyParamOps cap params- s0 = EvalState [] cap params'- in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)--writeCapOps :: CapOps -> Eval ()-writeCapOps ops = mapM_ writeCapOp ops--writeCapOp :: CapOp -> Eval ()-writeCapOp (Bytes !offset !count) = do- !cap <- get >>= return . evalExpression- let bytes = Vector.take count $ Vector.drop offset (capBytes cap)- Vector.forM_ bytes $ tell.writeWord8-writeCapOp DecOut = do- p <- pop- forM_ (show p) $ tell.writeWord8.toEnum.fromEnum-writeCapOp CharOut = do- pop >>= tell.writeWord8.toEnum.fromEnum-writeCapOp (PushParam pn) = do- readParam pn >>= push-writeCapOp (PushValue v) = do- push v-writeCapOp (Conditional expr parts) = do- writeCapOps expr- writeContitionalParts parts- where- writeContitionalParts [] = return ()- writeContitionalParts ((trueOps, falseOps) : falseParts) = do- -- (man 5 terminfo)- -- Usually the %? expr part pushes a value onto the stack,- -- and %t pops it from the stack, testing if it is nonzero- -- (true). If it is zero (false), control passes to the %e- -- (else) part.- v <- pop- if v /= 0- then writeCapOps trueOps- else do- writeCapOps falseOps- writeContitionalParts falseParts--writeCapOp BitwiseOr = do- v0 <- pop- v1 <- pop- push $ v0 .|. v1-writeCapOp BitwiseAnd = do- v0 <- pop- v1 <- pop- push $ v0 .&. v1-writeCapOp BitwiseXOr = do- v1 <- pop- v0 <- pop- push $ v0 `xor` v1-writeCapOp ArithPlus = do- v1 <- pop- v0 <- pop- push $ v0 + v1-writeCapOp ArithMinus = do- v1 <- pop- v0 <- pop- push $ v0 - v1-writeCapOp CompareEq = do- v1 <- pop- v0 <- pop- push $ if v0 == v1 then 1 else 0-writeCapOp CompareLt = do- v1 <- pop- v0 <- pop- push $ if v0 < v1 then 1 else 0-writeCapOp CompareGt = do- v1 <- pop- v0 <- pop- push $ if v0 > v1 then 1 else 0
− src/Data/Terminfo/Parse.hs
@@ -1,348 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS_GHC -funbox-strict-fields -O #-}--module Data.Terminfo.Parse- ( module Data.Terminfo.Parse- , Text.Parsec.ParseError- )-where--import Control.Monad ( liftM )-import Control.DeepSeq--#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup(..))-#endif-import Data.Word-import qualified Data.Vector.Unboxed as Vector--import Numeric (showHex)--import Text.Parsec--data CapExpression = CapExpression- { capOps :: !CapOps- , capBytes :: !(Vector.Vector Word8)- , sourceString :: !String- , paramCount :: !Int- , paramOps :: !ParamOps- } deriving (Eq)--instance Show CapExpression where- show c- = "CapExpression { " ++ show (capOps c) ++ " }"- ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]"- ++ " <= " ++ show (sourceString c)- where- hexDump :: [Word8] -> String- hexDump = foldr (\b s -> showHex b s) ""--instance NFData CapExpression where- rnf (CapExpression ops !_bytes !str !c !pOps)- = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps--type CapParam = Word--type CapOps = [CapOp]-data CapOp =- Bytes !Int !Int -- offset count- | DecOut | CharOut- -- This stores a 0-based index to the parameter. However the- -- operation that implies this op is 1-based- | PushParam !Word | PushValue !Word- -- The conditional parts are the sequence of (%t expression, %e- -- The expression) pairs. %e expression may be NOP- | Conditional- { conditionalExpr :: !CapOps- , conditionalParts :: ![(CapOps, CapOps)]- }- | BitwiseOr | BitwiseXOr | BitwiseAnd- | ArithPlus | ArithMinus- | CompareEq | CompareLt | CompareGt- deriving (Show, Eq)--instance NFData CapOp where- rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount- rnf (PushParam pn) = rnf pn- rnf (PushValue v) = rnf v- rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts- rnf BitwiseOr = ()- rnf BitwiseXOr = ()- rnf BitwiseAnd = ()- rnf ArithPlus = ()- rnf ArithMinus = ()- rnf CompareEq = ()- rnf CompareLt = ()- rnf CompareGt = ()- rnf DecOut = ()- rnf CharOut = ()--type ParamOps = [ParamOp]-data ParamOp =- IncFirstTwo- deriving (Show, Eq)--instance NFData ParamOp where- rnf IncFirstTwo = ()--parseCapExpression :: String -> Either ParseError CapExpression-parseCapExpression capString =- let v = runParser capExpressionParser- initialBuildState- "terminfo cap"- capString- in case v of- Left e -> Left e- Right buildResults -> Right $ constructCapExpression capString buildResults--constructCapExpression :: [Char] -> BuildResults -> CapExpression-constructCapExpression capString buildResults =- let expr = CapExpression- { capOps = outCapOps buildResults- -- The cap bytes are the lower 8 bits of the input- -- string's characters.- , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString- , sourceString = capString- , paramCount = outParamCount buildResults- , paramOps = outParamOps buildResults- }- in rnf expr `seq` expr--type CapParser a = Parsec String BuildState a--capExpressionParser :: CapParser BuildResults-capExpressionParser = do- rs <- many $ paramEscapeParser <|> bytesOpParser- return $ mconcat rs--paramEscapeParser :: CapParser BuildResults-paramEscapeParser = do- _ <- char '%'- incOffset 1- literalPercentParser <|> paramOpParser--literalPercentParser :: CapParser BuildResults-literalPercentParser = do- _ <- char '%'- startOffset <- getState >>= return . nextOffset- incOffset 1- return $ BuildResults 0 [Bytes startOffset 1] []--paramOpParser :: CapParser BuildResults-paramOpParser- = incrementOpParser- <|> pushOpParser- <|> decOutParser- <|> charOutParser- <|> conditionalOpParser- <|> bitwiseOpParser- <|> arithOpParser- <|> literalIntOpParser- <|> compareOpParser- <|> charConstParser--incrementOpParser :: CapParser BuildResults-incrementOpParser = do- _ <- char 'i'- incOffset 1- return $ BuildResults 0 [] [ IncFirstTwo ]--pushOpParser :: CapParser BuildResults-pushOpParser = do- _ <- char 'p'- paramN <- digit >>= return . (\d -> read [d])- incOffset 2- return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []--decOutParser :: CapParser BuildResults-decOutParser = do- _ <- char 'd'- incOffset 1- return $ BuildResults 0 [ DecOut ] []--charOutParser :: CapParser BuildResults-charOutParser = do- _ <- char 'c'- incOffset 1- return $ BuildResults 0 [ CharOut ] []--conditionalOpParser :: CapParser BuildResults-conditionalOpParser = do- _ <- char '?'- incOffset 1- condPart <- manyExpr conditionalTrueParser- parts <- manyP- ( do- truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser- , conditionalFalseParser- ]- falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser- , conditionalTrueParser- ]- return ( truePart, falsePart )- )- conditionalEndParser-- let trueParts = map fst parts- falseParts = map snd parts- BuildResults n cond condParamOps = condPart-- let n' = maximum $ n : map outParamCount trueParts- n'' = maximum $ n' : map outParamCount falseParts-- let trueOps = map outCapOps trueParts- falseOps = map outCapOps falseParts- condParts = zip trueOps falseOps-- let trueParamOps = mconcat $ map outParamOps trueParts- falseParamOps = mconcat $ map outParamOps falseParts- pOps = mconcat [condParamOps, trueParamOps, falseParamOps]-- return $ BuildResults n'' [ Conditional cond condParts ] pOps-- where- manyP !p !end = choice- [ try end >> return []- , do !v <- p- !vs <- manyP p end- return $! v : vs- ]- manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end--conditionalTrueParser :: CapParser ()-conditionalTrueParser = do- _ <- string "%t"- incOffset 2--conditionalFalseParser :: CapParser ()-conditionalFalseParser = do- _ <- string "%e"- incOffset 2--conditionalEndParser :: CapParser ()-conditionalEndParser = do- _ <- string "%;"- incOffset 2--bitwiseOpParser :: CapParser BuildResults-bitwiseOpParser- = bitwiseOrParser- <|> bitwiseAndParser- <|> bitwiseXorParser--bitwiseOrParser :: CapParser BuildResults-bitwiseOrParser = do- _ <- char '|'- incOffset 1- return $ BuildResults 0 [ BitwiseOr ] [ ]--bitwiseAndParser :: CapParser BuildResults-bitwiseAndParser = do- _ <- char '&'- incOffset 1- return $ BuildResults 0 [ BitwiseAnd ] [ ]--bitwiseXorParser :: CapParser BuildResults-bitwiseXorParser = do- _ <- char '^'- incOffset 1- return $ BuildResults 0 [ BitwiseXOr ] [ ]--arithOpParser :: CapParser BuildResults-arithOpParser- = plusOp- <|> minusOp- where- plusOp = do- _ <- char '+'- incOffset 1- return $ BuildResults 0 [ ArithPlus ] [ ]- minusOp = do- _ <- char '-'- incOffset 1- return $ BuildResults 0 [ ArithMinus ] [ ]--literalIntOpParser :: CapParser BuildResults-literalIntOpParser = do- _ <- char '{'- incOffset 1- nStr <- many1 digit- incOffset $ toEnum $ length nStr- let n :: Word = read nStr- _ <- char '}'- incOffset 1- return $ BuildResults 0 [ PushValue n ] [ ]--compareOpParser :: CapParser BuildResults-compareOpParser- = compareEqOp- <|> compareLtOp- <|> compareGtOp- where- compareEqOp = do- _ <- char '='- incOffset 1- return $ BuildResults 0 [ CompareEq ] [ ]- compareLtOp = do- _ <- char '<'- incOffset 1- return $ BuildResults 0 [ CompareLt ] [ ]- compareGtOp = do- _ <- char '>'- incOffset 1- return $ BuildResults 0 [ CompareGt ] [ ]--bytesOpParser :: CapParser BuildResults-bytesOpParser = do- bytes <- many1 $ satisfy (/= '%')- startOffset <- getState >>= return . nextOffset- let !c = length bytes- !s <- getState- let s' = s { nextOffset = startOffset + c }- setState s'- return $ BuildResults 0 [Bytes startOffset c] []--charConstParser :: CapParser BuildResults-charConstParser = do- _ <- char '\''- charValue <- liftM (toEnum . fromEnum) anyChar- _ <- char '\''- incOffset 3- return $ BuildResults 0 [ PushValue charValue ] [ ]--data BuildState = BuildState- { nextOffset :: Int- }--incOffset :: Int -> CapParser ()-incOffset n = do- s <- getState- let s' = s { nextOffset = nextOffset s + n }- setState s'--initialBuildState :: BuildState-initialBuildState = BuildState 0--data BuildResults = BuildResults- { outParamCount :: !Int- , outCapOps :: !CapOps- , outParamOps :: !ParamOps- }--instance Semigroup BuildResults where- v0 <> v1- = BuildResults- { outParamCount = (outParamCount v0) `max` (outParamCount v1)- , outCapOps = (outCapOps v0) <> (outCapOps v1)- , outParamOps = (outParamOps v0) <> (outParamOps v1)- }--instance Monoid BuildResults where- mempty = BuildResults 0 [] []-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif
src/Graphics/Vty.hs view
@@ -1,43 +1,51 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Vty provides interfaces for both terminal input and terminal -- output. ----- - Input to the terminal is provided to the Vty application as a+-- - User input to the terminal is provided to the Vty application as a -- sequence of 'Event's. ----- - Output is provided to Vty by the application in the form of a+-- - Output is provided to by the application to Vty in the form of a -- 'Picture'. A 'Picture' is one or more layers of 'Image's. -- 'Image' values can be built by the various constructors in -- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute) -- values in the "Graphics.Vty.Attributes" module. ----- Vty uses threads internally, so programs made with Vty need to be--- compiled with the threaded runtime using the GHC @-threaded@ option.+-- - Each platform on which Vty is supported provides a package that+-- provides Vty with access to the platform-specific terminal+-- interface. For example, on Unix systems, the @vty-unix@ package+-- must be used to initialize Vty with access to a Unix terminal. ----- @--- import "Graphics.Vty"+-- As a small example, the following program demonstrates the use of Vty+-- on a Unix system using the @vty-unix@ package: ----- main = do--- cfg <- 'standardIOConfig'--- vty <- 'mkVty' cfg--- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\"--- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\"--- img = line0 '<->' line1--- pic = 'picForImage' img--- 'update' vty pic--- e <- 'nextEvent' vty--- 'shutdown' vty--- 'print' (\"Last event was: \" '++' 'show' e)--- @+-- > import Graphics.Vty+-- > import Graphics.Vty.Platform.Unix (mkVty)+-- >+-- > main = do+-- > vty <- mkVty defaultConfig+-- > let line0 = string (defAttr `withForeColor` green) "first line"+-- > line1 = string (defAttr `withBackColor` blue) "second line"+-- > img = line0 <-> line1+-- > pic = picForImage img+-- > update vty pic+-- > e <- nextEvent vty+-- > shutdown vty+-- > print ("Last event was: " ++ show e)+--+-- Vty uses threads internally, so programs made with Vty must be+-- compiled with the threaded runtime using the GHC @-threaded@ option. module Graphics.Vty ( Vty(..)- , mkVty- , Mode(..)+ , setWindowTitle+ , installCustomWidthTable+ , mkVtyFromPair , module Graphics.Vty.Config , module Graphics.Vty.Input+ , module Graphics.Vty.Input.Events , module Graphics.Vty.Output- , module Graphics.Vty.Output.Interface , module Graphics.Vty.Picture , module Graphics.Vty.Image , module Graphics.Vty.Attributes@@ -46,8 +54,8 @@ import Graphics.Vty.Config import Graphics.Vty.Input+import Graphics.Vty.Input.Events import Graphics.Vty.Output-import Graphics.Vty.Output.Interface import Graphics.Vty.Picture import Graphics.Vty.Image import Graphics.Vty.Attributes@@ -63,26 +71,28 @@ import Data.Semigroup ((<>)) #endif --- | A Vty value represents a handle to the Vty library that the+-- | A 'Vty' value represents a handle to the Vty library that the -- application must create in order to use Vty. ----- The use of Vty typically follows this process:+-- The use of this library typically follows this process: ----- 1. Initialize vty with 'mkVty' (this takes control of the terminal).+-- 1. Initialize Vty with the 'mkVty' implementation for your+-- platform's Vty package (e.g. @vty-unix@), or, more generically, with+-- 'mkVtyFromPair'. This takes control of (and sets up) the terminal. ----- 2. Use 'update' to display a picture.+-- 2. Use 'update' to display a picture. ----- 3. Use 'nextEvent' to get the next input event.+-- 3. Use 'nextEvent' to get the next input event. ----- 4. Depending on the event, go to 2 or 5.+-- 4. Depending on the event, go to 2 or 5. ----- 5. Shutdown vty and restore the terminal state with 'shutdown'. At--- this point the 'Vty' handle cannot be used again.+-- 5. Shutdown Vty and restore the terminal state with 'shutdown'. At+-- this point the 'Vty' handle cannot be used again. -- -- Operations on Vty handles are not thread-safe. data Vty = Vty { update :: Picture -> IO ()- -- ^ Outputs the given 'Picture'.+ -- ^ Output the given 'Picture' to the terminal. , nextEvent :: IO Event -- ^ Return the next 'Event' or block until one becomes -- available.@@ -104,41 +114,42 @@ , isShutdown :: IO Bool } --- | Create a Vty handle. At most one handle should be created at a time--- for a given terminal device.------ The specified configuration is added to the the configuration--- loaded by 'userConfig' with the 'userConfig' configuration taking--- precedence. See "Graphics.Vty.Config".+-- | Attempt to load and install a custom character width table into+-- this process. ----- For most applications @mkVty defaultConfig@ is sufficient.-mkVty :: Config -> IO Vty-mkVty appConfig = do- config <- (<> appConfig) <$> userConfig-- when (allowCustomUnicodeWidthTables config /= Just False) $- installCustomWidthTable config-- input <- inputForConfig config- out <- outputForConfig config- internalMkVty input out--installCustomWidthTable :: Config -> IO ()-installCustomWidthTable c = do- let doLog s = case debugLog c of- Nothing -> return ()- Just path -> appendFile path $ "installWidthTable: " <> s <> "\n"+-- This looks up the specified terminal name in the specified width+-- table map and, if a map file path is found, the map is loaded and+-- installed. This is exposed for Vty platform package implementors;+-- application developers should never need to call this.+installCustomWidthTable :: Maybe FilePath+ -- ^ Optional path to a log file where log+ -- messages should be written when attempting to+ -- load a width table.+ -> Maybe String+ -- ^ Optional width table entry name (usually+ -- the terminal name, e.g. value of @TERM@ on+ -- Unix systems). If omitted, this function does+ -- not attempt to load a table.+ -> [(String, FilePath)]+ -- ^ Mapping from width table entry names to+ -- width table file paths. This is usually+ -- obtained from 'configTermWidthMaps' of+ -- 'VtyUserConfig'.+ -> IO ()+installCustomWidthTable logPath tblName widthMaps = do+ let doLog s = case logPath of+ Nothing -> return ()+ Just path -> appendFile path $ "installWidthTable: " <> s <> "\n" customInstalled <- isCustomTableReady when (not customInstalled) $ do- mTerm <- currentTerminalName- case mTerm of+ case tblName of Nothing ->- doLog "No current terminal name available"- Just currentTerm ->- case lookup currentTerm (termWidthMaps c) of+ doLog "No terminal name given in the configuration, skipping load"+ Just name ->+ case lookup name widthMaps of Nothing ->- doLog "Current terminal not found in custom character width mapping list"+ doLog $ "Width table " <> show name <> " not found in custom character width mapping list" Just path -> do tableResult <- E.try $ readUnicodeWidthTable path case tableResult of@@ -158,11 +169,16 @@ doLog $ "Successfully installed Unicode width table " <> " from " <> show path -internalMkVty :: Input -> Output -> IO Vty-internalMkVty input out = do+-- | Build a 'Vty' handle from an input/output pair.+--+-- This is exposed for Vty platform package implementors; application+-- developers should never need to call this, and should instead call+-- @mkVty@ or equivalent from their platform package of choice.+mkVtyFromPair :: Input -> Output -> IO Vty+mkVtyFromPair input out = do reserveDisplay out - shutdownVar <- atomically $ newTVar False+ shutdownVar <- newTVarIO False let shutdownIo = do alreadyShutdown <- atomically $ swapTVar shutdownVar True when (not alreadyShutdown) $ do@@ -170,7 +186,7 @@ releaseDisplay out releaseTerminal out - let shutdownStatus = atomically $ readTVar shutdownVar+ shutdownStatus = readTVarIO shutdownVar lastPicRef <- newIORef Nothing lastUpdateRef <- newIORef Nothing@@ -195,7 +211,7 @@ writeIORef lastUpdateRef $ Just updateData writeIORef lastPicRef $ Just inPic - let innerRefresh = do+ innerRefresh = do writeIORef lastUpdateRef Nothing bounds <- displayBounds out dc <- displayContext out bounds@@ -203,17 +219,19 @@ mPic <- readIORef lastPicRef maybe (return ()) innerUpdate mPic - let mkResize = uncurry EvResize <$> displayBounds out+ mkResize = uncurry EvResize <$> displayBounds out++ translateInternalEvent ResumeAfterInterrupt = mkResize+ translateInternalEvent (InputEvent e) = return e+ gkey = do- k <- atomically $ readTChan $ _eventChannel input- case k of- (EvResize _ _) -> mkResize- _ -> return k+ e <- atomically $ readTChan $ eventChannel input+ translateInternalEvent e gkey' = do- k <- atomically $ tryReadTChan $ _eventChannel input- case k of- (Just (EvResize _ _)) -> Just <$> mkResize- _ -> return k+ mEv <- atomically $ tryReadTChan $ eventChannel input+ case mEv of+ Just e -> Just <$> translateInternalEvent e+ Nothing -> return Nothing return $ Vty { update = innerUpdate , nextEvent = gkey@@ -224,3 +242,8 @@ , shutdown = shutdownIo , isShutdown = shutdownStatus }++-- | Set the terminal window title string.+setWindowTitle :: Vty -> String -> IO ()+setWindowTitle vty title =+ setOutputWindowTitle (outputIface vty) title
src/Graphics/Vty/Attributes.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} @@ -43,6 +40,7 @@ , withStyle , standout , italic+ , strikethrough , underline , reverseVideo , blink@@ -63,9 +61,6 @@ import Control.DeepSeq import Data.Bits-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup-#endif import Data.Text (Text) import Data.Word import GHC.Generics@@ -118,19 +113,6 @@ -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits. -instance Semigroup Attr where- attr0 <> attr1 =- Attr ( attrStyle attr0 <> attrStyle attr1 )- ( attrForeColor attr0 <> attrForeColor attr1 )- ( attrBackColor attr0 <> attrBackColor attr1 )- ( attrURL attr0 <> attrURL attr1 )--instance Monoid Attr where- mempty = Attr mempty mempty mempty mempty-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif- -- | Specifies the display attributes such that the final style and -- color values do not depend on the previously applied display -- attribute. The display attributes can still depend on the terminal's@@ -145,43 +127,20 @@ -- | The style and color attributes can either be the terminal defaults. -- Or be equivalent to the previously applied style. Or be a specific -- value.-data MaybeDefault v where- Default :: MaybeDefault v- KeepCurrent :: MaybeDefault v- SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v+data MaybeDefault v = Default | KeepCurrent | SetTo !v+ deriving (Eq, Read, Show) instance (NFData v) => NFData (MaybeDefault v) where rnf Default = () rnf KeepCurrent = () rnf (SetTo v) = rnf v -deriving instance Eq v => Eq (MaybeDefault v)-deriving instance Eq v => Show (MaybeDefault v)-deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)--instance Eq v => Semigroup (MaybeDefault v) where- Default <> Default = Default- Default <> KeepCurrent = Default- Default <> SetTo v = SetTo v- KeepCurrent <> Default = Default- KeepCurrent <> KeepCurrent = KeepCurrent- KeepCurrent <> SetTo v = SetTo v- SetTo _v <> Default = Default- SetTo v <> KeepCurrent = SetTo v- SetTo _ <> SetTo v = SetTo v--instance Eq v => Monoid ( MaybeDefault v ) where- mempty = KeepCurrent-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif- -- | Styles are represented as an 8 bit word. Each bit in the word is 1 -- if the style attribute assigned to that bit should be applied and 0 -- if the style attribute should not be applied. type Style = Word8 --- | The 7 possible style attributes:+-- | Valid style attributes include: -- -- * standout --@@ -197,9 +156,11 @@ -- -- * italic --+-- * strikethrough (via the smxx/rmxx terminfo capabilities)+-- -- (The invisible, protect, and altcharset display attributes some -- terminals support are not supported via VTY.)-standout, underline, reverseVideo, blink, dim, bold, italic :: Style+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style standout = 0x01 underline = 0x02 reverseVideo = 0x04@@ -207,6 +168,7 @@ dim = 0x10 bold = 0x20 italic = 0x40+strikethrough = 0x80 defaultStyleMask :: Style defaultStyleMask = 0x00
src/Graphics/Vty/Attributes/Color.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Attributes.Color ( Color(..)+ , ColorMode(..) -- ** Fixed Colors -- | Standard 8-color ANSI terminal color codes.@@ -32,7 +35,10 @@ , brightCyan , brightWhite -- ** Creating Colors From RGB+ , linearColor+ , srgbColor , rgbColor+ , color240 , module Graphics.Vty.Attributes.Color240 ) where@@ -58,21 +64,21 @@ -- -- The 8 ISO 6429 (ANSI) colors are as follows: ----- 0. black+-- * black (0) ----- 1. red+-- * red (1) ----- 2. green+-- * green (2) ----- 3. yellow+-- * yellow (3) ----- 4. blue+-- * blue (4) ----- 5. magenta+-- * magenta (5) ----- 6. cyan+-- * cyan (6) ----- 7. white+-- * white (7) -- -- The mapping from points in the 240 color palette to colors actually -- displayable by the terminal depends on the number of colors the@@ -81,7 +87,7 @@ -- reported then the color reproduction will be incorrect. -- -- If the terminal reports <= 16 colors then the 240 color palette--- points are only mapped to the 8 color pallete. I'm not sure of+-- points are only mapped to the 8 color palette. I'm not sure of -- the RGB points for the "bright" colors which is why they are not -- addressable via the 240 color palette. --@@ -95,9 +101,17 @@ -- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE.-data Color = ISOColor !Word8 | Color240 !Word8+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8 deriving ( Eq, Show, Read, Generic, NFData ) +data ColorMode+ = NoColor+ | ColorMode8+ | ColorMode16+ | ColorMode240 !Word8+ | FullColor+ deriving ( Eq, Show, Read )+ black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 red = ISOColor 1@@ -119,9 +133,41 @@ brightCyan = ISOColor 14 brightWhite = ISOColor 15 +-- | Create a color value from RGB values in the 0..255 range inclusive.+-- No transformation of the input values is done; a color is created+-- directly from the RGB values specified, unlike the 'srgbColor' and+-- 'color240' functions.+linearColor :: Integral i => i -> i -> i -> Color+linearColor r g b = RGBColor r' g' b'+ where+ r' = fromIntegral (clamp r) :: Word8+ g' = fromIntegral (clamp g) :: Word8+ b' = fromIntegral (clamp b) :: Word8+ clamp = min 255 . max 0 +-- | Given RGB values in the range 0..255 inclusive, create a color+-- using the sRGB transformation described at+--+-- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation+srgbColor :: Integral i => i -> i -> i -> Color+srgbColor r g b =+ -- TODO: it may be worth translating this to a lookup table, as with color240+ let shrink n = fromIntegral n / 255 :: Double+ -- called gamma^-1 in wiki+ gamma u+ | u <= 0.04045 = u/12.92+ | otherwise = ((u + 0.055) / 1.055) ** 2.4+ -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?+ expand n = round (255 * n)+ convert = expand . gamma . shrink+ in RGBColor (convert r) (convert g) (convert b)++color240 :: Integral i => i -> i -> i -> Color+color240 r g b = Color240 (rgbColorToColor240 r g b)+ -- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.--- This function is lossy in the sense that we only internally support 240 colors but the--- #RRGGBB format supports 16^3 colors.+-- This is a synonym for 'color240'. This function is lossy in the sense+-- that we only internally support 240 colors but the #RRGGBB format+-- supports 256^3 colors. rgbColor :: Integral i => i -> i -> i -> Color-rgbColor r g b = Color240 (rgbColorToColor240 r g b)+rgbColor = color240
src/Graphics/Vty/Attributes/Color240.hs view
@@ -11,7 +11,10 @@ -- Note: rgbColor's mapping from RGB to 240 colors was generated from -- 256colres.pl which is forked from xterm 256colres.pl. --- | Create a value in the Color240 set from an RGB triple+-- | Create a value in the Color240 set from an RGB triple. This maps+-- the input arguments to an entry in the 240-color palette depicted at:+--+-- https://rich.readthedocs.io/en/stable/appendix/colors.html rgbColorToColor240 :: Integral i => i -> i -> i -> Word8 rgbColorToColor240 r g b | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"@@ -39,226 +42,18 @@ | r == 218 && g == 218 && b == 218 = 237 | r == 228 && g == 228 && b == 228 = 238 | r == 238 && g == 238 && b == 238 = 239- | r <= 0 && g <= 0 && b <= 0 = 0- | r <= 0 && g <= 0 && b <= 95 = 1- | r <= 0 && g <= 0 && b <= 135 = 2- | r <= 0 && g <= 0 && b <= 175 = 3- | r <= 0 && g <= 0 && b <= 215 = 4- | r <= 0 && g <= 0 && b <= 255 = 5- | r <= 0 && g <= 95 && b <= 0 = 6- | r <= 0 && g <= 95 && b <= 95 = 7- | r <= 0 && g <= 95 && b <= 135 = 8- | r <= 0 && g <= 95 && b <= 175 = 9- | r <= 0 && g <= 95 && b <= 215 = 10- | r <= 0 && g <= 95 && b <= 255 = 11- | r <= 0 && g <= 135 && b <= 0 = 12- | r <= 0 && g <= 135 && b <= 95 = 13- | r <= 0 && g <= 135 && b <= 135 = 14- | r <= 0 && g <= 135 && b <= 175 = 15- | r <= 0 && g <= 135 && b <= 215 = 16- | r <= 0 && g <= 135 && b <= 255 = 17- | r <= 0 && g <= 175 && b <= 0 = 18- | r <= 0 && g <= 175 && b <= 95 = 19- | r <= 0 && g <= 175 && b <= 135 = 20- | r <= 0 && g <= 175 && b <= 175 = 21- | r <= 0 && g <= 175 && b <= 215 = 22- | r <= 0 && g <= 175 && b <= 255 = 23- | r <= 0 && g <= 215 && b <= 0 = 24- | r <= 0 && g <= 215 && b <= 95 = 25- | r <= 0 && g <= 215 && b <= 135 = 26- | r <= 0 && g <= 215 && b <= 175 = 27- | r <= 0 && g <= 215 && b <= 215 = 28- | r <= 0 && g <= 215 && b <= 255 = 29- | r <= 0 && g <= 255 && b <= 0 = 30- | r <= 0 && g <= 255 && b <= 95 = 31- | r <= 0 && g <= 255 && b <= 135 = 32- | r <= 0 && g <= 255 && b <= 175 = 33- | r <= 0 && g <= 255 && b <= 215 = 34- | r <= 0 && g <= 255 && b <= 255 = 35- | r <= 95 && g <= 0 && b <= 0 = 36- | r <= 95 && g <= 0 && b <= 95 = 37- | r <= 95 && g <= 0 && b <= 135 = 38- | r <= 95 && g <= 0 && b <= 175 = 39- | r <= 95 && g <= 0 && b <= 215 = 40- | r <= 95 && g <= 0 && b <= 255 = 41- | r <= 95 && g <= 95 && b <= 0 = 42- | r <= 95 && g <= 95 && b <= 95 = 43- | r <= 95 && g <= 95 && b <= 135 = 44- | r <= 95 && g <= 95 && b <= 175 = 45- | r <= 95 && g <= 95 && b <= 215 = 46- | r <= 95 && g <= 95 && b <= 255 = 47- | r <= 95 && g <= 135 && b <= 0 = 48- | r <= 95 && g <= 135 && b <= 95 = 49- | r <= 95 && g <= 135 && b <= 135 = 50- | r <= 95 && g <= 135 && b <= 175 = 51- | r <= 95 && g <= 135 && b <= 215 = 52- | r <= 95 && g <= 135 && b <= 255 = 53- | r <= 95 && g <= 175 && b <= 0 = 54- | r <= 95 && g <= 175 && b <= 95 = 55- | r <= 95 && g <= 175 && b <= 135 = 56- | r <= 95 && g <= 175 && b <= 175 = 57- | r <= 95 && g <= 175 && b <= 215 = 58- | r <= 95 && g <= 175 && b <= 255 = 59- | r <= 95 && g <= 215 && b <= 0 = 60- | r <= 95 && g <= 215 && b <= 95 = 61- | r <= 95 && g <= 215 && b <= 135 = 62- | r <= 95 && g <= 215 && b <= 175 = 63- | r <= 95 && g <= 215 && b <= 215 = 64- | r <= 95 && g <= 215 && b <= 255 = 65- | r <= 95 && g <= 255 && b <= 0 = 66- | r <= 95 && g <= 255 && b <= 95 = 67- | r <= 95 && g <= 255 && b <= 135 = 68- | r <= 95 && g <= 255 && b <= 175 = 69- | r <= 95 && g <= 255 && b <= 215 = 70- | r <= 95 && g <= 255 && b <= 255 = 71- | r <= 135 && g <= 0 && b <= 0 = 72- | r <= 135 && g <= 0 && b <= 95 = 73- | r <= 135 && g <= 0 && b <= 135 = 74- | r <= 135 && g <= 0 && b <= 175 = 75- | r <= 135 && g <= 0 && b <= 215 = 76- | r <= 135 && g <= 0 && b <= 255 = 77- | r <= 135 && g <= 95 && b <= 0 = 78- | r <= 135 && g <= 95 && b <= 95 = 79- | r <= 135 && g <= 95 && b <= 135 = 80- | r <= 135 && g <= 95 && b <= 175 = 81- | r <= 135 && g <= 95 && b <= 215 = 82- | r <= 135 && g <= 95 && b <= 255 = 83- | r <= 135 && g <= 135 && b <= 0 = 84- | r <= 135 && g <= 135 && b <= 95 = 85- | r <= 135 && g <= 135 && b <= 135 = 86- | r <= 135 && g <= 135 && b <= 175 = 87- | r <= 135 && g <= 135 && b <= 215 = 88- | r <= 135 && g <= 135 && b <= 255 = 89- | r <= 135 && g <= 175 && b <= 0 = 90- | r <= 135 && g <= 175 && b <= 95 = 91- | r <= 135 && g <= 175 && b <= 135 = 92- | r <= 135 && g <= 175 && b <= 175 = 93- | r <= 135 && g <= 175 && b <= 215 = 94- | r <= 135 && g <= 175 && b <= 255 = 95- | r <= 135 && g <= 215 && b <= 0 = 96- | r <= 135 && g <= 215 && b <= 95 = 97- | r <= 135 && g <= 215 && b <= 135 = 98- | r <= 135 && g <= 215 && b <= 175 = 99- | r <= 135 && g <= 215 && b <= 215 = 100- | r <= 135 && g <= 215 && b <= 255 = 101- | r <= 135 && g <= 255 && b <= 0 = 102- | r <= 135 && g <= 255 && b <= 95 = 103- | r <= 135 && g <= 255 && b <= 135 = 104- | r <= 135 && g <= 255 && b <= 175 = 105- | r <= 135 && g <= 255 && b <= 215 = 106- | r <= 135 && g <= 255 && b <= 255 = 107- | r <= 175 && g <= 0 && b <= 0 = 108- | r <= 175 && g <= 0 && b <= 95 = 109- | r <= 175 && g <= 0 && b <= 135 = 110- | r <= 175 && g <= 0 && b <= 175 = 111- | r <= 175 && g <= 0 && b <= 215 = 112- | r <= 175 && g <= 0 && b <= 255 = 113- | r <= 175 && g <= 95 && b <= 0 = 114- | r <= 175 && g <= 95 && b <= 95 = 115- | r <= 175 && g <= 95 && b <= 135 = 116- | r <= 175 && g <= 95 && b <= 175 = 117- | r <= 175 && g <= 95 && b <= 215 = 118- | r <= 175 && g <= 95 && b <= 255 = 119- | r <= 175 && g <= 135 && b <= 0 = 120- | r <= 175 && g <= 135 && b <= 95 = 121- | r <= 175 && g <= 135 && b <= 135 = 122- | r <= 175 && g <= 135 && b <= 175 = 123- | r <= 175 && g <= 135 && b <= 215 = 124- | r <= 175 && g <= 135 && b <= 255 = 125- | r <= 175 && g <= 175 && b <= 0 = 126- | r <= 175 && g <= 175 && b <= 95 = 127- | r <= 175 && g <= 175 && b <= 135 = 128- | r <= 175 && g <= 175 && b <= 175 = 129- | r <= 175 && g <= 175 && b <= 215 = 130- | r <= 175 && g <= 175 && b <= 255 = 131- | r <= 175 && g <= 215 && b <= 0 = 132- | r <= 175 && g <= 215 && b <= 95 = 133- | r <= 175 && g <= 215 && b <= 135 = 134- | r <= 175 && g <= 215 && b <= 175 = 135- | r <= 175 && g <= 215 && b <= 215 = 136- | r <= 175 && g <= 215 && b <= 255 = 137- | r <= 175 && g <= 255 && b <= 0 = 138- | r <= 175 && g <= 255 && b <= 95 = 139- | r <= 175 && g <= 255 && b <= 135 = 140- | r <= 175 && g <= 255 && b <= 175 = 141- | r <= 175 && g <= 255 && b <= 215 = 142- | r <= 175 && g <= 255 && b <= 255 = 143- | r <= 215 && g <= 0 && b <= 0 = 144- | r <= 215 && g <= 0 && b <= 95 = 145- | r <= 215 && g <= 0 && b <= 135 = 146- | r <= 215 && g <= 0 && b <= 175 = 147- | r <= 215 && g <= 0 && b <= 215 = 148- | r <= 215 && g <= 0 && b <= 255 = 149- | r <= 215 && g <= 95 && b <= 0 = 150- | r <= 215 && g <= 95 && b <= 95 = 151- | r <= 215 && g <= 95 && b <= 135 = 152- | r <= 215 && g <= 95 && b <= 175 = 153- | r <= 215 && g <= 95 && b <= 215 = 154- | r <= 215 && g <= 95 && b <= 255 = 155- | r <= 215 && g <= 135 && b <= 0 = 156- | r <= 215 && g <= 135 && b <= 95 = 157- | r <= 215 && g <= 135 && b <= 135 = 158- | r <= 215 && g <= 135 && b <= 175 = 159- | r <= 215 && g <= 135 && b <= 215 = 160- | r <= 215 && g <= 135 && b <= 255 = 161- | r <= 215 && g <= 175 && b <= 0 = 162- | r <= 215 && g <= 175 && b <= 95 = 163- | r <= 215 && g <= 175 && b <= 135 = 164- | r <= 215 && g <= 175 && b <= 175 = 165- | r <= 215 && g <= 175 && b <= 215 = 166- | r <= 215 && g <= 175 && b <= 255 = 167- | r <= 215 && g <= 215 && b <= 0 = 168- | r <= 215 && g <= 215 && b <= 95 = 169- | r <= 215 && g <= 215 && b <= 135 = 170- | r <= 215 && g <= 215 && b <= 175 = 171- | r <= 215 && g <= 215 && b <= 215 = 172- | r <= 215 && g <= 215 && b <= 255 = 173- | r <= 215 && g <= 255 && b <= 0 = 174- | r <= 215 && g <= 255 && b <= 95 = 175- | r <= 215 && g <= 255 && b <= 135 = 176- | r <= 215 && g <= 255 && b <= 175 = 177- | r <= 215 && g <= 255 && b <= 215 = 178- | r <= 215 && g <= 255 && b <= 255 = 179- | r <= 255 && g <= 0 && b <= 0 = 180- | r <= 255 && g <= 0 && b <= 95 = 181- | r <= 255 && g <= 0 && b <= 135 = 182- | r <= 255 && g <= 0 && b <= 175 = 183- | r <= 255 && g <= 0 && b <= 215 = 184- | r <= 255 && g <= 0 && b <= 255 = 185- | r <= 255 && g <= 95 && b <= 0 = 186- | r <= 255 && g <= 95 && b <= 95 = 187- | r <= 255 && g <= 95 && b <= 135 = 188- | r <= 255 && g <= 95 && b <= 175 = 189- | r <= 255 && g <= 95 && b <= 215 = 190- | r <= 255 && g <= 95 && b <= 255 = 191- | r <= 255 && g <= 135 && b <= 0 = 192- | r <= 255 && g <= 135 && b <= 95 = 193- | r <= 255 && g <= 135 && b <= 135 = 194- | r <= 255 && g <= 135 && b <= 175 = 195- | r <= 255 && g <= 135 && b <= 215 = 196- | r <= 255 && g <= 135 && b <= 255 = 197- | r <= 255 && g <= 175 && b <= 0 = 198- | r <= 255 && g <= 175 && b <= 95 = 199- | r <= 255 && g <= 175 && b <= 135 = 200- | r <= 255 && g <= 175 && b <= 175 = 201- | r <= 255 && g <= 175 && b <= 215 = 202- | r <= 255 && g <= 175 && b <= 255 = 203- | r <= 255 && g <= 215 && b <= 0 = 204- | r <= 255 && g <= 215 && b <= 95 = 205- | r <= 255 && g <= 215 && b <= 135 = 206- | r <= 255 && g <= 215 && b <= 175 = 207- | r <= 255 && g <= 215 && b <= 215 = 208- | r <= 255 && g <= 215 && b <= 255 = 209- | r <= 255 && g <= 255 && b <= 0 = 210- | r <= 255 && g <= 255 && b <= 95 = 211- | r <= 255 && g <= 255 && b <= 135 = 212- | r <= 255 && g <= 255 && b <= 175 = 213- | r <= 255 && g <= 255 && b <= 215 = 214- | r <= 255 && g <= 255 && b <= 255 = 215- | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."+ | otherwise = 36 * go r + 6 * go g + go b+ where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette." (fromIntegral r :: Int) (fromIntegral g :: Int)- (fromIntegral b :: Int))+ (fromIntegral b :: Int)))++simpleColor_ :: Integral i => Word8 -> i -> Word8+simpleColor_ e c+ | c <= 0 = 0+ | c <= 95 = 1+ | c <= 255 = fromIntegral ((c-16) `div` 40)+ | otherwise = e -- | Create a RGB triple from a value in the Color240 set. color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)
src/Graphics/Vty/Config.hs view
@@ -1,17 +1,29 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-}--- | Vty supports a configuration file format and associated 'Config'--- data type. The 'Config' can be provided to 'mkVty' to customize the+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Vty supports a configuration file format and provides a+-- corresponding 'VtyUserConfig' data type. The 'VtyUserConfig' can be+-- provided to platform packages' @mkVty@ functions to customize the -- application's use of Vty. ----- Lines in config files that fail to parse are ignored. Later entries--- take precedence over earlier ones.--- -- = Debug --+-- == @colorMode@+--+-- Format:+--+-- @+-- colorMode \"<ColorMode8|ColorMode16|ColorMode240 <int>|FullColor>\"+-- @+--+-- The preferred color mode to use, chosen from the constructors of the+-- 'ColorMode' type. If absent, the backend driver may detect and choose+-- an appropriate color mode. Implementor's note: backend packages+-- should respect this setting when it is present even when their+-- detection indicates that a different color mode should be used.+-- -- == @debugLog@ -- -- Format:@@ -54,7 +66,7 @@ -- If a debug log is requested then vty will output the current input -- table to the log in the above format. A workflow for using this is -- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for--- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.+-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@. -- -- = Unicode Character Width Maps --@@ -72,27 +84,23 @@ -- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\" -- @ ----- This directive specifies the path to a Unicode character width--- map (the second argument) that should be loaded and used when--- the value of TERM matches the first argument. Unicode character--- width maps can be produced either by running the provided binary--- @vty-build-width-table@ or by calling the library routine--- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The--- 'Graphics.Vty.mkVty' function will use these configuration settings--- to attempt to load and install the specified width map. See the--- documentation for 'Graphics.Vty.mkVty' for details.+-- This directive specifies the path to a Unicode character+-- width map (the second argument) that should correspond to+-- the terminal named by first argument. Unicode character+-- width maps can be produced either by running platform+-- packages' width table tools or by calling the library routine+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. Vty+-- platform packages should use these configuration settings to attempt+-- to load and install the specified width map. module Graphics.Vty.Config ( InputMap- , Config(..)- , VtyConfigurationError(..)+ , VtyUserConfig(..) , userConfig , overrideEnvConfig- , standardIOConfig+ , currentTerminalName , runParseConfig , parseConfigFile , defaultConfig- , getTtyEraseChar- , currentTerminalName , vtyConfigPath , widthTableFilename@@ -109,7 +117,7 @@ import Control.Applicative hiding (many) -import Control.Exception (catch, IOException, Exception(..), throwIO)+import Control.Exception (catch, IOException) import Control.Monad (liftM, guard, void) import qualified Data.ByteString as BS@@ -119,8 +127,9 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif-import Data.Typeable (Typeable)+import Text.Read (readMaybe) +import Graphics.Vty.Attributes.Color (ColorMode(..)) import Graphics.Vty.Input.Events import GHC.Generics@@ -130,106 +139,73 @@ ) import System.Environment (lookupEnv) import System.FilePath ((</>), takeDirectory)-import System.Posix.IO (stdInput, stdOutput)-import System.Posix.Types (Fd(..))-import Foreign.C.Types (CInt(..), CChar(..)) import Text.Parsec hiding ((<|>)) import Text.Parsec.Token ( GenLanguageDef(..) ) import qualified Text.Parsec.Token as P --- | Type of errors that can be thrown when configuring VTY-data VtyConfigurationError =- VtyMissingTermEnvVar- -- ^ TERM environment variable not set- deriving (Show, Eq, Typeable)--instance Exception VtyConfigurationError where- displayException VtyMissingTermEnvVar = "TERM environment variable not set"- -- | Mappings from input bytes to event in the order specified. Later -- entries take precedence over earlier in the case multiple entries -- have the same byte string. type InputMap = [(Maybe String, String, Event)] --- | A Vty configuration.-data Config =- Config { vmin :: Maybe Int- -- ^ The default is 1 character.- , vtime :: Maybe Int- -- ^ The default is 100 milliseconds, 0.1 seconds.- , mouseMode :: Maybe Bool- -- ^ The default is False.- , bracketedPasteMode :: Maybe Bool- -- ^ The default is False.- , debugLog :: Maybe FilePath- -- ^ Debug information is appended to this file if not- -- Nothing.- , inputMap :: InputMap- -- ^ The (input byte, output event) pairs extend the internal- -- input table of VTY and the table from terminfo.- --- -- See "Graphics.Vty.Config" module documentation for- -- documentation of the @map@ directive.- , inputFd :: Maybe Fd- -- ^ The input file descriptor to use. The default is- -- 'System.Posix.IO.stdInput'- , outputFd :: Maybe Fd- -- ^ The output file descriptor to use. The default is- -- 'System.Posix.IO.stdOutput'- , termName :: Maybe String- -- ^ The terminal name used to look up terminfo capabilities.- -- The default is the value of the TERM environment variable.- , termWidthMaps :: [(String, FilePath)]- -- ^ Terminal width map files.- , allowCustomUnicodeWidthTables :: Maybe Bool- -- ^ Whether to permit custom Unicode width table loading by- -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that- -- table loading should not be performed. Other values permit- -- table loading.- --- -- If a table load is attempted and fails, information- -- about the failure will be logged to the debug log if the- -- configuration specifies one. If no custom table is loaded- -- (or if a load fails), the built-in character width table- -- will be used.- }- deriving (Show, Eq)+-- | A Vty core library configuration. Platform-specific details are not+-- included in the VtyUserConfig.+data VtyUserConfig =+ VtyUserConfig { configDebugLog :: Maybe FilePath+ -- ^ Debug information is appended to this file if not+ -- Nothing.+ , configInputMap :: InputMap+ -- ^ The (input byte, output event) pairs extend the internal+ -- input table of VTY and the table from terminfo.+ --+ -- See "Graphics.Vty.Config" module documentation for+ -- documentation of the @map@ directive.+ , configTermWidthMaps :: [(String, FilePath)]+ -- ^ Terminal width map files.+ , configAllowCustomUnicodeWidthTables :: Maybe Bool+ -- ^ Whether to permit custom Unicode width table loading by+ -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that+ -- table loading should not be performed. Other values permit+ -- table loading.+ --+ -- If a table load is attempted and fails, information+ -- about the failure will be logged to the debug log if the+ -- configuration specifies one. If no custom table is loaded+ -- (or if a load fails), the built-in character width table+ -- will be used.+ , configPreferredColorMode :: Maybe ColorMode+ -- ^ Preferred color mode. If set, this should+ -- override platform color mode detection.+ }+ deriving (Show, Eq) -defaultConfig :: Config+defaultConfig :: VtyUserConfig defaultConfig = mempty -instance Semigroup Config where+instance Semigroup VtyUserConfig where c0 <> c1 = -- latter config takes priority for everything but inputMap- Config { vmin = vmin c1 <|> vmin c0- , vtime = vtime c1 <|> vtime c0- , mouseMode = mouseMode c1- , bracketedPasteMode = bracketedPasteMode c1- , debugLog = debugLog c1 <|> debugLog c0- , inputMap = inputMap c0 <> inputMap c1- , inputFd = inputFd c1 <|> inputFd c0- , outputFd = outputFd c1 <|> outputFd c0- , termName = termName c1 <|> termName c0- , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0- , allowCustomUnicodeWidthTables =- allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0- }+ VtyUserConfig { configDebugLog =+ configDebugLog c1 <|> configDebugLog c0+ , configInputMap =+ configInputMap c0 <> configInputMap c1+ , configTermWidthMaps =+ configTermWidthMaps c1 <|> configTermWidthMaps c0+ , configAllowCustomUnicodeWidthTables =+ configAllowCustomUnicodeWidthTables c1 <|> configAllowCustomUnicodeWidthTables c0+ , configPreferredColorMode =+ configPreferredColorMode c1 <|> configPreferredColorMode c0+ } -instance Monoid Config where+instance Monoid VtyUserConfig where mempty =- Config { vmin = Nothing- , vtime = Nothing- , mouseMode = Nothing- , bracketedPasteMode = Nothing- , debugLog = mempty- , inputMap = mempty- , inputFd = Nothing- , outputFd = Nothing- , termName = Nothing- , termWidthMaps = []- , allowCustomUnicodeWidthTables = Nothing- }+ VtyUserConfig { configDebugLog = mempty+ , configInputMap = mempty+ , configTermWidthMaps = []+ , configAllowCustomUnicodeWidthTables = Nothing+ , configPreferredColorMode = Nothing+ } #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif@@ -246,7 +222,8 @@ vtyConfigFileEnvName = "VTY_CONFIG_FILE" -- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.-userConfig :: IO Config+-- If none is found, build a default configuration.+userConfig :: IO VtyUserConfig userConfig = do configFile <- vtyConfigPath >>= parseConfigFile overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<@@ -272,35 +249,21 @@ Just term -> do return $ Just $ dataDir </> widthTableFilename term -overrideEnvConfig :: IO Config+overrideEnvConfig :: IO VtyUserConfig overrideEnvConfig = do d <- lookupEnv "VTY_DEBUG_LOG"- return $ defaultConfig { debugLog = d }---- | Configures VTY using defaults suitable for terminals. This function--- can raise 'VtyConfigurationError'.-standardIOConfig :: IO Config-standardIOConfig = do- mb <- lookupEnv termVariable- case mb of- Nothing -> throwIO VtyMissingTermEnvVar- Just t ->- return defaultConfig- { vmin = Just 1- , mouseMode = Just False- , bracketedPasteMode = Just False- , vtime = Just 100- , inputFd = Just stdInput- , outputFd = Just stdOutput- , termName = Just t- }+ return $ defaultConfig { configDebugLog = d } -parseConfigFile :: FilePath -> IO Config+-- | Parse a Vty configuration file.+--+-- Lines in config files that fail to parse are ignored. Later entries+-- take precedence over earlier ones.+parseConfigFile :: FilePath -> IO VtyUserConfig parseConfigFile path = do catch (runParseConfig path <$> BS.readFile path) (\(_ :: IOException) -> return defaultConfig) -runParseConfig :: String -> BS.ByteString -> Config+runParseConfig :: String -> BS.ByteString -> VtyUserConfig runParseConfig name cfgTxt = case runParser parseConfig () name cfgTxt of Right cfg -> cfg@@ -328,7 +291,7 @@ configLexer :: Monad m => P.GenTokenParser BS.ByteString () m configLexer = P.makeTokenParser configLanguage -mapDecl :: Parser Config+mapDecl :: Parser VtyUserConfig mapDecl = do "map" <- P.identifier configLexer termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)@@ -336,28 +299,34 @@ bytes <- P.stringLiteral configLexer key <- parseValue modifiers <- parseValue- return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] }+ return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] } -debugLogDecl :: Parser Config+debugLogDecl :: Parser VtyUserConfig debugLogDecl = do "debugLog" <- P.identifier configLexer path <- P.stringLiteral configLexer- return defaultConfig { debugLog = Just path }+ return defaultConfig { configDebugLog = Just path } -widthMapDecl :: Parser Config+colorModeDecl :: Parser VtyUserConfig+colorModeDecl = do+ "colorMode" <- P.identifier configLexer+ mode <- P.stringLiteral configLexer+ return defaultConfig { configPreferredColorMode = readMaybe mode }++widthMapDecl :: Parser VtyUserConfig widthMapDecl = do "widthMap" <- P.identifier configLexer tName <- P.stringLiteral configLexer path <- P.stringLiteral configLexer- return defaultConfig { termWidthMaps = [(tName, path)] }+ return defaultConfig { configTermWidthMaps = [(tName, path)] } ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline -parseConfig :: Parser Config+parseConfig :: Parser VtyUserConfig parseConfig = liftM mconcat $ many $ do P.whiteSpace configLexer- let directives = [try mapDecl, try debugLogDecl, try widthMapDecl]+ let directives = [try mapDecl, try debugLogDecl, try widthMapDecl, try colorModeDecl] choice directives <|> (ignoreLine >> return defaultConfig) class Parse a where parseValue :: Parser a@@ -404,32 +373,22 @@ instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1" -foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar---- | Get the "erase" character for the terminal attached to the--- specified file descriptor. This is the character configured by 'stty--- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'.--- Otherwise it will return the character that has been configured to--- indicate the canonical mode ERASE behavior. That character can then--- be added to the table of strings that we interpret to mean Backspace.------ For more details, see:------ * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html--- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty--- * https://github.com/matterhorn-chat/matterhorn/issues/565-getTtyEraseChar :: Fd -> IO (Maybe Char)-getTtyEraseChar fd = do- c <- cGetTtyErase fd- if c /= 0- then return $ Just $ toEnum $ fromEnum c- else return Nothing-+-- | The result of a configuration change attempt made by+-- 'addConfigWidthMap'. data ConfigUpdateResult = ConfigurationCreated+ -- ^ A new configuration file file was written with the new width+ -- table entry. | ConfigurationModified+ -- ^ An existing configuration file was modified with the new width+ -- table entry. | ConfigurationConflict String+ -- ^ The attempted width table entry could not be written to the+ -- configuration due to a conflict; the argument here is the width+ -- table file path for the conflicting entry. | ConfigurationRedundant+ -- ^ No change was made because the existing configuration already+ -- contains the specified mapping. deriving (Eq, Show) -- | Add a @widthMap@ directive to the Vty configuration file at the@@ -443,8 +402,8 @@ -- If the configuration path does not exist, a new configuration file -- will be created and any directories in the path will also be created. ----- This returns @True@ if the configuration was created or modified and--- @False@ otherwise. This does not handle exceptions raised by file or+-- This returns a 'ConfigUpdateResult' indicating the change to the+-- configuration. This does not handle exceptions raised by file or -- directory permissions issues. addConfigWidthMap :: FilePath -- ^ The configuration file path of the configuration@@ -470,9 +429,9 @@ updateConfig = do config <- parseConfigFile configPath- if (term, tablePath) `elem` termWidthMaps config+ if (term, tablePath) `elem` configTermWidthMaps config then return ConfigurationRedundant- else case lookup term (termWidthMaps config) of+ else case lookup term (configTermWidthMaps config) of Just other -> return $ ConfigurationConflict other Nothing -> do appendFile configPath directive
src/Graphics/Vty/Debug.hs view
@@ -1,13 +1,18 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug- ( module Graphics.Vty.Debug- , module Graphics.Vty.Debug.Image+ ( MockWindow(..)+ , SpanConstructLog+ , regionForWindow+ , allSpansHaveWidth+ , spanOpsAffectedColumns+ , spanOpsAffectedRows+ , rowOpsAffectedColumns+ , isSetAttr ) where import Graphics.Vty.Attributes import Graphics.Vty.Image (DisplayRegion)-import Graphics.Vty.Debug.Image import Graphics.Vty.Span import qualified Data.Vector as Vector
− src/Graphics/Vty/Debug/Image.hs
@@ -1,32 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-module Graphics.Vty.Debug.Image where--import Graphics.Vty.Image--type ImageConstructLog = [ImageConstructEvent]-data ImageConstructEvent = ImageConstructEvent- deriving ( Show, Eq )--forwardImageOps :: [Image -> Image]-forwardImageOps = map forwardTransform debugImageOps--forwardTransform, reverseTransform :: ImageOp -> (Image -> Image)--forwardTransform (ImageOp f _) = f-reverseTransform (ImageOp _ r) = r--data ImageOp = ImageOp ImageEndo ImageEndo-type ImageEndo = Image -> Image--debugImageOps :: [ImageOp]-debugImageOps =- [ idImageOp- -- , renderSingleColumnCharOp- -- , renderDoubleColumnCharOp- ]--idImageOp :: ImageOp-idImageOp = ImageOp id id---- renderCharOp :: ImageOp--- renderCharOp = ImageOp id id
src/Graphics/Vty/DisplayAttributes.hs view
@@ -2,7 +2,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -module Graphics.Vty.DisplayAttributes where+module Graphics.Vty.DisplayAttributes+ ( DisplayAttrDiff(..)+ , StyleStateChange(..)+ , DisplayColorDiff(..)+ , URLDiff(..)+ , fixDisplayAttr+ , displayAttrDiffs+ )+where import Graphics.Vty.Attributes @@ -96,6 +104,8 @@ | RemoveStandout | ApplyItalic | RemoveItalic+ | ApplyStrikethrough+ | RemoveStrikethrough | ApplyUnderline | RemoveUnderline | ApplyReverseVideo@@ -144,6 +154,7 @@ [ styleDiff standout ApplyStandout RemoveStandout , styleDiff underline ApplyUnderline RemoveUnderline , styleDiff italic ApplyItalic RemoveItalic+ , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo , styleDiff blink ApplyBlink RemoveBlink , styleDiff dim ApplyDim RemoveDim
src/Graphics/Vty/Error.hs view
@@ -1,4 +1,7 @@-module Graphics.Vty.Error where+module Graphics.Vty.Error+ ( VtyException(..)+ )+where -- | The type of exceptions specific to vty. --
src/Graphics/Vty/Image.hs view
@@ -1,5 +1,4 @@ -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -- | A Vty program makes 'Picture's from 'Image's. This module provides@@ -53,7 +52,6 @@ , wctwidth , wctlwidth -- * Display Regions- , DisplayText , DisplayRegion , regionWidth , regionHeight@@ -117,14 +115,16 @@ vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage --- | Make an 'Image' from a lazy text value. This function should not be--- given a text value containing escapes.+-- | Make an 'Image' from a lazy text value. The text value should be+-- sanitized of escape sequences (ASCII 27) and carriage returns;+-- otherwise layout and attribute problems may result. text :: Attr -> TL.Text -> Image text a txt = let displayWidth = safeWctlwidth txt in HorizText a txt displayWidth (fromIntegral $! TL.length txt) --- | Make an 'Image' from a text value. This function should not be--- given a text value containing escapes.+-- | Make an 'Image' from a text value. The text value should be+-- sanitized of escape sequences (ASCII 27) and carriage returns;+-- otherwise layout and attribute problems may result. text' :: Attr -> T.Text -> Image text' a txt = let displayWidth = safeWctwidth txt in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)@@ -136,10 +136,11 @@ let displayWidth = safeWcwidth c in HorizText a (TL.singleton c) displayWidth 1 --- | Make an image from a string of characters layed out on a single+-- | Make an image from a string of characters laid out on a single -- row with the same display attribute. The string is assumed to be a--- sequence of ISO-10646 characters. This function should not be given a--- string containing escapes.+-- sequence of ISO-10646 characters. The input string should be+-- sanitized of escape sequences (ASCII 27) and carriage returns;+-- otherwise layout and attribute problems may result. -- -- Note: depending on how the Haskell compiler represents string -- literals, a string literal in a UTF-8 encoded source file, for@@ -156,8 +157,7 @@ -- -- This is an alias for iso10646String since the usual case is that a -- literal string like "foo" is represented internally as a list of ISO--- 10646 31 bit characters. This function should not be given a string--- containing escapes.+-- 10646 31 bit characters. -- -- Note: Keep in mind that GHC will compile source encoded as UTF-8 -- but the literal strings, while UTF-8 encoded in the source, will be@@ -257,7 +257,7 @@ translateX :: Int -> Image -> Image translateX x i | x < 0 && (abs x > imageWidth i) = emptyImage- | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)+ | x < 0 = cropLeft (imageWidth i + x) i | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h @@ -265,7 +265,7 @@ translateY :: Int -> Image -> Image translateY y i | y < 0 && (abs y > imageHeight i) = emptyImage- | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)+ | y < 0 = cropTop (imageHeight i + y) i | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) @@ -295,12 +295,11 @@ | otherwise = go inI where go EmptyImage = EmptyImage- go i@(CropBottom {croppedImage, outputWidth, outputHeight})- | outputHeight <= h = i- | otherwise = CropBottom croppedImage outputWidth h+ go i@(Crop {outputHeight})+ = i {outputHeight = min h outputHeight} go i | h >= imageHeight i = i- | otherwise = CropBottom i (imageWidth i) h+ | otherwise = Crop i 0 0 (imageWidth i) h -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise@@ -312,12 +311,11 @@ | otherwise = go inI where go EmptyImage = EmptyImage- go i@(CropRight {croppedImage, outputWidth, outputHeight})- | outputWidth <= w = i- | otherwise = CropRight croppedImage w outputHeight+ go i@(Crop {outputWidth})+ = i {outputWidth = min w outputWidth} go i | w >= imageWidth i = i- | otherwise = CropRight i w (imageHeight i)+ | otherwise = Crop i 0 0 w (imageHeight i) -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise@@ -329,14 +327,13 @@ | otherwise = go inI where go EmptyImage = EmptyImage- go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})- | outputWidth <= w = i- | otherwise =- let leftSkip' = leftSkip + outputWidth - w- in CropLeft croppedImage leftSkip' w outputHeight+ go i@(Crop {leftSkip, outputWidth}) =+ let delta = max 0 (outputWidth - w)+ in i { leftSkip = leftSkip + delta+ , outputWidth = outputWidth - delta } go i | imageWidth i <= w = i- | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)+ | otherwise = Crop i (imageWidth i - w) 0 w (imageHeight i) -- | Crop an image's height. If the image's height is less than or equal -- to the specified height then this operation has no effect. Otherwise@@ -348,14 +345,13 @@ | otherwise = go inI where go EmptyImage = EmptyImage- go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight})- | outputHeight <= h = i- | otherwise =- let topSkip' = topSkip + outputHeight - h- in CropTop croppedImage topSkip' outputWidth h+ go i@(Crop {topSkip, outputHeight}) =+ let delta = max 0 (outputHeight - h)+ in i { topSkip = topSkip + delta+ , outputHeight = outputHeight - delta } go i | imageHeight i <= h = i- | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h+ | otherwise = Crop i 0 (imageHeight i - h) (imageWidth i) h -- | Generic resize. Pads and crops are added to ensure that the -- resulting image matches the specified dimensions. This is biased to
src/Graphics/Vty/Image/Internal.hs view
@@ -3,8 +3,18 @@ {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} -module Graphics.Vty.Image.Internal where+module Graphics.Vty.Image.Internal+ ( Image(..)+ , imageHeight+ , imageWidth+ , horizJoin+ , vertJoin + , ppImageStructure+ , clipText+ )+where+ import Graphics.Vty.Attributes import Graphics.Text.Width @@ -17,10 +27,7 @@ #endif import qualified Data.Text.Lazy as TL --- | A display text is a Data.Text.Lazy-type DisplayText = TL.Text--clipText :: DisplayText -> Int -> Int -> DisplayText+clipText :: TL.Text -> Int -> Int -> TL.Text clipText txt leftSkip rightClip = -- CPS would clarify this I think let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0@@ -57,7 +64,7 @@ { attr :: Attr -- | The text to display. The display width of the text is always -- outputWidth.- , displayText :: DisplayText+ , displayText :: TL.Text -- | The number of display columns for the text. , outputWidth :: Int -- | the number of characters in the text.@@ -96,42 +103,12 @@ { outputWidth :: Int -- ^ always > 0 , outputHeight :: Int -- ^ always > 0 }- -- | Crop an image horizontally to a size by reducing the size from- -- the right.- | CropRight- { croppedImage :: Image- -- | Always < imageWidth croppedImage > 0- , outputWidth :: Int- , outputHeight :: Int -- ^ imageHeight croppedImage- }- -- | Crop an image horizontally to a size by reducing the size from- -- the left.- | CropLeft+ -- | Crop an image+ | Crop { croppedImage :: Image- -- | Always < imageWidth croppedImage > 0 , leftSkip :: Int- -- | Always < imageWidth croppedImage > 0- , outputWidth :: Int- , outputHeight :: Int- }- -- | Crop an image vertically to a size by reducing the size from- -- the bottom- | CropBottom- { croppedImage :: Image- -- | imageWidth croppedImage- , outputWidth :: Int- -- | height image is cropped to. Always < imageHeight croppedImage > 0- , outputHeight :: Int- }- -- | Crop an image vertically to a size by reducing the size from- -- the top- | CropTop- { croppedImage :: Image- -- | Always < imageHeight croppedImage > 0 , topSkip :: Int- -- | imageWidth croppedImage , outputWidth :: Int- -- | Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | The empty image@@ -146,7 +123,7 @@ -- | pretty print just the structure of an image. ppImageStructure :: Image -> String-ppImageStructure inImg = go 0 inImg+ppImageStructure = go 0 where go indent img = tab indent ++ pp indent img tab indent = concat $ replicate indent " "@@ -159,26 +136,14 @@ = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n" ++ go (i+1) t ++ "\n" ++ go (i+1) b- pp i (CropRight {croppedImage, outputWidth, outputHeight})- = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"- ++ go (i+1) croppedImage- pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})- = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"- ++ go (i+1) croppedImage- pp i (CropBottom {croppedImage, outputWidth, outputHeight})- = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"- ++ go (i+1) croppedImage- pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight})- = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n"+ pp i (Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight})+ = "Crop(" ++ show leftSkip ++ "," ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp _ EmptyImage = "EmptyImage" instance NFData Image where rnf EmptyImage = ()- rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()- rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` ()- rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` ()- rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` ()+ rnf (Crop i x y w h) = i `deepseq` x `seq` y `seq` w `seq` h `seq` () rnf (BGFill w h) = w `seq` h `seq` () rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` () rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()@@ -191,10 +156,7 @@ imageWidth HorizJoin { outputWidth = w } = w imageWidth VertJoin { outputWidth = w } = w imageWidth BGFill { outputWidth = w } = w-imageWidth CropRight { outputWidth = w } = w-imageWidth CropLeft { outputWidth = w } = w-imageWidth CropBottom { outputWidth = w } = w-imageWidth CropTop { outputWidth = w } = w+imageWidth Crop { outputWidth = w } = w imageWidth EmptyImage = 0 -- | The height of an Image. This is the number of display rows the@@ -204,10 +166,7 @@ imageHeight HorizJoin { outputHeight = h } = h imageHeight VertJoin { outputHeight = h } = h imageHeight BGFill { outputHeight = h } = h-imageHeight CropRight { outputHeight = h } = h-imageHeight CropLeft { outputHeight = h } = h-imageHeight CropBottom { outputHeight = h } = h-imageHeight CropTop { outputHeight = h } = h+imageHeight Crop { outputHeight = h } = h imageHeight EmptyImage = 0 -- | Append in the 'Semigroup' instance is equivalent to '<->'.@@ -228,7 +187,7 @@ -- -- The result image will have a width equal to the sum of the two images -- width. And the height will equal the largest height of the two--- images. The area not defined in one image due to a height missmatch+-- images. The area not defined in one image due to a height mismatch -- will be filled with the background pattern. horizJoin :: Image -> Image -> Image horizJoin EmptyImage i = i@@ -259,7 +218,7 @@ -- -- The result image will have a height equal to the sum of the heights -- of both images. The width will equal the largest width of the two--- images. The area not defined in one image due to a width missmatch+-- images. The area not defined in one image due to a width mismatch -- will be filled with the background pattern. vertJoin :: Image -> Image -> Image vertJoin EmptyImage i = i
src/Graphics/Vty/Inline.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- -- | The inline module provides a limited interface to changing the -- style of terminal output. The intention is for this interface to be -- used inline with other output systems.@@ -31,13 +29,11 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Inline ( module Graphics.Vty.Inline- , withVty ) where import Graphics.Vty import Graphics.Vty.DisplayAttributes-import Graphics.Vty.Inline.Unsafe import Blaze.ByteString.Builder (writeToByteString) @@ -58,13 +54,13 @@ -- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM () backColor c = modify $ \s ->- s { inlineAttr = inlineAttr s `mappend` (currentAttr `withBackColor` c)+ s { inlineAttr = inlineAttr s `withBackColor` c } -- | Set the foreground color to the provided 'Color'. foreColor :: Color -> InlineM () foreColor c = modify $ \s ->- s { inlineAttr = inlineAttr s `mappend` (currentAttr `withForeColor` c)+ s { inlineAttr = inlineAttr s `withForeColor` c } -- | Attempt to change the 'Style' of the following text..@@ -73,7 +69,7 @@ -- produced. The style can still be removed. applyStyle :: Style -> InlineM () applyStyle st = modify $ \s ->- s { inlineAttr = inlineAttr s `mappend` (currentAttr `withStyle` st)+ s { inlineAttr = inlineAttr s `withStyle` st } -- | Attempt to remove the specified 'Style' from the display of the@@ -85,8 +81,8 @@ removeStyle sMask = modify $ \s -> s { inlineAttr = let style' = case attrStyle (inlineAttr s) of- Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."- KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."+ Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."+ KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." SetTo st -> st .&. complement sMask in (inlineAttr s) { attrStyle = SetTo style' } }@@ -121,8 +117,8 @@ -- output device. -- -- This will flush the terminal output.-putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()-putAttrChange_ c = liftIO $ withOutput $ \out -> do+putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()+putAttrChange_ out c = liftIO $ do hFlush stdout putAttrChange out c hFlush stdout
− src/Graphics/Vty/Inline/Unsafe.hs
@@ -1,59 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module Graphics.Vty.Inline.Unsafe where--import Graphics.Vty--import Data.IORef--import GHC.IO.Handle (hDuplicate)--import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering))--import System.IO.Unsafe--import System.Posix.IO (handleToFd)--globalVty :: IORef (Maybe Vty)-{-# NOINLINE globalVty #-}-globalVty = unsafePerformIO $ newIORef Nothing--globalOutput :: IORef (Maybe Output)-{-# NOINLINE globalOutput #-}-globalOutput = unsafePerformIO $ newIORef Nothing--mkDupeConfig :: IO Config-mkDupeConfig = do- hSetBuffering stdout NoBuffering- hSetBuffering stdin NoBuffering- stdinDupe <- hDuplicate stdin >>= handleToFd- stdoutDupe <- hDuplicate stdout >>= handleToFd- return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }---- | This will create a Vty instance using 'mkVty' and execute an IO--- action provided that instance. The created Vty instance will be--- stored to the unsafe 'IORef' 'globalVty'.------ This instance will use duplicates of the stdin and stdout Handles.-withVty :: (Vty -> IO b) -> IO b-withVty f = do- mvty <- readIORef globalVty- vty <- case mvty of- Nothing -> do- vty <- mkDupeConfig >>= mkVty- writeIORef globalVty (Just vty)- return vty- Just vty -> return vty- f vty--withOutput :: (Output -> IO b) -> IO b-withOutput f = do- mout <- readIORef globalOutput- out <- case mout of- Nothing -> do- config <- mappend <$> userConfig <*> mkDupeConfig- out <- outputForConfig config- writeIORef globalOutput (Just out)- return out- Just out -> return out- f out
src/Graphics/Vty/Input.hs view
@@ -1,187 +1,32 @@-{-# LANGUAGE RecordWildCards, CPP #-}---- | This module provides the input layer for Vty, including methods--- for initializing an 'Input' structure and reading 'Event's from the--- terminal.------ Note that due to the evolution of terminal emulators, some keys--- and combinations will not reliably map to the expected events by--- any terminal program. There is no 1:1 mapping from key events to--- bytes read from the terminal input device. In very limited cases the--- terminal and vty's input process can be customized to resolve these--- issues; see "Graphics.Vty.Config" for how to configure vty's input--- processing.------ = VTY's Implementation------ There are two input modes:------ 1. 7-bit------ 2. 8-bit------ The 7-bit input mode is the default and the expected mode in most use--- cases. This is what Vty uses.------ == 7-bit input encoding------ Control key combinations are represented by masking the two high bits--- of the 7-bit input. Historically the control key actually grounded--- the two high bit wires: 6 and 7. This is why control key combos--- map to single character events: the input bytes are identical. The--- input byte is the bit encoding of the character with bits 6 and 7--- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For--- example,------ * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become--- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key.------ * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero--- which is `0000011` and is the "End of Text" code.------ * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this--- is the value 1 with bit 7 set and 6 unset.------ * Hypothesis: Bit 6 is unset by upper case letters because,--- initially, there were only upper case letters used and a 5 bit--- encoding.------ == 8-bit encoding------ The 8th bit was originally used for parity checking which is useless--- for terminal emulators. Some terminal emulators support an 8-bit--- input encoding. While this provides some advantages, the actual usage--- is low. Most systems use 7-bit mode but recognize 8-bit control--- characters when escaped. This is what Vty does.------ == Escaped Control Keys------ Using 7-bit input encoding, the @ESC@ byte can signal the start of--- an encoded control key. To differentiate a single @ESC@ event from a--- control key, the timing of the input is used.------ 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of--- 'VMIN' milliseconds.------ 2. Control keys that contain @ESC@ in their encoding: The @ESC byte--- is followed by more bytes read within 'VMIN' milliseconds. All bytes--- up until the next valid input block are passed to the classifier.------ If the current runtime is the threaded runtime then the terminal's--- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If--- the current runtime does not support 'forkOS' then there is currently--- no implementation.------ == Unicode Input and Escaped Control Key Sequences------ The input encoding determines how UTF-8 encoded characters are--- recognized.------ * 7-bit mode: UTF-8 can be input unambiguiously. UTF-8 input is--- a superset of ASCII. UTF-8 does not overlap escaped control key--- sequences. However, the escape key must be differentiated from--- escaped control key sequences by the timing of the input bytes.------ * 8-bit mode: UTF-8 cannot be input unambiguously. This does not--- require using the timing of input bytes to differentiate the escape--- key. Many terminals do not support 8-bit mode.------ == Terminfo------ The terminfo system is used to determine how some keys are encoded.--- Terminfo is incomplete and in some cases terminfo is incorrect. Vty--- assumes terminfo is correct but provides a mechanism to override--- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'.------ == Terminal Input is Broken------ Clearly terminal input has fundemental issues. There is no easy way--- to reliably resolve these issues.------ One resolution would be to ditch standard terminal interfaces--- entirely and just go directly to scancodes. This would be a--- reasonable option for Vty if everybody used the linux kernel console--- but for obvious reasons this is not possible.------ The "Graphics.Vty.Config" module supports customizing the--- input-byte-to-event mapping and xterm supports customizing the--- scancode-to-input-byte mapping. With a lot of work a user's system--- can be set up to encode all the key combos in an almost-sane manner.------ == See also------ * http://www.leonerd.org.uk/hacks/fixterms/+-- | This module provides the input abstraction for Vty. module Graphics.Vty.Input- ( Key(..)- , Modifier(..)- , Button(..)- , Event(..)- , Input(..)- , inputForConfig+ ( Input(..)+ , module Graphics.Vty.Input.Events ) where -import Graphics.Vty.Config import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Loop-import Graphics.Vty.Input.Terminfo--import Control.Concurrent.STM-import Lens.Micro--import qualified System.Console.Terminfo as Terminfo-import System.Posix.Signals.Exts--#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif+import Control.Concurrent.STM (TChan) --- | Set up the terminal with file descriptor `inputFd` for input.--- Returns an 'Input'.------ The table used to determine the 'Events' to produce for the input--- bytes comes from 'classifyMapForTerm' which is then overridden by--- the the applicable entries from the configuration's 'inputMap'.------ The terminal device is configured with the attributes:------ * IXON disabled: disables software flow control on outgoing data.--- This stops the process from being suspended if the output terminal--- cannot keep up.------ * Raw mode is used for input.------ * ISIG disabled (enables keyboard combinations that result in--- signals)------ * ECHO disabled (input is not echoed to the output)------ * ICANON disabled (canonical mode (line mode) input is not used)------ * IEXTEN disabled (extended functions are disabled)-inputForConfig :: Config -> IO Input-inputForConfig config@Config{ termName = Just termName- , inputFd = Just termFd- , vmin = Just _- , vtime = Just _- , .. } = do- terminal <- Terminfo.setupTerm termName- let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]- activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides- (setAttrs,unsetAttrs) <- attributeControl termFd- setAttrs- input <- initInput config activeInputMap- let pokeIO = Catch $ do- let e = error "vty internal failure: this value should not propagate to users"- setAttrs- atomically $ writeTChan (input^.eventChannel) (EvResize e e)- _ <- installHandler windowChange pokeIO Nothing- _ <- installHandler continueProcess pokeIO Nothing- return $ input- { shutdownInput = do- shutdownInput input- _ <- installHandler windowChange Ignore Nothing- _ <- installHandler continueProcess Ignore Nothing- unsetAttrs- }-inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig+-- | The library's input-processing abstraction. Platform-specific+-- implementations must implement an 'Input' and provide it to+-- 'Graphics.Vty.mkVtyFromPair'.+data Input =+ Input { eventChannel :: TChan InternalEvent+ -- ^ A channel of events generated by input processing. The+ -- input implementation must write its input events to this+ -- channel; the Vty event loop will read from this channel+ -- and provide the events to the user's application via+ -- 'nextEvent'.+ , shutdownInput :: IO ()+ -- ^ Shut down the input processing. As part of shutting down+ -- the input, this should also restore the input state if+ -- appropriate.+ , restoreInputState :: IO ()+ -- ^ Restore the terminal's input state to what it was prior+ -- to configuring the input for Vty. This should be done as+ -- part of 'shutdownInput' but is exposed in case it needs to+ -- be used directly.+ , inputLogMsg :: String -> IO ()+ -- ^ Log the specified message.+ }
− src/Graphics/Vty/Input/Classify.hs
@@ -1,86 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- This makes a kind of tri. Has space efficiency issues with large--- input blocks. Likely building a parser and just applying that would--- be better.-module Graphics.Vty.Input.Classify- ( classify- , KClass(..)- )-where--import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Mouse-import Graphics.Vty.Input.Focus-import Graphics.Vty.Input.Paste-import Graphics.Vty.Input.Classify.Types--import Codec.Binary.UTF8.Generic (decode)--import Data.List (inits)-import qualified Data.Map as M( fromList, lookup )-import Data.Maybe ( mapMaybe )-import qualified Data.Set as S( fromList, member )--import Data.Char-import Data.Word--compile :: ClassifyMap -> [Char] -> KClass-compile table = cl' where- -- take all prefixes and create a set of these- prefixSet = S.fromList $ concatMap (init . inits . fst) $ table- maxValidInputLength = maximum (map (length . fst) table)- eventForInput = M.fromList table- cl' [] = Prefix- cl' inputBlock = case M.lookup inputBlock eventForInput of- -- if the inputBlock is exactly what is expected for an- -- event then consume the whole block and return the event- Just e -> Valid e []- Nothing -> case S.member inputBlock prefixSet of- True -> Prefix- -- look up progressively smaller tails of the input- -- block until an event is found The assumption is that- -- the event that consumes the most input bytes should- -- be produced.- -- The test verifyFullSynInputToEvent2x verifies this.- -- H: There will always be one match. The prefixSet- -- contains, by definition, all prefixes of an event.- False ->- let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock- in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of- (s,e) : _ -> Valid e (drop (length s) inputBlock)- -- neither a prefix or a full event.- [] -> Invalid--classify :: ClassifyMap -> [Char] -> KClass-classify table =- let standardClassifier = compile table- in \s -> case s of- _ | bracketedPasteStarted s ->- if bracketedPasteFinished s- then parseBracketedPaste s- else Prefix- _ | isMouseEvent s -> classifyMouseEvent s- _ | isFocusEvent s -> classifyFocusEvent s- c:cs | ord c >= 0xC2 -> classifyUtf8 c cs- _ -> standardClassifier s--classifyUtf8 :: Char -> [Char] -> KClass-classifyUtf8 c cs =- let n = utf8Length (ord c)- (codepoint,rest) = splitAt n (c:cs)-- codepoint8 :: [Word8]- codepoint8 = map (fromIntegral . ord) codepoint-- in case decode codepoint8 of- _ | n < length codepoint -> Prefix- Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest- -- something bad happened; just ignore and continue.- Nothing -> Invalid--utf8Length :: (Num t, Ord a, Num a) => a -> t-utf8Length c- | c < 0x80 = 1- | c < 0xE0 = 2- | c < 0xF0 = 3- | otherwise = 4
− src/Graphics/Vty/Input/Classify/Parse.hs
@@ -1,58 +0,0 @@--- | This module provides a simple parser for parsing input event--- control sequences.-module Graphics.Vty.Input.Classify.Parse- ( Parser- , runParser- , failParse- , readInt- , readChar- , expectChar- )-where--import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Classify.Types--import Control.Monad.Trans.Maybe-import Control.Monad.State--type Parser a = MaybeT (State String) a---- | Run a parser on a given input string. If the parser fails, return--- 'Invalid'. Otherwise return the valid event ('Valid') and the--- remaining unparsed characters.-runParser :: String -> Parser Event -> KClass-runParser s parser =- case runState (runMaybeT parser) s of- (Nothing, _) -> Invalid- (Just e, remaining) -> Valid e remaining---- | Fail a parsing operation.-failParse :: Parser a-failParse = fail "invalid parse"---- | Read an integer from the input stream. If an integer cannot be--- read, fail parsing. E.g. calling readInt on an input of "123abc" will--- return '123' and consume those characters.-readInt :: Parser Int-readInt = do- s <- get- case (reads :: ReadS Int) s of- [(i, rest)] -> put rest >> return i- _ -> failParse---- | Read a character from the input stream. If one cannot be read (e.g.--- we are out of characters), fail parsing.-readChar :: Parser Char-readChar = do- s <- get- case s of- c:rest -> put rest >> return c- _ -> failParse---- | Read a character from the input stream and fail parsing if it is--- not the specified character.-expectChar :: Char -> Parser ()-expectChar c = do- c' <- readChar- if c' == c then return () else failParse
− src/Graphics/Vty/Input/Classify/Types.hs
@@ -1,19 +0,0 @@--- | This module exports the input classification type to avoid import--- cycles between other modules that need this.-module Graphics.Vty.Input.Classify.Types- ( KClass(..)- )-where--import Graphics.Vty.Input.Events--data KClass- = Valid Event [Char]- -- ^ A valid event was parsed. Any unused characters from the input- -- stream are also provided.- | Invalid- -- ^ The input characters did not represent a valid event.- | Prefix- -- ^ The input characters form the prefix of a valid event character- -- sequence.- deriving(Show, Eq)
src/Graphics/Vty/Input/Events.hs view
@@ -1,6 +1,16 @@ {-# Language DeriveGeneric #-}-module Graphics.Vty.Input.Events where+{-# Language StrictData #-}+module Graphics.Vty.Input.Events+ ( Key(..)+ , Modifier(..)+ , Event(..)+ , Button(..)+ , ClassifyMap+ , InternalEvent(..)+ )+where +import Control.DeepSeq import Data.ByteString import GHC.Generics @@ -14,23 +24,38 @@ -- -- * Actually, support for most of these but KEsc, KChar, KBS, and -- KEnter vary by terminal and keyboard.-data Key = KEsc | KChar Char | KBS | KEnter+data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter- | KFun Int | KBackTab | KPrtScr | KPause | KIns+ | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu- deriving (Eq,Show,Read,Ord,Generic)+ deriving (Eq, Show, Read, Ord, Generic) +instance NFData Key+ -- | Modifier keys. Key codes are interpreted such that users are more -- likely to have Meta than Alt; for instance on the PC Linux console, -- 'MMeta' will generally correspond to the physical Alt key. data Modifier = MShift | MCtrl | MMeta | MAlt- deriving (Eq,Show,Read,Ord,Generic)+ deriving (Eq, Show, Read, Ord, Generic) +instance NFData Modifier+ -- | Mouse buttons.-data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown- deriving (Eq,Show,Read,Ord,Generic)+data Button+ = BLeft+ | BMiddle+ | BRight+ | BScrollUp+ | BScrollDown+ | BScrollLeft+ -- ^ Some terminals (e.g., Kitty, Alacritty) support horizontal+ -- scrolling in addition to vertical scrolling.+ | BScrollRight+ deriving (Eq, Show, Read, Ord, Generic) +instance NFData Button+ -- | Events. data Event = EvKey Key [Modifier]@@ -44,10 +69,8 @@ -- without specifying which one; in that case, Nothing is provided. -- Otherwise Just the button released is included in the event. | EvResize Int Int- -- ^ If read from 'eventChannel' this is the size at the time of the- -- signal. If read from 'nextEvent' this is the size at the time the- -- event was processed by Vty. Typically these are the same, but if- -- somebody is resizing the terminal quickly they can be different.+ -- The terminal window was resized and the size is provided in the+ -- integer fields (width, height). | EvPaste ByteString -- ^ A paste event occurs when a bracketed paste input sequence is -- received. For terminals that support bracketed paste mode, these@@ -60,6 +83,18 @@ -- ^ The terminal running the application lost input focus. | EvGainedFocus -- ^ The terminal running the application gained input focus.- deriving (Eq,Show,Read,Ord,Generic)+ deriving (Eq, Show, Read, Ord, Generic) +instance NFData Event+ type ClassifyMap = [(String,Event)]++-- | The type of internal events that drive the internal Vty event+-- dispatching to the application.+data InternalEvent =+ ResumeAfterInterrupt+ -- ^ Vty resumed operation after the process was interrupted (e.g.+ -- with a signal). In practice this translates into a screen redraw+ -- in the input event loop.+ | InputEvent Event+ -- ^ An input event was received.
− src/Graphics/Vty/Input/Focus.hs
@@ -1,47 +0,0 @@-module Graphics.Vty.Input.Focus- ( requestFocusEvents- , disableFocusEvents- , isFocusEvent- , classifyFocusEvent- )-where--import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Classify.Types-import Graphics.Vty.Input.Classify.Parse--import Control.Monad.State-import Data.List (isPrefixOf)---- | These sequences set xterm-based terminals to send focus event--- sequences.-requestFocusEvents :: String-requestFocusEvents = "\ESC[?1004h"---- | These sequences disable focus events.-disableFocusEvents :: String-disableFocusEvents = "\ESC[?1004l"---- | Does the specified string begin with a focus event?-isFocusEvent :: String -> Bool-isFocusEvent s = isPrefixOf focusIn s ||- isPrefixOf focusOut s--focusIn :: String-focusIn = "\ESC[I"--focusOut :: String-focusOut = "\ESC[O"---- | Attempt to classify an input string as a focus event.-classifyFocusEvent :: String -> KClass-classifyFocusEvent s = runParser s $ do- when (not $ isFocusEvent s) failParse-- expectChar '\ESC'- expectChar '['- ty <- readChar- case ty of- 'I' -> return EvGainedFocus- 'O' -> return EvLostFocus- _ -> failParse
− src/Graphics/Vty/Input/Loop.hs
@@ -1,229 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}--- | The input layer used to be a single function that correctly--- accounted for the non-threaded runtime by emulating the terminal--- VMIN adn VTIME handling. This has been removed and replace with a--- more straightforward parser. The non-threaded runtime is no longer--- supported.------ This is an example of an algorithm where code coverage could be high,--- even 100%, but the behavior is still under tested. I should collect--- more of these examples...------ reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html-module Graphics.Vty.Input.Loop where--import Graphics.Vty.Config-import Graphics.Vty.Input.Classify-import Graphics.Vty.Input.Events--import Control.Applicative-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception (mask, try, SomeException)-import Lens.Micro hiding ((<>~))-import Lens.Micro.Mtl-import Lens.Micro.TH-import Control.Monad (when, mzero, forM_)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.State (StateT(..), evalStateT)-import Control.Monad.State.Class (MonadState, modify)-import Control.Monad.Trans.Reader (ReaderT(..))--import Data.Char-import Data.IORef-import Data.Word (Word8)--import Foreign ( allocaArray, peekArray, Ptr )-import Foreign.C.Types (CInt(..))--import System.IO-import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))-import System.Posix.Terminal-import System.Posix.Types (Fd(..))--import Text.Printf (hPrintf)--data Input = Input- { -- | Channel of events direct from input processing. Unlike- -- 'nextEvent' this will not refresh the display if the next event- -- is an 'EvResize'.- _eventChannel :: TChan Event- -- | Shuts down the input processing. This should return the- -- terminal input state to before he input initialized.- , shutdownInput :: IO ()- -- | Changes to this value are reflected after the next event.- , _configRef :: IORef Config- -- | input debug log- , _inputDebug :: Maybe Handle- }--makeLenses ''Input--data InputBuffer = InputBuffer- { _ptr :: Ptr Word8- , _size :: Int- }--makeLenses ''InputBuffer--data InputState = InputState- { _unprocessedBytes :: String- , _appliedConfig :: Config- , _inputBuffer :: InputBuffer- , _classifier :: String -> KClass- }--makeLenses ''InputState--type InputM a = StateT InputState (ReaderT Input IO) a--logMsg :: String -> InputM ()-logMsg msg = do- d <- view inputDebug- case d of- Nothing -> return ()- Just h -> liftIO $ hPutStrLn h msg >> hFlush h---- this must be run on an OS thread dedicated to this input handling.--- otherwise the terminal timing read behavior will block the execution--- of the lightweight threads.-loopInputProcessor :: InputM ()-loopInputProcessor = do- readFromDevice >>= addBytesToProcess- validEvents <- many parseEvent- forM_ validEvents emit- dropInvalid- loopInputProcessor--addBytesToProcess :: String -> InputM ()-addBytesToProcess block = unprocessedBytes <>= block--emit :: Event -> InputM ()-emit event = do- logMsg $ "parsed event: " ++ show event- view eventChannel >>= liftIO . atomically . flip writeTChan event---- The timing requirements are assured by the VMIN and VTIME set for the--- device.------ Precondition: Under the threaded runtime. Only current use is from a--- forkOS thread. That case satisfies precondition.-readFromDevice :: InputM String-readFromDevice = do- newConfig <- view configRef >>= liftIO . readIORef- oldConfig <- use appliedConfig- let Just fd = inputFd newConfig- when (newConfig /= oldConfig) $ do- logMsg $ "new config: " ++ show newConfig- liftIO $ applyConfig fd newConfig- appliedConfig .= newConfig- bufferPtr <- use $ inputBuffer.ptr- maxBytes <- use $ inputBuffer.size- stringRep <- liftIO $ do- -- The killThread used in shutdownInput will not interrupt the- -- foreign call fdReadBuf uses this provides a location to be- -- interrupted prior to the foreign call. If there is input on- -- the FD then the fdReadBuf will return in a finite amount of- -- time due to the vtime terminal setting.- threadWaitRead fd- bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)- if bytesRead > 0- then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr- else return []- when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep- return stringRep--applyConfig :: Fd -> Config -> IO ()-applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })- = setTermTiming fd theVmin (theVtime `div` 100)-applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"--parseEvent :: InputM Event-parseEvent = do- c <- use classifier- b <- use unprocessedBytes- case c b of- Valid e remaining -> do- logMsg $ "valid parse: " ++ show e- logMsg $ "remaining: " ++ show remaining- unprocessedBytes .= remaining- return e- _ -> mzero--dropInvalid :: InputM ()-dropInvalid = do- c <- use classifier- b <- use unprocessedBytes- when (c b == Invalid) $ do- logMsg "dropping input bytes"- unprocessedBytes .= []--runInputProcessorLoop :: ClassifyMap -> Input -> IO ()-runInputProcessorLoop classifyTable input = do- let bufferSize = 1024- allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do- s0 <- InputState [] <$> readIORef (_configRef input)- <*> pure (InputBuffer bufferPtr bufferSize)- <*> pure (classify classifyTable)- runReaderT (evalStateT loopInputProcessor s0) input--attributeControl :: Fd -> IO (IO (), IO ())-attributeControl fd = do- original <- getTerminalAttributes fd- let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts- , EnableEcho, ProcessInput, ExtendedFunctions- ]- let setAttrs = setTerminalAttributes fd vtyMode Immediately- unsetAttrs = setTerminalAttributes fd original Immediately- return (setAttrs,unsetAttrs)--logInitialInputState :: Input -> ClassifyMap -> IO()-logInitialInputState input classifyTable = case _inputDebug input of- Nothing -> return ()- Just h -> do- Config{ vmin = Just theVmin- , vtime = Just theVtime- , termName = Just theTerm, .. } <- readIORef $ _configRef input- _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))- forM_ classifyTable $ \i -> case i of- (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)- (show inBytes)- (show k)- (show mods)- _ -> return ()--initInput :: Config -> ClassifyMap -> IO Input-initInput config classifyTable = do- let Just fd = inputFd config- setFdOption fd NonBlockingRead False- applyConfig fd config- stopSync <- newEmptyMVar- input <- Input <$> atomically newTChan- <*> pure (return ())- <*> newIORef config- <*> maybe (return Nothing)- (\f -> Just <$> openFile f AppendMode)- (debugLog config)- logInitialInputState input classifyTable- inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input)- (\_ -> putMVar stopSync ())- let killAndWait = do- killThread inputThread- takeMVar stopSync- return $ input { shutdownInput = killAndWait }--foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()--forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkOSFinally action and_then =- mask $ \restore -> forkOS $ try (restore action) >>= and_then--(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()-l <>= a = modify (l <>~ a)--(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t-l <>~ n = over l (`mappend` n)
− src/Graphics/Vty/Input/Mouse.hs
@@ -1,161 +0,0 @@--- | This module provides parsers for mouse events for both "normal" and--- "extended" modes. This implementation was informed by------ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking-module Graphics.Vty.Input.Mouse- ( requestMouseEvents- , disableMouseEvents- , isMouseEvent- , classifyMouseEvent- )-where--import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Classify.Types-import Graphics.Vty.Input.Classify.Parse--import Control.Monad.State-import Data.List (isPrefixOf)-import Data.Maybe (catMaybes)-import Data.Bits ((.&.))---- A mouse event in SGR extended mode is------ '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')------ where------ * B is the number with button and modifier bits set,--- * X is the X coordinate of the event starting at 1--- * Y is the Y coordinate of the event starting at 1--- * the final character is 'M' for a press, 'm' for a release---- | These sequences set xterm-based terminals to send mouse event--- sequences.-requestMouseEvents :: String-requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h"---- | These sequences disable mouse events.-disableMouseEvents :: String-disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l"---- | Does the specified string begin with a mouse event?-isMouseEvent :: String -> Bool-isMouseEvent s = isSGREvent s || isNormalEvent s--isSGREvent :: String -> Bool-isSGREvent = isPrefixOf sgrPrefix--sgrPrefix :: String-sgrPrefix = "\ESC[M"--isNormalEvent :: String -> Bool-isNormalEvent = isPrefixOf normalPrefix--normalPrefix :: String-normalPrefix = "\ESC[<"---- Modifier bits:-shiftBit :: Int-shiftBit = 4--metaBit :: Int-metaBit = 8--ctrlBit :: Int-ctrlBit = 16---- These bits indicate the buttons involved:-buttonMask :: Int-buttonMask = 67--leftButton :: Int-leftButton = 0--middleButton :: Int-middleButton = 1--rightButton :: Int-rightButton = 2--scrollUp :: Int-scrollUp = 64--scrollDown :: Int-scrollDown = 65--hasBitSet :: Int -> Int -> Bool-hasBitSet val bit = val .&. bit > 0---- | Attempt to lassify an input string as a mouse event.-classifyMouseEvent :: String -> KClass-classifyMouseEvent s = runParser s $ do- when (not $ isMouseEvent s) failParse-- expectChar '\ESC'- expectChar '['- ty <- readChar- case ty of- '<' -> classifySGRMouseEvent- 'M' -> classifyNormalMouseEvent- _ -> failParse---- Given a modifer/button value, determine which button was indicated-getSGRButton :: Int -> Parser Button-getSGRButton mods =- let buttonMap = [ (leftButton, BLeft)- , (middleButton, BMiddle)- , (rightButton, BRight)- , (scrollUp, BScrollUp)- , (scrollDown, BScrollDown)- ]- in case lookup (mods .&. buttonMask) buttonMap of- Nothing -> failParse- Just b -> return b--getModifiers :: Int -> [Modifier]-getModifiers mods =- catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing- , if mods `hasBitSet` metaBit then Just MMeta else Nothing- , if mods `hasBitSet` ctrlBit then Just MCtrl else Nothing- ]---- Attempt to classify a control sequence as a "normal" mouse event. To--- get here we should have already read "\ESC[M" so that will not be--- included in the string to be parsed.-classifyNormalMouseEvent :: Parser Event-classifyNormalMouseEvent = do- statusChar <- readChar- xCoordChar <- readChar- yCoordChar <- readChar-- let xCoord = fromEnum xCoordChar - 32- yCoord = fromEnum yCoordChar - 32- status = fromEnum statusChar- modifiers = getModifiers status-- let press = status .&. buttonMask /= 3- case press of- True -> do- button <- getSGRButton status- return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers- False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing---- Attempt to classify a control sequence as an SGR mouse event. To--- get here we should have already read "\ESC[<" so that will not be--- included in the string to be parsed.-classifySGRMouseEvent :: Parser Event-classifySGRMouseEvent = do- mods <- readInt- expectChar ';'- xCoord <- readInt- expectChar ';'- yCoord <- readInt- final <- readChar-- let modifiers = getModifiers mods- button <- getSGRButton mods- case final of- 'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers- 'm' -> return $ EvMouseUp (xCoord-1) (yCoord-1) (Just button)- _ -> failParse
− src/Graphics/Vty/Input/Paste.hs
@@ -1,49 +0,0 @@--- | This module provides bracketed paste support as described at------ http://cirw.in/blog/bracketed-paste-module Graphics.Vty.Input.Paste- ( parseBracketedPaste- , bracketedPasteStarted- , bracketedPasteFinished- )-where--import qualified Data.ByteString.Char8 as BS8--import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Classify.Types--import Data.List (isPrefixOf, isInfixOf)--bracketedPasteStart :: String-bracketedPasteStart = "\ESC[200~"--bracketedPasteEnd :: String-bracketedPasteEnd = "\ESC[201~"---- | Does the input start a bracketed paste?-bracketedPasteStarted :: String -> Bool-bracketedPasteStarted = isPrefixOf bracketedPasteStart---- | Does the input contain a complete bracketed paste?-bracketedPasteFinished :: String -> Bool-bracketedPasteFinished = isInfixOf bracketedPasteEnd---- | Parse a bracketed paste. This should only be called on a string if--- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return--- 'True'.-parseBracketedPaste :: String -> KClass-parseBracketedPaste s =- let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd- rest' = if bracketedPasteEnd `isPrefixOf` rest- then drop (length bracketedPasteEnd) rest- else rest- in Valid (EvPaste $ BS8.pack p) rest'--takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])-takeUntil [] _ = ([], [])-takeUntil cs sub- | length cs < length sub = (cs, [])- | take (length sub) cs == sub = ([], drop (length sub) cs)- | otherwise = let (pre, suf) = takeUntil (tail cs) sub- in (head cs:pre, suf)
− src/Graphics/Vty/Input/Terminfo.hs
@@ -1,184 +0,0 @@-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-module Graphics.Vty.Input.Terminfo where--import Graphics.Vty.Input.Events-import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT--import Control.Arrow-import System.Console.Terminfo---- | Queries the terminal for all capability-based input sequences and--- then adds on a terminal-dependent input sequence mapping.------ For reference see:------ * http://vimdoc.sourceforge.net/htmldoc/term.html------ * vim74/src/term.c------ * http://invisible-island.net/vttest/------ * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html------ Terminfo is incomplete. The vim source implies that terminfo is also--- incorrect. Vty assumes that the internal terminfo table added to the--- system-provided terminfo table is correct.------ The procedure used here is:------ 1. Build terminfo table for all caps. Missing caps are not added.------ 2. Add tables for visible chars, esc, del, ctrl, and meta.------ 3. Add internally-defined table for given terminal type.------ Precedence is currently implicit in the 'compile' algorithm.-classifyMapForTerm :: String -> Terminal -> ClassifyMap-classifyMapForTerm termName term =- concat $ capsClassifyMap term keysFromCapsTable- : universalTable- : termSpecificTables termName---- | The key table applicable to all terminals.------ Note that some of these entries are probably only applicable to--- ANSI/VT100 terminals.-universalTable :: ClassifyMap-universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]--capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap-capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]- where extractCap = first (getCapability terminal . tiGetStr)---- | Tables specific to a given terminal that are not derivable from--- terminfo.------ Note that this adds the ANSI/VT100/VT50 tables regardless of term--- identifier.-termSpecificTables :: String -> [ClassifyMap]-termSpecificTables _termName = ANSIVT.classifyTable---- | Visible characters in the ISO-8859-1 and UTF-8 common set.------ We limit to < 0xC1. The UTF8 sequence detector will catch all values--- 0xC2 and above before this classify table is reached.-visibleChars :: ClassifyMap-visibleChars = [ ([x], EvKey (KChar x) [])- | x <- [' ' .. toEnum 0xC1]- ]---- | Non-printable characters in the ISO-8859-1 and UTF-8 common set--- translated to ctrl + char.------ This treats CTRL-i the same as tab.-ctrlChars :: ClassifyMap-ctrlChars =- [ ([toEnum x],EvKey (KChar y) [MCtrl])- | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])- , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.- , y /= 'h' -- CTRL-h should not hide BS- ]---- | Ctrl+Meta+Char-ctrlMetaChars :: ClassifyMap-ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars---- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.-specialSupportKeys :: ClassifyMap-specialSupportKeys =- [ -- special support for ESC- ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])- -- Special support for backspace- , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])- -- Special support for Enter- , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])- -- explicit support for tab- , ("\t", EvKey (KChar '\t') [])- ]---- | A classification table directly generated from terminfo cap--- strings. These are:------ * ka1 - keypad up-left------ * ka3 - keypad up-right------ * kb2 - keypad center------ * kbs - keypad backspace------ * kbeg - begin------ * kcbt - back tab------ * kc1 - keypad left-down------ * kc3 - keypad right-down------ * kdch1 - delete------ * kcud1 - down------ * kend - end------ * kent - enter------ * kf0 - kf63 - function keys------ * khome - KHome------ * kich1 - insert------ * kcub1 - left------ * knp - next page (page down)------ * kpp - previous page (page up)------ * kcuf1 - right------ * kDC - shift delete------ * kEND - shift end------ * kHOM - shift home------ * kIC - shift insert------ * kLFT - shift left------ * kRIT - shift right------ * kcuu1 - up-keysFromCapsTable :: ClassifyMap-keysFromCapsTable =- [ ("ka1", EvKey KUpLeft [])- , ("ka3", EvKey KUpRight [])- , ("kb2", EvKey KCenter [])- , ("kbs", EvKey KBS [])- , ("kbeg", EvKey KBegin [])- , ("kcbt", EvKey KBackTab [])- , ("kc1", EvKey KDownLeft [])- , ("kc3", EvKey KDownRight [])- , ("kdch1", EvKey KDel [])- , ("kcud1", EvKey KDown [])- , ("kend", EvKey KEnd [])- , ("kent", EvKey KEnter [])- , ("khome", EvKey KHome [])- , ("kich1", EvKey KIns [])- , ("kcub1", EvKey KLeft [])- , ("knp", EvKey KPageDown [])- , ("kpp", EvKey KPageUp [])- , ("kcuf1", EvKey KRight [])- , ("kDC", EvKey KDel [MShift])- , ("kEND", EvKey KEnd [MShift])- , ("kHOM", EvKey KHome [MShift])- , ("kIC", EvKey KIns [MShift])- , ("kLFT", EvKey KLeft [MShift])- , ("kRIT", EvKey KRight [MShift])- , ("kcuu1", EvKey KUp [])- ] ++ functionKeyCapsTable---- | Cap names for function keys.-functionKeyCapsTable :: ClassifyMap-functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
− src/Graphics/Vty/Input/Terminfo/ANSIVT.hs
@@ -1,88 +0,0 @@--- | Input mappings for ANSI/VT100/VT50 terminals that is missing from--- terminfo.------ Or that are sent regardless of terminfo by terminal emulators. EG:--- Terminal emulators will often use VT50 input bytes regardless of--- declared terminal type. This provides compatibility with programs--- that don't follow terminfo.-module Graphics.Vty.Input.Terminfo.ANSIVT where--import Graphics.Vty.Input.Events---- | Encoding for navigation keys.-navKeys0 :: ClassifyMap-navKeys0 =- [ k "G" KCenter- , k "P" KPause- , k "A" KUp- , k "B" KDown- , k "C" KRight- , k "D" KLeft- , k "H" KHome- , k "F" KEnd- , k "E" KBegin- ]- where k c s = ("\ESC["++c,EvKey s [])---- | encoding for shift, meta and ctrl plus arrows/home/end-navKeys1 :: ClassifyMap-navKeys1 =- [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)- | charCnt <- ["1;", ""], -- we can have a count or not- (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),- -- modifiers and their codes- ([MShift, MCtrl],6), ([MShift, MMeta],4)],- -- directions and their codes- (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)]- ]---- | encoding for ins, del, pageup, pagedown, home, end-navKeys2 :: ClassifyMap-navKeys2 =- let k n s = ("\ESC["++show n++"~",EvKey s [])- in zipWith k [2::Int,3,5,6,1,4]- [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]---- | encoding for ctrl + ins, del, pageup, pagedown, home, end-navKeys3 :: ClassifyMap-navKeys3 =- let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])- in zipWith k [2::Int,3,5,6,1,4]- [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]---- | encoding for shift plus function keys------ According to------ * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html------ This encoding depends on the terminal.-functionKeys1 :: ClassifyMap-functionKeys1 =- let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in- concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]---- | encoding for meta plus char------ 1. removed 'ESC' from second list due to duplication with--- "special_support_keys".--- 2. removed '[' from second list due to conflict with 7-bit encoding--- for ESC. Whether meta+[ is the same as ESC should examine km and--- current encoding.--- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped--- to KBS by special_support_keys.-functionKeys2 :: ClassifyMap-functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])- | x <- '\t':[' ' .. '~']- , x /= '['- ]--classifyTable :: [ClassifyMap]-classifyTable =- [ navKeys0- , navKeys1- , navKeys2- , navKeys3- , functionKeys1- , functionKeys2- ]
src/Graphics/Vty/Output.hs view
@@ -1,83 +1,132 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, CPP #-}--- | This module provides functions for accessing the current terminal--- or a specific terminal device.------ See also:------ 1. "Graphics.Vty.Output": This instantiates an abtract interface--- to the terminal based on the @TERM@ and @COLORTERM@ environment--- variables.------ 2. "Graphics.Vty.Output.Interface": Defines the generic interface all--- terminal modules need to implement.------ 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance--- that uses terminfo for all control strings. No attempt is made to--- change the character set to UTF-8 for these terminals.------ 4. "Graphics.Vty.Output.XTermColor": This module contains an--- interface suitable for xterm-like terminals. These are the terminals--- where @TERM@ begins with @xterm@. This does use terminfo for as many--- control codes as possible.+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards, CPP #-}+-- | This module provides an abstract interface for performing terminal+-- output and functions for accessing the current terminal or a specific+-- terminal device. module Graphics.Vty.Output- ( outputForConfig+ ( Output(..)+ , AssumedState(..)+ , DisplayContext(..)+ , Mode(..)+ , displayContext+ , outputPicture+ , initialAssumedState+ , limitAttrForDisplay , setCursorPos , hideCursor , showCursor ) where +import Blaze.ByteString.Builder (Write, writeToByteString)+import Blaze.ByteString.Builder.ByteString (writeByteString) import Control.Monad (when)--import Graphics.Vty.Config-import Graphics.Vty.Image (regionWidth, regionHeight)-import Graphics.Vty.Output.Interface-import Graphics.Vty.Output.XTermColor as XTermColor-import Graphics.Vty.Output.TerminfoBased as TerminfoBased--import Blaze.ByteString.Builder (writeToByteString)--import Data.List (isPrefixOf)-+import qualified Data.ByteString as BS+import Data.IORef+import qualified Data.Vector as Vector #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif---- | Returns an `Output` for the terminal specified in `Config`.------ The specific Output implementation used is hidden from the API user.--- All terminal implementations are assumed to perform more, or less,--- the same. Currently, all implementations use terminfo for at least--- some terminal specific information.------ If a terminal implementation is developed for a terminal without--- terminfo support then Vty should work as expected on that terminal.------ Selection of a terminal is done as follows:------ * If TERM contains "xterm" or "screen", use XTermColor.--- * otherwise use the TerminfoBased driver.-outputForConfig :: Config -> IO Output-outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do- t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName- then XTermColor.reserveTerminal termName fd- -- Not an xterm-like terminal. try for generic terminfo.- else TerminfoBased.reserveTerminal termName fd+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL - case mouseMode of- Just s -> setMode t Mouse s- Nothing -> return ()+import Graphics.Vty.Attributes+import Graphics.Vty.DisplayAttributes+import Graphics.Vty.Image (DisplayRegion, regionWidth, regionHeight)+import Graphics.Vty.Picture+import Graphics.Vty.PictureToSpans+import Graphics.Vty.Span - case bracketedPasteMode of- Just s -> setMode t BracketedPaste s- Nothing -> return ()+-- | Modal terminal features that can be enabled and disabled.+data Mode = Mouse+ -- ^ Mouse mode (whether the terminal is configured to provide+ -- mouse input events)+ | BracketedPaste+ -- ^ Paste mode (whether the terminal is configured to provide+ -- events on OS pastes)+ | Focus+ -- ^ Focus-in/focus-out events (whether the terminal is+ -- configured to provide events on focus change)+ | Hyperlink+ -- ^ Hyperlink mode via the 'withURL' attribute modifier (see+ -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).+ -- Note that this may not work gracefully in all terminal+ -- emulators so be sure to test this mode with the terminals+ -- you intend to support. It is off by default.+ deriving (Eq, Read, Show) - return t-outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig+-- | The library's device output abstraction. Platform-specific+-- implementations must implement an 'Output' and provide it to+-- 'Graphics.Vty.mkVtyFromPair'.+data Output = Output+ { -- | Text identifier for the output device. Used for debugging.+ terminalID :: String+ -- | Release the terminal just prior to application exit and reset+ -- it to its state prior to application startup.+ , releaseTerminal :: IO ()+ -- | Clear the display and initialize the terminal to some initial+ -- display state.+ --+ -- The expectation of a program is that the display starts in some+ -- The initial state. initial state would consist of fixed values:+ --+ -- - cursor at top left+ -- - UTF-8 character encoding+ -- - drawing characteristics are the default+ , reserveDisplay :: IO ()+ -- | Return the display to the state before `reserveDisplay` If no+ -- previous state then set the display state to the initial state.+ , releaseDisplay :: IO ()+ -- | Sets the current display bounds (width, height).+ , setDisplayBounds :: (Int, Int) -> IO ()+ -- | Returns the current display bounds.+ , displayBounds :: IO DisplayRegion+ -- | Output the bytestring to the terminal device.+ , outputByteBuffer :: BS.ByteString -> IO ()+ -- | Specifies whether the cursor can be shown / hidden.+ , supportsCursorVisibility :: Bool+ -- | Indicates support for terminal modes for this output device.+ , supportsMode :: Mode -> Bool+ -- | Enables or disables a mode (does nothing if the mode is+ -- unsupported).+ , setMode :: Mode -> Bool -> IO ()+ -- | Returns whether a mode is enabled.+ , getModeStatus :: Mode -> IO Bool+ , assumedStateRef :: IORef AssumedState+ -- | Acquire display access to the given region of the display.+ -- Currently all regions have the upper left corner of (0,0) and+ -- the lower right corner at (max displayWidth providedWidth, max+ -- displayHeight providedHeight)+ , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext+ -- | Ring the terminal bell if supported.+ , ringTerminalBell :: IO ()+ -- | Returns whether the terminal has an audio bell feature.+ , supportsBell :: IO Bool+ -- | Returns whether the terminal supports italicized text.+ --+ -- This is terminal-dependent and should make a best effort to+ -- determine whether this feature is supported, but even if the+ -- terminal advertises support (e.g. via terminfo) that might not+ -- be a reliable indicator of whether the feature will work as+ -- desired.+ , supportsItalics :: IO Bool+ -- | Returns whether the terminal supports strikethrough text.+ --+ -- This is terminal-dependent and should make a best effort to+ -- determine whether this feature is supported, but even if the+ -- terminal advertises support (e.g. via terminfo) that might not+ -- be a reliable indicator of whether the feature will work as+ -- desired.+ , supportsStrikethrough :: IO Bool+ -- | Returns how many colors the terminal supports.+ , outputColorMode :: ColorMode+ -- | Set the output's window title, if any.+ , setOutputWindowTitle :: String -> IO ()+ } -- | Sets the cursor position to the given output column and row. ----- This is not necessarially the same as the character position with the+-- This is not necessarily the same as the character position with the -- same coordinates. Characters can be a variable number of columns in -- width. --@@ -104,3 +153,215 @@ bounds <- displayBounds t dc <- displayContext t bounds outputByteBuffer t $ writeToByteString $ writeShowCursor dc++displayContext :: Output -> DisplayRegion -> IO DisplayContext+displayContext t = mkDisplayContext t t++data AssumedState = AssumedState+ { prevFattr :: Maybe FixedAttr+ , prevOutputOps :: Maybe DisplayOps+ }++initialAssumedState :: AssumedState+initialAssumedState = AssumedState Nothing Nothing++data DisplayContext = DisplayContext+ { contextDevice :: Output+ -- | Provide the bounds of the display context.+ , contextRegion :: DisplayRegion+ -- | Sets the output position to the specified row and column+ -- where the number of bytes required for the control codes can be+ -- specified seperate from the actual byte sequence.+ , writeMoveCursor :: Int -> Int -> Write+ , writeShowCursor :: Write+ , writeHideCursor :: Write+ -- Ensure that the specified output attributes will be applied to+ -- all the following text until the next output attribute change+ -- where the number of bytes required for the control codes can be+ -- specified seperately from the actual byte sequence. The required+ -- number of bytes must be at least the maximum number of bytes+ -- required by any attribute changes. The serialization equations+ -- must provide the ptr to the next byte to be specified in the+ -- output buffer.+ --+ -- The currently applied display attributes are provided as well.+ -- The Attr data type can specify the style or color should not be+ -- changed from the currently applied display attributes. In order+ -- to support this the currently applied display attributes are+ -- required. In addition it may be possible to optimize the state+ -- changes based off the currently applied display attributes.+ , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write+ -- | Reset the display attributes to the default display attributes.+ , writeDefaultAttr :: Bool -> Write+ , writeRowEnd :: Write+ -- | See `Graphics.Vty.Output.XTermColor.inlineHack`+ , inlineHack :: IO ()+ }++-- | All terminals serialize UTF8 text to the terminal device exactly as+-- serialized in memory.+writeUtf8Text :: BS.ByteString -> Write+writeUtf8Text = writeByteString++-- | Displays the given `Picture`.+--+-- 1. The image is cropped to the display size.+--+-- 2. Converted into a sequence of attribute changes and text spans.+--+-- 3. The cursor is hidden.+--+-- 4. Serialized to the display.+--+-- 5. The cursor is then shown and positioned or kept hidden.+outputPicture :: DisplayContext -> Picture -> IO ()+outputPicture dc pic = do+ urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink+ as <- readIORef (assumedStateRef $ contextDevice dc)+ let manipCursor = supportsCursorVisibility (contextDevice dc)+ r = contextRegion dc+ ops = displayOpsForPic pic r+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing+ -- Diff the previous output against the requested output.+ -- Differences are currently on a per-row basis.+ diffs :: [Bool] = case prevOutputOps as of+ Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True+ Just previousOps -> if affectedRegion previousOps /= affectedRegion ops+ then replicate (displayOpsRows ops) True+ else Vector.toList $ Vector.zipWith (/=) previousOps ops+ -- build the Write corresponding to the output image+ out = (if manipCursor then writeHideCursor dc else mempty)+ `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops+ `mappend`+ (let (w,h) = contextRegion dc+ clampX = max 0 . min (w-1)+ clampY = max 0 . min (h-1) in+ case picCursor pic of+ _ | not manipCursor -> mempty+ NoCursor -> mempty+ AbsoluteCursor x y ->+ writeShowCursor dc `mappend`+ writeMoveCursor dc (clampX x) (clampY y)+ PositionOnly isAbs x y ->+ if isAbs+ then writeMoveCursor dc (clampX x) (clampY y)+ else let (ox, oy) = charToOutputPos m (clampX x, clampY y)+ m = cursorOutputMap ops $ picCursor pic+ in writeMoveCursor dc (clampX ox) (clampY oy)+ Cursor x y ->+ let m = cursorOutputMap ops $ picCursor pic+ (ox, oy) = charToOutputPos m (clampX x, clampY y)+ in writeShowCursor dc `mappend`+ writeMoveCursor dc (clampX ox) (clampY oy)+ )+ -- ... then serialize+ outputByteBuffer (contextDevice dc) (writeToByteString out)+ -- Cache the output spans.+ let as' = as { prevOutputOps = Just ops }+ writeIORef (assumedStateRef $ contextDevice dc) as'++writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write+writeOutputOps urlsEnabled dc initialAttr diffs ops =+ let (_, out, _) = Vector.foldl' writeOutputOps'+ (0, mempty, diffs)+ ops+ in out+ where+ writeOutputOps' (y, out, True : diffs') spanOps+ = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps+ out' = out `mappend` spanOut+ in (y+1, out', diffs')+ writeOutputOps' (y, out, False : diffs') _spanOps+ = (y + 1, out, diffs')+ writeOutputOps' (_y, _out, []) _spanOps+ = error "vty - output spans without a corresponding diff."++writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write+writeSpanOps urlsEnabled dc y initialAttr spanOps =+ -- The first operation is to set the cursor to the start of the row+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled+ -- then the span ops are serialized in the order specified+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of+ (opOut, fattr') -> (out `mappend` opOut, fattr')+ )+ (start, initialAttr)+ spanOps++writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =+ let attr' = limitAttrForDisplay (contextDevice dc) attr+ fattr' = fixDisplayAttr fattr attr'+ diffs = displayAttrDiffs fattr fattr'+ out = writeSetAttr dc urlsEnabled fattr attr' diffs+ `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)+ in (out, fattr')+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)++-- | The cursor position is given in X,Y character offsets. Due to+-- multi-column characters this needs to be translated to column, row+-- positions.+data CursorOutputMap = CursorOutputMap+ { charToOutputPos :: (Int, Int) -> (Int, Int)+ }++cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap+cursorOutputMap spanOps _cursor = CursorOutputMap+ { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)+ }++cursorColumnOffset :: DisplayOps -> Int -> Int -> Int+cursorColumnOffset ops cx cy =+ let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)+ (outOffset, _, _)+ = Vector.foldl' ( \(d, currentCx, done) op ->+ if done then (d, currentCx, done) else case spanOpHasWidth op of+ Nothing -> (d, currentCx, False)+ Just (cw, ow) -> case compare cx (currentCx + cw) of+ GT -> ( d + ow+ , currentCx + cw+ , False+ )+ EQ -> ( d + ow+ , currentCx + cw+ , True+ )+ LT -> ( d + columnsToCharOffset (cx - currentCx) op+ , currentCx + cw+ , True+ )+ )+ (0, 0, False)+ cursorRowOps+ in outOffset++-- | Not all terminals support all display attributes. This filters a+-- display attribute to what the given terminal can display.+limitAttrForDisplay :: Output -> Attr -> Attr+limitAttrForDisplay t attr+ = attr { attrForeColor = clampColor $ attrForeColor attr+ , attrBackColor = clampColor $ attrBackColor attr+ }+ where+ clampColor Default = Default+ clampColor KeepCurrent = KeepCurrent+ clampColor (SetTo c) = clampColor' (outputColorMode t) c++ clampColor' NoColor _ = Default++ clampColor' ColorMode8 (ISOColor v)+ | v >= 8 = SetTo $ ISOColor (v - 8)+ | otherwise = SetTo $ ISOColor v+ clampColor' ColorMode8 _ = Default++ clampColor' ColorMode16 c@(ISOColor _) = SetTo c+ clampColor' ColorMode16 _ = Default++ clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c+ clampColor' (ColorMode240 colorCount) c@(Color240 n)+ | n <= colorCount = SetTo c+ | otherwise = Default+ clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =+ clampColor' colorMode (color240 r g b)++ clampColor' FullColor c = SetTo c
− src/Graphics/Vty/Output/Interface.hs
@@ -1,302 +0,0 @@--- Copyright Corey O'Connor-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}--- | This module provides an abstract interface for performing terminal--- output. The only user-facing part of this API is 'Output'.-module Graphics.Vty.Output.Interface- ( Output(..)- , AssumedState(..)- , DisplayContext(..)- , Mode(..)- , displayContext- , outputPicture- , initialAssumedState- , limitAttrForDisplay- )-where--import Graphics.Vty.Attributes-import Graphics.Vty.Image (DisplayRegion, regionHeight)-import Graphics.Vty.Picture-import Graphics.Vty.PictureToSpans-import Graphics.Vty.Span--import Graphics.Vty.DisplayAttributes--import Blaze.ByteString.Builder (Write, writeToByteString)-import Blaze.ByteString.Builder.ByteString (writeByteString)--import qualified Data.ByteString as BS-import Data.IORef-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as Vector---- | Modal terminal features that can be enabled and disabled.-data Mode = Mouse- -- ^ Mouse mode (whether the terminal is configured to provide- -- mouse input events)- | BracketedPaste- -- ^ Paste mode (whether the terminal is configured to provide- -- events on OS pastes)- | Focus- -- ^ Focus-in/focus-out events (whether the terminal is- -- configured to provide events on focus change)- | Hyperlink- -- ^ Hyperlink mode via the 'withURL' attribute modifier (see- -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).- -- Note that this may not work gracefully in all terminal- -- emulators so be sure to test this mode with the terminals- -- you intend to support. It is off by default.- deriving (Eq, Read, Show)---- | The Vty terminal output interface.-data Output = Output- { -- | Text identifier for the output device. Used for debugging.- terminalID :: String- -- | Release the terminal just prior to application exit and reset- -- it to its state prior to application startup.- , releaseTerminal :: IO ()- -- | Clear the display and initialize the terminal to some initial- -- display state.- --- -- The expectation of a program is that the display starts in some- -- The initial state. initial state would consist of fixed values:- --- -- - cursor at top left- -- - UTF-8 character encoding- -- - drawing characteristics are the default- , reserveDisplay :: IO ()- -- | Return the display to the state before `reserveDisplay` If no- -- previous state then set the display state to the initial state.- , releaseDisplay :: IO ()- -- | Returns the current display bounds.- , displayBounds :: IO DisplayRegion- -- | Output the bytestring to the terminal device.- , outputByteBuffer :: BS.ByteString -> IO ()- -- | Specifies the maximum number of colors supported by the- -- context.- , contextColorCount :: Int- -- | Specifies whether the cursor can be shown / hidden.- , supportsCursorVisibility :: Bool- -- | Indicates support for terminal modes for this output device.- , supportsMode :: Mode -> Bool- -- | Enables or disables a mode (does nothing if the mode is- -- unsupported).- , setMode :: Mode -> Bool -> IO ()- -- | Returns whether a mode is enabled.- , getModeStatus :: Mode -> IO Bool- , assumedStateRef :: IORef AssumedState- -- | Acquire display access to the given region of the display.- -- Currently all regions have the upper left corner of (0,0) and- -- the lower right corner at (max displayWidth providedWidth, max- -- displayHeight providedHeight)- , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext- -- | Ring the terminal bell if supported.- , ringTerminalBell :: IO ()- -- | Returns whether the terminal has an audio bell feature.- , supportsBell :: IO Bool- }--displayContext :: Output -> DisplayRegion -> IO DisplayContext-displayContext t = mkDisplayContext t t--data AssumedState = AssumedState- { prevFattr :: Maybe FixedAttr- , prevOutputOps :: Maybe DisplayOps- }--initialAssumedState :: AssumedState-initialAssumedState = AssumedState Nothing Nothing--data DisplayContext = DisplayContext- { contextDevice :: Output- -- | Provide the bounds of the display context.- , contextRegion :: DisplayRegion- -- | Sets the output position to the specified row and column- -- where the number of bytes required for the control codes can be- -- specified seperate from the actual byte sequence.- , writeMoveCursor :: Int -> Int -> Write- , writeShowCursor :: Write- , writeHideCursor :: Write- -- Ensure that the specified output attributes will be applied to- -- all the following text until the next output attribute change- -- where the number of bytes required for the control codes can be- -- specified seperately from the actual byte sequence. The required- -- number of bytes must be at least the maximum number of bytes- -- required by any attribute changes. The serialization equations- -- must provide the ptr to the next byte to be specified in the- -- output buffer.- --- -- The currently applied display attributes are provided as well.- -- The Attr data type can specify the style or color should not be- -- changed from the currently applied display attributes. In order- -- to support this the currently applied display attributes are- -- required. In addition it may be possible to optimize the state- -- changes based off the currently applied display attributes.- , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write- -- | Reset the display attributes to the default display attributes.- , writeDefaultAttr :: Bool -> Write- , writeRowEnd :: Write- -- | See `Graphics.Vty.Output.XTermColor.inlineHack`- , inlineHack :: IO ()- }---- | All terminals serialize UTF8 text to the terminal device exactly as--- serialized in memory.-writeUtf8Text :: BS.ByteString -> Write-writeUtf8Text = writeByteString---- | Displays the given `Picture`.------ 1. The image is cropped to the display size.------ 2. Converted into a sequence of attribute changes and text spans.------ 3. The cursor is hidden.------ 4. Serialized to the display.------ 5. The cursor is then shown and positioned or kept hidden.-outputPicture :: DisplayContext -> Picture -> IO ()-outputPicture dc pic = do- urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink- as <- readIORef (assumedStateRef $ contextDevice dc)- let manipCursor = supportsCursorVisibility (contextDevice dc)- r = contextRegion dc- ops = displayOpsForPic pic r- initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing- -- Diff the previous output against the requested output.- -- Differences are currently on a per-row basis.- diffs :: [Bool] = case prevOutputOps as of- Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True- Just previousOps -> if affectedRegion previousOps /= affectedRegion ops- then replicate (displayOpsRows ops) True- else Vector.toList $ Vector.zipWith (/=) previousOps ops- -- build the Write corresponding to the output image- out = (if manipCursor then writeHideCursor dc else mempty)- `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops- `mappend`- (let (w,h) = contextRegion dc- clampX = max 0 . min (w-1)- clampY = max 0 . min (h-1) in- case picCursor pic of- _ | not manipCursor -> mempty- NoCursor -> mempty- AbsoluteCursor x y ->- writeShowCursor dc `mappend`- writeMoveCursor dc (clampX x) (clampY y)- Cursor x y ->- let m = cursorOutputMap ops $ picCursor pic- (ox, oy) = charToOutputPos m (clampX x, clampY y)- in writeShowCursor dc `mappend`- writeMoveCursor dc (clampX ox) (clampY oy)- )- -- ... then serialize- outputByteBuffer (contextDevice dc) (writeToByteString out)- -- Cache the output spans.- let as' = as { prevOutputOps = Just ops }- writeIORef (assumedStateRef $ contextDevice dc) as'--writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write-writeOutputOps urlsEnabled dc initialAttr diffs ops =- let (_, out, _) = Vector.foldl' writeOutputOps'- (0, mempty, diffs)- ops- in out- where- writeOutputOps' (y, out, True : diffs') spanOps- = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps- out' = out `mappend` spanOut- in (y+1, out', diffs')- writeOutputOps' (y, out, False : diffs') _spanOps- = (y + 1, out, diffs')- writeOutputOps' (_y, _out, []) _spanOps- = error "vty - output spans without a corresponding diff."--writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write-writeSpanOps urlsEnabled dc y initialAttr spanOps =- -- The first operation is to set the cursor to the start of the row- let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled- -- then the span ops are serialized in the order specified- in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of- (opOut, fattr') -> (out `mappend` opOut, fattr')- )- (start, initialAttr)- spanOps--writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)-writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =- let attr' = limitAttrForDisplay (contextDevice dc) attr- fattr' = fixDisplayAttr fattr attr'- diffs = displayAttrDiffs fattr fattr'- out = writeSetAttr dc urlsEnabled fattr attr' diffs- `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)- in (out, fattr')-writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"-writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)---- | The cursor position is given in X,Y character offsets. Due to--- multi-column characters this needs to be translated to column, row--- positions.-data CursorOutputMap = CursorOutputMap- { charToOutputPos :: (Int, Int) -> (Int, Int)- }--cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap-cursorOutputMap spanOps _cursor = CursorOutputMap- { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)- }--cursorColumnOffset :: DisplayOps -> Int -> Int -> Int-cursorColumnOffset ops cx cy =- let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)- (outOffset, _, _)- = Vector.foldl' ( \(d, currentCx, done) op ->- if done then (d, currentCx, done) else case spanOpHasWidth op of- Nothing -> (d, currentCx, False)- Just (cw, ow) -> case compare cx (currentCx + cw) of- GT -> ( d + ow- , currentCx + cw- , False- )- EQ -> ( d + ow- , currentCx + cw- , True- )- LT -> ( d + columnsToCharOffset (cx - currentCx) op- , currentCx + cw- , True- )- )- (0, 0, False)- cursorRowOps- in outOffset---- | Not all terminals support all display attributes. This filters a--- display attribute to what the given terminal can display.-limitAttrForDisplay :: Output -> Attr -> Attr-limitAttrForDisplay t attr- = attr { attrForeColor = clampColor $ attrForeColor attr- , attrBackColor = clampColor $ attrBackColor attr- }- where- clampColor Default = Default- clampColor KeepCurrent = KeepCurrent- clampColor (SetTo c) = clampColor' c- clampColor' (ISOColor v)- | contextColorCount t < 8 = Default- | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)- | otherwise = SetTo $ ISOColor v- clampColor' (Color240 v)- -- Should we choose closest ISO color?- | contextColorCount t < 8 = Default- | contextColorCount t < 16 = Default- | contextColorCount t <= 256 = SetTo $ Color240 v- | otherwise- = let p :: Double = fromIntegral v / 240.0- v' = floor $ p * (fromIntegral $ contextColorCount t)- in SetTo $ Color240 v'
src/Graphics/Vty/Output/Mock.hs view
@@ -11,7 +11,8 @@ where import Graphics.Vty.Image (DisplayRegion)-import Graphics.Vty.Output.Interface+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))+import Graphics.Vty.Output import Blaze.ByteString.Builder.Word (writeWord8) @@ -30,7 +31,7 @@ -- without considering terminal specific issues. -- -- The mock implementation is useful in manually determining if the--- sequence of terminal operations matche the expected sequence. The+-- sequence of terminal operations matches the expected sequence. The -- requirement of the produced representation is simplicity in parsing -- the text representation and determining how the picture was mapped to -- terminal operations.@@ -48,16 +49,20 @@ , releaseDisplay = return () , ringTerminalBell = return () , supportsBell = return False+ , supportsItalics = return False+ , supportsStrikethrough = return False+ , setDisplayBounds = const $ return () , displayBounds = return r , outputByteBuffer = \bytes -> do putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes" writeIORef outRef $ UTF8.fromRep bytes- , contextColorCount = 16 , supportsCursorVisibility = True , supportsMode = const False , setMode = const $ const $ return () , getModeStatus = const $ return False , assumedStateRef = newAssumedStateRef+ , outputColorMode = ColorMode16+ , setOutputWindowTitle = const $ return () , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual@@ -83,4 +88,3 @@ } } return (outRef, t)-
− src/Graphics/Vty/Output/TerminfoBased.hs
@@ -1,539 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}-{-# CFILES gwinsz.c #-}---- | Terminfo-based terminal output driver.------ Copyright Corey O'Connor (coreyoconnor@gmail.com)-module Graphics.Vty.Output.TerminfoBased- ( reserveTerminal- )-where--import Control.Monad (when)-import qualified Data.ByteString as BS-import Data.ByteString.Internal (toForeignPtr)-import Data.Terminfo.Parse-import Data.Terminfo.Eval--import Graphics.Vty.Attributes-import Graphics.Vty.Image (DisplayRegion)-import Graphics.Vty.DisplayAttributes-import Graphics.Vty.Output.Interface--import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)--import Data.Bits ((.&.))-import Data.IORef-import Data.Maybe (isJust, isNothing, fromJust)-import Data.Word--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (foldMap)-#endif--import Foreign.C.Types ( CInt(..), CLong(..) )-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr)--import qualified System.Console.Terminfo as Terminfo-import System.Posix.IO (fdWriteBuf)-import System.Posix.Types (Fd(..))--data TerminfoCaps = TerminfoCaps- { smcup :: Maybe CapExpression- , rmcup :: Maybe CapExpression- , cup :: CapExpression- , cnorm :: Maybe CapExpression- , civis :: Maybe CapExpression- , supportsNoColors :: Bool- , useAltColorMap :: Bool- , setForeColor :: CapExpression- , setBackColor :: CapExpression- , setDefaultAttr :: CapExpression- , clearScreen :: CapExpression- , clearEol :: CapExpression- , displayAttrCaps :: DisplayAttrCaps- , ringBellAudio :: Maybe CapExpression- }--data DisplayAttrCaps = DisplayAttrCaps- { setAttrStates :: Maybe CapExpression- , enterStandout :: Maybe CapExpression- , exitStandout :: Maybe CapExpression- , enterItalic :: Maybe CapExpression- , exitItalic :: Maybe CapExpression- , enterUnderline :: Maybe CapExpression- , exitUnderline :: Maybe CapExpression- , enterReverseVideo :: Maybe CapExpression- , enterDimMode :: Maybe CapExpression- , enterBoldMode :: Maybe CapExpression- }---- kinda like:--- https://code.google.com/p/vim/source/browse/src/fileio.c#10422--- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR--- the write will be retried.-fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int-fdWriteAll outFd ptr len count- | len < 0 = fail "fdWriteAll: len is less than 0"- | len == 0 = return count- | otherwise = do- writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)- let len' = len - writeCount- ptr' = ptr `plusPtr` writeCount- count' = count + writeCount- fdWriteAll outFd ptr' len' count'--sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()-sendCapToTerminal t cap capParams = do- outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams---- | Constructs an output driver that uses terminfo for all control--- codes. While this should provide the most compatible terminal,--- terminfo does not support some features that would increase--- efficiency and improve compatibility:------ * determining the character encoding supported by the terminal.--- Should this be taken from the LANG environment variable?------ * Providing independent string capabilities for all display--- attributes.-reserveTerminal :: String -> Fd -> IO Output-reserveTerminal termName outFd = do- ti <- Terminfo.setupTerm termName- -- assumes set foreground always implies set background exists.- -- if set foreground is not set then all color changing style- -- attributes are filtered.- msetaf <- probeCap ti "setaf"- msetf <- probeCap ti "setf"- let (noColors, useAlt, setForeCap)- = case msetaf of- Just setaf -> (False, False, setaf)- Nothing -> case msetf of- Just setf -> (False, True, setf)- Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)- msetab <- probeCap ti "setab"- msetb <- probeCap ti "setb"- let set_back_cap- = case msetab of- Nothing -> case msetb of- Just setb -> setb- Nothing -> error $ "no back color support for terminal " ++ termName- Just setab -> setab-- hyperlinkModeStatus <- newIORef False- newAssumedStateRef <- newIORef initialAssumedState-- let terminfoSetMode m newStatus = do- curStatus <- terminfoModeStatus m- when (newStatus /= curStatus) $- case m of- Hyperlink -> do- writeIORef hyperlinkModeStatus newStatus- writeIORef newAssumedStateRef initialAssumedState- _ -> return ()- terminfoModeStatus m =- case m of- Hyperlink -> readIORef hyperlinkModeStatus- _ -> return False- terminfoModeSupported Hyperlink = True- terminfoModeSupported _ = False-- terminfoCaps <- pure TerminfoCaps- <*> probeCap ti "smcup"- <*> probeCap ti "rmcup"- <*> requireCap ti "cup"- <*> probeCap ti "cnorm"- <*> probeCap ti "civis"- <*> pure noColors- <*> pure useAlt- <*> pure setForeCap- <*> pure set_back_cap- <*> requireCap ti "sgr0"- <*> requireCap ti "clear"- <*> requireCap ti "el"- <*> currentDisplayAttrCaps ti- <*> probeCap ti "bel"- let t = Output- { terminalID = termName- , releaseTerminal = do- sendCap setDefaultAttr []- maybeSendCap cnorm []- , supportsBell = return $ isJust $ ringBellAudio terminfoCaps- , ringTerminalBell = maybeSendCap ringBellAudio []- , reserveDisplay = do- -- If there is no support for smcup: Clear the screen- -- and then move the mouse to the home position to- -- approximate the behavior.- maybeSendCap smcup []- sendCap clearScreen []- , releaseDisplay = do- maybeSendCap rmcup []- maybeSendCap cnorm []- , displayBounds = do- rawSize <- getWindowSize outFd- case rawSize of- (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize- | otherwise -> return (w,h)- , outputByteBuffer = \outBytes -> do- let (fptr, offset, len) = toForeignPtr outBytes- actualLen <- withForeignPtr fptr- $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0- when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "- ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen- ++ " Please report this bug to vty project."- , contextColorCount- = case supportsNoColors terminfoCaps of- False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of- Nothing -> 8- Just v -> toEnum v- True -> 1- , supportsCursorVisibility = isJust $ civis terminfoCaps- , supportsMode = terminfoModeSupported- , setMode = terminfoSetMode- , getModeStatus = terminfoModeStatus- , assumedStateRef = newAssumedStateRef- -- I think fix would help assure tActual is the only- -- reference. I was having issues tho.- , mkDisplayContext = \tActual -> terminfoDisplayContext tActual terminfoCaps- }- sendCap s = sendCapToTerminal t (s terminfoCaps)- maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)- return t--requireCap :: Terminfo.Terminal -> String -> IO CapExpression-requireCap ti capName- = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of- Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""- Just capStr -> parseCap capStr--probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)-probeCap ti capName- = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of- Nothing -> return Nothing- Just capStr -> Just <$> parseCap capStr--parseCap :: String -> IO CapExpression-parseCap capStr = do- case parseCapExpression capStr of- Left e -> fail $ show e- Right cap -> return cap--currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps-currentDisplayAttrCaps ti- = pure DisplayAttrCaps- <*> probeCap ti "sgr"- <*> probeCap ti "smso"- <*> probeCap ti "rmso"- <*> probeCap ti "sitm"- <*> probeCap ti "ritm"- <*> probeCap ti "smul"- <*> probeCap ti "rmul"- <*> probeCap ti "rev"- <*> probeCap ti "dim"- <*> probeCap ti "bold"--foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong--getWindowSize :: Fd -> IO (Int,Int)-getWindowSize fd = do- (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd- return (fromIntegral b, fromIntegral a)--terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext-terminfoDisplayContext tActual terminfoCaps r = return dc- where dc = DisplayContext- { contextDevice = tActual- , contextRegion = r- , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]- , writeShowCursor = case cnorm terminfoCaps of- Nothing -> error "this terminal does not support show cursor"- Just c -> writeCapExpr c []- , writeHideCursor = case civis terminfoCaps of- Nothing -> error "this terminal does not support hide cursor"- Just c -> writeCapExpr c []- , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps- , writeDefaultAttr = \urlsEnabled ->- writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`- (if urlsEnabled then writeURLEscapes EndLink else mempty)- , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []- , inlineHack = return ()- }---- | Write the escape sequences that are used in some terminals to--- include embedded hyperlinks. As of yet, this information isn't--- included in termcap or terminfo, so this writes them directly--- instead of looking up the appropriate capabilities.-writeURLEscapes :: URLDiff -> Write-writeURLEscapes (LinkTo url) =- foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`- foldMap writeStorable (BS.unpack url) `mappend`- writeStorable (0x07 :: Word8)-writeURLEscapes EndLink =- foldMap writeStorable (BS.unpack "\x1b]8;;\a")-writeURLEscapes NoLinkChange =- mempty---- | Portably setting the display attributes is a giant pain in the ass.------ If the terminal supports the sgr capability (which sets the on/off--- state of each style directly ; and, for no good reason, resets the--- colors to the default) this procedure is used:------ 0. set the style attributes. This resets the fore and back color.------ 1, If a foreground color is to be set then set the foreground color------ 2. likewise with the background color------ If the terminal does not support the sgr cap then: if there is a--- change from an applied color to the default (in either the fore or--- back color) then:------ 0. reset all display attributes (sgr0)------ 1. enter required style modes------ 2. set the fore color if required------ 3. set the back color if required------ Entering the required style modes could require a reset of the--- display attributes. If this is the case then the back and fore colors--- always need to be set if not default.------ This equation implements the above logic.------ Note that this assumes the removal of color changes in the--- display attributes is done as expected with noColors == True. See--- `limitAttrForDisplay`.------ Note that this optimizes for fewer state changes followed by fewer--- bytes.-terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write-terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =- urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of- -- The only way to reset either color, portably, to the default- -- is to use either the set state capability or the set default- -- capability.- True -> do- case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)- (fixedStyle attr )- (styleToApplySeq $ fixedStyle attr) of- -- only way to reset a color to the defaults- EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled- `mappend`- foldMap (\cap -> writeCapExpr cap []) caps- `mappend`- setColors- -- implicitly resets the colors to the defaults- SetState state -> writeCapExpr (fromJust $ setAttrStates- $ displayAttrCaps- $ terminfoCaps- )- (sgrArgsForState state)- `mappend` setItalics- `mappend` setColors- -- Otherwise the display colors are not changing or changing- -- between two non-default points.- False -> do- -- Still, it could be the case that the change in display- -- attributes requires the colors to be reset because the- -- required capability was not available.- case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)- (fixedStyle attr)- (styleDiffs diffs) of- -- Really, if terminals were re-implemented with modern- -- concepts instead of bowing down to 40 yr old dumb- -- terminal requirements this would be the only case- -- ever reached! Changes the style and color states- -- according to the differences with the currently- -- applied states.- EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps- `mappend`- writeColorDiff setForeColor (foreColorDiff diffs)- `mappend`- writeColorDiff setBackColor (backColorDiff diffs)- -- implicitly resets the colors to the defaults- SetState state -> writeCapExpr (fromJust $ setAttrStates- $ displayAttrCaps terminfoCaps- )- (sgrArgsForState state)- `mappend` setItalics- `mappend` setColors- where- urlAttrs True = writeURLEscapes (urlDiff diffs)- urlAttrs False = mempty- colorMap = case useAltColorMap terminfoCaps of- False -> ansiColorIndex- True -> altColorIndex- attr = fixDisplayAttr prevAttr reqAttr-- -- italics can't be set via SGR, so here we manually- -- apply the enter and exit sequences as needed after- -- changing the SGR- setItalics- | hasStyle (fixedStyle attr) italic- , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)- = writeCapExpr sitm []- | otherwise = mempty- setColors =- (case fixedForeColor attr of- Just c -> writeCapExpr (setForeColor terminfoCaps)- [toEnum $ colorMap c]- Nothing -> mempty)- `mappend`- (case fixedBackColor attr of- Just c -> writeCapExpr (setBackColor terminfoCaps)- [toEnum $ colorMap c]- Nothing -> mempty)- writeColorDiff _f NoColorChange- = mempty- writeColorDiff _f ColorToDefault- = error "ColorToDefault is not a possible case for applyColorDiffs"- writeColorDiff f (SetColor c)- = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]---- | The color table used by a terminal is a 16 color set followed by a--- 240 color set that might not be supported by the terminal.------ This takes a Color which clearly identifies which pallete to use and--- computes the index into the full 256 color pallete.-ansiColorIndex :: Color -> Int-ansiColorIndex (ISOColor v) = fromEnum v-ansiColorIndex (Color240 v) = 16 + fromEnum v---- | For terminals without setaf/setab------ See table in `man terminfo`--- Will error if not in table.-altColorIndex :: Color -> Int-altColorIndex (ISOColor 0) = 0-altColorIndex (ISOColor 1) = 4-altColorIndex (ISOColor 2) = 2-altColorIndex (ISOColor 3) = 6-altColorIndex (ISOColor 4) = 1-altColorIndex (ISOColor 5) = 5-altColorIndex (ISOColor 6) = 3-altColorIndex (ISOColor 7) = 7-altColorIndex (ISOColor v) = fromEnum v-altColorIndex (Color240 v) = 16 + fromEnum v--{- | The sequence of terminfo caps to apply a given style are determined- - according to these rules.- -- - 1. The assumption is that it's preferable to use the simpler- - enter/exit mode capabilities than the full set display attribute- - state capability.- -- - 2. If a mode is supposed to be removed but there is not an exit- - capability defined then the display attributes are reset to defaults- - then the display attribute state is set.- -- - 3. If a mode is supposed to be applied but there is not an enter- - capability defined then then display attribute state is set if- - possible. Otherwise the mode is not applied.- -- - 4. If the display attribute state is being set then just update the- - arguments to that for any apply/remove.- -}-data DisplayAttrSeq- = EnterExitSeq [CapExpression]- | SetState DisplayAttrState--data DisplayAttrState = DisplayAttrState- { applyStandout :: Bool- , applyUnderline :: Bool- , applyItalic :: Bool- , applyReverseVideo :: Bool- , applyBlink :: Bool- , applyDim :: Bool- , applyBold :: Bool- }--sgrArgsForState :: DisplayAttrState -> [CapParam]-sgrArgsForState attrState = map (\b -> if b then 1 else 0)- [ applyStandout attrState- , applyUnderline attrState- , applyReverseVideo attrState- , applyBlink attrState- , applyDim attrState- , applyBold attrState- , False -- invis- , False -- protect- , False -- alt char set- ]--reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq-reqDisplayCapSeqFor caps s diffs- -- if the state transition implied by any diff cannot be supported- -- with an enter/exit mode cap then either the state needs to be set- -- or the attribute change ignored.- = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of- -- If all the diffs have an enter-exit cap then just use those- ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs- -- If not all the diffs have an enter-exit cap and there is no- -- set state cap then filter out all unsupported diffs and just- -- apply the rest- ( True, False ) -> EnterExitSeq $ map enterExitCap- $ filter (not . noEnterExitCap) diffs- -- if not all the diffs have an enter-exit can and there is a- -- set state cap then just use the set state cap.- ( True, True ) -> SetState $ stateForStyle s- where- noEnterExitCap ApplyItalic = isNothing $ enterItalic caps- noEnterExitCap RemoveItalic = isNothing $ exitItalic caps- noEnterExitCap ApplyStandout = isNothing $ enterStandout caps- noEnterExitCap RemoveStandout = isNothing $ exitStandout caps- noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps- noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps- noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps- noEnterExitCap RemoveReverseVideo = True- noEnterExitCap ApplyBlink = True- noEnterExitCap RemoveBlink = True- noEnterExitCap ApplyDim = isNothing $ enterDimMode caps- noEnterExitCap RemoveDim = True- noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps- noEnterExitCap RemoveBold = True- enterExitCap ApplyItalic = fromJust $ enterItalic caps- enterExitCap RemoveItalic = fromJust $ exitItalic caps- enterExitCap ApplyStandout = fromJust $ enterStandout caps- enterExitCap RemoveStandout = fromJust $ exitStandout caps- enterExitCap ApplyUnderline = fromJust $ enterUnderline caps- enterExitCap RemoveUnderline = fromJust $ exitUnderline caps- enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps- enterExitCap ApplyDim = fromJust $ enterDimMode caps- enterExitCap ApplyBold = fromJust $ enterBoldMode caps- enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."--stateForStyle :: Style -> DisplayAttrState-stateForStyle s = DisplayAttrState- { applyStandout = isStyleSet standout- , applyUnderline = isStyleSet underline- , applyItalic = isStyleSet italic- , applyReverseVideo = isStyleSet reverseVideo- , applyBlink = isStyleSet blink- , applyDim = isStyleSet dim- , applyBold = isStyleSet bold- }- where isStyleSet = hasStyle s--styleToApplySeq :: Style -> [StyleStateChange]-styleToApplySeq s = concat- [ applyIfRequired ApplyStandout standout- , applyIfRequired ApplyUnderline underline- , applyIfRequired ApplyItalic italic- , applyIfRequired ApplyReverseVideo reverseVideo- , applyIfRequired ApplyBlink blink- , applyIfRequired ApplyDim dim- , applyIfRequired ApplyBold bold- ]- where- applyIfRequired op flag- = if 0 == (flag .&. s)- then []- else [op]
− src/Graphics/Vty/Output/XTermColor.hs
@@ -1,122 +0,0 @@-{-# Language CPP #-}--- Copyright 2009-2010 Corey O'Connor--- | Xterm output driver. This uses the Terminfo driver with some--- extensions for Xterm.-module Graphics.Vty.Output.XTermColor- ( reserveTerminal- )-where--import Graphics.Vty.Output.Interface-import Graphics.Vty.Input.Mouse-import Graphics.Vty.Input.Focus-import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased--import Blaze.ByteString.Builder (writeToByteString)-import Blaze.ByteString.Builder.Word (writeWord8)--import Control.Monad (void, when)-import Control.Monad.Trans-import Data.IORef--import System.Posix.IO (fdWrite)-import System.Posix.Types (Fd)-import System.Posix.Env (getEnv)--import Data.List (isInfixOf)-import Data.Maybe (catMaybes)--#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif---- | Construct an Xterm output driver. Initialize the display to UTF-8.-reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output-reserveTerminal variant outFd = liftIO $ do- let flushedPut = void . fdWrite outFd- -- If the terminal variant is xterm-color use xterm instead since,- -- more often than not, xterm-color is broken.- let variant' = if variant == "xterm-color" then "xterm" else variant-- utf8a <- utf8Active- when (not utf8a) $ flushedPut setUtf8CharSet- t <- TerminfoBased.reserveTerminal variant' outFd-- mouseModeStatus <- newIORef False- focusModeStatus <- newIORef False- pasteModeStatus <- newIORef False-- let xtermSetMode t' m newStatus = do- curStatus <- getModeStatus t' m- when (newStatus /= curStatus) $- case m of- Focus -> liftIO $ do- case newStatus of- True -> flushedPut requestFocusEvents- False -> flushedPut disableFocusEvents- writeIORef focusModeStatus newStatus- Mouse -> liftIO $ do- case newStatus of- True -> flushedPut requestMouseEvents- False -> flushedPut disableMouseEvents- writeIORef mouseModeStatus newStatus- BracketedPaste -> liftIO $ do- case newStatus of- True -> flushedPut enableBracketedPastes- False -> flushedPut disableBracketedPastes- writeIORef pasteModeStatus newStatus- Hyperlink -> setMode t Hyperlink newStatus-- xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus- xtermGetMode Focus = liftIO $ readIORef focusModeStatus- xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus- xtermGetMode Hyperlink = getModeStatus t Hyperlink-- let t' = t- { terminalID = terminalID t ++ " (xterm-color)"- , releaseTerminal = do- when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet- setMode t' BracketedPaste False- setMode t' Mouse False- setMode t' Focus False- releaseTerminal t- , mkDisplayContext = \tActual r -> do- dc <- mkDisplayContext t tActual r- return $ dc { inlineHack = xtermInlineHack t' }- , supportsMode = const True- , getModeStatus = xtermGetMode- , setMode = xtermSetMode t'- }- return t'--utf8Active :: IO Bool-utf8Active = do- let vars = ["LC_ALL", "LANG", "LC_CTYPE"]- results <- catMaybes <$> mapM getEnv vars- let matches = filter ("UTF8" `isInfixOf`) results <>- filter ("UTF-8" `isInfixOf`) results- return $ not $ null matches---- | Enable bracketed paste mode:--- http://cirw.in/blog/bracketed-paste-enableBracketedPastes :: String-enableBracketedPastes = "\ESC[?2004h"---- | Disable bracketed paste mode:-disableBracketedPastes :: String-disableBracketedPastes = "\ESC[?2004l"---- | These sequences set xterm based terminals to UTF-8 output.------ There is no known terminfo capability equivalent to this.-setUtf8CharSet, setDefaultCharSet :: String-setUtf8CharSet = "\ESC%G"-setDefaultCharSet = "\ESC%@"---- | I think xterm is broken: Reseting the background color as the first--- bytes serialized on a new line does not effect the background color--- xterm uses to clear the line. Which is used *after* the next newline.-xtermInlineHack :: Output -> IO ()-xtermInlineHack t = do- let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"- outputByteBuffer t $ writeToByteString writeReset
src/Graphics/Vty/Picture.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} -- A 'Picture' is a background paired with a set of 'Image' layers. The -- 'Picture' data structure is representative of the final terminal -- view.@@ -31,10 +30,7 @@ , picBackground :: Background -- ^ The picture's background to be displayed in locations with no -- Image data.- } deriving Eq--instance Show Picture where- show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"+ } deriving (Eq, Show) instance NFData Picture where rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()@@ -80,12 +76,20 @@ data Cursor = -- | Hide the cursor NoCursor+ -- | Set the terminal's cursor position without displaying a cursor+ -- character. This is important for accessibility with screen+ -- readers where a cursor position needs to be reported but we may+ -- not want to show a block cursor in that location for cosmetic+ -- reasons. The boolean argument indicates whether the positioning+ -- should be absolute as with 'AbsoluteCursor' ('True') or logical+ -- as with 'Cursor' ('False').+ | PositionOnly !Bool !Int !Int -- | Show the cursor at the given logical column accounting for -- character width in the presence of multi-column characters. | Cursor !Int !Int -- | Show the cursor at the given absolute terminal column and row | AbsoluteCursor !Int !Int- deriving Eq+ deriving (Eq, Show) instance NFData Cursor where rnf c = c `seq` ()@@ -109,7 +113,7 @@ -- -- * End of line if there are no remaining non-skip ops. | ClearBackground- deriving Eq+ deriving (Eq, Show) instance NFData Background where rnf (Background c a) = c `seq` a `seq` ()
src/Graphics/Vty/PictureToSpans.hs view
@@ -3,10 +3,12 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-} -- | Transforms an image into rows of operations.-module Graphics.Vty.PictureToSpans where+module Graphics.Vty.PictureToSpans+ ( displayOpsForPic+ )+where import Graphics.Vty.Attributes (Attr, currentAttr) import Graphics.Vty.Image@@ -16,7 +18,7 @@ import Lens.Micro import Lens.Micro.Mtl-import Lens.Micro.TH+import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) import Control.Monad.ST.Strict@@ -29,8 +31,6 @@ type MRowOps s = MVector s SpanOps -type MSpanOps s = MVector s SpanOp- -- transform plus clip. More or less. data BlitState = BlitState -- we always snoc to the operation vectors. Thus the columnOffset =@@ -53,15 +53,35 @@ , _remainingRows :: Int } -makeLenses ''BlitState+columnOffset :: Lens' BlitState Int+columnOffset = lens _columnOffset (\e v -> e { _columnOffset = v }) +rowOffset :: Lens' BlitState Int+rowOffset = lens _rowOffset (\e v -> e { _rowOffset = v })++skipColumns :: Lens' BlitState Int+skipColumns = lens _skipColumns (\e v -> e { _skipColumns = v })++skipRows :: Lens' BlitState Int+skipRows = lens _skipRows (\e v -> e { _skipRows = v })++remainingColumns :: Lens' BlitState Int+remainingColumns = lens _remainingColumns (\e v -> e { _remainingColumns = v })++remainingRows :: Lens' BlitState Int+remainingRows = lens _remainingRows (\e v -> e { _remainingRows = v })+ data BlitEnv s = BlitEnv { _region :: DisplayRegion , _mrowOps :: MRowOps s } -makeLenses ''BlitEnv+region :: Lens' (BlitEnv s) DisplayRegion+region = lens _region (\e r -> e { _region = r }) +mrowOps :: Lens' (BlitEnv s) (MRowOps s)+mrowOps = lens _mrowOps (\e r -> e { _mrowOps = r })+ type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a -- | Produces the span ops that will render the given picture, possibly@@ -69,21 +89,14 @@ displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r) --- | Returns the DisplayOps for an image rendered to a window the size--- of the image.------ largerly used only for debugging.-displayOpsForImage :: Image -> DisplayOps-displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)- -- | Produces the span ops for each layer then combines them. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0 | otherwise = do- layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)+ layerOps <- mapM (`buildSpans` r) (picLayers pic) case layerOps of- [] -> fail "empty picture"+ [] -> error "empty picture" [ops] -> substituteSkips (picBackground pic) ops -- instead of merging ops after generation the merging can -- be performed as part of snocOp.@@ -113,7 +126,7 @@ -- At this point we decide if the background character is single -- column or not. obviously, single column is easier. case safeWcwidth backgroundChar of- w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar+ w | w == 0 -> error $ "invalid background character " ++ show backgroundChar | w == 1 -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row@@ -136,8 +149,8 @@ return upper mergeRowUnder :: SpanOps -> SpanOps -> SpanOps-mergeRowUnder upperRowOps lowerRowOps =- onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps+mergeRowUnder upperRowOps =+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) where -- H: it will never be the case that we are out of upper ops -- before lower ops.@@ -159,7 +172,7 @@ swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f- where f (Skip ow) = let txt = TL.pack $ replicate ow c+ where f (Skip ow) = let txt = TL.take (toEnum ow) $ TL.repeat c in TextSpan a ow ow txt f v = v @@ -220,18 +233,18 @@ isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s- | s ^. remainingColumns <= 0 = True- | s ^. remainingRows <= 0 = True+ | s ^. remainingColumns <= 0 = True+ | s ^. remainingRows <= 0 = True | s ^. skipColumns >= imageWidth i = True | s ^. skipRows >= imageHeight i = True | otherwise = False -- | This adds an image that might be partially clipped to the output -- ops.--- -- This is a very touchy algorithm. Too touchy. For instance, the--- CropRight and CropBottom implementations are odd. They pass the--- current tests but something seems terribly wrong about all this.+-- Crop implementations is odd. They pass the current tests but+-- something seems terribly wrong about all this.+-- addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do@@ -266,23 +279,13 @@ outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows) y <- use rowOffset forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth')-addMaybeClipped CropRight {croppedImage, outputWidth} = do- s <- use skipColumns- r <- use remainingColumns- let x = outputWidth - s- when (x < r) $ remainingColumns .= x- addMaybeClipped croppedImage-addMaybeClipped CropLeft {croppedImage, leftSkip} = do+addMaybeClipped Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight} = do+ sx <- use skipColumns skipColumns += leftSkip- addMaybeClipped croppedImage-addMaybeClipped CropBottom {croppedImage, outputHeight} = do- s <- use skipRows- r <- use remainingRows- let x = outputHeight - s- when (x < r) $ remainingRows .= x- addMaybeClipped croppedImage-addMaybeClipped CropTop {croppedImage, topSkip} = do+ modifying remainingColumns (min (outputWidth - sx))+ sy <- use skipRows skipRows += topSkip+ modifying remainingRows (min (outputHeight - sy)) addMaybeClipped croppedImage addMaybeClippedJoin :: forall s . String@@ -296,7 +299,7 @@ -> BlitM s () addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do state <- get- when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"+ when (state^.remaining <= 0) $ error $ name ++ " with remaining <= 0" case state^.skip of s | s > size -> put $ state & skip %~ subtract size | s == 0 -> if state^.remaining > i0Dim@@ -316,9 +319,9 @@ | s >= i0Dim -> do put $ state & skip %~ subtract i0Dim addMaybeClipped i1- _ -> fail $ name ++ " has unhandled skip class"+ _ -> error $ name ++ " has unhandled skip class" -addUnclippedText :: Attr -> DisplayText -> BlitM s ()+addUnclippedText :: Attr -> TL.Text -> BlitM s () addUnclippedText a txt = do let op = TextSpan a usedDisplayColumns (fromIntegral $ TL.length txt)@@ -344,5 +347,5 @@ ops <- MVector.read theMrowOps row let ops' = Vector.snoc ops op when (spanOpsAffectedColumns ops' > regionWidth theRegion)- $ fail $ "row " ++ show row ++ " now exceeds region width"+ $ error $ "row " ++ show row ++ " now exceeds region width" MVector.write theMrowOps row ops'
src/Graphics/Vty/Span.hs view
@@ -1,6 +1,4 @@ -- Copyright Corey O'Connor-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} -- | A picture is translated into a sequences of state changes and -- character spans. The attribute is applied to all following spans,@@ -9,8 +7,23 @@ -- -- A span op sequence will be defined for all rows and columns (and no -- more) of the region provided with the picture to 'spansForPic'.-module Graphics.Vty.Span where+module Graphics.Vty.Span+ ( SpanOp(..)+ , columnsToCharOffset+ , spanOpHasWidth + , SpanOps+ , spanOpsAffectedColumns+ , splitOpsAt+ , dropOps++ , DisplayOps+ , displayOpsRows+ , displayOpsColumns+ , affectedRegion+ )+where+ import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText )@@ -30,7 +43,7 @@ { textSpanAttr :: !Attr , textSpanOutputWidth :: !Int , textSpanCharWidth :: !Int- , textSpanText :: DisplayText+ , textSpanText :: TL.Text } -- | Skips the given number of columns. | Skip !Int@@ -52,7 +65,7 @@ dropOps w = snd . splitOpsAt w splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)-splitOpsAt inW inOps = splitOpsAt' inW inOps+splitOpsAt = splitOpsAt' where splitOpsAt' 0 ops = (Vector.empty, ops) splitOpsAt' remainingColumns ops = case Vector.head ops of@@ -103,7 +116,7 @@ -- | The number of rows the DisplayOps are defined for. displayOpsRows :: DisplayOps -> Int-displayOpsRows ops = Vector.length ops+displayOpsRows = Vector.length affectedRegion :: DisplayOps -> DisplayRegion affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
+ src/Graphics/Vty/UnicodeWidthTable/Main.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+-- | This module provides a command-line tool implementation for+-- building Vty character width tables and updating the user's local Vty+-- configuration to load them.+--+-- The API is parameterized on a platform-specific function to obtain+-- character widths. For example, on Unix platforms, this could be done+-- with a routine that communicates with the terminal to query it for+-- character widths. On other platforms, such a routine might interact+-- with a system library.+--+-- This tool is provided as a library implementation so that the tool+-- has a consistent interface across platforms and so that it implements+-- the Vty configuration update the same way everywhere.+module Graphics.Vty.UnicodeWidthTable.Main+ ( defaultMain+ )+where++import qualified Control.Exception as E+import Control.Monad (when)+import Data.Maybe (fromMaybe)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs, getProgName)+import System.FilePath (takeDirectory)+import System.Exit (exitFailure)+import System.Console.GetOpt+import Text.Read (readMaybe)++import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName+ , vtyConfigPath, addConfigWidthMap+ , ConfigUpdateResult(..)+ )+import Graphics.Vty.UnicodeWidthTable.IO+import Graphics.Vty.UnicodeWidthTable.Query++data Arg = Help+ | OutputPath String+ | TableUpperBound String+ | UpdateConfig+ | VtyConfigPath String+ deriving (Eq, Show)++options :: Config -> [OptDescr Arg]+options config =+ [ Option "h" ["help"] (NoArg Help)+ "This help output"+ , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")+ ("The maximum Unicode code point to test when building the table " <>+ "(default: " <> (show $ fromEnum $ configBound config) <> ")")+ , Option "p" ["path"] (ReqArg OutputPath "PATH")+ ("The output path to write to (default: " <>+ fromMaybe "<none>" (configOutputPath config) <> ")")+ , Option "u" ["update-config"] (NoArg UpdateConfig)+ "Create or update the Vty configuration file to use the new table (default: no)"+ , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")+ ("Update the specified Vty configuration file path when -u is set (default: " <>+ configPath config <> ")")+ ]++data Config =+ Config { configOutputPath :: Maybe FilePath+ , configBound :: Char+ , configUpdate :: Bool+ , configPath :: FilePath+ }+ deriving (Show)++mkDefaultConfig :: IO Config+mkDefaultConfig = do+ Config <$> terminalWidthTablePath+ <*> pure defaultUnicodeTableUpperBound+ <*> pure False+ <*> vtyConfigPath++usage :: IO ()+usage = do+ config <- mkDefaultConfig+ pn <- getProgName+ putStrLn $ "Usage: " <> pn <> " [options]"+ putStrLn ""+ putStrLn "This tool queries the terminal on stdout to determine the widths"+ putStrLn "of Unicode characters rendered to the terminal. The resulting data"+ putStrLn "is written to a table at the specified output path for later"+ putStrLn "loading by Vty-based applications."+ putStrLn ""++ putStrLn $ usageInfo pn (options config)++updateConfigFromArg :: Arg -> Config -> Config+updateConfigFromArg Help c =+ c+updateConfigFromArg UpdateConfig c =+ c { configUpdate = True }+updateConfigFromArg (VtyConfigPath p) c =+ c { configPath = p }+updateConfigFromArg (TableUpperBound s) c =+ case readMaybe s of+ Nothing -> error $ "Invalid table upper bound: " <> show s+ Just v -> c { configBound = toEnum v }+updateConfigFromArg (OutputPath p) c =+ c { configOutputPath = Just p }++-- | Run the character width table builder tool using the specified+-- function to obtain character widths. This is intended to be a 'main'+-- implementation, e.g. @main = defaultMain getCharWidth@.+--+-- The tool queries the local terminal in some way (as determined by+-- the provided function) over a wide range of Unicode code points and+-- generates a table of character widths that can subsequently be loaded+-- by Vty-based applications.+--+-- The tool respects the following command-line flags, all of which are+-- optional and have sensible defaults:+--+-- * @-h@/@--help@: help output+-- * @-b@/@--bound@: Unicode code point upper bound to use when building+-- the table.+-- * @-p@/@--path@: the output path where the generated table should be+-- written.+-- * @-u@/@--update-config@: If given, create or update the user's Vty+-- configuration file to use the new table.+-- * @-c@/@--config-path@: the path to the user's Vty configuration.+defaultMain :: (Char -> IO Int) -> IO ()+defaultMain charWidth = do+ defConfig <- mkDefaultConfig+ strArgs <- getArgs+ let (args, unused, errors) = getOpt Permute (options defConfig) strArgs++ when (not $ null errors) $ do+ mapM_ putStrLn errors+ exitFailure++ when ((not $ null unused) || (Help `elem` args)) $ do+ usage+ exitFailure++ let config = foldr updateConfigFromArg defConfig args++ outputPath <- case configOutputPath config of+ Nothing -> do+ putStrLn "Error: could not obtain terminal width table path"+ exitFailure+ Just path -> return path++ putStrLn "Querying terminal:"+ builtTable <- buildUnicodeWidthTable charWidth $ configBound config++ let dir = takeDirectory outputPath+ createDirectoryIfMissing True dir+ writeUnicodeWidthTable outputPath builtTable++ putStrLn $ "\nOutput table written to " <> outputPath++ when (configUpdate config) $ do+ let cPath = configPath config+ Just tName <- currentTerminalName++ result <- E.try $ addConfigWidthMap cPath tName outputPath++ case result of+ Left (e::E.SomeException) -> do+ putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>+ show e+ exitFailure+ Right ConfigurationCreated -> do+ putStrLn $ "Configuration file created: " <> cPath+ Right ConfigurationModified -> do+ putStrLn $ "Configuration file updated: " <> cPath+ Right (ConfigurationConflict other) -> do+ putStrLn $ "Configuration file not updated: uses a different table " <>+ "for TERM=" <> tName <> ": " <> other+ Right ConfigurationRedundant -> do+ putStrLn $ "Configuration file not updated: configuration " <>+ cPath <> " already uses table " <> outputPath <>+ " for TERM=" <> tName
src/Graphics/Vty/UnicodeWidthTable/Query.hs view
@@ -7,8 +7,6 @@ import Control.Monad (forM) import Data.Char (generalCategory, GeneralCategory(..))-import System.Console.ANSI (getCursorPosition)-import Text.Printf (printf) import Graphics.Vty.UnicodeWidthTable.Types @@ -20,13 +18,6 @@ Surrogate -> False _ -> True -charWidth :: Char -> IO Int-charWidth c = do- printf "\r"- putChar c- Just (_, col) <- getCursorPosition- return col- -- | Convert a sequence of character/width pairs into a list of -- run-length encoded ranges. This function assumes the pairs come -- sorted by character ordinal value. It does not require that the@@ -57,21 +48,21 @@ defaultUnicodeTableUpperBound :: Char defaultUnicodeTableUpperBound = '\xe0000' --- | Construct a unicode character width table by querying the terminal--- connected to stdout. This works by emitting characters to stdout--- and then querying the terminal to determine the resulting cursor--- position in order to measure character widths. Consequently this will--- generate a lot of output and may take a while, depending on your--- system performance. This should not be run in a terminal while it is--- controlled by Vty.+-- | Construct a unicode character width table. This works by using the+-- provided function to obtain the appropriate width for each character+-- in a wide range of Unicode code points, which on some platforms+-- may perform local terminal operations or may interact with system+-- libraries. Depending on how the provided width function works, this+-- may need to be run only in a terminal that is not actively controlled+-- by a Vty handle. ----- The argument specifies the upper bound code point to test when--- building the table. This allows callers to decide how much of the--- Unicode code point space to scan when building the table.+-- The character argument specifies the upper bound code point to test+-- when building the table. This allows callers to decide how much of+-- the Unicode code point space to scan when building the table. -- -- This does not handle exceptions.-buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable-buildUnicodeWidthTable tableUpperBound = do+buildUnicodeWidthTable :: (Char -> IO Int) -> Char -> IO UnicodeWidthTable+buildUnicodeWidthTable charWidth tableUpperBound = do pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i -> (i,) <$> charWidth i
− test/Verify.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module Verify- ( module Verify- , module Control.Applicative- , module Control.DeepSeq- , module Control.Exception- , module Control.Monad- , module Test.QuickCheck- , module Test.QuickCheck.Modifiers- , module Text.Printf- , succeeded- , failed- , monadicIO- , liftIO- , liftBool- , Test(..)- , Prop.Result(..)- )-where--import Control.Exception ( bracket, try, SomeException(..) )--import Distribution.TestSuite hiding ( Result(..) )-import qualified Distribution.TestSuite as TS--import Test.QuickCheck hiding ( Result(..) )-import qualified Test.QuickCheck as QC-import Test.QuickCheck.Modifiers-import Test.QuickCheck.Property hiding ( Result(..) )-import qualified Test.QuickCheck.Property as Prop-import Test.QuickCheck.Monadic ( monadicIO )--import Text.Printf--import qualified Codec.Binary.UTF8.String as UTF8--import Control.Applicative hiding ( (<|>) )-import Control.DeepSeq-import Control.Monad ( forM, mapM, mapM_, forM_ )-import Control.Monad.State.Strict--import Numeric ( showHex )--verify :: Testable t => String -> t -> Test-verify testName p = Test $ TestInstance- { name = testName- , run = do- qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p- case qcResult of- QC.Success {..} -> return $ Finished TS.Pass- QC.Failure {numShrinks,reason} -> return $ Finished- $ TS.Fail $ "After "- ++ show numShrinks ++ " shrinks determined failure to be: "- ++ show reason- _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"- , tags = []- , options = []- , setOption = \_ _ -> Left "no options supported"- }--data SingleColumnChar = SingleColumnChar Char- deriving (Show, Eq)--instance Arbitrary SingleColumnChar where- arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E]--data DoubleColumnChar = DoubleColumnChar Char- deriving (Eq)--instance Show DoubleColumnChar where- show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c]--instance Arbitrary DoubleColumnChar where- arbitrary = elements $ map DoubleColumnChar $- [ toEnum 0x3040 .. toEnum 0x3098 ]- ++ [ toEnum 0x309B .. toEnum 0xA4CF ]--liftIOResult :: Testable prop => IO prop -> Property-liftIOResult = ioProperty--data Bench where- Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
− test/Verify/Data/Terminfo/Parse.hs
@@ -1,112 +0,0 @@-module Verify.Data.Terminfo.Parse- ( module Verify.Data.Terminfo.Parse- , module Data.Terminfo.Parse- )-where--import Data.Terminfo.Parse-import Data.Terminfo.Eval-import Verify--import Data.Word-import qualified Data.Vector.Unboxed as Vector--import Numeric--hexDump :: [Word8] -> String-hexDump bytes = foldr (\b s -> showHex b s) "" bytes--data NonParamCapString = NonParamCapString String- deriving Show--instance Arbitrary NonParamCapString where- arbitrary- = ( do- s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')- return $ NonParamCapString s- ) `suchThat` ( \(NonParamCapString str) -> length str < 255 )--data LiteralPercentCap = LiteralPercentCap String [Word8]- deriving ( Show )--instance Arbitrary LiteralPercentCap where- arbitrary- = ( do- NonParamCapString s <- arbitrary- (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s- return $ LiteralPercentCap s' bytes- ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )--data IncFirstTwoCap = IncFirstTwoCap String [Word8]- deriving ( Show )--instance Arbitrary IncFirstTwoCap where- arbitrary- = ( do- NonParamCapString s <- arbitrary- (s', bytes) <- insertEscapeOp "i" [] s- return $ IncFirstTwoCap s' bytes- ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )--data PushParamCap = PushParamCap String Int [Word8]- deriving ( Show )--instance Arbitrary PushParamCap where- arbitrary- = ( do- NonParamCapString s <- arbitrary- n <- choose (1,9)- (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s- return $ PushParamCap s' n bytes- ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )--data DecPrintCap = DecPrintCap String Int [Word8]- deriving ( Show )--instance Arbitrary DecPrintCap where- arbitrary- = ( do- NonParamCapString s <- arbitrary- n <- choose (1,9)- (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s- return $ DecPrintCap s' n bytes- ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )--insertEscapeOp opStr replBytes s = do- insertPoints <- listOf1 $ elements [0 .. length s - 1]- let s' = f s ('%' : opStr)- remainingBytes = f (map (toEnum . fromEnum) s) replBytes- f inVs out_v = concat [ vs- | vi <- zip inVs [0 .. length s - 1]- , let vs = fst vi : ( if snd vi `elem` insertPoints- then out_v- else []- )- ]- return (s', remainingBytes)--isBytesOp :: CapOp -> Bool-isBytesOp (Bytes {}) = True--- isBytesOp _ = False--bytesForRange cap offset count- = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap--collectBytes :: CapExpression -> [Word8]-collectBytes e = concat [ bytes- | Bytes offset count <- capOps e- , let bytes = bytesForRange e offset count- ]---verifyBytesEqual :: [Word8] -> [Word8] -> Result-verifyBytesEqual outBytes expectedBytes- = if outBytes == expectedBytes- then succeeded- else failed- { reason = "outBytes ["- ++ hexDump outBytes- ++ "] /= expectedBytes ["- ++ hexDump expectedBytes- ++ "]"- }
− test/Verify/Graphics/Vty/Attributes.hs
@@ -1,73 +0,0 @@-module Verify.Graphics.Vty.Attributes- ( module Verify.Graphics.Vty.Attributes- , module Graphics.Vty.Attributes- )-where--import Graphics.Vty.Attributes-import Verify--import Data.List ( delete )--allColors :: [Color]-allColors =- [ black- , red- , green- , yellow- , blue- , magenta- , cyan- , white- , brightBlack- , brightRed- , brightGreen- , brightYellow- , brightBlue- , brightMagenta- , brightCyan- , brightWhite- ] ++ map Color240 [0..239]--allStyles :: [Style]-allStyles =- [ standout- , underline- , reverseVideo- , blink- , dim- , bold- ]---- Limit the possible attributes to just a few for now.-possibleAttrMods :: [ AttrOp ]-possibleAttrMods =- [ idOp- ] ++ map setForeColorOp allColors- ++ map setBackColorOp allColors- ++ map setStyleOp allStyles--instance Arbitrary Attr where- arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr--data DiffAttr = DiffAttr Attr Attr--instance Arbitrary DiffAttr where- arbitrary = do- op0 <- elements possibleAttrMods- let possibleAttrMods' = delete op0 possibleAttrMods- op1 <- elements possibleAttrMods'- return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr)--data AttrOp = AttrOp String (Attr -> Attr)--instance Eq AttrOp where- AttrOp n0 _ == AttrOp n1 _ = n0 == n1--setStyleOp s = AttrOp "set_style" (flip withStyle s)-setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c)-setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c)-idOp = AttrOp "id" id--applyOp :: AttrOp -> Attr -> Attr-applyOp (AttrOp _ f) a = f a
− test/Verify/Graphics/Vty/DisplayAttributes.hs
@@ -1,8 +0,0 @@-module Verify.Graphics.Vty.DisplayAttributes- ( module Verify.Graphics.Vty.DisplayAttributes- , module Graphics.Vty.DisplayAttributes- )-where--import Graphics.Vty.DisplayAttributes-import Verify
− test/Verify/Graphics/Vty/Image.hs
@@ -1,218 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DisambiguateRecordFields #-}-module Verify.Graphics.Vty.Image- ( module Verify.Graphics.Vty.Image- , module Graphics.Vty.Image- )-where--import Verify.Graphics.Vty.Attributes-import Graphics.Vty.Image-import Graphics.Vty.Image.Internal--import Verify--data UnitImage = UnitImage Char Image--instance Arbitrary UnitImage where- arbitrary = do- SingleColumnChar c <- arbitrary- a <- arbitrary- return $ UnitImage c (char a c)--instance Show UnitImage where- show (UnitImage c _) = "UnitImage " ++ show c--data DefaultImage = DefaultImage Image--instance Show DefaultImage where- show (DefaultImage i)- = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i)--instance Arbitrary DefaultImage where- arbitrary = do- i <- return $ char defAttr 'X'- return $ DefaultImage i--data SingleRowSingleAttrImage- = SingleRowSingleAttrImage- { expectedAttr :: Attr- , expectedColumns :: Int- , rowImage :: Image- }--instance Show SingleRowSingleAttrImage where- show (SingleRowSingleAttrImage attr columns image)- = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"--newtype WidthResize = WidthResize (Image -> (Image, Int))--instance Arbitrary WidthResize where- arbitrary = do- WidthResize f <- arbitrary- w <- choose (1,64)- oneof $ map (return . WidthResize)- [ \i -> (i, imageWidth i)- , \i -> (resizeWidth w $ fst $ f i, w)- , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w)- , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w)- ]--newtype HeightResize = HeightResize (Image -> (Image, Int))--instance Arbitrary HeightResize where- arbitrary = do- HeightResize f <- arbitrary- h <- choose (1,64)- oneof $ map (return . HeightResize)- [ \i -> (i, imageHeight i)- , \i -> (resizeHeight h $ fst $ f i, h)- , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h)- , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h)- ]--newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))--instance Arbitrary ImageResize where- arbitrary = oneof- [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))- , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))- , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))- , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))- , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))- , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))- , do- ImageResize f <- arbitrary- WidthResize g <- arbitrary- return $! ImageResize $! \i ->- let (i0, (_, outHeight)) = f i- gI = g i0- in (fst gI, (snd gI, outHeight))- , do- ImageResize f <- arbitrary- HeightResize g <- arbitrary- return $! ImageResize $! \i ->- let (i0, (outWidth, _)) = f i- gI = g i0- in (fst gI, (outWidth, snd gI))- ]---instance Arbitrary SingleRowSingleAttrImage where- arbitrary = do- -- The text must contain at least one character. Otherwise the- -- image simplifies to the IdImage which has a height of 0. If- -- this is to represent a single row then the height must be 1- singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)- a <- arbitrary- let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]- outWidth = length singleColumnRowText- return $ SingleRowSingleAttrImage a outWidth outImage--data SingleRowTwoAttrImage- = SingleRowTwoAttrImage- { part0 :: SingleRowSingleAttrImage- , part1 :: SingleRowSingleAttrImage- , joinImage :: Image- } deriving Show--instance Arbitrary SingleRowTwoAttrImage where- arbitrary = do- p0 <- arbitrary- p1 <- arbitrary- return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1)--data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack- { stackImage :: Image- , stackSourceImages :: [SingleRowSingleAttrImage]- , stackWidth :: Int- , stackHeight :: Int- }- deriving Show--instance Arbitrary SingleAttrSingleSpanStack where- arbitrary = do- imageList <- Verify.resize 16 (listOf1 arbitrary)- return $ mkSingleAttrSingleSpanStack imageList- shrink s = do- imageList <- shrink $ stackSourceImages s- if null imageList- then []- else return $ mkSingleAttrSingleSpanStack imageList--mkSingleAttrSingleSpanStack imageList =- let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ]- in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList)- (toEnum $ length imageList)--instance Arbitrary Image where- arbitrary = oneof- [ return EmptyImage- , do- SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary- ImageResize f <- Verify.resize 2 arbitrary- return $! fst $! f stackImage- , do- SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary- ImageResize f <- Verify.resize 2 arbitrary- return $! fst $! f stackImage- , do- i0 <- arbitrary- i1 <- arbitrary- let i = i0 <|> i1- ImageResize f <- Verify.resize 2 arbitrary- return $! fst $! f i- , do- i0 <- arbitrary- i1 <- arbitrary- let i = i0 <-> i1- ImageResize f <- Verify.resize 2 arbitrary- return $! fst $! f i- ]- {-- shrink i@(HorizJoin {partLeft, partRight}) = do- let !i_alt = backgroundFill (imageWidth i) (imageHeight i)- !partLeft' <- shrink partLeft- !partRight' <- shrink partRight- [i_alt, partLeft' <|> partRight']- shrink i@(VertJoin {partTop, partBottom}) = do- let !i_alt = backgroundFill (imageWidth i) (imageHeight i)- !partTop' <- shrink partTop- !partBottom' <- shrink partBottom- [i_alt, partTop' <-> partBottom']- shrink i@(CropRight {croppedImage, outputWidth}) = do- let !i_alt = backgroundFill (imageWidth i) (imageHeight i)- [i_alt, croppedImage]- shrink i@(CropLeft {croppedImage, leftSkip, outputWidth}) = do- let !i_alt = backgroundFill (imageWidth i) (imageHeight i)- [i_alt, croppedImage]- shrink i@(CropBottom {croppedImage, outputHeight}) = do- let !i_alt = backgroundFill (imageWidth i) (imageHeight i)- [i_alt, croppedImage]- shrink i@(CropTop {croppedImage, topSkip, outputHeight}) = do- let !i_alt = backgroundFill (imageWidth i) (imageHeight i)- [i_alt, croppedImage]- shrink i = [emptyImage, backgroundFill (imageWidth i) (imageHeight i)]- -}--data CropOperation- = CropFromLeft- | CropFromRight- | CropFromTop- | CropFromBottom- deriving (Eq, Show)--instance Arbitrary CropOperation where- arbitrary = oneof $ map return [CropFromLeft, CropFromRight, CropFromTop, CropFromBottom]--data Translation = Translation Image (Int, Int) Image- deriving (Eq, Show)--instance Arbitrary Translation where- arbitrary = do- i <- arbitrary- x <- arbitrary `suchThat` (> 0)- y <- arbitrary `suchThat` (> 0)- let i' = translate x y i- return $ Translation i (x,y) i'
− test/Verify/Graphics/Vty/Output.hs
@@ -1,59 +0,0 @@-module Verify.Graphics.Vty.Output where--import Control.Applicative ((<$>))--import Graphics.Vty.Output.Mock--import Data.IORef-import qualified Data.String.UTF8 as UTF8--import Test.QuickCheck.Property---- A list of terminals that should be supported. This started with a--- list of terminals ubuntu supported. Then those terminals that really--- could not be supported were removed. Then a few more were pruned--- until a reasonable looking set was made.-terminalsOfInterest :: [String]-terminalsOfInterest =- [ "vt100"- , "vt220"- , "vt102"- , "xterm-r5"- , "xterm-xfree86"- , "xterm-r6"- , "xterm-256color"- , "xterm-vt220"- , "xterm-debian"- , "xterm-mono"- , "xterm-color"- , "xterm"- , "mach"- , "mach-bold"- , "mach-color"- , "linux"- , "ansi"- , "hurd"- , "Eterm"- , "pcansi"- , "screen-256color"- , "screen-bce"- , "screen-s"- , "screen-w"- , "screen"- , "screen-256color-bce"- , "sun"- , "rxvt"- , "rxvt-unicode"- , "rxvt-basic"- , "cygwin"- ]--compareMockOutput :: MockData -> String -> IO Result-compareMockOutput mockData expectedStr = do- outStr <- UTF8.toString <$> readIORef mockData- if outStr /= expectedStr- then return $ failed { reason = "bytes\n" ++ outStr- ++ "\nare not the expected bytes\n"- ++ expectedStr- }- else return succeeded
− test/Verify/Graphics/Vty/Picture.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-module Verify.Graphics.Vty.Picture- ( module Verify.Graphics.Vty.Picture- , module Graphics.Vty.Picture- )-where--import Verify.Graphics.Vty.Prelude--import Graphics.Vty.Picture-import Graphics.Vty.Debug--import Verify.Graphics.Vty.Attributes-import Verify.Graphics.Vty.Image--import Verify--data DefaultPic = DefaultPic- { defaultPic :: Picture- , defaultWin :: MockWindow- }--instance Show DefaultPic where- show (DefaultPic pic win)- = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n"--instance Arbitrary DefaultPic where- arbitrary = do- DefaultImage image <- arbitrary- let win = MockWindow (imageWidth image) (imageHeight image)- return $ DefaultPic (picForImage image)- win--data PicWithBGAttr = PicWithBGAttr- { withAttrPic :: Picture- , withAttrWin :: MockWindow- , withAttrSpecifiedAttr :: Attr- } deriving ( Show )--instance Arbitrary PicWithBGAttr where- arbitrary = do- DefaultImage image <- arbitrary- let win = MockWindow (imageWidth image) (imageHeight image)- attr <- arbitrary- return $ PicWithBGAttr (picForImage image)- win- attr--instance Arbitrary Picture where- arbitrary = do- layers <- Verify.resize 20 (listOf1 arbitrary)- return $ picForLayers layers
− test/Verify/Graphics/Vty/Prelude.hs
@@ -1,24 +0,0 @@-module Verify.Graphics.Vty.Prelude- ( module Verify.Graphics.Vty.Prelude- , MockWindow(..)- )-where--import Graphics.Vty.Debug--import Verify--data EmptyWindow = EmptyWindow MockWindow--instance Arbitrary EmptyWindow where- arbitrary = return $ EmptyWindow (MockWindow (0 :: Int) (0 :: Int))--instance Show EmptyWindow where- show (EmptyWindow _) = "EmptyWindow"--instance Arbitrary MockWindow where- arbitrary = do- w <- choose (1,1024)- h <- choose (1,1024)- return $ MockWindow w h-
− test/Verify/Graphics/Vty/Span.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Verify.Graphics.Vty.Span- ( module Verify.Graphics.Vty.Span- , module Graphics.Vty.Span- )-where--import Graphics.Vty.Debug-import Graphics.Vty.Span--import Verify.Graphics.Vty.Picture--import qualified Data.Vector as Vector-import Data.Word--import Verify--isAttrSpanOp :: SpanOp -> Bool-isAttrSpanOp TextSpan {} = True-isAttrSpanOp _ = False--verifyAllSpansHaveWidth i spans w- = let v = map (\s -> (spanOpsAffectedColumns s /= w, s)) (Vector.toList spans)- in case any ((== True) . fst) v of- False -> succeeded- True -> failed { reason = "Not all spans contained operations defining exactly "- ++ show w- ++ " columns of output - \n"- ++ (concatMap ((++ "\n") . show)) v- }--verifyOpsEquality i_ops i_alt_ops =- if i_ops == i_alt_ops- then succeeded- else failed { reason = "ops for alternate image " ++ show i_alt_ops- ++ " are not the same as " ++ show i_ops- }
− test/VerifyConfig.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Main where--import Graphics.Vty.Config-import Graphics.Vty.Input.Events--import Data.String.QQ-import qualified Data.ByteString.Char8 as B--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--exampleConfig :: B.ByteString-exampleConfig = B.pack [s|--- comments should be ignored.-map _ "\ESC[B" KUp []-askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored-map _ "\ESC[1;3B" KDown [MAlt]-map "xterm" "\ESC[1;3B" KDown [MAlt]-map "xterm-256-color" "\ESC[1;3B" KDown [MAlt]-debugLog "/tmp/vty-debug.txt"-|]--exampleConfigConfig :: Config-exampleConfigConfig = defaultConfig- { debugLog = Just "/tmp/vty-debug.txt"- , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])- , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])- , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt])- , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt])- ]- }--exampleConfigParses :: IO ()-exampleConfigParses =- assertEqual "example config parses as expected"- exampleConfigConfig- (runParseConfig "exampleConfig" exampleConfig)--main :: IO ()-main = defaultMain- [ testCase "example config parses" $ exampleConfigParses- ]
− test/VerifyCropSpanGeneration.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyCropSpanGeneration where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Span--import Graphics.Vty.Debug-import Graphics.Vty.PictureToSpans--import Verify--import qualified Data.Vector as Vector--cropOpDisplayOps :: (Int -> Image -> Image) ->- Int -> Image -> (DisplayOps, Image)-cropOpDisplayOps cropOp v i =- let iOut = cropOp v i- p = picForImage iOut- w = MockWindow (imageWidth iOut) (imageHeight iOut)- in (displayOpsForPic p (regionForWindow w), iOut)--widthCropOutputColumns :: (Int -> Image -> Image) ->- SingleAttrSingleSpanStack ->- NonNegative Int ->- Property-widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==>- let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s)- in verifyAllSpansHaveWidth iOut ops w--heightCropOutputColumns :: (Int -> Image -> Image) ->- SingleAttrSingleSpanStack ->- NonNegative Int ->- Property-heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==>- let (ops, _) = cropOpDisplayOps cropOp h (stackImage s)- in displayOpsRows ops == h--cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropRightOutputColumns = widthCropOutputColumns cropRight--cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropLeftOutputColumns = widthCropOutputColumns cropLeft--cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropTopOutputRows = heightCropOutputColumns cropTop--cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropBottomOutputRows = heightCropOutputColumns cropBottom---- TODO: known benign failure.-cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property-cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==>- let i = stackImage stack- -- the right part is made by cropping the image from the left.- iR = cropLeft (imageWidth i `div` 2) i- -- the left part is made by cropping the image from the right- iL = cropRight (imageWidth i `div` 2) i- iAlt = iL <|> iR- iOps = displayOpsForImage i- iAltOps = displayOpsForImage iAlt- in verifyOpsEquality iOps iAltOps--cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property-cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==>- let i = stackImage stack- -- the top part is made by cropping the image from the bottom.- iT = cropBottom (imageHeight i `div` 2) i- -- the bottom part is made by cropping the image from the top.- iB = cropTop (imageHeight i `div` 2) i- iAlt = iT <-> iB- in displayOpsForImage i == displayOpsForImage iAlt--tests :: IO [Test]-tests = return- [ verify "cropping from the bottom produces display operations covering the expected rows"- cropBottomOutputRows- , verify "cropping from the top produces display operations covering the expected rows"- cropTopOutputRows- , verify "cropping from the left produces display operations covering the expected columns"- cropLeftOutputColumns- , verify "cropping from the right produces display operations covering the expected columns"- cropRightOutputColumns- -- TODO: known benign failure.- -- , verify "the output of a stack is the same as that stack cropped left & right and joined together"- -- cropRightAndLeftRejoinedEquivalence- , verify "the output of a stack is the same as that stack cropped top & bottom and joined together"- cropTopAndBottomRejoinedEquivalence- ]
− test/VerifyDisplayAttributes.hs
@@ -1,9 +0,0 @@-module VerifyDisplayAttributes where--import Verify.Graphics.Vty.DisplayAttributes-import Verify.Graphics.Vty.Attributes--import Verify--tests :: IO [Test]-tests = return []
− test/VerifyEmptyImageProps.hs
@@ -1,13 +0,0 @@-module VerifyEmptyImageProps where--import Verify---- should be exported by Graphics.Vty.Picture-import Graphics.Vty.Image ( Image, emptyImage )--tests :: IO [Test]-tests = do- -- should provide an image type.- let _ :: Image = emptyImage- return []-
− test/VerifyEvalTerminfoCaps.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyEvalTerminfoCaps where--import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)-import Data.Terminfo.Eval-import Data.Terminfo.Parse-import Control.DeepSeq--import qualified System.Console.Terminfo as Terminfo--import Verify-import Verify.Graphics.Vty.Output--import Control.Applicative ( (<$>) )-import Control.Exception ( try, SomeException(..) )--import Control.Monad ( mapM_, forM, forM_ )--import Data.Maybe ( fromJust )-import Data.Word--import Foreign.Marshal.Alloc (mallocBytes)-import Foreign.Ptr (Ptr, minusPtr)-import Numeric---- If a terminal defines one of the caps then it's expected to be--- parsable.-capsOfInterest =- [ "cup"- , "sc"- , "rc"- , "setf"- , "setb"- , "setaf"- , "setab"- , "op"- , "cnorm"- , "civis"- , "smcup"- , "rmcup"- , "clear"- , "hpa"- , "vpa"- , "sgr"- , "sgr0"- ]--fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)--tests :: IO [Test]-tests = do- -- 1 MB should be big enough for any termcaps ;-)- evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024)- fmap concat $ forM terminalsOfInterest $ \termName -> do- putStrLn $ "adding tests for terminal: " ++ termName- mti <- try $ Terminfo.setupTerm termName- case mti of- Left (_e :: SomeException)- -> return []- Right ti -> do- fmap concat $ forM capsOfInterest $ \capName -> do- case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of- Just capDef -> do- putStrLn $ "\tadding test for cap: " ++ capName- let testName = termName ++ "(" ++ capName ++ ")"- case parseCapExpression capDef of- Left error -> return [verify testName (failed {reason = "parse error " ++ show error})]- Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)]- Nothing -> do- return []--{-# NOINLINE verifyEvalCap #-}-verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property-verifyEvalCap evalBuffer expr !junkInt = do- forAll (vector 9) $ \inputValues ->- let write = writeCapExpr expr inputValues- !byteCount = getBound write- in liftIOResult $ do- let startPtr :: Ptr Word8 = evalBuffer- forM_ [0..100] $ \i -> runWrite write startPtr- endPtr <- runWrite write startPtr- case endPtr `minusPtr` startPtr of- count | count < 0 ->- return $ failed { reason = "End pointer before start pointer." }- | toEnum count > byteCount ->- return $ failed { reason = "End pointer past end of buffer by "- ++ show (toEnum count - byteCount)- }- | otherwise ->- return succeeded
− test/VerifyImageOps.hs
@@ -1,173 +0,0 @@-module VerifyImageOps where--import Graphics.Vty.Attributes-import Graphics.Vty.Image.Internal-import Verify.Graphics.Vty.Image--import Verify--import Control.DeepSeq--twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool-twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =- imageWidth (char defAttr c1 <|> char defAttr c2) == 2--manySwHorizConcat :: [SingleColumnChar] -> Bool-manySwHorizConcat cs =- let chars = [ char | SingleColumnChar char <- cs ]- l = fromIntegral $ length cs- in imageWidth ( horizCat $ map (char defAttr) chars ) == l--twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool-twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =- imageHeight (char defAttr c1 <-> char defAttr c2) == 2--horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool-horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =- (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2- ==- char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)--twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool-twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =- imageWidth (char defAttr c1 <|> char defAttr c2) == 4--manyDwHorizConcat :: [DoubleColumnChar] -> Bool-manyDwHorizConcat cs =- let chars = [ char | DoubleColumnChar char <- cs ]- l = fromIntegral $ length cs- in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2--twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool-twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =- imageHeight (char defAttr c1 <-> char defAttr c2) == 2--horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool-horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =- (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2- ==- char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)--vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool-vertContatSingleRow (NonEmpty stack) =- let expectedHeight :: Int = length stack- stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]- in imageHeight stackImage == expectedHeight--disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage- -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =- let expectedHeight :: Int = max (length stack0) (length stack1)- stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]- stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]- in imageHeight (stackImage0 <|> stackImage1) == expectedHeight---disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage- -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =- let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]- stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]- image = stackImage0 <|> stackImage1- expectedHeight = imageHeight image- in case image of- HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) )- &&- ( expectedHeight == (imageHeight $ partRight image) )- _ -> True--disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage- -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) =- let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)- stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]- stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]- stack0Image = vertCat stack0Images- stack1Image = vertCat stack1Images- image = stack0Image <-> stack1Image- in imageWidth image == expectedWidth--disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage- -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =- let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)- stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]- stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]- stack0Image = vertCat stack0Images- stack1Image = vertCat stack1Images- image = stack0Image <-> stack1Image- in case image of- VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )- &&- ( expectedWidth == (imageWidth $ partBottom image) )- _ -> True--translationIsLinearOnOutSize :: Translation -> Bool-translationIsLinearOnOutSize (Translation i (x,y) i') =- imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y--paddingIsLinearOnOutSize :: Image -> Gen Bool-paddingIsLinearOnOutSize i = do- l <- offset- t <- offset- r <- offset- b <- offset- let i' = pad l t r b i- return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b- where offset = choose (1,1024)--cropLeftLimitsWidth :: Image -> Int -> Property-cropLeftLimitsWidth i v = v >= 0 ==>- v >= imageWidth (cropLeft v i)--cropRightLimitsWidth :: Image -> Int -> Property-cropRightLimitsWidth i v = v >= 0 ==>- v >= imageWidth (cropRight v i)--cropTopLimitsHeight :: Image -> Int -> Property-cropTopLimitsHeight i v = v >= 0 ==>- v >= imageHeight (cropTop v i)--cropBottomLimitsHeight :: Image -> Int -> Property-cropBottomLimitsHeight i v = v >= 0 ==>- v >= imageHeight (cropBottom v i)---- rediculous tests just to satisfy my desire for nice code coverage :-P-canShowImage :: Image -> Bool-canShowImage i = length (show i) > 0--canRnfImage :: Image -> Bool-canRnfImage i = rnf i == ()--canPpImage :: Image -> Bool-canPpImage i = length (ppImageStructure i) > 0--tests :: IO [Test]-tests = return- [ verify "twoSwHorizConcat" twoSwHorizConcat- , verify "manySwHorizConcat" manySwHorizConcat- , verify "twoSwVertConcat" twoSwVertConcat- , verify "horizConcatSwAssoc" horizConcatSwAssoc- , verify "manyDwHorizConcat" manyDwHorizConcat- , verify "twoDwHorizConcat" twoDwHorizConcat- , verify "twoDwVertConcat" twoDwVertConcat- , verify "horizConcatDwAssoc" horizConcatDwAssoc- , verify "single row vert concats to correct height" vertContatSingleRow- , verify "disjointHeightHorizJoin" disjointHeightHorizJoin- , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill- , verify "disjointWidthVertJoin" disjointWidthVertJoin- , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill- , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize- , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize- , verify "crop left limits width" cropLeftLimitsWidth- , verify "crop right limits width" cropRightLimitsWidth- , verify "crop top limits height" cropTopLimitsHeight- , verify "crop bottom limits height" cropBottomLimitsHeight- , verify "can show image" canShowImage- , verify "can rnf image" canRnfImage- , verify "can pp image" canPpImage- ]
− test/VerifyImageTrans.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-module VerifyImageTrans where--import Verify.Graphics.Vty.Image--import Graphics.Vty.Image.Internal--import Verify--import Data.Word--isHorizTextOfColumns :: Image -> Int -> Bool-isHorizTextOfColumns (HorizText { outputWidth = inW }) expectedW = inW == expectedW-isHorizTextOfColumns (BGFill { outputWidth = inW }) expectedW = inW == expectedW-isHorizTextOfColumns _image _expectedW = False--verifyHorizContatWoAttrChangeSimplifies :: SingleRowSingleAttrImage -> Bool-verifyHorizContatWoAttrChangeSimplifies (SingleRowSingleAttrImage _attr charCount image) =- isHorizTextOfColumns image charCount--verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool-verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0)- (SingleRowSingleAttrImage attr1 charCount1 _image1)- i- )- | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1)- | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1)--tests :: IO [Test]-tests = return- [ verify "verifyHorizContatWoAttrChangeSimplifies" verifyHorizContatWoAttrChangeSimplifies- , verify "verifyHorizContatWAttrChangeSimplifies" verifyHorizContatWAttrChangeSimplifies- ]-
− test/VerifyInline.hs
@@ -1,31 +0,0 @@-module VerifyInline where--import Graphics.Vty.Inline-import Graphics.Vty.Output-import Graphics.Vty.Output.TerminfoBased as TerminfoBased--import Verify.Graphics.Vty.Output--import Verify--import Distribution.TestSuite--import System.IO--tests :: IO [Test]-tests = concat <$> forM terminalsOfInterest (\termName -> return $- [ Test $ TestInstance- { name = "verify vty inline"- , run = do- {- disabled because I cannot get useful output out of cabal why this fails.- nullOut <- openFile "/dev/null" WriteMode- t <- TerminfoBased.reserveTerminal termName nullOut- putAttrChange t $ default_all- releaseTerminal t- -}- return $ Finished Pass- , tags = []- , options = []- , setOption = \_ _ -> Left "no options supported"- }- ])
− test/VerifyLayersSpanGeneration.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyLayersSpanGeneration where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Attributes-import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Span--import Graphics.Vty.Debug-import Graphics.Vty.PictureToSpans--import Verify--import qualified Data.Vector as Vector--largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-largerHorizSpanOcclusion row0 row1 =- let i0 = rowImage row0- i1 = rowImage row1- (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0)- expectedOps = displayOpsForImage iLarger- p = picForLayers [iLarger, iSmaller]- ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)- in verifyOpsEquality expectedOps ops---- | Two rows stacked vertical is equivalent to the first row rendered--- as the top layer and the second row rendered as a bottom layer with a--- background fill where the first row would be.-vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-vertStackLayerEquivalence0 row0 row1 =- let i0 = rowImage row0- i1 = rowImage row1- i = i0 <-> i1- p = picForImage i- iLower = backgroundFill (imageWidth i0) 1 <-> i1- pLayered = picForLayers [i0, iLower]- expectedOps = displayOpsForImage i- opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)- in verifyOpsEquality expectedOps opsLayered--vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-vertStackLayerEquivalence1 row0 row1 =- let i0 = rowImage row0- i1 = rowImage row1- i = i0 <-> i1- p = picForImage i- iLower = i0 <-> backgroundFill (imageWidth i1) 1- iUpper = backgroundFill (imageWidth i0) 1 <-> i1- pLayered = picForLayers [iUpper, iLower]- expectedOps = displayOpsForImage i- opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)- in verifyOpsEquality expectedOps opsLayered---- | Two rows horiz joined is equivalent to the first row rendered as--- the top layer and the second row rendered as a bottom layer with a--- background fill where the first row would be.-horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-horizJoinLayerEquivalence0 row0 row1 =- let i0 = rowImage row0- i1 = rowImage row1- i = i0 <|> i1- p = picForImage i- iLower = backgroundFill (imageWidth i0) 1 <|> i1- pLayered = picForLayers [i0, iLower]- expectedOps = displayOpsForImage i- opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)- in verifyOpsEquality expectedOps opsLayered--horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-horizJoinLayerEquivalence1 row0 row1 =- let i0 = rowImage row0- i1 = rowImage row1- i = i0 <|> i1- p = picForImage i- iLower = i0 <|> backgroundFill (imageWidth i1) 1- iUpper = backgroundFill (imageWidth i0) 1 <|> i1- pLayered = picForLayers [iUpper, iLower]- expectedOps = displayOpsForImage i- opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)- in verifyOpsEquality expectedOps opsLayered--horizJoinAlternate0 :: Result-horizJoinAlternate0 =- let size = 4- str0 = replicate size 'a'- str1 = replicate size 'b'- i0 = string defAttr str0- i1 = string defAttr str1- i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)- layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1- layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1- expectedOps = displayOpsForImage i- opsLayered = displayOpsForPic (picForLayers [layer0, layer1])- (imageWidth i,imageHeight i)- in verifyOpsEquality expectedOps opsLayered--horizJoinAlternate1 :: Result-horizJoinAlternate1 =- let size = 4- str0 = replicate size 'a'- str1 = replicate size 'b'- i0 = string defAttr str0- i1 = string defAttr str1- i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)- layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1]- expectedOps = displayOpsForImage i- opsLayered = displayOpsForPic (picForLayers layers)- (imageWidth i,imageHeight i)- in verifyOpsEquality expectedOps opsLayered--tests :: IO [Test]-tests = return- [ verify "a larger horiz span occludes a smaller span on a lower layer"- largerHorizSpanOcclusion- , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"- vertStackLayerEquivalence0- , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)"- vertStackLayerEquivalence1- -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)"- -- horizJoinLayerEquivalence0- -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)"- -- horizJoinLayerEquivalence1- -- , verify "alternating images using joins is the same as alternating images using layers (0)"- -- horizJoinAlternate0- -- , verify "alternating images using joins is the same as alternating images using layers (1)"- -- horizJoinAlternate1- ]
− test/VerifyOutput.hs
@@ -1,53 +0,0 @@--- We setup the environment to envoke certain terminals of interest.--- This assumes appropriate definitions exist in the current environment--- for the terminals of interest.-module VerifyOutput where--import Verify--import Graphics.Vty--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Output--import Control.Monad--import qualified System.Console.Terminfo as Terminfo-import System.Posix.IO--tests :: IO [Test]-tests = concat <$> forM terminalsOfInterest (\termName -> do- -- check if that terminfo exists- -- putStrLn $ "testing end to end for terminal: " ++ termName- mti <- try $ Terminfo.setupTerm termName- case mti of- Left (_ :: SomeException) -> return []- Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture")- (smokeTestTermNonMac termName)- ]- )--smokeTestTermNonMac :: String -> Image -> Property-smokeTestTermNonMac termName i = liftIOResult $ do- smokeTestTerm termName i--smokeTestTerm :: String -> Image -> IO Result-smokeTestTerm termName i = do- nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags- t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName }- -- putStrLn $ "context color count: " ++ show (contextColorCount t)- reserveDisplay t- dc <- displayContext t (100,100)- -- always show the cursor to produce tests for terminals with no- -- cursor support.- let pic = (picForImage i) { picCursor = Cursor 0 0 }- outputPicture dc pic- setCursorPos t 0 0- when (supportsCursorVisibility t) $ do- hideCursor t- showCursor t- releaseDisplay t- releaseTerminal t- closeFd nullOut- return succeeded-
− test/VerifyParseTerminfoCaps.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-module VerifyParseTerminfoCaps where--import Prelude hiding ( catch )--import qualified System.Console.Terminfo as Terminfo--import Verify.Data.Terminfo.Parse-import Verify.Graphics.Vty.Output-import Verify--import Data.Maybe ( catMaybes, fromJust )-import Data.Word--import Numeric---- If a terminal defines one of the caps then it's expected to be parsable.--- TODO: reduce duplication with terminfo terminal implementation.-capsOfInterest =- [ "cup"- , "sc"- , "rc"- , "setf"- , "setb"- , "setaf"- , "setab"- , "op"- , "cnorm"- , "civis"- , "smcup"- , "rmcup"- , "clear"- , "hpa"- , "vpa"- , "sgr"- , "sgr0"- ]--fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)--tests :: IO [Test]-tests = do- parseTests <- concat <$> forM terminalsOfInterest (\termName ->- liftIO (try $ Terminfo.setupTerm termName)- >>= either (\(_e :: SomeException) -> return [])- (\ti -> concat <$> forM capsOfInterest (\capName -> do- let caseName = "\tparsing cap: " ++ capName- liftIO $ putStrLn caseName- return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of- Just capDef -> [verify (caseName ++ " -> " ++ show capDef)- (verifyParseCap capDef $ const succeeded)]- Nothing -> []- )- )- )- return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps- , verify "parse cap string with literal %" literalPercentCaps- , verify "parse cap string with %i op" incFirstTwoCaps- , verify "parse cap string with %pN op" pushParamCaps- ] ++ parseTests--verifyParseCap capString onParse =- case parseCapExpression capString of- Left error -> failed { reason = "parse error " ++ show error }- Right e -> onParse e--nonParamaterizedCaps (NonParamCapString cap) = do- verifyParseCap cap $ \e ->- let expectedBytes = map (toEnum . fromEnum) cap- outBytes = bytesForRange e 0 (length cap)- in verifyBytesEqual outBytes expectedBytes--literalPercentCaps (LiteralPercentCap capString expectedBytes) = do- verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes--incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do- verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes--pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do- verifyParseCap capString $ \e ->- let outBytes = collectBytes e- outParamCount = paramCount e- in if outParamCount == expectedParamCount- then verifyBytesEqual outBytes expectedBytes- else failed { reason = "out param count /= expected param count" }--decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do- verifyParseCap capString $ \e ->- let outBytes = collectBytes e- outParamCount = paramCount e- in if outParamCount == expectedParamCount- then verifyBytesEqual outBytes expectedBytes- else failed { reason = "out param count /= expected param count" }--printCap ti capName = do- putStrLn $ capName ++ ": " ++ show (fromCapname ti capName)--printExpression ti capName = do- let parseResult = parseCapExpression $ fromCapname ti capName- putStrLn $ capName ++ ": " ++ show parseResult
− test/VerifySimpleSpanGeneration.hs
@@ -1,188 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifySimpleSpanGeneration where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Span--import Graphics.Vty.Debug-import Graphics.Vty.PictureToSpans--import Verify--import qualified Data.Vector as Vector--unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool-unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =- let p = picForImage i- ops = displayOpsForPic p (regionForWindow w)- in displayOpsColumns ops == 0 && displayOpsRows ops == 0--unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool-unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =- let p = picForImage i- ops = displayOpsForPic p (regionForWindow w)- in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )--horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool-horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =- let p = picForImage i- ops = displayOpsForPic p (regionForWindow w)- in displayOpsColumns ops == 0 && displayOpsRows ops == 0--horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool-horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =- let p = picForImage i- ops = displayOpsForPic p (regionForWindow w)- in ( spanOpsAffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )--horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result-horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =- let p = picForImage i- w = MockWindow c 1- ops = displayOpsForPic p (regionForWindow w)- in verifyAllSpansHaveWidth i ops c--horizSpanImageAndEqualWindow1 :: SingleRowSingleAttrImage -> Bool-horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =- let p = picForImage i- w = MockWindow c 1- ops = displayOpsForPic p (regionForWindow w)- in spanOpsAffectedRows ops == 1--horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result-horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =- let p = picForImage i- lesserWidth = c `div` 2- w = MockWindow lesserWidth 1- ops = displayOpsForPic p (regionForWindow w)- in verifyAllSpansHaveWidth i ops lesserWidth--singleAttrSingleSpanStackCropped0 :: SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackCropped0 stack =- let p = picForImage (stackImage stack)- w = MockWindow (stackWidth stack `div` 2) (stackHeight stack)- ops = displayOpsForPic p (regionForWindow w)- in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack `div` 2)--singleAttrSingleSpanStackCropped1 :: SingleAttrSingleSpanStack -> Bool-singleAttrSingleSpanStackCropped1 stack =- let p = picForImage (stackImage stack)- expectedRowCount = stackHeight stack `div` 2- w = MockWindow (stackWidth stack) expectedRowCount- ops = displayOpsForPic p (regionForWindow w)- actualRowCount = spanOpsAffectedRows ops- in expectedRowCount == actualRowCount--singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackCropped2 stack0 stack1 =- let p = picForImage (stackImage stack0 <|> stackImage stack1)- w = MockWindow (stackWidth stack0) (imageHeight (picImage p))- ops = displayOpsForPic p (regionForWindow w)- in verifyAllSpansHaveWidth (picImage p) ops (stackWidth stack0)--singleAttrSingleSpanStackCropped3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool-singleAttrSingleSpanStackCropped3 stack0 stack1 =- let p = picForImage (stackImage stack0 <|> stackImage stack1)- w = MockWindow (imageWidth (picImage p)) expectedRowCount- ops = displayOpsForPic p (regionForWindow w)- expectedRowCount = imageHeight (picImage p) `div` 2- actualRowCount = spanOpsAffectedRows ops- in expectedRowCount == actualRowCount--singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackCropped4 stack0 stack1 =- let p = picForImage (stackImage stack0 <-> stackImage stack1)- w = MockWindow expectedWidth (imageHeight (picImage p))- ops = displayOpsForPic p (regionForWindow w)- expectedWidth = imageWidth (picImage p) `div` 2- in verifyAllSpansHaveWidth (picImage p) ops expectedWidth--singleAttrSingleSpanStackCropped5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool-singleAttrSingleSpanStackCropped5 stack0 stack1 =- let p = picForImage (stackImage stack0 <-> stackImage stack1)- w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)- ops = displayOpsForPic p (regionForWindow w)- expectedRowCount = stackHeight stack0- actualRowCount = spanOpsAffectedRows ops- in expectedRowCount == actualRowCount--horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result-horizSpanImageAndGreaterWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =- let p = picForImage i- -- SingleRowSingleAttrImage always has width >= 1- greaterWidth = c * 2- w = MockWindow greaterWidth 1- ops = displayOpsForPic p (regionForWindow w)- in verifyAllSpansHaveWidth i ops greaterWidth--arbImageIsCropped :: DefaultImage -> MockWindow -> Bool-arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =- let pic = picForImage image- ops = displayOpsForPic pic (regionForWindow win)- in ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w )--spanOpsActuallyFillRows :: DefaultPic -> Bool-spanOpsActuallyFillRows (DefaultPic pic win) =- let ops = displayOpsForPic pic (regionForWindow win)- expectedRowCount = regionHeight (regionForWindow win)- actualRowCount = spanOpsAffectedRows ops- in expectedRowCount == actualRowCount--spanOpsActuallyFillColumns :: DefaultPic -> Bool-spanOpsActuallyFillColumns (DefaultPic pic win) =- let ops = displayOpsForPic pic (regionForWindow win)- expectedColumnCount = regionWidth (regionForWindow win)- in allSpansHaveWidth ops expectedColumnCount--firstSpanOpSetsAttr :: DefaultPic -> Bool-firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =- let ops = displayOpsForPic pic (regionForWindow win)- in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops )--singleAttrSingleSpanStackOpCoverage :: SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackOpCoverage stack =- let p = picForImage (stackImage stack)- w = MockWindow (stackWidth stack) (stackHeight stack)- ops = displayOpsForPic p (regionForWindow w)- in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack)--imageCoverageMatchesBounds :: Image -> Result-imageCoverageMatchesBounds i =- let p = picForImage i- r = (imageWidth i,imageHeight i)- ops = displayOpsForPic p r- in verifyAllSpansHaveWidth i ops (imageWidth i)--tests :: IO [Test]-tests = return- [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0- , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1- , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0- , verify "horiz span image is cropped when window size == (0,0) [1]" horizSpanImageAndZeroWindow1- , verify "horiz span image is not cropped when window size == size of image [width]" horizSpanImageAndEqualWindow0- , verify "horiz span image is not cropped when window size == size of image [height]" horizSpanImageAndEqualWindow1- , verify "horiz span image is not cropped when window size < size of image [width]" horizSpanImageAndLesserWindow0- , verify "horiz span image is not cropped when window size > size of image [width]" horizSpanImageAndGreaterWindow0- , verify "first span op is always to set the text attribute" firstSpanOpSetsAttr- , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"- singleAttrSingleSpanStackOpCoverage- , verify "a single attr text span is cropped when window size < size of stack image [width]"- singleAttrSingleSpanStackCropped0- , verify "a single attr text span is cropped when window size < size of stack image [height]"- singleAttrSingleSpanStackCropped1- , verify "single attr text span <|> single attr text span display cropped. [width]"- singleAttrSingleSpanStackCropped2- , verify "single attr text span <|> single attr text span display cropped. [height]"- singleAttrSingleSpanStackCropped3- , verify "single attr text span <-> single attr text span display cropped. [width]"- singleAttrSingleSpanStackCropped4- , verify "single attr text span <-> single attr text span display cropped. [height]"- singleAttrSingleSpanStackCropped5- , verify "an arbitrary image when rendered to a window of the same size will cover the entire window"- imageCoverageMatchesBounds- ]-
− test/VerifyUsingMockInput.hs
@@ -1,220 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--- Generate some input bytes and delays between blocks of input bytes.--- Verify the events produced are as expected.-module Main where--import Verify.Graphics.Vty.Output--import Graphics.Vty hiding (resize)-import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Loop-import Graphics.Vty.Input.Terminfo--import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception-import Lens.Micro ((^.))-import Control.Monad--import Data.IORef-import Data.List (intersperse, reverse, nubBy)--import System.Console.Terminfo-import System.Posix.IO-import System.Posix.Terminal (openPseudoTerminal)-import System.Posix.Types-import System.Timeout--import Test.Framework.Providers.SmallCheck-import Test.Framework-import Test.SmallCheck-import Test.SmallCheck.Series--import Text.Printf---- processing a block of 16 chars is the largest I can do without taking--- too long to run the test.-maxBlockSize :: Int-maxBlockSize = 16--maxTableSize :: Int-maxTableSize = 28--forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m-forEachOf l = over (generate (\n -> take n l))--data InputEvent- = Bytes String- -- ^ Input sequence encoded as a string. Regardless, the input is- -- read a byte at a time.- | Delay Int- -- ^ Microsecond delay- deriving Show--type InputSpec = [InputEvent]--type ExpectedSpec = [Event]--synthesizeInput :: InputSpec -> Fd -> IO ()-synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")- where- f (Bytes str) = void $ fdWrite outHandle str- f (Delay t) = threadDelay t--minDetectableDelay :: Int-minDetectableDelay = 4000--minTimout :: Int-minTimout = 4000000--testKeyDelay :: Int-testKeyDelay = minDetectableDelay * 4--testEscSampleDelay :: Int-testEscSampleDelay = minDetectableDelay * 2--genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()-genEventsUsingIoActions maxDuration inputAction outputAction = do- let maxDuration' = max minTimout maxDuration- readComplete <- newEmptyMVar- writeComplete <- newEmptyMVar- _ <- forkOS $ inputAction `finally` putMVar writeComplete ()- _ <- forkOS $ outputAction `finally` putMVar readComplete ()- Just () <- timeout maxDuration' $ takeMVar writeComplete- Just () <- timeout maxDuration' $ takeMVar readComplete- return ()--compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool-compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents- where- compareEvents' [] [] = return True- compareEvents' [] outEvents' = do- printf "extra events %s\n" (show outEvents') :: IO ()- return False- compareEvents' expectedEvents' [] = do- printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()- printf "expected events %s\n" (show expectedEvents) :: IO ()- printf "received events %s\n" (show outEvents) :: IO ()- return False- compareEvents' (e : expectedEvents') (o : outEvents')- | e == o = compareEvents' expectedEvents' outEvents'- | otherwise = do- printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()- printf "expected events %s\n" (show expectedEvents) :: IO ()- printf "received events %s\n" (show outEvents) :: IO ()- return False--assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool-assertEventsFromSynInput table inputSpec expectedEvents = do- let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay- eventCount = length expectedEvents- (writeFd, readFd) <- openPseudoTerminal- (setTermAttr,_) <- attributeControl readFd- setTermAttr- let testConfig = defaultConfig { inputFd = Just readFd- , termName = Just "dummy"- , vmin = Just 1- , vtime = Just 100- }- input <- initInput testConfig table- eventsRef <- newIORef []- let writeWaitClose = do- synthesizeInput inputSpec writeFd- threadDelay minDetectableDelay- shutdownInput input- threadDelay minDetectableDelay- closeFd writeFd- closeFd readFd- -- drain output pipe- let readEvents = readLoop eventCount- readLoop 0 = return ()- readLoop n = do- e <- atomically $ readTChan $ input^.eventChannel- modifyIORef eventsRef ((:) e)- readLoop (n - 1)- genEventsUsingIoActions maxDuration writeWaitClose readEvents- outEvents <- reverse <$> readIORef eventsRef- compareEvents inputSpec expectedEvents outEvents--newtype InputBlocksUsingTable event- = InputBlocksUsingTable ([(String,event)] -> [(String, event)])--instance Show (InputBlocksUsingTable event) where- show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"--instance Monad m => Serial m (InputBlocksUsingTable event) where- series = do- n :: Int <- localDepth (const maxTableSize) series- return $ InputBlocksUsingTable $ \raw_table ->- let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table- in concat (take n (selections table))- where- selections [] = []- selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)--verifyVisibleSynInputToEvent :: Property IO-verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do- let table = visibleChars- inputSeq = gen table- events = map snd inputSeq- keydowns = map (Bytes . fst) inputSeq- input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]- assertEventsFromSynInput universalTable input events--verifyCapsSynInputToEvent :: Property IO-verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->- forEachOf terminalsOfInterest $ \terminalName -> monadic $ do- term <- setupTerm terminalName- let table = capsClassifyMap term keysFromCapsTable- inputSeq = gen table- events = map snd inputSeq- keydowns = map (Bytes . fst) inputSeq- input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]- assertEventsFromSynInput table input events--verifySpecialSynInputToEvent :: Property IO-verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do- let table = specialSupportKeys- inputSeq = gen table- events = map snd inputSeq- keydowns = map (Bytes . fst) inputSeq- input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]- assertEventsFromSynInput universalTable input events--verifyFullSynInputToEvent :: Property IO-verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->- forEachOf terminalsOfInterest $ \terminalName -> monadic $ do- term <- setupTerm terminalName- let table = classifyMapForTerm terminalName term- inputSeq = gen table- events = map snd inputSeq- keydowns = map (Bytes . fst) inputSeq- input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]- assertEventsFromSynInput table input events--verifyFullSynInputToEvent_2x :: Property IO-verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->- forEachOf terminalsOfInterest $ \terminalName -> monadic $ do- term <- setupTerm terminalName- let table = classifyMapForTerm terminalName term- inputSeq = gen table- events = concatMap ((\s -> [s,s]) . snd) inputSeq- keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq- input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]- assertEventsFromSynInput table input events--main :: IO ()-main = defaultMain- [ testProperty "synthesized typing of single visible chars translates to expected events"- verifyVisibleSynInputToEvent- , testProperty "synthesized typing of keys from capabilities tables translates to expected events"- verifyCapsSynInputToEvent- , testProperty "synthesized typing of hard coded special keys translates to expected events"- verifySpecialSynInputToEvent- , testProperty "synthesized typing of any key in the table translates to its paired event"- verifyFullSynInputToEvent- , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"- verifyFullSynInputToEvent_2x- ]-
− test/VerifyUsingMockTerminal.hs
@@ -1,108 +0,0 @@-module VerifyUsingMockTerminal where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Attributes-import Verify.Graphics.Vty.Span-import Verify.Graphics.Vty.Output-import Graphics.Vty.Output-import Graphics.Vty.Output.Interface-import Graphics.Vty.Output.Mock--import Graphics.Vty.Debug--import Verify--import qualified Data.ByteString as BS-import Data.IORef-import qualified Data.String.UTF8 as UTF8--import System.IO--unitImageUnitBounds :: UnitImage -> Property-unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do- (_,t) <- mockTerminal (1,1)- dc <- displayBounds t >>= displayContext t- let pic = picForImage i- outputPicture dc pic- return succeeded--unitImageArbBounds :: UnitImage -> MockWindow -> Property-unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do- (_,t) <- mockTerminal (w,h)- dc <- displayBounds t >>= displayContext t- let pic = picForImage i- outputPicture dc pic- return succeeded--singleTRow :: MockWindow -> Property-singleTRow (MockWindow w h) = liftIOResult $ do- (mockData,t) <- mockTerminal (w,h)- dc <- displayBounds t >>= displayContext t- -- create an image that contains just the character T repeated for a- -- single row- let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')- pic = (picForImage i) { picBackground = Background 'B' defAttr }- outputPicture dc pic- -- The mock output string that represents the output bytes a single- -- line containing the T string: Followed by h - 1 lines of a change- -- to the background attribute and then the background character- let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'- ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')- compareMockOutput mockData expected--manyTRows :: MockWindow -> Property-manyTRows (MockWindow w h) = liftIOResult $ do- (mockData, t) <- mockTerminal (w,h)- dc <- displayBounds t >>= displayContext t- -- create an image that contains the character 'T' repeated for all- -- the rows- let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')- pic = (picForImage i) { picBackground = Background 'B' defAttr }- outputPicture dc pic- -- The UTF8 string that represents the output bytes is h repeats of- -- a move, 'M', followed by an attribute change. 'A', followed by w- -- 'T's- let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')- compareMockOutput mockData expected--manyTRowsCroppedWidth :: MockWindow -> Property-manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do- (mockData,t) <- mockTerminal (w,h)- dc <- displayBounds t >>= displayContext t- -- create an image that contains the character 'T' repeated for all- -- the rows- let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')- pic = (picForImage i) { picBackground = Background 'B' defAttr }- outputPicture dc pic- -- The UTF8 string that represents the output bytes is h repeats of- -- a move, 'M', followed by an attribute change. 'A', followed by w- -- 'T's- let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')- compareMockOutput mockData expected--manyTRowsCroppedHeight :: MockWindow -> Property-manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do- (mockData,t) <- mockTerminal (w,h)- dc <- displayBounds t >>= displayContext t- -- create an image that contains the character 'T' repeated for all- -- the rows- let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')- pic = (picForImage i) { picBackground = Background 'B' defAttr }- outputPicture dc pic- -- The UTF8 string that represents the output bytes is h repeats of- -- a move, 'M', followed by an attribute change. 'A', followed by w- -- count 'T's- let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')- compareMockOutput mockData expected--tests :: IO [Test]-tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds- , verify "unitImageArbBounds" unitImageArbBounds- , verify "singleTRow" singleTRow- , verify "manyTRows" manyTRows- , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth- , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight- ]
− test/VerifyUtf8Width.hs
@@ -1,30 +0,0 @@-module VerifyUtf8Width where--import Verify--import Graphics.Text.Width-import Graphics.Vty.Attributes-import Graphics.Vty.Picture-import Graphics.Vty.Image--swIs1Column :: SingleColumnChar -> Bool-swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1--dwIs2Column :: DoubleColumnChar -> Bool-dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2--dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool-dcStringIsEven (NonEmpty dw_list) =- even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ]--safeWcwidthForControlChars :: Bool-safeWcwidthForControlChars = 0 == safeWcwidth '\NUL'--tests :: IO [Test]-tests = return- [ verify "swIs1Column" swIs1Column- , verify "dwIs2Column" dwIs2Column- , verify "a string of double characters is an even width" dcStringIsEven- , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars- ]-
− tools/BuildWidthTable.hs
@@ -1,144 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-module Main where--import qualified Control.Exception as E-import Control.Monad (when)-import Data.Maybe (fromMaybe)-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup ((<>))-#endif-import System.Directory (createDirectoryIfMissing)-import System.Environment (getArgs, getProgName)-import System.FilePath (takeDirectory)-import System.Exit (exitFailure)-import System.Console.GetOpt-import Text.Read (readMaybe)--import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName- , vtyConfigPath, addConfigWidthMap- , ConfigUpdateResult(..)- )-import Graphics.Vty.UnicodeWidthTable.IO-import Graphics.Vty.UnicodeWidthTable.Query--data Arg = Help- | OutputPath String- | TableUpperBound String- | UpdateConfig- | VtyConfigPath String- deriving (Eq, Show)--options :: Config -> [OptDescr Arg]-options config =- [ Option "h" ["help"] (NoArg Help)- "This help output"- , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")- ("The maximum Unicode code point to test when building the table " <>- "(default: " <> (show $ fromEnum $ configBound config) <> ")")- , Option "p" ["path"] (ReqArg OutputPath "PATH")- ("The output path to write to (default: " <>- fromMaybe "<none>" (configOutputPath config) <> ")")- , Option "u" ["update-config"] (NoArg UpdateConfig)- "Create or update the Vty configuration file to use the new table (default: no)"- , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")- ("Update the specified Vty configuration file path when -u is set (default: " <>- configPath config <> ")")- ]--data Config =- Config { configOutputPath :: Maybe FilePath- , configBound :: Char- , configUpdate :: Bool- , configPath :: FilePath- }- deriving (Show)--mkDefaultConfig :: IO Config-mkDefaultConfig = do- Config <$> terminalWidthTablePath- <*> pure defaultUnicodeTableUpperBound- <*> pure False- <*> vtyConfigPath--usage :: IO ()-usage = do- config <- mkDefaultConfig- pn <- getProgName- putStrLn $ "Usage: " <> pn <> " [options]"- putStrLn ""- putStrLn "This tool queries the terminal on stdout to determine the widths"- putStrLn "of Unicode characters rendered to the terminal. The resulting data"- putStrLn "is written to a table at the specified output path for later"- putStrLn "loading by Vty-based applications."- putStrLn ""-- putStrLn $ usageInfo pn (options config)--updateConfigFromArg :: Arg -> Config -> Config-updateConfigFromArg Help c =- c-updateConfigFromArg UpdateConfig c =- c { configUpdate = True }-updateConfigFromArg (VtyConfigPath p) c =- c { configPath = p }-updateConfigFromArg (TableUpperBound s) c =- case readMaybe s of- Nothing -> error $ "Invalid table upper bound: " <> show s- Just v -> c { configBound = toEnum v }-updateConfigFromArg (OutputPath p) c =- c { configOutputPath = Just p }--main :: IO ()-main = do- defConfig <- mkDefaultConfig- strArgs <- getArgs- let (args, unused, errors) = getOpt Permute (options defConfig) strArgs-- when (not $ null errors) $ do- mapM_ putStrLn errors- exitFailure-- when ((not $ null unused) || (Help `elem` args)) $ do- usage- exitFailure-- let config = foldr updateConfigFromArg defConfig args-- outputPath <- case configOutputPath config of- Nothing -> do- putStrLn "Error: could not obtain terminal width table path"- exitFailure- Just path -> return path-- putStrLn "Querying terminal:"- builtTable <- buildUnicodeWidthTable $ configBound config-- let dir = takeDirectory outputPath- createDirectoryIfMissing True dir- writeUnicodeWidthTable outputPath builtTable-- putStrLn $ "\nOutput table written to " <> outputPath-- when (configUpdate config) $ do- let cPath = configPath config- Just tName <- currentTerminalName-- result <- E.try $ addConfigWidthMap cPath tName outputPath-- case result of- Left (e::E.SomeException) -> do- putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>- show e- exitFailure- Right ConfigurationCreated -> do- putStrLn $ "Configuration file created: " <> cPath- Right ConfigurationModified -> do- putStrLn $ "Configuration file updated: " <> cPath- Right (ConfigurationConflict other) -> do- putStrLn $ "Configuration file not updated: uses a different table " <>- "for TERM=" <> tName <> ": " <> other- Right ConfigurationRedundant -> do- putStrLn $ "Configuration file not updated: configuration " <>- cPath <> " already uses table " <> outputPath <>- " for TERM=" <> tName
vty.cabal view
@@ -1,5 +1,5 @@ name: vty-version: 5.28.2+version: 6.6 license: BSD3 license-file: LICENSE author: AUTHORS@@ -9,15 +9,10 @@ synopsis: A simple terminal UI library description: vty is terminal GUI library in the niche of ncurses. It is intended to- be easy to use, have no confusing corner cases, and good support for- common terminal types.- .- See the @vty-examples@ package as well as the program- @test/interactive_terminal_test.hs@ included in the @vty@ package for- examples on how to use the library.+ be easy to use and to provide good support for common terminal types. .- Import the "Graphics.Vty" convenience module to get access to the core- parts of the library.+ See the example programs in the @vty-crossplatform@ package examples+ on how to use the library. . © 2006-2007 Stefan O'Rear; BSD3 license. .@@ -30,7 +25,9 @@ AUTHORS, CHANGELOG.md, LICENSE-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7,+ GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.4, GHC==9.10.1,+ GHC==9.12.1 source-repository head type: git@@ -38,588 +35,52 @@ library default-language: Haskell2010+ include-dirs: cbits+ hs-source-dirs: src+ ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10+ ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 build-depends: base >= 4.8 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring,- containers,- deepseq >= 1.1 && < 1.5,- directory,- filepath >= 1.0 && < 2.0,- microlens < 0.4.12,+ deepseq >= 1.1 && < 1.6,+ microlens < 0.6, microlens-mtl,- microlens-th,- hashable >= 1.2,- mtl >= 1.1.1.0 && < 2.3,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,+ mtl >= 1.1.1.0 && < 2.4, stm,- terminfo >= 0.3 && < 0.5,- transformers >= 0.3.0.0, text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,+ utf8-string >= 0.3.1 && < 1.1, vector >= 0.7, binary,- ansi-terminal >= 0.10.3+ parsec,+ filepath,+ directory if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16, fail - exposed-modules: Graphics.Vty+ exposed-modules: Graphics.Text.Width+ Graphics.Vty Graphics.Vty.Attributes- Graphics.Vty.Attributes.Color + Graphics.Vty.Attributes.Color+ Graphics.Vty.Attributes.Color240 Graphics.Vty.Config+ Graphics.Vty.Debug+ Graphics.Vty.DisplayAttributes Graphics.Vty.Error Graphics.Vty.Image+ Graphics.Vty.Image.Internal Graphics.Vty.Inline- Graphics.Vty.Inline.Unsafe Graphics.Vty.Input Graphics.Vty.Input.Events- Graphics.Vty.Picture Graphics.Vty.Output- Graphics.Text.Width- Codec.Binary.UTF8.Debug- Data.Terminfo.Parse- Data.Terminfo.Eval- Graphics.Vty.Debug- Graphics.Vty.DisplayAttributes- Graphics.Vty.Image.Internal- Graphics.Vty.Input.Classify- Graphics.Vty.Input.Classify.Types- Graphics.Vty.Input.Classify.Parse- Graphics.Vty.Input.Loop- Graphics.Vty.Input.Mouse- Graphics.Vty.Input.Focus- Graphics.Vty.Input.Paste- Graphics.Vty.Input.Terminfo+ Graphics.Vty.Output.Mock+ Graphics.Vty.Picture Graphics.Vty.PictureToSpans Graphics.Vty.Span- Graphics.Vty.Output.Mock- Graphics.Vty.Output.Interface- Graphics.Vty.Output.XTermColor- Graphics.Vty.Output.TerminfoBased- Graphics.Vty.UnicodeWidthTable.Types Graphics.Vty.UnicodeWidthTable.IO- Graphics.Vty.UnicodeWidthTable.Query Graphics.Vty.UnicodeWidthTable.Install-- other-modules: Graphics.Vty.Attributes.Color240- Graphics.Vty.Debug.Image- Graphics.Vty.Input.Terminfo.ANSIVT-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/get_tty_erase.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- hs-source-dirs: src-- default-extensions: ScopedTypeVariables-- ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10-- ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10--executable vty-build-width-table- main-is: BuildWidthTable.hs- hs-source-dirs: tools-- default-language: Haskell2010- ghc-options: -threaded -Wall-- if !impl(ghc >= 8.0)- build-depends: semigroups >= 0.16-- build-depends: vty,- directory,- filepath,- base >= 4.8 && < 5--executable vty-mode-demo- main-is: ModeDemo.hs- hs-source-dirs: demos-- default-language: Haskell2010- default-extensions: ScopedTypeVariables- ghc-options: -threaded-- build-depends: vty,- base >= 4.8 && < 5,- containers,- microlens,- microlens-mtl,- mtl >= 1.1.1.0 && < 2.3--executable vty-demo- main-is: Demo.hs- hs-source-dirs: demos-- default-language: Haskell2010- default-extensions: ScopedTypeVariables- ghc-options: -threaded-- build-depends: vty,- base >= 4.8 && < 5,- containers,- microlens,- microlens-mtl,- mtl >= 1.1.1.0 && < 2.3--test-suite verify-using-mock-terminal- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyUsingMockTerminal-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Prelude- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span- Verify.Graphics.Vty.Output-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-terminal- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyOutput-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Prelude- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span- Verify.Graphics.Vty.Output-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- terminfo >= 0.3 && < 0.5,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-display-attributes- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyDisplayAttributes-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.DisplayAttributes- Verify.Graphics.Vty.Prelude- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-empty-image-props- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyEmptyImageProps-- other-modules: Verify-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-eval-terminfo-caps- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyEvalTerminfoCaps-- other-modules: Verify- Verify.Graphics.Vty.Output-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- blaze-builder >= 0.3.3.2 && < 0.5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- terminfo >= 0.3 && < 0.5,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-image-ops- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyImageOps-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Image-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-image-trans- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyImageTrans-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Image-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-inline- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyInline-- other-modules: Verify- Verify.Graphics.Vty.Output-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-parse-terminfo-caps- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyParseTerminfoCaps-- other-modules: Verify- Verify.Data.Terminfo.Parse- Verify.Graphics.Vty.Output-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- terminfo >= 0.3 && < 0.5,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-simple-span-generation- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifySimpleSpanGeneration-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Prelude- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7---test-suite verify-crop-span-generation- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyCropSpanGeneration-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Prelude- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7---test-suite verify-layers-span-generation- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyLayersSpanGeneration-- other-modules: Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Prelude- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-utf8-width- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: detailed-0.9-- hs-source-dirs: test-- test-module: VerifyUtf8Width-- other-modules: Verify-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- mtl >= 1.1.1.0 && < 2.3,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7--test-suite verify-using-mock-input- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: exitcode-stdio-1.0-- hs-source-dirs: test-- main-is: VerifyUsingMockInput.hs-- build-depends: vty,- Cabal >= 1.20,- QuickCheck >= 2.7,- smallcheck == 1.*,- quickcheck-assertions >= 0.1.1,- test-framework == 0.8.*,- test-framework-smallcheck == 0.2.*,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- microlens,- microlens-mtl,- mtl >= 1.1.1.0 && < 2.3,- stm,- terminfo >= 0.3 && < 0.5,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7-- ghc-options: -threaded -Wall--test-suite verify-config- default-language: Haskell2010- default-extensions: ScopedTypeVariables-- type: exitcode-stdio-1.0-- hs-source-dirs: test-- main-is: VerifyConfig.hs-- build-depends: vty,- Cabal >= 1.20,- HUnit,- QuickCheck >= 2.7,- smallcheck == 1.*,- quickcheck-assertions >= 0.1.1,- test-framework == 0.8.*,- test-framework-smallcheck == 0.2.*,- test-framework-hunit,- random >= 1.0 && < 1.2,- base >= 4.8 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.5,- microlens,- microlens-mtl,- mtl >= 1.1.1.0 && < 2.3,- string-qq,- terminfo >= 0.3 && < 0.5,- text >= 0.11.3,- unix,- utf8-string >= 0.3 && < 1.1,- vector >= 0.7-- ghc-options: -threaded -Wall+ Graphics.Vty.UnicodeWidthTable.Main+ Graphics.Vty.UnicodeWidthTable.Query+ Graphics.Vty.UnicodeWidthTable.Types+ c-sources: cbits/mk_wcwidth.c