vty 3.1.8.4 → 6.6
raw patch · 45 files changed
Files
- AUTHORS +22/−0
- CHANGELOG.md +1113/−0
- Graphics/Vty.hs +0/−127
- Graphics/Vty/ControlStrings.hs +0/−16
- Graphics/Vty/Cursor.hs +0/−64
- Graphics/Vty/LLInput.hs +0/−225
- Graphics/Vty/Output.hs +0/−114
- Graphics/Vty/Types.hs +0/−177
- LICENSE +3/−1
- README +0/−54
- README.md +173/−0
- TODO +0/−8
- cbits/gwinsz.c +0/−9
- cbits/gwinsz.h +0/−1
- cbits/mk_wcwidth.c +351/−0
- cbits/set_term_timing.c +0/−14
- src/Graphics/Text/Width.hs +64/−0
- src/Graphics/Vty.hs +249/−0
- src/Graphics/Vty/Attributes.hs +228/−0
- src/Graphics/Vty/Attributes/Color.hs +173/−0
- src/Graphics/Vty/Attributes/Color240.hs +301/−0
- src/Graphics/Vty/Config.hs +438/−0
- src/Graphics/Vty/Debug.hs +44/−0
- src/Graphics/Vty/DisplayAttributes.hs +173/−0
- src/Graphics/Vty/Error.hs +11/−0
- src/Graphics/Vty/Image.hs +376/−0
- src/Graphics/Vty/Image/Internal.hs +244/−0
- src/Graphics/Vty/Inline.hs +124/−0
- src/Graphics/Vty/Input.hs +32/−0
- src/Graphics/Vty/Input/Events.hs +100/−0
- src/Graphics/Vty/Output.hs +367/−0
- src/Graphics/Vty/Output/Mock.hs +90/−0
- src/Graphics/Vty/Picture.hs +128/−0
- src/Graphics/Vty/PictureToSpans.hs +351/−0
- src/Graphics/Vty/Span.hs +144/−0
- 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/Bench.hs +0/−47
- test/Test.hs +0/−29
- test/Test2.hs +0/−12
- test/make_tests.sh +0/−10
- vty.cabal +78/−49
+ AUTHORS view
@@ -0,0 +1,22 @@+The following people should be thanked for contributing to the vty+library:++ * Andrea Vezzosi+ * Corey O'Connor+ * Emily Backes+ * Josef Svenningsson+ * Nicolas Pouillard+ * Roman Cheplyaka+ * Stefan O'Rear+ * Yusaku Hashimoto+ * allan.clark+ * gwern0+ * jeanphilippe.bernardy+ * m.niloc+ * mikesteele81+ * Mikolaj Konarski+ * Eyal Lotem+ * Yoshikuni Jujo+ * Dmitry Ivanov++Plus others.. Check the git log and CHANGELOG.md for a full list.
+ 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
− Graphics/Vty.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-{-# 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(..)- , beep- , mkVty- , mkVtyEscDelay- , module Graphics.Vty.Types- , Key(..)- , Modifier(..)- , Button(..)- , Event(..)- ) - where--import Control.Concurrent--import Graphics.Vty.Types -import qualified Graphics.Vty.Types as T(Color(..), Attr(..), Image(..), fillSeg)-import Graphics.Vty.Cursor-import Graphics.Vty.LLInput-import Graphics.Vty.Output--import Foreign.Marshal.Array-import Foreign.Marshal.Alloc-import Foreign.Marshal.Error-import Foreign.Storable-import Foreign.Ptr--import System.Console.Terminfo---- |The main object. At most one should be created.-data Vty = Vty { -- |Update the screen to reflect the contents of a 'Picture'.- -- This is not currently threadsafe.- update :: Picture -> IO (),- -- |Get one Event object, blocking if necessary.- getEvent :: IO Event,- -- |Get the size of the display.- getSize :: IO (Int,Int),- -- |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.- shutdown :: IO () - }---- |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--mkVtyEscDelay :: Int -> IO Vty-mkVtyEscDelay escDelay = do - terminal <- setupTermFromEnv - (tstate, endo) <- initTermOutput terminal- (kvar, endi) <- initTermInput escDelay terminal- state <- newMVar =<< fmap ((,,,) tstate (-1) (-1)) (mallocArray 2)- intMkVty kvar (endi >> endo) state---intMkVty :: IO Event -> IO () -> MVar (TermState, Int, Int, Ptr Int) -> IO Vty-intMkVty kvar fend rstate = - return $ Vty { update = update' - , getEvent = gkey- , getSize = ulift getwinsize- , refresh = refr- , shutdown = fend - }- where- ulift :: (TermState -> IO (a, TermState)) -> IO a- ulift f = modifyMVar rstate (\(v,a,b,c) -> fmap (\(x,y) -> ((y,a,b,c),x)) (f v))-- update' (Pic nc (T.Image wr w h)) = modifyMVar_ rstate $ \(ts0, fbw, fbh, oldptr) -> do- (shd,ts1) <- case (fbw,fbh) == (w,h) of- True -> return (oldptr,ts0)- False -> do new <- throwIfNull "clrscr realloc" $ reallocArray oldptr (w * h * 2)- T.fillSeg attr ' ' new (new `advancePtr` (w * h * 2))- fmap ((,) new) (clrscr ts0)- fb <- throwIfNull "update alloc" $ mallocArray (w * h * 2)- wr (w * 2 * sizeOf (undefined :: Int)) fb- ts2 <- diffs w h shd fb ts1- ts3 <- case nc of - NoCursor -> setCursorInvis ts2- Cursor x y -> move w x y ts2 >>= setCursorVis- ts4 <- flush ts3- free shd- return (ts4, w, h, fb)-- -- just refresh- refr = modifyMVar_ rstate $ \(ts0,_,_,p) -> - fmap (\(_,ts1) -> (ts1,(-1),(-1),p)) (getwinsize ts0)-- -- refresh and return a state event- inval = modifyMVar rstate $ \(ts0,_,_,p) -> - fmap (\((x,y),ts1) -> ((ts1,(-1),(-1),p),EvResize x y)) (getwinsize ts0)-- gkey = do k <- kvar- case k of - (EvResize _ _) -> inval- _ -> return k--{- |Given the width and height of a text region along with the old text for the region and the new- - text for the region this only outputs the changes between the two regions to the terminal.- - TODO: This needs to be updated to account for issue #10. - -}-diffs :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState-diffs !w !h !old !new !state = diffs' 0 0 old new state- where- diffs' :: Int -> Int -> Ptr Int -> Ptr Int -> TermState -> IO TermState- diffs' !x !y !olp !nwp !stat- | y == h = return stat- | x == w = diffs' 0 (y+1) olp nwp stat- | otherwise = do ola <- peek olp- nwa <- peek nwp- olc <- peekElemOff olp 1- nwc <- peekElemOff nwp 1- stat' <- case (ola /= nwa || olc /= nwc) of- False -> return stat- True -> mvputch w x y (toEnum nwc) (Attr nwa) stat- diffs' (x+1) y (olp `advancePtr` 2) (nwp `advancePtr` 2) stat'--
− Graphics/Vty/ControlStrings.hs
@@ -1,16 +0,0 @@-module Graphics.Vty.ControlStrings - where--csi, cvis, civis :: String--csi = "\ESC["--setCursorPosition :: Int -> Int -> String-setCursorPosition row column = csi ++ show row ++ ";" ++ show column ++ "H"---- | Show the cursor-cvis = csi ++ "?25h" ---- | Hide the cursor-civis = csi ++ "?25l"-
− Graphics/Vty/Cursor.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-{-# CFILES gwinsz.c #-}-module Graphics.Vty.Cursor ( move- , setCursorInvis- , setCursorVis - , mvputch- ) - where--import Graphics.Vty.Types-import Graphics.Vty.ControlStrings-import Graphics.Vty.Output ( chgatt- ,tputchar- ,putShow- )--import Control.Monad ( when )--{--import Data.Bits ( (.|.), (.&.), shiftR )-import Data.Maybe ( maybe )--import Foreign.C.Types ( CLong )-import Foreign.Ptr ( Ptr )-import Foreign.Storable ( peekElemOff, peek )-import Foreign.Marshal.Array ( advancePtr )--import System.IO ( stdout, hFlush )--}---- | Move the cursor to (x,y); sx is the current width of the screen.--- (this is a bit of a hack, forcing clients to cache that data)-move :: Int -> Int -> Int -> TermState -> IO TermState-move sx x y (TS ox oy at) = do movcsr y oy x ox sx- return (TS x y at)---- | Put a (char,attr) at a given (x,y) cursor position; sx is the--- current width of the screen. (this is a bit of a hack, forcing--- clients to cache that data)-mvputch :: Int -> Int -> Int -> Char -> Attr -> TermState -> IO TermState-mvputch !sx !x !y !ch !att !(TS ox oy oat) = do - movcsr y oy x ox sx- when (att /= oat) $ chgatt att- tputchar ch- return (TS (x+1) y att)---- | Make the cursor invisible.-setCursorInvis :: TermState -> IO TermState-setCursorInvis ts = putStr civis >> return ts---- | Make the cursor visible.-setCursorVis :: TermState -> IO TermState-setCursorVis ts = putStr cvis >> return ts---- we always use absolute motion between lines to work around diffs-movcsr :: Int -> Int -> Int -> Int -> Int -> IO ()-movcsr y oy x ox wid- | y /= oy || ox == wid = putStr "\ESC[" >> putShow (y+1) >> putChar ';' >> putShow (x+1) >> putChar 'H'- | x == ox = return ()- | x == (ox + 1) = putStr "\ESC[C"- | x > ox = putStr "\ESC[" >> putShow (x - ox) >> putChar 'C'- | otherwise = putStr "\ESC[" >> putShow (ox - x) >> putChar 'D'-{-# INLINE movcsr #-}-
− Graphics/Vty/LLInput.hs
@@ -1,225 +0,0 @@-{-# 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.Extensible--import System.Console.Terminfo--import System.Posix.Signals.Exts-import System.Posix.Signals-import System.Posix.Terminal-import System.Posix.IO ( stdInput- ,fdRead- ,setFdOption- ,FdOption(..)- )---- |Representations of non-modifier keys.-data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns- | KHome | KPageUp | KDel | KEnd | KPageDown | 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]- 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 -> loop ""- 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 = loop- where - loop = do- setFdOption stdInput NonBlockingRead False- threadWaitRead stdInput- setFdOption stdInput NonBlockingRead True- try readAll :: IO (Either IOException ())- when (escDelay == 0) finishAtomicInput- loop- readAll = do- (bytes, bytes_read) <- fdRead stdInput 1- when (bytes_read > 0) $ do- tryPutMVar hadInput () -- signal input- writeChan inputChannel (head bytes)- readAll- -- | 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?- 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 ],-- -- Support for arrows- [("\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)] -- directions and their codes- ],- - let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6] [KIns,KDel,KPageUp,KPageDown],-- -- 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- 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 "set_term_timing" set_term_timing :: IO ()-
− Graphics/Vty/Output.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# CFILES gwinsz.c #-}-module Graphics.Vty.Output ( initTermOutput- , clrscr- , getwinsize- , beep- , flush- , tputchar- , chgatt- , putShow- )- where--import Graphics.Vty.Types-import Graphics.Vty.ControlStrings--import Control.Monad ( when )-import Data.Bits ( (.|.), (.&.), shiftR )--import Foreign.C.Types ( CLong )--import System.Console.Terminfo-import System.IO ( stdout, hFlush )---- | Set up the terminal for output, and create an object representing the--- initial state. Also returns a function for shutting down the terminal access.-initTermOutput :: Terminal -> IO (TermState, IO ())-initTermOutput terminal = do - let cap_smcup = getCapability terminal $ tiGetStr "smcup"- maybe (return ()) putStr cap_smcup- putStr reset- hFlush stdout- return (TS 0 0 attr, uninitTermOutput terminal)--uninitTermOutput :: Terminal -> IO ()-uninitTermOutput terminal = do - (_,sy) <- getwinsize_- putStr (endterm sy)- let cap_rmcup = getCapability terminal $ tiGetStr "rmcup"- maybe (return ()) putStr cap_rmcup- hFlush stdout---- | Force sent commands to be respected.-flush :: TermState -> IO TermState-flush ts = hFlush stdout >> return ts---- | Reset the screen.-clrscr :: TermState -> IO TermState-clrscr _ts = do putStr reset- return (TS 0 0 attr)---- ANSI specific bits-chgatt :: Attr -> IO ()-chgatt (Attr bf)- = putStr "\ESC[0;" >>- putShow (bf .&. 0xFF) >> - putStr ";" >> putShow ((bf `shiftR` 8) .&. 0xFF) >> - 0x10000 ? ";1" >>- 0x20000 ? ";5" >> 0x40000 ? ";7" >> 0x80000 ? ";2" >> 0x100000 ? ";4" >> - putStr "m"- where- {-# INLINE (?) #-}- (?) :: Int -> [Char] -> IO ()- field ? x | bf .&. field == 0 = return ()- | otherwise = putStr x--tputchar :: Char -> IO ()-tputchar ch | ich < 0x80 = pch ich- | ich < 0x800 = pch (0xC0 .|. (ich `usr` 6)) >> pch (0x80 .|. (0x3F .&. ich))- | ich < 0x10000 = pch (0xE0 .|. (ich `usr` 12)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >>- pch (0x80 .|. (0x3F .&. ich))- | otherwise = pch (0xF0 .|. (ich `usr` 24)) >> pch (0x80 .|. (0x3F .&. (ich `usr` 12))) >>- pch (0x80 .|. (0x3F .&. (ich `usr` 6))) >> pch (0x80 .|. (0x3F .&. ich))- where ich = fromEnum ch- pch = putChar . toEnum- usr = shiftR--putShow :: Int -> IO ()-putShow n = when (ini /= 0) (putShow ini) >> putChar (toEnum (lst + 48))- where (ini, lst) = divMod n 10--- {-# INLINE putShow #-}--foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong-getwinsize_ :: IO (Int,Int)-getwinsize_ = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size- return (fromIntegral b, fromIntegral a)-getwinsize :: TermState -> IO ((Int,Int), TermState)-getwinsize ts = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size- return ((fromIntegral b, fromIntegral a), ts)--reset :: String-reset = -- "\ESCc" ++ -- full reset- utf8CharSet ++ - setCursorPosition 1 1 ++- "\ESC[2J" -- erase all---- | Make the terminal beep.-beep :: IO ()-beep = putStr "\BEL" ---- | Restore the terminal to a good state for the shell.--- Parameter is the line where the cursor should appear.-endterm :: Int -> [Char]-endterm sy = setCursorPosition sy 1 ++- "\ESC[0;39;49m" ++ -- graphic rendition- defaultCharSet ++ - "\CR" ++ - cvis ++- "\ESC[K" -- erase line--defaultCharSet, utf8CharSet :: String-defaultCharSet = "\ESC%@"-utf8CharSet = "\ESC%G"-
− Graphics/Vty/Types.hs
@@ -1,177 +0,0 @@-module Graphics.Vty.Types - where--import Data.Bits( (.&.), (.|.), shiftL )--import Foreign.Ptr-import Foreign.Storable-import Foreign.C.Types (CChar)-import Foreign.Marshal.Array-import qualified Data.ByteString as B--infixr 5 <|>-infixr 4 <->---- |This type represents the visible cursor state.-data Cursor = NoCursor -- ^ Hide the cursor.- | Cursor Int Int -- ^ Display the cursor at the given XY position.---- | An object representing the current state of the terminal.-data TermState = TS {_tsRow :: !Int, _tsColumn :: !Int, _tsAttr :: !Attr}---- Gah. GHC can't unbox bitfields itself :(---- | Opaque data type representing character attributes.-newtype Attr = Attr Int deriving (Eq)---- | Set the foreground color of an `Attr'.-setFG :: Color -> Attr -> Attr-setFG (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. (30 + c))---- | Set the background color of an `Attr'.-setBG :: Color -> Attr -> Attr-setBG (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. ((40 + c) `shiftL` 8))---- | Set the foreground color of an `Attr'.-setFGVivid :: Color -> Attr -> Attr-setFGVivid (Color c) (Attr a) = Attr ((a .&. 0xFFFFFF00) .|. (90 + c))---- | Set the background color of an `Attr'.-setBGVivid :: Color -> Attr -> Attr-setBGVivid (Color c) (Attr a) = Attr ((a .&. 0xFFFF00FF) .|. ((100 + c) `shiftL` 8))-- --- | Set bold attribute of an `Attr'.-setBold :: Attr -> Attr-setBold (Attr a) = Attr (a .|. 0x10000)---- | Set blink attribute of an `Attr'.-setBlink :: Attr -> Attr-setBlink (Attr a) = Attr (a .|. 0x20000)---- | Set reverse-video attribute of an `Attr'.-setRV :: Attr -> Attr-setRV (Attr a) = Attr (a .|. 0x40000)---- | Set half-bright attribute of an `Attr'.-setHalfBright :: Attr -> Attr-setHalfBright (Attr a) = Attr (a .|. 0x80000)---- | Set underline attribute of an `Attr'.-setUnderline :: Attr -> Attr-setUnderline (Attr a) = Attr (a .|. 0x100000)---- |'Attr' with all default values.-attr :: Attr-attr = Attr 0x909---- |Abstract data type representing a color.-newtype Color = Color Int deriving(Eq)---- FIXME: this assumes a 8-color terminal.--- |Basic color definitions.-black, red, green, yellow, blue, magenta, cyan, white, def :: Color-black = Color 0 ; red = Color 1 ; green = Color 2 ; yellow = Color 3-blue = Color 4 ; magenta= Color 5 ; cyan = Color 6 ; white = Color 7-def = Color 9---- This uses a somewhat tricky implementation, for efficiency.---- |A two-dimensional array of (Char,Attr) pairs.-data Image = Image (Int -> Ptr Int -> IO ()) !Int !Int---- | Access the width of an Image.-imgWidth :: Image -> Int-imgWidth (Image _ w _) = w---- | Access the height of an Image.-imgHeight :: Image -> Int-imgHeight (Image _ _ h) = h---- | The empty image.-empty :: Image-empty = Image (\_ _ -> return ()) 0 0---- | Compose two images side by side. The images must of the same height,--- or one must be empty.-(<|>) :: Image -> Image -> Image-Image f1 x1 y1 <|> Image f2 x2 y2 | y1 == y2 || x1 == 0 || x2 == 0 =- Image (\stride ptr -> do f1 stride ptr- f2 stride (ptr `plusPtr` ((sizeOf (undefined :: Int) * 2) * x1)))- (x1+x2) (max y1 y2)-_ <|> _ = error "Graphics.Vty.(<|>) : image heights do not match"---- | Compose two images vertically. The images must of the same width,--- or one must be empty.-(<->) :: Image -> Image -> Image-Image f1 x1 y1 <-> Image f2 x2 y2 | x1 == x2 || y1 == 0 || y2 == 0 =- Image (\stride ptr -> do f1 stride ptr- f2 stride (ptr `plusPtr` (stride * y1)))- (max x1 x2) (y1+y2)-_ <-> _ = error "Graphics.Vty.(<->) : image widths do not match"---- | Helper - fill a buffer segment with a char\/attr.-fillSeg :: Attr -> Char -> Ptr Int -> Ptr Int -> IO ()-fillSeg (Attr a) ch p1 pe = a `seq` ch `seq` pe `seq` worker p1- where- worker p | p == pe = return ()- | otherwise = do pokeElemOff p 0 a- pokeElemOff p 1 (fromEnum ch)- worker (p `advancePtr` 2)---- | Compose any number of images horizontally.-horzcat :: [Image] -> Image-horzcat = foldr (<|>) empty---- | Compose any number of images vertically.-vertcat :: [Image] -> Image-vertcat = foldr (<->) empty---- | Create an `Image' from a `B.ByteString' with a single uniform `Attr'.-renderBS :: Attr -> B.ByteString -> Image-renderBS (Attr a) bs = a `seq` Image (\ _stride ptr -> B.useAsCStringLen bs (worker ptr)) (B.length bs) 1- where- worker :: Ptr Int -> (Ptr CChar, Int) -> IO ()- worker _op (_ip, 0) = return ()- worker op (ip, ct) = do inp <- peek ip- pokeElemOff op 0 a- pokeElemOff op 1 (fromIntegral inp)- worker (op `advancePtr` 2) ((ip `advancePtr` 1), (ct - 1))---- | Create a 1x1 image. Warning, this is likely to be inefficient.-renderChar :: Attr -> Char -> Image-renderChar (Attr a) ch = a `seq` ch `seq` Image (\ _stride ptr -> pokeElemOff ptr 0 a >> pokeElemOff ptr 1 (fromEnum ch)) 1 1---- | Create an image by repeating a single character and attribute horizontally.-renderHFill :: Attr -> Char -> Int -> Image-renderHFill _ _ w | w < 0 || w > 10000 = error "renderHFill: bizarre width"-renderHFill a ch w = a `seq` ch `seq` Image (\ _stride ptr -> fillSeg a ch ptr (ptr `advancePtr` (2*w))) w 1---- | Create an image by repeating a single character and attribute.-renderFill :: Attr -> Char -> Int -> Int -> Image-renderFill _ _ w _ | w < 0 || w > 10000 = error "renderFill: bizarre width"-renderFill _ _ _ h | h < 0 || h > 10000 = error "renderFill: bizarre height"-renderFill (Attr a) ch w h = a `seq` ch `seq` Image (worker h) w h- where- worker :: Int -> Int -> Ptr Int -> IO ()- worker 0 _stride _ptr = return ()- worker ct stride ptr = do let ptr2 = ptr `advancePtr` (2 * w)- fillSeg (Attr a) ch ptr ptr2- worker (ct - 1) stride ptr2---- |The type of images to be displayed using 'update'. You probably shouldn't--- create this directly if you care about compatibility with future versions of--- vty; instead use 'pic' and record update syntax.-data Picture = Pic { -- |The position and visibility status of the virtual- -- cursor.- pCursor :: Cursor,- -- |A 2d array of (character,attribute) pairs, representing- -- the screen image.- pImage :: Image }---- |Create a 'Picture' object with all default values. By using this and record--- update, rather than directly using the Pic constructor, your code will be--- compatible with additions to the Picture object. You must specify at least--- 'pImage'.-pic :: Picture-pic = Pic { pCursor = NoCursor, pImage = error "Pic.pImage not initialized" }
LICENSE view
@@ -1,4 +1,6 @@-Copyright Stefan O'Rear 2006+BSD 3-Clause License++Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved.
− README
@@ -1,54 +0,0 @@-vty is a very simple terminal interface library.--Vty currently provides:--* Automatic handling of suspend/resume (SIGTSTP+SIGCONT).--* Automatic handling of window resizes.--* Supports Unicode characters on output, automatically setting and- resetting UTF-8 mode (beware double width and combining characters!)--* Automatic computation of minimal differences.--* 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 simple type-safe interface.--* Properly handles cleanup, leaving the cursor at the bottom of- the screen and erasing the last line.--Current disadvantages:--* No current support for non-ANSI terminals.--* UTF-8 support only works properly on the linux console/xterm,- and even then only if it is not the system default.--* 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.--darcs get --tag=rel-3.0.0 http://code.haskell.org/vty/--To compile the demonstration program: ghc --make 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,8 +0,0 @@-Minor:-- xterm keyboard support-- Termcap/terminfo parser-- 256 color support (xterm)-- Improve input handling performance.--Major:-- Remove size fields in resize constr
− cbits/gwinsz.c
@@ -1,9 +0,0 @@-#include <sys/ioctl.h>--unsigned long 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/gwinsz.h
@@ -1,1 +0,0 @@-unsigned long c_get_window_size(void);
+ cbits/mk_wcwidth.c view
@@ -0,0 +1,351 @@+/*+ * This is an implementation of wcwidth() and wcswidth() (defined in+ * IEEE Std 1002.1-2001) for Unicode.+ *+ * http://www.opengroup.org/onlinepubs/007904975/functions/wcwidth.html+ * http://www.opengroup.org/onlinepubs/007904975/functions/wcswidth.html+ *+ * In fixed-width output devices, Latin characters all occupy a single+ * "cell" position of equal width, whereas ideographic CJK characters+ * occupy two such cells. Interoperability between terminal-line+ * applications and (teletype-style) character terminals using the+ * UTF-8 encoding requires agreement on which character should advance+ * the cursor by how many cell positions. No established formal+ * standards exist at present on which Unicode character shall occupy+ * how many cell positions on character terminals. These routines are+ * a first attempt of defining such behavior based on simple rules+ * applied to data provided by the Unicode Consortium.+ *+ * For some graphical characters, the Unicode standard explicitly+ * defines a character-cell width via the definition of the East Asian+ * FullWidth (F), Wide (W), Half-width (H), and Narrow (Na) classes.+ * In all these cases, there is no ambiguity about which width a+ * terminal shall use. For characters in the East Asian Ambiguous (A)+ * class, the width choice depends purely on a preference of backward+ * compatibility with either historic CJK or Western practice.+ * Choosing single-width for these characters is easy to justify as+ * the appropriate long-term solution, as the CJK practice of+ * displaying these characters as double-width comes from historic+ * implementation simplicity (8-bit encoded characters were displayed+ * single-width and 16-bit ones double-width, even for Greek,+ * Cyrillic, etc.) and not any typographic considerations.+ *+ * Much less clear is the choice of width for the Not East Asian+ * (Neutral) class. Existing practice does not dictate a width for any+ * of these characters. It would nevertheless make sense+ * typographically to allocate two character cells to characters such+ * as for instance EM SPACE or VOLUME INTEGRAL, which cannot be+ * represented adequately with a single-width glyph. The following+ * routines at present merely assign a single-cell width to all+ * neutral characters, in the interest of simplicity. This is not+ * entirely satisfactory and should be reconsidered before+ * establishing a formal standard in this area. At the moment, the+ * decision which Not East Asian (Neutral) characters should be+ * represented by double-width glyphs cannot yet be answered by+ * applying a simple rule from the Unicode database content. Setting+ * up a proper standard for the behavior of UTF-8 character terminals+ * will require a careful analysis not only of each Unicode character,+ * but also of each presentation form, something the author of these+ * routines has avoided to do so far.+ *+ * http://www.unicode.org/unicode/reports/tr11/+ *+ * Markus Kuhn -- 2007-05-26 (Unicode 5.0)+ *+ * Permission to use, copy, modify, and distribute this software+ * for any purpose and without fee is hereby granted. The author+ * disclaims all warranties with regard to this software.+ *+ * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c+ */++#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(HsChar ucs, const struct interval *table, int max) {+ int min = 0;+ int mid;++ if (ucs < table[0].first || ucs > table[max].last)+ return 0;+ while (max >= min) {+ mid = (min + max) / 2;+ if (ucs > table[mid].last)+ min = mid + 1;+ else if (ucs < table[mid].first)+ max = mid - 1;+ else+ return 1;+ }++ return 0;+}+++/* The following two functions define the column width of an ISO 10646+ * character as follows:+ *+ * - The null character (U+0000) has a column width of 0.+ *+ * - Other C0/C1 control characters and DEL will lead to a return+ * value of -1.+ *+ * - Non-spacing and enclosing combining characters (general+ * category code Mn or Me in the Unicode database) have a+ * column width of 0.+ *+ * - SOFT HYPHEN (U+00AD) has a column width of 1.+ *+ * - Other format characters (general category code Cf in the Unicode+ * database) and ZERO WIDTH SPACE (U+200B) have a column width of 0.+ *+ * - Hangul Jamo medial vowels and final consonants (U+1160-U+11FF)+ * have a column width of 0.+ *+ * - Spacing characters in the East Asian Wide (W) or East Asian+ * Full-width (F) category as defined in Unicode Technical+ * Report #11 have a column width of 2.+ *+ * - All remaining characters (including all printable+ * ISO 8859-1 and WGL4 characters, Unicode control characters,+ * etc.) have a column width of 1.+ *+ * This implementation assumes that wchar_t characters are encoded+ * in ISO 10646.+ */++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" */+ static const struct interval combining[] = {+ { 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 },+ { 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 },+ { 0x05C4, 0x05C5 }, { 0x05C7, 0x05C7 }, { 0x0600, 0x0603 },+ { 0x0610, 0x0615 }, { 0x064B, 0x065E }, { 0x0670, 0x0670 },+ { 0x06D6, 0x06E4 }, { 0x06E7, 0x06E8 }, { 0x06EA, 0x06ED },+ { 0x070F, 0x070F }, { 0x0711, 0x0711 }, { 0x0730, 0x074A },+ { 0x07A6, 0x07B0 }, { 0x07EB, 0x07F3 }, { 0x0901, 0x0902 },+ { 0x093C, 0x093C }, { 0x0941, 0x0948 }, { 0x094D, 0x094D },+ { 0x0951, 0x0954 }, { 0x0962, 0x0963 }, { 0x0981, 0x0981 },+ { 0x09BC, 0x09BC }, { 0x09C1, 0x09C4 }, { 0x09CD, 0x09CD },+ { 0x09E2, 0x09E3 }, { 0x0A01, 0x0A02 }, { 0x0A3C, 0x0A3C },+ { 0x0A41, 0x0A42 }, { 0x0A47, 0x0A48 }, { 0x0A4B, 0x0A4D },+ { 0x0A70, 0x0A71 }, { 0x0A81, 0x0A82 }, { 0x0ABC, 0x0ABC },+ { 0x0AC1, 0x0AC5 }, { 0x0AC7, 0x0AC8 }, { 0x0ACD, 0x0ACD },+ { 0x0AE2, 0x0AE3 }, { 0x0B01, 0x0B01 }, { 0x0B3C, 0x0B3C },+ { 0x0B3F, 0x0B3F }, { 0x0B41, 0x0B43 }, { 0x0B4D, 0x0B4D },+ { 0x0B56, 0x0B56 }, { 0x0B82, 0x0B82 }, { 0x0BC0, 0x0BC0 },+ { 0x0BCD, 0x0BCD }, { 0x0C3E, 0x0C40 }, { 0x0C46, 0x0C48 },+ { 0x0C4A, 0x0C4D }, { 0x0C55, 0x0C56 }, { 0x0CBC, 0x0CBC },+ { 0x0CBF, 0x0CBF }, { 0x0CC6, 0x0CC6 }, { 0x0CCC, 0x0CCD },+ { 0x0CE2, 0x0CE3 }, { 0x0D41, 0x0D43 }, { 0x0D4D, 0x0D4D },+ { 0x0DCA, 0x0DCA }, { 0x0DD2, 0x0DD4 }, { 0x0DD6, 0x0DD6 },+ { 0x0E31, 0x0E31 }, { 0x0E34, 0x0E3A }, { 0x0E47, 0x0E4E },+ { 0x0EB1, 0x0EB1 }, { 0x0EB4, 0x0EB9 }, { 0x0EBB, 0x0EBC },+ { 0x0EC8, 0x0ECD }, { 0x0F18, 0x0F19 }, { 0x0F35, 0x0F35 },+ { 0x0F37, 0x0F37 }, { 0x0F39, 0x0F39 }, { 0x0F71, 0x0F7E },+ { 0x0F80, 0x0F84 }, { 0x0F86, 0x0F87 }, { 0x0F90, 0x0F97 },+ { 0x0F99, 0x0FBC }, { 0x0FC6, 0x0FC6 }, { 0x102D, 0x1030 },+ { 0x1032, 0x1032 }, { 0x1036, 0x1037 }, { 0x1039, 0x1039 },+ { 0x1058, 0x1059 }, { 0x1160, 0x11FF }, { 0x135F, 0x135F },+ { 0x1712, 0x1714 }, { 0x1732, 0x1734 }, { 0x1752, 0x1753 },+ { 0x1772, 0x1773 }, { 0x17B4, 0x17B5 }, { 0x17B7, 0x17BD },+ { 0x17C6, 0x17C6 }, { 0x17C9, 0x17D3 }, { 0x17DD, 0x17DD },+ { 0x180B, 0x180D }, { 0x18A9, 0x18A9 }, { 0x1920, 0x1922 },+ { 0x1927, 0x1928 }, { 0x1932, 0x1932 }, { 0x1939, 0x193B },+ { 0x1A17, 0x1A18 }, { 0x1B00, 0x1B03 }, { 0x1B34, 0x1B34 },+ { 0x1B36, 0x1B3A }, { 0x1B3C, 0x1B3C }, { 0x1B42, 0x1B42 },+ { 0x1B6B, 0x1B73 }, { 0x1DC0, 0x1DCA }, { 0x1DFE, 0x1DFF },+ { 0x200B, 0x200F }, { 0x202A, 0x202E }, { 0x2060, 0x2063 },+ { 0x206A, 0x206F }, { 0x20D0, 0x20EF }, { 0x302A, 0x302F },+ { 0x3099, 0x309A }, { 0xA806, 0xA806 }, { 0xA80B, 0xA80B },+ { 0xA825, 0xA826 }, { 0xFB1E, 0xFB1E }, { 0xFE00, 0xFE0F },+ { 0xFE20, 0xFE23 }, { 0xFEFF, 0xFEFF }, { 0xFFF9, 0xFFFB },+ { 0x10A01, 0x10A03 }, { 0x10A05, 0x10A06 }, { 0x10A0C, 0x10A0F },+ { 0x10A38, 0x10A3A }, { 0x10A3F, 0x10A3F }, { 0x1D167, 0x1D169 },+ { 0x1D173, 0x1D182 }, { 0x1D185, 0x1D18B }, { 0x1D1AA, 0x1D1AD },+ { 0x1D242, 0x1D244 }, { 0xE0001, 0xE0001 }, { 0xE0020, 0xE007F },+ { 0xE0100, 0xE01EF }+ };++ /* test for 8-bit control characters */+ if (ucs == 0)+ return 0;+ if (ucs < 32 || (ucs >= 0x7f && ucs < 0xa0))+ return -1;++ /* binary search in table of non-spacing characters */+ if (vty_bisearch(ucs, combining,+ sizeof(combining) / sizeof(struct interval) - 1))+ return 0;++ /* if we arrive here, ucs is not a combining or C0/C1 control character */++ return 1 ++ (ucs >= 0x1100 &&+ (ucs <= 0x115f || /* Hangul Jamo init. consonants */+ ucs == 0x2329 || ucs == 0x232a ||+ (ucs >= 0x2e80 && ucs <= 0xa4cf &&+ ucs != 0x303f) || /* CJK ... Yi */+ (ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */+ (ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */+ (ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */+ (ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */+ (ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */+ (ucs >= 0xffe0 && ucs <= 0xffe6) ||+ (ucs >= 0x20000 && ucs <= 0x2fffd) ||+ (ucs >= 0x30000 && ucs <= 0x3fffd)));+}++// 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)+{+ if (custom_table_ready) {+ if ((ch >= 0) && (ch < custom_table_size)) {+ uint8_t result = custom_table[ch];++ // The table is filled with UNUSED_CELL values for+ // uninitialized ranges so we can defer to the built-in+ // table in those cases.+ if (result == UNUSED_CELL) {+ return builtin_wcwidth(ch);+ } else {+ return result;+ }+ } else {+ return -1;+ }+ } else {+ return builtin_wcwidth(ch);+ }+}++// 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)+{+ 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;+ }+}++// 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()+{+ if (custom_table_ready || (custom_table == NULL)) {+ return 1;+ } else {+ custom_table_ready = 1;+ return 0;+ }+}++// Returns whether a custom character width table has been marked ready.+int vty_custom_table_ready()+{+ return custom_table_ready;+}++// 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 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/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
@@ -0,0 +1,249 @@+{-# 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.Config+import Graphics.Vty.Input+import Graphics.Vty.Input.Events+import Graphics.Vty.Output+import Graphics.Vty.Picture+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++-- | 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+ }++-- | Attempt to load and install a custom character width table into+-- this process.+--+-- This looks up the specified terminal name in the specified width+-- table map and, if a map file path is found, the map is loaded and+-- installed. This is exposed for Vty platform package implementors;+-- application developers should never need to call this.+installCustomWidthTable :: Maybe FilePath+ -- ^ Optional path to a log file where log+ -- messages should be written when attempting to+ -- load a width table.+ -> Maybe String+ -- ^ Optional width table entry name (usually+ -- the terminal name, e.g. value of @TERM@ on+ -- Unix systems). If omitted, this function does+ -- not attempt to load a table.+ -> [(String, FilePath)]+ -- ^ Mapping from width table entry names to+ -- width table file paths. This is usually+ -- obtained from 'configTermWidthMaps' of+ -- 'VtyUserConfig'.+ -> IO ()+installCustomWidthTable logPath tblName widthMaps = do+ let doLog s = case logPath of+ Nothing -> return ()+ Just path -> appendFile path $ "installWidthTable: " <> s <> "\n"++ customInstalled <- isCustomTableReady+ when (not customInstalled) $ do+ 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++-- | Build a 'Vty' handle from an input/output pair.+--+-- This is exposed for Vty platform package implementors; application+-- developers should never need to call this, and should instead call+-- @mkVty@ or equivalent from their platform package of choice.+mkVtyFromPair :: Input -> Output -> IO Vty+mkVtyFromPair input out = do+ reserveDisplay out++ shutdownVar <- newTVarIO False+ let shutdownIo = do+ alreadyShutdown <- atomically $ swapTVar shutdownVar True+ when (not alreadyShutdown) $ do+ shutdownInput input+ releaseDisplay out+ releaseTerminal out++ 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+ dc <- displayContext out b+ outputPicture dc inPic+ return (b, dc)+ Just (lastBounds, lastContext) -> do+ if b /= lastBounds+ then do+ dc <- displayContext out b+ outputPicture dc inPic+ return (b, dc)+ else do+ outputPicture lastContext inPic+ return (b, lastContext)+ writeIORef lastUpdateRef $ Just updateData+ writeIORef lastPicRef $ Just inPic++ innerRefresh = do+ writeIORef lastUpdateRef Nothing+ bounds <- displayBounds out+ dc <- displayContext out bounds+ writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState+ mPic <- readIORef lastPicRef+ maybe (return ()) innerUpdate mPic++ mkResize = uncurry EvResize <$> displayBounds out++ 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
@@ -0,0 +1,228 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}++-- | Display attributes+--+-- 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+-- 01 => unchanged+-- 10 => set+-- YY - foreground color action+-- 00 => reset to default+-- 01 => unchanged+-- 10 => set+-- ZZ - background color action+-- 00 => reset to default+-- 01 => unchanged+-- 10 => set+-- __ - unused+--+-- Next is the style flags+-- SURBDOI_+-- S - standout+-- U - underline+-- R - reverse video+-- B - blink+-- D - dim+-- O - bold+-- I - italic+-- _ - unused+--+-- Then the foreground color encoded into 8 bits.+-- Then the background color encoded into 8 bits.++-- | 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+ { 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 = Default | KeepCurrent | SetTo !v+ deriving (Eq, Read, Show)++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.+type Style = Word8++-- | Valid style attributes include:+--+-- * standout+--+-- * underline+--+-- * reverseVideo+--+-- * blink+--+-- * dim+--+-- * bold/bright+--+-- * 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+reverseVideo = 0x04+blink = 0x08+dim = 0x10+bold = 0x20+italic = 0x40+strikethrough = 0x80++defaultStyleMask :: Style+defaultStyleMask = 0x00++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.+hasStyle :: Style -> Style -> Bool+hasStyle s bitMask = ( s .&. bitMask ) /= 0++-- | Set the foreground color of an `Attr'.+withForeColor :: Attr -> Color -> Attr+withForeColor attr c = attr { attrForeColor = SetTo c }++-- | Set the background color of an `Attr'.+withBackColor :: Attr -> Color -> Attr+withBackColor attr c = attr { attrBackColor = SetTo c }++-- | Add the given style attribute+withStyle :: Attr -> Style -> Attr+withStyle attr 0 = attr+withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag }++-- | 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 }++-- | 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 `withForeColor` brightMagenta+--+-- 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
@@ -0,0 +1,173 @@+{-# 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.+--+-- * 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:+--+-- * black (0)+--+-- * red (1)+--+-- * green (2)+--+-- * yellow (3)+--+-- * blue (4)+--+-- * magenta (5)+--+-- * cyan (6)+--+-- * 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.+--+-- 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.+--+-- 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 | 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
@@ -0,0 +1,301 @@+-- This header file was generated by ./256colres.pl+module Graphics.Vty.Attributes.Color240+ ( rgbColorToColor240+ , color240CodeToRGB+ )+where++import Data.Word (Word8)+import Text.Printf++-- 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:+--+-- 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)))++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
@@ -0,0 +1,44 @@+-- Copyright 2009-2010 Corey O'Connor+module Graphics.Vty.Debug+ ( MockWindow(..)+ , SpanConstructLog+ , regionForWindow+ , allSpansHaveWidth+ , spanOpsAffectedColumns+ , spanOpsAffectedRows+ , rowOpsAffectedColumns+ , isSetAttr+ )+where++import Graphics.Vty.Attributes+import Graphics.Vty.Image (DisplayRegion)+import Graphics.Vty.Span++import qualified Data.Vector as Vector++rowOpsAffectedColumns :: DisplayOps -> [Int]+rowOpsAffectedColumns ops+ = Vector.toList $ Vector.map spanOpsAffectedColumns ops++allSpansHaveWidth :: DisplayOps -> Int -> Bool+allSpansHaveWidth ops expected+ = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops++spanOpsAffectedRows :: DisplayOps -> Int+spanOpsAffectedRows ops+ = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))++type SpanConstructLog = [SpanConstructEvent]+data SpanConstructEvent = SpanSetAttr Attr++isSetAttr :: Attr -> SpanConstructEvent -> Bool+isSetAttr expectedAttr (SpanSetAttr inAttr)+ | inAttr == expectedAttr = True+isSetAttr _attr _event = False++data MockWindow = MockWindow Int Int+ deriving (Show, Eq)++regionForWindow :: MockWindow -> DisplayRegion+regionForWindow (MockWindow w h) = (w,h)
+ src/Graphics/Vty/DisplayAttributes.hs view
@@ -0,0 +1,173 @@+-- Copyright 2009-2010 Corey O'Connor+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++module Graphics.Vty.DisplayAttributes+ ( DisplayAttrDiff(..)+ , StyleStateChange(..)+ , DisplayColorDiff(..)+ , URLDiff(..)+ , fixDisplayAttr+ , displayAttrDiffs+ )+where++import Graphics.Vty.Attributes++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"+-- abstraction.+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+ 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.+--+-- 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+ { styleDiffs :: [StyleStateChange]+ , foreColorDiff :: DisplayColorDiff+ , backColorDiff :: DisplayColorDiff+ , urlDiff :: URLDiff+ }+ 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 NoLinkChange+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif++-- | Used in the computation of a final style attribute change.+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?+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+ = ColorToDefault+ | NoColorChange+ | SetColor !Color+ deriving (Show, Eq)++-- | 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+ | RemoveReverseVideo+ | ApplyBlink+ | RemoveBlink+ | ApplyDim+ | RemoveDim+ | ApplyBold+ | RemoveBold+ deriving (Show, Eq)++-- 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')+ }++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'+diffColor Nothing Nothing = NoColorChange+diffColor (Just _) Nothing = ColorToDefault++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+ styleDiff s sm rm+ = case (0 == prev .&. s, 0 == cur .&. s) of+ -- not set in either+ (True, True) -> []+ -- set in both+ (False, False) -> []+ -- now set+ (True, False) -> [sm]+ -- now unset+ (False, True) -> [rm]
+ 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
@@ -0,0 +1,376 @@+-- Copyright 2009-2010 Corey O'Connor+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DisambiguateRecordFields #-}+-- | 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 Graphics.Vty.Image.Internal+import Graphics.Text.Width++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++-- | A region of the display (first width, then height)+type DisplayRegion = (Int,Int)++regionWidth :: DisplayRegion -> Int+regionWidth = fst++regionHeight :: DisplayRegion -> Int+regionHeight = snd++infixr 5 <|>+infixr 4 <->++-- | 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++-- | Combines two images horizontally. This is an alias for 'horizJoin'.+--+-- infixr 5+(<|>) :: Image -> Image -> Image+(<|>) = horizJoin++-- | Combines two images vertically. This is an alias for 'vertJoin'.+--+-- infixr 4+(<->) :: Image -> Image -> Image+(<->) = vertJoin++-- | Compose any number of images together horizontally, with the first+-- in the list being leftmost.+horizCat :: [Image] -> Image+horizCat = foldr horizJoin EmptyImage++-- | Compose any number of images vertically, with the first in the list+-- being topmost.+vertCat :: [Image] -> Image+vertCat = foldr vertJoin 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)++-- | 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)++-- | 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 displayWidth = safeWcwidth c+ in HorizText a (TL.singleton c) displayWidth 1++-- | 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 iso10646String or string.+iso10646String :: Attr -> String -> Image+iso10646String a str =+ let displayWidth = safeWcswidth str+ in HorizText a (TL.pack str) displayWidth (length str)++-- | Make an 'Image' from a 'String'.+--+-- 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 = iso10646String++-- | 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)++-- | Make an 'Image' from a UTF-8 encoded lazy bytestring.+utf8Bytestring :: Attr -> BL.ByteString -> Image+utf8Bytestring a bs = text a (TL.decodeUtf8 bs)++-- | Make an 'Image' from a UTF-8 encoded strict bytestring.+utf8Bytestring' :: Attr -> B.ByteString -> Image+utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)++-- | 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++ charWidth :: Num a => a+ charWidth = fromIntegral w++-- | 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.+--+-- 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)++-- | 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++-- | 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 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)++-- | 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
@@ -0,0 +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 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 will print the text+-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red+-- background and underlined.+--+-- @+-- putStr \"Not styled. \"+-- putAttrChange_ $ do+-- backColor red+-- applyStyle underline+-- putStr \" Styled! \"+-- putAttrChange_ $ defaultAll+-- putStrLn \"Not styled.\"+-- @+--+-- '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+module Graphics.Vty.Inline+ ( module Graphics.Vty.Inline+ )+where++import Graphics.Vty+import Graphics.Vty.DisplayAttributes++import Blaze.ByteString.Builder (writeToByteString)++import Control.Monad.State.Strict++import Data.Bits ( (.&.), complement )+import Data.IORef++import System.IO++type InlineM v = State InlineState v++data InlineState =+ InlineState { inlineAttr :: Attr+ , inlineUrlsEnabled :: Bool+ }++-- | Set the background color to the provided 'Color'.+backColor :: Color -> InlineM ()+backColor c = modify $ \s ->+ s { inlineAttr = inlineAttr s `withBackColor` c+ }++-- | Set the foreground color to the provided 'Color'.+foreColor :: Color -> InlineM ()+foreColor c = modify $ \s ->+ s { inlineAttr = inlineAttr s `withForeColor` c+ }++-- | Attempt to change the 'Style' of the following text..+--+-- 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.+--+-- 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.+defaultAll :: InlineM ()+defaultAll = modify $ \s -> s { inlineAttr = defAttr }++-- | Apply the provided display attribute changes to the given terminal+-- output device.+--+-- 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 $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False+ return $ FixedAttr defaultStyleMask Nothing Nothing Nothing+ Just v -> return v+ 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/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
@@ -0,0 +1,128 @@+-- 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 Control.DeepSeq++-- | A Vty picture.+--+-- These can be constructed directly or using `picForImage`.+data Picture = Picture+ { 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 NFData Picture where+ rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()++-- | 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+ }++-- | Create a picture with the given layers, top-most first.+--+-- 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.+--+-- 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)++instance NFData Cursor where+ rnf c = c `seq` ()++-- | A 'Picture' has a background pattern. The background is either:+--+-- * ClearBackground, which shows the layer below or is blank if the+-- bottom layer+-- * A character and a display attribute+--+-- 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
@@ -0,0 +1,144 @@+-- Copyright Corey O'Connor+{-# LANGUAGE GADTs #-}+-- | 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+ ( SpanOp(..)+ , columnsToCharOffset+ , spanOpHasWidth++ , SpanOps+ , spanOpsAffectedColumns+ , splitOpsAt+ , dropOps++ , DisplayOps+ , displayOpsRows+ , displayOpsColumns+ , affectedRegion+ )+where++import Graphics.Vty.Attributes (Attr)+import Graphics.Vty.Image+import Graphics.Vty.Image.Internal ( clipText )++import qualified Data.Text.Lazy as TL+import Data.Vector (Vector)+import qualified Data.Vector as Vector++-- | 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++-- | 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++dropOps :: Int -> SpanOps -> SpanOps+dropOps w = snd . splitOpsAt w++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"++-- | A vector of span operation vectors for display, one per row of the+-- output region.+type DisplayOps = Vector SpanOps++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 ++ ")"++-- | The number of columns the DisplayOps are defined for.+--+-- 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++-- | The number of rows the DisplayOps are defined for.+displayOpsRows :: DisplayOps -> Int+displayOpsRows = Vector.length++affectedRegion :: DisplayOps -> DisplayRegion+affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)++-- | 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++-- | 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/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/Bench.hs
@@ -1,47 +0,0 @@-import Graphics.Vty-import System.IO-import System.Environment( getArgs )-import Control.Concurrent( threadDelay )-import System.Random-import Data.List-import Control.Monad( liftM2 )--import qualified Data.ByteString.Char8 as B--main = do args <- getArgs- case args of- [] -> mkVty >>= liftM2 (>>) (run False) shutdown- ["--slow"] -> mkVty >>= liftM2 (>>) (run True ) shutdown- _ -> fail "usage: ./Bench [--slow]"--run True vt = mapM_ (update vt) . uncurry benchgen =<< getSize vt-run False vt = mapM_ (update vt) (benchgen 200 100)---- Currently, we just do scrolling.-takem :: (a -> Int) -> Int -> [a] -> ([a],[a])-takem len n [] = ([],[])-takem len n (x:xs) | lx > n = ([], x:xs)- | True = let (tk,dp) = takem len (n - lx) xs in (x:tk,dp)- where lx = len x--fold :: (a -> Int) -> [Int] -> [a] -> [[a]]-fold len [] xs = []-fold len (ll:lls) xs = let (tk,dp) = takem len ll xs in tk : fold len lls dp--lengths :: Int -> StdGen -> [Int]-lengths ml g = let (x,g2) = randomR (0,ml) g ; (y,g3) = randomR (0,x) g2 in y : lengths ml g3--nums :: StdGen -> [(Attr, B.ByteString)]-nums g = let (x,g2) = (random g :: (Int, StdGen))- (c,g3) = random g2- in (if c then setFG red attr else attr, B.pack (shows x " ")) : nums g3--pad :: Int -> Image -> Image-pad ml img = img <|> renderHFill attr ' ' (ml - imgWidth img)--clines :: StdGen -> Int -> [Image]-clines g maxll = map (pad maxll . horzcat . map (uncurry renderBS)) $ fold (B.length . snd) (lengths maxll g1) (nums g2)- where (g1,g2) =split g--benchgen :: Int -> Int -> [Picture]-benchgen w h = take 1000 $ map ((\i -> pic{ pImage = i}) . vertcat . take h) $ tails $ clines (mkStdGen 42) w
− test/Test.hs
@@ -1,29 +0,0 @@-import Graphics.Vty-import System.IO--import qualified Data.ByteString.Char8 as B--main = do vt <- mkVty- (sx,sy) <- getSize vt- play vt 0 0 sx sy ""--pieceA = setFG red attr-dumpA = setRV attr--play vt x y sx sy btl = do update vt (render x y sx sy btl)- k <- getEvent vt- case k of EvKey (KASCII 'r') [MCtrl] -> refresh vt >> play vt x y sx sy btl- EvKey KLeft [] | x /= 0 -> play vt (x-1) y sx sy btl- EvKey KRight [] | x /= (sx-1) -> play vt (x+1) y sx sy btl- EvKey KUp [] | y /= 0 -> play vt x (y-1) sx sy btl- EvKey KDown [] | y /= (sy-2) -> play vt x (y+1) sx sy btl- EvKey KEsc [] -> shutdown vt >> return ()- EvResize nx ny -> play vt (min x (nx-1)) (min y (ny-2)) nx ny btl- _ -> play vt x y sx sy (take sx (show k ++ btl))---render x y sx sy btl = pic { pCursor = Cursor x y,- pImage = renderFill pieceA ' ' sx y <->- renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (sx - x - 1) <->- renderFill pieceA ' ' sx (sy - y - 1) <->- renderBS dumpA (B.pack $ take sx (btl ++ repeat ' ')) }
− test/Test2.hs
@@ -1,12 +0,0 @@-module Main where-import Graphics.Vty--main = do- vty <- mkVty- (sx,sy) <- getSize vty- update vty (pic { pImage = renderFill (setBG red attr) 'X' sx sy })- refresh vty- shutdown vty- putStrLn "Done!"- return ()-
− test/make_tests.sh
@@ -1,10 +0,0 @@-#!/bin/sh-rm -f Test.o Test.hi Test-ghc --make Test--rm -f Test2.o Test2.hi Test2-ghc --make Test2--rm -f Bench.o Bench.hi Bench-ghc --make Bench-
vty.cabal view
@@ -1,57 +1,86 @@-Name: vty-Version: 3.1.8.4-License: BSD3-License-file: LICENSE-Author: Stefan O'Rear-Maintainer: Corey O'Connor (coreyoconnor@gmail.com)-Homepage: http://trac.haskell.org/vty/-Category: User Interfaces-Synopsis: A simple terminal access library-Description:- vty is a *very* simplistic 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.+name: vty+version: 6.6+license: BSD3+license-file: LICENSE+author: AUTHORS+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 and to provide good support for common terminal types. .- If you want to use it, currently the best reference is the test module (Test.hs).+ See the example programs in the @vty-crossplatform@ package examples+ on how to use the library. .- Notable infelicities: requires an ANSI-type terminal, poor efficiency,- requires Linux\/xterm style UTF8 support.+ © 2006-2007 Stefan O'Rear; BSD3 license. .- The latest code is in a darcs repo at <http://code.haskell.org/vty/>. This is only- compatible with GHC 6.10+.+ © Corey O'Connor; BSD3 license. .- The 3.1.8.* line of vty which is compatable with GHC 6.8 and GHC 6.10 is currently - in the darcs repo at <http://www.tothepowerofdisco.com/repo/vty-compat>.- '- © 2006-2007 Stefan O'Rear; BSD3 license.+ © Jonathan Daugherty; BSD3 license.+cabal-version: 1.18+build-type: Simple+extra-doc-files: README.md,+ AUTHORS,+ 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 -Build-Type: Simple-Data-Files: README, TODO-Extra-Source-Files: test/Test.hs, test/Bench.hs, test/Test2.hs, test/make_tests.sh-Extra-Source-Files: cbits/gwinsz.h-cabal-version: >=1.2+source-repository head+ type: git+ location: https://github.com/jtdaugherty/vty.git -Library {- if impl(ghc>=6.9)- Build-Depends: base >= 4 && < 5- else- Build-Depends: base < 4- Build-Depends: extensible-exceptions- Build-Depends: bytestring, containers, unix- Build-Depends: terminfo >= 0.3 && < 0.4- Build-Depends: utf8-string >= 0.3 && < 0.4+library+ default-language: Haskell2010+ include-dirs: cbits+ hs-source-dirs: src+ ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10+ ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10+ build-depends: base >= 4.8 && < 5,+ blaze-builder >= 0.3.3.2 && < 0.5,+ bytestring,+ 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 - Exposed-Modules: Graphics.Vty- C-Sources: cbits/gwinsz.c- cbits/set_term_timing.c- Include-Dirs: cbits- Install-Includes: gwinsz.h- Other-Modules: Graphics.Vty.Types- Graphics.Vty.Cursor- Graphics.Vty.LLInput- Graphics.Vty.Output- Graphics.Vty.ControlStrings+ if !impl(ghc >= 8.0)+ build-depends: semigroups >= 0.16,+ fail - ghc-options: -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr- ghc-prof-options: -funbox-strict-fields -prof -auto-all -Wall -fno-full-laziness -fspec-constr-}+ exposed-modules: Graphics.Text.Width+ Graphics.Vty+ Graphics.Vty.Attributes+ Graphics.Vty.Attributes.Color+ Graphics.Vty.Attributes.Color240+ Graphics.Vty.Config+ Graphics.Vty.Debug+ Graphics.Vty.DisplayAttributes+ Graphics.Vty.Error+ Graphics.Vty.Image+ Graphics.Vty.Image.Internal+ Graphics.Vty.Inline+ Graphics.Vty.Input+ Graphics.Vty.Input.Events+ Graphics.Vty.Output+ Graphics.Vty.Output.Mock+ Graphics.Vty.Picture+ Graphics.Vty.PictureToSpans+ Graphics.Vty.Span+ 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