vty 4.7.5 → 6.6
raw patch · 69 files changed
Files
- AUTHORS +6/−1
- CHANGELOG +0/−89
- CHANGELOG.md +1113/−0
- LICENSE +2/−0
- README +0/−50
- README.md +173/−0
- TODO +0/−15
- cbits/gwinsz.c +0/−9
- cbits/mk_wcwidth.c +138/−96
- cbits/set_term_timing.c +0/−14
- src/Codec/Binary/UTF8/Width.hs +0/−33
- src/Data/Marshalling.hs +0/−30
- src/Data/Terminfo/Eval.hs +0/−249
- src/Data/Terminfo/Parse.hs +0/−341
- src/Graphics/Text/Width.hs +64/−0
- src/Graphics/Vty.hs +229/−129
- src/Graphics/Vty/Attributes.hs +159/−122
- src/Graphics/Vty/Attributes/Color.hs +152/−30
- src/Graphics/Vty/Attributes/Color240.hs +294/−254
- src/Graphics/Vty/Config.hs +438/−0
- src/Graphics/Vty/Debug.hs +29/−28
- src/Graphics/Vty/Debug/Image.hs +0/−32
- src/Graphics/Vty/DisplayAttributes.hs +126/−79
- src/Graphics/Vty/DisplayRegion.hs +0/−12
- src/Graphics/Vty/Error.hs +11/−0
- src/Graphics/Vty/Image.hs +334/−336
- src/Graphics/Vty/Image/Internal.hs +244/−0
- src/Graphics/Vty/Inline.hs +90/−68
- src/Graphics/Vty/Input.hs +32/−0
- src/Graphics/Vty/Input/Events.hs +100/−0
- src/Graphics/Vty/LLInput.hs +0/−250
- src/Graphics/Vty/Output.hs +367/−0
- src/Graphics/Vty/Output/Mock.hs +90/−0
- src/Graphics/Vty/Picture.hs +112/−65
- src/Graphics/Vty/PictureToSpans.hs +351/−0
- src/Graphics/Vty/Span.hs +123/−333
- src/Graphics/Vty/Terminal.hs +0/−137
- src/Graphics/Vty/Terminal/Debug.hs +0/−121
- src/Graphics/Vty/Terminal/Generic.hs +0/−417
- src/Graphics/Vty/Terminal/MacOSX.hs +0/−102
- src/Graphics/Vty/Terminal/TerminfoBased.hs +0/−437
- src/Graphics/Vty/Terminal/XTermColor.hs +0/−109
- src/Graphics/Vty/UnicodeWidthTable/IO.hs +105/−0
- src/Graphics/Vty/UnicodeWidthTable/Install.hs +129/−0
- src/Graphics/Vty/UnicodeWidthTable/Main.hs +180/−0
- src/Graphics/Vty/UnicodeWidthTable/Query.hs +70/−0
- src/Graphics/Vty/UnicodeWidthTable/Types.hs +29/−0
- test/Verify.hs +0/−85
- test/Verify/Data/Terminfo/Parse.hs +0/−120
- test/Verify/Graphics/Vty/Attributes.hs +0/−40
- test/Verify/Graphics/Vty/DisplayRegion.hs +0/−28
- test/Verify/Graphics/Vty/Image.hs +0/−90
- test/Verify/Graphics/Vty/Picture.hs +0/−50
- test/Verify/Graphics/Vty/Span.hs +0/−30
- test/VerifyAttributeOps.hs +0/−9
- test/VerifyDisplayAttributes.hs +0/−9
- test/VerifyEmptyImageProps.hs +0/−14
- test/VerifyEvalTerminfoCaps.hs +0/−130
- test/VerifyImageOps.hs +0/−125
- test/VerifyImageTrans.hs +0/−32
- test/VerifyInline.hs +0/−23
- test/VerifyMockTerminal.hs +0/−115
- test/VerifyParseTerminfoCaps.hs +0/−160
- test/VerifyPictureOps.hs +0/−8
- test/VerifyPictureToSpan.hs +0/−10
- test/VerifySpanOps.hs +0/−180
- test/VerifyUtf8Width.hs +0/−18
- test/interactive_terminal_test.hs +0/−954
- vty.cabal +56/−610
AUTHORS view
@@ -1,4 +1,6 @@-The following people should be thanked for contributing to the vty library:+The following people should be thanked for contributing to the vty+library:+ * Andrea Vezzosi * Corey O'Connor * Emily Backes@@ -15,3 +17,6 @@ * Mikolaj Konarski * Eyal Lotem * Yoshikuni Jujo+ * Dmitry Ivanov++Plus others.. Check the git log and CHANGELOG.md for a full list.
− CHANGELOG
@@ -1,89 +0,0 @@-4.7.4- * backported rgb_color from 5.0. Maps from 8 bit integer RGB to Color--4.7.0.0- * API changes:- * Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size.- * Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size.- * Added Graphics.Vty.Image.translate: Offset an image.- * Thanks Ben Boeckel <MathStuf@gmail.com> for these features.--4.3.0.0--4.2.1.0- * API changes:- * Attr record accessor fore_color changed to attr_fore_color- * Attr record accessor back_color changed to attr_back_color- * Attr record accessor style changed to attr_style- * Added an "inline" display attribute changing DSL:- * put_attr_change applies a display attribute change immediately to a terminal- * For instance, can be used to change the display attrbiutes of text output via putStrLn- and putStr. EX: "put_attr_change $ back_color red" will set the- background color to red. - * Changes do not apply to a Picture output via output_picture. - * See Graphics.Vty.Inline- * Moved all IO actions into any monad an instance of MonadIO--4.0.0.1- * binding for mk_wcswidth was incorrect. Most platforms just magically worked due to- coincidence.--4.0.0- * API changes:- * "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an- instance of the Vty data structure.- * added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated- with the Vty instance.- * Graphics.Vty.Types has undergone a number of changes. Summary:- * Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for- image combinators. Graphics.Vty.Picture for final picture construction.- * Graphics.Vty.Attributes:- * "setFG" and "setBG" are now "with_fore_color" and "with_back_color"- * All other "set.." equations similarly replaced.- * "attr" is now "def_attr", short for "default display attributes" Also added a- "current_attr" for "currently applied display attributes"- * Graphics.Vty.Image:- * "horzcat" is now "horiz_cat"- * "vertcat" is now "vert_cat"- * "renderBS" is now "utf8_bytestring"- * "renderChar" is now "char"- * "renderFill" is now "char_fill"- * added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings- and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime- representation.- * Graphics.Vty.Picture:- * exports Graphics.Vty.Image- * "pic" is now "pic_for_image"- * added API for setting background fill pattern.- * Completely rewritten output backend.- * Efficient, scanline style output span generator. Has not been fully optimized, but good- enough.- * The details required to display the desired picture on a terminal are well encapsulated.- * Terminfo based display terminal implementation. With specialized derivitives for xterm,- Terminal.app, and iTerm.app. - * Attempts to robustly handle even terminals that don't support all display attributes.- * I've tested the following terminals with success: iTerm.app, Terminal.app, xterm,- rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be- as successfull. - * Improved unicode support. Double wide characters will display as expected.- * 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted- according to the number of colors the terminal supports.- * The Graphics.Vty.Image combinators no longer require matching dimensions to arguments.- Unspecified areas are filled in with a user-customizable background pattern. See- Graphics.Vty.Picture.- * output images are always cropped to display size.- * Significant code coverage by QuickCheck tests. An interactive test for those final properties- that couldn't be automatically verified.-- issues resolved:- * "gnome terminal displays non-basic attributes as strikethrough"- * http://trac.haskell.org/vty/ticket/14- * "Multi-byte characters are not displayed correctly on update"- * http://trac.haskell.org/vty/ticket/10- * "Redraw does not handle rendering a line that extends beyond screen width characters" - * http://trac.haskell.org/vty/ticket/13- * "The <|> and <-> combinators should be more forgiving of mismatched dimensions" - * http://trac.haskell.org/vty/ticket/9- * "256-color support" - * http://trac.haskell.org/vty/ticket/19-
+ CHANGELOG.md view
@@ -0,0 +1,1113 @@++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+------++Bug fixes:+ * Added a package dependency on `semigroups` for the+ `vty-build-width-table` tool on older GHCs (#185)++5.28.1+------++Bug fixes:+ * `installUnicodeWidthTable`: use `throwIO`, not `throw`++5.28+----++This release improves Vty's support for multi-column Unicode characters+and provides greater compatibility with a wider array of terminal+emulators. The following sections summarize the relevant changes, but an+overview of the new functionality is motivated and detailed in the new+"Multi-Column Character Support" README section. For+historical context, please also consider reading over+[#175](https://github.com/jtdaugherty/vty/issues/175).++API changes:+ * New modules were added:+ * `Graphics.Vty.UnicodeWidthTable.Types`+ * `Graphics.Vty.UnicodeWidthTable.IO`+ * `Graphics.Vty.UnicodeWidthTable.Query`+ * `Graphics.Vty.UnicodeWidthTable.Install`+ * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,+ that controls whether `mkVty` will attempt to load a Unicode width+ table if specified in the configuration.++Configuration file changes:+ * A new syntax was added to support specifying Unicode width tables on+ a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the+ documentation for `Graphics.Vty.Config` for details. Since prior+ versions of this library will silently ignore any configuration file+ lines they cannot parse, this change to user configuration files is+ at least non-breaking for older versions of Vty.++Other changes:+ * The `mkVty` function now automatically attempts to load a custom+ Unicode width table if one is specified in the configuration,+ provided `allowCustomUnicodeWidthTables` is not set to `Just False`.+ See the documentation for `Graphics.Vty.mkVty` for details.+ * Vty now includes a command line tool, `vty-build-width-table`, that+ queries the terminal emulator to construct a custom Unicode width+ table and optionally update the Vty configuration file to use it.+ Programs that want to use that tool's functionality may also do so+ via the API exposed in the various modules listed above.++5.27+----++* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the+ kernel for the current terminal's settings to obtain the character+ assigned by the `stty erase` command. That can then be added to the+ Vty configuration's input map to map to `KBS` (backspace) if desired.++5.26+----++* Resolved various import warnings (thanks @glguy)+* Removed the `MonadIO` constraint from the Output type's fields and+ removed `MonadFail` uses (PR #177, thanks @glguy)+* Clarified documentation for ANSI colors (thanks Colby Jenn)+* `Graphics.Vty.Attributes` no longer re-exports+ `Graphics.Vty.Attributes.Color`+* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks+ Colby Jenn)+* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)+* Changed from using `System.Posix.Env.getEnv` to+ `System.Environment.lookupEnv` (thanks Jonathan Osser)+* Added `Graphics.Vty.Image` functions for dealing with character width+ computations on `Text` values instead of `Strings`:+ * `safeWctwidth`+ * `safeWctlwidth`+ * `wctwidth`+ * `wctlwidth`++5.25.1+------++* Avoided a conflict with a Microlens 0.4.10 operator and added an+ upper bound on Microlens of 0.4.11.++5.25+----++* The Vty type got a new field, isShutdown, that returns whether the+ Vty handle has had its 'shutdown' function called (thanks Ian+ Jeffries)+* Vty's shutdown function is now thread-safe.++5.24.1+------++* The "shutdown" method of Vty handles is now idempotent (#159)++5.24+----++* Add Generic and NFData instances for some types+* Image: remove custom Show instance, add derived Show and Read+ instances+* Updated Travis build settings (thanks Eric Mertens)++5.23.1+------++* Fixed a bug where italics did not combine properly with other display+ modes (#155, thanks Eric Mertens)++5.23+----++* Added support for italicized output when terminfo supports it. This+ takes the form of a new Style, "italic". Note that most terminfo+ descriptors do not report capabilities for italics, so support for+ this will be very spotty.+* Updateed text/string function documentation to indicate that escapes+ are not permitted in their inputs.++5.22+----++* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function+ (thanks Brent Carmer)+* Added nextEventNonblocking function (field) to Vty type (#87)++5.21+----++* Picture and Background now provide Eq instances (thanks Jaro Reinders)+* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)+* #142: note requirement of threaded RTS++5.20+----++API changes:+* Split up Monoid instances into Monoid and Semigroup for newer GHCs+ (thanks Ryan Scott)++5.19.1+------++API changes:+* Cursor now provides an Eq instance (thanks Jaro Reinders)++5.19+----++API changes:+* URL hyperlinking (via 'withURL') is now optional and disabled by+ default due to poor support on some common terminals. A new 'Mode'+ constructor, 'Hyperlink', has been added to enable this feature. To+ change the hyperlinking mode, use 'setMode' on the 'outputIface' of a+ Vty handle.++5.18.1+------++Bug fixes:+* Reset the hyperlink state on line endings to avoid run-on hyperlinks++5.18+----++API changes:+* Added support for hyperlinking attributes (thanks Getty Ritter). This+ change adds a new Attr field for containing the hyperlink to apply,+ as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda++5.17.1+------++* withStyle now ignores zero arguments, leaving attribute styles+ untouched if the input style is the null style++5.17+----++API changes:+* Add support for terminal focus events. This change adds a new mode+ usable with setMode, Focus, that requests that the terminal send+ events on focus lose/gain. This change also adds two new Event+ constructors, EvLostFocus and EvGainedFocus.+* No longer enable UTF8 mouse event encoding. This encoding was not+ working properly with Terminal.app, and using the other modes (SGR,+ etc.) work.+* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes+ #131)++5.16+----++API changes:+* Added support for mouse wheel events while in mouse mode. The Button+ type got two new constructors as a result: BScrollUp and BScrollDown.+ Thanks to doublescale@tutanota.com for this contribution!++Bug fixes:+* charFill now clamps negative arguments to zero (thanks Eric Mertens!)++5.15.1+------++Package changes:+* Documentation files are now marked accordingly (thanks Michal+ Suchánek)++Bug fixes:+* translateX/Y: fix negative translations++5.15+----++Package changes:+* Discontinued support for GHC versions prior to 7.10.1.+* Removed instructions and configuration for Stack builds since they+ are no longer supported.+* Clarified README mention of (lack of) Windows support (contributors+ wanted, though!)+* Removed dependency on data-default (see below).++API changes:+* Moved color definitions from Attributes to Color module.+* In lieu of data-default (Default) instances for Attr and Config, use+ 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.+* Graphics.Vty.Output no longer re-exports+ Graphics.Vty.Output.Interface.+* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its+ accessors to Graphics.Vty.Image.+* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.+* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.++5.14+----++* addMaybeClippedJoin: instead of raising an exception when the join+ is totally clipped, just reduce the clip amount and continue+* addMaybeClipped: skip blit of joins when their primary dimension is+ zero+* 'string' and related text functions no longer treat an empty string+ as an empty image (thanks Chris Penner). This means that now it is+ possible to use 'str ""' as a non-empty image with height 1.++5.13+----++* Reverted changes in 5.12 due to disagreements between terminal+ emulators and utf8proc; for more details, please see the ticket+ discussion at+ https://github.com/coreyoconnor/vty/issues/115++5.12+----++* Replaced 'wcwidth' with a call to the utf8proc library's character+ width function, which is much more up to date (by several Unicode+ versions) and returns the right width for a much larger set of+ characters.+* Added a bundled version of the utf8proc C library.++5.11.3+------++* Fix mouse event offsets in mouse-up events++5.11.2+------++* Mouse events were modified so that the upper-left corner of the window+ is (0,0) rather than (1,1).++5.11.1+------++* Add Generic instance for Image+* nextEvent: stop trying to refresh on a resize event (fixes segfault+ on refresh with normal cursor positioning mode)+* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)+* Update maintainer++5.11+----++* Vty now raises a VtyConfigurationError exception when the TERM+ evironment variable is missing (thanks Eric Mertens)+* Graphics.Vty.Config got an explicit export list to avoid accidentally+ exporting internal types (thanks Eric Mertens)++5.10+----++* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This+ mode provides greater control over cursor positioning by bypassing+ the logical positioning provided by default. Rather than positioning+ the cursor by looking at the widths of characters involved, this+ constructor lets you provide a physical row and column instead. This+ is useful in more sophisticated programs. (thanks Eric Mertens)+* Added a new Generic-derived config parser (thanks Eric Mertens)+* Fixed the MShift case in the configuration file parser (thanks Eric+ Mertens)+* Fixed wcwidth import and matched safeWcswidth to its documented+ behavior. Previously vty_mk_wcwidth was being imported with the+ wrong type causing the -1 return value to be mapped to the wrong Int+ value. Additionally safeWcswidth was using the unsafe character width+ function and only ensuring that the final result was non-negative.+ (thanks Eric Mertens)++5.9.1+-----++* Vty now only emits UTF8 charset sequences in terminals without a+ preexisting UTF8 declaration to avoid emitting garbage sequences+ (fixes #89)++5.9+---++* Added new Output methods supportsBell and ringTerminalBell to find out+ whether the output device has an audio bell and to ring it (see #102)++5.8.1+-----++* Fixed "refresh" to work as advertised (see #104)++5.8+---++* API change: EvPaste input event now provides paste data as a raw+ ByteString rather than a String to allow the application to decode how+ best to decode it++5.7.1+-----++* ModeDemo: added an explicit Control.Applicative import for older GHCs++5.7+---++* Mouse and paste modes are now off by default.+* The Config type got new fields: mouseMode and bracketedPasteMode.+ These determine whether these modes are enabled initially (for+ terminals that support them).+* Added a Mode type for modal terminal features (mouse events,+ bracketed paste mode) that is used with new Output interface+ functions:+ * supportsMode :: Mode -> Bool tells whether the device supports a+ mode+ * setMode :: Mode -> Bool -> IO () turns a mode on or off+ * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or+ off+* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes++5.6+---++* Added support for normal and extended mouse modes in Xterm-like+ terminals via the MouseDown and MouseUp Event constructors+* Added support for bracketed paste mode in Xterm-like terminals via+ the EvPaste event constructor+* Added derived Show instances for Event and Button (thanks Felix+ Hirn)+* Now TERM values containing "screen" will automatically use the+ XtermColor driver rather than just TerminfoBased++5.5.0+-----++* Replaced lens dependency with microlens, microlens-mtl, microlens-th+ dependencies. Issue #90+ * Thanks Jonathan Daugherty+* Cabal corrections.+ * Thanks Lennart Spitzner++5.4.0+-----++* Changed eventChannel of Graphics.Vty.Input from Chan to+ TChan. This enables clients to query if there are no pending+ events. The Graphics.Vty interface nextEvent is unchanged.+ Clients that use eventChannel directly will require updating.+ https://github.com/coreyoconnor/vty/issues/60++5.3.1+-----++* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to+ possibly breaking this on reasonable GHC versions++5.3+---++* Upgraded QuickCheck dependency to 2.7+* The standard IO Config (standardIOConfig) was overriding any provided+ application config. In addition, the inputFd and outputFd could not be+ changed if mkVty was used. Fixed.+* Correct handling of display attributes at end of line. The output+ attributes are set to default at the end of content for the line and+ at the start of a new line. Previously the current attribute would+ extend to the next start of content. This was odd to reason about and+ was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi+ requires the old behavior to display the selection region correctly.+* shutdown of the input thread is now performed using killThread and+ synchronization on an MVar. For correct handling of the terminal read+ vmin and vtime the read must be a blocking read on an OS thread.+ This places a threadWaitRead, which will be interrupted by the+ killThread, prior to the uninterruptable read. An alternative would be+ to re-import the read foreign call as interruptable.++5.2.11+------++* deepseq bounds increased for tests.+* Clean up warnings when compiling on 7.10+ * Thanks Eric Mertens+* Avoid discarding input bytes after multi-byte encoded codepoint+ * Thanks Eric Mertens++5.2.10+------++* "str" now returns EmptyImage for empty strings to match behavior of+ other string-like Image constructors (fixes #74)+ * Thanks Jonathan Daugherty++5.2.9+-----++* dependency version bumps+ * https://github.com/coreyoconnor/vty/pull/71+ * https://github.com/coreyoconnor/vty/pull/70+* Correct/Simplify the example code+ * Thanks glguy+ * https://github.com/coreyoconnor/vty/pull/69++5.2.8+-----++* blaze-builder, lens, utf8-string version constraint bump+ * Thanks glguy+ * https://github.com/coreyoconnor/vty/pull/67+* Do not differentiate based on TERM_PROGRAM+ * https://github.com/coreyoconnor/vty/issues/68++5.2.7+-----++* lens and deepseq constraint bump + misc+ * Thanks ethercrow+ * https://github.com/coreyoconnor/vty/pull/66++5.2.6+-----++* lens constraint bump+ * Thanks alexander-b!+ * https://github.com/coreyoconnor/vty/pull/64++5.2.5+-----++* lens and random version constraint bump.+ * Thanks RyanGlScott!+ * https://github.com/coreyoconnor/vty/pull/62++5.2.4+-----++* removed -fpic from cc-options. No longer required.+ * https://github.com/coreyoconnor/vty/issues/61+ * https://ghc.haskell.org/trac/ghc/ticket/9657+ * Thanks Fuuzetsu!++5.2.3+-----++* evaluate/compile the input parsing table once instead of each+ keystroke.+ * https://github.com/coreyoconnor/vty/pull/59+ * Thanks ethercrow!++5.2.2+-----++* When looking at input for an event, don't look too deep.+ * https://github.com/coreyoconnor/vty/pull/57+ * Thanks ethercrow!++5.2.1+-----++* Bump upper version bound for lens to 4.5. Thanks markus1189!++5.2.0+-----++* Config structure now specifies file descriptor to use. The default+ is stdInput and stdOutput file descriptors. Previously Vty used+ stdInput for input and the follow code for output:+ * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`+ NoBuffering)+ * the difference was required by Vty.Inline. Now, Vty.Inline uses+ the Config structure options to acheive the same effect.+* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,+ inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO+* added: inputForConfig, outputForConfig+* updates to vty-rogue from jtdaugherty. Thanks!+* the oldest version of GHC tested to support vty is 7.6.2.+* the oldest version of GHC that vty compiles under is 7.4.2++5.1.4+-----++* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!++5.1.1+-----++* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!+* jtdaugherty resolved a number of compiler warnings. Thanks!++5.1.0+-----++* vmin and vtime can be specified however the application requires.+ See Graphics.Vty.Config.+* fixed the processing of input when vmin is set > 1.++5.0.0+-----++* The naming convention now matches:+ * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions+* all projects using vty for input must be compiled with -threaded.+ Please notify vty author if this is not acceptable.+* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized+ vty with the default configuration.+* input handling changes+ * KASCII is now KChar+ * KPN5 is now KCenter+ * tests exist.+ * Applications can add to the input tables by setting inputMap of+ the Config. See Graphics.Vty.Config+ * Users can define input table extensions that will apply to all vty+ applications. See Graphics.Vty.Config+ * terminal timing is now handled by selecting an appropriate VTIME.+ Previously this was implemented within Vty itself. This reduced+ complexity in vty but provides a different meta key behavior and+ implies a requirement on -threaded.+ * The time vty will wait to verify an ESC byte means a single ESC+ key is the singleEscPeriod of the Input Config structure.+* removed the typeclass based terminal and display context interface+ in favor of a data structure of properties interface.+* renamed the Terminal interface to Output+* The default picture for an image now uses the "clear" background.+ This background fills background spans with spaces or just ends the+ line.+ * Previously the background defaulted to the space character. This+ causes issues copying text from a text editor. The text would end+ up with extra spaces at the end of the line.+* Layer support+ * Each layer is an image.+ * The layers for a picture are a list of images.+ * The first image is the top-most layer. The images are ordered from+ top to bottom.+ * The transparent areas for a layer are the backgroundFill areas.+ backgroundFill is added to pad images when images of different+ sizes are joined.+ * If the background is clear there is no background layer.+ * If there is a background character then the bottom layer is the+ background layer.+ * emptyPicture is a Picture with no layers and no cursor+ * addToTop and addToBottom add a layer to the top and bottom of the+ given Picture.+* compatibility improvements:+ * terminfo based terminals with no cursor support are silently+ accepted. The cursor visibility changes in the Picture will have+ no effect.+ * alternate (setf/setb) color maps supported. Though colors beyond+ the first 8 are just a guess.+ * added "rgbColor" for easy support of RGB specified colors.+ * Both applications and users can add to the mapping used to+ translate from input bytes to events.+* Additional information about input and output process can be+ appended to a debug log+ * Set environment variable VTY_DEBUG_LOG to path of debug log+ * Or use "debugLog <path>" config directive+ * Or set 'debugLog' property of the Config provided to mkVty.+* examples moved to vty-examples package. See test directory for cabal+ file.+ * vty-interactive-terminal-test+ * interactive test. Useful for building a bug report for vty's+ author.+ * test/interactive_terminal_test.hs+ * vty-event-echo+ * view a input event log for vty. Example of interacting with+ user.+ * test/EventEcho.hs+ * vty-rogue+ * The start of a rogue-like game. Example of layers and image+ build operations.+ * test/Rogue.hs+ * vty-benchmark+ * benchmarks vty. A series of tests that push random pictures to+ the terminal. The random pictures are generated using+ QuickCheck. The same generators used in the automated tests.+ * test/benchmark.hs++4.7.0.0+-------++API changes:+* Added Graphics.Vty.Image.crop: Ensure an image is no larger+ than the specified size.+* Added Graphics.Vty.Image.pad: Ensure an image is no smaller+ than the specified size.+* Added Graphics.Vty.Image.translate: Offset an image.+* Thanks Ben Boeckel <MathStuf@gmail.com> for these features.++4.2.1.0+-------++API changes:+* Attr record accessor fore_color changed to attr_fore_color+* Attr record accessor back_color changed to attr_back_color+* Attr record accessor style changed to attr_style+* Added an "inline" display attribute changing DSL:+ * put_attr_change applies a display attribute change+ immediately to a terminal+ * For instance, can be used to change the display attrbiutes+ of text output via putStrLn and putStr. EX:+ "put_attr_change $ back_color red" will set the background+ color to red.+ * Changes do not apply to a Picture output via output_picture.+ * See Graphics.Vty.Inline+* Moved all IO actions into any monad an instance of MonadIO++4.0.0.1+-------++* binding for mk_wcswidth was incorrect. Most platforms just+ magically worked due to coincidence.++4.0.0+-----++API changes:+* "getSize" has been removed. Use "terminal vty >>= display_bounds"+ where "vty" is an instance of the Vty data structure.+* added a "terminal" field to the Vty data structure. Accesses the+ TerminalHandle associated with the Vty instance.+* Graphics.Vty.Types has undergone a number of changes. Summary:+ * Partitioned into Graphics.Vty.Attributes for display attributes.+ Graphics.Vty.Image for image combinators. Graphics.Vty.Picture+ for final picture construction.+* Graphics.Vty.Attributes:+ * "setFG" and "setBG" are now "with_fore_color" and+ "with_back_color"+ * All other "set.." equations similarly replaced.+ * "attr" is now "def_attr", short for "default display attributes"+ Also added a "current_attr" for "currently applied display+ attributes"+* Graphics.Vty.Image:+ * "horzcat" is now "horiz_cat"+ * "vertcat" is now "vert_cat"+ * "renderBS" is now "utf8_bytestring"+ * "renderChar" is now "char"+ * "renderFill" is now "char_fill"+ * added a "utf8_string" and "string" (AKA "iso_10464_string") for+ UTF-8 encoded Strings and ISO-10464 encoded Strings. String+ literals in GHC have an ISO-10464 runtime representation.+* Graphics.Vty.Picture:+ * exports Graphics.Vty.Image+ * "pic" is now "pic_for_image"+ * added API for setting background fill pattern.+* Completely rewritten output backend.+ * Efficient, scanline style output span generator. Has not been+ fully optimized, but good enough.+ * The details required to display the desired picture on a+ terminal are well encapsulated.+ * Terminfo based display terminal implementation. With specialized+ derivitives for xterm, Terminal.app, and iTerm.app.+ * Attempts to robustly handle even terminals that don't+ support all display attributes.+ * I've tested the following terminals with success: iTerm.app,+ Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,+ konsole, screen, linux vty. Hopefully you will be as+ successfull.+ * Improved unicode support. Double wide characters will display as+ expected.+* 256 color support. See Graphics.Vty.Attributes.Color240. The actual+ output color is adjusted according to the number of colors the+ terminal supports.+* The Graphics.Vty.Image combinators no longer require matching+ dimensions to arguments. Unspecified areas are filled in with a+ user-customizable background pattern. See Graphics.Vty.Picture.+* output images are always cropped to display size.+* Significant code coverage by QuickCheck tests. An interactive test+ for those final properties that couldn't be automatically verified.++Issues resolved:+* "gnome terminal displays non-basic attributes as strikethrough"+ * http://trac.haskell.org/vty/ticket/14+* "Multi-byte characters are not displayed correctly on update"+ * http://trac.haskell.org/vty/ticket/10+* "Redraw does not handle rendering a line that extends beyond screen+ width characters"+ * http://trac.haskell.org/vty/ticket/13+* "The <|> and <-> combinators should be more forgiving of mismatched+ dimensions"+ * http://trac.haskell.org/vty/ticket/9+* "256-color support"+ * http://trac.haskell.org/vty/ticket/19
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
@@ -1,50 +0,0 @@-vty is a terminal interface library.--Vty currently provides:--* Automatic handling of window resizes.--* Supports Unicode characters on output, automatically setting and- resetting UTF-8 mode for xterm. Other terminals are assumed to support --* Efficient output. --* Minimizes repaint area, thus virtually eliminating the flicker- problem that plagues ncurses programs.--* A pure, compositional interface for efficiently constructing display- images.--* Automatically decodes keyboard keys into (key,[modifier]) tuples.--* Automatically supports refresh on Ctrl-L.--* Automatically supports timeout after 50ms for lone ESC (a barely- noticable delay)--* Interface is designed for relatively easy compatible extension.--* Supports all ANSI SGR-modes (defined in console_codes(4)) with- a type-safe interface. --* Properly handles cleanup.--Current disadvantages:--* The character encoding of the output terminal is assumed to be UTF-8.--* Minimal support for special keys on terminals other than the- linux-console. (F1-5 and arrow keys should work, but anything- shifted isn't likely to.)--* Uses the TIOCGWINSZ ioctl to find the current window size, which- appears to be limited to Linux and *BSD.--Project is hosted on github.com: https://github.com/coreyoconnor/vty--git clone git://github.com/coreyoconnor/vty.git--To compile the demonstration program: ghc --make test/Test.hs gwinsz.c--The main documentation consists of the haddock-comments and the demonstration-program
+ README.md view
@@ -0,0 +1,173 @@+[](https://travis-ci.org/jtdaugherty/vty)++`vty` is a terminal interface library. It provides a high-level+interface for doing terminal I/O. Vty is supported on GHC versions+7.10.1 and up.++`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:++* [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++# How to use 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.++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.++# Implementing support for a new platform++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`.++# 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 supports refresh on Ctrl-L.++* Provides extensible input and output interfaces.++* Properly handles cleanup (but not due to signals).++* Provides a comprehensive test suite.++* Supports "normal" and "extended" (SGR) mouse modes as described at+ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking++* Supports bracketed paste mode as described at+ http://cirw.in/blog/bracketed-paste++* Supports multi-column Unicode characters such as emoji characters. In+ cases where Vty and your terminal emulator disagree on character+ widths, Vty provides a tool `vty-build-width-table` and library+ functionality to build a width table that will work for your terminal+ and load it on application startup.++# Development Notes++Vty uses threads internally, so programs made with Vty need to be+compiled with the threaded runtime using the GHC `-threaded` option.++# Multi-Column Character Support++Vty supports rendering of multi-column characters such as two-column+Asian characters and Emoji characters. This section details how to+take advantage of this feature, since its behavior will depend on the+terminal emulator in use.++Terminal emulators support Unicode to varying degrees, and each terminal+emulator relies on a table of column widths for each supported Unicode+character. Vty also needs to rely on such a table to compute the width+of Vty images to do image layout. Since those tables can disagree if+Vty and the terminal emulator support different versions of Unicode,+and since different terminal emulators will support different versions+of Unicode, it's likely that for some wide characters, Vty applications+will exhibit rendering problems. Those rendering problems arise from Vty+and the terminal emulator coming to different conclusions about how wide+some characters are.++To address this, Vty supports loading custom character width tables+that are based on the terminal's behavior in order to eliminate these+disagreements. By default, though, Vty will use its built-in Unicode+character width table. Since the built-in table is likely to eventually+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 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:++* Via the library API in `Graphics.Vty.UnicodeWidthTable.IO`+* By adding a `widthMap` directive to your Vty configuration file and+ then invoking `mkVty` to initialize Vty++The Vty configuration file supports the `widthMap` directive to allow+users to specify which custom width table should be loaded for a given+terminal type. This is done by specifying, e.g.,++```+widthMap "xterm" "/path/to/map.dat"+```++where the first argument is the value that `TERM` must have in order for+the table to be loaded, and the second argument is the path to the table+file itself as generated by the two alternatives listed above. If the+Vty configuration file contains multiple matching `widthMap` directives+for the current value of `TERM`, the last one listed in the file is+used.++The tables declared in the configuration file are only ever+automatically loaded when applications set up Vty by calling+`Graphics.Vty.mkVty`.++Before a custom table has been loaded, calls to the library's character+width functions (e.g. `wcwidth`) will use the default built-in table.+Once a custom table has been loaded, the functions will use the new+custom table. Only one custom table load can be performed in a Vty+program. Once a custom table has been loaded, it cannot be replaced or+removed.++# 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.+ - 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++Good sources of documentation for terminal programming are:++* https://github.com/b4winckler/vim/blob/master/src/term.c+* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html+* http://ulisse.elettra.trieste.it/services/doc/serial/config.html+* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html+* http://www.unixwiz.net/techtips/termios-vmin-vtime.html+* http://vt100.net/docs/vt100-ug/chapter3.html
− TODO
@@ -1,15 +0,0 @@-- Improve input handling- - base off of haskeline input system. The haskeline input system appears to be excellent and- satisfy all of Vty's input requirements. The current haskeline distribution does not appear to- export the required modules. Either:- 0. Add the required exports to the haskeline distribution. - - fine for development but complicates the UI for production clients. Though, exposing- the modules would only complicate the appearance of haskeline's interface. - 1. Partition the backend of haskeline into a separate package usable by both vty and- haskeline.-- use compact-string for character encoding handling-- Custom cursor appearance handling?- - specific color?- - reverse video?- - auto?-
− cbits/gwinsz.c
@@ -1,9 +0,0 @@-#include <sys/ioctl.h>--unsigned long vty_c_get_window_size(void) {- struct winsize w;- if (ioctl (0, TIOCGWINSZ, &w) >= 0)- return (w.ws_row << 16) + w.ws_col;- else- return 0x190050;-}
cbits/mk_wcwidth.c view
@@ -59,15 +59,40 @@ * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c */ -#include <wchar.h>+#include <HsFFI.h>+#include <stdlib.h>+#include <string.h> +// The maximum size for a custom character width table is the total+// number of possible characters as dictated by the compiler.+#define MAX_CUSTOM_TABLE_SIZE (HS_CHAR_MAX + 1)++// The pointer to the start of the custom character width table, if+// any. If this is NULL or this is set but the ready flag is false, the+// 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.+static uint32_t custom_table_size = 0;++// A flag indicating whether the custom table is ready for+// use. This should only be set once the table has been+// allocated with vty_init_custom_table and initialized with+// vty_set_custom_table_range.+static uint8_t custom_table_ready = 0;+ struct interval { int first; int last; }; /* auxiliary function for binary search in interval table */-static int vty_bisearch(wchar_t ucs, const struct interval *table, int max) {+static int vty_bisearch(HsChar ucs, const struct interval *table, int max) { int min = 0; int mid; @@ -119,7 +144,7 @@ * in ISO 10646. */ -int vty_mk_wcwidth(wchar_t ucs)+static HsInt builtin_wcwidth(HsChar ucs) { /* sorted list of non-overlapping intervals of non-spacing characters */ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */@@ -182,7 +207,7 @@ /* binary search in table of non-spacing characters */ if (vty_bisearch(ucs, combining,- sizeof(combining) / sizeof(struct interval) - 1))+ sizeof(combining) / sizeof(struct interval) - 1)) return 0; /* if we arrive here, ucs is not a combining or C0/C1 control character */@@ -203,107 +228,124 @@ (ucs >= 0x30000 && ucs <= 0x3fffd))); } --int vty_mk_wcswidth(const wchar_t *pwcs, size_t n)+// 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, 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) {- int w, width = 0;-- for (;n-- > 0; pwcs++)- if ((w = vty_mk_wcwidth(*pwcs)) < 0)- return -1;- else- width += w;+ if (custom_table_ready) {+ if ((ch >= 0) && (ch < custom_table_size)) {+ uint8_t result = custom_table[ch]; - return width;+ // 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;+ }+ } else {+ return builtin_wcwidth(ch);+ } } --/*- * The following functions are the same as mk_wcwidth() and- * mk_wcswidth(), except that spacing characters in the East Asian- * Ambiguous (A) category as defined in Unicode Technical Report #11- * have a column width of 2. This variant might be useful for users of- * CJK legacy encodings who want to migrate to UCS without changing- * the traditional terminal character-width behaviour. It is not- * otherwise recommended for general use.- */-int vty_mk_wcwidth_cjk(wchar_t ucs)+// Initialize a custom character width table.+//+// 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 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+// the table as ready, call vty_activate_custom_table() after the table+// has been set up with calls to vty_set_custom_table_range.+int vty_init_custom_table(int size) {- /* sorted list of non-overlapping intervals of East Asian Ambiguous- * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */- static const struct interval ambiguous[] = {- { 0x00A1, 0x00A1 }, { 0x00A4, 0x00A4 }, { 0x00A7, 0x00A8 },- { 0x00AA, 0x00AA }, { 0x00AE, 0x00AE }, { 0x00B0, 0x00B4 },- { 0x00B6, 0x00BA }, { 0x00BC, 0x00BF }, { 0x00C6, 0x00C6 },- { 0x00D0, 0x00D0 }, { 0x00D7, 0x00D8 }, { 0x00DE, 0x00E1 },- { 0x00E6, 0x00E6 }, { 0x00E8, 0x00EA }, { 0x00EC, 0x00ED },- { 0x00F0, 0x00F0 }, { 0x00F2, 0x00F3 }, { 0x00F7, 0x00FA },- { 0x00FC, 0x00FC }, { 0x00FE, 0x00FE }, { 0x0101, 0x0101 },- { 0x0111, 0x0111 }, { 0x0113, 0x0113 }, { 0x011B, 0x011B },- { 0x0126, 0x0127 }, { 0x012B, 0x012B }, { 0x0131, 0x0133 },- { 0x0138, 0x0138 }, { 0x013F, 0x0142 }, { 0x0144, 0x0144 },- { 0x0148, 0x014B }, { 0x014D, 0x014D }, { 0x0152, 0x0153 },- { 0x0166, 0x0167 }, { 0x016B, 0x016B }, { 0x01CE, 0x01CE },- { 0x01D0, 0x01D0 }, { 0x01D2, 0x01D2 }, { 0x01D4, 0x01D4 },- { 0x01D6, 0x01D6 }, { 0x01D8, 0x01D8 }, { 0x01DA, 0x01DA },- { 0x01DC, 0x01DC }, { 0x0251, 0x0251 }, { 0x0261, 0x0261 },- { 0x02C4, 0x02C4 }, { 0x02C7, 0x02C7 }, { 0x02C9, 0x02CB },- { 0x02CD, 0x02CD }, { 0x02D0, 0x02D0 }, { 0x02D8, 0x02DB },- { 0x02DD, 0x02DD }, { 0x02DF, 0x02DF }, { 0x0391, 0x03A1 },- { 0x03A3, 0x03A9 }, { 0x03B1, 0x03C1 }, { 0x03C3, 0x03C9 },- { 0x0401, 0x0401 }, { 0x0410, 0x044F }, { 0x0451, 0x0451 },- { 0x2010, 0x2010 }, { 0x2013, 0x2016 }, { 0x2018, 0x2019 },- { 0x201C, 0x201D }, { 0x2020, 0x2022 }, { 0x2024, 0x2027 },- { 0x2030, 0x2030 }, { 0x2032, 0x2033 }, { 0x2035, 0x2035 },- { 0x203B, 0x203B }, { 0x203E, 0x203E }, { 0x2074, 0x2074 },- { 0x207F, 0x207F }, { 0x2081, 0x2084 }, { 0x20AC, 0x20AC },- { 0x2103, 0x2103 }, { 0x2105, 0x2105 }, { 0x2109, 0x2109 },- { 0x2113, 0x2113 }, { 0x2116, 0x2116 }, { 0x2121, 0x2122 },- { 0x2126, 0x2126 }, { 0x212B, 0x212B }, { 0x2153, 0x2154 },- { 0x215B, 0x215E }, { 0x2160, 0x216B }, { 0x2170, 0x2179 },- { 0x2190, 0x2199 }, { 0x21B8, 0x21B9 }, { 0x21D2, 0x21D2 },- { 0x21D4, 0x21D4 }, { 0x21E7, 0x21E7 }, { 0x2200, 0x2200 },- { 0x2202, 0x2203 }, { 0x2207, 0x2208 }, { 0x220B, 0x220B },- { 0x220F, 0x220F }, { 0x2211, 0x2211 }, { 0x2215, 0x2215 },- { 0x221A, 0x221A }, { 0x221D, 0x2220 }, { 0x2223, 0x2223 },- { 0x2225, 0x2225 }, { 0x2227, 0x222C }, { 0x222E, 0x222E },- { 0x2234, 0x2237 }, { 0x223C, 0x223D }, { 0x2248, 0x2248 },- { 0x224C, 0x224C }, { 0x2252, 0x2252 }, { 0x2260, 0x2261 },- { 0x2264, 0x2267 }, { 0x226A, 0x226B }, { 0x226E, 0x226F },- { 0x2282, 0x2283 }, { 0x2286, 0x2287 }, { 0x2295, 0x2295 },- { 0x2299, 0x2299 }, { 0x22A5, 0x22A5 }, { 0x22BF, 0x22BF },- { 0x2312, 0x2312 }, { 0x2460, 0x24E9 }, { 0x24EB, 0x254B },- { 0x2550, 0x2573 }, { 0x2580, 0x258F }, { 0x2592, 0x2595 },- { 0x25A0, 0x25A1 }, { 0x25A3, 0x25A9 }, { 0x25B2, 0x25B3 },- { 0x25B6, 0x25B7 }, { 0x25BC, 0x25BD }, { 0x25C0, 0x25C1 },- { 0x25C6, 0x25C8 }, { 0x25CB, 0x25CB }, { 0x25CE, 0x25D1 },- { 0x25E2, 0x25E5 }, { 0x25EF, 0x25EF }, { 0x2605, 0x2606 },- { 0x2609, 0x2609 }, { 0x260E, 0x260F }, { 0x2614, 0x2615 },- { 0x261C, 0x261C }, { 0x261E, 0x261E }, { 0x2640, 0x2640 },- { 0x2642, 0x2642 }, { 0x2660, 0x2661 }, { 0x2663, 0x2665 },- { 0x2667, 0x266A }, { 0x266C, 0x266D }, { 0x266F, 0x266F },- { 0x273D, 0x273D }, { 0x2776, 0x277F }, { 0xE000, 0xF8FF },- { 0xFFFD, 0xFFFD }, { 0xF0000, 0xFFFFD }, { 0x100000, 0x10FFFD }- };-- /* binary search in table of non-spacing characters */- if (vty_bisearch(ucs, ambiguous,- sizeof(ambiguous) / sizeof(struct interval) - 1))- return 2;-- return vty_mk_wcwidth(ucs);+ if (custom_table == NULL) {+ if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) {+ custom_table_ready = 0;+ custom_table = malloc(size);+ memset(custom_table, UNUSED_CELL, size);+ custom_table_size = size;+ return 0;+ } else {+ return 1;+ }+ } else {+ return 1;+ } } +// Set the specified character range in the custom width table to the+// specified width.+//+// This function sets 'width' as the character width for all entries+// in the custom character table starting at the 'start' entry and+// including all entries up to and including 'start + size - 1'.+//+// If this succeeds, it returns zero. If it fails, it returns 1. It+// fails if the table is not allocated, marked as ready (i.e. it is in+// use and has already been populated), or if the start or size values+// are not in bounds for the table.+int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width)+{+ if ((custom_table == NULL) ||+ (size >= custom_table_size) ||+ (start >= custom_table_size) ||+ ((start + 1) >= (custom_table_size - size)) ||+ custom_table_ready) {+ return 1;+ } else {+ memset(custom_table + start, width, size);+ return 0;+ }+} -int vty_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n)+// Mark the allocated custom character width table as ready for use.+//+// After this call, further calls to vty_set_custom_table_range will+// fail.+//+// This function returns 0 if it succeeds. If it fails, it returns 1.+// It fails if the custom table is already ready or if it has not been+// allocated.+int vty_activate_custom_table() {- int w, width = 0;+ if (custom_table_ready || (custom_table == NULL)) {+ return 1;+ } else {+ custom_table_ready = 1;+ return 0;+ }+} - for (;n-- > 0; pwcs++)- if ((w = vty_mk_wcwidth_cjk(*pwcs)) < 0)- return -1;- else- width += w;+// Returns whether a custom character width table has been marked ready.+int vty_custom_table_ready()+{+ return custom_table_ready;+} - return width;+// Deallocate the custom width table.+//+// This does nothing if there is no allocated custom width table, or if+// there is one but it is in use (marked ready). This is only useful if+// an initial allocation succeeds, but range population fails, after+// which point the application may want to deallocate the table to avoid+// leaving it in an intermediate state.+void vty_deallocate_custom_table()+{+ if ((custom_table != NULL) && (!custom_table_ready)) {+ free(custom_table);+ custom_table = NULL;+ custom_table_size = 0;+ } }
− cbits/set_term_timing.c
@@ -1,14 +0,0 @@-#include <termios.h>-#include <stdio.h>-#include <unistd.h>-#include <stdlib.h>--void vty_set_term_timing(void)-{- struct termios trm;- tcgetattr(STDIN_FILENO, &trm);- trm.c_cc[VMIN] = 0;- trm.c_cc[VTIME] = 0;- tcsetattr(STDIN_FILENO, TCSANOW, &trm); -}-
− src/Codec/Binary/UTF8/Width.hs
@@ -1,33 +0,0 @@--- Copyright 2009 Corey O'Connor-{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-}-{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-module Codec.Binary.UTF8.Width ( wcwidth- , wcswidth- )- where--import Foreign.C.Types-import Foreign.C.String-import Foreign.Storable-import Foreign.Ptr--import System.IO.Unsafe--wcwidth :: Char -> Int-wcwidth c = unsafePerformIO (withCWString [c] $! \ws -> do- wc <- peek ws- let !w = fromIntegral $! wcwidth' wc- return w- )-{-# NOINLINE wcwidth #-}--foreign import ccall unsafe "vty_mk_wcwidth" wcwidth' :: CWchar -> CInt--wcswidth :: String -> Int-wcswidth str = unsafePerformIO (withCWStringLen str $! \(ws, ws_len) -> do- let !w = fromIntegral $! wcswidth' ws (fromIntegral ws_len)- return w- )-{-# NOINLINE wcswidth #-}--foreign import ccall unsafe "vty_mk_wcswidth" wcswidth' :: Ptr CWchar -> CSize -> CInt
− src/Data/Marshalling.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- Copyright 2009 Corey O'Connor-module Data.Marshalling ( module Data.Marshalling- , module Data.Word- , module Foreign.Ptr- , module Foreign.ForeignPtr- , module Foreign.Marshal- , module Foreign.Storable- )- where--import Control.Monad.Trans--import Data.Word--import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.Marshal-import Foreign.Storable--type OutputBuffer = Ptr Word8--string_to_bytes :: String -> [Word8]-string_to_bytes str = map (toEnum . fromEnum) str--serialize_bytes :: MonadIO m => [Word8] -> OutputBuffer -> m OutputBuffer-serialize_bytes bytes !out_ptr = do- liftIO $! pokeArray out_ptr bytes- return $! out_ptr `plusPtr` ( length bytes )-
− src/Data/Terminfo/Eval.hs
@@ -1,249 +0,0 @@-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{- Evaluates the paramaterized terminfo string capability with the given parameters.- -- - todo: This can be greatly simplified.- -}-module Data.Terminfo.Eval ( cap_expression_required_bytes- , serialize_cap_expression- )- where--import Data.ByteString.Internal ( memcpy ) -import Data.Marshalling-import Data.Terminfo.Parse--import Control.Monad.Identity-import Control.Monad.State.Strict--import Data.Bits ( (.|.), (.&.), xor )-import Data.List --import GHC.Prim-import GHC.Word---- | capability evaluator state-data EvalState = EvalState- { eval_stack :: ![ CapParam ]- , eval_expression :: !CapExpression- , eval_params :: ![ CapParam ]- }--type EvalT m a = StateT EvalState m a-type Eval a = EvalT Identity a--{-# SPECIALIZE pop :: EvalT IO CapParam #-}-pop :: Monad m => EvalT m CapParam-pop = do- s <- get- let v : stack' = eval_stack s- s' = s { eval_stack = stack' }- put s'- return v--{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}-read_param :: Monad m => Word -> EvalT m CapParam-read_param pn = do- !params <- get >>= return . eval_params- return $! genericIndex params pn--{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}-push :: Monad m => CapParam -> EvalT m ()-push !v = do- s <- get- let s' = s { eval_stack = v : eval_stack s }- put s'--apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]-apply_param_ops cap params = foldl apply_param_op params (param_ops cap)--apply_param_op :: [CapParam] -> ParamOp -> [CapParam]-apply_param_op params IncFirstTwo = map (+ 1) params--cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word-cap_expression_required_bytes cap params = - let params' = apply_param_ops cap params- s_0 = EvalState [] cap params'- in fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0--cap_ops_required_bytes :: CapOps -> Eval Word-cap_ops_required_bytes ops = do- counts <- mapM cap_op_required_bytes ops- return $ sum counts--cap_op_required_bytes :: CapOp -> Eval Word-cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c-cap_op_required_bytes DecOut = do- p <- pop- return $ toEnum $ length $ show p-cap_op_required_bytes CharOut = do- _ <- pop- return 1-cap_op_required_bytes (PushParam pn) = do- read_param pn >>= push- return 0-cap_op_required_bytes (PushValue v) = do- push v- return 0-cap_op_required_bytes (Conditional expr parts) = do- c_expr <- cap_ops_required_bytes expr- c_parts <- cond_parts_required_bytes parts- return $ c_expr + c_parts- where - cond_parts_required_bytes [] = return 0- cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = 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- c_total <- if v /= 0- then cap_ops_required_bytes true_ops- else do- c_false <- cap_ops_required_bytes false_ops- c_remain <- cond_parts_required_bytes false_parts- return $ c_false + c_remain- return c_total-cap_op_required_bytes BitwiseOr = do- v_1 <- pop- v_0 <- pop- push $ v_0 .|. v_1- return 0-cap_op_required_bytes BitwiseAnd = do- v_1 <- pop- v_0 <- pop- push $ v_0 .&. v_1- return 0-cap_op_required_bytes BitwiseXOr = do- v_1 <- pop- v_0 <- pop- push $ v_0 `xor` v_1- return 0-cap_op_required_bytes ArithPlus = do- v_1 <- pop- v_0 <- pop- push $ v_0 + v_1- return 0-cap_op_required_bytes ArithMinus = do- v_1 <- pop- v_0 <- pop- push $ v_0 - v_1- return 0-cap_op_required_bytes CompareEq = do- v_1 <- pop- v_0 <- pop- push $ if v_0 == v_1 then 1 else 0- return 0-cap_op_required_bytes CompareLt = do- v_1 <- pop- v_0 <- pop- push $ if v_0 < v_1 then 1 else 0- return 0-cap_op_required_bytes CompareGt = do- v_1 <- pop- v_0 <- pop- push $ if v_0 > v_1 then 1 else 0- return 0--serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer-serialize_cap_expression cap params out_ptr = do- let params' = apply_param_ops cap params- s_0 = EvalState [] cap params'- (!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0- return $! out_ptr'--serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer-serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops--serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer-serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do- !cap <- get >>= return . eval_expression- let ( !start_ptr, _ ) = cap_bytes cap- !src_ptr = start_ptr `plusPtr` offset- !out_ptr' = out_ptr `plusPtr` next_offset- liftIO $! memcpy out_ptr src_ptr (fromIntegral byte_count)- return $! out_ptr'-serialize_cap_op out_ptr DecOut = do- p <- pop- let out_str = show p- out_bytes = string_to_bytes out_str- serialize_bytes out_bytes out_ptr-serialize_cap_op out_ptr CharOut = do- W# p <- pop- -- XXX Truncate the character value to a single byte?- let !out_byte = W8# (and# p 0xFF##)- !out_ptr' = out_ptr `plusPtr` 1- liftIO $ poke out_ptr out_byte- return out_ptr'-serialize_cap_op out_ptr (PushParam pn) = do- read_param pn >>= push- return out_ptr-serialize_cap_op out_ptr (PushValue v) = do- push v- return out_ptr-serialize_cap_op out_ptr (Conditional expr parts) = do- out_ptr' <- serialize_cap_ops out_ptr expr- out_ptr'' <- serialize_cond_parts out_ptr' parts- return out_ptr''- where - serialize_cond_parts ptr [] = return ptr- serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = 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- ptr'' <- if v /= 0- then serialize_cap_ops ptr true_ops- else do- ptr' <- serialize_cap_ops ptr false_ops- serialize_cond_parts ptr' false_parts- return ptr''--serialize_cap_op out_ptr BitwiseOr = do- v_0 <- pop- v_1 <- pop- push $ v_0 .|. v_1- return out_ptr-serialize_cap_op out_ptr BitwiseAnd = do- v_0 <- pop- v_1 <- pop- push $ v_0 .&. v_1- return out_ptr-serialize_cap_op out_ptr BitwiseXOr = do- v_1 <- pop- v_0 <- pop- push $ v_0 `xor` v_1- return out_ptr-serialize_cap_op out_ptr ArithPlus = do- v_1 <- pop- v_0 <- pop- push $ v_0 + v_1- return out_ptr-serialize_cap_op out_ptr ArithMinus = do- v_1 <- pop- v_0 <- pop- push $ v_0 - v_1- return out_ptr-serialize_cap_op out_ptr CompareEq = do- v_1 <- pop- v_0 <- pop- push $ if v_0 == v_1 then 1 else 0- return out_ptr-serialize_cap_op out_ptr CompareLt = do- v_1 <- pop- v_0 <- pop- push $ if v_0 < v_1 then 1 else 0- return out_ptr-serialize_cap_op out_ptr CompareGt = do- v_1 <- pop- v_0 <- pop- push $ if v_0 > v_1 then 1 else 0- return out_ptr-
− src/Data/Terminfo/Parse.hs
@@ -1,341 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS_GHC -funbox-strict-fields -O #-}-module Data.Terminfo.Parse ( module Data.Terminfo.Parse- , Text.ParserCombinators.Parsec.ParseError- )- where--import Control.Applicative ( Applicative(..), pure, (<*>) ) -import Control.Monad ( liftM )-import Control.Monad.Trans-import Control.DeepSeq--import Data.Monoid-import Data.Word--import Foreign.C.Types-import Foreign.Marshal.Array-import Foreign.Ptr--import Text.ParserCombinators.Parsec--type CapBytes = ( Ptr Word8, CSize )--data CapExpression = CapExpression- { cap_ops :: !CapOps- , cap_bytes :: !CapBytes- , source_string :: !String- , param_count :: !Word- , param_ops :: !ParamOps- }--instance NFData CapExpression where- rnf (CapExpression ops !_bytes !str !c !p_ops) - = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops--type CapParam = Word--type CapOps = [CapOp]-data CapOp = - Bytes !Int !CSize !Int- | 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 expression) pairs.- -- The %e expression may be NOP- | Conditional - { conditional_expr :: !CapOps- , conditional_parts :: ![(CapOps, CapOps)]- }- | BitwiseOr | BitwiseXOr | BitwiseAnd- | ArithPlus | ArithMinus- | CompareEq | CompareLt | CompareGt- deriving ( Show )--instance NFData CapOp where- rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset- rnf (PushParam pn) = rnf pn- rnf (PushValue v) = rnf v - rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts - 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 )--instance NFData ParamOp where- rnf IncFirstTwo = ()--parse_cap_expression :: ( Applicative m- , MonadIO m- )- => String - -> m ( Either ParseError CapExpression )-parse_cap_expression cap_string = - let v = runParser cap_expression_parser- initial_build_state- "terminfo cap" - cap_string - in case v of- Left e -> return $ Left e- Right build_results -> pure Right <*> construct_cap_expression cap_string build_results--construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression-construct_cap_expression cap_string build_results = do- byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string )- let expr = CapExpression- { cap_ops = out_cap_ops build_results- -- The cap bytes are the lower 8 bits of the input string's characters.- -- \todo Verify the input string actually contains an 8bit byte per character.- , cap_bytes = ( byte_array, toEnum $! length cap_string )- , source_string = cap_string- , param_count = out_param_count build_results- , param_ops = out_param_ops build_results- } - return $! rnf expr `seq` expr--type CapParser a = GenParser Char BuildState a --cap_expression_parser :: CapParser BuildResults-cap_expression_parser = do- rs <- many $ param_escape_parser <|> bytes_op_parser - return $ mconcat rs--param_escape_parser :: CapParser BuildResults-param_escape_parser = do- _ <- char '%'- inc_offset 1- literal_percent_parser <|> param_op_parser --literal_percent_parser :: CapParser BuildResults-literal_percent_parser = do- _ <- char '%'- start_offset <- getState >>= return . next_offset- inc_offset 1- return $ BuildResults 0 [Bytes start_offset 1 1] []--param_op_parser :: CapParser BuildResults-param_op_parser- = increment_op_parser - <|> push_op_parser- <|> dec_out_parser- <|> char_out_parser- <|> conditional_op_parser- <|> bitwise_op_parser- <|> arith_op_parser- <|> literal_int_op_parser- <|> compare_op_parser- <|> char_const_parser--increment_op_parser :: CapParser BuildResults-increment_op_parser = do- _ <- char 'i'- inc_offset 1- return $ BuildResults 0 [] [ IncFirstTwo ]--push_op_parser :: CapParser BuildResults-push_op_parser = do- _ <- char 'p'- param_n <- digit >>= return . (\d -> read [d])- inc_offset 2- return $ BuildResults param_n [ PushParam $ param_n - 1 ] []--dec_out_parser :: CapParser BuildResults-dec_out_parser = do- _ <- char 'd'- inc_offset 1- return $ BuildResults 0 [ DecOut ] []--char_out_parser :: CapParser BuildResults-char_out_parser = do- _ <- char 'c'- inc_offset 1- return $ BuildResults 0 [ CharOut ] []--conditional_op_parser :: CapParser BuildResults-conditional_op_parser = do- _ <- char '?'- inc_offset 1- cond_part <- many_expr conditional_true_parser- parts <- many_p - ( do- true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser- , conditional_false_parser - ]- false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser- , conditional_true_parser- ]- return ( true_part, false_part )- ) - conditional_end_parser-- let true_parts = map fst parts- false_parts = map snd parts- BuildResults n cond cond_param_ops = cond_part-- let n' = maximum $ n : map out_param_count true_parts- n'' = maximum $ n' : map out_param_count false_parts-- let true_ops = map out_cap_ops true_parts- false_ops = map out_cap_ops false_parts- cond_parts = zip true_ops false_ops-- let true_param_ops = mconcat $ map out_param_ops true_parts- false_param_ops = mconcat $ map out_param_ops false_parts- p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]-- return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops-- where - many_p !p !end = choice - [ try end >> return []- , do !v <- p - !vs <- many_p p end- return $! v : vs- ]- many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end--conditional_true_parser :: CapParser ()-conditional_true_parser = do- _ <- string "%t"- inc_offset 2--conditional_false_parser :: CapParser ()-conditional_false_parser = do- _ <- string "%e"- inc_offset 2--conditional_end_parser :: CapParser ()-conditional_end_parser = do- _ <- string "%;"- inc_offset 2--bitwise_op_parser :: CapParser BuildResults-bitwise_op_parser - = bitwise_or_parser- <|> bitwise_and_parser- <|> bitwise_xor_parser--bitwise_or_parser :: CapParser BuildResults-bitwise_or_parser = do- _ <- char '|'- inc_offset 1- return $ BuildResults 0 [ BitwiseOr ] [ ]--bitwise_and_parser :: CapParser BuildResults-bitwise_and_parser = do- _ <- char '&'- inc_offset 1- return $ BuildResults 0 [ BitwiseAnd ] [ ]--bitwise_xor_parser :: CapParser BuildResults-bitwise_xor_parser = do- _ <- char '^'- inc_offset 1- return $ BuildResults 0 [ BitwiseXOr ] [ ]--arith_op_parser :: CapParser BuildResults-arith_op_parser - = plus_op - <|> minus_op - where- plus_op = do- _ <- char '+'- inc_offset 1- return $ BuildResults 0 [ ArithPlus ] [ ]- minus_op = do- _ <- char '-'- inc_offset 1- return $ BuildResults 0 [ ArithMinus ] [ ]--literal_int_op_parser :: CapParser BuildResults-literal_int_op_parser = do- _ <- char '{'- inc_offset 1- n_str <- many1 digit- inc_offset $ toEnum $ length n_str- let n :: Word = read n_str- _ <- char '}'- inc_offset 1- return $ BuildResults 0 [ PushValue n ] [ ]--compare_op_parser :: CapParser BuildResults-compare_op_parser - = compare_eq_op- <|> compare_lt_op - <|> compare_gt_op - where- compare_eq_op = do- _ <- char '='- inc_offset 1- return $ BuildResults 0 [ CompareEq ] [ ]- compare_lt_op = do- _ <- char '<'- inc_offset 1- return $ BuildResults 0 [ CompareLt ] [ ]- compare_gt_op = do- _ <- char '>'- inc_offset 1- return $ BuildResults 0 [ CompareGt ] [ ]--bytes_op_parser :: CapParser BuildResults-bytes_op_parser = do- bytes <- many1 $ satisfy (/= '%')- start_offset <- getState >>= return . next_offset- let !c = length bytes- !s <- getState- let s' = s { next_offset = start_offset + c }- setState s'- return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] []--char_const_parser :: CapParser BuildResults-char_const_parser = do- _ <- char '\''- char_value <- liftM (toEnum . fromEnum) anyChar - _ <- char '\''- inc_offset 3- return $ BuildResults 0 [ PushValue char_value ] [ ]--data BuildState = BuildState - { next_offset :: Int- } --inc_offset :: Int -> CapParser ()-inc_offset n = do- s <- getState- let s' = s { next_offset = next_offset s + n }- setState s'--initial_build_state :: BuildState-initial_build_state = BuildState 0--data BuildResults = BuildResults- { out_param_count :: !Word- , out_cap_ops :: !CapOps- , out_param_ops :: !ParamOps- }--instance Monoid BuildResults where- mempty = BuildResults 0 [] []- v0 `mappend` v1 - = BuildResults- { out_param_count = (out_param_count v0) `max` (out_param_count v1)- , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)- , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)- }-
+ src/Graphics/Text/Width.hs view
@@ -0,0 +1,64 @@+-- Copyright 2009 Corey O'Connor+{-# OPTIONS_GHC -D_XOPEN_SOURCE #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- | This module provides functions to measure the terminal column width+-- of characters and strings.+--+-- The functions provided in this module all ultimately make calls to+-- the C implementation in @cbits/mk_wcwidth.c@. That code manages some+-- global state that carries a table of Unicode character widths. For+-- more details, see 'Graphics.Vty.UnicodeWidthTable.Install', the C+-- code, and the "Multi-Column Character Support" section of the project+-- @README@.+module Graphics.Text.Width+ ( wcwidth+ , wcswidth+ , wctwidth+ , wctlwidth+ , safeWcwidth+ , safeWcswidth+ , safeWctwidth+ , safeWctlwidth+ )+where++import Data.List (foldl')+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int++wcswidth :: String -> Int+wcswidth = foldl' (\l c -> wcwidth c + l) 0+{-# INLINE [1] wcswidth #-}++wctwidth :: T.Text -> Int+wctwidth = T.foldl' (\l c -> wcwidth c + l) 0++wctlwidth :: TL.Text -> Int+wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0++{-# RULES+"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x+"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x+ #-}++-- | Returns the display width of a character. Assumes all characters+-- with unknown widths are 0 width.+safeWcwidth :: Char -> Int+safeWcwidth = max 0 . wcwidth++-- | Returns the display width of a string. Assumes all characters with+-- unknown widths are 0 width.+safeWcswidth :: String -> Int+safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0++-- | Returns the display width of a text. Assumes all characters with+-- unknown widths are 0 width.+safeWctwidth :: T.Text -> Int+safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0++-- | Returns the display width of a lazy text. Assumes all characters+-- with unknown widths are 0 width.+safeWctlwidth :: TL.Text -> Int+safeWctlwidth = TL.foldl' (\l c -> safeWcwidth c + l) 0
src/Graphics/Vty.hs view
@@ -1,149 +1,249 @@--- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE ForeignFunctionInterface, BangPatterns, UnboxedTuples #-}-{-# CFILES gwinsz.c #-}---- Good sources of documentation for terminal programming are:--- vt100 control sequences: http://vt100.net/docs/vt100-ug/chapter3.html#S3.3.3--- Xterm control sequences: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html--module Graphics.Vty ( Vty(..)- , mkVty- , mkVtyEscDelay- , module Graphics.Vty.Terminal- , module Graphics.Vty.Picture- , module Graphics.Vty.DisplayRegion- , Key(..)- , Modifier(..)- , Button(..)- , Event(..)- ) - where+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} +-- | Vty provides interfaces for both terminal input and terminal+-- output.+--+-- - User input to the terminal is provided to the Vty application as a+-- sequence of 'Event's.+--+-- - 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.+--+-- - 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.+--+-- As a small example, the following program demonstrates the use of Vty+-- on a Unix system using the @vty-unix@ package:+--+-- > 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(..)+ , setWindowTitle+ , installCustomWidthTable+ , mkVtyFromPair+ , module Graphics.Vty.Config+ , module Graphics.Vty.Input+ , module Graphics.Vty.Input.Events+ , module Graphics.Vty.Output+ , module Graphics.Vty.Picture+ , module Graphics.Vty.Image+ , module Graphics.Vty.Attributes+ )+where -import Graphics.Vty.Terminal+import Graphics.Vty.Config+import Graphics.Vty.Input+import Graphics.Vty.Input.Events+import Graphics.Vty.Output import Graphics.Vty.Picture-import Graphics.Vty.DisplayRegion-import Graphics.Vty.LLInput+import Graphics.Vty.Image+import Graphics.Vty.Attributes+import Graphics.Vty.UnicodeWidthTable.IO+import Graphics.Vty.UnicodeWidthTable.Install +import qualified Control.Exception as E+import Control.Monad (when)+import Control.Concurrent.STM+ import Data.IORef+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif -import qualified System.Console.Terminfo as Terminfo+-- | A 'Vty' value represents a handle to the Vty library that the+-- application must create in order to use Vty.+--+-- The use of this library typically follows this process:+--+-- 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.+--+-- 3. Use 'nextEvent' to get the next input event.+--+-- 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.+--+-- Operations on Vty handles are not thread-safe.+data Vty =+ Vty { update :: Picture -> IO ()+ -- ^ Output the given 'Picture' to the terminal.+ , nextEvent :: IO Event+ -- ^ Return the next 'Event' or block until one becomes+ -- available.+ , nextEventNonblocking :: IO (Maybe Event)+ -- ^ Non-blocking version of 'nextEvent'.+ , inputIface :: Input+ -- ^ The input interface. See 'Input'.+ , outputIface :: Output+ -- ^ The output interface. See 'Output'.+ , refresh :: IO ()+ -- ^ Refresh the display. If other programs output to the+ -- terminal and mess up the display then the application might+ -- want to force a refresh using this function.+ , shutdown :: IO ()+ -- ^ Clean up after vty. A call to this function is necessary to+ -- cleanly restore the terminal state before application exit.+ -- The above methods will throw an exception if executed after+ -- this is executed. Idempotent.+ , isShutdown :: IO Bool+ } --- | The main object. At most one should be created.--- An alternative is to use unsafePerformIO to automatically create a singleton Vty instance when--- required.+-- | Attempt to load and install a custom character width table into+-- this process. ----- This does not assure any thread safety. In theory, as long as an update action is not executed--- when another update action is already then it's safe to call this on multiple threads.--- --- todo: Once the Terminal interface encompasses input this interface will be deprecated.--- Currently, just using the Terminal interface there is no support for input events.-data Vty = Vty - { -- | Outputs the given Picture. Equivalent to output_picture applied to a display context- -- implicitly managed by Vty. - update :: Picture -> IO ()- -- | Get one Event object, blocking if necessary.- , next_event :: IO Event- -- | Handle to the terminal interface. See `Terminal`- --- -- The use of Vty typically follows this process:- --- -- 0. initialize vty- --- -- 1. use the update equation of Vty to display a picture- --- -- 2. repeat- --- -- 3. shutdown vty. - -- - -- todo: provide a similar abstraction to Graphics.Vty.Terminal for input. Use haskeline's- -- input backend for implementation.- -- - -- todo: remove explicit `shutdown` requirement. - , terminal :: TerminalHandle- -- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some- -- other program might output to the terminal and mess the display. In that case the user- -- might want to force a refresh.- , refresh :: IO ()- -- | Clean up after vty.- -- The above methods will throw an exception if executed after this is executed.- , shutdown :: IO () - }+-- 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" --- | Set up the state object for using vty. At most one state object should be--- created at a time.-mkVty :: IO Vty-mkVty = mkVtyEscDelay 0+ customInstalled <- isCustomTableReady+ when (not customInstalled) $ do+ case tblName of+ Nothing ->+ doLog "No terminal name given in the configuration, skipping load"+ Just name ->+ case lookup name widthMaps of+ Nothing ->+ doLog $ "Width table " <> show name <> " not found in custom character width mapping list"+ Just path -> do+ tableResult <- E.try $ readUnicodeWidthTable path+ case tableResult of+ Left (e::E.SomeException) ->+ doLog $ "Error reading custom character width table " <>+ "at " <> show path <> ": " <> show e+ Right (Left msg) ->+ doLog $ "Error reading custom character width table " <>+ "at " <> show path <> ": " <> msg+ Right (Right table) -> do+ installResult <- E.try $ installUnicodeWidthTable table+ case installResult of+ Left (e::E.SomeException) ->+ doLog $ "Error installing unicode table (" <>+ show path <> ": " <> show e+ Right () ->+ doLog $ "Successfully installed Unicode width table " <>+ " from " <> show path --- | Set up the state object for using vty. At most one state object should be--- created at a time. The delay, in microseconds, specifies the period of time to wait for a key--- following reading ESC from the terminal before considering the ESC key press as a discrete event.-mkVtyEscDelay :: Int -> IO Vty-mkVtyEscDelay escDelay = do - term_info <- Terminfo.setupTermFromEnv - t <- terminal_handle- reserve_display t- (kvar, endi) <- initTermInput escDelay term_info- intMkVty kvar ( endi >> release_display t >> release_terminal t ) t+-- | 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 -intMkVty :: IO Event -> IO () -> TerminalHandle -> IO Vty-intMkVty kvar fend t = do- last_pic_ref <- newIORef Nothing- last_update_ref <- newIORef Nothing+ shutdownVar <- newTVarIO False+ let shutdownIo = do+ alreadyShutdown <- atomically $ swapTVar shutdownVar True+ when (not alreadyShutdown) $ do+ shutdownInput input+ releaseDisplay out+ releaseTerminal out - let inner_update in_pic = do- b <- display_bounds t- let DisplayRegion w h = b- cursor = pic_cursor in_pic- in_pic' = case cursor of- Cursor x y ->- let- x' = case x of- _ | x >= 0x80000000 -> 0- | x >= w -> w - 1- | otherwise -> x- y' = case y of- _ | y >= 0x80000000 -> 0- | y >= h -> h - 1- | otherwise -> y- in in_pic { pic_cursor = Cursor x' y' }- _ -> in_pic- mlast_update <- readIORef last_update_ref- update_data <- case mlast_update of+ shutdownStatus = readTVarIO shutdownVar++ lastPicRef <- newIORef Nothing+ lastUpdateRef <- newIORef Nothing++ let innerUpdate inPic = do+ b <- displayBounds out+ mlastUpdate <- readIORef lastUpdateRef+ updateData <- case mlastUpdate of Nothing -> do- d <- display_context t b- output_picture d in_pic'- return (b, d)- Just (last_bounds, last_context) -> do- if b /= last_bounds+ dc <- displayContext out b+ outputPicture dc inPic+ return (b, dc)+ Just (lastBounds, lastContext) -> do+ if b /= lastBounds then do- d <- display_context t b- output_picture d in_pic'- return (b, d)+ dc <- displayContext out b+ outputPicture dc inPic+ return (b, dc) else do- output_picture last_context in_pic'- return (b, last_context)- writeIORef last_update_ref $ Just update_data- writeIORef last_pic_ref $ Just in_pic'+ outputPicture lastContext inPic+ return (b, lastContext)+ writeIORef lastUpdateRef $ Just updateData+ writeIORef lastPicRef $ Just inPic - let inner_refresh - = writeIORef last_update_ref Nothing- >> readIORef last_pic_ref - >>= maybe ( return () ) ( \pic -> inner_update pic ) + innerRefresh = do+ writeIORef lastUpdateRef Nothing+ bounds <- displayBounds out+ dc <- displayContext out bounds+ writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState+ mPic <- readIORef lastPicRef+ maybe (return ()) innerUpdate mPic - let gkey = do k <- kvar- case k of - (EvResize _ _) -> inner_refresh - >> display_bounds t - >>= return . ( \(DisplayRegion w h) - -> EvResize (fromEnum w) (fromEnum h)- )- _ -> return k+ mkResize = uncurry EvResize <$> displayBounds out - return $ Vty { update = inner_update- , next_event = gkey- , terminal = t- , refresh = inner_refresh- , shutdown = fend + translateInternalEvent ResumeAfterInterrupt = mkResize+ translateInternalEvent (InputEvent e) = return e++ gkey = do+ e <- atomically $ readTChan $ eventChannel input+ translateInternalEvent e+ gkey' = do+ mEv <- atomically $ tryReadTChan $ eventChannel input+ case mEv of+ Just e -> Just <$> translateInternalEvent e+ Nothing -> return Nothing++ return $ Vty { update = innerUpdate+ , nextEvent = gkey+ , nextEventNonblocking = gkey'+ , inputIface = input+ , outputIface = out+ , refresh = innerRefresh+ , 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,11 +1,89 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+ -- | Display attributes ----- For efficiency, this could be encoded into a single 32 bit word. The 32 bit word is first divided--- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to--- the other groups.+-- Attributes have three components: a foreground color, a background+-- color, and a style mask. The simplest attribute is the default+-- attribute, or 'defAttr'. Attributes can be modified with+-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,+--+-- @+-- defAttr \`withForeColor\` red+-- @+--+-- 'Image' constructors often require an 'Attr' to indicate the+-- attributes used in the image, e.g.,+--+-- @+-- string (defAttr \`withForeColor\` red) "this text will be red"+-- @+--+-- The appearance of 'Image's using 'defAttr' is determined by the The+-- terminal, so this is not something VTY can control. The user is free+-- to The define the color scheme of the terminal as they see fit.+--+-- The value 'currentAttr' will keep the attributes of whatever was+-- output previously.+module Graphics.Vty.Attributes+ ( module Graphics.Vty.Attributes.Color++ , Attr(..)+ , FixedAttr(..)+ , MaybeDefault(..)+ , defAttr+ , currentAttr++ -- * Styles+ , Style+ , withStyle+ , standout+ , italic+ , strikethrough+ , underline+ , reverseVideo+ , blink+ , dim+ , bold+ , defaultStyleMask+ , styleMask+ , hasStyle++ -- * Setting attribute colors+ , withForeColor+ , withBackColor++ -- * Setting hyperlinks+ , withURL+ )+where++import Control.DeepSeq+import Data.Bits+import Data.Text (Text)+import Data.Word+import GHC.Generics++import Graphics.Vty.Attributes.Color++-- | A display attribute defines the Color and Style of all the+-- characters rendered after the attribute is applied.+--+-- At most 256 colors, picked from a 240 and 16 color palette, are+-- possible for the background and foreground. The 240 colors and+-- 16 colors are points in different palettes. See Color for more+-- information.+data Attr = Attr+ { attrStyle :: !(MaybeDefault Style)+ , attrForeColor :: !(MaybeDefault Color)+ , attrBackColor :: !(MaybeDefault Color)+ , attrURL :: !(MaybeDefault Text)+ } deriving ( Eq, Show, Read, Generic, NFData )++-- This could be encoded into a single 32 bit word. The 32 bit word is+-- first divided into 4 groups of 8 bits where: The first group codes+-- what action should be taken with regards to the other groups. -- XXYYZZ__ -- XX - style action -- 00 => reset to default@@ -22,115 +100,53 @@ -- __ - unused -- -- Next is the style flags--- SURBDO__+-- SURBDOI_ -- S - standout -- U - underline -- R - reverse video -- B - blink -- D - dim -- O - bold--- __ - unused+-- I - italic+-- _ - unused -- -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits.----module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes- , module Graphics.Vty.Attributes.Color- , module Graphics.Vty.Attributes.Color240- )- where -import Graphics.Vty.Attributes.Color-import Graphics.Vty.Attributes.Color240--import Data.Bits-import Data.Monoid-import Data.Word---- | A display attribute defines the Color and Style of all the characters rendered after the--- attribute is applied.------ At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and--- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more--- information.-data Attr = Attr - { attr_style :: !(MaybeDefault Style)- , attr_fore_color :: !(MaybeDefault Color)- , attr_back_color :: !(MaybeDefault Color)- } deriving ( Eq, Show )--instance Monoid Attr where- mempty = Attr mempty mempty mempty- mappend attr_0 attr_1 = - Attr ( attr_style attr_0 `mappend` attr_style attr_1 )- ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 )- ( attr_back_color attr_0 `mappend` attr_back_color attr_1 )---- | 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 default colors (unfortunately).+-- | 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+-- default colors (unfortunately). data FixedAttr = FixedAttr- { fixed_style :: !Style- , fixed_fore_color :: !(Maybe Color)- , fixed_back_color :: !(Maybe Color)+ { fixedStyle :: !Style+ , fixedForeColor :: !(Maybe Color)+ , fixedBackColor :: !(Maybe Color)+ , fixedURL :: !(Maybe Text) } deriving ( Eq, Show ) --- | 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 ) => !v -> MaybeDefault v--deriving instance Eq v => Eq (MaybeDefault v)-deriving instance Eq v => Show (MaybeDefault v)--instance Eq v => Monoid ( MaybeDefault v ) where- mempty = KeepCurrent- mappend Default Default = Default- mappend Default KeepCurrent = Default- mappend Default ( SetTo v ) = SetTo v- mappend KeepCurrent Default = Default- mappend KeepCurrent KeepCurrent = KeepCurrent- mappend KeepCurrent ( SetTo v ) = SetTo v- mappend ( SetTo _v ) Default = Default- mappend ( SetTo v ) KeepCurrent = SetTo v- mappend ( SetTo _ ) ( SetTo v ) = SetTo v---- | Standard 8-color ANSI terminal color codes.-black, red, green, yellow, blue, magenta, cyan, white :: Color-black = ISOColor 0-red = ISOColor 1-green = ISOColor 2-yellow = ISOColor 3-blue = ISOColor 4-magenta= ISOColor 5-cyan = ISOColor 6-white = ISOColor 7+-- | 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 = Default | KeepCurrent | SetTo !v+ deriving (Eq, Read, Show) --- | Bright/Vivid variants of the standard 8-color ANSI -bright_black, bright_red, bright_green, bright_yellow :: Color-bright_blue, bright_magenta, bright_cyan, bright_white :: Color-bright_black = ISOColor 8-bright_red = ISOColor 9-bright_green = ISOColor 10-bright_yellow = ISOColor 11-bright_blue = ISOColor 12-bright_magenta= ISOColor 13-bright_cyan = ISOColor 14-bright_white = ISOColor 15+instance (NFData v) => NFData (MaybeDefault v) where+ rnf Default = ()+ rnf KeepCurrent = ()+ rnf (SetTo v) = rnf v --- | 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.+-- | 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 6 possible style attributes:+-- | Valid style attributes include: -- -- * standout -- -- * underline ----- * reverse_video+-- * reverseVideo -- -- * blink --@@ -138,54 +154,75 @@ -- -- * bold/bright ----- ( The invisible, protect, and altcharset display attributes some terminals support are not--- supported via VTY.)-standout, underline, reverse_video, blink, dim, bold :: Style+-- * 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, strikethrough :: Style standout = 0x01 underline = 0x02-reverse_video = 0x04+reverseVideo = 0x04 blink = 0x08 dim = 0x10 bold = 0x20+italic = 0x40+strikethrough = 0x80 -default_style_mask :: Style-default_style_mask = 0x00+defaultStyleMask :: Style+defaultStyleMask = 0x00 -style_mask :: Attr -> Word8-style_mask attr - = case attr_style attr of+styleMask :: Attr -> Word8+styleMask attr+ = case attrStyle attr of Default -> 0 KeepCurrent -> 0 SetTo v -> v -- | true if the given Style value has the specified Style set.-has_style :: Style -> Style -> Bool-has_style s bit_mask = ( s .&. bit_mask ) /= 0+hasStyle :: Style -> Style -> Bool+hasStyle s bitMask = ( s .&. bitMask ) /= 0 -- | Set the foreground color of an `Attr'.-with_fore_color :: Attr -> Color -> Attr-with_fore_color attr c = attr { attr_fore_color = SetTo c }+withForeColor :: Attr -> Color -> Attr+withForeColor attr c = attr { attrForeColor = SetTo c } -- | Set the background color of an `Attr'.-with_back_color :: Attr -> Color -> Attr-with_back_color attr c = attr { attr_back_color = SetTo c }+withBackColor :: Attr -> Color -> Attr+withBackColor attr c = attr { attrBackColor = SetTo c } -- | Add the given style attribute-with_style :: Attr -> Style -> Attr-with_style attr style_flag = attr { attr_style = SetTo $ style_mask attr .|. style_flag }+withStyle :: Attr -> Style -> Attr+withStyle attr 0 = attr+withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } --- | Sets the style, background color and foreground color to the default values for the terminal.--- There is no easy way to determine what the default background and foreground colors are.-def_attr :: Attr-def_attr = Attr Default Default Default+-- | Add a hyperlinked URL using the proposed [escape sequences for+-- hyperlinked+-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).+-- These escape sequences are comparatively new and aren't widely+-- supported in terminal emulators yet, but most terminal emulators+-- that don't know about these sequences will ignore these sequences,+-- and therefore this should fall back sensibly. In some cases they+-- won't and this will result in garbage, so this is why hyperlinking is+-- disabled by default, in which case this combinator has no observable+-- effect. To enable it, enable 'Hyperlink' mode on your Vty output+-- interface.+withURL :: Attr -> Text -> Attr+withURL attr url = attr { attrURL = SetTo url } --- | Keeps the style, background color and foreground color that was previously set. Used to--- override some part of the previous style.+-- | Sets the style, background color and foreground color to the+-- default values for the terminal. There is no easy way to determine+-- what the default background and foreground colors are.+defAttr :: Attr+defAttr = Attr Default Default Default Default++-- | Keeps the style, background color and foreground color that was+-- previously set. Used to override some part of the previous style. ----- EG: current_style `with_fore_color` bright_magenta+-- EG: current_style `withForeColor` brightMagenta ----- Would be the currently applied style (be it underline, bold, etc) but with the foreground color--- set to bright_magenta.-current_attr :: Attr-current_attr = Attr KeepCurrent KeepCurrent KeepCurrent-+-- Would be the currently applied style (be it underline, bold, etc) but+-- with the foreground color set to brightMagenta.+currentAttr :: Attr+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs view
@@ -1,51 +1,173 @@-module Graphics.Vty.Attributes.Color where+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Graphics.Vty.Attributes.Color+ ( Color(..)+ , ColorMode(..)++ -- ** Fixed Colors+ -- | Standard 8-color ANSI terminal color codes.+ --+ -- Note that these map to colors in the terminal's custom palette. For+ -- instance, `white` maps to whatever the terminal color theme uses for+ -- white.+ --+ -- Use these functions if you want to make apps that fit the terminal theme.+ -- If you want access to more/stronger colors use `rgbColor`+ , black+ , red+ , green+ , yellow+ , blue+ , magenta+ , cyan+ , white++ -- | Bright/Vivid variants of the standard 8-color ANSI+ , brightBlack+ , brightRed+ , brightGreen+ , brightYellow+ , brightBlue+ , brightMagenta+ , brightCyan+ , brightWhite+ -- ** Creating Colors From RGB+ , linearColor+ , srgbColor+ , rgbColor+ , color240+ , module Graphics.Vty.Attributes.Color240+ )+where+ import Data.Word+import GHC.Generics+import Control.DeepSeq +import Graphics.Vty.Attributes.Color240+ -- | Abstract data type representing a color.--- --- Currently the foreground and background color are specified as points in either a: ----- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8--- color palette and the second 8 colors are bright/vivid versions of the first 8 colors.+-- Currently the foreground and background color are specified as points+-- in either a: ----- * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first--- 224 colors. The remaining 16 colors is a greyscale palette.--- +-- * 16 color palette. Where the first 8 colors are equal to the 8+-- colors of the ISO 6429 (ANSI) 8 color palette and the second 8+-- colors are bright/vivid versions of the first 8 colors.+--+-- * 240 color palette. This palette is a regular sampling of the full+-- RGB colorspace for the first 224 colors. The remaining 16 colors is+-- a greyscale palette.+-- -- 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 terminal claims to support. Which is usually determined by--- the terminfo "colors" property. If this property is not being accurately reported then the color--- reproduction will be incorrect.+-- The mapping from points in the 240 color palette to colors actually+-- displayable by the terminal depends on the number of colors the+-- terminal claims to support. Which is usually determined by the+-- terminfo "colors" property. If this property is not being accurately+-- 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 the RGB points for the "bright" colors which is why they are not--- addressable via the 240 color palette. +-- If the terminal reports <= 16 colors then the 240 color palette+-- 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. ----- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest--- points in a ("color count" - 16) subsampling of the 240 color palette.+-- If the terminal reports > 16 colors then the 240 color palette+-- points are mapped to the nearest points in a ("color count" - 16)+-- subsampling of the 240 color palette. ----- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors.--- And that the individual colors have not been remapped by the user. There may be a way to verify--- this through terminfo but I don't know it.+-- All of this assumes the terminals are behaving similarly to xterm and+-- rxvt when handling colors. And that the individual colors have not+-- been remapped by the user. There may be a way to verify this through+-- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE.-data Color = ISOColor !Word8 | Color240 !Word8- deriving ( Eq, Show )+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+green = ISOColor 2+yellow = ISOColor 3+blue = ISOColor 4+magenta= ISOColor 5+cyan = ISOColor 6+white = ISOColor 7++brightBlack, brightRed, brightGreen, brightYellow :: Color+brightBlue, brightMagenta, brightCyan, brightWhite :: Color+brightBlack = ISOColor 8+brightRed = ISOColor 9+brightGreen = ISOColor 10+brightYellow = ISOColor 11+brightBlue = ISOColor 12+brightMagenta= ISOColor 13+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 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 = color240
src/Graphics/Vty/Attributes/Color240.hs view
@@ -1,261 +1,301 @@-{-- - This header file was generated by ./256colres.pl- -}-module Graphics.Vty.Attributes.Color240 where--import Graphics.Vty.Attributes.Color+-- This header file was generated by ./256colres.pl+module Graphics.Vty.Attributes.Color240+ ( rgbColorToColor240+ , color240CodeToRGB+ )+where +import Data.Word (Word8) import Text.Printf --- | 8 bit RGB color to 240 color palette.+-- 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. This maps+-- the input arguments to an entry in the 240-color palette depicted at: ----- generated from 256colres.pl which is forked from xterm 256colres.pl--- todo: all values get clamped high.-rgb_color :: Integral i => i -> i -> i -> Color-rgb_color r g b- | r < 0 && g < 0 && b < 0 = error "rgb_color with negative color component intensity"- | r == 8 && g == 8 && b == 8 = Color240 216- | r == 18 && g == 18 && b == 18 = Color240 217- | r == 28 && g == 28 && b == 28 = Color240 218- | r == 38 && g == 38 && b == 38 = Color240 219- | r == 48 && g == 48 && b == 48 = Color240 220- | r == 58 && g == 58 && b == 58 = Color240 221- | r == 68 && g == 68 && b == 68 = Color240 222- | r == 78 && g == 78 && b == 78 = Color240 223- | r == 88 && g == 88 && b == 88 = Color240 224- | r == 98 && g == 98 && b == 98 = Color240 225- | r == 108 && g == 108 && b == 108 = Color240 226- | r == 118 && g == 118 && b == 118 = Color240 227- | r == 128 && g == 128 && b == 128 = Color240 228- | r == 138 && g == 138 && b == 138 = Color240 229- | r == 148 && g == 148 && b == 148 = Color240 230- | r == 158 && g == 158 && b == 158 = Color240 231- | r == 168 && g == 168 && b == 168 = Color240 232- | r == 178 && g == 178 && b == 178 = Color240 233- | r == 188 && g == 188 && b == 188 = Color240 234- | r == 198 && g == 198 && b == 198 = Color240 235- | r == 208 && g == 208 && b == 208 = Color240 236- | r == 218 && g == 218 && b == 218 = Color240 237- | r == 228 && g == 228 && b == 228 = Color240 238- | r == 238 && g == 238 && b == 238 = Color240 239- | r <= 0 && g <= 0 && b <= 0 = Color240 0- | r <= 0 && g <= 0 && b <= 95 = Color240 1- | r <= 0 && g <= 0 && b <= 135 = Color240 2- | r <= 0 && g <= 0 && b <= 175 = Color240 3- | r <= 0 && g <= 0 && b <= 215 = Color240 4- | r <= 0 && g <= 0 && b <= 255 = Color240 5- | r <= 0 && g <= 95 && b <= 0 = Color240 6- | r <= 0 && g <= 95 && b <= 95 = Color240 7- | r <= 0 && g <= 95 && b <= 135 = Color240 8- | r <= 0 && g <= 95 && b <= 175 = Color240 9- | r <= 0 && g <= 95 && b <= 215 = Color240 10- | r <= 0 && g <= 95 && b <= 255 = Color240 11- | r <= 0 && g <= 135 && b <= 0 = Color240 12- | r <= 0 && g <= 135 && b <= 95 = Color240 13- | r <= 0 && g <= 135 && b <= 135 = Color240 14- | r <= 0 && g <= 135 && b <= 175 = Color240 15- | r <= 0 && g <= 135 && b <= 215 = Color240 16- | r <= 0 && g <= 135 && b <= 255 = Color240 17- | r <= 0 && g <= 175 && b <= 0 = Color240 18- | r <= 0 && g <= 175 && b <= 95 = Color240 19- | r <= 0 && g <= 175 && b <= 135 = Color240 20- | r <= 0 && g <= 175 && b <= 175 = Color240 21- | r <= 0 && g <= 175 && b <= 215 = Color240 22- | r <= 0 && g <= 175 && b <= 255 = Color240 23- | r <= 0 && g <= 215 && b <= 0 = Color240 24- | r <= 0 && g <= 215 && b <= 95 = Color240 25- | r <= 0 && g <= 215 && b <= 135 = Color240 26- | r <= 0 && g <= 215 && b <= 175 = Color240 27- | r <= 0 && g <= 215 && b <= 215 = Color240 28- | r <= 0 && g <= 215 && b <= 255 = Color240 29- | r <= 0 && g <= 255 && b <= 0 = Color240 30- | r <= 0 && g <= 255 && b <= 95 = Color240 31- | r <= 0 && g <= 255 && b <= 135 = Color240 32- | r <= 0 && g <= 255 && b <= 175 = Color240 33- | r <= 0 && g <= 255 && b <= 215 = Color240 34- | r <= 0 && g <= 255 && b <= 255 = Color240 35- | r <= 95 && g <= 0 && b <= 0 = Color240 36- | r <= 95 && g <= 0 && b <= 95 = Color240 37- | r <= 95 && g <= 0 && b <= 135 = Color240 38- | r <= 95 && g <= 0 && b <= 175 = Color240 39- | r <= 95 && g <= 0 && b <= 215 = Color240 40- | r <= 95 && g <= 0 && b <= 255 = Color240 41- | r <= 95 && g <= 95 && b <= 0 = Color240 42- | r <= 95 && g <= 95 && b <= 95 = Color240 43- | r <= 95 && g <= 95 && b <= 135 = Color240 44- | r <= 95 && g <= 95 && b <= 175 = Color240 45- | r <= 95 && g <= 95 && b <= 215 = Color240 46- | r <= 95 && g <= 95 && b <= 255 = Color240 47- | r <= 95 && g <= 135 && b <= 0 = Color240 48- | r <= 95 && g <= 135 && b <= 95 = Color240 49- | r <= 95 && g <= 135 && b <= 135 = Color240 50- | r <= 95 && g <= 135 && b <= 175 = Color240 51- | r <= 95 && g <= 135 && b <= 215 = Color240 52- | r <= 95 && g <= 135 && b <= 255 = Color240 53- | r <= 95 && g <= 175 && b <= 0 = Color240 54- | r <= 95 && g <= 175 && b <= 95 = Color240 55- | r <= 95 && g <= 175 && b <= 135 = Color240 56- | r <= 95 && g <= 175 && b <= 175 = Color240 57- | r <= 95 && g <= 175 && b <= 215 = Color240 58- | r <= 95 && g <= 175 && b <= 255 = Color240 59- | r <= 95 && g <= 215 && b <= 0 = Color240 60- | r <= 95 && g <= 215 && b <= 95 = Color240 61- | r <= 95 && g <= 215 && b <= 135 = Color240 62- | r <= 95 && g <= 215 && b <= 175 = Color240 63- | r <= 95 && g <= 215 && b <= 215 = Color240 64- | r <= 95 && g <= 215 && b <= 255 = Color240 65- | r <= 95 && g <= 255 && b <= 0 = Color240 66- | r <= 95 && g <= 255 && b <= 95 = Color240 67- | r <= 95 && g <= 255 && b <= 135 = Color240 68- | r <= 95 && g <= 255 && b <= 175 = Color240 69- | r <= 95 && g <= 255 && b <= 215 = Color240 70- | r <= 95 && g <= 255 && b <= 255 = Color240 71- | r <= 135 && g <= 0 && b <= 0 = Color240 72- | r <= 135 && g <= 0 && b <= 95 = Color240 73- | r <= 135 && g <= 0 && b <= 135 = Color240 74- | r <= 135 && g <= 0 && b <= 175 = Color240 75- | r <= 135 && g <= 0 && b <= 215 = Color240 76- | r <= 135 && g <= 0 && b <= 255 = Color240 77- | r <= 135 && g <= 95 && b <= 0 = Color240 78- | r <= 135 && g <= 95 && b <= 95 = Color240 79- | r <= 135 && g <= 95 && b <= 135 = Color240 80- | r <= 135 && g <= 95 && b <= 175 = Color240 81- | r <= 135 && g <= 95 && b <= 215 = Color240 82- | r <= 135 && g <= 95 && b <= 255 = Color240 83- | r <= 135 && g <= 135 && b <= 0 = Color240 84- | r <= 135 && g <= 135 && b <= 95 = Color240 85- | r <= 135 && g <= 135 && b <= 135 = Color240 86- | r <= 135 && g <= 135 && b <= 175 = Color240 87- | r <= 135 && g <= 135 && b <= 215 = Color240 88- | r <= 135 && g <= 135 && b <= 255 = Color240 89- | r <= 135 && g <= 175 && b <= 0 = Color240 90- | r <= 135 && g <= 175 && b <= 95 = Color240 91- | r <= 135 && g <= 175 && b <= 135 = Color240 92- | r <= 135 && g <= 175 && b <= 175 = Color240 93- | r <= 135 && g <= 175 && b <= 215 = Color240 94- | r <= 135 && g <= 175 && b <= 255 = Color240 95- | r <= 135 && g <= 215 && b <= 0 = Color240 96- | r <= 135 && g <= 215 && b <= 95 = Color240 97- | r <= 135 && g <= 215 && b <= 135 = Color240 98- | r <= 135 && g <= 215 && b <= 175 = Color240 99- | r <= 135 && g <= 215 && b <= 215 = Color240 100- | r <= 135 && g <= 215 && b <= 255 = Color240 101- | r <= 135 && g <= 255 && b <= 0 = Color240 102- | r <= 135 && g <= 255 && b <= 95 = Color240 103- | r <= 135 && g <= 255 && b <= 135 = Color240 104- | r <= 135 && g <= 255 && b <= 175 = Color240 105- | r <= 135 && g <= 255 && b <= 215 = Color240 106- | r <= 135 && g <= 255 && b <= 255 = Color240 107- | r <= 175 && g <= 0 && b <= 0 = Color240 108- | r <= 175 && g <= 0 && b <= 95 = Color240 109- | r <= 175 && g <= 0 && b <= 135 = Color240 110- | r <= 175 && g <= 0 && b <= 175 = Color240 111- | r <= 175 && g <= 0 && b <= 215 = Color240 112- | r <= 175 && g <= 0 && b <= 255 = Color240 113- | r <= 175 && g <= 95 && b <= 0 = Color240 114- | r <= 175 && g <= 95 && b <= 95 = Color240 115- | r <= 175 && g <= 95 && b <= 135 = Color240 116- | r <= 175 && g <= 95 && b <= 175 = Color240 117- | r <= 175 && g <= 95 && b <= 215 = Color240 118- | r <= 175 && g <= 95 && b <= 255 = Color240 119- | r <= 175 && g <= 135 && b <= 0 = Color240 120- | r <= 175 && g <= 135 && b <= 95 = Color240 121- | r <= 175 && g <= 135 && b <= 135 = Color240 122- | r <= 175 && g <= 135 && b <= 175 = Color240 123- | r <= 175 && g <= 135 && b <= 215 = Color240 124- | r <= 175 && g <= 135 && b <= 255 = Color240 125- | r <= 175 && g <= 175 && b <= 0 = Color240 126- | r <= 175 && g <= 175 && b <= 95 = Color240 127- | r <= 175 && g <= 175 && b <= 135 = Color240 128- | r <= 175 && g <= 175 && b <= 175 = Color240 129- | r <= 175 && g <= 175 && b <= 215 = Color240 130- | r <= 175 && g <= 175 && b <= 255 = Color240 131- | r <= 175 && g <= 215 && b <= 0 = Color240 132- | r <= 175 && g <= 215 && b <= 95 = Color240 133- | r <= 175 && g <= 215 && b <= 135 = Color240 134- | r <= 175 && g <= 215 && b <= 175 = Color240 135- | r <= 175 && g <= 215 && b <= 215 = Color240 136- | r <= 175 && g <= 215 && b <= 255 = Color240 137- | r <= 175 && g <= 255 && b <= 0 = Color240 138- | r <= 175 && g <= 255 && b <= 95 = Color240 139- | r <= 175 && g <= 255 && b <= 135 = Color240 140- | r <= 175 && g <= 255 && b <= 175 = Color240 141- | r <= 175 && g <= 255 && b <= 215 = Color240 142- | r <= 175 && g <= 255 && b <= 255 = Color240 143- | r <= 215 && g <= 0 && b <= 0 = Color240 144- | r <= 215 && g <= 0 && b <= 95 = Color240 145- | r <= 215 && g <= 0 && b <= 135 = Color240 146- | r <= 215 && g <= 0 && b <= 175 = Color240 147- | r <= 215 && g <= 0 && b <= 215 = Color240 148- | r <= 215 && g <= 0 && b <= 255 = Color240 149- | r <= 215 && g <= 95 && b <= 0 = Color240 150- | r <= 215 && g <= 95 && b <= 95 = Color240 151- | r <= 215 && g <= 95 && b <= 135 = Color240 152- | r <= 215 && g <= 95 && b <= 175 = Color240 153- | r <= 215 && g <= 95 && b <= 215 = Color240 154- | r <= 215 && g <= 95 && b <= 255 = Color240 155- | r <= 215 && g <= 135 && b <= 0 = Color240 156- | r <= 215 && g <= 135 && b <= 95 = Color240 157- | r <= 215 && g <= 135 && b <= 135 = Color240 158- | r <= 215 && g <= 135 && b <= 175 = Color240 159- | r <= 215 && g <= 135 && b <= 215 = Color240 160- | r <= 215 && g <= 135 && b <= 255 = Color240 161- | r <= 215 && g <= 175 && b <= 0 = Color240 162- | r <= 215 && g <= 175 && b <= 95 = Color240 163- | r <= 215 && g <= 175 && b <= 135 = Color240 164- | r <= 215 && g <= 175 && b <= 175 = Color240 165- | r <= 215 && g <= 175 && b <= 215 = Color240 166- | r <= 215 && g <= 175 && b <= 255 = Color240 167- | r <= 215 && g <= 215 && b <= 0 = Color240 168- | r <= 215 && g <= 215 && b <= 95 = Color240 169- | r <= 215 && g <= 215 && b <= 135 = Color240 170- | r <= 215 && g <= 215 && b <= 175 = Color240 171- | r <= 215 && g <= 215 && b <= 215 = Color240 172- | r <= 215 && g <= 215 && b <= 255 = Color240 173- | r <= 215 && g <= 255 && b <= 0 = Color240 174- | r <= 215 && g <= 255 && b <= 95 = Color240 175- | r <= 215 && g <= 255 && b <= 135 = Color240 176- | r <= 215 && g <= 255 && b <= 175 = Color240 177- | r <= 215 && g <= 255 && b <= 215 = Color240 178- | r <= 215 && g <= 255 && b <= 255 = Color240 179- | r <= 255 && g <= 0 && b <= 0 = Color240 180- | r <= 255 && g <= 0 && b <= 95 = Color240 181- | r <= 255 && g <= 0 && b <= 135 = Color240 182- | r <= 255 && g <= 0 && b <= 175 = Color240 183- | r <= 255 && g <= 0 && b <= 215 = Color240 184- | r <= 255 && g <= 0 && b <= 255 = Color240 185- | r <= 255 && g <= 95 && b <= 0 = Color240 186- | r <= 255 && g <= 95 && b <= 95 = Color240 187- | r <= 255 && g <= 95 && b <= 135 = Color240 188- | r <= 255 && g <= 95 && b <= 175 = Color240 189- | r <= 255 && g <= 95 && b <= 215 = Color240 190- | r <= 255 && g <= 95 && b <= 255 = Color240 191- | r <= 255 && g <= 135 && b <= 0 = Color240 192- | r <= 255 && g <= 135 && b <= 95 = Color240 193- | r <= 255 && g <= 135 && b <= 135 = Color240 194- | r <= 255 && g <= 135 && b <= 175 = Color240 195- | r <= 255 && g <= 135 && b <= 215 = Color240 196- | r <= 255 && g <= 135 && b <= 255 = Color240 197- | r <= 255 && g <= 175 && b <= 0 = Color240 198- | r <= 255 && g <= 175 && b <= 95 = Color240 199- | r <= 255 && g <= 175 && b <= 135 = Color240 200- | r <= 255 && g <= 175 && b <= 175 = Color240 201- | r <= 255 && g <= 175 && b <= 215 = Color240 202- | r <= 255 && g <= 175 && b <= 255 = Color240 203- | r <= 255 && g <= 215 && b <= 0 = Color240 204- | r <= 255 && g <= 215 && b <= 95 = Color240 205- | r <= 255 && g <= 215 && b <= 135 = Color240 206- | r <= 255 && g <= 215 && b <= 175 = Color240 207- | r <= 255 && g <= 215 && b <= 215 = Color240 208- | r <= 255 && g <= 215 && b <= 255 = Color240 209- | r <= 255 && g <= 255 && b <= 0 = Color240 210- | r <= 255 && g <= 255 && b <= 95 = Color240 211- | r <= 255 && g <= 255 && b <= 135 = Color240 212- | r <= 255 && g <= 255 && b <= 175 = Color240 213- | r <= 255 && g <= 255 && b <= 215 = Color240 214- | r <= 255 && g <= 255 && b <= 255 = Color240 215- | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." +-- 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"+ | r == 8 && g == 8 && b == 8 = 216+ | r == 18 && g == 18 && b == 18 = 217+ | r == 28 && g == 28 && b == 28 = 218+ | r == 38 && g == 38 && b == 38 = 219+ | r == 48 && g == 48 && b == 48 = 220+ | r == 58 && g == 58 && b == 58 = 221+ | r == 68 && g == 68 && b == 68 = 222+ | r == 78 && g == 78 && b == 78 = 223+ | r == 88 && g == 88 && b == 88 = 224+ | r == 98 && g == 98 && b == 98 = 225+ | r == 108 && g == 108 && b == 108 = 226+ | r == 118 && g == 118 && b == 118 = 227+ | r == 128 && g == 128 && b == 128 = 228+ | r == 138 && g == 138 && b == 138 = 229+ | r == 148 && g == 148 && b == 148 = 230+ | r == 158 && g == 158 && b == 158 = 231+ | r == 168 && g == 168 && b == 168 = 232+ | r == 178 && g == 178 && b == 178 = 233+ | r == 188 && g == 188 && b == 188 = 234+ | r == 198 && g == 198 && b == 198 = 235+ | r == 208 && g == 208 && b == 208 = 236+ | r == 218 && g == 218 && b == 218 = 237+ | r == 228 && g == 228 && b == 228 = 238+ | r == 238 && g == 238 && b == 238 = 239+ | 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)+color240CodeToRGB n = case n of+ 0 -> Just (0, 0, 0)+ 1 -> Just (0, 0, 95)+ 2 -> Just (0, 0, 135)+ 3 -> Just (0, 0, 175)+ 4 -> Just (0, 0, 215)+ 5 -> Just (0, 0, 255)+ 6 -> Just (0, 95, 0)+ 7 -> Just (0, 95, 95)+ 8 -> Just (0, 95, 135)+ 9 -> Just (0, 95, 175)+ 10 -> Just (0, 95, 215)+ 11 -> Just (0, 95, 255)+ 12 -> Just (0, 135, 0)+ 13 -> Just (0, 135, 95)+ 14 -> Just (0, 135, 135)+ 15 -> Just (0, 135, 175)+ 16 -> Just (0, 135, 215)+ 17 -> Just (0, 135, 255)+ 18 -> Just (0, 175, 0)+ 19 -> Just (0, 175, 95)+ 20 -> Just (0, 175, 135)+ 21 -> Just (0, 175, 175)+ 22 -> Just (0, 175, 215)+ 23 -> Just (0, 175, 255)+ 24 -> Just (0, 215, 0)+ 25 -> Just (0, 215, 95)+ 26 -> Just (0, 215, 135)+ 27 -> Just (0, 215, 175)+ 28 -> Just (0, 215, 215)+ 29 -> Just (0, 215, 255)+ 30 -> Just (0, 255, 0)+ 31 -> Just (0, 255, 95)+ 32 -> Just (0, 255, 135)+ 33 -> Just (0, 255, 175)+ 34 -> Just (0, 255, 215)+ 35 -> Just (0, 255, 255)+ 36 -> Just (95, 0, 0)+ 37 -> Just (95, 0, 95)+ 38 -> Just (95, 0, 135)+ 39 -> Just (95, 0, 175)+ 40 -> Just (95, 0, 215)+ 41 -> Just (95, 0, 255)+ 42 -> Just (95, 95, 0)+ 43 -> Just (95, 95, 95)+ 44 -> Just (95, 95, 135)+ 45 -> Just (95, 95, 175)+ 46 -> Just (95, 95, 215)+ 47 -> Just (95, 95, 255)+ 48 -> Just (95, 135, 0)+ 49 -> Just (95, 135, 95)+ 50 -> Just (95, 135, 135)+ 51 -> Just (95, 135, 175)+ 52 -> Just (95, 135, 215)+ 53 -> Just (95, 135, 255)+ 54 -> Just (95, 175, 0)+ 55 -> Just (95, 175, 95)+ 56 -> Just (95, 175, 135)+ 57 -> Just (95, 175, 175)+ 58 -> Just (95, 175, 215)+ 59 -> Just (95, 175, 255)+ 60 -> Just (95, 215, 0)+ 61 -> Just (95, 215, 95)+ 62 -> Just (95, 215, 135)+ 63 -> Just (95, 215, 175)+ 64 -> Just (95, 215, 215)+ 65 -> Just (95, 215, 255)+ 66 -> Just (95, 255, 0)+ 67 -> Just (95, 255, 95)+ 68 -> Just (95, 255, 135)+ 69 -> Just (95, 255, 175)+ 70 -> Just (95, 255, 215)+ 71 -> Just (95, 255, 255)+ 72 -> Just (135, 0, 0)+ 73 -> Just (135, 0, 95)+ 74 -> Just (135, 0, 135)+ 75 -> Just (135, 0, 175)+ 76 -> Just (135, 0, 215)+ 77 -> Just (135, 0, 255)+ 78 -> Just (135, 95, 0)+ 79 -> Just (135, 95, 95)+ 80 -> Just (135, 95, 135)+ 81 -> Just (135, 95, 175)+ 82 -> Just (135, 95, 215)+ 83 -> Just (135, 95, 255)+ 84 -> Just (135, 135, 0)+ 85 -> Just (135, 135, 95)+ 86 -> Just (135, 135, 135)+ 87 -> Just (135, 135, 175)+ 88 -> Just (135, 135, 215)+ 89 -> Just (135, 135, 255)+ 90 -> Just (135, 175, 0)+ 91 -> Just (135, 175, 95)+ 92 -> Just (135, 175, 135)+ 93 -> Just (135, 175, 175)+ 94 -> Just (135, 175, 215)+ 95 -> Just (135, 175, 255)+ 96 -> Just (135, 215, 0)+ 97 -> Just (135, 215, 95)+ 98 -> Just (135, 215, 135)+ 99 -> Just (135, 215, 175)+ 100 -> Just (135, 215, 215)+ 101 -> Just (135, 215, 255)+ 102 -> Just (135, 255, 0)+ 103 -> Just (135, 255, 95)+ 104 -> Just (135, 255, 135)+ 105 -> Just (135, 255, 175)+ 106 -> Just (135, 255, 215)+ 107 -> Just (135, 255, 255)+ 108 -> Just (175, 0, 0)+ 109 -> Just (175, 0, 95)+ 110 -> Just (175, 0, 135)+ 111 -> Just (175, 0, 175)+ 112 -> Just (175, 0, 215)+ 113 -> Just (175, 0, 255)+ 114 -> Just (175, 95, 0)+ 115 -> Just (175, 95, 95)+ 116 -> Just (175, 95, 135)+ 117 -> Just (175, 95, 175)+ 118 -> Just (175, 95, 215)+ 119 -> Just (175, 95, 255)+ 120 -> Just (175, 135, 0)+ 121 -> Just (175, 135, 95)+ 122 -> Just (175, 135, 135)+ 123 -> Just (175, 135, 175)+ 124 -> Just (175, 135, 215)+ 125 -> Just (175, 135, 255)+ 126 -> Just (175, 175, 0)+ 127 -> Just (175, 175, 95)+ 128 -> Just (175, 175, 135)+ 129 -> Just (175, 175, 175)+ 130 -> Just (175, 175, 215)+ 131 -> Just (175, 175, 255)+ 132 -> Just (175, 215, 0)+ 133 -> Just (175, 215, 95)+ 134 -> Just (175, 215, 135)+ 135 -> Just (175, 215, 175)+ 136 -> Just (175, 215, 215)+ 137 -> Just (175, 215, 255)+ 138 -> Just (175, 255, 0)+ 139 -> Just (175, 255, 95)+ 140 -> Just (175, 255, 135)+ 141 -> Just (175, 255, 175)+ 142 -> Just (175, 255, 215)+ 143 -> Just (175, 255, 255)+ 144 -> Just (215, 0, 0)+ 145 -> Just (215, 0, 95)+ 146 -> Just (215, 0, 135)+ 147 -> Just (215, 0, 175)+ 148 -> Just (215, 0, 215)+ 149 -> Just (215, 0, 255)+ 150 -> Just (215, 95, 0)+ 151 -> Just (215, 95, 95)+ 152 -> Just (215, 95, 135)+ 153 -> Just (215, 95, 175)+ 154 -> Just (215, 95, 215)+ 155 -> Just (215, 95, 255)+ 156 -> Just (215, 135, 0)+ 157 -> Just (215, 135, 95)+ 158 -> Just (215, 135, 135)+ 159 -> Just (215, 135, 175)+ 160 -> Just (215, 135, 215)+ 161 -> Just (215, 135, 255)+ 162 -> Just (215, 175, 0)+ 163 -> Just (215, 175, 95)+ 164 -> Just (215, 175, 135)+ 165 -> Just (215, 175, 175)+ 166 -> Just (215, 175, 215)+ 167 -> Just (215, 175, 255)+ 168 -> Just (215, 215, 0)+ 169 -> Just (215, 215, 95)+ 170 -> Just (215, 215, 135)+ 171 -> Just (215, 215, 175)+ 172 -> Just (215, 215, 215)+ 173 -> Just (215, 215, 255)+ 174 -> Just (215, 255, 0)+ 175 -> Just (215, 255, 95)+ 176 -> Just (215, 255, 135)+ 177 -> Just (215, 255, 175)+ 178 -> Just (215, 255, 215)+ 179 -> Just (215, 255, 255)+ 180 -> Just (255, 0, 0)+ 181 -> Just (255, 0, 95)+ 182 -> Just (255, 0, 135)+ 183 -> Just (255, 0, 175)+ 184 -> Just (255, 0, 215)+ 185 -> Just (255, 0, 255)+ 186 -> Just (255, 95, 0)+ 187 -> Just (255, 95, 95)+ 188 -> Just (255, 95, 135)+ 189 -> Just (255, 95, 175)+ 190 -> Just (255, 95, 215)+ 191 -> Just (255, 95, 255)+ 192 -> Just (255, 135, 0)+ 193 -> Just (255, 135, 95)+ 194 -> Just (255, 135, 135)+ 195 -> Just (255, 135, 175)+ 196 -> Just (255, 135, 215)+ 197 -> Just (255, 135, 255)+ 198 -> Just (255, 175, 0)+ 199 -> Just (255, 175, 95)+ 200 -> Just (255, 175, 135)+ 201 -> Just (255, 175, 175)+ 202 -> Just (255, 175, 215)+ 203 -> Just (255, 175, 255)+ 204 -> Just (255, 215, 0)+ 205 -> Just (255, 215, 95)+ 206 -> Just (255, 215, 135)+ 207 -> Just (255, 215, 175)+ 208 -> Just (255, 215, 215)+ 209 -> Just (255, 215, 255)+ 210 -> Just (255, 255, 0)+ 211 -> Just (255, 255, 95)+ 212 -> Just (255, 255, 135)+ 213 -> Just (255, 255, 175)+ 214 -> Just (255, 255, 215)+ 215 -> Just (255, 255, 255)+ 216 -> Just (8, 8, 8)+ 217 -> Just (18, 18, 18)+ 218 -> Just (28, 28, 28)+ 219 -> Just (38, 38, 38)+ 220 -> Just (48, 48, 48)+ 221 -> Just (58, 58, 58)+ 222 -> Just (68, 68, 68)+ 223 -> Just (78, 78, 78)+ 224 -> Just (88, 88, 88)+ 225 -> Just (98, 98, 98)+ 226 -> Just (108, 108, 108)+ 227 -> Just (118, 118, 118)+ 228 -> Just (128, 128, 128)+ 229 -> Just (138, 138, 138)+ 230 -> Just (148, 148, 148)+ 231 -> Just (158, 158, 158)+ 232 -> Just (168, 168, 168)+ 233 -> Just (178, 178, 178)+ 234 -> Just (188, 188, 188)+ 235 -> Just (198, 198, 198)+ 236 -> Just (208, 208, 208)+ 237 -> Just (218, 218, 218)+ 238 -> Just (228, 228, 228)+ 239 -> Just (238, 238, 238)+ _ -> Nothing
+ src/Graphics/Vty/Config.hs view
@@ -0,0 +1,438 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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.+--+-- = 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:+--+-- @+-- \"debugLog\" string+-- @+--+-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent+-- to a debugLog entry at the end of the last config file.+--+-- = Input Processing+--+-- == @map@+--+-- Format:+--+-- @+-- \"map\" term string key modifier_list+-- where+-- key := KEsc | KChar Char | KBS ... (same as 'Key')+-- modifier_list := \"[\" modifier+ \"]\"+-- modifier := MShift | MCtrl | MMeta | MAlt+-- term := "_" | string+-- @+--+-- E.g., if the contents are+--+-- @+-- map _ \"\\ESC[B\" KUp []+-- map _ \"\\ESC[1;3B\" KDown [MAlt]+-- map \"xterm\" \"\\ESC[D\" KLeft []+-- @+--+-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all+-- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown+-- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will+-- result in the KLeft event when @TERM@ is @xterm@.+--+-- 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@.+--+-- = Unicode Character Width Maps+--+-- == @widthMap@+--+-- Format:+--+-- @+-- \"widthMap\" string string+-- @+--+-- E.g.,+--+-- @+-- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"+-- @+--+-- 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+ , VtyUserConfig(..)+ , userConfig+ , overrideEnvConfig+ , currentTerminalName+ , runParseConfig+ , parseConfigFile+ , defaultConfig++ , vtyConfigPath+ , widthTableFilename+ , vtyDataDirectory+ , terminalWidthTablePath+ , vtyConfigFileEnvName++ , ConfigUpdateResult(..)+ , addConfigWidthMap+ )+where++import Prelude++import Control.Applicative hiding (many)++import Control.Exception (catch, IOException)+import Control.Monad (liftM, guard, void)++import qualified Data.ByteString as BS+#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Text.Read (readMaybe)++import Graphics.Vty.Attributes.Color (ColorMode(..))+import Graphics.Vty.Input.Events++import GHC.Generics++import System.Directory ( getAppUserDataDirectory, doesFileExist+ , createDirectoryIfMissing+ )+import System.Environment (lookupEnv)+import System.FilePath ((</>), takeDirectory)++import Text.Parsec hiding ((<|>))+import Text.Parsec.Token ( GenLanguageDef(..) )+import qualified Text.Parsec.Token as P++-- | 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 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 :: VtyUserConfig+defaultConfig = mempty++instance Semigroup VtyUserConfig where+ c0 <> c1 =+ -- latter config takes priority for everything but inputMap+ 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 VtyUserConfig where+ mempty =+ VtyUserConfig { configDebugLog = mempty+ , configInputMap = mempty+ , configTermWidthMaps = []+ , configAllowCustomUnicodeWidthTables = Nothing+ , configPreferredColorMode = Nothing+ }+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif++vtyDataDirectory :: IO FilePath+vtyDataDirectory = getAppUserDataDirectory "vty"++vtyConfigPath :: IO FilePath+vtyConfigPath = do+ dir <- vtyDataDirectory+ return $ dir </> "config"++vtyConfigFileEnvName :: String+vtyConfigFileEnvName = "VTY_CONFIG_FILE"++-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.+-- If none is found, build a default configuration.+userConfig :: IO VtyUserConfig+userConfig = do+ configFile <- vtyConfigPath >>= parseConfigFile+ overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<+ lookupEnv vtyConfigFileEnvName+ let base = configFile <> overrideConfig+ mappend base <$> overrideEnvConfig++widthTableFilename :: String -> String+widthTableFilename term = "width_table_" <> term <> ".dat"++termVariable :: String+termVariable = "TERM"++currentTerminalName :: IO (Maybe String)+currentTerminalName = lookupEnv termVariable++terminalWidthTablePath :: IO (Maybe FilePath)+terminalWidthTablePath = do+ dataDir <- vtyDataDirectory+ result <- lookupEnv termVariable+ case result of+ Nothing -> return Nothing+ Just term -> do+ return $ Just $ dataDir </> widthTableFilename term++overrideEnvConfig :: IO VtyUserConfig+overrideEnvConfig = do+ d <- lookupEnv "VTY_DEBUG_LOG"+ return $ defaultConfig { configDebugLog = d }++-- | 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 -> VtyUserConfig+runParseConfig name cfgTxt =+ case runParser parseConfig () name cfgTxt of+ Right cfg -> cfg+ Left{} -> defaultConfig++------------------------------------------------------------------------++type Parser = Parsec BS.ByteString ()++configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m+configLanguage = LanguageDef+ { commentStart = "{-"+ , commentEnd = "-}"+ , commentLine = "--"+ , nestedComments = True+ , identStart = letter <|> char '_'+ , identLetter = alphaNum <|> oneOf "_'"+ , opStart = opLetter configLanguage+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , reservedOpNames = []+ , reservedNames = []+ , caseSensitive = True+ }++configLexer :: Monad m => P.GenTokenParser BS.ByteString () m+configLexer = P.makeTokenParser configLanguage++mapDecl :: Parser VtyUserConfig+mapDecl = do+ "map" <- P.identifier configLexer+ termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)+ <|> (Just <$> P.stringLiteral configLexer)+ bytes <- P.stringLiteral configLexer+ key <- parseValue+ modifiers <- parseValue+ return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] }++debugLogDecl :: Parser VtyUserConfig+debugLogDecl = do+ "debugLog" <- P.identifier configLexer+ path <- P.stringLiteral configLexer+ return defaultConfig { configDebugLog = Just path }++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 { configTermWidthMaps = [(tName, path)] }++ignoreLine :: Parser ()+ignoreLine = void $ manyTill anyChar newline++parseConfig :: Parser VtyUserConfig+parseConfig = liftM mconcat $ many $ do+ P.whiteSpace configLexer+ let directives = [try mapDecl, try debugLogDecl, try widthMapDecl, try colorModeDecl]+ choice directives <|> (ignoreLine >> return defaultConfig)++class Parse a where parseValue :: Parser a+instance Parse Char where parseValue = P.charLiteral configLexer+instance Parse Int where parseValue = fromInteger <$> P.natural configLexer+instance Parse Key where parseValue = genericParse+instance Parse Modifier where parseValue = genericParse+instance Parse a => Parse [a] where+ parseValue = P.brackets configLexer+ (parseValue `sepBy` P.symbol configLexer ",")++------------------------------------------------------------------------+-- Derived parser for ADTs via generics+------------------------------------------------------------------------++genericParse :: (Generic a, GParse (Rep a)) => Parser a+genericParse = to <$> gparse++class GParse f where gparse :: Parser (f a)+instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse+instance GParse U1 where gparse = return U1+instance Parse a => GParse (K1 i a) where gparse = K1 <$> parseValue++instance (GParse f, GParse g) => GParse (f :*: g) where+ gparse = (:*:) <$> gparse <*> gparse++instance GParseAlts f => GParse (M1 D i f) where+ gparse =+ do con <- P.identifier configLexer+ M1 <$> gparseAlts con++------------------------------------------------------------------------++class GParseAlts f where+ gparseAlts :: String -> Parser (f a)++instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where+ gparseAlts con =+ do guard (con == conName (M1 Nothing :: C1 i Maybe a))+ M1 <$> gparse++instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where+ gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con++instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"++-- | 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+-- specified path.+--+-- If the configuration path refers to a configuration that already+-- contains the directive for the specified map and terminal type, the+-- configuration file will not be modified. If the file does not contain+-- the directive, it will be appended to the file.+--+-- 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 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+ -- to modify or create.+ -> String+ -- ^ The @TERM@ value for the @widthMap@ directive.+ -> FilePath+ -- ^ The width table file path for the directive.+ -> IO ConfigUpdateResult+addConfigWidthMap configPath term tablePath = do+ configEx <- doesFileExist configPath+ if configEx+ then updateConfig+ else createConfig >> return ConfigurationCreated++ where+ directive = "widthMap " <> show term <> " " <> show tablePath <> "\n"++ createConfig = do+ let dir = takeDirectory configPath+ createDirectoryIfMissing True dir+ writeFile configPath directive++ updateConfig = do+ config <- parseConfigFile configPath+ if (term, tablePath) `elem` configTermWidthMaps config+ then return ConfigurationRedundant+ else case lookup term (configTermWidthMaps config) of+ Just other -> return $ ConfigurationConflict other+ Nothing -> do+ appendFile configPath directive+ return ConfigurationModified
src/Graphics/Vty/Debug.hs view
@@ -1,43 +1,44 @@ -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE ScopedTypeVariables #-}-module Graphics.Vty.Debug ( module Graphics.Vty.Debug- , module Graphics.Vty.Debug.Image- )+module Graphics.Vty.Debug+ ( MockWindow(..)+ , SpanConstructLog+ , regionForWindow+ , allSpansHaveWidth+ , spanOpsAffectedColumns+ , spanOpsAffectedRows+ , rowOpsAffectedColumns+ , isSetAttr+ ) where import Graphics.Vty.Attributes-import Graphics.Vty.Debug.Image+import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Span-import Graphics.Vty.DisplayRegion -import qualified Data.Vector as Vector -import Data.Word+import qualified Data.Vector as Vector -row_ops_effected_columns :: DisplayOps -> [Word]-row_ops_effected_columns spans - = Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans+rowOpsAffectedColumns :: DisplayOps -> [Int]+rowOpsAffectedColumns ops+ = Vector.toList $ Vector.map spanOpsAffectedColumns ops -all_spans_have_width :: DisplayOps -> Word -> Bool-all_spans_have_width spans expected- = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans+allSpansHaveWidth :: DisplayOps -> Int -> Bool+allSpansHaveWidth ops expected+ = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops -span_ops_effected_rows :: DisplayOps -> Word-span_ops_effected_rows (DisplayOps _ the_row_ops) - = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList the_row_ops))- +spanOpsAffectedRows :: DisplayOps -> Int+spanOpsAffectedRows ops+ = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))+ type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr -is_set_attr :: Attr -> SpanConstructEvent -> Bool-is_set_attr expected_attr (SpanSetAttr in_attr)- | in_attr == expected_attr = True-is_set_attr _attr _event = False+isSetAttr :: Attr -> SpanConstructEvent -> Bool+isSetAttr expectedAttr (SpanSetAttr inAttr)+ | inAttr == expectedAttr = True+isSetAttr _attr _event = False -data DebugWindow = DebugWindow Word Word+data MockWindow = MockWindow Int Int deriving (Show, Eq) -region_for_window :: DebugWindow -> DisplayRegion-region_for_window (DebugWindow w h) = DisplayRegion w h--type TestWindow = DebugWindow-+regionForWindow :: MockWindow -> DisplayRegion+regionForWindow (MockWindow w h) = (w,h)
− src/Graphics/Vty/Debug/Image.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Graphics.Vty.Debug.Image where--import Graphics.Vty.Image--type ImageConstructLog = [ImageConstructEvent]-data ImageConstructEvent = ImageConstructEvent- deriving ( Show, Eq )--forward_image_ops :: [Image -> Image]-forward_image_ops = map forward_transform debug_image_ops--forward_transform, reverse_transform :: ImageOp -> (Image -> Image)--forward_transform (ImageOp f _) = f-reverse_transform (ImageOp _ r) = r--data ImageOp = ImageOp ImageEndo ImageEndo-type ImageEndo = Image -> Image--debug_image_ops :: [ImageOp]-debug_image_ops = - [ id_image_op- -- , render_single_column_char_op- -- , render_double_column_char_op- ]--id_image_op :: ImageOp-id_image_op = ImageOp id id---- render_char_op :: ImageOp--- render_char_op = ImageOp id id
src/Graphics/Vty/DisplayAttributes.hs view
@@ -1,78 +1,111 @@ -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+ module Graphics.Vty.DisplayAttributes- where+ ( DisplayAttrDiff(..)+ , StyleStateChange(..)+ , DisplayColorDiff(..)+ , URLDiff(..)+ , fixDisplayAttr+ , displayAttrDiffs+ )+where import Graphics.Vty.Attributes -import Data.Bits ( (.&.) )-import Data.Monoid ( Monoid(..), mconcat )+import Data.Bits ((.&.))+import Data.ByteString (ByteString)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8) --- | Given the previously applied display attributes as a FixedAttr and the current display--- attributes as an Attr produces a FixedAttr that represents the current display attributes. This--- is done by using the previously applied display attributes to remove the "KeepCurrent"+-- | Given the previously applied display attributes as a FixedAttr and+-- the current display attributes as an Attr produces a FixedAttr that+-- represents the current display attributes. This is done by using the+-- previously applied display attributes to remove the "KeepCurrent" -- abstraction.-fix_display_attr :: FixedAttr -> Attr -> FixedAttr-fix_display_attr fattr attr - = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) )- ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) )- ( fix_color (fixed_back_color fattr) (attr_back_color attr) )+fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr+fixDisplayAttr fattr attr+ = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))+ (fixColor (fixedForeColor fattr) (attrForeColor attr))+ (fixColor (fixedBackColor fattr) (attrBackColor attr))+ (fixURL (fixedURL fattr) (attrURL attr)) where- fix_style _s Default = default_style_mask- fix_style s KeepCurrent = s- fix_style _s (SetTo new_style) = new_style- fix_color _c Default = Nothing- fix_color c KeepCurrent = c- fix_color _c (SetTo c) = Just c+ fixStyle _s Default = defaultStyleMask+ fixStyle s KeepCurrent = s+ fixStyle _s (SetTo newStyle) = newStyle+ fixColor _c Default = Nothing+ fixColor c KeepCurrent = c+ fixColor _c (SetTo c) = Just c+ fixURL c KeepCurrent = c+ fixURL _c (SetTo n) = Just n+ fixURL _c Default = Nothing --- | difference between two display attributes. Used in the calculation of the operations required--- to go from one display attribute to the next.+-- | difference between two display attributes. Used in the calculation+-- of the operations required to go from one display attribute to the+-- next. ----- Previously, vty would reset display attributes to default then apply the new display attributes.--- This turned out to be very expensive: A *lot* more data would be sent to the terminal than--- required.+-- Previously, vty would reset display attributes to default then apply+-- the new display attributes. This turned out to be very expensive: A+-- *lot* more data would be sent to the terminal than required. data DisplayAttrDiff = DisplayAttrDiff- { style_diffs :: [ StyleStateChange ]- , fore_color_diff :: DisplayColorDiff- , back_color_diff :: DisplayColorDiff+ { styleDiffs :: [StyleStateChange]+ , foreColorDiff :: DisplayColorDiff+ , backColorDiff :: DisplayColorDiff+ , urlDiff :: URLDiff }- deriving ( Show )+ deriving (Show) +instance Semigroup DisplayAttrDiff where+ d0 <> d1 =+ let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1)+ fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)+ bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)+ ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)+ in DisplayAttrDiff ds fcd bcd ud+ instance Monoid DisplayAttrDiff where- mempty = DisplayAttrDiff [] NoColorChange NoColorChange- mappend d_0 d_1 = - let ds = simplify_style_diffs ( style_diffs d_0 ) ( style_diffs d_1 )- fcd = simplify_color_diffs ( fore_color_diff d_0 ) ( fore_color_diff d_1 )- bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 )- in DisplayAttrDiff ds fcd bcd+ mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif -- | Used in the computation of a final style attribute change.------ TODO(corey): not really a simplify but a monoid instance.-simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ]-simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1+simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]+simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1 --- | Consider two display color attributes diffs. What display color attribute diff are these--- equivalent to?------ TODO(corey): not really a simplify but a monoid instance.-simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff-simplify_color_diffs _cd ColorToDefault = ColorToDefault-simplify_color_diffs cd NoColorChange = cd-simplify_color_diffs _cd ( SetColor !c ) = SetColor c+-- | Consider two display color attributes diffs. What display color+-- attribute diff are these equivalent to?+simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff+simplifyColorDiffs _cd ColorToDefault = ColorToDefault+simplifyColorDiffs cd NoColorChange = cd+simplifyColorDiffs _cd (SetColor !c) = SetColor c +-- | Consider two URL changes, which are mostly going to be the latter+-- unless the latter specifies no change.+simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff+simplifyUrlDiffs ud NoLinkChange = ud+simplifyUrlDiffs _ ud = ud+ -- | Difference between two display color attribute changes.-data DisplayColorDiff +data DisplayColorDiff = ColorToDefault | NoColorChange | SetColor !Color- deriving ( Show, Eq )+ deriving (Show, Eq) --- | Style attribute changes are transformed into a sequence of apply/removes of the individual--- attributes.-data StyleStateChange +-- | Style attribute changes are transformed into a sequence of+-- apply/removes of the individual attributes.+data StyleStateChange = ApplyStandout | RemoveStandout+ | ApplyItalic+ | RemoveItalic+ | ApplyStrikethrough+ | RemoveStrikethrough | ApplyUnderline | RemoveUnderline | ApplyReverseVideo@@ -83,44 +116,58 @@ | RemoveDim | ApplyBold | RemoveBold- deriving ( Show, Eq )+ deriving (Show, Eq) --- | Determines the diff between two display&color attributes. This diff determines the operations--- that actually get output to the terminal.-display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff-display_attr_diffs attr attr' = DisplayAttrDiff- { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )- , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )- , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )+-- Setting and unsetting hyperlinks+data URLDiff+ = LinkTo !ByteString+ | NoLinkChange+ | EndLink+ deriving (Show, Eq)++-- | Determines the diff between two display&color attributes. This diff+-- determines the operations that actually get output to the terminal.+displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff+displayAttrDiffs attr attr' = DisplayAttrDiff+ { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')+ , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')+ , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')+ , urlDiff = diffURL (fixedURL attr) (fixedURL attr') } -diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff-diff_color Nothing (Just c') = SetColor c'-diff_color (Just c) (Just c') +diffURL :: Maybe Text -> Maybe Text -> URLDiff+diffURL Nothing Nothing = NoLinkChange+diffURL (Just _) Nothing = EndLink+diffURL _ (Just url) = LinkTo (encodeUtf8 url)++diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff+diffColor Nothing (Just c') = SetColor c'+diffColor (Just c) (Just c') | c == c' = NoColorChange | otherwise = SetColor c'-diff_color Nothing Nothing = NoColorChange-diff_color (Just _) Nothing = ColorToDefault+diffColor Nothing Nothing = NoColorChange+diffColor (Just _) Nothing = ColorToDefault -diff_styles :: Style -> Style -> [StyleStateChange]-diff_styles prev cur - = mconcat - [ style_diff standout ApplyStandout RemoveStandout- , style_diff underline ApplyUnderline RemoveUnderline- , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo- , style_diff blink ApplyBlink RemoveBlink- , style_diff dim ApplyDim RemoveDim- , style_diff bold ApplyBold RemoveBold+diffStyles :: Style -> Style -> [StyleStateChange]+diffStyles prev cur+ = mconcat+ [ 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+ , styleDiff bold ApplyBold RemoveBold ]- where - style_diff s sm rm - = case ( 0 == prev .&. s, 0 == cur .&. s ) of+ where+ styleDiff s sm rm+ = case (0 == prev .&. s, 0 == cur .&. s) of -- not set in either- ( True, True ) -> []+ (True, True) -> [] -- set in both- ( False, False ) -> []+ (False, False) -> [] -- now set- ( True, False) -> [ sm ]+ (True, False) -> [sm] -- now unset- ( False, True) -> [ rm ]-+ (False, True) -> [rm]
− src/Graphics/Vty/DisplayRegion.hs
@@ -1,12 +0,0 @@--- Copyright 2009 Corey O'Connor-module Graphics.Vty.DisplayRegion- where--import Data.Word---- | Region of the terminal that vty will output to. Units are columns not characters.-data DisplayRegion = DisplayRegion - { region_width :: !Word - , region_height :: !Word- } deriving ( Show, Eq )-
+ src/Graphics/Vty/Error.hs view
@@ -0,0 +1,11 @@+module Graphics.Vty.Error+ ( VtyException(..)+ )+where++-- | The type of exceptions specific to vty.+--+-- These have fully qualified names by default since, IMO, exception+-- handling requires this.+data VtyException+ = VtyFailure String -- ^ Uncategorized failure specific to vty.
src/Graphics/Vty/Image.hs view
@@ -1,378 +1,376 @@ -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-module Graphics.Vty.Image ( DisplayString- , Image(..)- , image_width- , image_height- , (<|>)- , (<->)- , horiz_cat- , vert_cat- , background_fill- , char- , string- , iso_10646_string- , utf8_string- , utf8_bytestring- , char_fill- , empty_image- , translate- , safe_wcwidth- , safe_wcswidth- , wcwidth- , wcswidth- , crop- , pad- -- | The possible display attributes used in constructing an `Image`.- , module Graphics.Vty.Attributes- )- where+-- | A Vty program makes 'Picture's from 'Image's. This module provides+-- the core constructors for creating, combining, and modifying+-- 'Image's.+module Graphics.Vty.Image+ (+ -- * Images+ Image+ , imageWidth+ , imageHeight+ -- * Image constructors+ , emptyImage+ , char+ , string+ , iso10646String+ , utf8String+ , text+ , text'+ , backgroundFill+ , utf8Bytestring+ , utf8Bytestring'+ , charFill+ -- * Combinators+ , horizJoin+ , (<|>)+ , vertJoin+ , (<->)+ , horizCat+ , vertCat+ -- * Image modifications+ , crop+ , cropRight+ , cropLeft+ , cropBottom+ , cropTop+ , pad+ , resize+ , resizeWidth+ , resizeHeight+ , translate+ , translateX+ , translateY+ -- * Character width functions+ , safeWcwidth+ , safeWcswidth+ , safeWctwidth+ , safeWctlwidth+ , wcwidth+ , wcswidth+ , wctwidth+ , wctlwidth+ -- * Display Regions+ , DisplayRegion+ , regionWidth+ , regionHeight+ )+where import Graphics.Vty.Attributes--import Codec.Binary.UTF8.Width--import Codec.Binary.UTF8.String ( decode )+import Graphics.Vty.Image.Internal+import Graphics.Text.Width -import qualified Data.ByteString as BS-import Data.Monoid-import qualified Data.Sequence as Seq-import qualified Data.String.UTF8 as UTF8+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL import Data.Word -infixr 5 <|>-infixr 4 <->---- | We pair each character with it's display length. This way we only compute the length once per--- character.--- * Though currently the width of some strings is still compute multiple times. -type DisplayString = Seq.Seq (Char, Word)---- | An image in VTY defines:------ * properties required to display the image. These are properties that effect the output image--- but are independent of position ------ * A set of position-dependent text and attribute regions. The possible regions are:------ * a point. ( char )------ * a horizontal line of characters with a single attribute. (string, utf8_string,--- utf8_bytestring )------ * a fill of a single character. (char_fill)------ * a fill of the picture's background. (background_fill)------ todo: increase the number of encoded bytestring formats supported.-data Image = - -- A horizontal text span is always >= 1 column and has a row height of 1.- HorizText- { attr :: !Attr- -- All character data is stored as Char sequences with the ISO-10646 encoding.- , text :: DisplayString- , output_width :: !Word -- >= 0- , char_width :: !Word -- >= 1- }- -- A horizontal join can be constructed between any two images. However a HorizJoin instance is- -- required to be between two images of equal height. The horiz_join constructor adds background- -- filles to the provided images that assure this is true for the HorizJoin value produced.- | HorizJoin- { part_left :: Image - , part_right :: Image- , output_width :: !Word -- >= 1- , output_height :: !Word -- >= 1- }- -- A veritical join can be constructed between any two images. However a VertJoin instance is- -- required to be between two images of equal width. The vert_join constructor adds background- -- fills to the provides images that assure this is true for the VertJoin value produced.- | VertJoin- { part_top :: Image- , part_bottom :: Image- , output_width :: !Word -- >= 1- , output_height :: !Word -- >= 1- }- -- A background fill will be filled with the background pattern. The background pattern is- -- defined as a property of the Picture this Image is used to form. - | BGFill- { output_width :: !Word -- >= 1- , output_height :: !Word -- >= 1- }- -- The combining operators identity constant. - -- EmptyImage <|> a = a- -- EmptyImage <-> a = a- -- - -- Any image of zero size equals the empty image.- | EmptyImage- | Translation (Int, Int) Image- -- Crop an image to a size- | ImageCrop (Word, Word) Image- -- Pad an image up to a size- | ImagePad (Word, Word) Image- deriving Eq--instance Show Image where- show ( HorizText { output_width = ow, text = txt } ) - = "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")"- show ( BGFill { output_width = c, output_height = r } ) - = "BGFill (" ++ show c ++ "," ++ show r ++ ")"- show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) - = "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )"- show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) - = "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )"- show ( Translation offset i )- = "Translation " ++ show offset ++ " ( " ++ show i ++ " )"- show ( ImageCrop size i )- = "ImageCrop " ++ show size ++ " ( " ++ show i ++ " )"- show ( ImagePad size i )- = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )"- show ( EmptyImage ) = "EmptyImage"+-- | A region of the display (first width, then height)+type DisplayRegion = (Int,Int) --- | Currently append in the Monoid instance is equivalent to <->. -instance Monoid Image where- mempty = empty_image- mappend = (<->)- --- A horizontal text image of 0 characters in width simplifies to the EmptyImage-horiz_text :: Attr -> DisplayString -> Word -> Image-horiz_text a txt ow- | ow == 0 = EmptyImage- | otherwise = HorizText a txt ow (toEnum $ Seq.length txt)+regionWidth :: DisplayRegion -> Int+regionWidth = fst -horiz_join :: Image -> Image -> Word -> Word -> Image-horiz_join i_0 i_1 w h- -- A horiz join of two 0 width images simplifies to the EmptyImage- | w == 0 = EmptyImage- -- A horizontal join where either part is 0 columns in width simplifies to the other part.- -- This covers the case where one part is the EmptyImage.- | image_width i_0 == 0 = i_1- | image_width i_1 == 0 = i_0- -- If the images are of the same height then no BG padding is required- | image_height i_0 == image_height i_1 = HorizJoin i_0 i_1 w h- -- otherwise one of the imagess needs to be padded to the right size.- | image_height i_0 < image_height i_1 -- Pad i_0- = let pad_amount = image_height i_1 - image_height i_0- in horiz_join ( vert_join i_0 - ( BGFill ( image_width i_0 ) pad_amount ) - ( image_width i_0 )- ( image_height i_1 )- ) - i_1 - w h- | image_height i_0 > image_height i_1 -- Pad i_1- = let pad_amount = image_height i_0 - image_height i_1- in horiz_join i_0 - ( vert_join i_1 - ( BGFill ( image_width i_1 ) pad_amount ) - ( image_width i_1 )- ( image_height i_0 )- )- w h-horiz_join _ _ _ _ = error "horiz_join applied to undefined values."+regionHeight :: DisplayRegion -> Int+regionHeight = snd -vert_join :: Image -> Image -> Word -> Word -> Image-vert_join i_0 i_1 w h- -- A vertical join of two 0 height images simplifies to the EmptyImage- | h == 0 = EmptyImage- -- A vertical join where either part is 0 rows in height simplifies to the other part.- -- This covers the case where one part is the EmptyImage- | image_height i_0 == 0 = i_1- | image_height i_1 == 0 = i_0- -- If the images are of the same height then no background padding is required- | image_width i_0 == image_width i_1 = VertJoin i_0 i_1 w h- -- Otherwise one of the images needs to be padded to the size of the other image.- | image_width i_0 < image_width i_1- = let pad_amount = image_width i_1 - image_width i_0- in vert_join ( horiz_join i_0- ( BGFill pad_amount ( image_height i_0 ) )- ( image_width i_1 )- ( image_height i_0 )- )- i_1- w h- | image_width i_0 > image_width i_1- = let pad_amount = image_width i_0 - image_width i_1- in vert_join i_0- ( horiz_join i_1- ( BGFill pad_amount ( image_height i_1 ) )- ( image_width i_0 )- ( image_height i_1 )- )- w h-vert_join _ _ _ _ = error "vert_join applied to undefined values."+infixr 5 <|>+infixr 4 <-> --- | An area of the picture's bacground (See Background) of w columns and h rows.-background_fill :: Word -> Word -> Image-background_fill w h +-- | An area of the picture's background (See 'Background').+backgroundFill :: Int+ -- ^ Fill width in columns+ -> Int+ -- ^ Fill height in rows+ -> Image+backgroundFill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h --- | The width of an Image. This is the number display columns the image will occupy.-image_width :: Image -> Word-image_width HorizText { output_width = w } = w-image_width HorizJoin { output_width = w } = w-image_width VertJoin { output_width = w } = w-image_width BGFill { output_width = w } = w-image_width EmptyImage = 0-image_width ( Translation v i ) = toEnum $ max 0 $ (fst v +) $ fromEnum $ image_width i-image_width ( ImageCrop v i ) = min (image_width i) $ fst v-image_width ( ImagePad v i ) = max (image_width i) $ fst v---- | The height of an Image. This is the number of display rows the image will occupy.-image_height :: Image -> Word-image_height HorizText {} = 1-image_height HorizJoin { output_height = r } = r-image_height VertJoin { output_height = r } = r-image_height BGFill { output_height = r } = r-image_height EmptyImage = 0-image_height ( Translation v i ) = toEnum $ max 0 $ (snd v +) $ fromEnum $ image_height i-image_height ( ImageCrop v i ) = min (image_height i) $ snd v-image_height ( ImagePad v i ) = max (image_height i) $ snd v---- | Combines two images side by side.+-- | Combines two images horizontally. This is an alias for 'horizJoin'. ----- 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 will be filled with the background pattern.+-- infixr 5 (<|>) :: Image -> Image -> Image---- Two horizontal text spans with the same attributes can be merged.-h0@(HorizText attr_0 text_0 ow_0 _) <|> h1@(HorizText attr_1 text_1 ow_1 _) - | attr_0 == attr_1 = horiz_text attr_0 (text_0 Seq.>< text_1) (ow_0 + ow_1)- | otherwise = horiz_join h0 h1 (ow_0 + ow_1) 1---- Anything placed to the right of a join wil be joined to the right sub image.--- The total columns for the join is the sum of the two arguments columns-h0@( HorizJoin {} ) <|> h1 - = horiz_join ( part_left h0 ) - ( part_right h0 <|> h1 )- ( image_width h0 + image_width h1 )- ( max (image_height h0) (image_height h1) )+(<|>) = horizJoin --- Anything but a join placed to the left of a join wil be joined to the left sub image.--- The total columns for the join is the sum of the two arguments columns-h0 <|> h1@( HorizJoin {} ) - = horiz_join ( h0 <|> part_left h1 ) - ( part_right h1 )- ( image_width h0 + image_width h1 )- ( max (image_height h0) (image_height h1) )+-- | Combines two images vertically. This is an alias for 'vertJoin'.+--+-- infixr 4+(<->) :: Image -> Image -> Image+(<->) = vertJoin -h0 <|> h1 - = horiz_join h0 - h1 - ( image_width h0 + image_width h1 )- ( max (image_height h0) (image_height h1) )+-- | Compose any number of images together horizontally, with the first+-- in the list being leftmost.+horizCat :: [Image] -> Image+horizCat = foldr horizJoin EmptyImage --- | Combines two images vertically.--- 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 will be filled with the background--- pattern.-(<->) :: Image -> Image -> Image-im_t <-> im_b - = vert_join im_t - im_b - ( max (image_width im_t) (image_width im_b) ) - ( image_height im_t + image_height im_b )+-- | Compose any number of images vertically, with the first in the list+-- being topmost.+vertCat :: [Image] -> Image+vertCat = foldr vertJoin EmptyImage --- | Compose any number of images horizontally.-horiz_cat :: [Image] -> Image-horiz_cat = foldr (<|>) EmptyImage+-- | 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) --- | Compose any number of images vertically.-vert_cat :: [Image] -> Image-vert_cat = foldr (<->) EmptyImage+-- | 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) --- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in--- the ISO-10646 encoding.+-- | Make an image from a single character. This is a standard Haskell+-- 31-bit character assumed to be in the ISO-10646 encoding. char :: Attr -> Char -> Image-char !a !c = - let display_width = safe_wcwidth c- in HorizText a (Seq.singleton (c, display_width)) display_width 1+char a c =+ let displayWidth = safeWcwidth c+ in HorizText a (TL.singleton c) displayWidth 1 --- | A string of characters layed out on a single row with the same display attribute. The string is--- assumed to be a sequence of ISO-10646 characters. +-- | 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. 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 example, may be represented as a ISO-10646 string. --- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry--- about the encoding format when outputting string literals. Just provide the string literal--- directly to iso_10646_string or string.--- -iso_10646_string :: Attr -> String -> Image-iso_10646_string !a !str = - let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str- in horiz_text a display_text (safe_wcswidth str)+-- Note: depending on how the Haskell compiler represents string+-- literals, a string literal in a UTF-8 encoded source file, for+-- example, may be represented as a ISO-10646 string. That is, I think,+-- the case with GHC 6.10. This means, for the most part, you don't need+-- to worry about the encoding format when outputting string literals.+-- Just provide the string literal directly to iso10646String or string.+iso10646String :: Attr -> String -> Image+iso10646String a str =+ let displayWidth = safeWcswidth str+ in HorizText a (TL.pack str) displayWidth (length str) --- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is--- represented internally as a list of ISO 10646 31 bit characters. +-- | Make an 'Image' from a 'String'. ----- 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 transcoded to a ISO 10646 31 bit characters runtime--- representation.+-- 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.+--+-- 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+-- transcoded to a ISO 10646 31 bit characters runtime representation. string :: Attr -> String -> Image-string = iso_10646_string+string = iso10646String --- | A string of characters layed out on a single row. The string is assumed to be a sequence of--- UTF-8 characters.-utf8_string :: Attr -> [Word8] -> Image-utf8_string !a !str = string a ( decode str )+-- | Make an 'Image' from a string of characters layed out on a single+-- row. The input is assumed to be the bytes for UTF-8 encoded text.+utf8String :: Attr -> [Word8] -> Image+utf8String a bytes = utf8Bytestring a (BL.pack bytes) --- XXX: Characters with unknown widths occupy 1 column?--- --- Not sure if this is actually correct. I presume there is a replacement character that is output--- by the terminal instead of the character and this replacement character is 1 column wide. If this--- is not true for all terminals then a per-terminal replacement character width needs to be--- implemented.+-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.+utf8Bytestring :: Attr -> BL.ByteString -> Image+utf8Bytestring a bs = text a (TL.decodeUtf8 bs) --- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width-safe_wcwidth :: Char -> Word-safe_wcwidth c = case wcwidth c of- i | i < 0 -> 1 - | otherwise -> toEnum i+-- | Make an 'Image' from a UTF-8 encoded strict bytestring.+utf8Bytestring' :: Attr -> B.ByteString -> Image+utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) --- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width-safe_wcswidth :: String -> Word-safe_wcswidth str = case wcswidth str of- i | i < 0 -> 1 - | otherwise -> toEnum i+-- | Make an image filling a region with the specified character.+--+-- If either the width or height are less than or equal to 0, then+-- the result is the empty image.+charFill :: Integral d+ => Attr+ -- ^ The attribute to use.+ -> Char+ -- ^ The character to use in filling the region.+ -> d+ -- ^ The region width.+ -> d+ -- ^ The region height.+ -> Image+charFill a c w h+ | w <= 0 || h <= 0 = EmptyImage+ | otherwise = vertCat+ $ replicate (fromIntegral h)+ $ HorizText a txt displayWidth charWidth+ where+ txt = TL.replicate charWidth (TL.singleton c)+ displayWidth = safeWcwidth c * charWidth --- | Renders a UTF-8 encoded bytestring. -utf8_bytestring :: Attr -> BS.ByteString -> Image-utf8_bytestring !a !bs = string a (UTF8.toString $ UTF8.fromRep bs)+ charWidth :: Num a => a+ charWidth = fromIntegral w --- | creates a fill of the specified character. The dimensions are in number of characters wide and--- number of rows high.+-- | The empty image. Useful for fold combinators. These occupy no space+-- and do not affect display attributes.+emptyImage :: Image+emptyImage = EmptyImage++-- | Pad the given image. This adds background character fills to the+-- left, top, right, bottom.+pad :: Int+ -- ^ How much padding to add to the left side of the image.+ -> Int+ -- ^ How much padding to add to the top of the image.+ -> Int+ -- ^ How much padding to add to the right side of the image.+ -> Int+ -- ^ How much padding to add to the bottom of the image.+ -> Image+ -- ^ The image to pad.+ -> Image+pad 0 0 0 0 i = i+pad inL inT inR inB inImage+ | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"+ | otherwise = go inL inT inR inB inImage+ where+ go 0 0 0 0 i = i+ go 0 0 0 b i = VertJoin i (BGFill w b) w h+ where w = imageWidth i+ h = imageHeight i + b+ go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h+ where w = imageWidth i + r+ h = imageHeight i+ go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h+ where w = imageWidth i+ h = imageHeight i + t+ go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h+ where w = imageWidth i + l+ h = imageHeight i++-- | Translates an image by padding or cropping the left and top. ----- Unlike the Background fill character this character can have double column display width.-char_fill :: Enum d => Attr -> Char -> d -> d -> Image-char_fill !a !c w h = - vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) $ char a c+-- If translation offsets are negative then the image is cropped.+translate :: Int+ -- ^ The horizontal translation offset (can be negative)+ -> Int+ -- ^ The vertical translation offset (can be negative)+ -> Image+ -- ^ The image to translate.+ -> Image+translate x y i = translateX x (translateY y i) --- | The empty image. Useful for fold combinators. These occupy no space nor define any display--- attributes.-empty_image :: Image -empty_image = EmptyImage+-- | Translates an image by padding or cropping its left side.+translateX :: Int -> Image -> Image+translateX x i+ | x < 0 && (abs x > imageWidth i) = emptyImage+ | 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 --- | Apply the given offset to the image.-translate :: (Int, Int) -> Image -> Image-translate v i = Translation v i+-- | Translates an image by padding or cropping its top.+translateY :: Int -> Image -> Image+translateY y i+ | y < 0 && (abs y > imageHeight i) = emptyImage+ | 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) --- | Ensure an image is no larger than the provided size. If the image is larger then crop.-crop :: (Word, Word) -> Image -> Image-crop (0,_) _ = EmptyImage-crop (_,0) _ = EmptyImage-crop v (ImageCrop _size i) = ImageCrop (min (fst v) (fst _size), min (snd v) (snd _size)) i-crop v i = ImageCrop v i+-- | Ensure an image is no larger than the provided size. If the image+-- is larger then crop the right or bottom.+--+-- This is equivalent to a vertical crop from the bottom followed by+-- horizontal crop from the right.+crop :: Int+ -- ^ Cropping width+ -> Int+ -- ^ Cropping height+ -> Image+ -- ^ The image to crop+ -> Image+crop 0 _ _ = EmptyImage+crop _ 0 _ = EmptyImage+crop w h i = cropBottom h (cropRight w i) --- | Ensure an image is at least the provided size. If the image is smaller then pad.-pad :: (Word, Word) -> Image -> Image-pad (0,_) _ = EmptyImage-pad (_,0) _ = EmptyImage-pad v (ImagePad _size i) = ImagePad (max (fst v) (fst _size), max (snd v) (snd _size)) i-pad v i = ImagePad v 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+-- the image is cropped from the bottom.+cropBottom :: Int -> Image -> Image+cropBottom 0 _ = EmptyImage+cropBottom h inI+ | h < 0 = error "cannot crop height to less than zero"+ | otherwise = go inI+ where+ go EmptyImage = EmptyImage+ go i@(Crop {outputHeight})+ = i {outputHeight = min h outputHeight}+ go i+ | h >= imageHeight i = i+ | 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+-- the image is cropped from the right.+cropRight :: Int -> Image -> Image+cropRight 0 _ = EmptyImage+cropRight w inI+ | w < 0 = error "cannot crop width to less than zero"+ | otherwise = go inI+ where+ go EmptyImage = EmptyImage+ go i@(Crop {outputWidth})+ = i {outputWidth = min w outputWidth}+ go i+ | w >= imageWidth i = 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+-- the image is cropped from the left.+cropLeft :: Int -> Image -> Image+cropLeft 0 _ = EmptyImage+cropLeft w inI+ | w < 0 = error "cannot crop the width to less than zero"+ | otherwise = go inI+ where+ go EmptyImage = EmptyImage+ 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 = 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+-- the image is cropped from the top.+cropTop :: Int -> Image -> Image+cropTop 0 _ = EmptyImage+cropTop h inI+ | h < 0 = error "cannot crop the height to less than zero"+ | otherwise = go inI+ where+ go EmptyImage = EmptyImage+ 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 = 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+-- pad/crop the right and bottom.+resize :: Int -> Int -> Image -> Image+resize w h i = resizeHeight h (resizeWidth w i)++-- | Resize the width. Pads and crops as required to assure the given+-- display width. This is biased to pad/crop on the right.+resizeWidth :: Int -> Image -> Image+resizeWidth w i = case w `compare` imageWidth i of+ LT -> cropRight w i+ EQ -> i+ GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)++-- | Resize the height. Pads and crops as required to assure the given+-- display height. This is biased to pad/crop on the bottom.+resizeHeight :: Int -> Image -> Image+resizeHeight h i = case h `compare` imageHeight i of+ LT -> cropBottom h i+ EQ -> i+ GT -> i <-> BGFill (imageWidth i) (h - imageHeight i)
+ src/Graphics/Vty/Image/Internal.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_HADDOCK hide #-}++module Graphics.Vty.Image.Internal+ ( Image(..)+ , imageHeight+ , imageWidth+ , horizJoin+ , vertJoin++ , ppImageStructure+ , clipText+ )+where++import Graphics.Vty.Attributes+import Graphics.Text.Width++import GHC.Generics++import Control.DeepSeq++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import qualified Data.Text.Lazy as TL++clipText :: TL.Text -> Int -> Int -> TL.Text+clipText txt leftSkip rightClip =+ -- CPS would clarify this I think+ let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0+ txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt+ (toTake,padSuffix) = clipForCharWidth rightClip txt' 0+ txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)+ -- Note: some characters and zero-width and combining characters+ -- combine to the left, so keep taking characters even if the+ -- width is zero.+ clipForCharWidth w t n+ | TL.null t = (n, False)+ | w < cw = (n, w /= 0)+ | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1)+ where cw = safeWcwidth (TL.head t)+ in txt''++-- | This is the internal representation of Images. Use the constructors+-- in "Graphics.Vty.Image" to create instances.+--+-- Images are:+--+-- * a horizontal span of text+--+-- * a horizontal or vertical join of two images+--+-- * a two dimensional fill of the 'Picture's background character+--+-- * a cropped image+--+-- * an empty image of no size or content.+data Image =+ -- | A horizontal text span has a row height of 1.+ HorizText+ { attr :: Attr+ -- | The text to display. The display width of the text is always+ -- outputWidth.+ , displayText :: TL.Text+ -- | The number of display columns for the text.+ , outputWidth :: Int+ -- | the number of characters in the text.+ , charWidth :: Int+ }+ -- | A horizontal join can be constructed between any two images.+ -- However a HorizJoin instance is required to be between two images+ -- of equal height. The horizJoin constructor adds background fills+ -- to the provided images that assure this is true for the HorizJoin+ -- value produced.+ | HorizJoin+ { partLeft :: Image+ , partRight :: Image+ , outputWidth :: Int+ -- ^ imageWidth partLeft == imageWidth partRight. Always > 0+ , outputHeight :: Int+ -- ^ imageHeight partLeft == imageHeight partRight. Always > 0+ }+ -- | A veritical join can be constructed between any two images.+ -- However a VertJoin instance is required to be between two images+ -- of equal width. The vertJoin constructor adds background fills+ -- to the provides images that assure this is true for the VertJoin+ -- value produced.+ | VertJoin+ { partTop :: Image+ , partBottom :: Image+ , outputWidth :: Int+ -- ^ imageWidth partTop == imageWidth partBottom. always > 0+ , outputHeight :: Int+ -- ^ imageHeight partTop == imageHeight partBottom. always > 1+ }+ -- | A background fill will be filled with the background char. The+ -- background char is defined as a property of the Picture this+ -- Image is used to form.+ | BGFill+ { outputWidth :: Int -- ^ always > 0+ , outputHeight :: Int -- ^ always > 0+ }+ -- | Crop an image+ | Crop+ { croppedImage :: Image+ , leftSkip :: Int+ , topSkip :: Int+ , outputWidth :: Int+ , outputHeight :: Int+ }+ -- | The empty image+ --+ -- The combining operators identity constant.+ -- EmptyImage <|> a = a+ -- EmptyImage <-> a = a+ --+ -- Any image of zero size equals the empty image.+ | EmptyImage+ deriving (Eq, Generic, Show, Read)++-- | pretty print just the structure of an image.+ppImageStructure :: Image -> String+ppImageStructure = go 0+ where+ go indent img = tab indent ++ pp indent img+ tab indent = concat $ replicate indent " "+ pp _ (HorizText {outputWidth}) = "HorizText(" ++ show outputWidth ++ ")"+ pp _ (BGFill {outputWidth, outputHeight})+ = "BGFill(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"+ pp i (HorizJoin {partLeft = l, partRight = r, outputWidth = c})+ = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r+ pp i (VertJoin {partTop = t, partBottom = b, outputWidth = c, outputHeight = r})+ = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n"+ ++ go (i+1) t ++ "\n"+ ++ go (i+1) b+ 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 (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` ()+ rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()++-- | The width of an Image. This is the number display columns the image+-- will occupy.+imageWidth :: Image -> Int+imageWidth HorizText { outputWidth = w } = w+imageWidth HorizJoin { outputWidth = w } = w+imageWidth VertJoin { outputWidth = w } = w+imageWidth BGFill { outputWidth = w } = w+imageWidth Crop { outputWidth = w } = w+imageWidth EmptyImage = 0++-- | The height of an Image. This is the number of display rows the+-- image will occupy.+imageHeight :: Image -> Int+imageHeight HorizText {} = 1+imageHeight HorizJoin { outputHeight = h } = h+imageHeight VertJoin { outputHeight = h } = h+imageHeight BGFill { outputHeight = h } = h+imageHeight Crop { outputHeight = h } = h+imageHeight EmptyImage = 0++-- | Append in the 'Semigroup' instance is equivalent to '<->'.+instance Semigroup Image where+ (<>) = vertJoin++-- | Append in the 'Monoid' instance is equivalent to '<->'.+instance Monoid Image where+ mempty = EmptyImage+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif++-- | combines two images side by side+--+-- Combines text chunks where possible. Assures outputWidth and+-- outputHeight properties are not violated.+--+-- 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 mismatch+-- will be filled with the background pattern.+horizJoin :: Image -> Image -> Image+horizJoin EmptyImage i = i+horizJoin i EmptyImage = i+horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)+ | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)+ -- assumes horiz text height is always 1+ | otherwise = HorizJoin i0 i1 (w0 + w1) 1+horizJoin i0 i1+ -- If the images are of the same height then no padding is required+ | h0 == h1 = HorizJoin i0 i1 w h0+ -- otherwise one of the images needs to be padded to the right size.+ | h0 < h1 -- Pad i0+ = let padAmount = h1 - h0+ in HorizJoin (VertJoin i0 (BGFill w0 padAmount) w0 h1) i1 w h1+ | h0 > h1 -- Pad i1+ = let padAmount = h0 - h1+ in HorizJoin i0 (VertJoin i1 (BGFill w1 padAmount) w1 h0) w h0+ where+ w0 = imageWidth i0+ w1 = imageWidth i1+ w = w0 + w1+ h0 = imageHeight i0+ h1 = imageHeight i1+horizJoin _ _ = error "horizJoin applied to undefined values."++-- | combines two images vertically+--+-- 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 mismatch+-- will be filled with the background pattern.+vertJoin :: Image -> Image -> Image+vertJoin EmptyImage i = i+vertJoin i EmptyImage = i+vertJoin i0 i1+ -- If the images are of the same width then no background padding is+ -- required+ | w0 == w1 = VertJoin i0 i1 w0 h+ -- Otherwise one of the images needs to be padded to the size of the+ -- other image.+ | w0 < w1+ = let padAmount = w1 - w0+ in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h+ | w0 > w1+ = let padAmount = w0 - w1+ in VertJoin i0 (HorizJoin i1 (BGFill padAmount h1) w0 h1) w0 h+ where+ w0 = imageWidth i0+ w1 = imageWidth i1+ h0 = imageHeight i0+ h1 = imageHeight i1+ h = h0 + h1+vertJoin _ _ = error "vertJoin applied to undefined values."
src/Graphics/Vty/Inline.hs view
@@ -1,102 +1,124 @@--- | 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. +-- | 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. ----- The changes specified by the InlineM monad are applied to the terminals display attributes. These--- display attributes effect the display of all following text output to the terminal file--- descriptor.+-- The changes specified by the InlineM monad are applied to the+-- terminal's display attributes. These display attributes affect the+-- display of all following text output to the terminal file descriptor. ----- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the--- text \" Styled! \" drawn over a red background and underlined.+-- For example, in an IO monad the following code will print the text+-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red+-- background and underlined. -- -- @--- t <- terminal_handle -- putStr \"Not styled. \"--- put_attr_change t $ do--- back_color red --- apply_style underline+-- putAttrChange_ $ do+-- backColor red+-- applyStyle underline -- putStr \" Styled! \"--- put_attr_change t $ default_all+-- putAttrChange_ $ defaultAll -- putStrLn \"Not styled.\"--- release_terminal t -- @ ----- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate--- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been--- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than--- 'put_attr_change'+-- 'putAttrChange' emits the control codes to the terminal device+-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when+-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been+-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a+-- different 'Handle' than 'putAttrChange'. -- -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE BangPatterns #-}-module Graphics.Vty.Inline ( module Graphics.Vty.Inline- )- where+module Graphics.Vty.Inline+ ( module Graphics.Vty.Inline+ )+where -import Graphics.Vty.Attributes+import Graphics.Vty import Graphics.Vty.DisplayAttributes-import Graphics.Vty.Terminal.Generic -import Control.Applicative+import Blaze.ByteString.Builder (writeToByteString)+ import Control.Monad.State.Strict import Data.Bits ( (.&.), complement ) import Data.IORef-import Data.Monoid ( mappend ) import System.IO -type InlineM v = State Attr v+type InlineM v = State InlineState v --- | Set the background color to the provided 'Color'-back_color :: Color -> InlineM ()-back_color c = modify $ flip mappend ( current_attr `with_back_color` c )+data InlineState =+ InlineState { inlineAttr :: Attr+ , inlineUrlsEnabled :: Bool+ } --- | Set the foreground color to the provided 'Color'-fore_color :: Color -> InlineM ()-fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )+-- | Set the background color to the provided 'Color'.+backColor :: Color -> InlineM ()+backColor c = modify $ \s ->+ s { inlineAttr = inlineAttr s `withBackColor` c+ } --- | Attempt to change the 'Style' of the following text.+-- | Set the foreground color to the provided 'Color'.+foreColor :: Color -> InlineM ()+foreColor c = modify $ \s ->+ s { inlineAttr = inlineAttr s `withForeColor` c+ }++-- | Attempt to change the 'Style' of the following text.. ----- If the terminal does not support the style change no error is produced. The style can still be--- removed.-apply_style :: Style -> InlineM ()-apply_style s = modify $ flip mappend ( current_attr `with_style` s )+-- If the terminal does not support the style change then no error is+-- produced. The style can still be removed.+applyStyle :: Style -> InlineM ()+applyStyle st = modify $ \s ->+ s { inlineAttr = inlineAttr s `withStyle` st+ } --- | Attempt to remove the specified 'Style' from the display of the following text.+-- | Attempt to remove the specified 'Style' from the display of the+-- following text. ----- This will fail if apply_style for the given style has not been previously called. -remove_style :: Style -> InlineM ()-remove_style s_mask = modify $ \attr -> - let style' = case attr_style attr of- Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."- KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."- SetTo s -> s .&. complement s_mask- in attr { attr_style = SetTo style' } +-- This will fail if 'applyStyle' for the given style has not been+-- previously called.+removeStyle :: Style -> InlineM ()+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."+ SetTo st -> st .&. complement sMask+ in (inlineAttr s) { attrStyle = SetTo style' }+ } --- | Reset the display attributes-default_all :: InlineM ()-default_all = put def_attr+-- | Reset the display attributes.+defaultAll :: InlineM ()+defaultAll = modify $ \s -> s { inlineAttr = defAttr } --- | Apply the provided display attribute changes to the terminal.+-- | Apply the provided display attribute changes to the given terminal+-- output device. ----- This also flushes the 'stdout' handle.-put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m ()-put_attr_change t c = do- bounds <- display_bounds t- d <- display_context t bounds- mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )+-- This does not flush the terminal.+putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()+putAttrChange out c = liftIO $ do+ bounds <- displayBounds out+ dc <- displayContext out bounds+ mfattr <- prevFattr <$> readIORef (assumedStateRef out) fattr <- case mfattr of Nothing -> do- liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d) - return $ FixedAttr default_style_mask Nothing Nothing+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False+ return $ FixedAttr defaultStyleMask Nothing Nothing Nothing Just v -> return v- let attr = execState c current_attr- attr' = limit_attr_for_display d attr- fattr' = fix_display_attr fattr attr'- diffs = display_attr_diffs fattr fattr'- liftIO $ hFlush stdout- liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )- ( serialize_set_attr d fattr attr' diffs )- liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }- inline_hack d- liftIO $ hFlush stdout+ let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)+ attr' = limitAttrForDisplay out attr+ fattr' = fixDisplayAttr fattr attr'+ diffs = displayAttrDiffs fattr fattr'+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs+ modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }+ inlineHack dc +-- | Apply the provided display attributes changes to the terminal+-- output device.+--+-- This will flush the terminal output.+putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()+putAttrChange_ out c = liftIO $ do+ hFlush stdout+ putAttrChange out c+ hFlush stdout
+ src/Graphics/Vty/Input.hs view
@@ -0,0 +1,32 @@+-- | This module provides the input abstraction for Vty.+module Graphics.Vty.Input+ ( Input(..)+ , module Graphics.Vty.Input.Events+ )+where++import Graphics.Vty.Input.Events+import Control.Concurrent.STM (TChan)++-- | 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/Events.hs view
@@ -0,0 +1,100 @@+{-# Language DeriveGeneric #-}+{-# Language StrictData #-}+module Graphics.Vty.Input.Events+ ( Key(..)+ , Modifier(..)+ , Event(..)+ , Button(..)+ , ClassifyMap+ , InternalEvent(..)+ )+where++import Control.DeepSeq+import Data.ByteString+import GHC.Generics++-- | Representations of non-modifier keys.+--+-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by+-- terminal and keyboard.+--+-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by+-- terminal and keyboard.+--+-- * Actually, support for most of these but KEsc, KChar, KBS, and+-- KEnter vary by terminal and keyboard.+data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter+ | KLeft | KRight | KUp | KDown+ | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter+ | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns+ | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu+ 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)++instance NFData Modifier++-- | Mouse buttons.+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]+ -- ^ A keyboard key was pressed with the specified modifiers.+ | EvMouseDown Int Int Button [Modifier]+ -- ^ A mouse button was pressed at the specified column and row. Any+ -- modifiers available in the event are also provided.+ | EvMouseUp Int Int (Maybe Button)+ -- ^ A mouse button was released at the specified column and+ -- row. Some terminals report only that a button was released+ -- without specifying which one; in that case, Nothing is provided.+ -- Otherwise Just the button released is included in the event.+ | EvResize Int Int+ -- 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+ -- events will be triggered on a paste event. Terminals that do not+ -- support bracketed pastes will send the paste contents as ordinary+ -- input (which is probably bad, so beware!) Note that the data is+ -- provided in raw form and you'll have to decode (e.g. as UTF-8) if+ -- that's what your application expects.+ | EvLostFocus+ -- ^ The terminal running the application lost input focus.+ | EvGainedFocus+ -- ^ The terminal running the application gained input focus.+ 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/LLInput.hs
@@ -1,250 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- Copyright 2009-2010 Corey O'Connor-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Graphics.Vty.LLInput ( Key(..)- , Modifier(..)- , Button(..)- , Event(..)- , initTermInput- )- where--import Data.Char-import Data.Maybe ( mapMaybe- )-import Data.List( inits )-import Data.Word-import qualified Data.Map as M( fromList, lookup )-import qualified Data.Set as S( fromList, member )--import Codec.Binary.UTF8.Generic (decode)--import Control.Monad (when)-import Control.Concurrent-import Control.Exception--import System.Console.Terminfo--import System.Posix.Signals.Exts-import System.Posix.Terminal-import System.Posix.IO ( stdInput- ,fdReadBuf- ,setFdOption- ,FdOption(..)- )--import Foreign ( alloca, poke, peek, Ptr )---- |Representations of non-modifier keys.-data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns- | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KNP5 | KUp | KMenu- | KLeft | KDown | KRight | KEnter- deriving (Eq,Show,Ord)---- |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,Ord)---- |Mouse buttons. Not yet used.-data Button = BLeft | BMiddle | BRight- deriving (Eq,Show,Ord)---- |Generic events.-data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]- | EvResize Int Int- deriving (Eq,Show,Ord)--data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char]- deriving(Show)---- | Set up the terminal for input. Returns a function which reads key--- events, and a function for shutting down the terminal access.-initTermInput :: Int -> Terminal -> IO (IO Event, IO ())-initTermInput escDelay terminal = do- eventChannel <- newChan- inputChannel <- newChan- hadInput <- newEmptyMVar- oattr <- getTerminalAttributes stdInput- let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts,- EnableEcho, ProcessInput, ExtendedFunctions]- setTerminalAttributes stdInput nattr Immediately- set_term_timing- let inputToEventThread :: IO ()- inputToEventThread = loop []- where loop kb = case (classify kb) of- Prefix -> do c <- readChan inputChannel- loop (kb ++ [c])- Invalid -> do c <- readChan inputChannel- loop [c]- MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s- Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""-- finishAtomicInput = writeChan inputChannel '\xFFFE'-- inputThread :: IO ()- inputThread = do- _ <- alloca $ \(input_buffer :: Ptr Word8) -> do- let loop = do- setFdOption stdInput NonBlockingRead False- threadWaitRead stdInput- setFdOption stdInput NonBlockingRead True- _ <- try readAll :: IO (Either IOException ())- when (escDelay == 0) finishAtomicInput- loop- readAll = do- poke input_buffer 0- bytes_read <- fdReadBuf stdInput input_buffer 1- input_char <- fmap (chr . fromIntegral) $ peek input_buffer- when (bytes_read > 0) $ do- _ <- tryPutMVar hadInput () -- signal input- writeChan inputChannel input_char- readAll- loop- return ()-- -- | If there is no input for some time, this thread puts '\xFFFE' in the- -- inputChannel.- noInputThread :: IO ()- noInputThread = when (escDelay > 0) loop- where loop = do- takeMVar hadInput -- wait for some input- threadDelay escDelay -- microseconds- hadNoInput <- isEmptyMVar hadInput -- no input yet?- -- TODO(corey): there is a race between here and the inputThread.- when hadNoInput $ do- finishAtomicInput- loop--- compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass- compile lst = cl' where- lst' = concat lst- pfx = S.fromList $ concatMap (init . inits . fst) $ lst'- mlst = M.fromList lst'- cl' str = case S.member str pfx of- True -> Prefix- False -> case M.lookup str mlst of- Just (k,m) -> Valid k m- Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of- (s,(k,m)) -> MisPfx k m (drop (length s) str)-- -- ANSI specific bits--- classify, classifyTab :: [Char] -> KClass-- -- As soon as- classify "\xFFFE" = Invalid- classify s@(c:_) | ord c >= 0xC2 =- if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence- classify other = classifyTab other-- classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of- Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []- _ -> Invalid -- something bad happened; just ignore and continue.-- classifyTab = compile (caps_classify_table : ansi_classify_table)-- caps_tabls = [("khome", (KHome, [])),- ("kend", (KEnd, [])),- ("cbt", (KBackTab, [])),- ("kcud1", (KDown, [])),- ("kcuu1", (KUp, [])),- ("kcuf1", (KRight, [])),- ("kcub1", (KLeft, [])),-- ("kLFT", (KLeft, [MShift])),- ("kRIT", (KRight, [MShift]))- ]-- caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls]-- ansi_classify_table :: [[([Char], (Key, [Modifier]))]]- ansi_classify_table =- [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5- , k "P" KPause- , k "A" KUp- , k "B" KDown- , k "C" KRight- , k "D" KLeft- , k "H" KHome- , k "F" KEnd- , k "E" KBegin- ],-- -- Support for arrows and KHome/KEnd- [("\ESC[" ++ charCnt ++ show mc++c,(s,m))- | charCnt <- ["1;", ""], -- we can have a count or not- (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),- ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes- (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes- ],-- let k n s = ("\ESC["++show n++"~",(s,[]))- in zipWith k [2::Int,3,5,6,1,4]- [KIns,KDel,KPageUp,KPageDown,KHome,KEnd],-- let k n s = ("\ESC["++show n++";5~",(s,[MCtrl]))- in zipWith k [2::Int,3,5,6,1,4]- [KIns,KDel,KPageUp,KPageDown,KHome,KEnd],-- -- Support for simple characters.- [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],-- -- Support for function keys (should use terminfo)- [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],- let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in- concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],- [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],-- -- Ctrl+Char- [ ([toEnum x],(KASCII y,[MCtrl]))- | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),- y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.- ],-- -- Ctrl+Meta+Char- [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],-- -- Special support- [ -- special support for ESC- ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])),-- -- Special support for backspace- ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),-- -- Special support for Enter- ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ]- ]-- eventThreadId <- forkIO $ inputToEventThread- inputThreadId <- forkIO $ inputThread- noInputThreadId <- forkIO $ noInputThread- let pokeIO = (Catch $ do let e = error "(getsize in input layer)"- setTerminalAttributes stdInput nattr Immediately- writeChan eventChannel (EvResize e e))- _ <- installHandler windowChange pokeIO Nothing- _ <- installHandler continueProcess pokeIO Nothing- -- TODO(corey): killThread is a bit risky for my tastes.- let uninit = do killThread eventThreadId- killThread inputThreadId- killThread noInputThreadId- _ <- installHandler windowChange Ignore Nothing- _ <- installHandler continueProcess Ignore Nothing- setTerminalAttributes stdInput oattr Immediately- return (readChan eventChannel, uninit)--first :: (a -> b) -> (a,c) -> (b,c)-first f (x,y) = (f x, y)--utf8Length :: (Num t, Ord a, Num a) => a -> t-utf8Length c- | c < 0x80 = 1- | c < 0xE0 = 2- | c < 0xF0 = 3- | otherwise = 4--foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()
+ src/Graphics/Vty/Output.hs view
@@ -0,0 +1,367 @@+{-# 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+ ( 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 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+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL++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++-- | 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 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 necessarily the same as the character position with the+-- same coordinates. Characters can be a variable number of columns in+-- width.+--+-- Currently, the only way to set the cursor position to a given+-- character coordinate is to specify the coordinate in the Picture+-- instance provided to 'outputPicture' or 'refresh'.+setCursorPos :: Output -> Int -> Int -> IO ()+setCursorPos t x y = do+ bounds <- displayBounds t+ when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do+ dc <- displayContext t bounds+ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y++-- | Hides the cursor.+hideCursor :: Output -> IO ()+hideCursor t = do+ bounds <- displayBounds t+ dc <- displayContext t bounds+ outputByteBuffer t $ writeToByteString $ writeHideCursor dc++-- | Shows the cursor.+showCursor :: Output -> IO ()+showCursor t = do+ 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/Mock.hs view
@@ -0,0 +1,90 @@+-- Copyright Corey O'Connor+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+-- | This provides a mock terminal implementation that is nice for+-- testing. This transforms the output operations to visible characters+-- which is useful for testing.+module Graphics.Vty.Output.Mock+ ( MockData+ , mockTerminal+ )+where++import Graphics.Vty.Image (DisplayRegion)+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))+import Graphics.Vty.Output++import Blaze.ByteString.Builder.Word (writeWord8)++import Control.Monad.Trans++import qualified Data.ByteString as BS+import Data.IORef+import qualified Data.String.UTF8 as UTF8++type MockData = IORef (UTF8.UTF8 BS.ByteString)++-- | The mock display terminal produces a string representation of+-- the requested picture. There is *not* an isomorphism between the+-- string representation and the picture. The string representation is+-- a simplification of the picture that is only useful in debugging VTY+-- without considering terminal specific issues.+--+-- The mock implementation is useful in manually determining if 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.+--+-- The string representation is a sequence of identifiers where each+-- identifier is the name of an operation in the algebra.+mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)+mockTerminal r = liftIO $ do+ outRef <- newIORef undefined+ newAssumedStateRef <- newIORef initialAssumedState+ let t = Output+ { terminalID = "mock terminal"+ , releaseTerminal = return ()+ , reserveDisplay = return ()+ , 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+ , 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+ -- A cursor move is always visualized as the single+ -- character 'M'+ , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'+ -- Show cursor is always visualized as the single+ -- character 'S'+ , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S'+ -- Hide cursor is always visualized as the single+ -- character 'H'+ , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'+ -- An attr change is always visualized as the single+ -- character 'A'+ , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'+ -- default attr is always visualized as the single+ -- character 'D'+ , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'+ -- row end is always visualized as the single character+ -- 'E'+ , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'+ , inlineHack = return ()+ }+ }+ return (outRef, t)
src/Graphics/Vty/Picture.hs view
@@ -1,81 +1,128 @@--- | The Picture data structure is representative of the final terminal view.------ This module re-exports most of the Graphics.Vty.Image and Graphics.Vty.Attributes modules.------ Copyright 2009-2010 Corey O'Connor-module Graphics.Vty.Picture ( module Graphics.Vty.Picture- , Image- , image_width- , image_height- , (<|>)- , (<->)- , horiz_cat- , vert_cat- , background_fill- , char- , string- , iso_10646_string- , utf8_string- , utf8_bytestring- , char_fill- , empty_image- , translate- , crop- , pad- -- | The possible display attributes used in constructing an `Image`.- , module Graphics.Vty.Attributes- )- where+-- A 'Picture' is a background paired with a set of 'Image' layers. The+-- 'Picture' data structure is representative of the final terminal+-- view.+module Graphics.Vty.Picture+ ( Picture(..)+ , Cursor(..)+ , Background(..)+ , emptyPicture+ , addToTop+ , addToBottom+ , picForImage+ , picForLayers+ , picImage+ )+where +import Graphics.Vty.Image import Graphics.Vty.Attributes-import Graphics.Vty.Image hiding ( attr ) -import Data.Word+import Control.DeepSeq --- | The type of images to be displayed using 'update'. --- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with--- reasonable defaults for pic_cursor and pic_background.+-- | A Vty picture.+--+-- These can be constructed directly or using `picForImage`. data Picture = Picture- { pic_cursor :: Cursor- , pic_image :: Image - , pic_background :: Background- }+ { picCursor :: Cursor+ -- ^ The picture's cursor.+ , picLayers :: [Image]+ -- ^ The picture's image layers (top-most first).+ , picBackground :: Background+ -- ^ The picture's background to be displayed in locations with no+ -- Image data.+ } deriving (Eq, Show) -instance Show Picture where- show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"+instance NFData Picture where+ rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () --- | Create a picture for display for the given image. The picture will not have a displayed cursor--- and the background display attribute will be `current_attr`.-pic_for_image :: Image -> Picture-pic_for_image i = Picture - { pic_cursor = NoCursor- , pic_image = i- , pic_background = Background ' ' current_attr+-- | A picture with no cursor, background or image layers.+emptyPicture :: Picture+emptyPicture = Picture NoCursor [] ClearBackground++-- | Add an 'Image' as the top-most layer of a 'Picture'.+addToTop :: Picture -> Image -> Picture+addToTop p i = p {picLayers = i : picLayers p}++-- | Add an 'Image' as the bottom-most layer of a 'Picture'.+addToBottom :: Picture -> Image -> Picture+addToBottom p i = p {picLayers = picLayers p ++ [i]}++-- | Create a picture from the given image. The picture will not have a+-- displayed cursor and no background pattern (ClearBackground) will be+-- used.+picForImage :: Image -> Picture+picForImage i = Picture+ { picCursor = NoCursor+ , picLayers = [i]+ , picBackground = ClearBackground } --- | A picture can be configured either to not show the cursor or show the cursor at the specified--- character position. +-- | Create a picture with the given layers, top-most first. ----- There is not a 1 to 1 map from character positions to a row and column on the screen due to--- characters that take more than 1 column.+-- The picture will not have a displayed cursor and no background+-- pattern (ClearBackgroun) will be used.+picForLayers :: [Image] -> Picture+picForLayers is = Picture+ { picCursor = NoCursor+ , picLayers = is+ , picBackground = ClearBackground+ }++-- | A picture can be configured to hide the cursor or to show the+-- cursor at the specified character position. ----- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the--- output region. In this case the cursor will not be shown.-data Cursor = - NoCursor- | Cursor Word Word+-- There is not a 1:1 map from character positions to a row and column+-- on the screen due to characters that take more than 1 column.+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, Show) --- | Unspecified regions are filled with the picture's background pattern. The background pattern--- can specify a character and a display attribute. If the display attribute used previously should--- be used for a background fill then use `current_attr` for the background attribute. This is the--- default background display attribute.+instance NFData Cursor where+ rnf c = c `seq` ()++-- | A 'Picture' has a background pattern. The background is either: ----- \todo The current attribute is always set to the default attributes at the start of updating the--- screen to a picture.+-- * ClearBackground, which shows the layer below or is blank if the+-- bottom layer+-- * A character and a display attribute ----- \todo The background character *must* occupy a single column and no more.-data Background = Background - { background_char :: Char - , background_attr :: Attr+-- If the display attribute used previously should be used for a+-- background fill then use `currentAttr` for the background attribute.+data Background+ = Background+ { backgroundChar :: Char+ , backgroundAttr :: Attr }+ -- | A ClearBackground is:+ --+ -- * the space character if there are remaining non-skip ops+ --+ -- * End of line if there are no remaining non-skip ops.+ | ClearBackground+ deriving (Eq, Show) +instance NFData Background where+ rnf (Background c a) = c `seq` a `seq` ()+ rnf ClearBackground = ()++-- | Return the top-most 'Image' layer for a picture. This is unsafe for+-- 'Picture's without at least one layer.+--+-- This is provided for compatibility with applications that do not use+-- more than a single layer.+picImage :: Picture -> Image+picImage = head . picLayers
+ src/Graphics/Vty/PictureToSpans.hs view
@@ -0,0 +1,351 @@+-- Copyright Corey O'Connor<coreyoconnor@gmail.com>+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++-- | Transforms an image into rows of operations.+module Graphics.Vty.PictureToSpans+ ( displayOpsForPic+ )+where++import Graphics.Vty.Attributes (Attr, currentAttr)+import Graphics.Vty.Image+import Graphics.Vty.Image.Internal+import Graphics.Vty.Picture+import Graphics.Vty.Span++import Lens.Micro+import Lens.Micro.Mtl+import Control.Monad+import Control.Monad.Reader+import Control.Monad.State.Strict hiding ( state )+import Control.Monad.ST.Strict++import qualified Data.Vector as Vector hiding ( take, replicate )+import Data.Vector.Mutable ( MVector(..))+import qualified Data.Vector.Mutable as MVector++import qualified Data.Text.Lazy as TL++type MRowOps s = MVector s SpanOps++-- transform plus clip. More or less.+data BlitState = BlitState+ -- we always snoc to the operation vectors. Thus the columnOffset =+ -- length of row at rowOffset although, one possibility is to merge+ -- layers right in snocOp (naming it something else, of course). In+ -- which case columnnOffset would be applicable. Right now we need+ -- it to exist.+ { _columnOffset :: Int+ , _rowOffset :: Int+ -- clip coordinate space is in image space. Which means it's >= 0+ -- and < imageWidth.+ , _skipColumns :: Int+ -- >= 0 and < imageHeight+ , _skipRows :: Int+ -- includes consideration of skipColumns. In display space. The+ -- number of columns from the next column to be defined to the end+ -- of the display for the row.+ , _remainingColumns :: Int+ -- includes consideration of skipRows. In display space.+ , _remainingRows :: Int+ }++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+ }++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+-- cropped or padded, into the specified region.+displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps+displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)++-- | 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 (`buildSpans` r) (picLayers pic)+ case layerOps of+ [] -> error "empty picture"+ [ops] -> substituteSkips (picBackground pic) ops+ -- instead of merging ops after generation the merging can+ -- be performed as part of snocOp.+ topOps : lowerOps -> do+ ops <- foldM mergeUnder topOps lowerOps+ substituteSkips (picBackground pic) ops++substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)+substituteSkips ClearBackground ops = do+ forM_ [0 .. MVector.length ops - 1] $ \row -> do+ rowOps <- MVector.read ops row+ -- the image operations assure that background fills are+ -- combined. clipping a background fill does not split the+ -- background fill. merging of image layers can split a skip,+ -- but only by the insertion of a non skip. all this combines to+ -- mean we can check the last operation and remove it if it's a+ -- skip+ let rowOps' = case Vector.last rowOps of+ Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w+ _ -> rowOps+ -- now all the skips can be replaced by replications of ' ' of+ -- the required width.+ let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'+ MVector.write ops row rowOps''+ return ops+substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do+ -- 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 -> error $ "invalid background character " ++ show backgroundChar+ | w == 1 -> do+ forM_ [0 .. MVector.length ops - 1] $ \row -> do+ rowOps <- MVector.read ops row+ let rowOps' = swapSkipsForSingleColumnCharSpan backgroundChar backgroundAttr rowOps+ MVector.write ops row rowOps'+ | otherwise -> do+ forM_ [0 .. MVector.length ops - 1] $ \row -> do+ rowOps <- MVector.read ops row+ let rowOps' = swapSkipsForCharSpan w backgroundChar backgroundAttr rowOps+ MVector.write ops row rowOps'+ return ops++mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s)+mergeUnder upper lower = do+ forM_ [0 .. MVector.length upper - 1] $ \row -> do+ upperRowOps <- MVector.read upper row+ lowerRowOps <- MVector.read lower row+ let rowOps = mergeRowUnder upperRowOps lowerRowOps+ MVector.write upper row rowOps+ return upper++mergeRowUnder :: SpanOps -> SpanOps -> SpanOps+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.+ onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps+ onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =+ let lowerOps' = dropOps w lowerOps+ outOps' = Vector.snoc outOps op+ in if Vector.null lowerOps'+ then outOps'+ else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps'+ onUpperOp outOps (Skip w) upperOps lowerOps =+ let (ops', lowerOps') = splitOpsAt w lowerOps+ outOps' = outOps `mappend` ops'+ in if Vector.null lowerOps'+ then outOps'+ else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps'+ onUpperOp _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops"+++swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps+swapSkipsForSingleColumnCharSpan c a = Vector.map f+ where f (Skip ow) = let txt = TL.take (toEnum ow) $ TL.repeat c+ in TextSpan a ow ow txt+ f v = v++swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps+swapSkipsForCharSpan w c a = Vector.map f+ where+ f (Skip ow) = let txt0Cw = ow `div` w+ txt0 = TL.pack $ replicate txt0Cw c+ txt1Cw = ow `mod` w+ txt1 = TL.pack $ replicate txt1Cw '…'+ cw = txt0Cw + txt1Cw+ txt = txt0 `TL.append` txt1+ in TextSpan a ow cw txt+ f v = v++-- | Builds a vector of row operations that will output the given+-- picture to the terminal.+--+-- Crops to the given display region.+buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)+buildSpans image outRegion = do+ -- First we create a mutable vector for each rows output operations.+ outOps <- MVector.replicate (regionHeight outRegion) Vector.empty+ -- It's possible that building the span operations in display order+ -- would provide better performance.+ --+ -- A depth first traversal of the image is performed. ordered+ -- according to the column range defined by the image from least+ -- to greatest. The output row ops will at least have the region+ -- of the image specified. Iterate over all output rows and output+ -- background fills for all unspecified columns.+ --+ -- The images are made into span operations from left to right. It's+ -- possible that this could easily be made to assure top to bottom+ -- output as well.+ when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do+ -- The ops builder recursively descends the image and outputs+ -- span ops that would display that image. The number of columns+ -- remaining in this row before exceeding the bounds is also+ -- provided. This is used to clip the span ops produced to the+ -- display.+ let fullBuild = do+ startImageBuild image+ -- Fill in any unspecified columns with a skip.+ forM_ [0 .. (regionHeight outRegion - 1)] (addRowCompletion outRegion)+ initEnv = BlitEnv outRegion outOps+ initState = BlitState 0 0 0 0 (regionWidth outRegion) (regionHeight outRegion)+ _ <- runStateT (runReaderT fullBuild initEnv) initState+ return ()+ return outOps++-- | Add the operations required to build a given image to the current+-- set of row operations.+startImageBuild :: Image -> BlitM s ()+startImageBuild image = do+ outOfBounds <- isOutOfBounds image <$> get+ when (not outOfBounds) $ addMaybeClipped image++isOutOfBounds :: Image -> BlitState -> Bool+isOutOfBounds i s+ | 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+-- 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+ -- This assumes that text spans are only 1 row high.+ s <- use skipRows+ when (s < 1) $ do+ leftClip <- use skipColumns+ rightClip <- use remainingColumns+ let leftClipped = leftClip > 0+ rightClipped = (ow - leftClip) > rightClip+ if leftClipped || rightClipped+ then let textStr' = clipText textStr leftClip rightClip+ in addUnclippedText a textStr'+ else addUnclippedText a textStr+addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do+ when (imageHeight topImage + imageHeight bottomImage > 0) $+ addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset+ (imageHeight topImage)+ topImage+ bottomImage+ oh+addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do+ when (imageWidth leftImage + imageWidth rightImage > 0) $+ addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset+ (imageWidth leftImage)+ leftImage+ rightImage+ ow+addMaybeClipped BGFill {outputWidth, outputHeight} = do+ s <- get+ let outputWidth' = min (outputWidth - s^.skipColumns) (s^.remainingColumns)+ outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows)+ y <- use rowOffset+ forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth')+addMaybeClipped Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight} = do+ sx <- use skipColumns+ skipColumns += leftSkip+ modifying remainingColumns (min (outputWidth - sx))+ sy <- use skipRows+ skipRows += topSkip+ modifying remainingRows (min (outputHeight - sy))+ addMaybeClipped croppedImage++addMaybeClippedJoin :: forall s . String+ -> Lens BlitState BlitState Int Int+ -> Lens BlitState BlitState Int Int+ -> Lens BlitState BlitState Int Int+ -> Int+ -> Image+ -> Image+ -> Int+ -> BlitM s ()+addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do+ state <- get+ 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+ then do+ addMaybeClipped i0+ put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim+ addMaybeClipped i1+ else addMaybeClipped i0+ | s < i0Dim ->+ let i0Dim' = i0Dim - s+ in if state^.remaining <= i0Dim'+ then addMaybeClipped i0+ else do+ addMaybeClipped i0+ put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0+ addMaybeClipped i1+ | s >= i0Dim -> do+ put $ state & skip %~ subtract i0Dim+ addMaybeClipped i1+ _ -> error $ name ++ " has unhandled skip class"++addUnclippedText :: Attr -> TL.Text -> BlitM s ()+addUnclippedText a txt = do+ let op = TextSpan a usedDisplayColumns+ (fromIntegral $ TL.length txt)+ txt+ usedDisplayColumns = wctlwidth txt+ use rowOffset >>= snocOp op++addRowCompletion :: DisplayRegion -> Int -> BlitM s ()+addRowCompletion displayRegion row = do+ allRowOps <- view mrowOps+ rowOps <- lift $ lift $ MVector.read allRowOps row+ let endX = spanOpsAffectedColumns rowOps+ when (endX < regionWidth displayRegion) $ do+ let ow = regionWidth displayRegion - endX+ snocOp (Skip ow) row++-- | snocs the operation to the operations for the given row.+snocOp :: SpanOp -> Int -> BlitM s ()+snocOp !op !row = do+ theMrowOps <- view mrowOps+ theRegion <- view region+ lift $ lift $ do+ ops <- MVector.read theMrowOps row+ let ops' = Vector.snoc ops op+ when (spanOpsAffectedColumns ops' > regionWidth theRegion)+ $ error $ "row " ++ show row ++ " now exceeds region width"+ MVector.write theMrowOps row ops'
src/Graphics/Vty/Span.hs view
@@ -1,354 +1,144 @@--- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE NamedFieldPuns #-}+-- Copyright Corey O'Connor {-# LANGUAGE GADTs #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables #-}--- The ops to define the content for an output region. +-- | A picture is translated into a sequences of state changes and+-- character spans. The attribute is applied to all following spans,+-- including spans of the next row. The nth element of the sequence+-- represents the nth row (from top to bottom) of the picture to render.+--+-- 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+ ( SpanOp(..)+ , columnsToCharOffset+ , spanOpHasWidth -import Graphics.Vty.Image-import Graphics.Vty.Picture-import Graphics.Vty.DisplayRegion+ , SpanOps+ , spanOpsAffectedColumns+ , splitOpsAt+ , dropOps -import Codec.Binary.UTF8.String ( encode )+ , DisplayOps+ , displayOpsRows+ , displayOpsColumns+ , affectedRegion+ )+where -import Control.Monad ( forM_ )-import Control.Monad.ST.Strict hiding ( unsafeIOToST )-import Control.Monad.ST.Unsafe ( unsafeIOToST )+import Graphics.Vty.Attributes (Attr)+import Graphics.Vty.Image+import Graphics.Vty.Image.Internal ( clipText ) +import qualified Data.Text.Lazy as TL import Data.Vector (Vector)-import qualified Data.Vector as Vector hiding ( take, replicate )-import Data.Vector.Mutable ( MVector(..))-import qualified Data.Vector.Mutable as Vector--import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as BInt-import qualified Data.Foldable as Foldable-import qualified Data.String.UTF8 as UTF8-import Data.Word--import Foreign.Storable ( pokeByteOff )--{- | A picture is translated into a sequences of state changes and character spans.- - State changes are currently limited to new attribute values. The attribute is applied to all- - following spans. Including spans of the next row. The nth element of the sequence represents the- - nth row (from top to bottom) of the picture to render.- -- - A span op sequence will be defined for all rows and columns (and no more) of the region provided- - with the picture to spans_for_pic.- - - - todo: Partition attribute changes into multiple categories according to the serialized- - representation of the various attributes.- -}--data DisplayOps = DisplayOps- { effected_region :: DisplayRegion - , display_ops :: RowOps- }---- | vector of span operation vectors. One per row of the screen.-type RowOps = Vector SpanOps+import qualified Data.Vector as Vector -type MRowOps s = MVector s SpanOps+-- | This represents an operation on the terminal: either an attribute+-- change or the output of a text string.+data SpanOp =+ -- | A span of UTF-8 text occupies a specific number of screen space+ -- columns. A single UTF character does not necessarily represent 1+ -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width+ -- in columns] [number of characters] [data]+ TextSpan+ { textSpanAttr :: !Attr+ , textSpanOutputWidth :: !Int+ , textSpanCharWidth :: !Int+ , textSpanText :: TL.Text+ }+ -- | Skips the given number of columns.+ | Skip !Int+ -- | Marks the end of a row. Specifies how many columns are+ -- remaining. These columns will not be explicitly overwritten with+ -- the span ops. The terminal is require to assure the remaining+ -- columns are clear.+ | RowEnd !Int+ deriving Eq --- | vector of span operations. executed in succession. This represents the operations required to--- render a row of the terminal. The operations in one row may effect subsequent rows.--- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground--- color is changed.+-- | A vector of span operations executed in succession. This represents+-- the operations required to render a row of the terminal. The+-- operations in one row may affect subsequent rows. For example,+-- setting the foreground color in one row will affect all subsequent+-- rows until the foreground color is changed. type SpanOps = Vector SpanOp -type MSpanOps s = MVector s SpanOp--instance Show DisplayOps where- show (DisplayOps _ the_row_ops)- = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"--instance Show SpanOp where- show (AttributeChange attr) = show attr- show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw---- | Number of columns the DisplayOps are defined for-span_ops_columns :: DisplayOps -> Word-span_ops_columns ops = region_width $ effected_region ops---- | Number of rows the DisplayOps are defined for-span_ops_rows :: DisplayOps -> Word-span_ops_rows ops = region_height $ effected_region ops---- | The number of columns a SpanOps effects.-span_ops_effected_columns :: SpanOps -> Word-span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops- where - span_ops_effected_columns' t (TextSpan w _ _ ) = t + w- span_ops_effected_columns' t _ = t---- | This represents an operation on the terminal. Either an attribute change or the output of a--- text string.--- --- todo: This type may need to be restructured to increase sharing in the bytestring--- --- todo: Make foldable-data SpanOp =- AttributeChange !Attr- -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF- -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width- -- TextSpan [output width in columns] [number of characters] [data]- | TextSpan !Word !Word (UTF8.UTF8 B.ByteString)- deriving Eq+dropOps :: Int -> SpanOps -> SpanOps+dropOps w = snd . splitOpsAt w --- | The width of a single SpanOp in columns-span_op_has_width :: SpanOp -> Maybe (Word, Word)-span_op_has_width (TextSpan ow cw _) = Just (cw, ow)-span_op_has_width _ = Nothing+splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)+splitOpsAt = splitOpsAt'+ where+ splitOpsAt' 0 ops = (Vector.empty, ops)+ splitOpsAt' remainingColumns ops = case Vector.head ops of+ t@(TextSpan {}) -> if remainingColumns >= textSpanOutputWidth t+ then let (pre,post) = splitOpsAt' (remainingColumns - textSpanOutputWidth t)+ (Vector.tail ops)+ in (Vector.cons t pre, post)+ else let preTxt = clipText (textSpanText t) 0 remainingColumns+ preOp = TextSpan { textSpanAttr = textSpanAttr t+ , textSpanOutputWidth = remainingColumns+ , textSpanCharWidth = fromIntegral $! TL.length preTxt+ , textSpanText = preTxt+ }+ postWidth = textSpanOutputWidth t - remainingColumns+ postTxt = clipText (textSpanText t) remainingColumns postWidth+ postOp = TextSpan { textSpanAttr = textSpanAttr t+ , textSpanOutputWidth = postWidth+ , textSpanCharWidth = fromIntegral $! TL.length postTxt+ , textSpanText = postTxt+ }+ in ( Vector.singleton preOp+ , Vector.cons postOp (Vector.tail ops)+ )+ Skip w -> if remainingColumns >= w+ then let (pre,post) = splitOpsAt' (remainingColumns - w) (Vector.tail ops)+ in (Vector.cons (Skip w) pre, post)+ else ( Vector.singleton $ Skip remainingColumns+ , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops)+ )+ RowEnd _ -> error "cannot split ops containing a row end" --- | returns the number of columns to the character at the given position in the span op-columns_to_char_offset :: Word -> SpanOp -> Word-columns_to_char_offset cx (TextSpan _ _ utf8_str) =- let str = UTF8.toString utf8_str- in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str-columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"+-- | A vector of span operation vectors for display, one per row of the+-- output region.+type DisplayOps = Vector SpanOps --- | Produces the span ops that will render the given picture, possibly cropped or padded, into the--- specified region.-spans_for_pic :: Picture -> DisplayRegion -> DisplayOps-spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r)+instance Show SpanOp where+ show (TextSpan attr ow cw _) = "TextSpan(" ++ show attr ++ ")(" ++ show ow ++ ", " ++ show cw ++ ")"+ show (Skip ow) = "Skip(" ++ show ow ++ ")"+ show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" --- | Builds a vector of row operations that will output the given picture to the terminal.+-- | The number of columns the DisplayOps are defined for. ----- Crops to the given display region.-build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s)-build_spans pic region = do- -- First we create a mutable vector for each rows output operations.- mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty- -- \todo I think building the span operations in display order would provide better performance.- -- However, I got stuck trying to implement an algorithm that did this. This will be considered- -- as a possible future optimization. - --- -- A depth first traversal of the image is performed. ordered according to the column range- -- defined by the image from least to greatest. The output row ops will at least have the- -- region of the image specified. Iterate over all output rows and output background fills for- -- all unspecified columns.- --- -- The images are made into span operations from left to right. It's possible that this could- -- easily be made to assure top to bottom output as well. - if region_height region > 0- then do - -- The ops builder recursively descends the image and outputs span ops that would- -- display that image. The number of columns remaining in this row before exceeding the- -- bounds is also provided. This is used to clip the span ops produced to the display.- -- The skip dimensions provided do....???- _ <- row_ops_for_image mrow_ops - (pic_image pic)- (pic_background pic) - region - (0,0) - 0 - (region_width region)- (fromEnum $ region_height region)- -- Fill in any unspecified columns with the background pattern.- forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do- end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns- if end_x < region_width region - then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row- else return ()- else return ()- return mrow_ops+-- All spans are verified to define same number of columns.+displayOpsColumns :: DisplayOps -> Int+displayOpsColumns ops+ | Vector.length ops == 0 = 0+ | otherwise = Vector.length $ Vector.head ops --- | Add the operations required to build a given image to the current set of row operations.-row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word)-row_ops_for_image mrow_ops -- the image to output the ops to- image -- the image to rasterize in column order to mrow_ops- bg -- the background fill- region -- ???- skip_dim@(skip_row,skip_col) -- the number of rows - y -- ???- remaining_columns -- ???- remain_rows- | remaining_columns == 0 = return skip_dim- | remain_rows == 0 = return skip_dim- | y >= fromEnum (region_height region) = return skip_dim- | otherwise = case image of- EmptyImage -> return skip_dim- -- The width provided is the number of columns this text span will occupy when displayed.- -- if this is greater than the number of remaining columsn the output has to be produced a- -- character at a time.- HorizText a text_str _ _ -> do- if skip_row > 0- then return (skip_row - 1, skip_col)- else do- skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns- return (skip_row, skip_col')- VertJoin top_image bottom_image _ _ -> do- (skip_row',skip_col') <- row_ops_for_image mrow_ops - top_image- bg - region - skip_dim - y - remaining_columns- remain_rows- let top_height = (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row')- (skip_row'',skip_col'') <- row_ops_for_image mrow_ops - bottom_image- bg - region - (skip_row', skip_col) - (y + top_height)- remaining_columns- (max 0 $ remain_rows - top_height)- return (skip_row'', min skip_col' skip_col'')- HorizJoin l r _ _ -> do- (skip_row',skip_col') <- row_ops_for_image mrow_ops l bg region skip_dim y remaining_columns remain_rows- -- Don't output the right part unless there is at least a single column left after- -- outputting the left part.- if image_width l - (skip_col - skip_col') > remaining_columns- then return (skip_row,skip_col')- else do- (skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col')) remain_rows- return (min skip_row' skip_row'', skip_col'')- BGFill width height -> do- let min_height = if y + (fromEnum height) > (fromEnum $! region_height region)- then region_height region - (toEnum y)- else min height (toEnum remain_rows)- min_width = min width remaining_columns- actual_height = if skip_row > min_height- then 0- else min_height - skip_row- actual_width = if skip_col > min_width- then 0- else min_width - skip_col- forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y'- let skip_row' = if actual_height > skip_row- then 0- else skip_row - min_height- skip_col' = if actual_width > skip_col- then 0- else skip_col - min_width- return (skip_row',skip_col')- Translation (dx,dy) i -> do- if dx < 0- -- Translation left- -- Extract the delta and add it to skip_col.- then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns remain_rows- -- Translation right- else if dy < 0- -- Translation up- -- Extract the delta and add it to skip_row.- then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns remain_rows- -- Translation down- -- Pad the start of lines and above the image with a- -- background_fill image- else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns remain_rows- where- dw = toEnum $ abs dx- dh = toEnum $ abs dy- ow = image_width image- ih = image_height i- ImageCrop (max_w,max_h) i ->- row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows $ fromEnum max_h)- ImagePad (min_w,min_h) i -> do- let hpad = if image_width i < min_w- then background_fill (min_w - image_width i) (image_height i)- else empty_image- let vpad = if image_height i < min_h- then background_fill (image_width i) (min_h - image_height i)- else empty_image- row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns remain_rows+-- | The number of rows the DisplayOps are defined for.+displayOpsRows :: DisplayOps -> Int+displayOpsRows = Vector.length -snoc_text_span :: Attr -- the display attributes of the text span- -> DisplayString -- the text to output- -> MRowOps s -- the display operations to add to- -> Word -- the number of display columns in the text span to - -- skip before outputting- -> Int -- the row of the display operations to add to- -> Word -- the number of columns from the next column to be - -- defined to the end of the display for the row.- -> ST s Word-snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do- {-# SCC "snoc_text_span-pre" #-} snoc_op mrow_ops y $! AttributeChange a- -- At most a text span will consist of remaining_columns characters- -- we keep track of the position of the next character.- let max_len :: Int = fromEnum remaining_columns- mspan_chars <- Vector.new max_len- ( used_display_columns, display_columns_skipped, used_char_count ) - <- {-# SCC "snoc_text_span-foldlM" #-} Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str- -- once all characters have been output to mspan_chars we grab the used head - out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars- -- convert to UTF8 bytestring.- -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold- -- contained in fromString with the unfold in toList. No biggy right now then.- {-# SCC "snoc_text_span-post" #-} snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count)- $! UTF8.fromString - $! Vector.toList out_text- return $ columns_to_skip - display_columns_skipped- where- build_text_span mspan_chars (!used_display_columns, !display_columns_skipped, !used_char_count) - (out_char, char_display_width) = {-# SCC "build_text_span" #-}- -- Only valid if the maximum width of a character is 2 display columns.- -- XXX: Optimize into a skip pass then clipped fill pass- if display_columns_skipped == columns_to_skip- then if used_display_columns == remaining_columns- then return $! ( used_display_columns, display_columns_skipped, used_char_count )- else if ( used_display_columns + char_display_width ) > remaining_columns- then do- Vector.unsafeWrite mspan_chars used_char_count '…'- return $! ( used_display_columns + 1- , display_columns_skipped- , used_char_count + 1- )- else do- Vector.unsafeWrite mspan_chars used_char_count out_char- return $! ( used_display_columns + char_display_width- , display_columns_skipped- , used_char_count + 1- )- else if (display_columns_skipped + char_display_width) > columns_to_skip- then do- Vector.unsafeWrite mspan_chars used_char_count '…'- return $! ( used_display_columns + 1- , columns_to_skip- , used_char_count + 1- )- else return $ ( used_display_columns- , display_columns_skipped + char_display_width- , used_char_count- )+affectedRegion :: DisplayOps -> DisplayRegion+affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) --- | Add a background fill of the given column width to the row display operations.------ This has a fast path for background characters that are a single column and a single byte.--- Otherwise this has to compute the width of the background character and replicate a sequence of--- bytes to fill in the required width.-snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s ()-snoc_bg_fill _row_ops _bg 0 _row - = return ()-snoc_bg_fill mrow_ops (Background c back_attr) fill_length row - = do- snoc_op mrow_ops row $ AttributeChange back_attr- -- By all likelyhood the background character will be an ASCII character. Which is a single- -- byte in utf8. Optimize for this special case.- utf8_bs <- if c <= (toEnum 255 :: Char)- then- let !(c_byte :: Word8) = BInt.c2w c- in unsafeIOToST $ do- BInt.create ( fromEnum fill_length ) - $ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte)- [0 .. fromEnum (fill_length - 1)]- else - let !(c_bytes :: [Word8]) = encode [c]- in unsafeIOToST $ do- BInt.create (fromEnum fill_length * length c_bytes) - $ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b)- $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)- snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)+-- | The number of columns a SpanOps affects.+spanOpsAffectedColumns :: SpanOps -> Int+spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps+ where+ spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w+ spanOpsAffectedColumns' t (Skip w) = t + w+ spanOpsAffectedColumns' t (RowEnd w) = t + w --- | snocs the operation to the operations for the given row.-snoc_op :: MRowOps s -> Int -> SpanOp -> ST s ()-snoc_op !mrow_ops !row !op = do- ops <- Vector.read mrow_ops row- let ops' = Vector.snoc ops op- Vector.write mrow_ops row ops'+-- | The width of a single SpanOp in columns.+spanOpHasWidth :: SpanOp -> Maybe (Int, Int)+spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)+spanOpHasWidth (Skip ow) = Just (ow,ow)+spanOpHasWidth (RowEnd ow) = Just (ow,ow) +-- | The number of columns to the character at the given position in the+-- span op.+columnsToCharOffset :: Int -> SpanOp -> Int+columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =+ wctlwidth (TL.take (fromIntegral cx) utf8Str)+columnsToCharOffset cx (Skip _) = cx+columnsToCharOffset cx (RowEnd _) = cx
− src/Graphics/Vty/Terminal.hs
@@ -1,137 +0,0 @@--- | Generic Terminal interface.------ Defines the common interface supported by all terminals.------ See also:------ 1. Graphics.Vty.Terminal: This instantiates an abtract interface to the terminal interface based--- on the TERM and COLORTERM environment variables. --- --- 2. Graphics.Vty.Terminal.Generic: Defines the generic interface all terminals need to implement.------ 3. Graphics.Vty.Terminal.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.--- I don't know a way to reliably determine if that is required or how to do so.------ 4. Graphics.Vty.Terminal.XTermColor: This module contains an interface suitable for xterm-like--- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many--- control codes as possible. ------ Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE ScopedTypeVariables #-}-module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal- , Terminal(..)- , TerminalHandle(..)- , DisplayHandle(..)- , output_picture- , display_context- )- where---import Graphics.Vty.Terminal.Generic-import Graphics.Vty.Terminal.MacOSX as MacOSX-import Graphics.Vty.Terminal.XTermColor as XTermColor-import Graphics.Vty.Terminal.TerminfoBased as TerminfoBased--import Control.Applicative-import Control.Exception ( SomeException, try )-import Control.Monad.Trans--import Data.List ( isPrefixOf )-import Data.Word--import System.Environment---- | Returns a TerminalHandle (an abstract Terminal instance) for the current terminal.------ The specific Terminal 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. This is why platforms without terminfo--- are not supported. However, as mentioned before, any specifics about it being based on terminfo--- are hidden from the API user. If a terminal implementation is developed for a terminal for a--- platform without terminfo support then Vty should work as expected on that terminal.------ Selection of a terminal is done as follows:------ * If TERM == xterm--- then the terminal might be one of the Mac OS X .app terminals. Check if that might be--- the case and use MacOSX if so.--- otherwise use XTermColor.------ * for any other TERM value TerminfoBased is used.--------- The terminal has to be determined dynamically at runtime. To satisfy this requirement all--- terminals instances are lifted into an abstract terminal handle via existential qualification.--- This implies that the only equations that can used are those in the terminal class.------ To differentiate between Mac OS X terminals this uses the TERM_PROGRAM environment variable.--- However, an xterm started by Terminal or iTerm *also* has TERM_PROGRAM defined since the--- environment variable is not reset/cleared by xterm. However a Terminal.app or iTerm.app started--- from an xterm under X11 on mac os x will likely be done via open. Since this does not propogate--- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true--- Terminal.app or iTerm.app session.--------- The file descriptor used for output will a duplicate of the current stdout file descriptor.------ todo: add an implementation for windows that does not depend on terminfo. Should be installable--- with only what is provided in the haskell platform.------ todo: The Terminal interface does not provide any input support.-terminal_handle :: ( Applicative m, MonadIO m ) => m TerminalHandle-terminal_handle = do- term_type <- liftIO $ getEnv "TERM"- t <- if "xterm" `isPrefixOf` term_type- then do- maybe_terminal_app <- get_env "TERM_PROGRAM"- case maybe_terminal_app of- Nothing - -> XTermColor.terminal_instance term_type >>= new_terminal_handle- Just v | v == "Apple_Terminal" || v == "iTerm.app" - -> do- maybe_xterm <- get_env "XTERM_VERSION"- case maybe_xterm of- Nothing -> MacOSX.terminal_instance v >>= new_terminal_handle- Just _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle- -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app- -- like terminal?- _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle- -- Not an xterm-like terminal. try for generic terminfo.- else TerminfoBased.terminal_instance term_type >>= new_terminal_handle- return t- where- get_env var = do- mv <- liftIO $ try $ getEnv var- case mv of- Left (_e :: SomeException) -> return $ Nothing- Right v -> return $ Just v---- | Sets the cursor position to the given output column and row. ------ This is not necessarially the same as the character position with the same coordinates.--- Characters can be a variable number of columns in width.------ Currently, the only way to set the cursor position to a given character coordinate is to specify--- the coordinate in the Picture instance provided to output_picture or refresh.-set_cursor_pos :: MonadIO m => TerminalHandle -> Word -> Word -> m ()-set_cursor_pos t x y = do- bounds <- display_bounds t- d <- display_context t bounds- liftIO $ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y)---- | Hides the cursor-hide_cursor :: MonadIO m => TerminalHandle -> m ()-hide_cursor t = do- bounds <- display_bounds t- d <- display_context t bounds- liftIO $ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d) - --- | Shows the cursor-show_cursor :: MonadIO m => TerminalHandle -> m ()-show_cursor t = do- bounds <- display_bounds t- d <- display_context t bounds- liftIO $ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d) -
− src/Graphics/Vty/Terminal/Debug.hs
@@ -1,121 +0,0 @@--- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-module Graphics.Vty.Terminal.Debug ( DebugTerminal(..)- , DebugDisplay(..)- , terminal_instance- , dehandle- )- where--import Graphics.Vty.DisplayRegion-import Graphics.Vty.Terminal.Generic--import Control.Applicative-import Control.Monad.Trans-import Control.Monad.State.Strict--import qualified Data.ByteString.UTF8 as BS-import qualified Data.ByteString as BSCore-import Data.IORef-import qualified Data.Sequence as Seq-import qualified Data.String.UTF8 as UTF8-import Data.Word--import Foreign.Marshal.Array ( peekArray )-import Foreign.Ptr ( plusPtr )-import Foreign.Storable ( poke )--import System.IO--import Unsafe.Coerce---- | The debug display terminal produces a string representation of the requested picture. There is--- *not* an isomorphism between the string representation and the picture. The string--- representation is a simplification of the picture that is only useful in debugging VTY without--- considering terminal specific issues.------ The debug implementation is useful in manually determining if the sequence of terminal operations--- matches the expected sequence. So requirement of the produced representation is simplicity in--- parsing the text representation and determining how the picture was mapped to terminal--- operations.------ All terminals support the operations specified in the Terminal class defined in--- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad--- class there exists a monoid that defines it's algebra. The string representation is a sequence of--- identifiers where each identifier is the name of an operation in the algebra.--data DebugTerminal = DebugTerminal- { debug_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString)- , debug_terminal_bounds :: DisplayRegion- } --instance Terminal DebugTerminal where- terminal_ID _t = "debug_terminal"- release_terminal _t = return ()- reserve_display _t = return ()- release_display _t = return ()- display_bounds t = return $ debug_terminal_bounds t- display_terminal_instance t r c = return $ c (DebugDisplay r)- output_byte_buffer t out_buffer buffer_size - = liftIO $ do- putStrLn $ "output_byte_buffer ?? " ++ show buffer_size- peekArray (fromEnum buffer_size) out_buffer - >>= return . UTF8.fromRep . BSCore.pack- >>= writeIORef (debug_terminal_last_output t)-- output_handle t = return stdout--data DebugDisplay = DebugDisplay- { debug_display_bounds :: DisplayRegion- } --terminal_instance :: ( Applicative m, MonadIO m ) => DisplayRegion -> m TerminalHandle-terminal_instance r = do- output_ref <- liftIO $ newIORef undefined- new_terminal_handle $ DebugTerminal output_ref r--dehandle :: TerminalHandle -> DebugTerminal-dehandle (TerminalHandle t _) = unsafeCoerce t--instance DisplayTerminal DebugDisplay where- -- | Provide the current bounds of the output terminal.- context_region d = debug_display_bounds d-- -- | A cursor move is always visualized as the single character 'M'- move_cursor_required_bytes _d _x _y = 1-- -- | A cursor move is always visualized as the single character 'M'- serialize_move_cursor _d _x _y ptr = do- liftIO $ poke ptr (toEnum $ fromEnum 'M') - return $ ptr `plusPtr` 1-- -- | Show cursor is always visualized as the single character 'S'- show_cursor_required_bytes _d = 1-- -- | Show cursor is always visualized as the single character 'S'- serialize_show_cursor _d ptr = do- liftIO $ poke ptr (toEnum $ fromEnum 'S') - return $ ptr `plusPtr` 1-- -- | Hide cursor is always visualized as the single character 'H'- hide_cursor_required_bytes _d = 1-- -- | Hide cursor is always visualized as the single character 'H'- serialize_hide_cursor _d ptr = do- liftIO $ poke ptr (toEnum $ fromEnum 'H') - return $ ptr `plusPtr` 1-- -- | An attr change is always visualized as the single character 'A'- attr_required_bytes _d _fattr _diffs _attr = 1-- -- | An attr change is always visualized as the single character 'A'- serialize_set_attr _d _fattr _diffs _attr ptr = do- liftIO $ poke ptr (toEnum $ fromEnum 'A')- return $ ptr `plusPtr` 1-- default_attr_required_bytes _d = 1- serialize_default_attr _d ptr = do- liftIO $ poke ptr (toEnum $ fromEnum 'D')- return $ ptr `plusPtr` 1-
− src/Graphics/Vty/Terminal/Generic.hs
@@ -1,417 +0,0 @@--- Copyright 2009-2011 Corey O'Connor-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic- , OutputBuffer- )- where--import Data.Marshalling--import Graphics.Vty.Picture-import Graphics.Vty.Span-import Graphics.Vty.DisplayRegion--import Graphics.Vty.DisplayAttributes--import Control.Monad ( liftM )-import Control.Monad.Trans--import qualified Data.ByteString.Internal as BSCore-import Data.IORef-import Data.String.UTF8 hiding ( foldl )-import qualified Data.Vector as Vector --import System.IO---- | An handle to a terminal that hides the implementation.-data TerminalHandle where- TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle--state_ref :: TerminalHandle -> IORef TerminalState-state_ref (TerminalHandle _ s_ref) = s_ref--new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle-new_terminal_handle t = do- s_ref <- liftIO $ newIORef initial_terminal_state- return $ TerminalHandle t s_ref---- | The current terminal state. This may not exactly be known.-data TerminalState = TerminalState- { known_fattr :: Maybe FixedAttr- }---- | Initially we know nothing about a terminal's state.-initial_terminal_state :: TerminalState-initial_terminal_state = TerminalState Nothing--class Terminal t where- -- | Text identifier for the terminal. Used for debugging.- terminal_ID :: t -> String- -- | - release_terminal :: MonadIO m => t -> m ()- -- | Clear the display and initialize the terminal to some initial display state. - --- -- The expectation of a program is that the display starts in some initial state. - -- The initial state would consist of fixed values:- -- - cursor at top left- -- - UTF-8 character encoding- -- - drawing characteristics are the default- -- The abstract operation I think all these behaviors are instances of is reserving exclusive- -- access to a display such that:- -- - The previous state cannot be determined- -- - When exclusive access to a display is release the display returns to the previous state.- reserve_display :: MonadIO m => t -> m ()-- -- | Return the display to the state before reserve_display- -- If no previous state then set the display state to the initial state.- release_display :: MonadIO m => t -> m ()- - -- | Returns the current display bounds.- display_bounds :: MonadIO m => t -> m DisplayRegion-- -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle- -- constructor.- display_terminal_instance :: MonadIO m - => t - -> DisplayRegion - -> (forall d. DisplayTerminal d => d -> DisplayHandle) - -> m DisplayHandle-- -- | Output the byte buffer of the specified size to the terminal device. The size is equal to- -- end_ptr - start_ptr- output_byte_buffer :: t -> OutputBuffer -> Word -> IO ()-- -- | Handle of output device- output_handle :: t -> IO Handle--instance Terminal TerminalHandle where- terminal_ID (TerminalHandle t _) = terminal_ID t- release_terminal (TerminalHandle t _) = release_terminal t- reserve_display (TerminalHandle t _) = reserve_display t- release_display (TerminalHandle t _) = release_display t- display_bounds (TerminalHandle t _) = display_bounds t- display_terminal_instance (TerminalHandle t _) = display_terminal_instance t- output_byte_buffer (TerminalHandle t _) = output_byte_buffer t- output_handle (TerminalHandle t _) = output_handle t--data DisplayHandle where- DisplayHandle :: forall d . DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle---- | 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 display_width provided_width, max display_height provided_height)-display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle-display_context t b = do- s <- initial_display_state- display_terminal_instance t b (\ d -> DisplayHandle d t s)--data DisplayState = DisplayState- { previous_output_ref :: IORef (Maybe DisplayOps)- }--initial_display_state :: MonadIO m => m DisplayState-initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing--class DisplayTerminal d where- -- | Provide the bounds of the display context. - context_region :: d -> DisplayRegion-- -- | Maximum number of colors supported by the context.- context_color_count :: d -> Word-- -- | 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.- move_cursor_required_bytes :: d -> Word -> Word -> Word- serialize_move_cursor :: MonadIO m => d -> Word -> Word -> OutputBuffer -> m OutputBuffer-- show_cursor_required_bytes :: d -> Word- serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer-- hide_cursor_required_bytes :: d -> Word- serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer-- -- | Assure 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 seperate 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.- attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Word- serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer-- -- | Reset the display attributes to the default display attributes- default_attr_required_bytes :: d -> Word- serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer-- -- | See Graphics.Vty.Terminal.XTermColor.inline_hack- inline_hack :: MonadIO m => d -> m ()- inline_hack _d = return ()---instance DisplayTerminal DisplayHandle where- context_region (DisplayHandle d _ _) = context_region d- context_color_count (DisplayHandle d _ _) = context_color_count d- move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d- serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d- show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d- serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d- hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d- serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d- attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d- serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d- default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d- serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d- inline_hack (DisplayHandle d _ _) = inline_hack d - --- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.-utf8_text_required_bytes :: UTF8 BSCore.ByteString -> Word-utf8_text_required_bytes str =- let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str)- in toEnum src_bytes_length---- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.-serialize_utf8_text :: MonadIO m => UTF8 BSCore.ByteString -> OutputBuffer -> m OutputBuffer-serialize_utf8_text str dest_ptr = - let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str)- in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do- let src_ptr' = src_ptr `plusPtr` src_ptr_offset- BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length) - return (dest_ptr `plusPtr` src_bytes_length)----- | Displays the given `Picture`.------ 0. The image is cropped to the display size. ------ 1. Converted into a sequence of attribute changes and text spans.--- --- 2. The cursor is hidden.------ 3. Serialized to the display.------ 4. The cursor is then shown and positioned or kept hidden.------ --- todo: specify possible IO exceptions.--- abstract from IO monad to a MonadIO instance.-output_picture :: MonadIO m => DisplayHandle -> Picture -> m ()-output_picture (DisplayHandle d t s) pic = do- let !r = context_region d- let !ops = spans_for_pic pic r- let !initial_attr = FixedAttr default_style_mask Nothing Nothing- -- Diff the previous output against the requested output. Differences are currently on a per-row- -- basis.- diffs :: [Bool]- <- liftIO ( readIORef (previous_output_ref s) )- >>= \mprevious_ops -> case mprevious_ops of- Nothing - -> return $ replicate ( fromEnum $ region_height $ effected_region ops ) - True- Just previous_ops - -> if effected_region previous_ops /= effected_region ops- then return $ replicate ( fromEnum $ region_height $ effected_region ops ) - True- else return $ zipWith (/=) ( Vector.toList $ display_ops previous_ops ) - ( Vector.toList $ display_ops ops )-- -- determine the number of bytes required to completely serialize the output ops.- let total = hide_cursor_required_bytes d - + default_attr_required_bytes d- + required_bytes d initial_attr diffs ops - + case pic_cursor pic of- NoCursor -> 0- Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic- ( ox, oy ) = char_to_output_pos m ( x, y )- in show_cursor_required_bytes d- + move_cursor_required_bytes d ox oy-- -- ... then serialize- liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do- ptr <- serialize_hide_cursor d start_ptr- ptr' <- serialize_default_attr d ptr- ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops- end_ptr <- case pic_cursor pic of- NoCursor -> return ptr''- Cursor x y -> do- let m = cursor_output_map ops $ pic_cursor pic- (ox, oy) = char_to_output_pos m (x,y)- serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy- -- todo: How to handle exceptions?- case end_ptr `minusPtr` start_ptr of- count | count < 0 -> fail "End pointer before start of buffer."- | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total)- | otherwise -> output_byte_buffer t start_ptr (toEnum count)- -- Cache the output spans.- liftIO $ writeIORef (previous_output_ref s) (Just ops)- return ()--required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Word-required_bytes d in_fattr diffs ops = - let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops )- in n- where - required_bytes' (y, current_sum, fattr, True : diffs') span_ops- = let (s, fattr') = span_ops_required_bytes d y fattr span_ops - in ( y + 1, s + current_sum, fattr', diffs' )- required_bytes' (y, current_sum, fattr, False : diffs') _span_ops- = ( y + 1, current_sum, fattr, diffs' )- required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops- = error "shouldn't be possible"--span_ops_required_bytes :: DisplayTerminal d => d -> Word -> FixedAttr -> SpanOps -> (Word, FixedAttr)-span_ops_required_bytes d y in_fattr span_ops = - -- The first operation is to set the cursor to the start of the row- let header_required_bytes = move_cursor_required_bytes d 0 y- -- then the span ops are serialized in the order specified- in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op - in (c + current_sum, fattr') - ) - (header_required_bytes, in_fattr)- span_ops--span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)-span_op_required_bytes d fattr (AttributeChange attr) = - let attr' = limit_attr_for_display d attr- diffs = display_attr_diffs fattr fattr'- c = attr_required_bytes d fattr attr' diffs- fattr' = fix_display_attr fattr attr'- in (c, fattr')-span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)--serialize_output_ops :: ( MonadIO m, DisplayTerminal d )- => d - -> OutputBuffer - -> FixedAttr - -> [Bool]- -> DisplayOps - -> m OutputBuffer-serialize_output_ops d start_ptr in_fattr diffs ops = do- (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops' - ( 0, start_ptr, in_fattr, diffs ) - ( display_ops ops )- return end_ptr- where - serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops- = serialize_span_ops d y out_ptr fattr span_ops - >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )- serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops- = return ( y + 1, out_ptr, fattr, diffs' )- serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops- = error "shouldn't be possible"--serialize_span_ops :: ( MonadIO m, DisplayTerminal d )- => d - -> Word - -> OutputBuffer - -> FixedAttr - -> SpanOps - -> m (OutputBuffer, FixedAttr)-serialize_span_ops d y out_ptr in_fattr span_ops = do- -- The first operation is to set the cursor to the start of the row- out_ptr' <- serialize_move_cursor d 0 y out_ptr- -- then the span ops are serialized in the order specified- Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr ) - (out_ptr', in_fattr)- span_ops--serialize_span_op :: ( MonadIO m, DisplayTerminal d )- => d - -> SpanOp - -> OutputBuffer - -> FixedAttr- -> m (OutputBuffer, FixedAttr)-serialize_span_op d (AttributeChange attr) out_ptr fattr = do- let attr' = limit_attr_for_display d attr- fattr' = fix_display_attr fattr attr'- diffs = display_attr_diffs fattr fattr'- out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr- return (out_ptr', fattr')-serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do- out_ptr' <- serialize_utf8_text str out_ptr- return (out_ptr', fattr)--marshall_to_terminal :: ( Terminal t )- => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()-marshall_to_terminal t c f = do- start_ptr <- mallocBytes (fromEnum c)- -- - -- todo: capture exceptions?- end_ptr <- f start_ptr- case end_ptr `minusPtr` start_ptr of- count | count < 0 -> fail "End pointer before start pointer."- | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)- | otherwise -> output_byte_buffer t start_ptr (toEnum count)- free start_ptr- return ()---- | 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- { char_to_output_pos :: (Word, Word) -> (Word, Word)- } --cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap-cursor_output_map span_ops _cursor = CursorOutputMap- { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)- }--cursor_column_offset :: DisplayOps -> Word -> Word -> Word-cursor_column_offset span_ops cx cy =- let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy)- (out_offset, _, _) - = Vector.foldl' ( \(d, current_cx, done) op -> - if done then (d, current_cx, done) else case span_op_has_width op of- Nothing -> (d, current_cx, False)- Just (cw, ow) -> case compare cx (current_cx + cw) of- GT -> ( d + ow- , current_cx + cw- , False - )- EQ -> ( d + ow- , current_cx + cw- , True - )- LT -> ( d + columns_to_char_offset (cx - current_cx) op- , current_cx + cw- , True- )- )- (0, 0, False)- cursor_row_ops- in out_offset---- | Not all terminals support all display attributes. This filters a display attribute to what the--- given terminal can display.-limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr-limit_attr_for_display d attr - = attr { attr_fore_color = clamp_color $ attr_fore_color attr- , attr_back_color = clamp_color $ attr_back_color attr- }- where- clamp_color Default = Default- clamp_color KeepCurrent = KeepCurrent- clamp_color (SetTo c) = clamp_color' c- clamp_color' (ISOColor v) - | context_color_count d < 8 = Default- | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)- | otherwise = SetTo $ ISOColor v- clamp_color' (Color240 v)- -- TODO: Choose closes ISO color?- | context_color_count d < 8 = Default- | context_color_count d < 16 = Default- | context_color_count d == 240 = SetTo $ Color240 v- | otherwise - = let p :: Double = fromIntegral v / 240.0 - v' = floor $ p * (fromIntegral $ context_color_count d)- in SetTo $ Color240 v'-
− src/Graphics/Vty/Terminal/MacOSX.hs
@@ -1,102 +0,0 @@--- Copyright 2009-2010 Corey O'Connor--- The standard Mac OS X terminals Terminal.app and iTerm both declare themselves to be--- "xterm-color" by default. However the terminfo database for xterm-color included with OS X is--- incomplete. ------ This terminal implementation modifies the standard terminfo terminal as required for complete OS--- X support.-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-module Graphics.Vty.Terminal.MacOSX ( terminal_instance- )- where--import Graphics.Vty.Terminal.Generic-import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased--import Control.Applicative-import Control.Monad.Trans--import System.IO---- | A Mac terminal is assumed to be an xterm based terminal.-data Term = Term - { super_term :: TerminalHandle- , term_app :: String- }---- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier--- "xterm-256color" is used.------ This effects the terminfo lookup.-terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term-terminal_instance v = do- let base_term "iTerm.app" = "xterm-256color"- base_term _ = "xterm"- t <- TerminfoBased.terminal_instance (base_term v) >>= new_terminal_handle- return $ Term t v--flushed_put :: MonadIO m => String -> m ()-flushed_put str = do- liftIO $ hPutStr stdout str- liftIO $ hFlush stdout---- | Terminal.app requires the xterm-color smcup and rmcup caps. Not the generic xterm ones.--- Otherwise, Terminal.app expects the xterm caps.-smcup_str, rmcup_str :: String-smcup_str = "\ESC7\ESC[?47h"-rmcup_str = "\ESC[2J\ESC[?47l\ESC8"---- | iTerm needs a clear screen after smcup as well.-clear_screen_str :: String-clear_screen_str = "\ESC[H\ESC[2J"--instance Terminal Term where- terminal_ID t = term_app t ++ " :: MacOSX"-- release_terminal t = do - release_terminal $ super_term t-- reserve_display _t = do- flushed_put smcup_str- flushed_put clear_screen_str-- release_display _t = do- flushed_put rmcup_str-- display_terminal_instance t b c = do- d <- display_context (super_term t) b- return $ c (DisplayContext d)-- display_bounds t = display_bounds (super_term t)- - output_byte_buffer t = output_byte_buffer (super_term t)-- output_handle t = output_handle (super_term t)--data DisplayContext = DisplayContext- { super_display :: DisplayHandle- }--instance DisplayTerminal DisplayContext where- context_region d = context_region (super_display d)- context_color_count d = context_color_count (super_display d)-- move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)- serialize_move_cursor d = serialize_move_cursor (super_display d)-- show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)- serialize_show_cursor d = serialize_show_cursor (super_display d)-- hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)- serialize_hide_cursor d = serialize_hide_cursor (super_display d)-- attr_required_bytes d = attr_required_bytes (super_display d)- serialize_set_attr d = serialize_set_attr (super_display d)-- default_attr_required_bytes d = default_attr_required_bytes (super_display d)- serialize_default_attr d = serialize_default_attr (super_display d)-
− src/Graphics/Vty/Terminal/TerminfoBased.hs
@@ -1,437 +0,0 @@--- Copyright Corey O'Connor (coreyoconnor@gmail.com)-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}-module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance- )- where--import Data.Terminfo.Parse-import Data.Terminfo.Eval--import Graphics.Vty.Attributes-import Graphics.Vty.DisplayAttributes-import Graphics.Vty.Terminal.Generic-import Graphics.Vty.DisplayRegion--import Control.Applicative -import Control.Monad ( foldM )-import Control.Monad.Trans--import Data.Bits ( (.&.) )-import Data.Maybe ( isJust, isNothing, fromJust )-import Data.Word--import Foreign.C.Types ( CLong(..) )--import GHC.IO.Handle--import qualified System.Console.Terminfo as Terminfo-import System.IO--data Term = Term - { term_info_ID :: String- , term_info :: Terminfo.Terminal- , smcup :: Maybe CapExpression- , rmcup :: Maybe CapExpression- , cup :: CapExpression- , cnorm :: CapExpression- , civis :: CapExpression- , set_fore_color :: CapExpression- , set_back_color :: CapExpression- , set_default_attr :: CapExpression- , clear_screen :: CapExpression- , display_attr_caps :: DisplayAttrCaps- , term_handle :: Handle- }--data DisplayAttrCaps = DisplayAttrCaps- { set_attr_states :: Maybe CapExpression- , enter_standout :: Maybe CapExpression- , exit_standout :: Maybe CapExpression- , enter_underline :: Maybe CapExpression- , exit_underline :: Maybe CapExpression- , enter_reverse_video :: Maybe CapExpression- , enter_dim_mode :: Maybe CapExpression- , enter_bold_mode :: Maybe CapExpression- }- -marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()-marshall_cap_to_terminal t cap_selector cap_params = do- marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )- ( serialize_cap_expression (cap_selector t) cap_params )- return ()--{- | 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:- - * determine the character encoding supported by the terminal. Should this be taken from the LANG- - environment variable? - - * Provide independent string capabilities for all display attributes.- -- - - - todo: Some display attributes like underline and bold have independent string capabilities that- - should be used instead of the generic "sgr" string capability.- -}-terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term-terminal_instance in_ID = do- ti <- liftIO $ Terminfo.setupTerm in_ID- let require_cap str - = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of- Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""- Just cap_str -> do- parse_result <- parse_cap_expression cap_str - case parse_result of - Left e -> fail $ show e- Right cap -> return cap- probe_cap cap_name - = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of- Nothing -> return Nothing- Just cap_str -> do- parse_result <- parse_cap_expression cap_str- case parse_result of- Left e -> fail $ show e- Right cap -> return $ Just cap- the_handle <- liftIO $ hDuplicate stdout- pure Term- <*> pure in_ID- <*> pure ti- <*> probe_cap "smcup"- <*> probe_cap "rmcup"- <*> require_cap "cup"- <*> require_cap "cnorm"- <*> require_cap "civis"- <*> require_cap "setaf"- <*> require_cap "setab"- <*> require_cap "sgr0"- <*> require_cap "clear"- <*> current_display_attr_caps ti- <*> pure the_handle--current_display_attr_caps :: ( Applicative m, MonadIO m ) - => Terminfo.Terminal - -> m DisplayAttrCaps-current_display_attr_caps ti - = pure DisplayAttrCaps - <*> probe_cap "sgr"- <*> probe_cap "smso"- <*> probe_cap "rmso"- <*> probe_cap "smul"- <*> probe_cap "rmul"- <*> probe_cap "rev"- <*> probe_cap "dim"- <*> probe_cap "bold"- where probe_cap cap_name - = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of- Nothing -> return Nothing- Just cap_str -> do- parse_result <- parse_cap_expression cap_str- case parse_result of- Left e -> fail $ show e- Right cap -> return $ Just cap--instance Terminal Term where- terminal_ID t = term_info_ID t ++ " :: TerminfoBased"-- release_terminal t = liftIO $ do- marshall_cap_to_terminal t set_default_attr []- marshall_cap_to_terminal t cnorm []- hClose $ term_handle t- return ()-- reserve_display t = liftIO $ do- if (isJust $ smcup t)- then marshall_cap_to_terminal t (fromJust . smcup) []- else return ()- -- Screen on OS X does not appear to support smcup?- -- To approximate the expected behavior: clear the screen and then move the mouse to the- -- home position.- hFlush stdout- marshall_cap_to_terminal t clear_screen []- return ()-- release_display t = liftIO $ do- if (isJust $ rmcup t)- then marshall_cap_to_terminal t (fromJust . rmcup) []- else return ()- marshall_cap_to_terminal t cnorm []- return ()-- display_terminal_instance t b c = do- let color_count - = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of- Nothing -> 8- Just v -> toEnum v- return $ c (DisplayContext b t color_count)-- display_bounds _t = do- raw_size <- liftIO $ get_window_size- case raw_size of- ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size- | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)-- -- | Output the byte buffer of the specified size to the terminal device.- output_byte_buffer t out_ptr out_byte_count = do- -- if the out fd is actually the same as stdout's then a- -- flush is required *before* the c_output_byte_buffer call- -- otherwise there may still be data in GHC's internal stdout buffer.- -- _ <- handleToFd stdout- hPutBuf (term_handle t) out_ptr (fromEnum out_byte_count)- hFlush (term_handle t)-- output_handle t = return (term_handle t)--foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size - :: IO CLong--get_window_size :: IO (Int,Int)-get_window_size = do - (a,b) <- (`divMod` 65536) `fmap` c_get_window_size- return (fromIntegral b, fromIntegral a)--data DisplayContext = DisplayContext- { bounds :: DisplayRegion- , term :: Term- , supported_colors :: Word- }--instance DisplayTerminal DisplayContext where- context_region d = bounds d-- context_color_count d = supported_colors d-- move_cursor_required_bytes d x y - = cap_expression_required_bytes (cup $ term d) [y, x]- serialize_move_cursor d x y out_ptr - = liftIO $ serialize_cap_expression (cup $ term d) [y, x] out_ptr-- show_cursor_required_bytes d - = cap_expression_required_bytes (cnorm $ term d) []- serialize_show_cursor d out_ptr - = liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr-- hide_cursor_required_bytes d - = cap_expression_required_bytes (civis $ term d) []- serialize_hide_cursor d out_ptr - = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr-- -- | Instead of evaluating all the rules related to setting display attributes twice (once in- -- required bytes and again in serialize) or some memoization scheme just return a size- -- requirement as big the longest possible control string.- -- - -- Which is assumed to the be less than 512 for now. - --- -- \todo Not verified as safe and wastes memory.- attr_required_bytes _d _prev_attr _req_attr _diffs = 512-- -- | 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.- serialize_set_attr d prev_attr req_attr diffs out_ptr = do- case (fore_color_diff diffs == ColorToDefault) || (back_color_diff 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 req_display_cap_seq_for ( display_attr_caps $ term d )- ( fixed_style attr )- ( style_to_apply_seq $ fixed_style attr )- of- EnterExitSeq caps - -- only way to reset a color to the defaults- -> serialize_default_attr d out_ptr- >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)- >>= set_colors- SetState state- -- implicitly resets the colors to the defaults- -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states - $ display_attr_caps - $ term d - )- ( sgr_args_for_state state )- out_ptr- >>= set_colors- -- 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 req_display_cap_seq_for ( display_attr_caps $ term d )- ( fixed_style attr )- ( style_diffs 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 - -> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps )- >>= apply_color_diff set_fore_color ( fore_color_diff diffs )- >>= apply_color_diff set_back_color ( back_color_diff diffs )- SetState state- -- implicitly resets the colors to the defaults- -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states - $ display_attr_caps- $ term d- )- ( sgr_args_for_state state )- out_ptr- >>= set_colors- where - attr = fix_display_attr prev_attr req_attr- set_colors ptr = do- ptr' <- case fixed_fore_color attr of- Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d ) - [ ansi_color_index c ]- ptr- Nothing -> return ptr- ptr'' <- case fixed_back_color attr of- Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d ) - [ ansi_color_index c ]- ptr'- Nothing -> return ptr'- return ptr''- apply_color_diff _f NoColorChange ptr- = return ptr- apply_color_diff _f ColorToDefault _ptr- = fail "ColorToDefault is not a possible case for apply_color_diffs"- apply_color_diff f ( SetColor c ) ptr- = liftIO $ serialize_cap_expression ( f $ term d ) - [ ansi_color_index c ]- ptr-- default_attr_required_bytes d - = cap_expression_required_bytes (set_default_attr $ term d) []- serialize_default_attr d out_ptr = do- liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr---- | 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.-ansi_color_index :: Color -> Word-ansi_color_index (ISOColor v) = toEnum $ fromEnum v-ansi_color_index (Color240 v) = 16 + ( toEnum $ 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- { apply_standout :: Bool- , apply_underline :: Bool- , apply_reverse_video :: Bool- , apply_blink :: Bool- , apply_dim :: Bool- , apply_bold :: Bool- }--sgr_args_for_state :: DisplayAttrState -> [CapParam]-sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)- [ apply_standout attr_state- , apply_underline attr_state- , apply_reverse_video attr_state- , apply_blink attr_state- , apply_dim attr_state- , apply_bold attr_state- , False -- invis- , False -- protect- , False -- alt char set- ]--req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq-req_display_cap_seq_for 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 no_enter_exit_cap diffs, isJust $ set_attr_states caps) of- -- If all the diffs have an enter-exit cap then just use those- ( False, _ ) -> EnterExitSeq $ map enter_exit_cap 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 enter_exit_cap - $ filter (not . no_enter_exit_cap) 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 $ state_for_style s- where- no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps- no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps- no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps- no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps- no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps- no_enter_exit_cap RemoveReverseVideo = True- no_enter_exit_cap ApplyBlink = True- no_enter_exit_cap RemoveBlink = True- no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps- no_enter_exit_cap RemoveDim = True- no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps- no_enter_exit_cap RemoveBold = True- enter_exit_cap ApplyStandout = fromJust $ enter_standout caps- enter_exit_cap RemoveStandout = fromJust $ exit_standout caps- enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps- enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps- enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps- enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps- enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps- enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."--state_for_style :: Style -> DisplayAttrState-state_for_style s = DisplayAttrState- { apply_standout = is_style_set standout- , apply_underline = is_style_set underline- , apply_reverse_video = is_style_set reverse_video- , apply_blink = is_style_set blink- , apply_dim = is_style_set dim- , apply_bold = is_style_set bold- }- where is_style_set = has_style s--style_to_apply_seq :: Style -> [StyleStateChange]-style_to_apply_seq s = concat- [ apply_if_required ApplyStandout standout- , apply_if_required ApplyUnderline underline- , apply_if_required ApplyReverseVideo reverse_video- , apply_if_required ApplyBlink blink- , apply_if_required ApplyDim dim- , apply_if_required ApplyBlink bold- ]- where - apply_if_required ap flag - = if 0 == ( flag .&. s )- then []- else [ ap ]-
− src/Graphics/Vty/Terminal/XTermColor.hs
@@ -1,109 +0,0 @@--- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-module Graphics.Vty.Terminal.XTermColor ( terminal_instance- )- where--import Graphics.Vty.Terminal.Generic-import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased--import Control.Applicative-import Control.Monad.Trans--import qualified Data.String.UTF8 as UTF8--import System.IO---- | An xterm color based terminal is some variant paired with a standard TerminfoBased terminal--- interface.------ For the most part, xterm terminals just use the TerminfoBased implementation.-data XTermColor = XTermColor - { xterm_variant :: String- , super_term :: TerminalHandle- }---- | Initialize the display to UTF-8. -terminal_instance :: ( Applicative m, MonadIO m ) => String -> m XTermColor-terminal_instance variant = do- -- 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- flushed_put set_utf8_char_set- t <- TerminfoBased.terminal_instance variant' >>= new_terminal_handle- return $ XTermColor variant' t---- | Output immediately followed by a flush.------ \todo move out of this module.-flushed_put :: MonadIO m => String -> m ()-flushed_put str = do- liftIO $ hPutStr stdout str- liftIO $ hFlush stdout---- | These sequences set xterm based terminals to UTF-8 output.------ \todo I don't know of a terminfo cap that is equivalent to this.-set_utf8_char_set, set_default_char_set :: String-set_utf8_char_set = "\ESC%G"-set_default_char_set = "\ESC%@"--instance Terminal XTermColor where- terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor"-- release_terminal t = do - flushed_put set_default_char_set- release_terminal $ super_term t-- reserve_display t = reserve_display (super_term t)-- release_display t = release_display (super_term t)-- display_terminal_instance t b c = do- d <- display_context (super_term t) b- return $ c (DisplayContext d)-- display_bounds t = display_bounds (super_term t)- - output_byte_buffer t = output_byte_buffer (super_term t)-- output_handle t = output_handle (super_term t)--data DisplayContext = DisplayContext- { super_display :: DisplayHandle- }--instance DisplayTerminal DisplayContext where- context_region d = context_region (super_display d)-- context_color_count d = context_color_count (super_display d)-- move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)- serialize_move_cursor d = serialize_move_cursor (super_display d)-- show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)- serialize_show_cursor d = serialize_show_cursor (super_display d)-- hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)- serialize_hide_cursor d = serialize_hide_cursor (super_display d)-- attr_required_bytes d = attr_required_bytes (super_display d)- serialize_set_attr d = serialize_set_attr (super_display d)-- default_attr_required_bytes d = default_attr_required_bytes (super_display d)- serialize_default_attr d = serialize_default_attr (super_display d)-- -- | 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.- inline_hack d = do- let t = case super_display d of- DisplayHandle _ t_ _ -> t_- let s_utf8 = UTF8.fromString "\ESC[K"- liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)- ( serialize_utf8_text s_utf8 )-
+ src/Graphics/Vty/UnicodeWidthTable/IO.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+module Graphics.Vty.UnicodeWidthTable.IO+ ( readUnicodeWidthTable+ , parseUnicodeWidthTable+ , writeUnicodeWidthTable+ )+where++import Control.Monad (when, forM)+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Lazy as BSL+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif++import Graphics.Vty.UnicodeWidthTable.Types++-- | Load a binary unicode width table from the specified file.+--+-- This either returns a successfully parsed table or a table parsing+-- error message. This does not handle I/O exceptions.+readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)+readUnicodeWidthTable path = parseUnicodeWidthTable <$> BSL.readFile path++-- | Parse a binary unicode width table.+parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable+parseUnicodeWidthTable bs =+ case runGetOrFail tableParser bs of+ Left (_, _, msg) ->+ Left msg++ -- Even if we parsed a table, leftover bytes indicate something+ -- could be wrong.+ Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->+ Left $ "Error: " <> show (BSL.length remainingBytes) <>+ " byte(s) left unconsumed"++ Right (_, _, table) ->+ Right table++-- | Write the unicode width table to the specified path.+--+-- This does not handle I/O exceptions.+writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()+writeUnicodeWidthTable path table = do+ let body = runPut (tableV1Writer table)+ BSL.writeFile path body++-- | Width table magic bytes for use in the binary format.+widthTableMagic :: Word32+widthTableMagic = 0xc1a9f7e0++tableParser :: Get UnicodeWidthTable+tableParser = do+ magic <- getWord32le++ when (magic /= widthTableMagic) $+ fail "Table magic number invalid"++ version <- getWord8++ case version of+ 1 -> tableV1Parser+ _ -> fail "Table version invalid"++tableV1Parser :: Get UnicodeWidthTable+tableV1Parser = do+ numRanges <- getWord32le++ let parseRange = do+ start <- getWord32le+ size <- getWord32le+ cols <- getWord8+ return WidthTableRange { rangeStart = start+ , rangeSize = size+ , rangeColumns = cols+ }++ ranges <- forM [1..numRanges] $ const parseRange++ return UnicodeWidthTable { unicodeWidthTableRanges = ranges+ }++tableV1Writer :: UnicodeWidthTable -> Put+tableV1Writer table = do+ -- Magic bytes+ putWord32le widthTableMagic++ -- Version+ putWord8 1++ -- Number of ranges+ let ranges = unicodeWidthTableRanges table+ let numRanges = length ranges+ putWord32le (fromIntegral numRanges)++ -- Ranges+ let putRange r = do+ putWord32le $ rangeStart r+ putWord32le $ rangeSize r+ putWord8 $ rangeColumns r++ mapM_ putRange ranges
+ src/Graphics/Vty/UnicodeWidthTable/Install.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Graphics.Vty.UnicodeWidthTable.Install+ ( TableInstallException(..)+ , installUnicodeWidthTable+ , isCustomTableReady+ )+where++import Control.Monad (when, forM_)+import qualified Control.Exception as E+import GHC.Conc.Sync (withMVar)+import Control.Concurrent.MVar (MVar, newMVar)+import Data.Word (Word8, Word32)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import System.IO.Unsafe (unsafePerformIO)++import Graphics.Vty.UnicodeWidthTable.Types++-- | The lock used to make functions in this module thread-safe.+installLock :: MVar ()+{-# NOINLINE installLock #-}+installLock = unsafePerformIO $ newMVar ()++-- | Returns True if and only if a custom table has been allocated and+-- marked as ready for use.+--+-- This function is thread-safe.+isCustomTableReady :: IO Bool+isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady++withInstallLock :: IO a -> IO a+withInstallLock act = withMVar installLock $ const act++-- This is the size of the allocated custom character width table, in+-- character slots. It's important that this be large enough to hold all+-- possible Unicode character values. At the time of this writing, the+-- valid Unicode range is 0 - 0x10ffff, hence this value.+tableSize :: Int+tableSize = 0x110000++-- | Exception type raised by 'installUnicodeWidthTable'.+data TableInstallException =+ TableInitFailure Int Int+ -- ^ The width table could not be initialized. Args: failure status,+ -- requested table size.+ | TableRangeFailure Int WidthTableRange+ -- ^ A code point range could not be configured. Args: failure+ -- status, offending range.+ | TableActivationFailure Int+ -- ^ The table could not be activated. Args: failure status.+ deriving (Eq, Show)++instance E.Exception TableInstallException++-- | Install a custom unicode character width+-- table. Such tables are obtained with+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and+-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.+--+-- ALERT! This function is probably not what you want to use because+-- it is automatically called by 'Graphics.Vty.mkVty'. You will only+-- ever need to call this function if you want to use functions+-- in 'Graphics.Text.Width' without controlling the terminal with+-- 'Graphics.Vty.mkVty'.+--+-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'+-- function and functions that call it. It does so by+-- changing global state available to the C implementation+-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your+-- program gets consistent results from evaluating calls to+-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table+-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in+-- your program.+--+-- This is best done at Vty startup, and if you use+-- 'Graphics.Vty.mkVty', that function calls this automatically based on+-- the Vty configuration's declared width tables. It is exposed as part+-- of the public API so that applications can call this as needed if+-- they don't want to control the terminal with 'mkVty' but do want to+-- make calls to 'Graphics.Vty.Image.wcwidth'.+--+-- It's also important to note that once a custom table has been+-- installed, it is permanent for the life of the process. No new table+-- can be installed, and the new custom table cannot be removed.+--+-- If this function fails for any reason -- if the table cannot be+-- installed or is invalid, or if a custom table already exists -- this+-- will raise a 'TableInstallException' exception.+--+-- This function is thread-safe.+installUnicodeWidthTable :: UnicodeWidthTable -> IO ()+installUnicodeWidthTable table = withInstallLock $ do+ initResult <- initCustomTable tableSize+ when (initResult /= 0) $+ E.throwIO $ TableInitFailure initResult tableSize++ forM_ (unicodeWidthTableRanges table) $ \r -> do+ result <- setCustomTableRange (rangeStart r)+ (rangeSize r)+ (rangeColumns r)++ when (result /= 0) $ do+ deallocateCustomTable+ E.throwIO $ TableRangeFailure result r++ actResult <- activateCustomTable+ when (actResult /= 0) $+ E.throwIO $ TableActivationFailure actResult++------------------------------------------------------------------------+-- C imports++foreign import ccall unsafe "vty_init_custom_table"+ initCustomTable :: Int -> IO Int++foreign import ccall unsafe "vty_set_custom_table_range"+ setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int++foreign import ccall unsafe "vty_activate_custom_table"+ activateCustomTable :: IO Int++foreign import ccall unsafe "vty_custom_table_ready"+ c_isCustomTableReady :: IO Int++foreign import ccall unsafe "vty_deallocate_custom_table"+ deallocateCustomTable :: IO ()
+ 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
@@ -0,0 +1,70 @@+{-# LANGUAGE TupleSections #-}+module Graphics.Vty.UnicodeWidthTable.Query+ ( buildUnicodeWidthTable+ , defaultUnicodeTableUpperBound+ )+where++import Control.Monad (forM)+import Data.Char (generalCategory, GeneralCategory(..))++import Graphics.Vty.UnicodeWidthTable.Types++shouldConsider :: Char -> Bool+shouldConsider c =+ case generalCategory c of+ Control -> False+ NotAssigned -> False+ Surrogate -> False+ _ -> True++-- | 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+-- character range is fully covered by the sequence.+--+-- The result of this function is a list of ranges in reverse order+-- relative to the input sequence.+mkRanges :: [(Char, Int)] -> [WidthTableRange]+mkRanges pairs =+ let convertedPairs = convert <$> pairs+ convert (c, i) = (fromIntegral $ fromEnum c, fromIntegral i)++ go Nothing finishedRanges [] = finishedRanges+ go (Just r) finishedRanges [] = r:finishedRanges++ go Nothing finishedRanges ((c, width):rest) =+ go (Just $ WidthTableRange c 1 width) finishedRanges rest++ go (Just r@(WidthTableRange prevCh sz prevWidth)) finishedRanges ((c, width):rest) =+ if c == prevCh + sz && prevWidth == width+ then go (Just (WidthTableRange prevCh (sz + 1) prevWidth)) finishedRanges rest+ else go (Just (WidthTableRange c 1 width)) (r:finishedRanges) rest++ in go Nothing [] convertedPairs++-- The uppermost code point to consider when building Unicode width+-- tables.+defaultUnicodeTableUpperBound :: Char+defaultUnicodeTableUpperBound = '\xe0000'++-- | 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 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 Int) -> Char -> IO UnicodeWidthTable+buildUnicodeWidthTable charWidth tableUpperBound = do+ pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i ->+ (i,) <$> charWidth i++ return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs+ }
+ src/Graphics/Vty/UnicodeWidthTable/Types.hs view
@@ -0,0 +1,29 @@+module Graphics.Vty.UnicodeWidthTable.Types+ ( UnicodeWidthTable(..)+ , WidthTableRange(..)+ )+where++import Data.Word (Word8, Word32)++-- | A range of code points in a width table.+data WidthTableRange =+ WidthTableRange { rangeStart :: Word32+ -- ^ The range's starting code point.+ , rangeSize :: Word32+ -- ^ The number of code points in the contiguous+ -- range, beginning with the starting code point+ -- ('rangeStart').+ , rangeColumns :: Word8+ -- ^ The terminal width, in columns, of all of the+ -- characters corresponding to the code points in+ -- this range.+ }+ deriving (Eq, Show)++-- | A run-length-encoded table of Unicode character widths.+data UnicodeWidthTable =+ UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]+ -- ^ The ranges in the table.+ }+ deriving (Show)
− test/Verify.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module Verify ( module Verify- , module Test.QuickCheck- , succeeded- , failed- , result- , monadicIO- , liftIO- , liftBool- , Test(..)- , Prop.Result(..)- )- where--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.Property hiding ( Result(..) )-import qualified Test.QuickCheck.Property as Prop-import Test.QuickCheck.Monadic ( monadicIO ) --import qualified Codec.Binary.UTF8.String as UTF8--import Control.Monad.State.Strict--import Data.IORef-import Data.Word--import Numeric ( showHex )--import System.IO-import System.Random--verify :: Testable t => String -> t -> Test-verify test_name p = Test $ TestInstance- { name = test_name- , run = do- qc_result <- quickCheckResult p- case qc_result of- QC.Success {..} -> return $ Finished TS.Pass- _ -> 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 = morallyDubiousIOProperty--#if __GLASGOW_HASKELL__ <= 701-instance Random Word where- random g = - let (i :: Int, g') = random g- in (toEnum i, g')- randomR (l,h) g =- let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g- in (toEnum i, g')-#endif-
− test/Verify/Data/Terminfo/Parse.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-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 Numeric--instance Show CapExpression where- show c - = "CapExpression { " ++ show (cap_ops c) ++ " }"- ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]"- ++ " <= " ++ show (source_string c) --hex_dump :: [Word8] -> String-hex_dump 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) <- insert_escape_op "%" [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) <- insert_escape_op "i" [] s- return $ IncFirstTwoCap s' bytes- ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) --data PushParamCap = PushParamCap String Word [Word8]- deriving ( Show )--instance Arbitrary PushParamCap where- arbitrary- = ( do- NonParamCapString s <- arbitrary- n :: Word <- choose (1,9) >>= return . toEnum- (s', bytes) <- insert_escape_op ("p" ++ show n) [] s- return $ PushParamCap s' n bytes- ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) --data DecPrintCap = DecPrintCap String Word [Word8]- deriving ( Show )--instance Arbitrary DecPrintCap where- arbitrary- = ( do- NonParamCapString s <- arbitrary- n :: Word <- choose (1,9) >>= return . toEnum- (s', bytes) <- insert_escape_op ("p" ++ show n ++ "%d") [] s- return $ DecPrintCap s' n bytes- ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) --insert_escape_op op_str repl_bytes s = do- insert_points <- listOf1 $ elements [0 .. length s - 1]- let s' = f s ('%' : op_str)- remaining_bytes = f (map (toEnum . fromEnum) s) repl_bytes- f in_vs out_v = concat [ vs- | vi <- zip in_vs [0 .. length s - 1]- , let vs = fst vi : ( if snd vi `elem` insert_points- then out_v- else []- )- ]- return (s', remaining_bytes)--is_bytes_op :: CapOp -> Bool-is_bytes_op (Bytes {}) = True--- is_bytes_op _ = False--bytes_for_range cap offset c- = take (fromEnum c)- $ drop (fromEnum offset)- $ ( map ( toEnum . fromEnum ) $! source_string cap )--collect_bytes :: CapExpression -> [Word8]-collect_bytes e = concat [ bytes - | Bytes offset c _ <- cap_ops e- , let bytes = bytes_for_range e offset c- ]- --verify_bytes_equal :: [Word8] -> [Word8] -> Result-verify_bytes_equal out_bytes expected_bytes - = if out_bytes == expected_bytes- then succeeded- else failed - { reason = "out_bytes [" - ++ hex_dump out_bytes- ++ "] /= expected_bytes ["- ++ hex_dump expected_bytes- ++ "]"- }-
− test/Verify/Graphics/Vty/Attributes.hs
@@ -1,40 +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 )---- Limit the possible attributes to just a few for now.-possible_attr_mods :: [ AttrOp ]-possible_attr_mods = - [ set_bold_op- , id_op - ]--instance Arbitrary Attr where- arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr--data DiffAttr = DiffAttr Attr Attr--instance Arbitrary DiffAttr where- arbitrary = do- op0 <- elements possible_attr_mods- let possible_attr_mods' = delete op0 possible_attr_mods- op1 <- elements possible_attr_mods'- return $ DiffAttr (apply_op op0 def_attr) (apply_op op1 def_attr)--data AttrOp = AttrOp String (Attr -> Attr)--instance Eq AttrOp where- AttrOp n0 _ == AttrOp n1 _ = n0 == n1--set_bold_op = AttrOp "set_bold" (flip with_style bold)-id_op = AttrOp "id" id--apply_op :: AttrOp -> Attr -> Attr-apply_op (AttrOp _ f) a = f a-
− test/Verify/Graphics/Vty/DisplayRegion.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion- , module Graphics.Vty.DisplayRegion- , DebugWindow(..)- )- where--import Graphics.Vty.Debug-import Graphics.Vty.DisplayRegion--import Verify--import Data.Word--data EmptyWindow = EmptyWindow DebugWindow--instance Arbitrary EmptyWindow where- arbitrary = return $ EmptyWindow (DebugWindow (0 :: Word) (0 :: Word))--instance Show EmptyWindow where- show (EmptyWindow _) = "EmptyWindow"--instance Arbitrary DebugWindow where- arbitrary = do- w <- choose (1,1024)- h <- choose (1,1024)- return $ DebugWindow w h-
− test/Verify/Graphics/Vty/Image.hs
@@ -1,90 +0,0 @@-{-# 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.Debug.Image-import Graphics.Vty.Image--import Verify--import Data.Word--data UnitImage = UnitImage Char Image--instance Arbitrary UnitImage where- arbitrary = do- SingleColumnChar c <- arbitrary- return $ UnitImage c (char def_attr c)--instance Show UnitImage where- show (UnitImage c _) = "UnitImage " ++ show c--data DefaultImage = DefaultImage Image ImageConstructLog--instance Show DefaultImage where- show (DefaultImage i image_log) - = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i) ++ " " ++ show image_log--instance Arbitrary DefaultImage where- arbitrary = do- i <- return $ char def_attr 'X' -- elements forward_image_ops >>= return . (\op -> op empty_image)- return $ DefaultImage i []--data SingleRowSingleAttrImage - = SingleRowSingleAttrImage - { expected_attr :: Attr- , expected_columns :: Word- , row_image :: Image- }--instance Show SingleRowSingleAttrImage where- show (SingleRowSingleAttrImage attr columns image) - = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"--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- single_column_row_text <- resize 128 (listOf1 arbitrary)- attr <- arbitrary- return $ SingleRowSingleAttrImage - attr - ( fromIntegral $ length single_column_row_text )- ( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] )--data SingleRowTwoAttrImage - = SingleRowTwoAttrImage - { part_0 :: SingleRowSingleAttrImage- , part_1 :: SingleRowSingleAttrImage- , join_image :: Image- } deriving Show--instance Arbitrary SingleRowTwoAttrImage where- arbitrary = do- p0 <- arbitrary- p1 <- arbitrary- return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1)--data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack - { stack_image :: Image - , stack_source_images :: [SingleRowSingleAttrImage]- , stack_width :: Word- , stack_height :: Word- }- deriving Show--instance Arbitrary SingleAttrSingleSpanStack where- arbitrary = do- image_list <- resize 128 (listOf1 arbitrary)- let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]- return $ SingleAttrSingleSpanStack - image - image_list - ( maximum $ map expected_columns image_list )- ( toEnum $ length image_list )-
− test/Verify/Graphics/Vty/Picture.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture- , module Graphics.Vty.Picture- )- where--import Graphics.Vty.Picture-import Graphics.Vty.Debug--import Verify.Graphics.Vty.Attributes-import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.DisplayRegion--import Verify--data DefaultPic = DefaultPic - { default_pic :: Picture- , default_win :: DebugWindow - , default_construct_log :: ImageConstructLog- }--instance Show DefaultPic where- show (DefaultPic pic win image_log) - = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n\t" ++ show image_log ++ "\n"--instance Arbitrary DefaultPic where- arbitrary = do- DefaultImage image image_construct_events <- arbitrary- let win = DebugWindow (image_width image) (image_height image)- return $ DefaultPic (pic_for_image image) - win - image_construct_events--data PicWithBGAttr = PicWithBGAttr - { with_attr_pic :: Picture- , with_attr_win :: DebugWindow- , with_attr_construct_log :: ImageConstructLog- , with_attr_specified_attr :: Attr- } deriving ( Show )--instance Arbitrary PicWithBGAttr where- arbitrary = do- DefaultImage image image_construct_events <- arbitrary- let win = DebugWindow (image_width image) (image_height image)- attr <- arbitrary- return $ PicWithBGAttr (pic_for_image image) - win - image_construct_events- attr-
− test/Verify/Graphics/Vty/Span.hs
@@ -1,30 +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 Data.Word--import Verify--is_attr_span_op :: SpanOp -> Bool-is_attr_span_op AttributeChange {} = True-is_attr_span_op _ = False--verify_all_spans_have_width i spans w- = case all_spans_have_width spans w of- True -> succeeded- False -> failed { reason = "Not all spans contained operations defining exactly " - ++ show w- ++ " columns of output -\n"- ++ show i- ++ "\n->\n"- ++ show spans- }-
− test/VerifyAttributeOps.hs
@@ -1,9 +0,0 @@-module VerifyAttributeOps where--import Verify.Graphics.Vty.Attributes--import Verify--tests :: IO [Test]-tests = return []-
− 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,14 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module VerifyEmptyImageProps where--import Verify---- should be exported by Graphics.Vty.Picture-import Graphics.Vty.Picture ( Image, empty_image )--tests :: IO [Test]-tests = do- -- should provide an image type.- let _ :: Image = empty_image- return []-
− test/VerifyEvalTerminfoCaps.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyEvalTerminfoCaps where--import Data.Marshalling--import Data.Terminfo.Eval -import Data.Terminfo.Parse-import Control.DeepSeq--import qualified System.Console.Terminfo as Terminfo--import Verify--import Control.Applicative ( (<$>) )-import Control.Exception ( try, SomeException(..) )--import Control.Monad ( mapM_, forM, forM_ )--import Data.Maybe ( fromJust )-import Data.Word--import Numeric---- A list of terminals that ubuntu includes a terminfo cap file for. --- Assuming that is a good place to start.-terminals_of_interest = - [ "wsvt25"- , "wsvt25m"- , "vt52"- , "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"- , "cons25"- , "dumb"- ]---- If a terminal defines one of the caps then it's expected to be parsable.-caps_of_interest = - [ "cup"- , "sc"- , "rc"- , "setf"- , "setb"- , "setaf"- , "setab"- , "op"- , "cnorm"- , "civis"- , "smcup"- , "rmcup"- , "clear"- , "hpa"- , "vpa"- , "sgr"- , "sgr0"- ]--from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)--tests :: IO [Test]-tests = do- eval_buffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)- fmap concat $ forM terminals_of_interest $ \term_name -> do- putStrLn $ "adding tests for terminal: " ++ term_name- mti <- try $ Terminfo.setupTerm term_name- case mti of- Left (_e :: SomeException) - -> return []- Right ti -> do- fmap concat $ forM caps_of_interest $ \cap_name -> do- case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of- Just cap_def -> do- putStrLn $ "\tadding test for cap: " ++ cap_name- let test_name = term_name ++ "(" ++ cap_name ++ ")"- parse_result <- parse_cap_expression cap_def- case parse_result of- Left error -> return [ verify test_name ( failed { reason = "parse error " ++ show error } ) ]- Right !cap_expr -> return [ verify test_name ( verify_eval_cap eval_buffer cap_expr ) ]- Nothing -> do- return []--{-# NOINLINE verify_eval_cap #-}-verify_eval_cap :: Ptr Word8 -> CapExpression -> Int -> Property-verify_eval_cap eval_buffer expr !junk_int = do- forAll (vector 9) $ \input_values -> - let !byte_count = cap_expression_required_bytes expr input_values- in liftIOResult $ do- let start_ptr :: Ptr Word8 = eval_buffer- forM_ [0..100] $ \i -> serialize_cap_expression expr input_values start_ptr- end_ptr <- serialize_cap_expression expr input_values start_ptr- case end_ptr `minusPtr` start_ptr of- count | count < 0 -> - return $ failed { reason = "End pointer before start pointer." }- | toEnum count > byte_count -> - return $ failed { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byte_count) - }- | otherwise -> - return succeeded-
− test/VerifyImageOps.hs
@@ -1,125 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module VerifyImageOps where--import Graphics.Vty.Attributes-import Verify.Graphics.Vty.Image--import Verify--import Data.Word--two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool-two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) = - image_width (char def_attr c1 <|> char def_attr c2) == 2--many_sw_horiz_concat :: [SingleColumnChar] -> Bool-many_sw_horiz_concat cs = - let chars = [ char | SingleColumnChar char <- cs ]- l = fromIntegral $ length cs- in image_width ( horiz_cat $ map (char def_attr) chars ) == l--two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool-two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) = - image_height (char def_attr c1 <-> char def_attr c2) == 2--horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool-horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = - (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 - == - char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)--two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool-two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = - image_width (char def_attr c1 <|> char def_attr c2) == 4--many_dw_horiz_concat :: [DoubleColumnChar] -> Bool-many_dw_horiz_concat cs = - let chars = [ char | DoubleColumnChar char <- cs ]- l = fromIntegral $ length cs- in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2--two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool-two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = - image_height (char def_attr c1 <-> char def_attr c2) == 2--horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool-horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = - (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 - == - char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)--vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool-vert_contat_single_row (NonEmpty stack) =- let expected_height :: Word = fromIntegral $ length stack- stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ]- in image_height stack_image == expected_height--disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) =- let expected_height :: Word = fromIntegral $ max (length stack_0) (length stack_1)- stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]- stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]- in image_height (stack_image_0 <|> stack_image_1) == expected_height---disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =- let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]- stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]- image = stack_image_0 <|> stack_image_1- expected_height = image_height image- in case image of- HorizJoin {} -> ( expected_height == (image_height $ part_left image) )- && - ( expected_height == (image_height $ part_right image) )- _ -> True--disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) =- let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)- stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]- stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]- stack_0_image = vert_cat stack_0_images - stack_1_image = vert_cat stack_1_images - image = stack_0_image <-> stack_1_image- in image_width image == expected_width--disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage- -> Bool-disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =- let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)- stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]- stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]- stack_0_image = vert_cat stack_0_images - stack_1_image = vert_cat stack_1_images - image = stack_0_image <-> stack_1_image- in case image of- VertJoin {} -> ( expected_width == (image_width $ part_top image) )- &&- ( expected_width == (image_width $ part_bottom image) )- _ -> True--tests :: IO [Test]-tests = return- [ verify "two_sw_horiz_concat" two_sw_horiz_concat- , verify "many_sw_horiz_concat" many_sw_horiz_concat- , verify "two_sw_vert_concat" two_sw_vert_concat- , verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc- , verify "many_dw_horiz_concat" many_dw_horiz_concat- , verify "two_dw_horiz_concat" two_dw_horiz_concat- , verify "two_dw_vert_concat" two_dw_vert_concat- , verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc- , verify "single row vert concats to correct height" vert_contat_single_row- , verify "disjoint_height_horiz_join" disjoint_height_horiz_join- , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill- , verify "disjoint_width_vert_join" disjoint_width_vert_join- , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill- ]-
− test/VerifyImageTrans.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-module VerifyImageTrans where--import Verify.Graphics.Vty.Image--import Verify--import Data.Word--is_horiz_text_of_columns :: Image -> Word -> Bool-is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w-is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w-is_horiz_text_of_columns _image _expected_w = False--verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool-verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) =- is_horiz_text_of_columns image char_count--verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool-verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0)- (SingleRowSingleAttrImage attr1 char_count1 _image1)- i- ) - | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)- | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)--tests :: IO [Test]-tests = return- [ verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies- , verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies- ]-
− test/VerifyInline.hs
@@ -1,23 +0,0 @@-module VerifyInline where--import Graphics.Vty.Inline-import Graphics.Vty.Terminal--import Verify--import Distribution.TestSuite--tests :: IO [Test]-tests = return- [ Test $ TestInstance- { name = "verify vty inline"- , run = do- t <- terminal_handle- put_attr_change t $ default_all- return $ Finished Pass- , tags = []- , options = []- , setOption = \_ _ -> Left "no options supported"- }- ]-
− test/VerifyMockTerminal.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module VerifyMockTerminal where--import Verify.Graphics.Vty.DisplayRegion-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Span-import Graphics.Vty.Terminal-import Graphics.Vty.Terminal.Debug--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--unit_image_unit_bounds :: UnitImage -> Property-unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do- t <- terminal_instance (DisplayRegion 1 1)- d <- display_bounds t >>= display_context t- let pic = pic_for_image i- output_picture d pic- return succeeded--unit_image_arb_bounds :: UnitImage -> DebugWindow -> Property-unit_image_arb_bounds (UnitImage _ i) (DebugWindow w h) = liftIOResult $ do- t <- terminal_instance (DisplayRegion w h)- d <- display_bounds t >>= display_context t- let pic = pic_for_image i- output_picture d pic- return succeeded--single_T_row :: DebugWindow -> Property-single_T_row (DebugWindow w h) = liftIOResult $ do- t <- terminal_instance (DisplayRegion w h)- d <- display_bounds t >>= display_context t- -- create an image that contains just the character T repeated for a single row- let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T')- pic = (pic_for_image i) { pic_background = Background 'B' def_attr }- output_picture d pic- out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep- -- The UTF8 string that represents the output bytes a single line containing the T string:- let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T'- -- Followed by h - 1 lines of a change to the background attribute and then the background- -- character- ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B')- expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected- if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }- else return succeeded- -many_T_rows :: DebugWindow -> Property-many_T_rows (DebugWindow w h) = liftIOResult $ do- t <- terminal_instance (DisplayRegion w h)- d <- display_bounds t >>= display_context t- -- create an image that contains the character 'T' repeated for all the rows- let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')- pic = (pic_for_image i) { pic_background = Background 'B' def_attr }- output_picture d pic- out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep- -- 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 = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')- expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected- if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }- else return succeeded--many_T_rows_cropped_width :: DebugWindow -> Property-many_T_rows_cropped_width (DebugWindow w h) = liftIOResult $ do- t <- terminal_instance (DisplayRegion w h)- d <- display_bounds t >>= display_context t- -- create an image that contains the character 'T' repeated for all the rows- let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T')- pic = (pic_for_image i) { pic_background = Background 'B' def_attr }- output_picture d pic- out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep- -- 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 = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')- expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected- if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }- else return succeeded--many_T_rows_cropped_height :: DebugWindow -> Property-many_T_rows_cropped_height (DebugWindow w h) = liftIOResult $ do- t <- terminal_instance (DisplayRegion w h)- d <- display_bounds t >>= display_context t- -- create an image that contains the character 'T' repeated for all the rows- let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')- pic = (pic_for_image i) { pic_background = Background 'B' def_attr }- output_picture d pic- out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep- -- 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 = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')- expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected- if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }- else return succeeded--tests :: IO [Test]-tests = return [ verify "unit_image_unit_bounds" unit_image_unit_bounds- , verify "unit_image_arb_bounds" unit_image_arb_bounds- , verify "single_T_row" single_T_row- , verify "many_T_rows" many_T_rows- , verify "many_T_rows_cropped_width" many_T_rows_cropped_width- , verify "many_T_rows_cropped_height" many_T_rows_cropped_height- ]-
− test/VerifyParseTerminfoCaps.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyParseTerminfoCaps where--import Prelude hiding ( catch )--import qualified System.Console.Terminfo as Terminfo--import Verify.Data.Terminfo.Parse-import Verify--import Control.Applicative ( (<$>) )-import Control.Exception ( try, SomeException(..) )-import Control.Monad ( mapM_, forM, forM_ )--import Data.Maybe ( catMaybes, fromJust )-import Data.Word--import Numeric---- A list of terminals that ubuntu includes a terminfo cap file for. --- Assuming that is a good place to start.-terminals_of_interest = - [ "wsvt25"- , "wsvt25m"- , "vt52"- , "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"- , "cons25"- , "dumb"- ]---- If a terminal defines one of the caps then it's expected to be parsable.-caps_of_interest = - [ "cup"- , "sc"- , "rc"- , "setf"- , "setb"- , "setaf"- , "setab"- , "op"- , "cnorm"- , "civis"- , "smcup"- , "rmcup"- , "clear"- , "hpa"- , "vpa"- , "sgr"- , "sgr0"- ]--from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)--tests :: IO [Test]-tests = do- parse_tests <- concat <$> forM terminals_of_interest ( \term_name -> do- putStrLn $ "testing parsing of caps for terminal: " ++ term_name- mti <- liftIO $ try $ Terminfo.setupTerm term_name- case mti of- Left (_e :: SomeException)- -> return []- Right ti -> do- concat <$> forM caps_of_interest ( \cap_name -> do- liftIO $ putStrLn $ "\tparsing cap: " ++ cap_name- case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of- Just cap_def -> do- return [ verify ( "\tparse cap " ++ cap_name ++ " -> " ++ show cap_def )- ( verify_parse_cap cap_def $ const (return succeeded) ) ]- Nothing -> do- return []- )- )- -- The quickcheck tests- return $ [ verify "parse_non_paramaterized_caps" non_paramaterized_caps- , verify "parse cap string with literal %" literal_percent_caps- , verify "parse cap string with %i op" inc_first_two_caps- , verify "parse cap string with %pN op" push_param_caps- ] ++ parse_tests--verify_parse_cap cap_string on_parse = liftIOResult $ do- parse_result <- parse_cap_expression cap_string- case parse_result of- Left error -> return $ failed { reason = "parse error " ++ show error }- Right e -> on_parse e--non_paramaterized_caps (NonParamCapString cap) = do- verify_parse_cap cap $ \e -> - let expected_count :: Word8 = toEnum $ length cap- expected_bytes = map (toEnum . fromEnum) cap- out_bytes = bytes_for_range e 0 expected_count- in return $ verify_bytes_equal out_bytes expected_bytes--literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do- verify_parse_cap cap_string $ \e ->- let expected_count :: Word8 = toEnum $ length expected_bytes- out_bytes = collect_bytes e- in return $ verify_bytes_equal out_bytes expected_bytes--inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do- verify_parse_cap cap_string $ \e ->- let expected_count :: Word8 = toEnum $ length expected_bytes- out_bytes = collect_bytes e- in return $ verify_bytes_equal out_bytes expected_bytes- -push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do- verify_parse_cap cap_string $ \e ->- let expected_count :: Word8 = toEnum $ length expected_bytes- out_bytes = collect_bytes e- out_param_count = param_count e- in return $ if out_param_count == expected_param_count- then verify_bytes_equal out_bytes expected_bytes- else failed { reason = "out param count /= expected param count" }--dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do- verify_parse_cap cap_string $ \e ->- let expected_count :: Word8 = toEnum $ length expected_bytes- out_bytes = collect_bytes e- out_param_count = param_count e- in return $ if out_param_count == expected_param_count- then verify_bytes_equal out_bytes expected_bytes- else failed { reason = "out param count /= expected param count" }--print_cap ti cap_name = do- putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name)--print_expression ti cap_name = do- parse_result <- parse_cap_expression $ from_capname ti cap_name- putStrLn $ cap_name ++ ": " ++ show parse_result-
− test/VerifyPictureOps.hs
@@ -1,8 +0,0 @@-module VerifyPictureOps where--import Graphics.Vty.Picture ( translate )--import Verify--tests :: IO [Test]-tests = return []
− test/VerifyPictureToSpan.hs
@@ -1,10 +0,0 @@-module VerifyPictureToSpan where--import Graphics.Vty.Picture-import Graphics.Vty.Span-import Graphics.Vty.PictureToSpans--import Verify--tests :: IO [Test]-tests = return []
− test/VerifySpanOps.hs
@@ -1,180 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifySpanOps where--import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Span-import Verify.Graphics.Vty.DisplayRegion--import Graphics.Vty.Debug--import Verify--import qualified Data.Vector as Vector --unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool-unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) = - let p = pic_for_image i- spans = spans_for_pic p (region_for_window w)- in span_ops_columns spans == 0 && span_ops_rows spans == 0--unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool-unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) = - let p = pic_for_image i- spans = spans_for_pic p (region_for_window w)- in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 )--horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool-horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = - let p = pic_for_image i- spans = spans_for_pic p (region_for_window w)- in span_ops_columns spans == 0 && span_ops_rows spans == 0--horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool-horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = - let p = pic_for_image i- spans = spans_for_pic p (region_for_window w)- in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 )--horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result-horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =- let p = pic_for_image i- w = DebugWindow c 1- spans = spans_for_pic p (region_for_window w)- in verify_all_spans_have_width i spans c--horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool-horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =- let p = pic_for_image i- w = DebugWindow c 1- spans = spans_for_pic p (region_for_window w)- in span_ops_effected_rows spans == 1--horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result-horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =- let p = pic_for_image i- lesser_width = c `div` 2- w = DebugWindow lesser_width 1- spans = spans_for_pic p (region_for_window w)- in verify_all_spans_have_width i spans lesser_width--single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result-single_attr_single_span_stack_cropped_0 stack =- let p = pic_for_image (stack_image stack)- w = DebugWindow (stack_width stack `div` 2) (stack_height stack)- spans = spans_for_pic p (region_for_window w)- in verify_all_spans_have_width (stack_image stack) spans (stack_width stack `div` 2)--single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool-single_attr_single_span_stack_cropped_1 stack =- let p = pic_for_image (stack_image stack)- expected_row_count = stack_height stack `div` 2- w = DebugWindow (stack_width stack) expected_row_count- spans = spans_for_pic p (region_for_window w)- actual_row_count = span_ops_effected_rows spans- in expected_row_count == actual_row_count--single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result-single_attr_single_span_stack_cropped_2 stack_0 stack_1 =- let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)- w = DebugWindow (stack_width stack_0) (image_height (pic_image p))- spans = spans_for_pic p (region_for_window w)- in verify_all_spans_have_width (pic_image p) spans (stack_width stack_0)--single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool-single_attr_single_span_stack_cropped_3 stack_0 stack_1 =- let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)- w = DebugWindow (image_width (pic_image p)) expected_row_count- spans = spans_for_pic p (region_for_window w)- expected_row_count = image_height (pic_image p) `div` 2- actual_row_count = span_ops_effected_rows spans- in expected_row_count == actual_row_count--single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result-single_attr_single_span_stack_cropped_4 stack_0 stack_1 =- let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)- w = DebugWindow expected_width (image_height (pic_image p))- spans = spans_for_pic p (region_for_window w)- expected_width = image_width (pic_image p) `div` 2- in verify_all_spans_have_width (pic_image p) spans expected_width--single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool-single_attr_single_span_stack_cropped_5 stack_0 stack_1 =- let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)- w = DebugWindow (image_width (pic_image p)) (stack_height stack_0)- spans = spans_for_pic p (region_for_window w)- expected_row_count = stack_height stack_0- actual_row_count = span_ops_effected_rows spans- in expected_row_count == actual_row_count--horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result-horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =- let p = pic_for_image i- -- SingleRowSingleAttrImage always has width >= 1- greater_width = c * 2- w = DebugWindow greater_width 1- spans = spans_for_pic p (region_for_window w)- in verify_all_spans_have_width i spans greater_width--arb_image_is_cropped :: DefaultImage -> DebugWindow -> Bool-arb_image_is_cropped (DefaultImage image _) win@(DebugWindow w h) =- let pic = pic_for_image image- spans = spans_for_pic pic (region_for_window win)- in ( span_ops_effected_rows spans == h ) && ( all_spans_have_width spans w )--span_ops_actually_fill_rows :: DefaultPic -> Bool-span_ops_actually_fill_rows (DefaultPic pic win _) =- let spans = spans_for_pic pic (region_for_window win)- expected_row_count = region_height (region_for_window win)- actual_row_count = span_ops_effected_rows spans- in expected_row_count == actual_row_count--span_ops_actually_fill_columns :: DefaultPic -> Bool-span_ops_actually_fill_columns (DefaultPic pic win _) =- let spans = spans_for_pic pic (region_for_window win)- expected_column_count = region_width (region_for_window win)- in all_spans_have_width spans expected_column_count--first_span_op_sets_attr :: DefaultPic -> Bool-first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } = - let spans = spans_for_pic pic (region_for_window win)- in all ( is_attr_span_op . Vector.head ) ( Vector.toList $ display_ops spans )--single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result-single_attr_single_span_stack_op_coverage stack =- let p = pic_for_image (stack_image stack)- w = DebugWindow (stack_width stack) (stack_height stack)- spans = spans_for_pic p (region_for_window w)- in verify_all_spans_have_width (stack_image stack) spans (stack_width stack)--tests :: IO [Test]-tests = return - [ verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0- , verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1- , verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0- , verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1- , verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0- , verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1- , verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0- , verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0- , verify "arbitrary image is padded or cropped" arb_image_is_cropped- , verify "The span ops actually define content for all the rows in the output region" span_ops_actually_fill_rows- , verify "The span ops actually define content for all the columns in the output region" span_ops_actually_fill_columns- , verify "first span op is always to set the text attribute" first_span_op_sets_attr- , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"- single_attr_single_span_stack_op_coverage- , verify "a single attr text span is cropped when window size < size of stack image [width]"- single_attr_single_span_stack_cropped_0 - , verify "a single attr text span is cropped when window size < size of stack image [height]"- single_attr_single_span_stack_cropped_1- , verify "single attr text span <|> single attr text span cropped. [width]"- single_attr_single_span_stack_cropped_2- , verify "single attr text span <|> single attr text span cropped. [height]"- single_attr_single_span_stack_cropped_3- , verify "single attr text span <-> single attr text span cropped. [width]"- single_attr_single_span_stack_cropped_4- , verify "single attr text span <-> single attr text span cropped. [height]"- single_attr_single_span_stack_cropped_5- ]-
− test/VerifyUtf8Width.hs
@@ -1,18 +0,0 @@-module VerifyUtf8Width where-import Verify--import Graphics.Vty.Attributes-import Graphics.Vty.Picture--sw_is_1_column :: SingleColumnChar -> Bool-sw_is_1_column (SingleColumnChar c) = image_width (char def_attr c) == 1--dw_is_2_column :: DoubleColumnChar -> Bool-dw_is_2_column (DoubleColumnChar c) = image_width (char def_attr c) == 2--tests :: IO [Test]-tests = return- [ verify "sw_is_1_column" sw_is_1_column- , verify "dw_is_2_column" dw_is_2_column- ]-
− test/interactive_terminal_test.hs
@@ -1,954 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Main where--import Graphics.Vty-import Graphics.Vty.Attributes-import Graphics.Vty.Inline-import Graphics.Vty.Picture-import Graphics.Vty.Terminal-import Graphics.Vty.DisplayRegion--import Control.Exception-import Control.Monad--import Data.List ( lookup )-import Data.Maybe ( isJust, fromJust )-import Data.Monoid-import Data.String.QQ-import Data.Word--import Foreign.Marshal.Array --import qualified System.Environment as Env--import System.IO ( hFlush, hPutStr, hPutBuf, stdout )--main = do- print_intro--output_file_path = "test_results.list"--print_intro = do- putStr $ [s| -This is an interactive verification program for the terminal input and output-support of the VTY library. This will ask a series of questions about what you-see on screen. The goal is to verify that VTY's output and input support-performs as expected with your terminal.--This program produces a file named - |] ++ output_file_path ++ [s| -in the current directory that contains the results for each test assertion. This-can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve-support for your terminal. No personal information is contained in the report.--Each test follows, more or less, the following format:- 0. A description of the test is printed which will include a detailed- description of what VTY is going to try and what the expected results are.- Press return to move on.- 1. The program will produce some output or ask for you to press a key.- 2. You will then be asked to confirm if the behavior matched the provided- description. Just pressing enter implies the default response that- everything was as expected. --All the tests assume the following about the terminal display:- 0. The terminal display will not be resized during a test and is at least 80 - characters in width. - 1. The terminal display is using a monospaced font for both single width and- double width characters.- 2. A double width character is displayed with exactly twice the width of a - single column character. This may require adjusting the font used by the- terminal. At least, that is the case using xterm. - 3. Fonts are installed, and usable by the terminal, that define glyphs for- a good range of the unicode characters. Each test involving unicode display- describes the expected appearance of each glyph. --Thanks for the help! :-D-To exit the test early enter "q" anytime at the following menu screen.--If any test failed then please post an issue to- https://github.com/coreyoconnor/vty/issues-with the test_results.list file pasted into the issue. The issue summary can-mention the specific tests that failed or just say "interactive terminal test-failure".-|]- wait_for_return- results <- do_test_menu 1- env_attributes <- mapM ( \env_name -> Control.Exception.catch- ( Env.getEnv env_name >>= return . (,) env_name )- ( \ (_ :: SomeException) -> return (env_name, "") )- )- [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]- t <- terminal_handle- let results_txt = show env_attributes ++ "\n" - ++ terminal_ID t ++ "\n"- ++ show results ++ "\n"- release_terminal t- writeFile output_file_path results_txt--wait_for_return = do- putStr "\n(press return to continue)"- hFlush stdout- getLine--test_menu :: [(String, Test)]-test_menu = zip (map show [1..]) all_tests--do_test_menu :: Int -> IO [(String, Bool)]-do_test_menu next_ID - | next_ID > length all_tests = do- putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"- return []- | otherwise = do- display_test_menu- putStrLn $ "Press return to start with #" ++ show next_ID ++ "."- putStrLn "Enter a test number to perform only that test."- putStrLn "q (or control-C) to quit."- putStr "> "- hFlush stdout- s <- getLine >>= return . filter (/= '\n')- case s of- "q" -> return mempty- "" -> do - r <- run_test $ show next_ID - rs <- do_test_menu ( next_ID + 1 )- return $ r : rs- i | isJust ( lookup i test_menu ) -> do- r <- run_test i - rs <- do_test_menu ( read i + 1 )- return $ r : rs- where- display_test_menu - = mapM_ display_test_menu' test_menu- display_test_menu' ( i, t ) - = putStrLn $ ( if i == show next_ID - then "> " - else " "- ) ++ i ++ ". " ++ test_name t--run_test :: String -> IO (String, Bool)-run_test i = do- let t = fromJust $ lookup i test_menu - print_summary t- wait_for_return- test_action t- r <- confirm_results t- return (test_ID t, r)--default_success_confirm_results = do- putStr "\n"- putStr "[Y/n] "- hFlush stdout- r <- getLine- case r of- "" -> return True- "y" -> return True- "Y" -> return True- "n" -> return False--data Test = Test- { test_name :: String- , test_ID :: String- , test_action :: IO ()- , print_summary :: IO ()- , confirm_results :: IO Bool- }--all_tests - = [ reserve_output_test - , display_bounds_test_0- , display_bounds_test_1- , display_bounds_test_2- , display_bounds_test_3- , unicode_single_width_0- , unicode_single_width_1- , unicode_double_width_0- , unicode_double_width_1- , attributes_test_0- , attributes_test_1- , attributes_test_2- , attributes_test_3- , attributes_test_4- , attributes_test_5- , inline_test_0- , inline_test_1- , inline_test_2- , cursor_hide_test_0- ]--reserve_output_test = Test - { test_name = "Initialize and reserve terminal output then restore previous state."- , test_ID = "reserve_output_test"- , test_action = do- t <- terminal_handle- reserve_display t- putStrLn "Line 1"- putStrLn "Line 2"- putStrLn "Line 3"- putStrLn "Line 4 (press return)"- hFlush stdout- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared. - 1. Four lines of text should be visible.- 1. The cursor should be visible and at the start of the fifth line.--After return is pressed for the second time this test then:- * The screen containing the test summary should be restored;- * The cursor is visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--display_bounds_test_0 = Test- { test_name = "Verify display bounds are correct test 0: Using spaces."- , test_ID = "display_bounds_test_0"- , test_action = do- t <- terminal_handle- reserve_display t- DisplayRegion w h <- display_bounds t- let row_0 = replicate (fromEnum w) 'X' ++ "\n"- row_h = replicate (fromEnum w - 1) 'X'- row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"- image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h- putStr image- hFlush stdout- getLine- release_display t- release_terminal t- return ()- , print_summary = display_bounds_test_summary True- , confirm_results = generic_output_match_confirm- }--display_bounds_test_1 = Test- { test_name = "Verify display bounds are correct test 0: Using cursor movement."- , test_ID = "display_bounds_test_1"- , test_action = do- t <- terminal_handle- reserve_display t- DisplayRegion w h <- display_bounds t- set_cursor_pos t 0 0- let row_0 = replicate (fromEnum w) 'X' ++ "\n"- putStr row_0- forM_ [1 .. h - 2] $ \y -> do- set_cursor_pos t 0 y- putStr "X"- hFlush stdout- set_cursor_pos t (w - 1) y- putStr "X"- hFlush stdout- set_cursor_pos t 0 (h - 1)- let row_h = replicate (fromEnum w - 1) 'X'- putStr row_h- hFlush stdout- getLine- release_display t- release_terminal t- return ()- , print_summary = display_bounds_test_summary True- , confirm_results = generic_output_match_confirm- }--display_bounds_test_2 = Test- { test_name = "Verify display bounds are correct test 0: Using Image ops."- , test_ID = "display_bounds_test_2"- , test_action = do- t <- terminal_handle- reserve_display t- bounds@(DisplayRegion w h) <- display_bounds t- let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')- middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row- middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')- end_row = first_row- image = first_row <-> middle_rows <-> end_row- pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }- d <- display_context t bounds- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = display_bounds_test_summary True- , confirm_results = generic_output_match_confirm- }--display_bounds_test_3 = Test- { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."- , test_ID = "display_bounds_test_3"- , test_action = do- t <- terminal_handle- reserve_display t- DisplayRegion w h <- display_bounds t- hide_cursor t- set_cursor_pos t 0 0- let row_0 = replicate (fromEnum w) 'X'- putStrLn row_0- forM_ [1 .. h - 2] $ \y -> do- set_cursor_pos t 0 y- putStr "X"- hFlush stdout- set_cursor_pos t (w - 1) y- putStr "X"- hFlush stdout- set_cursor_pos t 0 (h - 1)- let row_h = row_0- putStr row_h- hFlush stdout- getLine- show_cursor t- release_display t- release_terminal t- return ()- , print_summary = display_bounds_test_summary False- , confirm_results = generic_output_match_confirm- }--display_bounds_test_summary has_cursor = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.-|]- if has_cursor- then putStr " 1. The cursor will be visible."- else putStr " 1. The cursor will NOT be visible."- putStr [s|- 2. The border of the display will be outlined in Xs. - So if - and | represented the edge of the terminal window:- |-------------|- |XXXXXXXXXXXXX|- |X X||]-- if has_cursor- then putStr $ [s|- |XXXXXXXXXXXXC| |]- else putStr $ [s|- |XXXXXXXXXXXXX| |]-- putStr $ [s|- |-------------|-- ( Where C is the final position of the cursor. There may be an X drawn- under the cursor. )- 3. The display will remain in this state until return is pressed again.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]--generic_output_match_confirm = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results---- Explicitely definethe bytes that encode each example text.--- This avoids any issues with how the compiler represents string literals.------ This document is UTF-8 encoded so the UTF-8 string is still included for--- reference------ It's assumed the compiler will at least not barf on UTF-8 encoded text in--- comments ;-)------ txt_0 = ↑↑↓↓←→←→BA--utf8_txt_0 :: [[Word8]]-utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]- , [ 0xe2 , 0x86 , 0x91 ]- , [ 0xe2 , 0x86 , 0x93 ]- , [ 0xe2 , 0x86 , 0x93 ]- , [ 0xe2 , 0x86 , 0x90 ]- , [ 0xe2 , 0x86 , 0x92 ]- , [ 0xe2 , 0x86 , 0x90 ]- , [ 0xe2 , 0x86 , 0x92 ]- , [ 0x42 ]- , [ 0x41 ]- ]--iso_10646_txt_0 :: String-iso_10646_txt_0 = map toEnum- [ 8593 - , 8593- , 8595- , 8595- , 8592- , 8594- , 8592- , 8594- , 66- , 65- ]--unicode_single_width_0 = Test- { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"- , test_ID = "unicode_single_width_0"- , test_action = do- t <- terminal_handle- reserve_display t- hide_cursor t- withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)- hPutStr stdout "\n"- hPutStr stdout "0123456789\n"- hFlush stdout- getLine- release_display t- release_terminal t- return ()- , print_summary = unicode_single_width_summary- , confirm_results = generic_output_match_confirm- }--unicode_single_width_1 = Test- { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"- , test_ID = "unicode_single_width_1"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = line_0 <-> line_1- line_0 = iso_10646_string def_attr iso_10646_txt_0- line_1 = string def_attr "0123456789"- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = unicode_single_width_summary- , confirm_results = generic_output_match_confirm- }--unicode_single_width_summary = putStr [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. Two horizontal lines of text will be displayed:- a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph- will occupy one column of space. The order and appearance of the glyphs- will be:- | column | appearance |- ==========================- | 0 | up arrow |- | 1 | up arrow |- | 2 | down arrow |- | 3 | down arrow |- | 4 | left arrow |- | 5 | right arrow |- | 6 | left arrow |- | 7 | right arrow |- | 8 | B |- | 9 | A |- ( see: http://en.wikipedia.org/wiki/Arrow_(symbol) )- b. The second will be: 0123456789. --Verify: - * The far right extent of the glyphs on both lines are equal; - * The glyphs are as described.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]---- The second example is a unicode string containing double-width glyphs--- 你好吗-utf8_txt_1 :: [[Word8]]-utf8_txt_1 = [ [0xe4,0xbd,0xa0]- , [0xe5,0xa5,0xbd]- , [0xe5,0x90,0x97]- ]--iso_10646_txt_1 :: String-iso_10646_txt_1 = map toEnum [20320,22909,21527]--unicode_double_width_0 = Test- { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"- , test_ID = "unicode_double_width_0"- , test_action = do- t <- terminal_handle- reserve_display t- hide_cursor t- withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)- hPutStr stdout "\n"- hPutStr stdout "012345\n"- hFlush stdout- getLine- release_display t- release_terminal t- return ()- , print_summary = unicode_double_width_summary- , confirm_results = generic_output_match_confirm- }--unicode_double_width_1 = Test- { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"- , test_ID = "unicode_double_width_1"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = line_0 <-> line_1- line_0 = iso_10646_string def_attr iso_10646_txt_1- line_1 = string def_attr "012345"- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = unicode_double_width_summary- , confirm_results = generic_output_match_confirm- }--unicode_double_width_summary = putStr [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. Two horizontal lines of text will be displayed:- a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph- will occupy two columns of space. The order and appearance of the glyphs- will be:- | column | appearance |- ======================================- | 0 | first half of ni3 |- | 1 | second half of ni3 |- | 2 | first half of hao3 |- | 3 | second half of hao3 |- | 4 | first half of ma |- | 5 | second half of ma |- b. The second will be: 012345. --Verify: - * The far right extent of the glyphs on both lines are equal; - * The glyphs are as described.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]--all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]- [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]--all_bright_colors - = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]- [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]--attributes_test_0 = Test - { test_name = "Character attributes: foreground colors."- , test_ID = "attributes_test_0"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = border <|> column_0 <|> border <|> column_1 <|> border- column_0 = vert_cat $ map line_with_color all_colors- border = vert_cat $ replicate (length all_colors) $ string def_attr " | "- column_1 = vert_cat $ map (string def_attr . snd) all_colors- line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. 9 lines of text in two columns will be drawn. The first column will be a- name of a standard color (for an 8 color terminal) rendered in that color.- For instance, one line will be the word "magenta" and that word should be- rendered in the magenta color. The second column will be the name of a- standard color rendered with the default attributes.--Verify: - * In the first column: The foreground color matches the named color.- * The second column: All text is rendered with the default attributes.- * The vertical bars used in each line to mark the border of a column are- lined up.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--attributes_test_1 = Test - { test_name = "Character attributes: background colors."- , test_ID = "attributes_test_1"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = border <|> column_0 <|> border <|> column_1 <|> border- column_0 = vert_cat $ map line_with_color all_colors- border = vert_cat $ replicate (length all_colors) $ string def_attr " | "- column_1 = vert_cat $ map (string def_attr . snd) all_colors- line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. 9 lines of text in two columns will be drawn. The first column will- contain be a name of a standard color for an 8 color terminal rendered with- the default foreground color with a background the named color. For- instance, one line will contain be the word "magenta" and the word should- be rendered in the default foreground color over a magenta background. The- second column will be the name of a standard color rendered with the default- attributes.--Verify: - * The first column: The background color matches the named color.- * The second column: All text is rendered with the default attributes.- * The vertical bars used in each line to mark the border of a column are- lined up.--Note: I haven't decided if, in this case, the background color should extend to-fills added for alignment. Right now the selected background color is only-applied to the background where the word is actually rendered. Since each word-is not of the same length VTY adds background fills to make the width of each-row effectively the same. These added fills are all currently rendered with the-default background pattern.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--attributes_test_2 = Test - { test_name = "Character attributes: Vivid foreground colors."- , test_ID = "attributes_test_2"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = horiz_cat [border, column_0, border, column_1, border, column_2, border]- border = vert_cat $ replicate (length all_colors) $ string def_attr " | "- column_0 = vert_cat $ map line_with_color_0 all_colors- column_1 = vert_cat $ map line_with_color_1 all_bright_colors- column_2 = vert_cat $ map (string def_attr . snd) all_colors- line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name- line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. 9 lines of text in three columns will be drawn:- a. The first column will be a name of a standard color (for an 8 color- terminal) rendered with that color as the foreground color. - b. The next column will be also be the name of a standard color rendered- with that color as the foreground color but the shade used should be- more vivid than the shade used in the first column. - c. The final column will be the name of a color rendered with the- default attributes.--For instance, one line will be the word "magenta" and that word should be-rendered in the magenta color. --I'm not actually sure exactly what "vivid" means in this context. For xterm the-vivid colors are brighter. --Verify: - * The first column: The foreground color matches the named color.- * The second column: The foreground color matches the named color but is- more vivid than the color used in the first column. - * The third column: All text is rendered with the default attributes.- * The vertical bars used in each line to mark the border of a column are- lined up.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--attributes_test_3 = Test - { test_name = "Character attributes: Vivid background colors."- , test_ID = "attributes_test_3"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = horiz_cat [border, column_0, border, column_1, border, column_2, border]- border = vert_cat $ replicate (length all_colors) $ string def_attr " | "- column_0 = vert_cat $ map line_with_color_0 all_colors- column_1 = vert_cat $ map line_with_color_1 all_bright_colors- column_2 = vert_cat $ map (string def_attr . snd) all_colors- line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name- line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. 9 lines of text in three columns will be drawn:- a. The first column will contain be a name of a standard color for an 8- color terminal rendered with the default foreground color with a- background the named color. - b. The first column will contain be a name of a standard color for an 8- color terminal rendered with the default foreground color with the- background a vivid version of the named color. - c. The third column will be the name of a standard color rendered with- the default attributes.- -For instance, one line will contain be the word "magenta" and the word should-be rendered in the default foreground color over a magenta background. --I'm not actually sure exactly what "vivid" means in this context. For xterm the-vivid colors are brighter.--Verify: - * The first column: The background color matches the named color.- * The second column: The background color matches the named color and is- more vivid than the color used in the first column. - * The third column column: All text is rendered with the default attributes.- * The vertical bars used in each line to mark the border of a column are- lined up.--Note: I haven't decided if, in this case, the background color should extend to-fills added for alignment. Right now the selected background color is only-applied to the background where the word is actually rendered. Since each word-is not of the same length VTY adds background fills to make the width of each-row effectively the same. These added fills are all currently rendered with the-default background pattern.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--attr_combos = - [ ( "default", id )- , ( "bold", flip with_style bold )- , ( "blink", flip with_style blink )- , ( "underline", flip with_style underline )- , ( "bold + blink", flip with_style (bold + blink) )- , ( "bold + underline", flip with_style (bold + underline) )- , ( "underline + blink", flip with_style (underline + blink) )- , ( "bold + blink + underline", flip with_style (bold + blink + underline) )- ]--attributes_test_4 = Test - { test_name = "Character attributes: Bold; Blink; Underline."- , test_ID = "attributes_test_4"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = horiz_cat [border, column_0, border, column_1, border]- border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "- column_0 = vert_cat $ map line_with_attrs attr_combos- column_1 = vert_cat $ map (string def_attr . fst) attr_combos- line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. 8 rows of text in two columns. - The rows will contain the following text:- default- bold - blink- underline- bold + blink- bold + underline- underline + blink- bold + blink + underline- The first column will be rendered with the described attributes. The second- column will be rendered with the default attributes.- -Verify: - * The vertical bars used in each line to mark the border of a column are- lined up.- * The text in the first column is rendered as described.--After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--attributes_test_5 = Test - { test_name = "Character attributes: 240 color palette"- , test_ID = "attributes_test_5"- , test_action = do- t <- terminal_handle- reserve_display t- let pic = pic_for_image image- image = vert_cat $ map horiz_cat $ split_color_images color_images- color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]- split_color_images [] = []- split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))- d <- display_bounds t >>= display_context t- output_picture d pic- getLine- release_display t- release_terminal t- return ()- , print_summary = do- putStr $ [s|-Once return is pressed:- 0. The screen will be cleared.- 1. The cursor will be hidden.- 2. A 20 character wide and 12 row high block of color squares. This should look like a palette- of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...--Verify: --After return is pressed for the second time:- 0. The screen containing the test summary should be restored.- 1. The cursor should be visible.-|]- , confirm_results = do- putStr $ [s|-Did the test output match the description?-|]- default_success_confirm_results- }--inline_test_0 = Test- { test_name = "Verify styled output can be performed without clearing the screen."- , test_ID = "inline_test_0"- , test_action = do- t <- terminal_handle- putStrLn "line 1."- put_attr_change t $ back_color red >> apply_style underline- putStrLn "line 2."- put_attr_change t $ default_all- putStrLn "line 3."- release_terminal t- return ()- , print_summary = putStr $ [s|-lines are in order.-The second line "line 2" should have a red background and the text underline.-The third line "line 3" should be drawn in the same style as the first line.-|]-- , confirm_results = generic_output_match_confirm- }--inline_test_1 = Test- { test_name = "Verify styled output can be performed without clearing the screen."- , test_ID = "inline_test_1"- , test_action = do- t <- terminal_handle- putStr "Not styled. "- put_attr_change t $ back_color red >> apply_style underline- putStr " Styled! "- put_attr_change t $ default_all- putStrLn "Not styled."- release_terminal t- return ()- , print_summary = putStr $ [s|-|]-- , confirm_results = generic_output_match_confirm- }--inline_test_2 = Test- { test_name = "Verify styled output can be performed without clearing the screen."- , test_ID = "inline_test_1"- , test_action = do- t <- terminal_handle- putStr "Not styled. "- put_attr_change t $ back_color red >> apply_style underline- putStr " Styled! "- put_attr_change t $ default_all- putStr "Not styled.\n"- release_terminal t- return ()- , print_summary = putStr $ [s|-|]- , confirm_results = generic_output_match_confirm- }--cursor_hide_test_0 :: Test-cursor_hide_test_0 = Test- { test_name = "Verify the cursor is hid and re-shown. issue #7"- , test_ID = "cursor_hide_test_0"- , test_action = do- vty <- mkVty- show_cursor $ terminal vty- set_cursor_pos (terminal vty) 5 5- next_event vty- hide_cursor $ terminal vty- next_event vty- shutdown vty- return ()- , print_summary = putStr $ [s|- 1. verify the cursor is displayed.- 2. press enter- 3. verify the cursor is hid.- 4. press enter.- 5. the display should return to the state before the test.-|]- , confirm_results = generic_output_match_confirm- }-
vty.cabal view
@@ -1,640 +1,86 @@ name: vty-version: 4.7.5+version: 6.6 license: BSD3 license-file: LICENSE author: AUTHORS-maintainer: Corey O'Connor (coreyoconnor@gmail.com)-homepage: https://github.com/coreyoconnor/vty+maintainer: Jonathan Daugherty (cygnus@foobox.com)+homepage: https://github.com/jtdaugherty/vty category: User Interfaces 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.- .- Included in the source distribution is a program test/interactive_terminal_test.hs that- demonstrates the various features. - .- If your terminal is not behaving as expected the results of the vty-interactive-terminal-test- executable should be sent to the Vty maintainter to aid in debugging the issue.- .- Notable infelicities: Sometimes poor efficiency; Assumes UTF-8 character encoding support by the- terminal;- .- Project is hosted on github.com: https://github.com/coreyoconnor/vty+ vty is terminal GUI library in the niche of ncurses. It is intended to+ be easy to use and to provide good support for common terminal types. .- git clone git://github.com/coreyoconnor/vty.git+ See the example programs in the @vty-crossplatform@ package examples+ on how to use the library. . © 2006-2007 Stefan O'Rear; BSD3 license. . © Corey O'Connor; BSD3 license.--- the test suites require >= 1.17.0-cabal-version: >= 1.14.0-build-type: Simple-data-files: README,- TODO,+ .+ © Jonathan Daugherty; BSD3 license.+cabal-version: 1.18+build-type: Simple+extra-doc-files: README.md, AUTHORS,- CHANGELOG,+ CHANGELOG.md, LICENSE+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+ location: https://github.com/jtdaugherty/vty.git+ library default-language: Haskell2010- build-depends: base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7-- exposed-modules: Graphics.Vty- Graphics.Vty.Attributes- Graphics.Vty.DisplayRegion- Graphics.Vty.Image- Graphics.Vty.Inline- Graphics.Vty.LLInput- Graphics.Vty.Picture- Graphics.Vty.Terminal- Codec.Binary.UTF8.Width-- other-modules: Data.Marshalling- Data.Terminfo.Parse- Data.Terminfo.Eval- Graphics.Vty.Attributes.Color- Graphics.Vty.Attributes.Color240- Graphics.Vty.DisplayAttributes- Graphics.Vty.Span- Graphics.Vty.Terminal.Generic- Graphics.Vty.Terminal.MacOSX- Graphics.Vty.Terminal.XTermColor- Graphics.Vty.Terminal.TerminfoBased-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c- include-dirs: cbits- hs-source-dirs: src-- ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10-- ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10-- cc-options: -O2--test-suite verify-attribute-ops- default-language: Haskell2010- type: detailed-0.9- hs-source-dirs: src test- test-module: VerifyAttributeOps- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,+ 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.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-using-mock-terminal- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test+ deepseq >= 1.1 && < 1.6,+ microlens < 0.6,+ microlens-mtl,+ mtl >= 1.1.1.0 && < 2.4,+ stm,+ text >= 0.11.3,+ utf8-string >= 0.3.1 && < 1.1,+ vector >= 0.7,+ binary,+ parsec,+ filepath,+ directory - test-module: VerifyMockTerminal+ if !impl(ghc >= 8.0)+ build-depends: semigroups >= 0.16,+ fail - other-modules: Graphics.Vty+ exposed-modules: Graphics.Text.Width+ Graphics.Vty Graphics.Vty.Attributes- Graphics.Vty.DisplayAttributes- Graphics.Vty.DisplayRegion- Graphics.Vty.Image- Graphics.Vty.Picture- Graphics.Vty.Span- Graphics.Vty.Terminal- Graphics.Vty.Terminal.Generic- Graphics.Vty.Terminal.Debug+ Graphics.Vty.Attributes.Color+ Graphics.Vty.Attributes.Color240+ Graphics.Vty.Config Graphics.Vty.Debug- Graphics.Vty.Debug.Image- Codec.Binary.UTF8.Width- Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.DisplayRegion- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-display-attributes- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyDisplayAttributes-- other-modules: Graphics.Vty- Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes- Graphics.Vty.DisplayRegion- Graphics.Vty.Image- Graphics.Vty.Picture- Graphics.Vty.Span- Graphics.Vty.Terminal- Graphics.Vty.Terminal.Generic- Graphics.Vty.Terminal.Debug- Graphics.Vty.Debug- Graphics.Vty.Debug.Image- Codec.Binary.UTF8.Width- Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.DisplayRegion- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-empty-image-props- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyEmptyImageProps-- other-modules: Graphics.Vty.Picture- Verify-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-eval-terminfo-caps- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyEvalTerminfoCaps-- other-modules: Data.Terminfo.Parse- Data.Terminfo.Eval- Data.Marshalling- Codec.Binary.UTF8.Width- Verify-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-image-ops- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyImageOps-- other-modules: Graphics.Vty.Attributes- Graphics.Vty.DisplayAttributes- Graphics.Vty.DisplayRegion- Graphics.Vty.Image- Graphics.Vty.Picture- Graphics.Vty.Span- Graphics.Vty.Debug.Image- Codec.Binary.UTF8.Width- Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Image-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-image-trans- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyImageTrans-- other-modules: Graphics.Vty.Attributes- Graphics.Vty.Debug.Image- Graphics.Vty.Image- Codec.Binary.UTF8.Width- Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.Image-- c-sources: cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-inline- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyInline-- other-modules: Codec.Binary.UTF8.Width- Data.Terminfo.Eval- Data.Terminfo.Parse- Data.Marshalling- Graphics.Vty.Attributes- Graphics.Vty.DisplayAttributes- Graphics.Vty.DisplayRegion+ Graphics.Vty.Error Graphics.Vty.Image+ Graphics.Vty.Image.Internal Graphics.Vty.Inline- Graphics.Vty.Span- Graphics.Vty.Terminal- Graphics.Vty.Terminal.Generic- Graphics.Vty.Terminal.MacOSX- Graphics.Vty.Terminal.TerminfoBased- Graphics.Vty.Terminal.XTermColor-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-parse-terminfo-caps- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyParseTerminfoCaps-- other-modules: Data.Terminfo.Parse- Verify- Verify.Data.Terminfo.Parse-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-picture-ops- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyPictureOps-- other-modules: Graphics.Vty.Picture- Verify-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-picture-to-span- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyPictureToSpan-- other-modules: Graphics.Vty- Graphics.Vty.Attributes- Graphics.Vty.DisplayAttributes- Graphics.Vty.DisplayRegion- Graphics.Vty.Image- Graphics.Vty.Picture- Graphics.Vty.Span- Graphics.Vty.Terminal- Graphics.Vty.Terminal.Generic- Graphics.Vty.Terminal.Debug- Graphics.Vty.Debug- Graphics.Vty.Debug.Image- Codec.Binary.UTF8.Width- Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.DisplayRegion- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-span-ops- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifySpanOps-- other-modules: Graphics.Vty- Graphics.Vty.Attributes- Graphics.Vty.DisplayAttributes- Graphics.Vty.DisplayRegion- Graphics.Vty.Image+ Graphics.Vty.Input+ Graphics.Vty.Input.Events+ Graphics.Vty.Output+ Graphics.Vty.Output.Mock Graphics.Vty.Picture+ Graphics.Vty.PictureToSpans Graphics.Vty.Span- Graphics.Vty.Terminal- Graphics.Vty.Terminal.Generic- Graphics.Vty.Terminal.Debug- Graphics.Vty.Debug- Graphics.Vty.Debug.Image- Codec.Binary.UTF8.Width- Verify- Verify.Graphics.Vty.Attributes- Verify.Graphics.Vty.DisplayRegion- Verify.Graphics.Vty.Picture- Verify.Graphics.Vty.Image- Verify.Graphics.Vty.Span-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--test-suite verify-utf8-width- default-language: Haskell2010-- type: detailed-0.9-- hs-source-dirs: src test-- test-module: VerifyUtf8Width-- other-modules: Codec.Binary.UTF8.Width- Graphics.Vty.Attributes- Graphics.Vty.Image- Verify-+ Graphics.Vty.UnicodeWidthTable.IO+ Graphics.Vty.UnicodeWidthTable.Install+ Graphics.Vty.UnicodeWidthTable.Main+ Graphics.Vty.UnicodeWidthTable.Query+ Graphics.Vty.UnicodeWidthTable.Types c-sources: cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: Cabal == 1.17.*,- QuickCheck >= 2.4,- random == 1.0.*,- base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7--executable vty-interactive-terminal-test- main-is: interactive_terminal_test.hs-- default-language: Haskell2010-- hs-source-dirs: src test-- c-sources: cbits/gwinsz.c- cbits/set_term_timing.c- cbits/mk_wcwidth.c-- include-dirs: cbits-- build-depends: base >= 4 && < 5,- bytestring,- containers,- deepseq >= 1.1 && < 1.4,- ghc-prim,- mtl >= 1.1.1.0 && < 2.2,- parallel >= 2.2 && < 3.3,- parsec >= 2 && < 4,- string-qq,- terminfo >= 0.3 && < 0.5,- unix,- utf8-string >= 0.3 && < 0.4,- vector >= 0.7---- Bench.hs--- Bench2.hs--- BenchRenderChar.hs--- ControlTable.hs--- HereDoc.hs--- Test.hs--- Test2.hs--- Verify.hs--- Verify/Data/Terminfo/Parse.hs--- Verify/Graphics/Vty/Attributes.hs--- Verify/Graphics/Vty/DisplayRegion.hs--- Verify/Graphics/Vty/Image.hs--- Verify/Graphics/Vty/Picture.hs--- Verify/Graphics/Vty/Span.hs--- vty_inline_example.hs--- vty_issue_18.hs--- yi_issue_264.hs-