diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,4 +1,6 @@ -The following people should be thanked for contributing to the vty library: +The following people should be thanked for contributing to the vty +library: + * Andrea Vezzosi * Corey O'Connor * Emily Backes @@ -15,3 +17,6 @@ * Mikolaj Konarski * Eyal Lotem * Yoshikuni Jujo + * Dmitry Ivanov + +Plus others.. Check the git log and CHANGELOG.md for a full list. diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,89 +0,0 @@ -4.7.4 - * backported rgb_color from 5.0. Maps from 8 bit integer RGB to Color - -4.7.0.0 - * API changes: - * Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size. - * Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size. - * Added Graphics.Vty.Image.translate: Offset an image. - * Thanks Ben Boeckel for these features. - -4.3.0.0 - -4.2.1.0 - * API changes: - * Attr record accessor fore_color changed to attr_fore_color - * Attr record accessor back_color changed to attr_back_color - * Attr record accessor style changed to attr_style - * Added an "inline" display attribute changing DSL: - * put_attr_change applies a display attribute change immediately to a terminal - * For instance, can be used to change the display attrbiutes of text output via putStrLn - and putStr. EX: "put_attr_change $ back_color red" will set the - background color to red. - * Changes do not apply to a Picture output via output_picture. - * See Graphics.Vty.Inline - * Moved all IO actions into any monad an instance of MonadIO - -4.0.0.1 - * binding for mk_wcswidth was incorrect. Most platforms just magically worked due to - coincidence. - -4.0.0 - * API changes: - * "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an - instance of the Vty data structure. - * added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated - with the Vty instance. - * Graphics.Vty.Types has undergone a number of changes. Summary: - * Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for - image combinators. Graphics.Vty.Picture for final picture construction. - * Graphics.Vty.Attributes: - * "setFG" and "setBG" are now "with_fore_color" and "with_back_color" - * All other "set.." equations similarly replaced. - * "attr" is now "def_attr", short for "default display attributes" Also added a - "current_attr" for "currently applied display attributes" - * Graphics.Vty.Image: - * "horzcat" is now "horiz_cat" - * "vertcat" is now "vert_cat" - * "renderBS" is now "utf8_bytestring" - * "renderChar" is now "char" - * "renderFill" is now "char_fill" - * added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings - and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime - representation. - * Graphics.Vty.Picture: - * exports Graphics.Vty.Image - * "pic" is now "pic_for_image" - * added API for setting background fill pattern. - * Completely rewritten output backend. - * Efficient, scanline style output span generator. Has not been fully optimized, but good - enough. - * The details required to display the desired picture on a terminal are well encapsulated. - * Terminfo based display terminal implementation. With specialized derivitives for xterm, - Terminal.app, and iTerm.app. - * Attempts to robustly handle even terminals that don't support all display attributes. - * I've tested the following terminals with success: iTerm.app, Terminal.app, xterm, - rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be - as successfull. - * Improved unicode support. Double wide characters will display as expected. - * 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted - according to the number of colors the terminal supports. - * The Graphics.Vty.Image combinators no longer require matching dimensions to arguments. - Unspecified areas are filled in with a user-customizable background pattern. See - Graphics.Vty.Picture. - * output images are always cropped to display size. - * Significant code coverage by QuickCheck tests. An interactive test for those final properties - that couldn't be automatically verified. - - issues resolved: - * "gnome terminal displays non-basic attributes as strikethrough" - * http://trac.haskell.org/vty/ticket/14 - * "Multi-byte characters are not displayed correctly on update" - * http://trac.haskell.org/vty/ticket/10 - * "Redraw does not handle rendering a line that extends beyond screen width characters" - * http://trac.haskell.org/vty/ticket/13 - * "The <|> and <-> combinators should be more forgiving of mismatched dimensions" - * http://trac.haskell.org/vty/ticket/9 - * "256-color support" - * http://trac.haskell.org/vty/ticket/19 - diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 `. 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 " 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 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,5 @@ +BSD 3-Clause License + Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,50 +0,0 @@ -vty is a terminal interface library. - -Vty currently provides: - -* Automatic handling of window resizes. - -* Supports Unicode characters on output, automatically setting and - resetting UTF-8 mode for xterm. Other terminals are assumed to support - -* Efficient output. - -* Minimizes repaint area, thus virtually eliminating the flicker - problem that plagues ncurses programs. - -* A pure, compositional interface for efficiently constructing display - images. - -* Automatically decodes keyboard keys into (key,[modifier]) tuples. - -* Automatically supports refresh on Ctrl-L. - -* Automatically supports timeout after 50ms for lone ESC (a barely - noticable delay) - -* Interface is designed for relatively easy compatible extension. - -* Supports all ANSI SGR-modes (defined in console_codes(4)) with - a type-safe interface. - -* Properly handles cleanup. - -Current disadvantages: - -* The character encoding of the output terminal is assumed to be UTF-8. - -* Minimal support for special keys on terminals other than the - linux-console. (F1-5 and arrow keys should work, but anything - shifted isn't likely to.) - -* Uses the TIOCGWINSZ ioctl to find the current window size, which - appears to be limited to Linux and *BSD. - -Project is hosted on github.com: https://github.com/coreyoconnor/vty - -git clone git://github.com/coreyoconnor/vty.git - -To compile the demonstration program: ghc --make test/Test.hs gwinsz.c - -The main documentation consists of the haddock-comments and the demonstration -program diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,173 @@ +[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](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 diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,15 +0,0 @@ -- Improve input handling - - base off of haskeline input system. The haskeline input system appears to be excellent and - satisfy all of Vty's input requirements. The current haskeline distribution does not appear to - export the required modules. Either: - 0. Add the required exports to the haskeline distribution. - - fine for development but complicates the UI for production clients. Though, exposing - the modules would only complicate the appearance of haskeline's interface. - 1. Partition the backend of haskeline into a separate package usable by both vty and - haskeline. -- use compact-string for character encoding handling -- Custom cursor appearance handling? - - specific color? - - reverse video? - - auto? - diff --git a/cbits/gwinsz.c b/cbits/gwinsz.c deleted file mode 100644 --- a/cbits/gwinsz.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -unsigned long vty_c_get_window_size(void) { - struct winsize w; - if (ioctl (0, TIOCGWINSZ, &w) >= 0) - return (w.ws_row << 16) + w.ws_col; - else - return 0x190050; -} diff --git a/cbits/mk_wcwidth.c b/cbits/mk_wcwidth.c --- a/cbits/mk_wcwidth.c +++ b/cbits/mk_wcwidth.c @@ -59,15 +59,40 @@ * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c */ -#include +#include +#include +#include +// The maximum size for a custom character width table is the total +// number of possible characters as dictated by the compiler. +#define MAX_CUSTOM_TABLE_SIZE (HS_CHAR_MAX + 1) + +// The pointer to the start of the custom character width table, if +// any. If this is NULL or this is set but the ready flag is false, the +// built-in tree search logic is used. +static uint8_t* custom_table = NULL; + +// Unused table cell value. +static uint8_t UNUSED_CELL = 0xff; + +// The size of the custom table, in entries. This should only be set +// if custom_table is not NULL. Its value should be the size of the +// custom_table array. +static uint32_t custom_table_size = 0; + +// A flag indicating whether the custom table is ready for +// use. This should only be set once the table has been +// allocated with vty_init_custom_table and initialized with +// vty_set_custom_table_range. +static uint8_t custom_table_ready = 0; + struct interval { int first; int last; }; /* auxiliary function for binary search in interval table */ -static int vty_bisearch(wchar_t ucs, const struct interval *table, int max) { +static int vty_bisearch(HsChar ucs, const struct interval *table, int max) { int min = 0; int mid; @@ -119,7 +144,7 @@ * in ISO 10646. */ -int vty_mk_wcwidth(wchar_t ucs) +static HsInt builtin_wcwidth(HsChar ucs) { /* sorted list of non-overlapping intervals of non-spacing characters */ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */ @@ -182,7 +207,7 @@ /* binary search in table of non-spacing characters */ if (vty_bisearch(ucs, combining, - sizeof(combining) / sizeof(struct interval) - 1)) + sizeof(combining) / sizeof(struct interval) - 1)) return 0; /* if we arrive here, ucs is not a combining or C0/C1 control character */ @@ -203,107 +228,124 @@ (ucs >= 0x30000 && ucs <= 0x3fffd))); } - -int vty_mk_wcswidth(const wchar_t *pwcs, size_t n) +// Return the width, in terminal cells, of the specified character. +// +// If the global custom width table is present, that table will be +// consulted for the character's width. If the character is not in the +// table, this will fall back to the built-in table. If the character is +// in neither table, zero will be returned. If the custom width table is +// not present, the built-in width table will be used. +HsInt vty_mk_wcwidth(HsChar ch) { - int w, width = 0; - - for (;n-- > 0; pwcs++) - if ((w = vty_mk_wcwidth(*pwcs)) < 0) - return -1; - else - width += w; + if (custom_table_ready) { + if ((ch >= 0) && (ch < custom_table_size)) { + uint8_t result = custom_table[ch]; - return width; + // The table is filled with UNUSED_CELL values for + // uninitialized ranges so we can defer to the built-in + // table in those cases. + if (result == UNUSED_CELL) { + return builtin_wcwidth(ch); + } else { + return result; + } + } else { + return -1; + } + } else { + return builtin_wcwidth(ch); + } } - -/* - * The following functions are the same as mk_wcwidth() and - * mk_wcswidth(), except that spacing characters in the East Asian - * Ambiguous (A) category as defined in Unicode Technical Report #11 - * have a column width of 2. This variant might be useful for users of - * CJK legacy encodings who want to migrate to UCS without changing - * the traditional terminal character-width behaviour. It is not - * otherwise recommended for general use. - */ -int vty_mk_wcwidth_cjk(wchar_t ucs) +// Initialize a custom character width table. +// +// This allocates a new character width table of the specified size +// (in characters). If a custom table has already been allocated, this +// returns 1. Otherwise it allocates a new table, initializes all of its +// entries to UNUSED_CELL, and returns zero. +// +// Note that this does *not* mark the table as ready for use. Until the +// table is marked ready, it will not be used by vty_mk_wcwidth. To mark +// the table as ready, call vty_activate_custom_table() after the table +// has been set up with calls to vty_set_custom_table_range. +int vty_init_custom_table(int size) { - /* sorted list of non-overlapping intervals of East Asian Ambiguous - * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */ - static const struct interval ambiguous[] = { - { 0x00A1, 0x00A1 }, { 0x00A4, 0x00A4 }, { 0x00A7, 0x00A8 }, - { 0x00AA, 0x00AA }, { 0x00AE, 0x00AE }, { 0x00B0, 0x00B4 }, - { 0x00B6, 0x00BA }, { 0x00BC, 0x00BF }, { 0x00C6, 0x00C6 }, - { 0x00D0, 0x00D0 }, { 0x00D7, 0x00D8 }, { 0x00DE, 0x00E1 }, - { 0x00E6, 0x00E6 }, { 0x00E8, 0x00EA }, { 0x00EC, 0x00ED }, - { 0x00F0, 0x00F0 }, { 0x00F2, 0x00F3 }, { 0x00F7, 0x00FA }, - { 0x00FC, 0x00FC }, { 0x00FE, 0x00FE }, { 0x0101, 0x0101 }, - { 0x0111, 0x0111 }, { 0x0113, 0x0113 }, { 0x011B, 0x011B }, - { 0x0126, 0x0127 }, { 0x012B, 0x012B }, { 0x0131, 0x0133 }, - { 0x0138, 0x0138 }, { 0x013F, 0x0142 }, { 0x0144, 0x0144 }, - { 0x0148, 0x014B }, { 0x014D, 0x014D }, { 0x0152, 0x0153 }, - { 0x0166, 0x0167 }, { 0x016B, 0x016B }, { 0x01CE, 0x01CE }, - { 0x01D0, 0x01D0 }, { 0x01D2, 0x01D2 }, { 0x01D4, 0x01D4 }, - { 0x01D6, 0x01D6 }, { 0x01D8, 0x01D8 }, { 0x01DA, 0x01DA }, - { 0x01DC, 0x01DC }, { 0x0251, 0x0251 }, { 0x0261, 0x0261 }, - { 0x02C4, 0x02C4 }, { 0x02C7, 0x02C7 }, { 0x02C9, 0x02CB }, - { 0x02CD, 0x02CD }, { 0x02D0, 0x02D0 }, { 0x02D8, 0x02DB }, - { 0x02DD, 0x02DD }, { 0x02DF, 0x02DF }, { 0x0391, 0x03A1 }, - { 0x03A3, 0x03A9 }, { 0x03B1, 0x03C1 }, { 0x03C3, 0x03C9 }, - { 0x0401, 0x0401 }, { 0x0410, 0x044F }, { 0x0451, 0x0451 }, - { 0x2010, 0x2010 }, { 0x2013, 0x2016 }, { 0x2018, 0x2019 }, - { 0x201C, 0x201D }, { 0x2020, 0x2022 }, { 0x2024, 0x2027 }, - { 0x2030, 0x2030 }, { 0x2032, 0x2033 }, { 0x2035, 0x2035 }, - { 0x203B, 0x203B }, { 0x203E, 0x203E }, { 0x2074, 0x2074 }, - { 0x207F, 0x207F }, { 0x2081, 0x2084 }, { 0x20AC, 0x20AC }, - { 0x2103, 0x2103 }, { 0x2105, 0x2105 }, { 0x2109, 0x2109 }, - { 0x2113, 0x2113 }, { 0x2116, 0x2116 }, { 0x2121, 0x2122 }, - { 0x2126, 0x2126 }, { 0x212B, 0x212B }, { 0x2153, 0x2154 }, - { 0x215B, 0x215E }, { 0x2160, 0x216B }, { 0x2170, 0x2179 }, - { 0x2190, 0x2199 }, { 0x21B8, 0x21B9 }, { 0x21D2, 0x21D2 }, - { 0x21D4, 0x21D4 }, { 0x21E7, 0x21E7 }, { 0x2200, 0x2200 }, - { 0x2202, 0x2203 }, { 0x2207, 0x2208 }, { 0x220B, 0x220B }, - { 0x220F, 0x220F }, { 0x2211, 0x2211 }, { 0x2215, 0x2215 }, - { 0x221A, 0x221A }, { 0x221D, 0x2220 }, { 0x2223, 0x2223 }, - { 0x2225, 0x2225 }, { 0x2227, 0x222C }, { 0x222E, 0x222E }, - { 0x2234, 0x2237 }, { 0x223C, 0x223D }, { 0x2248, 0x2248 }, - { 0x224C, 0x224C }, { 0x2252, 0x2252 }, { 0x2260, 0x2261 }, - { 0x2264, 0x2267 }, { 0x226A, 0x226B }, { 0x226E, 0x226F }, - { 0x2282, 0x2283 }, { 0x2286, 0x2287 }, { 0x2295, 0x2295 }, - { 0x2299, 0x2299 }, { 0x22A5, 0x22A5 }, { 0x22BF, 0x22BF }, - { 0x2312, 0x2312 }, { 0x2460, 0x24E9 }, { 0x24EB, 0x254B }, - { 0x2550, 0x2573 }, { 0x2580, 0x258F }, { 0x2592, 0x2595 }, - { 0x25A0, 0x25A1 }, { 0x25A3, 0x25A9 }, { 0x25B2, 0x25B3 }, - { 0x25B6, 0x25B7 }, { 0x25BC, 0x25BD }, { 0x25C0, 0x25C1 }, - { 0x25C6, 0x25C8 }, { 0x25CB, 0x25CB }, { 0x25CE, 0x25D1 }, - { 0x25E2, 0x25E5 }, { 0x25EF, 0x25EF }, { 0x2605, 0x2606 }, - { 0x2609, 0x2609 }, { 0x260E, 0x260F }, { 0x2614, 0x2615 }, - { 0x261C, 0x261C }, { 0x261E, 0x261E }, { 0x2640, 0x2640 }, - { 0x2642, 0x2642 }, { 0x2660, 0x2661 }, { 0x2663, 0x2665 }, - { 0x2667, 0x266A }, { 0x266C, 0x266D }, { 0x266F, 0x266F }, - { 0x273D, 0x273D }, { 0x2776, 0x277F }, { 0xE000, 0xF8FF }, - { 0xFFFD, 0xFFFD }, { 0xF0000, 0xFFFFD }, { 0x100000, 0x10FFFD } - }; - - /* binary search in table of non-spacing characters */ - if (vty_bisearch(ucs, ambiguous, - sizeof(ambiguous) / sizeof(struct interval) - 1)) - return 2; - - return vty_mk_wcwidth(ucs); + if (custom_table == NULL) { + if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) { + custom_table_ready = 0; + custom_table = malloc(size); + memset(custom_table, UNUSED_CELL, size); + custom_table_size = size; + return 0; + } else { + return 1; + } + } else { + return 1; + } } +// Set the specified character range in the custom width table to the +// specified width. +// +// This function sets 'width' as the character width for all entries +// in the custom character table starting at the 'start' entry and +// including all entries up to and including 'start + size - 1'. +// +// If this succeeds, it returns zero. If it fails, it returns 1. It +// fails if the table is not allocated, marked as ready (i.e. it is in +// use and has already been populated), or if the start or size values +// are not in bounds for the table. +int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width) +{ + if ((custom_table == NULL) || + (size >= custom_table_size) || + (start >= custom_table_size) || + ((start + 1) >= (custom_table_size - size)) || + custom_table_ready) { + return 1; + } else { + memset(custom_table + start, width, size); + return 0; + } +} -int vty_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n) +// Mark the allocated custom character width table as ready for use. +// +// After this call, further calls to vty_set_custom_table_range will +// fail. +// +// This function returns 0 if it succeeds. If it fails, it returns 1. +// It fails if the custom table is already ready or if it has not been +// allocated. +int vty_activate_custom_table() { - int w, width = 0; + if (custom_table_ready || (custom_table == NULL)) { + return 1; + } else { + custom_table_ready = 1; + return 0; + } +} - for (;n-- > 0; pwcs++) - if ((w = vty_mk_wcwidth_cjk(*pwcs)) < 0) - return -1; - else - width += w; +// Returns whether a custom character width table has been marked ready. +int vty_custom_table_ready() +{ + return custom_table_ready; +} - return width; +// Deallocate the custom width table. +// +// This does nothing if there is no allocated custom width table, or if +// there is one but it is in use (marked ready). This is only useful if +// an initial allocation succeeds, but range population fails, after +// which point the application may want to deallocate the table to avoid +// leaving it in an intermediate state. +void vty_deallocate_custom_table() +{ + if ((custom_table != NULL) && (!custom_table_ready)) { + free(custom_table); + custom_table = NULL; + custom_table_size = 0; + } } diff --git a/cbits/set_term_timing.c b/cbits/set_term_timing.c deleted file mode 100644 --- a/cbits/set_term_timing.c +++ /dev/null @@ -1,14 +0,0 @@ -#include -#include -#include -#include - -void vty_set_term_timing(void) -{ - struct termios trm; - tcgetattr(STDIN_FILENO, &trm); - trm.c_cc[VMIN] = 0; - trm.c_cc[VTIME] = 0; - tcsetattr(STDIN_FILENO, TCSANOW, &trm); -} - diff --git a/src/Codec/Binary/UTF8/Width.hs b/src/Codec/Binary/UTF8/Width.hs deleted file mode 100644 --- a/src/Codec/Binary/UTF8/Width.hs +++ /dev/null @@ -1,33 +0,0 @@ --- Copyright 2009 Corey O'Connor -{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-} -{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} -module Codec.Binary.UTF8.Width ( wcwidth - , wcswidth - ) - where - -import Foreign.C.Types -import Foreign.C.String -import Foreign.Storable -import Foreign.Ptr - -import System.IO.Unsafe - -wcwidth :: Char -> Int -wcwidth c = unsafePerformIO (withCWString [c] $! \ws -> do - wc <- peek ws - let !w = fromIntegral $! wcwidth' wc - return w - ) -{-# NOINLINE wcwidth #-} - -foreign import ccall unsafe "vty_mk_wcwidth" wcwidth' :: CWchar -> CInt - -wcswidth :: String -> Int -wcswidth str = unsafePerformIO (withCWStringLen str $! \(ws, ws_len) -> do - let !w = fromIntegral $! wcswidth' ws (fromIntegral ws_len) - return w - ) -{-# NOINLINE wcswidth #-} - -foreign import ccall unsafe "vty_mk_wcswidth" wcswidth' :: Ptr CWchar -> CSize -> CInt diff --git a/src/Data/Marshalling.hs b/src/Data/Marshalling.hs deleted file mode 100644 --- a/src/Data/Marshalling.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- Copyright 2009 Corey O'Connor -module Data.Marshalling ( module Data.Marshalling - , module Data.Word - , module Foreign.Ptr - , module Foreign.ForeignPtr - , module Foreign.Marshal - , module Foreign.Storable - ) - where - -import Control.Monad.Trans - -import Data.Word - -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Marshal -import Foreign.Storable - -type OutputBuffer = Ptr Word8 - -string_to_bytes :: String -> [Word8] -string_to_bytes str = map (toEnum . fromEnum) str - -serialize_bytes :: MonadIO m => [Word8] -> OutputBuffer -> m OutputBuffer -serialize_bytes bytes !out_ptr = do - liftIO $! pokeArray out_ptr bytes - return $! out_ptr `plusPtr` ( length bytes ) - diff --git a/src/Data/Terminfo/Eval.hs b/src/Data/Terminfo/Eval.hs deleted file mode 100644 --- a/src/Data/Terminfo/Eval.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{- Evaluates the paramaterized terminfo string capability with the given parameters. - - - - todo: This can be greatly simplified. - -} -module Data.Terminfo.Eval ( cap_expression_required_bytes - , serialize_cap_expression - ) - where - -import Data.ByteString.Internal ( memcpy ) -import Data.Marshalling -import Data.Terminfo.Parse - -import Control.Monad.Identity -import Control.Monad.State.Strict - -import Data.Bits ( (.|.), (.&.), xor ) -import Data.List - -import GHC.Prim -import GHC.Word - --- | capability evaluator state -data EvalState = EvalState - { eval_stack :: ![ CapParam ] - , eval_expression :: !CapExpression - , eval_params :: ![ CapParam ] - } - -type EvalT m a = StateT EvalState m a -type Eval a = EvalT Identity a - -{-# SPECIALIZE pop :: EvalT IO CapParam #-} -pop :: Monad m => EvalT m CapParam -pop = do - s <- get - let v : stack' = eval_stack s - s' = s { eval_stack = stack' } - put s' - return v - -{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-} -read_param :: Monad m => Word -> EvalT m CapParam -read_param pn = do - !params <- get >>= return . eval_params - return $! genericIndex params pn - -{-# SPECIALIZE push :: CapParam -> EvalT IO () #-} -push :: Monad m => CapParam -> EvalT m () -push !v = do - s <- get - let s' = s { eval_stack = v : eval_stack s } - put s' - -apply_param_ops :: CapExpression -> [CapParam] -> [CapParam] -apply_param_ops cap params = foldl apply_param_op params (param_ops cap) - -apply_param_op :: [CapParam] -> ParamOp -> [CapParam] -apply_param_op params IncFirstTwo = map (+ 1) params - -cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word -cap_expression_required_bytes cap params = - let params' = apply_param_ops cap params - s_0 = EvalState [] cap params' - in fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0 - -cap_ops_required_bytes :: CapOps -> Eval Word -cap_ops_required_bytes ops = do - counts <- mapM cap_op_required_bytes ops - return $ sum counts - -cap_op_required_bytes :: CapOp -> Eval Word -cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c -cap_op_required_bytes DecOut = do - p <- pop - return $ toEnum $ length $ show p -cap_op_required_bytes CharOut = do - _ <- pop - return 1 -cap_op_required_bytes (PushParam pn) = do - read_param pn >>= push - return 0 -cap_op_required_bytes (PushValue v) = do - push v - return 0 -cap_op_required_bytes (Conditional expr parts) = do - c_expr <- cap_ops_required_bytes expr - c_parts <- cond_parts_required_bytes parts - return $ c_expr + c_parts - where - cond_parts_required_bytes [] = return 0 - cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do - -- (man 5 terminfo) - -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the - -- stack, testing if it is nonzero (true). If it is zero (false), control - -- passes to the %e (else) part. - v <- pop - c_total <- if v /= 0 - then cap_ops_required_bytes true_ops - else do - c_false <- cap_ops_required_bytes false_ops - c_remain <- cond_parts_required_bytes false_parts - return $ c_false + c_remain - return c_total -cap_op_required_bytes BitwiseOr = do - v_1 <- pop - v_0 <- pop - push $ v_0 .|. v_1 - return 0 -cap_op_required_bytes BitwiseAnd = do - v_1 <- pop - v_0 <- pop - push $ v_0 .&. v_1 - return 0 -cap_op_required_bytes BitwiseXOr = do - v_1 <- pop - v_0 <- pop - push $ v_0 `xor` v_1 - return 0 -cap_op_required_bytes ArithPlus = do - v_1 <- pop - v_0 <- pop - push $ v_0 + v_1 - return 0 -cap_op_required_bytes ArithMinus = do - v_1 <- pop - v_0 <- pop - push $ v_0 - v_1 - return 0 -cap_op_required_bytes CompareEq = do - v_1 <- pop - v_0 <- pop - push $ if v_0 == v_1 then 1 else 0 - return 0 -cap_op_required_bytes CompareLt = do - v_1 <- pop - v_0 <- pop - push $ if v_0 < v_1 then 1 else 0 - return 0 -cap_op_required_bytes CompareGt = do - v_1 <- pop - v_0 <- pop - push $ if v_0 > v_1 then 1 else 0 - return 0 - -serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer -serialize_cap_expression cap params out_ptr = do - let params' = apply_param_ops cap params - s_0 = EvalState [] cap params' - (!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0 - return $! out_ptr' - -serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer -serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops - -serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer -serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do - !cap <- get >>= return . eval_expression - let ( !start_ptr, _ ) = cap_bytes cap - !src_ptr = start_ptr `plusPtr` offset - !out_ptr' = out_ptr `plusPtr` next_offset - liftIO $! memcpy out_ptr src_ptr (fromIntegral byte_count) - return $! out_ptr' -serialize_cap_op out_ptr DecOut = do - p <- pop - let out_str = show p - out_bytes = string_to_bytes out_str - serialize_bytes out_bytes out_ptr -serialize_cap_op out_ptr CharOut = do - W# p <- pop - -- XXX Truncate the character value to a single byte? - let !out_byte = W8# (and# p 0xFF##) - !out_ptr' = out_ptr `plusPtr` 1 - liftIO $ poke out_ptr out_byte - return out_ptr' -serialize_cap_op out_ptr (PushParam pn) = do - read_param pn >>= push - return out_ptr -serialize_cap_op out_ptr (PushValue v) = do - push v - return out_ptr -serialize_cap_op out_ptr (Conditional expr parts) = do - out_ptr' <- serialize_cap_ops out_ptr expr - out_ptr'' <- serialize_cond_parts out_ptr' parts - return out_ptr'' - where - serialize_cond_parts ptr [] = return ptr - serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do - -- (man 5 terminfo) - -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the - -- stack, testing if it is nonzero (true). If it is zero (false), control - -- passes to the %e (else) part. - v <- pop - ptr'' <- if v /= 0 - then serialize_cap_ops ptr true_ops - else do - ptr' <- serialize_cap_ops ptr false_ops - serialize_cond_parts ptr' false_parts - return ptr'' - -serialize_cap_op out_ptr BitwiseOr = do - v_0 <- pop - v_1 <- pop - push $ v_0 .|. v_1 - return out_ptr -serialize_cap_op out_ptr BitwiseAnd = do - v_0 <- pop - v_1 <- pop - push $ v_0 .&. v_1 - return out_ptr -serialize_cap_op out_ptr BitwiseXOr = do - v_1 <- pop - v_0 <- pop - push $ v_0 `xor` v_1 - return out_ptr -serialize_cap_op out_ptr ArithPlus = do - v_1 <- pop - v_0 <- pop - push $ v_0 + v_1 - return out_ptr -serialize_cap_op out_ptr ArithMinus = do - v_1 <- pop - v_0 <- pop - push $ v_0 - v_1 - return out_ptr -serialize_cap_op out_ptr CompareEq = do - v_1 <- pop - v_0 <- pop - push $ if v_0 == v_1 then 1 else 0 - return out_ptr -serialize_cap_op out_ptr CompareLt = do - v_1 <- pop - v_0 <- pop - push $ if v_0 < v_1 then 1 else 0 - return out_ptr -serialize_cap_op out_ptr CompareGt = do - v_1 <- pop - v_0 <- pop - push $ if v_0 > v_1 then 1 else 0 - return out_ptr - diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs deleted file mode 100644 --- a/src/Data/Terminfo/Parse.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -funbox-strict-fields -O #-} -module Data.Terminfo.Parse ( module Data.Terminfo.Parse - , Text.ParserCombinators.Parsec.ParseError - ) - where - -import Control.Applicative ( Applicative(..), pure, (<*>) ) -import Control.Monad ( liftM ) -import Control.Monad.Trans -import Control.DeepSeq - -import Data.Monoid -import Data.Word - -import Foreign.C.Types -import Foreign.Marshal.Array -import Foreign.Ptr - -import Text.ParserCombinators.Parsec - -type CapBytes = ( Ptr Word8, CSize ) - -data CapExpression = CapExpression - { cap_ops :: !CapOps - , cap_bytes :: !CapBytes - , source_string :: !String - , param_count :: !Word - , param_ops :: !ParamOps - } - -instance NFData CapExpression where - rnf (CapExpression ops !_bytes !str !c !p_ops) - = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops - -type CapParam = Word - -type CapOps = [CapOp] -data CapOp = - Bytes !Int !CSize !Int - | DecOut | CharOut - -- This stores a 0-based index to the parameter. However the operation that implies this op is - -- 1-based - | PushParam !Word | PushValue !Word - -- The conditional parts are the sequence of (%t expression, %e expression) pairs. - -- The %e expression may be NOP - | Conditional - { conditional_expr :: !CapOps - , conditional_parts :: ![(CapOps, CapOps)] - } - | BitwiseOr | BitwiseXOr | BitwiseAnd - | ArithPlus | ArithMinus - | CompareEq | CompareLt | CompareGt - deriving ( Show ) - -instance NFData CapOp where - rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset - rnf (PushParam pn) = rnf pn - rnf (PushValue v) = rnf v - rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts - rnf BitwiseOr = () - rnf BitwiseXOr = () - rnf BitwiseAnd = () - rnf ArithPlus = () - rnf ArithMinus = () - rnf CompareEq = () - rnf CompareLt = () - rnf CompareGt = () - rnf DecOut = () - rnf CharOut = () - -type ParamOps = [ParamOp] -data ParamOp = - IncFirstTwo - deriving ( Show ) - -instance NFData ParamOp where - rnf IncFirstTwo = () - -parse_cap_expression :: ( Applicative m - , MonadIO m - ) - => String - -> m ( Either ParseError CapExpression ) -parse_cap_expression cap_string = - let v = runParser cap_expression_parser - initial_build_state - "terminfo cap" - cap_string - in case v of - Left e -> return $ Left e - Right build_results -> pure Right <*> construct_cap_expression cap_string build_results - -construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression -construct_cap_expression cap_string build_results = do - byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string ) - let expr = CapExpression - { cap_ops = out_cap_ops build_results - -- The cap bytes are the lower 8 bits of the input string's characters. - -- \todo Verify the input string actually contains an 8bit byte per character. - , cap_bytes = ( byte_array, toEnum $! length cap_string ) - , source_string = cap_string - , param_count = out_param_count build_results - , param_ops = out_param_ops build_results - } - return $! rnf expr `seq` expr - -type CapParser a = GenParser Char BuildState a - -cap_expression_parser :: CapParser BuildResults -cap_expression_parser = do - rs <- many $ param_escape_parser <|> bytes_op_parser - return $ mconcat rs - -param_escape_parser :: CapParser BuildResults -param_escape_parser = do - _ <- char '%' - inc_offset 1 - literal_percent_parser <|> param_op_parser - -literal_percent_parser :: CapParser BuildResults -literal_percent_parser = do - _ <- char '%' - start_offset <- getState >>= return . next_offset - inc_offset 1 - return $ BuildResults 0 [Bytes start_offset 1 1] [] - -param_op_parser :: CapParser BuildResults -param_op_parser - = increment_op_parser - <|> push_op_parser - <|> dec_out_parser - <|> char_out_parser - <|> conditional_op_parser - <|> bitwise_op_parser - <|> arith_op_parser - <|> literal_int_op_parser - <|> compare_op_parser - <|> char_const_parser - -increment_op_parser :: CapParser BuildResults -increment_op_parser = do - _ <- char 'i' - inc_offset 1 - return $ BuildResults 0 [] [ IncFirstTwo ] - -push_op_parser :: CapParser BuildResults -push_op_parser = do - _ <- char 'p' - param_n <- digit >>= return . (\d -> read [d]) - inc_offset 2 - return $ BuildResults param_n [ PushParam $ param_n - 1 ] [] - -dec_out_parser :: CapParser BuildResults -dec_out_parser = do - _ <- char 'd' - inc_offset 1 - return $ BuildResults 0 [ DecOut ] [] - -char_out_parser :: CapParser BuildResults -char_out_parser = do - _ <- char 'c' - inc_offset 1 - return $ BuildResults 0 [ CharOut ] [] - -conditional_op_parser :: CapParser BuildResults -conditional_op_parser = do - _ <- char '?' - inc_offset 1 - cond_part <- many_expr conditional_true_parser - parts <- many_p - ( do - true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser - , conditional_false_parser - ] - false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser - , conditional_true_parser - ] - return ( true_part, false_part ) - ) - conditional_end_parser - - let true_parts = map fst parts - false_parts = map snd parts - BuildResults n cond cond_param_ops = cond_part - - let n' = maximum $ n : map out_param_count true_parts - n'' = maximum $ n' : map out_param_count false_parts - - let true_ops = map out_cap_ops true_parts - false_ops = map out_cap_ops false_parts - cond_parts = zip true_ops false_ops - - let true_param_ops = mconcat $ map out_param_ops true_parts - false_param_ops = mconcat $ map out_param_ops false_parts - p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops] - - return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops - - where - many_p !p !end = choice - [ try end >> return [] - , do !v <- p - !vs <- many_p p end - return $! v : vs - ] - many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end - -conditional_true_parser :: CapParser () -conditional_true_parser = do - _ <- string "%t" - inc_offset 2 - -conditional_false_parser :: CapParser () -conditional_false_parser = do - _ <- string "%e" - inc_offset 2 - -conditional_end_parser :: CapParser () -conditional_end_parser = do - _ <- string "%;" - inc_offset 2 - -bitwise_op_parser :: CapParser BuildResults -bitwise_op_parser - = bitwise_or_parser - <|> bitwise_and_parser - <|> bitwise_xor_parser - -bitwise_or_parser :: CapParser BuildResults -bitwise_or_parser = do - _ <- char '|' - inc_offset 1 - return $ BuildResults 0 [ BitwiseOr ] [ ] - -bitwise_and_parser :: CapParser BuildResults -bitwise_and_parser = do - _ <- char '&' - inc_offset 1 - return $ BuildResults 0 [ BitwiseAnd ] [ ] - -bitwise_xor_parser :: CapParser BuildResults -bitwise_xor_parser = do - _ <- char '^' - inc_offset 1 - return $ BuildResults 0 [ BitwiseXOr ] [ ] - -arith_op_parser :: CapParser BuildResults -arith_op_parser - = plus_op - <|> minus_op - where - plus_op = do - _ <- char '+' - inc_offset 1 - return $ BuildResults 0 [ ArithPlus ] [ ] - minus_op = do - _ <- char '-' - inc_offset 1 - return $ BuildResults 0 [ ArithMinus ] [ ] - -literal_int_op_parser :: CapParser BuildResults -literal_int_op_parser = do - _ <- char '{' - inc_offset 1 - n_str <- many1 digit - inc_offset $ toEnum $ length n_str - let n :: Word = read n_str - _ <- char '}' - inc_offset 1 - return $ BuildResults 0 [ PushValue n ] [ ] - -compare_op_parser :: CapParser BuildResults -compare_op_parser - = compare_eq_op - <|> compare_lt_op - <|> compare_gt_op - where - compare_eq_op = do - _ <- char '=' - inc_offset 1 - return $ BuildResults 0 [ CompareEq ] [ ] - compare_lt_op = do - _ <- char '<' - inc_offset 1 - return $ BuildResults 0 [ CompareLt ] [ ] - compare_gt_op = do - _ <- char '>' - inc_offset 1 - return $ BuildResults 0 [ CompareGt ] [ ] - -bytes_op_parser :: CapParser BuildResults -bytes_op_parser = do - bytes <- many1 $ satisfy (/= '%') - start_offset <- getState >>= return . next_offset - let !c = length bytes - !s <- getState - let s' = s { next_offset = start_offset + c } - setState s' - return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] [] - -char_const_parser :: CapParser BuildResults -char_const_parser = do - _ <- char '\'' - char_value <- liftM (toEnum . fromEnum) anyChar - _ <- char '\'' - inc_offset 3 - return $ BuildResults 0 [ PushValue char_value ] [ ] - -data BuildState = BuildState - { next_offset :: Int - } - -inc_offset :: Int -> CapParser () -inc_offset n = do - s <- getState - let s' = s { next_offset = next_offset s + n } - setState s' - -initial_build_state :: BuildState -initial_build_state = BuildState 0 - -data BuildResults = BuildResults - { out_param_count :: !Word - , out_cap_ops :: !CapOps - , out_param_ops :: !ParamOps - } - -instance Monoid BuildResults where - mempty = BuildResults 0 [] [] - v0 `mappend` v1 - = BuildResults - { out_param_count = (out_param_count v0) `max` (out_param_count v1) - , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1) - , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1) - } - diff --git a/src/Graphics/Text/Width.hs b/src/Graphics/Text/Width.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Text/Width.hs @@ -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 diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs --- a/src/Graphics/Vty.hs +++ b/src/Graphics/Vty.hs @@ -1,149 +1,249 @@ --- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE ForeignFunctionInterface, BangPatterns, UnboxedTuples #-} -{-# CFILES gwinsz.c #-} - --- Good sources of documentation for terminal programming are: --- vt100 control sequences: http://vt100.net/docs/vt100-ug/chapter3.html#S3.3.3 --- Xterm control sequences: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html - -module Graphics.Vty ( Vty(..) - , mkVty - , mkVtyEscDelay - , module Graphics.Vty.Terminal - , module Graphics.Vty.Picture - , module Graphics.Vty.DisplayRegion - , Key(..) - , Modifier(..) - , Button(..) - , Event(..) - ) - where +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Vty provides interfaces for both terminal input and terminal +-- output. +-- +-- - User input to the terminal is provided to the Vty application as a +-- sequence of 'Event's. +-- +-- - Output is provided to by the application to Vty in the form of a +-- 'Picture'. A 'Picture' is one or more layers of 'Image's. +-- 'Image' values can be built by the various constructors in +-- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute) +-- values in the "Graphics.Vty.Attributes" module. +-- +-- - Each platform on which Vty is supported provides a package that +-- provides Vty with access to the platform-specific terminal +-- interface. For example, on Unix systems, the @vty-unix@ package +-- must be used to initialize Vty with access to a Unix terminal. +-- +-- As a small example, the following program demonstrates the use of Vty +-- on a Unix system using the @vty-unix@ package: +-- +-- > import Graphics.Vty +-- > import Graphics.Vty.Platform.Unix (mkVty) +-- > +-- > main = do +-- > vty <- mkVty defaultConfig +-- > let line0 = string (defAttr `withForeColor` green) "first line" +-- > line1 = string (defAttr `withBackColor` blue) "second line" +-- > img = line0 <-> line1 +-- > pic = picForImage img +-- > update vty pic +-- > e <- nextEvent vty +-- > shutdown vty +-- > print ("Last event was: " ++ show e) +-- +-- Vty uses threads internally, so programs made with Vty must be +-- compiled with the threaded runtime using the GHC @-threaded@ option. +module Graphics.Vty + ( Vty(..) + , setWindowTitle + , installCustomWidthTable + , mkVtyFromPair + , module Graphics.Vty.Config + , module Graphics.Vty.Input + , module Graphics.Vty.Input.Events + , module Graphics.Vty.Output + , module Graphics.Vty.Picture + , module Graphics.Vty.Image + , module Graphics.Vty.Attributes + ) +where -import Graphics.Vty.Terminal +import Graphics.Vty.Config +import Graphics.Vty.Input +import Graphics.Vty.Input.Events +import Graphics.Vty.Output import Graphics.Vty.Picture -import Graphics.Vty.DisplayRegion -import Graphics.Vty.LLInput +import Graphics.Vty.Image +import Graphics.Vty.Attributes +import Graphics.Vty.UnicodeWidthTable.IO +import Graphics.Vty.UnicodeWidthTable.Install +import qualified Control.Exception as E +import Control.Monad (when) +import Control.Concurrent.STM + import Data.IORef +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif -import qualified System.Console.Terminfo as Terminfo +-- | A 'Vty' value represents a handle to the Vty library that the +-- application must create in order to use Vty. +-- +-- The use of this library typically follows this process: +-- +-- 1. Initialize Vty with the 'mkVty' implementation for your +-- platform's Vty package (e.g. @vty-unix@), or, more generically, with +-- 'mkVtyFromPair'. This takes control of (and sets up) the terminal. +-- +-- 2. Use 'update' to display a picture. +-- +-- 3. Use 'nextEvent' to get the next input event. +-- +-- 4. Depending on the event, go to 2 or 5. +-- +-- 5. Shutdown Vty and restore the terminal state with 'shutdown'. At +-- this point the 'Vty' handle cannot be used again. +-- +-- Operations on Vty handles are not thread-safe. +data Vty = + Vty { update :: Picture -> IO () + -- ^ Output the given 'Picture' to the terminal. + , nextEvent :: IO Event + -- ^ Return the next 'Event' or block until one becomes + -- available. + , nextEventNonblocking :: IO (Maybe Event) + -- ^ Non-blocking version of 'nextEvent'. + , inputIface :: Input + -- ^ The input interface. See 'Input'. + , outputIface :: Output + -- ^ The output interface. See 'Output'. + , refresh :: IO () + -- ^ Refresh the display. If other programs output to the + -- terminal and mess up the display then the application might + -- want to force a refresh using this function. + , shutdown :: IO () + -- ^ Clean up after vty. A call to this function is necessary to + -- cleanly restore the terminal state before application exit. + -- The above methods will throw an exception if executed after + -- this is executed. Idempotent. + , isShutdown :: IO Bool + } --- | The main object. At most one should be created. --- An alternative is to use unsafePerformIO to automatically create a singleton Vty instance when --- required. +-- | Attempt to load and install a custom character width table into +-- this process. -- --- This does not assure any thread safety. In theory, as long as an update action is not executed --- when another update action is already then it's safe to call this on multiple threads. --- --- todo: Once the Terminal interface encompasses input this interface will be deprecated. --- Currently, just using the Terminal interface there is no support for input events. -data Vty = Vty - { -- | Outputs the given Picture. Equivalent to output_picture applied to a display context - -- implicitly managed by Vty. - update :: Picture -> IO () - -- | Get one Event object, blocking if necessary. - , next_event :: IO Event - -- | Handle to the terminal interface. See `Terminal` - -- - -- The use of Vty typically follows this process: - -- - -- 0. initialize vty - -- - -- 1. use the update equation of Vty to display a picture - -- - -- 2. repeat - -- - -- 3. shutdown vty. - -- - -- todo: provide a similar abstraction to Graphics.Vty.Terminal for input. Use haskeline's - -- input backend for implementation. - -- - -- todo: remove explicit `shutdown` requirement. - , terminal :: TerminalHandle - -- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some - -- other program might output to the terminal and mess the display. In that case the user - -- might want to force a refresh. - , refresh :: IO () - -- | Clean up after vty. - -- The above methods will throw an exception if executed after this is executed. - , shutdown :: IO () - } +-- This looks up the specified terminal name in the specified width +-- table map and, if a map file path is found, the map is loaded and +-- installed. This is exposed for Vty platform package implementors; +-- application developers should never need to call this. +installCustomWidthTable :: Maybe FilePath + -- ^ Optional path to a log file where log + -- messages should be written when attempting to + -- load a width table. + -> Maybe String + -- ^ Optional width table entry name (usually + -- the terminal name, e.g. value of @TERM@ on + -- Unix systems). If omitted, this function does + -- not attempt to load a table. + -> [(String, FilePath)] + -- ^ Mapping from width table entry names to + -- width table file paths. This is usually + -- obtained from 'configTermWidthMaps' of + -- 'VtyUserConfig'. + -> IO () +installCustomWidthTable logPath tblName widthMaps = do + let doLog s = case logPath of + Nothing -> return () + Just path -> appendFile path $ "installWidthTable: " <> s <> "\n" --- | Set up the state object for using vty. At most one state object should be --- created at a time. -mkVty :: IO Vty -mkVty = mkVtyEscDelay 0 + customInstalled <- isCustomTableReady + when (not customInstalled) $ do + case tblName of + Nothing -> + doLog "No terminal name given in the configuration, skipping load" + Just name -> + case lookup name widthMaps of + Nothing -> + doLog $ "Width table " <> show name <> " not found in custom character width mapping list" + Just path -> do + tableResult <- E.try $ readUnicodeWidthTable path + case tableResult of + Left (e::E.SomeException) -> + doLog $ "Error reading custom character width table " <> + "at " <> show path <> ": " <> show e + Right (Left msg) -> + doLog $ "Error reading custom character width table " <> + "at " <> show path <> ": " <> msg + Right (Right table) -> do + installResult <- E.try $ installUnicodeWidthTable table + case installResult of + Left (e::E.SomeException) -> + doLog $ "Error installing unicode table (" <> + show path <> ": " <> show e + Right () -> + doLog $ "Successfully installed Unicode width table " <> + " from " <> show path --- | Set up the state object for using vty. At most one state object should be --- created at a time. The delay, in microseconds, specifies the period of time to wait for a key --- following reading ESC from the terminal before considering the ESC key press as a discrete event. -mkVtyEscDelay :: Int -> IO Vty -mkVtyEscDelay escDelay = do - term_info <- Terminfo.setupTermFromEnv - t <- terminal_handle - reserve_display t - (kvar, endi) <- initTermInput escDelay term_info - intMkVty kvar ( endi >> release_display t >> release_terminal t ) t +-- | Build a 'Vty' handle from an input/output pair. +-- +-- This is exposed for Vty platform package implementors; application +-- developers should never need to call this, and should instead call +-- @mkVty@ or equivalent from their platform package of choice. +mkVtyFromPair :: Input -> Output -> IO Vty +mkVtyFromPair input out = do + reserveDisplay out -intMkVty :: IO Event -> IO () -> TerminalHandle -> IO Vty -intMkVty kvar fend t = do - last_pic_ref <- newIORef Nothing - last_update_ref <- newIORef Nothing + shutdownVar <- newTVarIO False + let shutdownIo = do + alreadyShutdown <- atomically $ swapTVar shutdownVar True + when (not alreadyShutdown) $ do + shutdownInput input + releaseDisplay out + releaseTerminal out - let inner_update in_pic = do - b <- display_bounds t - let DisplayRegion w h = b - cursor = pic_cursor in_pic - in_pic' = case cursor of - Cursor x y -> - let - x' = case x of - _ | x >= 0x80000000 -> 0 - | x >= w -> w - 1 - | otherwise -> x - y' = case y of - _ | y >= 0x80000000 -> 0 - | y >= h -> h - 1 - | otherwise -> y - in in_pic { pic_cursor = Cursor x' y' } - _ -> in_pic - mlast_update <- readIORef last_update_ref - update_data <- case mlast_update of + shutdownStatus = readTVarIO shutdownVar + + lastPicRef <- newIORef Nothing + lastUpdateRef <- newIORef Nothing + + let innerUpdate inPic = do + b <- displayBounds out + mlastUpdate <- readIORef lastUpdateRef + updateData <- case mlastUpdate of Nothing -> do - d <- display_context t b - output_picture d in_pic' - return (b, d) - Just (last_bounds, last_context) -> do - if b /= last_bounds + dc <- displayContext out b + outputPicture dc inPic + return (b, dc) + Just (lastBounds, lastContext) -> do + if b /= lastBounds then do - d <- display_context t b - output_picture d in_pic' - return (b, d) + dc <- displayContext out b + outputPicture dc inPic + return (b, dc) else do - output_picture last_context in_pic' - return (b, last_context) - writeIORef last_update_ref $ Just update_data - writeIORef last_pic_ref $ Just in_pic' + outputPicture lastContext inPic + return (b, lastContext) + writeIORef lastUpdateRef $ Just updateData + writeIORef lastPicRef $ Just inPic - let inner_refresh - = writeIORef last_update_ref Nothing - >> readIORef last_pic_ref - >>= maybe ( return () ) ( \pic -> inner_update pic ) + innerRefresh = do + writeIORef lastUpdateRef Nothing + bounds <- displayBounds out + dc <- displayContext out bounds + writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState + mPic <- readIORef lastPicRef + maybe (return ()) innerUpdate mPic - let gkey = do k <- kvar - case k of - (EvResize _ _) -> inner_refresh - >> display_bounds t - >>= return . ( \(DisplayRegion w h) - -> EvResize (fromEnum w) (fromEnum h) - ) - _ -> return k + mkResize = uncurry EvResize <$> displayBounds out - return $ Vty { update = inner_update - , next_event = gkey - , terminal = t - , refresh = inner_refresh - , shutdown = fend + translateInternalEvent ResumeAfterInterrupt = mkResize + translateInternalEvent (InputEvent e) = return e + + gkey = do + e <- atomically $ readTChan $ eventChannel input + translateInternalEvent e + gkey' = do + mEv <- atomically $ tryReadTChan $ eventChannel input + case mEv of + Just e -> Just <$> translateInternalEvent e + Nothing -> return Nothing + + return $ Vty { update = innerUpdate + , nextEvent = gkey + , nextEventNonblocking = gkey' + , inputIface = input + , outputIface = out + , refresh = innerRefresh + , shutdown = shutdownIo + , isShutdown = shutdownStatus } +-- | Set the terminal window title string. +setWindowTitle :: Vty -> String -> IO () +setWindowTitle vty title = + setOutputWindowTitle (outputIface vty) title diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs --- a/src/Graphics/Vty/Attributes.hs +++ b/src/Graphics/Vty/Attributes.hs @@ -1,11 +1,89 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + -- | Display attributes -- --- For efficiency, this could be encoded into a single 32 bit word. The 32 bit word is first divided --- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to --- the other groups. +-- Attributes have three components: a foreground color, a background +-- color, and a style mask. The simplest attribute is the default +-- attribute, or 'defAttr'. Attributes can be modified with +-- 'withForeColor', 'withBackColor', and 'withStyle', e.g., +-- +-- @ +-- defAttr \`withForeColor\` red +-- @ +-- +-- 'Image' constructors often require an 'Attr' to indicate the +-- attributes used in the image, e.g., +-- +-- @ +-- string (defAttr \`withForeColor\` red) "this text will be red" +-- @ +-- +-- The appearance of 'Image's using 'defAttr' is determined by the The +-- terminal, so this is not something VTY can control. The user is free +-- to The define the color scheme of the terminal as they see fit. +-- +-- The value 'currentAttr' will keep the attributes of whatever was +-- output previously. +module Graphics.Vty.Attributes + ( module Graphics.Vty.Attributes.Color + + , Attr(..) + , FixedAttr(..) + , MaybeDefault(..) + , defAttr + , currentAttr + + -- * Styles + , Style + , withStyle + , standout + , italic + , strikethrough + , underline + , reverseVideo + , blink + , dim + , bold + , defaultStyleMask + , styleMask + , hasStyle + + -- * Setting attribute colors + , withForeColor + , withBackColor + + -- * Setting hyperlinks + , withURL + ) +where + +import Control.DeepSeq +import Data.Bits +import Data.Text (Text) +import Data.Word +import GHC.Generics + +import Graphics.Vty.Attributes.Color + +-- | A display attribute defines the Color and Style of all the +-- characters rendered after the attribute is applied. +-- +-- At most 256 colors, picked from a 240 and 16 color palette, are +-- possible for the background and foreground. The 240 colors and +-- 16 colors are points in different palettes. See Color for more +-- information. +data Attr = Attr + { attrStyle :: !(MaybeDefault Style) + , attrForeColor :: !(MaybeDefault Color) + , attrBackColor :: !(MaybeDefault Color) + , attrURL :: !(MaybeDefault Text) + } deriving ( Eq, Show, Read, Generic, NFData ) + +-- This could be encoded into a single 32 bit word. The 32 bit word is +-- first divided into 4 groups of 8 bits where: The first group codes +-- what action should be taken with regards to the other groups. -- XXYYZZ__ -- XX - style action -- 00 => reset to default @@ -22,115 +100,53 @@ -- __ - unused -- -- Next is the style flags --- SURBDO__ +-- SURBDOI_ -- S - standout -- U - underline -- R - reverse video -- B - blink -- D - dim -- O - bold --- __ - unused +-- I - italic +-- _ - unused -- -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits. --- -module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes - , module Graphics.Vty.Attributes.Color - , module Graphics.Vty.Attributes.Color240 - ) - where -import Graphics.Vty.Attributes.Color -import Graphics.Vty.Attributes.Color240 - -import Data.Bits -import Data.Monoid -import Data.Word - --- | A display attribute defines the Color and Style of all the characters rendered after the --- attribute is applied. --- --- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and --- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more --- information. -data Attr = Attr - { attr_style :: !(MaybeDefault Style) - , attr_fore_color :: !(MaybeDefault Color) - , attr_back_color :: !(MaybeDefault Color) - } deriving ( Eq, Show ) - -instance Monoid Attr where - mempty = Attr mempty mempty mempty - mappend attr_0 attr_1 = - Attr ( attr_style attr_0 `mappend` attr_style attr_1 ) - ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 ) - ( attr_back_color attr_0 `mappend` attr_back_color attr_1 ) - --- | Specifies the display attributes such that the final style and color values do not depend on --- the previously applied display attribute. The display attributes can still depend on the --- terminal's default colors (unfortunately). +-- | Specifies the display attributes such that the final style and +-- color values do not depend on the previously applied display +-- attribute. The display attributes can still depend on the terminal's +-- default colors (unfortunately). data FixedAttr = FixedAttr - { fixed_style :: !Style - , fixed_fore_color :: !(Maybe Color) - , fixed_back_color :: !(Maybe Color) + { fixedStyle :: !Style + , fixedForeColor :: !(Maybe Color) + , fixedBackColor :: !(Maybe Color) + , fixedURL :: !(Maybe Text) } deriving ( Eq, Show ) --- | The style and color attributes can either be the terminal defaults. Or be equivalent to the --- previously applied style. Or be a specific value. -data MaybeDefault v where - Default :: MaybeDefault v - KeepCurrent :: MaybeDefault v - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - -deriving instance Eq v => Eq (MaybeDefault v) -deriving instance Eq v => Show (MaybeDefault v) - -instance Eq v => Monoid ( MaybeDefault v ) where - mempty = KeepCurrent - mappend Default Default = Default - mappend Default KeepCurrent = Default - mappend Default ( SetTo v ) = SetTo v - mappend KeepCurrent Default = Default - mappend KeepCurrent KeepCurrent = KeepCurrent - mappend KeepCurrent ( SetTo v ) = SetTo v - mappend ( SetTo _v ) Default = Default - mappend ( SetTo v ) KeepCurrent = SetTo v - mappend ( SetTo _ ) ( SetTo v ) = SetTo v - --- | Standard 8-color ANSI terminal color codes. -black, red, green, yellow, blue, magenta, cyan, white :: Color -black = ISOColor 0 -red = ISOColor 1 -green = ISOColor 2 -yellow = ISOColor 3 -blue = ISOColor 4 -magenta= ISOColor 5 -cyan = ISOColor 6 -white = ISOColor 7 +-- | The style and color attributes can either be the terminal defaults. +-- Or be equivalent to the previously applied style. Or be a specific +-- value. +data MaybeDefault v = Default | KeepCurrent | SetTo !v + deriving (Eq, Read, Show) --- | Bright/Vivid variants of the standard 8-color ANSI -bright_black, bright_red, bright_green, bright_yellow :: Color -bright_blue, bright_magenta, bright_cyan, bright_white :: Color -bright_black = ISOColor 8 -bright_red = ISOColor 9 -bright_green = ISOColor 10 -bright_yellow = ISOColor 11 -bright_blue = ISOColor 12 -bright_magenta= ISOColor 13 -bright_cyan = ISOColor 14 -bright_white = ISOColor 15 +instance (NFData v) => NFData (MaybeDefault v) where + rnf Default = () + rnf KeepCurrent = () + rnf (SetTo v) = rnf v --- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute --- assigned to that bit should be applied and 0 if the style attribute should not be applied. +-- | Styles are represented as an 8 bit word. Each bit in the word is 1 +-- if the style attribute assigned to that bit should be applied and 0 +-- if the style attribute should not be applied. type Style = Word8 --- | The 6 possible style attributes: +-- | Valid style attributes include: -- -- * standout -- -- * underline -- --- * reverse_video +-- * reverseVideo -- -- * blink -- @@ -138,54 +154,75 @@ -- -- * bold/bright -- --- ( The invisible, protect, and altcharset display attributes some terminals support are not --- supported via VTY.) -standout, underline, reverse_video, blink, dim, bold :: Style +-- * italic +-- +-- * strikethrough (via the smxx/rmxx terminfo capabilities) +-- +-- (The invisible, protect, and altcharset display attributes some +-- terminals support are not supported via VTY.) +standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style standout = 0x01 underline = 0x02 -reverse_video = 0x04 +reverseVideo = 0x04 blink = 0x08 dim = 0x10 bold = 0x20 +italic = 0x40 +strikethrough = 0x80 -default_style_mask :: Style -default_style_mask = 0x00 +defaultStyleMask :: Style +defaultStyleMask = 0x00 -style_mask :: Attr -> Word8 -style_mask attr - = case attr_style attr of +styleMask :: Attr -> Word8 +styleMask attr + = case attrStyle attr of Default -> 0 KeepCurrent -> 0 SetTo v -> v -- | true if the given Style value has the specified Style set. -has_style :: Style -> Style -> Bool -has_style s bit_mask = ( s .&. bit_mask ) /= 0 +hasStyle :: Style -> Style -> Bool +hasStyle s bitMask = ( s .&. bitMask ) /= 0 -- | Set the foreground color of an `Attr'. -with_fore_color :: Attr -> Color -> Attr -with_fore_color attr c = attr { attr_fore_color = SetTo c } +withForeColor :: Attr -> Color -> Attr +withForeColor attr c = attr { attrForeColor = SetTo c } -- | Set the background color of an `Attr'. -with_back_color :: Attr -> Color -> Attr -with_back_color attr c = attr { attr_back_color = SetTo c } +withBackColor :: Attr -> Color -> Attr +withBackColor attr c = attr { attrBackColor = SetTo c } -- | Add the given style attribute -with_style :: Attr -> Style -> Attr -with_style attr style_flag = attr { attr_style = SetTo $ style_mask attr .|. style_flag } +withStyle :: Attr -> Style -> Attr +withStyle attr 0 = attr +withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } --- | Sets the style, background color and foreground color to the default values for the terminal. --- There is no easy way to determine what the default background and foreground colors are. -def_attr :: Attr -def_attr = Attr Default Default Default +-- | Add a hyperlinked URL using the proposed [escape sequences for +-- hyperlinked +-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). +-- These escape sequences are comparatively new and aren't widely +-- supported in terminal emulators yet, but most terminal emulators +-- that don't know about these sequences will ignore these sequences, +-- and therefore this should fall back sensibly. In some cases they +-- won't and this will result in garbage, so this is why hyperlinking is +-- disabled by default, in which case this combinator has no observable +-- effect. To enable it, enable 'Hyperlink' mode on your Vty output +-- interface. +withURL :: Attr -> Text -> Attr +withURL attr url = attr { attrURL = SetTo url } --- | Keeps the style, background color and foreground color that was previously set. Used to --- override some part of the previous style. +-- | Sets the style, background color and foreground color to the +-- default values for the terminal. There is no easy way to determine +-- what the default background and foreground colors are. +defAttr :: Attr +defAttr = Attr Default Default Default Default + +-- | Keeps the style, background color and foreground color that was +-- previously set. Used to override some part of the previous style. -- --- EG: current_style `with_fore_color` bright_magenta +-- EG: current_style `withForeColor` brightMagenta -- --- Would be the currently applied style (be it underline, bold, etc) but with the foreground color --- set to bright_magenta. -current_attr :: Attr -current_attr = Attr KeepCurrent KeepCurrent KeepCurrent - +-- Would be the currently applied style (be it underline, bold, etc) but +-- with the foreground color set to brightMagenta. +currentAttr :: Attr +currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent diff --git a/src/Graphics/Vty/Attributes/Color.hs b/src/Graphics/Vty/Attributes/Color.hs --- a/src/Graphics/Vty/Attributes/Color.hs +++ b/src/Graphics/Vty/Attributes/Color.hs @@ -1,51 +1,173 @@ -module Graphics.Vty.Attributes.Color where +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Graphics.Vty.Attributes.Color + ( Color(..) + , ColorMode(..) + + -- ** Fixed Colors + -- | Standard 8-color ANSI terminal color codes. + -- + -- Note that these map to colors in the terminal's custom palette. For + -- instance, `white` maps to whatever the terminal color theme uses for + -- white. + -- + -- Use these functions if you want to make apps that fit the terminal theme. + -- If you want access to more/stronger colors use `rgbColor` + , black + , red + , green + , yellow + , blue + , magenta + , cyan + , white + + -- | Bright/Vivid variants of the standard 8-color ANSI + , brightBlack + , brightRed + , brightGreen + , brightYellow + , brightBlue + , brightMagenta + , brightCyan + , brightWhite + -- ** Creating Colors From RGB + , linearColor + , srgbColor + , rgbColor + , color240 + , module Graphics.Vty.Attributes.Color240 + ) +where + import Data.Word +import GHC.Generics +import Control.DeepSeq +import Graphics.Vty.Attributes.Color240 + -- | Abstract data type representing a color. --- --- Currently the foreground and background color are specified as points in either a: -- --- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8 --- color palette and the second 8 colors are bright/vivid versions of the first 8 colors. +-- Currently the foreground and background color are specified as points +-- in either a: -- --- * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first --- 224 colors. The remaining 16 colors is a greyscale palette. --- +-- * 16 color palette. Where the first 8 colors are equal to the 8 +-- colors of the ISO 6429 (ANSI) 8 color palette and the second 8 +-- colors are bright/vivid versions of the first 8 colors. +-- +-- * 240 color palette. This palette is a regular sampling of the full +-- RGB colorspace for the first 224 colors. The remaining 16 colors is +-- a greyscale palette. +-- -- The 8 ISO 6429 (ANSI) colors are as follows: -- --- 0. black +-- * black (0) -- --- 1. red +-- * red (1) -- --- 2. green +-- * green (2) -- --- 3. yellow +-- * yellow (3) -- --- 4. blue +-- * blue (4) -- --- 5. magenta +-- * magenta (5) -- --- 6. cyan +-- * cyan (6) -- --- 7. white +-- * white (7) -- --- The mapping from points in the 240 color palette to colors actually displayable by the terminal --- depends on the number of colors the terminal claims to support. Which is usually determined by --- the terminfo "colors" property. If this property is not being accurately reported then the color --- reproduction will be incorrect. +-- The mapping from points in the 240 color palette to colors actually +-- displayable by the terminal depends on the number of colors the +-- terminal claims to support. Which is usually determined by the +-- terminfo "colors" property. If this property is not being accurately +-- reported then the color reproduction will be incorrect. -- --- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8 --- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not --- addressable via the 240 color palette. +-- If the terminal reports <= 16 colors then the 240 color palette +-- points are only mapped to the 8 color palette. I'm not sure of +-- the RGB points for the "bright" colors which is why they are not +-- addressable via the 240 color palette. -- --- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest --- points in a ("color count" - 16) subsampling of the 240 color palette. +-- If the terminal reports > 16 colors then the 240 color palette +-- points are mapped to the nearest points in a ("color count" - 16) +-- subsampling of the 240 color palette. -- --- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors. --- And that the individual colors have not been remapped by the user. There may be a way to verify --- this through terminfo but I don't know it. +-- All of this assumes the terminals are behaving similarly to xterm and +-- rxvt when handling colors. And that the individual colors have not +-- been remapped by the user. There may be a way to verify this through +-- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE. -data Color = ISOColor !Word8 | Color240 !Word8 - deriving ( Eq, Show ) +data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8 + deriving ( Eq, Show, Read, Generic, NFData ) +data ColorMode + = NoColor + | ColorMode8 + | ColorMode16 + | ColorMode240 !Word8 + | FullColor + deriving ( Eq, Show, Read ) + +black, red, green, yellow, blue, magenta, cyan, white :: Color +black = ISOColor 0 +red = ISOColor 1 +green = ISOColor 2 +yellow = ISOColor 3 +blue = ISOColor 4 +magenta= ISOColor 5 +cyan = ISOColor 6 +white = ISOColor 7 + +brightBlack, brightRed, brightGreen, brightYellow :: Color +brightBlue, brightMagenta, brightCyan, brightWhite :: Color +brightBlack = ISOColor 8 +brightRed = ISOColor 9 +brightGreen = ISOColor 10 +brightYellow = ISOColor 11 +brightBlue = ISOColor 12 +brightMagenta= ISOColor 13 +brightCyan = ISOColor 14 +brightWhite = ISOColor 15 + +-- | Create a color value from RGB values in the 0..255 range inclusive. +-- No transformation of the input values is done; a color is created +-- directly from the RGB values specified, unlike the 'srgbColor' and +-- 'color240' functions. +linearColor :: Integral i => i -> i -> i -> Color +linearColor r g b = RGBColor r' g' b' + where + r' = fromIntegral (clamp r) :: Word8 + g' = fromIntegral (clamp g) :: Word8 + b' = fromIntegral (clamp b) :: Word8 + clamp = min 255 . max 0 + +-- | Given RGB values in the range 0..255 inclusive, create a color +-- using the sRGB transformation described at +-- +-- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation +srgbColor :: Integral i => i -> i -> i -> Color +srgbColor r g b = + -- TODO: it may be worth translating this to a lookup table, as with color240 + let shrink n = fromIntegral n / 255 :: Double + -- called gamma^-1 in wiki + gamma u + | u <= 0.04045 = u/12.92 + | otherwise = ((u + 0.055) / 1.055) ** 2.4 + -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly? + expand n = round (255 * n) + convert = expand . gamma . shrink + in RGBColor (convert r) (convert g) (convert b) + +color240 :: Integral i => i -> i -> i -> Color +color240 r g b = Color240 (rgbColorToColor240 r g b) + +-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple. +-- This is a synonym for 'color240'. This function is lossy in the sense +-- that we only internally support 240 colors but the #RRGGBB format +-- supports 256^3 colors. +rgbColor :: Integral i => i -> i -> i -> Color +rgbColor = color240 diff --git a/src/Graphics/Vty/Attributes/Color240.hs b/src/Graphics/Vty/Attributes/Color240.hs --- a/src/Graphics/Vty/Attributes/Color240.hs +++ b/src/Graphics/Vty/Attributes/Color240.hs @@ -1,261 +1,301 @@ -{- - - This header file was generated by ./256colres.pl - -} -module Graphics.Vty.Attributes.Color240 where - -import Graphics.Vty.Attributes.Color +-- This header file was generated by ./256colres.pl +module Graphics.Vty.Attributes.Color240 + ( rgbColorToColor240 + , color240CodeToRGB + ) +where +import Data.Word (Word8) import Text.Printf --- | 8 bit RGB color to 240 color palette. +-- Note: rgbColor's mapping from RGB to 240 colors was generated from +-- 256colres.pl which is forked from xterm 256colres.pl. + +-- | Create a value in the Color240 set from an RGB triple. This maps +-- the input arguments to an entry in the 240-color palette depicted at: -- --- generated from 256colres.pl which is forked from xterm 256colres.pl --- todo: all values get clamped high. -rgb_color :: Integral i => i -> i -> i -> Color -rgb_color r g b - | r < 0 && g < 0 && b < 0 = error "rgb_color with negative color component intensity" - | r == 8 && g == 8 && b == 8 = Color240 216 - | r == 18 && g == 18 && b == 18 = Color240 217 - | r == 28 && g == 28 && b == 28 = Color240 218 - | r == 38 && g == 38 && b == 38 = Color240 219 - | r == 48 && g == 48 && b == 48 = Color240 220 - | r == 58 && g == 58 && b == 58 = Color240 221 - | r == 68 && g == 68 && b == 68 = Color240 222 - | r == 78 && g == 78 && b == 78 = Color240 223 - | r == 88 && g == 88 && b == 88 = Color240 224 - | r == 98 && g == 98 && b == 98 = Color240 225 - | r == 108 && g == 108 && b == 108 = Color240 226 - | r == 118 && g == 118 && b == 118 = Color240 227 - | r == 128 && g == 128 && b == 128 = Color240 228 - | r == 138 && g == 138 && b == 138 = Color240 229 - | r == 148 && g == 148 && b == 148 = Color240 230 - | r == 158 && g == 158 && b == 158 = Color240 231 - | r == 168 && g == 168 && b == 168 = Color240 232 - | r == 178 && g == 178 && b == 178 = Color240 233 - | r == 188 && g == 188 && b == 188 = Color240 234 - | r == 198 && g == 198 && b == 198 = Color240 235 - | r == 208 && g == 208 && b == 208 = Color240 236 - | r == 218 && g == 218 && b == 218 = Color240 237 - | r == 228 && g == 228 && b == 228 = Color240 238 - | r == 238 && g == 238 && b == 238 = Color240 239 - | r <= 0 && g <= 0 && b <= 0 = Color240 0 - | r <= 0 && g <= 0 && b <= 95 = Color240 1 - | r <= 0 && g <= 0 && b <= 135 = Color240 2 - | r <= 0 && g <= 0 && b <= 175 = Color240 3 - | r <= 0 && g <= 0 && b <= 215 = Color240 4 - | r <= 0 && g <= 0 && b <= 255 = Color240 5 - | r <= 0 && g <= 95 && b <= 0 = Color240 6 - | r <= 0 && g <= 95 && b <= 95 = Color240 7 - | r <= 0 && g <= 95 && b <= 135 = Color240 8 - | r <= 0 && g <= 95 && b <= 175 = Color240 9 - | r <= 0 && g <= 95 && b <= 215 = Color240 10 - | r <= 0 && g <= 95 && b <= 255 = Color240 11 - | r <= 0 && g <= 135 && b <= 0 = Color240 12 - | r <= 0 && g <= 135 && b <= 95 = Color240 13 - | r <= 0 && g <= 135 && b <= 135 = Color240 14 - | r <= 0 && g <= 135 && b <= 175 = Color240 15 - | r <= 0 && g <= 135 && b <= 215 = Color240 16 - | r <= 0 && g <= 135 && b <= 255 = Color240 17 - | r <= 0 && g <= 175 && b <= 0 = Color240 18 - | r <= 0 && g <= 175 && b <= 95 = Color240 19 - | r <= 0 && g <= 175 && b <= 135 = Color240 20 - | r <= 0 && g <= 175 && b <= 175 = Color240 21 - | r <= 0 && g <= 175 && b <= 215 = Color240 22 - | r <= 0 && g <= 175 && b <= 255 = Color240 23 - | r <= 0 && g <= 215 && b <= 0 = Color240 24 - | r <= 0 && g <= 215 && b <= 95 = Color240 25 - | r <= 0 && g <= 215 && b <= 135 = Color240 26 - | r <= 0 && g <= 215 && b <= 175 = Color240 27 - | r <= 0 && g <= 215 && b <= 215 = Color240 28 - | r <= 0 && g <= 215 && b <= 255 = Color240 29 - | r <= 0 && g <= 255 && b <= 0 = Color240 30 - | r <= 0 && g <= 255 && b <= 95 = Color240 31 - | r <= 0 && g <= 255 && b <= 135 = Color240 32 - | r <= 0 && g <= 255 && b <= 175 = Color240 33 - | r <= 0 && g <= 255 && b <= 215 = Color240 34 - | r <= 0 && g <= 255 && b <= 255 = Color240 35 - | r <= 95 && g <= 0 && b <= 0 = Color240 36 - | r <= 95 && g <= 0 && b <= 95 = Color240 37 - | r <= 95 && g <= 0 && b <= 135 = Color240 38 - | r <= 95 && g <= 0 && b <= 175 = Color240 39 - | r <= 95 && g <= 0 && b <= 215 = Color240 40 - | r <= 95 && g <= 0 && b <= 255 = Color240 41 - | r <= 95 && g <= 95 && b <= 0 = Color240 42 - | r <= 95 && g <= 95 && b <= 95 = Color240 43 - | r <= 95 && g <= 95 && b <= 135 = Color240 44 - | r <= 95 && g <= 95 && b <= 175 = Color240 45 - | r <= 95 && g <= 95 && b <= 215 = Color240 46 - | r <= 95 && g <= 95 && b <= 255 = Color240 47 - | r <= 95 && g <= 135 && b <= 0 = Color240 48 - | r <= 95 && g <= 135 && b <= 95 = Color240 49 - | r <= 95 && g <= 135 && b <= 135 = Color240 50 - | r <= 95 && g <= 135 && b <= 175 = Color240 51 - | r <= 95 && g <= 135 && b <= 215 = Color240 52 - | r <= 95 && g <= 135 && b <= 255 = Color240 53 - | r <= 95 && g <= 175 && b <= 0 = Color240 54 - | r <= 95 && g <= 175 && b <= 95 = Color240 55 - | r <= 95 && g <= 175 && b <= 135 = Color240 56 - | r <= 95 && g <= 175 && b <= 175 = Color240 57 - | r <= 95 && g <= 175 && b <= 215 = Color240 58 - | r <= 95 && g <= 175 && b <= 255 = Color240 59 - | r <= 95 && g <= 215 && b <= 0 = Color240 60 - | r <= 95 && g <= 215 && b <= 95 = Color240 61 - | r <= 95 && g <= 215 && b <= 135 = Color240 62 - | r <= 95 && g <= 215 && b <= 175 = Color240 63 - | r <= 95 && g <= 215 && b <= 215 = Color240 64 - | r <= 95 && g <= 215 && b <= 255 = Color240 65 - | r <= 95 && g <= 255 && b <= 0 = Color240 66 - | r <= 95 && g <= 255 && b <= 95 = Color240 67 - | r <= 95 && g <= 255 && b <= 135 = Color240 68 - | r <= 95 && g <= 255 && b <= 175 = Color240 69 - | r <= 95 && g <= 255 && b <= 215 = Color240 70 - | r <= 95 && g <= 255 && b <= 255 = Color240 71 - | r <= 135 && g <= 0 && b <= 0 = Color240 72 - | r <= 135 && g <= 0 && b <= 95 = Color240 73 - | r <= 135 && g <= 0 && b <= 135 = Color240 74 - | r <= 135 && g <= 0 && b <= 175 = Color240 75 - | r <= 135 && g <= 0 && b <= 215 = Color240 76 - | r <= 135 && g <= 0 && b <= 255 = Color240 77 - | r <= 135 && g <= 95 && b <= 0 = Color240 78 - | r <= 135 && g <= 95 && b <= 95 = Color240 79 - | r <= 135 && g <= 95 && b <= 135 = Color240 80 - | r <= 135 && g <= 95 && b <= 175 = Color240 81 - | r <= 135 && g <= 95 && b <= 215 = Color240 82 - | r <= 135 && g <= 95 && b <= 255 = Color240 83 - | r <= 135 && g <= 135 && b <= 0 = Color240 84 - | r <= 135 && g <= 135 && b <= 95 = Color240 85 - | r <= 135 && g <= 135 && b <= 135 = Color240 86 - | r <= 135 && g <= 135 && b <= 175 = Color240 87 - | r <= 135 && g <= 135 && b <= 215 = Color240 88 - | r <= 135 && g <= 135 && b <= 255 = Color240 89 - | r <= 135 && g <= 175 && b <= 0 = Color240 90 - | r <= 135 && g <= 175 && b <= 95 = Color240 91 - | r <= 135 && g <= 175 && b <= 135 = Color240 92 - | r <= 135 && g <= 175 && b <= 175 = Color240 93 - | r <= 135 && g <= 175 && b <= 215 = Color240 94 - | r <= 135 && g <= 175 && b <= 255 = Color240 95 - | r <= 135 && g <= 215 && b <= 0 = Color240 96 - | r <= 135 && g <= 215 && b <= 95 = Color240 97 - | r <= 135 && g <= 215 && b <= 135 = Color240 98 - | r <= 135 && g <= 215 && b <= 175 = Color240 99 - | r <= 135 && g <= 215 && b <= 215 = Color240 100 - | r <= 135 && g <= 215 && b <= 255 = Color240 101 - | r <= 135 && g <= 255 && b <= 0 = Color240 102 - | r <= 135 && g <= 255 && b <= 95 = Color240 103 - | r <= 135 && g <= 255 && b <= 135 = Color240 104 - | r <= 135 && g <= 255 && b <= 175 = Color240 105 - | r <= 135 && g <= 255 && b <= 215 = Color240 106 - | r <= 135 && g <= 255 && b <= 255 = Color240 107 - | r <= 175 && g <= 0 && b <= 0 = Color240 108 - | r <= 175 && g <= 0 && b <= 95 = Color240 109 - | r <= 175 && g <= 0 && b <= 135 = Color240 110 - | r <= 175 && g <= 0 && b <= 175 = Color240 111 - | r <= 175 && g <= 0 && b <= 215 = Color240 112 - | r <= 175 && g <= 0 && b <= 255 = Color240 113 - | r <= 175 && g <= 95 && b <= 0 = Color240 114 - | r <= 175 && g <= 95 && b <= 95 = Color240 115 - | r <= 175 && g <= 95 && b <= 135 = Color240 116 - | r <= 175 && g <= 95 && b <= 175 = Color240 117 - | r <= 175 && g <= 95 && b <= 215 = Color240 118 - | r <= 175 && g <= 95 && b <= 255 = Color240 119 - | r <= 175 && g <= 135 && b <= 0 = Color240 120 - | r <= 175 && g <= 135 && b <= 95 = Color240 121 - | r <= 175 && g <= 135 && b <= 135 = Color240 122 - | r <= 175 && g <= 135 && b <= 175 = Color240 123 - | r <= 175 && g <= 135 && b <= 215 = Color240 124 - | r <= 175 && g <= 135 && b <= 255 = Color240 125 - | r <= 175 && g <= 175 && b <= 0 = Color240 126 - | r <= 175 && g <= 175 && b <= 95 = Color240 127 - | r <= 175 && g <= 175 && b <= 135 = Color240 128 - | r <= 175 && g <= 175 && b <= 175 = Color240 129 - | r <= 175 && g <= 175 && b <= 215 = Color240 130 - | r <= 175 && g <= 175 && b <= 255 = Color240 131 - | r <= 175 && g <= 215 && b <= 0 = Color240 132 - | r <= 175 && g <= 215 && b <= 95 = Color240 133 - | r <= 175 && g <= 215 && b <= 135 = Color240 134 - | r <= 175 && g <= 215 && b <= 175 = Color240 135 - | r <= 175 && g <= 215 && b <= 215 = Color240 136 - | r <= 175 && g <= 215 && b <= 255 = Color240 137 - | r <= 175 && g <= 255 && b <= 0 = Color240 138 - | r <= 175 && g <= 255 && b <= 95 = Color240 139 - | r <= 175 && g <= 255 && b <= 135 = Color240 140 - | r <= 175 && g <= 255 && b <= 175 = Color240 141 - | r <= 175 && g <= 255 && b <= 215 = Color240 142 - | r <= 175 && g <= 255 && b <= 255 = Color240 143 - | r <= 215 && g <= 0 && b <= 0 = Color240 144 - | r <= 215 && g <= 0 && b <= 95 = Color240 145 - | r <= 215 && g <= 0 && b <= 135 = Color240 146 - | r <= 215 && g <= 0 && b <= 175 = Color240 147 - | r <= 215 && g <= 0 && b <= 215 = Color240 148 - | r <= 215 && g <= 0 && b <= 255 = Color240 149 - | r <= 215 && g <= 95 && b <= 0 = Color240 150 - | r <= 215 && g <= 95 && b <= 95 = Color240 151 - | r <= 215 && g <= 95 && b <= 135 = Color240 152 - | r <= 215 && g <= 95 && b <= 175 = Color240 153 - | r <= 215 && g <= 95 && b <= 215 = Color240 154 - | r <= 215 && g <= 95 && b <= 255 = Color240 155 - | r <= 215 && g <= 135 && b <= 0 = Color240 156 - | r <= 215 && g <= 135 && b <= 95 = Color240 157 - | r <= 215 && g <= 135 && b <= 135 = Color240 158 - | r <= 215 && g <= 135 && b <= 175 = Color240 159 - | r <= 215 && g <= 135 && b <= 215 = Color240 160 - | r <= 215 && g <= 135 && b <= 255 = Color240 161 - | r <= 215 && g <= 175 && b <= 0 = Color240 162 - | r <= 215 && g <= 175 && b <= 95 = Color240 163 - | r <= 215 && g <= 175 && b <= 135 = Color240 164 - | r <= 215 && g <= 175 && b <= 175 = Color240 165 - | r <= 215 && g <= 175 && b <= 215 = Color240 166 - | r <= 215 && g <= 175 && b <= 255 = Color240 167 - | r <= 215 && g <= 215 && b <= 0 = Color240 168 - | r <= 215 && g <= 215 && b <= 95 = Color240 169 - | r <= 215 && g <= 215 && b <= 135 = Color240 170 - | r <= 215 && g <= 215 && b <= 175 = Color240 171 - | r <= 215 && g <= 215 && b <= 215 = Color240 172 - | r <= 215 && g <= 215 && b <= 255 = Color240 173 - | r <= 215 && g <= 255 && b <= 0 = Color240 174 - | r <= 215 && g <= 255 && b <= 95 = Color240 175 - | r <= 215 && g <= 255 && b <= 135 = Color240 176 - | r <= 215 && g <= 255 && b <= 175 = Color240 177 - | r <= 215 && g <= 255 && b <= 215 = Color240 178 - | r <= 215 && g <= 255 && b <= 255 = Color240 179 - | r <= 255 && g <= 0 && b <= 0 = Color240 180 - | r <= 255 && g <= 0 && b <= 95 = Color240 181 - | r <= 255 && g <= 0 && b <= 135 = Color240 182 - | r <= 255 && g <= 0 && b <= 175 = Color240 183 - | r <= 255 && g <= 0 && b <= 215 = Color240 184 - | r <= 255 && g <= 0 && b <= 255 = Color240 185 - | r <= 255 && g <= 95 && b <= 0 = Color240 186 - | r <= 255 && g <= 95 && b <= 95 = Color240 187 - | r <= 255 && g <= 95 && b <= 135 = Color240 188 - | r <= 255 && g <= 95 && b <= 175 = Color240 189 - | r <= 255 && g <= 95 && b <= 215 = Color240 190 - | r <= 255 && g <= 95 && b <= 255 = Color240 191 - | r <= 255 && g <= 135 && b <= 0 = Color240 192 - | r <= 255 && g <= 135 && b <= 95 = Color240 193 - | r <= 255 && g <= 135 && b <= 135 = Color240 194 - | r <= 255 && g <= 135 && b <= 175 = Color240 195 - | r <= 255 && g <= 135 && b <= 215 = Color240 196 - | r <= 255 && g <= 135 && b <= 255 = Color240 197 - | r <= 255 && g <= 175 && b <= 0 = Color240 198 - | r <= 255 && g <= 175 && b <= 95 = Color240 199 - | r <= 255 && g <= 175 && b <= 135 = Color240 200 - | r <= 255 && g <= 175 && b <= 175 = Color240 201 - | r <= 255 && g <= 175 && b <= 215 = Color240 202 - | r <= 255 && g <= 175 && b <= 255 = Color240 203 - | r <= 255 && g <= 215 && b <= 0 = Color240 204 - | r <= 255 && g <= 215 && b <= 95 = Color240 205 - | r <= 255 && g <= 215 && b <= 135 = Color240 206 - | r <= 255 && g <= 215 && b <= 175 = Color240 207 - | r <= 255 && g <= 215 && b <= 215 = Color240 208 - | r <= 255 && g <= 215 && b <= 255 = Color240 209 - | r <= 255 && g <= 255 && b <= 0 = Color240 210 - | r <= 255 && g <= 255 && b <= 95 = Color240 211 - | r <= 255 && g <= 255 && b <= 135 = Color240 212 - | r <= 255 && g <= 255 && b <= 175 = Color240 213 - | r <= 255 && g <= 255 && b <= 215 = Color240 214 - | r <= 255 && g <= 255 && b <= 255 = Color240 215 - | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." +-- https://rich.readthedocs.io/en/stable/appendix/colors.html +rgbColorToColor240 :: Integral i => i -> i -> i -> Word8 +rgbColorToColor240 r g b + | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" + | r == 8 && g == 8 && b == 8 = 216 + | r == 18 && g == 18 && b == 18 = 217 + | r == 28 && g == 28 && b == 28 = 218 + | r == 38 && g == 38 && b == 38 = 219 + | r == 48 && g == 48 && b == 48 = 220 + | r == 58 && g == 58 && b == 58 = 221 + | r == 68 && g == 68 && b == 68 = 222 + | r == 78 && g == 78 && b == 78 = 223 + | r == 88 && g == 88 && b == 88 = 224 + | r == 98 && g == 98 && b == 98 = 225 + | r == 108 && g == 108 && b == 108 = 226 + | r == 118 && g == 118 && b == 118 = 227 + | r == 128 && g == 128 && b == 128 = 228 + | r == 138 && g == 138 && b == 138 = 229 + | r == 148 && g == 148 && b == 148 = 230 + | r == 158 && g == 158 && b == 158 = 231 + | r == 168 && g == 168 && b == 168 = 232 + | r == 178 && g == 178 && b == 178 = 233 + | r == 188 && g == 188 && b == 188 = 234 + | r == 198 && g == 198 && b == 198 = 235 + | r == 208 && g == 208 && b == 208 = 236 + | r == 218 && g == 218 && b == 218 = 237 + | r == 228 && g == 228 && b == 228 = 238 + | r == 238 && g == 238 && b == 238 = 239 + | otherwise = 36 * go r + 6 * go g + go b + where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette." (fromIntegral r :: Int) (fromIntegral g :: Int) - (fromIntegral b :: Int)) + (fromIntegral b :: Int))) +simpleColor_ :: Integral i => Word8 -> i -> Word8 +simpleColor_ e c + | c <= 0 = 0 + | c <= 95 = 1 + | c <= 255 = fromIntegral ((c-16) `div` 40) + | otherwise = e + +-- | Create a RGB triple from a value in the Color240 set. +color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int) +color240CodeToRGB n = case n of + 0 -> Just (0, 0, 0) + 1 -> Just (0, 0, 95) + 2 -> Just (0, 0, 135) + 3 -> Just (0, 0, 175) + 4 -> Just (0, 0, 215) + 5 -> Just (0, 0, 255) + 6 -> Just (0, 95, 0) + 7 -> Just (0, 95, 95) + 8 -> Just (0, 95, 135) + 9 -> Just (0, 95, 175) + 10 -> Just (0, 95, 215) + 11 -> Just (0, 95, 255) + 12 -> Just (0, 135, 0) + 13 -> Just (0, 135, 95) + 14 -> Just (0, 135, 135) + 15 -> Just (0, 135, 175) + 16 -> Just (0, 135, 215) + 17 -> Just (0, 135, 255) + 18 -> Just (0, 175, 0) + 19 -> Just (0, 175, 95) + 20 -> Just (0, 175, 135) + 21 -> Just (0, 175, 175) + 22 -> Just (0, 175, 215) + 23 -> Just (0, 175, 255) + 24 -> Just (0, 215, 0) + 25 -> Just (0, 215, 95) + 26 -> Just (0, 215, 135) + 27 -> Just (0, 215, 175) + 28 -> Just (0, 215, 215) + 29 -> Just (0, 215, 255) + 30 -> Just (0, 255, 0) + 31 -> Just (0, 255, 95) + 32 -> Just (0, 255, 135) + 33 -> Just (0, 255, 175) + 34 -> Just (0, 255, 215) + 35 -> Just (0, 255, 255) + 36 -> Just (95, 0, 0) + 37 -> Just (95, 0, 95) + 38 -> Just (95, 0, 135) + 39 -> Just (95, 0, 175) + 40 -> Just (95, 0, 215) + 41 -> Just (95, 0, 255) + 42 -> Just (95, 95, 0) + 43 -> Just (95, 95, 95) + 44 -> Just (95, 95, 135) + 45 -> Just (95, 95, 175) + 46 -> Just (95, 95, 215) + 47 -> Just (95, 95, 255) + 48 -> Just (95, 135, 0) + 49 -> Just (95, 135, 95) + 50 -> Just (95, 135, 135) + 51 -> Just (95, 135, 175) + 52 -> Just (95, 135, 215) + 53 -> Just (95, 135, 255) + 54 -> Just (95, 175, 0) + 55 -> Just (95, 175, 95) + 56 -> Just (95, 175, 135) + 57 -> Just (95, 175, 175) + 58 -> Just (95, 175, 215) + 59 -> Just (95, 175, 255) + 60 -> Just (95, 215, 0) + 61 -> Just (95, 215, 95) + 62 -> Just (95, 215, 135) + 63 -> Just (95, 215, 175) + 64 -> Just (95, 215, 215) + 65 -> Just (95, 215, 255) + 66 -> Just (95, 255, 0) + 67 -> Just (95, 255, 95) + 68 -> Just (95, 255, 135) + 69 -> Just (95, 255, 175) + 70 -> Just (95, 255, 215) + 71 -> Just (95, 255, 255) + 72 -> Just (135, 0, 0) + 73 -> Just (135, 0, 95) + 74 -> Just (135, 0, 135) + 75 -> Just (135, 0, 175) + 76 -> Just (135, 0, 215) + 77 -> Just (135, 0, 255) + 78 -> Just (135, 95, 0) + 79 -> Just (135, 95, 95) + 80 -> Just (135, 95, 135) + 81 -> Just (135, 95, 175) + 82 -> Just (135, 95, 215) + 83 -> Just (135, 95, 255) + 84 -> Just (135, 135, 0) + 85 -> Just (135, 135, 95) + 86 -> Just (135, 135, 135) + 87 -> Just (135, 135, 175) + 88 -> Just (135, 135, 215) + 89 -> Just (135, 135, 255) + 90 -> Just (135, 175, 0) + 91 -> Just (135, 175, 95) + 92 -> Just (135, 175, 135) + 93 -> Just (135, 175, 175) + 94 -> Just (135, 175, 215) + 95 -> Just (135, 175, 255) + 96 -> Just (135, 215, 0) + 97 -> Just (135, 215, 95) + 98 -> Just (135, 215, 135) + 99 -> Just (135, 215, 175) + 100 -> Just (135, 215, 215) + 101 -> Just (135, 215, 255) + 102 -> Just (135, 255, 0) + 103 -> Just (135, 255, 95) + 104 -> Just (135, 255, 135) + 105 -> Just (135, 255, 175) + 106 -> Just (135, 255, 215) + 107 -> Just (135, 255, 255) + 108 -> Just (175, 0, 0) + 109 -> Just (175, 0, 95) + 110 -> Just (175, 0, 135) + 111 -> Just (175, 0, 175) + 112 -> Just (175, 0, 215) + 113 -> Just (175, 0, 255) + 114 -> Just (175, 95, 0) + 115 -> Just (175, 95, 95) + 116 -> Just (175, 95, 135) + 117 -> Just (175, 95, 175) + 118 -> Just (175, 95, 215) + 119 -> Just (175, 95, 255) + 120 -> Just (175, 135, 0) + 121 -> Just (175, 135, 95) + 122 -> Just (175, 135, 135) + 123 -> Just (175, 135, 175) + 124 -> Just (175, 135, 215) + 125 -> Just (175, 135, 255) + 126 -> Just (175, 175, 0) + 127 -> Just (175, 175, 95) + 128 -> Just (175, 175, 135) + 129 -> Just (175, 175, 175) + 130 -> Just (175, 175, 215) + 131 -> Just (175, 175, 255) + 132 -> Just (175, 215, 0) + 133 -> Just (175, 215, 95) + 134 -> Just (175, 215, 135) + 135 -> Just (175, 215, 175) + 136 -> Just (175, 215, 215) + 137 -> Just (175, 215, 255) + 138 -> Just (175, 255, 0) + 139 -> Just (175, 255, 95) + 140 -> Just (175, 255, 135) + 141 -> Just (175, 255, 175) + 142 -> Just (175, 255, 215) + 143 -> Just (175, 255, 255) + 144 -> Just (215, 0, 0) + 145 -> Just (215, 0, 95) + 146 -> Just (215, 0, 135) + 147 -> Just (215, 0, 175) + 148 -> Just (215, 0, 215) + 149 -> Just (215, 0, 255) + 150 -> Just (215, 95, 0) + 151 -> Just (215, 95, 95) + 152 -> Just (215, 95, 135) + 153 -> Just (215, 95, 175) + 154 -> Just (215, 95, 215) + 155 -> Just (215, 95, 255) + 156 -> Just (215, 135, 0) + 157 -> Just (215, 135, 95) + 158 -> Just (215, 135, 135) + 159 -> Just (215, 135, 175) + 160 -> Just (215, 135, 215) + 161 -> Just (215, 135, 255) + 162 -> Just (215, 175, 0) + 163 -> Just (215, 175, 95) + 164 -> Just (215, 175, 135) + 165 -> Just (215, 175, 175) + 166 -> Just (215, 175, 215) + 167 -> Just (215, 175, 255) + 168 -> Just (215, 215, 0) + 169 -> Just (215, 215, 95) + 170 -> Just (215, 215, 135) + 171 -> Just (215, 215, 175) + 172 -> Just (215, 215, 215) + 173 -> Just (215, 215, 255) + 174 -> Just (215, 255, 0) + 175 -> Just (215, 255, 95) + 176 -> Just (215, 255, 135) + 177 -> Just (215, 255, 175) + 178 -> Just (215, 255, 215) + 179 -> Just (215, 255, 255) + 180 -> Just (255, 0, 0) + 181 -> Just (255, 0, 95) + 182 -> Just (255, 0, 135) + 183 -> Just (255, 0, 175) + 184 -> Just (255, 0, 215) + 185 -> Just (255, 0, 255) + 186 -> Just (255, 95, 0) + 187 -> Just (255, 95, 95) + 188 -> Just (255, 95, 135) + 189 -> Just (255, 95, 175) + 190 -> Just (255, 95, 215) + 191 -> Just (255, 95, 255) + 192 -> Just (255, 135, 0) + 193 -> Just (255, 135, 95) + 194 -> Just (255, 135, 135) + 195 -> Just (255, 135, 175) + 196 -> Just (255, 135, 215) + 197 -> Just (255, 135, 255) + 198 -> Just (255, 175, 0) + 199 -> Just (255, 175, 95) + 200 -> Just (255, 175, 135) + 201 -> Just (255, 175, 175) + 202 -> Just (255, 175, 215) + 203 -> Just (255, 175, 255) + 204 -> Just (255, 215, 0) + 205 -> Just (255, 215, 95) + 206 -> Just (255, 215, 135) + 207 -> Just (255, 215, 175) + 208 -> Just (255, 215, 215) + 209 -> Just (255, 215, 255) + 210 -> Just (255, 255, 0) + 211 -> Just (255, 255, 95) + 212 -> Just (255, 255, 135) + 213 -> Just (255, 255, 175) + 214 -> Just (255, 255, 215) + 215 -> Just (255, 255, 255) + 216 -> Just (8, 8, 8) + 217 -> Just (18, 18, 18) + 218 -> Just (28, 28, 28) + 219 -> Just (38, 38, 38) + 220 -> Just (48, 48, 48) + 221 -> Just (58, 58, 58) + 222 -> Just (68, 68, 68) + 223 -> Just (78, 78, 78) + 224 -> Just (88, 88, 88) + 225 -> Just (98, 98, 98) + 226 -> Just (108, 108, 108) + 227 -> Just (118, 118, 118) + 228 -> Just (128, 128, 128) + 229 -> Just (138, 138, 138) + 230 -> Just (148, 148, 148) + 231 -> Just (158, 158, 158) + 232 -> Just (168, 168, 168) + 233 -> Just (178, 178, 178) + 234 -> Just (188, 188, 188) + 235 -> Just (198, 198, 198) + 236 -> Just (208, 208, 208) + 237 -> Just (218, 218, 218) + 238 -> Just (228, 228, 228) + 239 -> Just (238, 238, 238) + _ -> Nothing diff --git a/src/Graphics/Vty/Config.hs b/src/Graphics/Vty/Config.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Config.hs @@ -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 \"|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 diff --git a/src/Graphics/Vty/Debug.hs b/src/Graphics/Vty/Debug.hs --- a/src/Graphics/Vty/Debug.hs +++ b/src/Graphics/Vty/Debug.hs @@ -1,43 +1,44 @@ -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE ScopedTypeVariables #-} -module Graphics.Vty.Debug ( module Graphics.Vty.Debug - , module Graphics.Vty.Debug.Image - ) +module Graphics.Vty.Debug + ( MockWindow(..) + , SpanConstructLog + , regionForWindow + , allSpansHaveWidth + , spanOpsAffectedColumns + , spanOpsAffectedRows + , rowOpsAffectedColumns + , isSetAttr + ) where import Graphics.Vty.Attributes -import Graphics.Vty.Debug.Image +import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Span -import Graphics.Vty.DisplayRegion -import qualified Data.Vector as Vector -import Data.Word +import qualified Data.Vector as Vector -row_ops_effected_columns :: DisplayOps -> [Word] -row_ops_effected_columns spans - = Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans +rowOpsAffectedColumns :: DisplayOps -> [Int] +rowOpsAffectedColumns ops + = Vector.toList $ Vector.map spanOpsAffectedColumns ops -all_spans_have_width :: DisplayOps -> Word -> Bool -all_spans_have_width spans expected - = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans +allSpansHaveWidth :: DisplayOps -> Int -> Bool +allSpansHaveWidth ops expected + = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops -span_ops_effected_rows :: DisplayOps -> Word -span_ops_effected_rows (DisplayOps _ the_row_ops) - = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList the_row_ops)) - +spanOpsAffectedRows :: DisplayOps -> Int +spanOpsAffectedRows ops + = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops)) + type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr -is_set_attr :: Attr -> SpanConstructEvent -> Bool -is_set_attr expected_attr (SpanSetAttr in_attr) - | in_attr == expected_attr = True -is_set_attr _attr _event = False +isSetAttr :: Attr -> SpanConstructEvent -> Bool +isSetAttr expectedAttr (SpanSetAttr inAttr) + | inAttr == expectedAttr = True +isSetAttr _attr _event = False -data DebugWindow = DebugWindow Word Word +data MockWindow = MockWindow Int Int deriving (Show, Eq) -region_for_window :: DebugWindow -> DisplayRegion -region_for_window (DebugWindow w h) = DisplayRegion w h - -type TestWindow = DebugWindow - +regionForWindow :: MockWindow -> DisplayRegion +regionForWindow (MockWindow w h) = (w,h) diff --git a/src/Graphics/Vty/Debug/Image.hs b/src/Graphics/Vty/Debug/Image.hs deleted file mode 100644 --- a/src/Graphics/Vty/Debug/Image.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Graphics.Vty.Debug.Image where - -import Graphics.Vty.Image - -type ImageConstructLog = [ImageConstructEvent] -data ImageConstructEvent = ImageConstructEvent - deriving ( Show, Eq ) - -forward_image_ops :: [Image -> Image] -forward_image_ops = map forward_transform debug_image_ops - -forward_transform, reverse_transform :: ImageOp -> (Image -> Image) - -forward_transform (ImageOp f _) = f -reverse_transform (ImageOp _ r) = r - -data ImageOp = ImageOp ImageEndo ImageEndo -type ImageEndo = Image -> Image - -debug_image_ops :: [ImageOp] -debug_image_ops = - [ id_image_op - -- , render_single_column_char_op - -- , render_double_column_char_op - ] - -id_image_op :: ImageOp -id_image_op = ImageOp id id - --- render_char_op :: ImageOp --- render_char_op = ImageOp id id diff --git a/src/Graphics/Vty/DisplayAttributes.hs b/src/Graphics/Vty/DisplayAttributes.hs --- a/src/Graphics/Vty/DisplayAttributes.hs +++ b/src/Graphics/Vty/DisplayAttributes.hs @@ -1,78 +1,111 @@ -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + module Graphics.Vty.DisplayAttributes - where + ( DisplayAttrDiff(..) + , StyleStateChange(..) + , DisplayColorDiff(..) + , URLDiff(..) + , fixDisplayAttr + , displayAttrDiffs + ) +where import Graphics.Vty.Attributes -import Data.Bits ( (.&.) ) -import Data.Monoid ( Monoid(..), mconcat ) +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) --- | Given the previously applied display attributes as a FixedAttr and the current display --- attributes as an Attr produces a FixedAttr that represents the current display attributes. This --- is done by using the previously applied display attributes to remove the "KeepCurrent" +-- | Given the previously applied display attributes as a FixedAttr and +-- the current display attributes as an Attr produces a FixedAttr that +-- represents the current display attributes. This is done by using the +-- previously applied display attributes to remove the "KeepCurrent" -- abstraction. -fix_display_attr :: FixedAttr -> Attr -> FixedAttr -fix_display_attr fattr attr - = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) ) - ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) ) - ( fix_color (fixed_back_color fattr) (attr_back_color attr) ) +fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr +fixDisplayAttr fattr attr + = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr)) + (fixColor (fixedForeColor fattr) (attrForeColor attr)) + (fixColor (fixedBackColor fattr) (attrBackColor attr)) + (fixURL (fixedURL fattr) (attrURL attr)) where - fix_style _s Default = default_style_mask - fix_style s KeepCurrent = s - fix_style _s (SetTo new_style) = new_style - fix_color _c Default = Nothing - fix_color c KeepCurrent = c - fix_color _c (SetTo c) = Just c + fixStyle _s Default = defaultStyleMask + fixStyle s KeepCurrent = s + fixStyle _s (SetTo newStyle) = newStyle + fixColor _c Default = Nothing + fixColor c KeepCurrent = c + fixColor _c (SetTo c) = Just c + fixURL c KeepCurrent = c + fixURL _c (SetTo n) = Just n + fixURL _c Default = Nothing --- | difference between two display attributes. Used in the calculation of the operations required --- to go from one display attribute to the next. +-- | difference between two display attributes. Used in the calculation +-- of the operations required to go from one display attribute to the +-- next. -- --- Previously, vty would reset display attributes to default then apply the new display attributes. --- This turned out to be very expensive: A *lot* more data would be sent to the terminal than --- required. +-- Previously, vty would reset display attributes to default then apply +-- the new display attributes. This turned out to be very expensive: A +-- *lot* more data would be sent to the terminal than required. data DisplayAttrDiff = DisplayAttrDiff - { style_diffs :: [ StyleStateChange ] - , fore_color_diff :: DisplayColorDiff - , back_color_diff :: DisplayColorDiff + { styleDiffs :: [StyleStateChange] + , foreColorDiff :: DisplayColorDiff + , backColorDiff :: DisplayColorDiff + , urlDiff :: URLDiff } - deriving ( Show ) + deriving (Show) +instance Semigroup DisplayAttrDiff where + d0 <> d1 = + let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1) + fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1) + bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1) + ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1) + in DisplayAttrDiff ds fcd bcd ud + instance Monoid DisplayAttrDiff where - mempty = DisplayAttrDiff [] NoColorChange NoColorChange - mappend d_0 d_1 = - let ds = simplify_style_diffs ( style_diffs d_0 ) ( style_diffs d_1 ) - fcd = simplify_color_diffs ( fore_color_diff d_0 ) ( fore_color_diff d_1 ) - bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 ) - in DisplayAttrDiff ds fcd bcd + mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif -- | Used in the computation of a final style attribute change. --- --- TODO(corey): not really a simplify but a monoid instance. -simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ] -simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1 +simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange] +simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1 --- | Consider two display color attributes diffs. What display color attribute diff are these --- equivalent to? --- --- TODO(corey): not really a simplify but a monoid instance. -simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff -simplify_color_diffs _cd ColorToDefault = ColorToDefault -simplify_color_diffs cd NoColorChange = cd -simplify_color_diffs _cd ( SetColor !c ) = SetColor c +-- | Consider two display color attributes diffs. What display color +-- attribute diff are these equivalent to? +simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff +simplifyColorDiffs _cd ColorToDefault = ColorToDefault +simplifyColorDiffs cd NoColorChange = cd +simplifyColorDiffs _cd (SetColor !c) = SetColor c +-- | Consider two URL changes, which are mostly going to be the latter +-- unless the latter specifies no change. +simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff +simplifyUrlDiffs ud NoLinkChange = ud +simplifyUrlDiffs _ ud = ud + -- | Difference between two display color attribute changes. -data DisplayColorDiff +data DisplayColorDiff = ColorToDefault | NoColorChange | SetColor !Color - deriving ( Show, Eq ) + deriving (Show, Eq) --- | Style attribute changes are transformed into a sequence of apply/removes of the individual --- attributes. -data StyleStateChange +-- | Style attribute changes are transformed into a sequence of +-- apply/removes of the individual attributes. +data StyleStateChange = ApplyStandout | RemoveStandout + | ApplyItalic + | RemoveItalic + | ApplyStrikethrough + | RemoveStrikethrough | ApplyUnderline | RemoveUnderline | ApplyReverseVideo @@ -83,44 +116,58 @@ | RemoveDim | ApplyBold | RemoveBold - deriving ( Show, Eq ) + deriving (Show, Eq) --- | Determines the diff between two display&color attributes. This diff determines the operations --- that actually get output to the terminal. -display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff -display_attr_diffs attr attr' = DisplayAttrDiff - { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' ) - , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' ) - , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' ) +-- Setting and unsetting hyperlinks +data URLDiff + = LinkTo !ByteString + | NoLinkChange + | EndLink + deriving (Show, Eq) + +-- | Determines the diff between two display&color attributes. This diff +-- determines the operations that actually get output to the terminal. +displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff +displayAttrDiffs attr attr' = DisplayAttrDiff + { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr') + , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr') + , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr') + , urlDiff = diffURL (fixedURL attr) (fixedURL attr') } -diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff -diff_color Nothing (Just c') = SetColor c' -diff_color (Just c) (Just c') +diffURL :: Maybe Text -> Maybe Text -> URLDiff +diffURL Nothing Nothing = NoLinkChange +diffURL (Just _) Nothing = EndLink +diffURL _ (Just url) = LinkTo (encodeUtf8 url) + +diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff +diffColor Nothing (Just c') = SetColor c' +diffColor (Just c) (Just c') | c == c' = NoColorChange | otherwise = SetColor c' -diff_color Nothing Nothing = NoColorChange -diff_color (Just _) Nothing = ColorToDefault +diffColor Nothing Nothing = NoColorChange +diffColor (Just _) Nothing = ColorToDefault -diff_styles :: Style -> Style -> [StyleStateChange] -diff_styles prev cur - = mconcat - [ style_diff standout ApplyStandout RemoveStandout - , style_diff underline ApplyUnderline RemoveUnderline - , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo - , style_diff blink ApplyBlink RemoveBlink - , style_diff dim ApplyDim RemoveDim - , style_diff bold ApplyBold RemoveBold +diffStyles :: Style -> Style -> [StyleStateChange] +diffStyles prev cur + = mconcat + [ styleDiff standout ApplyStandout RemoveStandout + , styleDiff underline ApplyUnderline RemoveUnderline + , styleDiff italic ApplyItalic RemoveItalic + , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough + , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo + , styleDiff blink ApplyBlink RemoveBlink + , styleDiff dim ApplyDim RemoveDim + , styleDiff bold ApplyBold RemoveBold ] - where - style_diff s sm rm - = case ( 0 == prev .&. s, 0 == cur .&. s ) of + where + styleDiff s sm rm + = case (0 == prev .&. s, 0 == cur .&. s) of -- not set in either - ( True, True ) -> [] + (True, True) -> [] -- set in both - ( False, False ) -> [] + (False, False) -> [] -- now set - ( True, False) -> [ sm ] + (True, False) -> [sm] -- now unset - ( False, True) -> [ rm ] - + (False, True) -> [rm] diff --git a/src/Graphics/Vty/DisplayRegion.hs b/src/Graphics/Vty/DisplayRegion.hs deleted file mode 100644 --- a/src/Graphics/Vty/DisplayRegion.hs +++ /dev/null @@ -1,12 +0,0 @@ --- Copyright 2009 Corey O'Connor -module Graphics.Vty.DisplayRegion - where - -import Data.Word - --- | Region of the terminal that vty will output to. Units are columns not characters. -data DisplayRegion = DisplayRegion - { region_width :: !Word - , region_height :: !Word - } deriving ( Show, Eq ) - diff --git a/src/Graphics/Vty/Error.hs b/src/Graphics/Vty/Error.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Error.hs @@ -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. diff --git a/src/Graphics/Vty/Image.hs b/src/Graphics/Vty/Image.hs --- a/src/Graphics/Vty/Image.hs +++ b/src/Graphics/Vty/Image.hs @@ -1,378 +1,376 @@ -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -module Graphics.Vty.Image ( DisplayString - , Image(..) - , image_width - , image_height - , (<|>) - , (<->) - , horiz_cat - , vert_cat - , background_fill - , char - , string - , iso_10646_string - , utf8_string - , utf8_bytestring - , char_fill - , empty_image - , translate - , safe_wcwidth - , safe_wcswidth - , wcwidth - , wcswidth - , crop - , pad - -- | The possible display attributes used in constructing an `Image`. - , module Graphics.Vty.Attributes - ) - where +-- | A Vty program makes 'Picture's from 'Image's. This module provides +-- the core constructors for creating, combining, and modifying +-- 'Image's. +module Graphics.Vty.Image + ( + -- * Images + Image + , imageWidth + , imageHeight + -- * Image constructors + , emptyImage + , char + , string + , iso10646String + , utf8String + , text + , text' + , backgroundFill + , utf8Bytestring + , utf8Bytestring' + , charFill + -- * Combinators + , horizJoin + , (<|>) + , vertJoin + , (<->) + , horizCat + , vertCat + -- * Image modifications + , crop + , cropRight + , cropLeft + , cropBottom + , cropTop + , pad + , resize + , resizeWidth + , resizeHeight + , translate + , translateX + , translateY + -- * Character width functions + , safeWcwidth + , safeWcswidth + , safeWctwidth + , safeWctlwidth + , wcwidth + , wcswidth + , wctwidth + , wctlwidth + -- * Display Regions + , DisplayRegion + , regionWidth + , regionHeight + ) +where import Graphics.Vty.Attributes - -import Codec.Binary.UTF8.Width - -import Codec.Binary.UTF8.String ( decode ) +import Graphics.Vty.Image.Internal +import Graphics.Text.Width -import qualified Data.ByteString as BS -import Data.Monoid -import qualified Data.Sequence as Seq -import qualified Data.String.UTF8 as UTF8 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import Data.Word -infixr 5 <|> -infixr 4 <-> - --- | We pair each character with it's display length. This way we only compute the length once per --- character. --- * Though currently the width of some strings is still compute multiple times. -type DisplayString = Seq.Seq (Char, Word) - --- | An image in VTY defines: --- --- * properties required to display the image. These are properties that effect the output image --- but are independent of position --- --- * A set of position-dependent text and attribute regions. The possible regions are: --- --- * a point. ( char ) --- --- * a horizontal line of characters with a single attribute. (string, utf8_string, --- utf8_bytestring ) --- --- * a fill of a single character. (char_fill) --- --- * a fill of the picture's background. (background_fill) --- --- todo: increase the number of encoded bytestring formats supported. -data Image = - -- A horizontal text span is always >= 1 column and has a row height of 1. - HorizText - { attr :: !Attr - -- All character data is stored as Char sequences with the ISO-10646 encoding. - , text :: DisplayString - , output_width :: !Word -- >= 0 - , char_width :: !Word -- >= 1 - } - -- A horizontal join can be constructed between any two images. However a HorizJoin instance is - -- required to be between two images of equal height. The horiz_join constructor adds background - -- filles to the provided images that assure this is true for the HorizJoin value produced. - | HorizJoin - { part_left :: Image - , part_right :: Image - , output_width :: !Word -- >= 1 - , output_height :: !Word -- >= 1 - } - -- A veritical join can be constructed between any two images. However a VertJoin instance is - -- required to be between two images of equal width. The vert_join constructor adds background - -- fills to the provides images that assure this is true for the VertJoin value produced. - | VertJoin - { part_top :: Image - , part_bottom :: Image - , output_width :: !Word -- >= 1 - , output_height :: !Word -- >= 1 - } - -- A background fill will be filled with the background pattern. The background pattern is - -- defined as a property of the Picture this Image is used to form. - | BGFill - { output_width :: !Word -- >= 1 - , output_height :: !Word -- >= 1 - } - -- The combining operators identity constant. - -- EmptyImage <|> a = a - -- EmptyImage <-> a = a - -- - -- Any image of zero size equals the empty image. - | EmptyImage - | Translation (Int, Int) Image - -- Crop an image to a size - | ImageCrop (Word, Word) Image - -- Pad an image up to a size - | ImagePad (Word, Word) Image - deriving Eq - -instance Show Image where - show ( HorizText { output_width = ow, text = txt } ) - = "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")" - show ( BGFill { output_width = c, output_height = r } ) - = "BGFill (" ++ show c ++ "," ++ show r ++ ")" - show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) - = "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )" - show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) - = "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )" - show ( Translation offset i ) - = "Translation " ++ show offset ++ " ( " ++ show i ++ " )" - show ( ImageCrop size i ) - = "ImageCrop " ++ show size ++ " ( " ++ show i ++ " )" - show ( ImagePad size i ) - = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )" - show ( EmptyImage ) = "EmptyImage" +-- | A region of the display (first width, then height) +type DisplayRegion = (Int,Int) --- | Currently append in the Monoid instance is equivalent to <->. -instance Monoid Image where - mempty = empty_image - mappend = (<->) - --- A horizontal text image of 0 characters in width simplifies to the EmptyImage -horiz_text :: Attr -> DisplayString -> Word -> Image -horiz_text a txt ow - | ow == 0 = EmptyImage - | otherwise = HorizText a txt ow (toEnum $ Seq.length txt) +regionWidth :: DisplayRegion -> Int +regionWidth = fst -horiz_join :: Image -> Image -> Word -> Word -> Image -horiz_join i_0 i_1 w h - -- A horiz join of two 0 width images simplifies to the EmptyImage - | w == 0 = EmptyImage - -- A horizontal join where either part is 0 columns in width simplifies to the other part. - -- This covers the case where one part is the EmptyImage. - | image_width i_0 == 0 = i_1 - | image_width i_1 == 0 = i_0 - -- If the images are of the same height then no BG padding is required - | image_height i_0 == image_height i_1 = HorizJoin i_0 i_1 w h - -- otherwise one of the imagess needs to be padded to the right size. - | image_height i_0 < image_height i_1 -- Pad i_0 - = let pad_amount = image_height i_1 - image_height i_0 - in horiz_join ( vert_join i_0 - ( BGFill ( image_width i_0 ) pad_amount ) - ( image_width i_0 ) - ( image_height i_1 ) - ) - i_1 - w h - | image_height i_0 > image_height i_1 -- Pad i_1 - = let pad_amount = image_height i_0 - image_height i_1 - in horiz_join i_0 - ( vert_join i_1 - ( BGFill ( image_width i_1 ) pad_amount ) - ( image_width i_1 ) - ( image_height i_0 ) - ) - w h -horiz_join _ _ _ _ = error "horiz_join applied to undefined values." +regionHeight :: DisplayRegion -> Int +regionHeight = snd -vert_join :: Image -> Image -> Word -> Word -> Image -vert_join i_0 i_1 w h - -- A vertical join of two 0 height images simplifies to the EmptyImage - | h == 0 = EmptyImage - -- A vertical join where either part is 0 rows in height simplifies to the other part. - -- This covers the case where one part is the EmptyImage - | image_height i_0 == 0 = i_1 - | image_height i_1 == 0 = i_0 - -- If the images are of the same height then no background padding is required - | image_width i_0 == image_width i_1 = VertJoin i_0 i_1 w h - -- Otherwise one of the images needs to be padded to the size of the other image. - | image_width i_0 < image_width i_1 - = let pad_amount = image_width i_1 - image_width i_0 - in vert_join ( horiz_join i_0 - ( BGFill pad_amount ( image_height i_0 ) ) - ( image_width i_1 ) - ( image_height i_0 ) - ) - i_1 - w h - | image_width i_0 > image_width i_1 - = let pad_amount = image_width i_0 - image_width i_1 - in vert_join i_0 - ( horiz_join i_1 - ( BGFill pad_amount ( image_height i_1 ) ) - ( image_width i_0 ) - ( image_height i_1 ) - ) - w h -vert_join _ _ _ _ = error "vert_join applied to undefined values." +infixr 5 <|> +infixr 4 <-> --- | An area of the picture's bacground (See Background) of w columns and h rows. -background_fill :: Word -> Word -> Image -background_fill w h +-- | An area of the picture's background (See 'Background'). +backgroundFill :: Int + -- ^ Fill width in columns + -> Int + -- ^ Fill height in rows + -> Image +backgroundFill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h --- | The width of an Image. This is the number display columns the image will occupy. -image_width :: Image -> Word -image_width HorizText { output_width = w } = w -image_width HorizJoin { output_width = w } = w -image_width VertJoin { output_width = w } = w -image_width BGFill { output_width = w } = w -image_width EmptyImage = 0 -image_width ( Translation v i ) = toEnum $ max 0 $ (fst v +) $ fromEnum $ image_width i -image_width ( ImageCrop v i ) = min (image_width i) $ fst v -image_width ( ImagePad v i ) = max (image_width i) $ fst v - --- | The height of an Image. This is the number of display rows the image will occupy. -image_height :: Image -> Word -image_height HorizText {} = 1 -image_height HorizJoin { output_height = r } = r -image_height VertJoin { output_height = r } = r -image_height BGFill { output_height = r } = r -image_height EmptyImage = 0 -image_height ( Translation v i ) = toEnum $ max 0 $ (snd v +) $ fromEnum $ image_height i -image_height ( ImageCrop v i ) = min (image_height i) $ snd v -image_height ( ImagePad v i ) = max (image_height i) $ snd v - --- | Combines two images side by side. +-- | Combines two images horizontally. This is an alias for 'horizJoin'. -- --- The result image will have a width equal to the sum of the two images width. And the height will --- equal the largest height of the two images. The area not defined in one image due to a height --- missmatch will be filled with the background pattern. +-- infixr 5 (<|>) :: Image -> Image -> Image - --- Two horizontal text spans with the same attributes can be merged. -h0@(HorizText attr_0 text_0 ow_0 _) <|> h1@(HorizText attr_1 text_1 ow_1 _) - | attr_0 == attr_1 = horiz_text attr_0 (text_0 Seq.>< text_1) (ow_0 + ow_1) - | otherwise = horiz_join h0 h1 (ow_0 + ow_1) 1 - --- Anything placed to the right of a join wil be joined to the right sub image. --- The total columns for the join is the sum of the two arguments columns -h0@( HorizJoin {} ) <|> h1 - = horiz_join ( part_left h0 ) - ( part_right h0 <|> h1 ) - ( image_width h0 + image_width h1 ) - ( max (image_height h0) (image_height h1) ) +(<|>) = horizJoin --- Anything but a join placed to the left of a join wil be joined to the left sub image. --- The total columns for the join is the sum of the two arguments columns -h0 <|> h1@( HorizJoin {} ) - = horiz_join ( h0 <|> part_left h1 ) - ( part_right h1 ) - ( image_width h0 + image_width h1 ) - ( max (image_height h0) (image_height h1) ) +-- | Combines two images vertically. This is an alias for 'vertJoin'. +-- +-- infixr 4 +(<->) :: Image -> Image -> Image +(<->) = vertJoin -h0 <|> h1 - = horiz_join h0 - h1 - ( image_width h0 + image_width h1 ) - ( max (image_height h0) (image_height h1) ) +-- | Compose any number of images together horizontally, with the first +-- in the list being leftmost. +horizCat :: [Image] -> Image +horizCat = foldr horizJoin EmptyImage --- | Combines two images vertically. --- The result image will have a height equal to the sum of the heights of both images. --- The width will equal the largest width of the two images. --- The area not defined in one image due to a width missmatch will be filled with the background --- pattern. -(<->) :: Image -> Image -> Image -im_t <-> im_b - = vert_join im_t - im_b - ( max (image_width im_t) (image_width im_b) ) - ( image_height im_t + image_height im_b ) +-- | Compose any number of images vertically, with the first in the list +-- being topmost. +vertCat :: [Image] -> Image +vertCat = foldr vertJoin EmptyImage --- | Compose any number of images horizontally. -horiz_cat :: [Image] -> Image -horiz_cat = foldr (<|>) EmptyImage +-- | Make an 'Image' from a lazy text value. The text value should be +-- sanitized of escape sequences (ASCII 27) and carriage returns; +-- otherwise layout and attribute problems may result. +text :: Attr -> TL.Text -> Image +text a txt = let displayWidth = safeWctlwidth txt + in HorizText a txt displayWidth (fromIntegral $! TL.length txt) --- | Compose any number of images vertically. -vert_cat :: [Image] -> Image -vert_cat = foldr (<->) EmptyImage +-- | Make an 'Image' from a text value. The text value should be +-- sanitized of escape sequences (ASCII 27) and carriage returns; +-- otherwise layout and attribute problems may result. +text' :: Attr -> T.Text -> Image +text' a txt = let displayWidth = safeWctwidth txt + in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) --- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in --- the ISO-10646 encoding. +-- | Make an image from a single character. This is a standard Haskell +-- 31-bit character assumed to be in the ISO-10646 encoding. char :: Attr -> Char -> Image -char !a !c = - let display_width = safe_wcwidth c - in HorizText a (Seq.singleton (c, display_width)) display_width 1 +char a c = + let displayWidth = safeWcwidth c + in HorizText a (TL.singleton c) displayWidth 1 --- | A string of characters layed out on a single row with the same display attribute. The string is --- assumed to be a sequence of ISO-10646 characters. +-- | Make an image from a string of characters laid out on a single +-- row with the same display attribute. The string is assumed to be a +-- sequence of ISO-10646 characters. The input string should be +-- sanitized of escape sequences (ASCII 27) and carriage returns; +-- otherwise layout and attribute problems may result. -- --- Note: depending on how the Haskell compiler represents string literals a string literal in a --- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string. --- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry --- about the encoding format when outputting string literals. Just provide the string literal --- directly to iso_10646_string or string. --- -iso_10646_string :: Attr -> String -> Image -iso_10646_string !a !str = - let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str - in horiz_text a display_text (safe_wcswidth str) +-- Note: depending on how the Haskell compiler represents string +-- literals, a string literal in a UTF-8 encoded source file, for +-- example, may be represented as a ISO-10646 string. That is, I think, +-- the case with GHC 6.10. This means, for the most part, you don't need +-- to worry about the encoding format when outputting string literals. +-- Just provide the string literal directly to iso10646String or string. +iso10646String :: Attr -> String -> Image +iso10646String a str = + let displayWidth = safeWcswidth str + in HorizText a (TL.pack str) displayWidth (length str) --- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is --- represented internally as a list of ISO 10646 31 bit characters. +-- | Make an 'Image' from a 'String'. -- --- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while --- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime --- representation. +-- This is an alias for iso10646String since the usual case is that a +-- literal string like "foo" is represented internally as a list of ISO +-- 10646 31 bit characters. +-- +-- Note: Keep in mind that GHC will compile source encoded as UTF-8 +-- but the literal strings, while UTF-8 encoded in the source, will be +-- transcoded to a ISO 10646 31 bit characters runtime representation. string :: Attr -> String -> Image -string = iso_10646_string +string = iso10646String --- | A string of characters layed out on a single row. The string is assumed to be a sequence of --- UTF-8 characters. -utf8_string :: Attr -> [Word8] -> Image -utf8_string !a !str = string a ( decode str ) +-- | Make an 'Image' from a string of characters layed out on a single +-- row. The input is assumed to be the bytes for UTF-8 encoded text. +utf8String :: Attr -> [Word8] -> Image +utf8String a bytes = utf8Bytestring a (BL.pack bytes) --- XXX: Characters with unknown widths occupy 1 column? --- --- Not sure if this is actually correct. I presume there is a replacement character that is output --- by the terminal instead of the character and this replacement character is 1 column wide. If this --- is not true for all terminals then a per-terminal replacement character width needs to be --- implemented. +-- | Make an 'Image' from a UTF-8 encoded lazy bytestring. +utf8Bytestring :: Attr -> BL.ByteString -> Image +utf8Bytestring a bs = text a (TL.decodeUtf8 bs) --- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width -safe_wcwidth :: Char -> Word -safe_wcwidth c = case wcwidth c of - i | i < 0 -> 1 - | otherwise -> toEnum i +-- | Make an 'Image' from a UTF-8 encoded strict bytestring. +utf8Bytestring' :: Attr -> B.ByteString -> Image +utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) --- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width -safe_wcswidth :: String -> Word -safe_wcswidth str = case wcswidth str of - i | i < 0 -> 1 - | otherwise -> toEnum i +-- | Make an image filling a region with the specified character. +-- +-- If either the width or height are less than or equal to 0, then +-- the result is the empty image. +charFill :: Integral d + => Attr + -- ^ The attribute to use. + -> Char + -- ^ The character to use in filling the region. + -> d + -- ^ The region width. + -> d + -- ^ The region height. + -> Image +charFill a c w h + | w <= 0 || h <= 0 = EmptyImage + | otherwise = vertCat + $ replicate (fromIntegral h) + $ HorizText a txt displayWidth charWidth + where + txt = TL.replicate charWidth (TL.singleton c) + displayWidth = safeWcwidth c * charWidth --- | Renders a UTF-8 encoded bytestring. -utf8_bytestring :: Attr -> BS.ByteString -> Image -utf8_bytestring !a !bs = string a (UTF8.toString $ UTF8.fromRep bs) + charWidth :: Num a => a + charWidth = fromIntegral w --- | creates a fill of the specified character. The dimensions are in number of characters wide and --- number of rows high. +-- | The empty image. Useful for fold combinators. These occupy no space +-- and do not affect display attributes. +emptyImage :: Image +emptyImage = EmptyImage + +-- | Pad the given image. This adds background character fills to the +-- left, top, right, bottom. +pad :: Int + -- ^ How much padding to add to the left side of the image. + -> Int + -- ^ How much padding to add to the top of the image. + -> Int + -- ^ How much padding to add to the right side of the image. + -> Int + -- ^ How much padding to add to the bottom of the image. + -> Image + -- ^ The image to pad. + -> Image +pad 0 0 0 0 i = i +pad inL inT inR inB inImage + | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount" + | otherwise = go inL inT inR inB inImage + where + go 0 0 0 0 i = i + go 0 0 0 b i = VertJoin i (BGFill w b) w h + where w = imageWidth i + h = imageHeight i + b + go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h + where w = imageWidth i + r + h = imageHeight i + go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h + where w = imageWidth i + h = imageHeight i + t + go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h + where w = imageWidth i + l + h = imageHeight i + +-- | Translates an image by padding or cropping the left and top. -- --- Unlike the Background fill character this character can have double column display width. -char_fill :: Enum d => Attr -> Char -> d -> d -> Image -char_fill !a !c w h = - vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) $ char a c +-- If translation offsets are negative then the image is cropped. +translate :: Int + -- ^ The horizontal translation offset (can be negative) + -> Int + -- ^ The vertical translation offset (can be negative) + -> Image + -- ^ The image to translate. + -> Image +translate x y i = translateX x (translateY y i) --- | The empty image. Useful for fold combinators. These occupy no space nor define any display --- attributes. -empty_image :: Image -empty_image = EmptyImage +-- | Translates an image by padding or cropping its left side. +translateX :: Int -> Image -> Image +translateX x i + | x < 0 && (abs x > imageWidth i) = emptyImage + | x < 0 = cropLeft (imageWidth i + x) i + | x == 0 = i + | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h --- | Apply the given offset to the image. -translate :: (Int, Int) -> Image -> Image -translate v i = Translation v i +-- | Translates an image by padding or cropping its top. +translateY :: Int -> Image -> Image +translateY y i + | y < 0 && (abs y > imageHeight i) = emptyImage + | y < 0 = cropTop (imageHeight i + y) i + | y == 0 = i + | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) --- | Ensure an image is no larger than the provided size. If the image is larger then crop. -crop :: (Word, Word) -> Image -> Image -crop (0,_) _ = EmptyImage -crop (_,0) _ = EmptyImage -crop v (ImageCrop _size i) = ImageCrop (min (fst v) (fst _size), min (snd v) (snd _size)) i -crop v i = ImageCrop v i +-- | Ensure an image is no larger than the provided size. If the image +-- is larger then crop the right or bottom. +-- +-- This is equivalent to a vertical crop from the bottom followed by +-- horizontal crop from the right. +crop :: Int + -- ^ Cropping width + -> Int + -- ^ Cropping height + -> Image + -- ^ The image to crop + -> Image +crop 0 _ _ = EmptyImage +crop _ 0 _ = EmptyImage +crop w h i = cropBottom h (cropRight w i) --- | Ensure an image is at least the provided size. If the image is smaller then pad. -pad :: (Word, Word) -> Image -> Image -pad (0,_) _ = EmptyImage -pad (_,0) _ = EmptyImage -pad v (ImagePad _size i) = ImagePad (max (fst v) (fst _size), max (snd v) (snd _size)) i -pad v i = ImagePad v i +-- | Crop an image's height. If the image's height is less than or equal +-- to the specified height then this operation has no effect. Otherwise +-- the image is cropped from the bottom. +cropBottom :: Int -> Image -> Image +cropBottom 0 _ = EmptyImage +cropBottom h inI + | h < 0 = error "cannot crop height to less than zero" + | otherwise = go inI + where + go EmptyImage = EmptyImage + go i@(Crop {outputHeight}) + = i {outputHeight = min h outputHeight} + go i + | h >= imageHeight i = i + | otherwise = Crop i 0 0 (imageWidth i) h +-- | Crop an image's width. If the image's width is less than or equal +-- to the specified width then this operation has no effect. Otherwise +-- the image is cropped from the right. +cropRight :: Int -> Image -> Image +cropRight 0 _ = EmptyImage +cropRight w inI + | w < 0 = error "cannot crop width to less than zero" + | otherwise = go inI + where + go EmptyImage = EmptyImage + go i@(Crop {outputWidth}) + = i {outputWidth = min w outputWidth} + go i + | w >= imageWidth i = i + | otherwise = Crop i 0 0 w (imageHeight i) + +-- | Crop an image's width. If the image's width is less than or equal +-- to the specified width then this operation has no effect. Otherwise +-- the image is cropped from the left. +cropLeft :: Int -> Image -> Image +cropLeft 0 _ = EmptyImage +cropLeft w inI + | w < 0 = error "cannot crop the width to less than zero" + | otherwise = go inI + where + go EmptyImage = EmptyImage + go i@(Crop {leftSkip, outputWidth}) = + let delta = max 0 (outputWidth - w) + in i { leftSkip = leftSkip + delta + , outputWidth = outputWidth - delta } + go i + | imageWidth i <= w = i + | otherwise = Crop i (imageWidth i - w) 0 w (imageHeight i) + +-- | Crop an image's height. If the image's height is less than or equal +-- to the specified height then this operation has no effect. Otherwise +-- the image is cropped from the top. +cropTop :: Int -> Image -> Image +cropTop 0 _ = EmptyImage +cropTop h inI + | h < 0 = error "cannot crop the height to less than zero" + | otherwise = go inI + where + go EmptyImage = EmptyImage + go i@(Crop {topSkip, outputHeight}) = + let delta = max 0 (outputHeight - h) + in i { topSkip = topSkip + delta + , outputHeight = outputHeight - delta } + go i + | imageHeight i <= h = i + | otherwise = Crop i 0 (imageHeight i - h) (imageWidth i) h + +-- | Generic resize. Pads and crops are added to ensure that the +-- resulting image matches the specified dimensions. This is biased to +-- pad/crop the right and bottom. +resize :: Int -> Int -> Image -> Image +resize w h i = resizeHeight h (resizeWidth w i) + +-- | Resize the width. Pads and crops as required to assure the given +-- display width. This is biased to pad/crop on the right. +resizeWidth :: Int -> Image -> Image +resizeWidth w i = case w `compare` imageWidth i of + LT -> cropRight w i + EQ -> i + GT -> i <|> BGFill (w - imageWidth i) (imageHeight i) + +-- | Resize the height. Pads and crops as required to assure the given +-- display height. This is biased to pad/crop on the bottom. +resizeHeight :: Int -> Image -> Image +resizeHeight h i = case h `compare` imageHeight i of + LT -> cropBottom h i + EQ -> i + GT -> i <-> BGFill (imageWidth i) (h - imageHeight i) diff --git a/src/Graphics/Vty/Image/Internal.hs b/src/Graphics/Vty/Image/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Image/Internal.hs @@ -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." diff --git a/src/Graphics/Vty/Inline.hs b/src/Graphics/Vty/Inline.hs --- a/src/Graphics/Vty/Inline.hs +++ b/src/Graphics/Vty/Inline.hs @@ -1,102 +1,124 @@ --- | The inline module provides a limited interface to changing the style of terminal output. The --- intention is for this interface to be used inline with other output systems. +-- | The inline module provides a limited interface to changing the +-- style of terminal output. The intention is for this interface to be +-- used inline with other output systems. -- --- The changes specified by the InlineM monad are applied to the terminals display attributes. These --- display attributes effect the display of all following text output to the terminal file --- descriptor. +-- The changes specified by the InlineM monad are applied to the +-- terminal's display attributes. These display attributes affect the +-- display of all following text output to the terminal file descriptor. -- --- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the --- text \" Styled! \" drawn over a red background and underlined. +-- For example, in an IO monad the following code will print the text +-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red +-- background and underlined. -- -- @ --- t <- terminal_handle -- putStr \"Not styled. \" --- put_attr_change t $ do --- back_color red --- apply_style underline +-- putAttrChange_ $ do +-- backColor red +-- applyStyle underline -- putStr \" Styled! \" --- put_attr_change t $ default_all +-- putAttrChange_ $ defaultAll -- putStrLn \"Not styled.\" --- release_terminal t -- @ -- --- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate --- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been --- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than --- 'put_attr_change' +-- 'putAttrChange' emits the control codes to the terminal device +-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when +-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been +-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a +-- different 'Handle' than 'putAttrChange'. -- -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE BangPatterns #-} -module Graphics.Vty.Inline ( module Graphics.Vty.Inline - ) - where +module Graphics.Vty.Inline + ( module Graphics.Vty.Inline + ) +where -import Graphics.Vty.Attributes +import Graphics.Vty import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Terminal.Generic -import Control.Applicative +import Blaze.ByteString.Builder (writeToByteString) + import Control.Monad.State.Strict import Data.Bits ( (.&.), complement ) import Data.IORef -import Data.Monoid ( mappend ) import System.IO -type InlineM v = State Attr v +type InlineM v = State InlineState v --- | Set the background color to the provided 'Color' -back_color :: Color -> InlineM () -back_color c = modify $ flip mappend ( current_attr `with_back_color` c ) +data InlineState = + InlineState { inlineAttr :: Attr + , inlineUrlsEnabled :: Bool + } --- | Set the foreground color to the provided 'Color' -fore_color :: Color -> InlineM () -fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c ) +-- | Set the background color to the provided 'Color'. +backColor :: Color -> InlineM () +backColor c = modify $ \s -> + s { inlineAttr = inlineAttr s `withBackColor` c + } --- | Attempt to change the 'Style' of the following text. +-- | Set the foreground color to the provided 'Color'. +foreColor :: Color -> InlineM () +foreColor c = modify $ \s -> + s { inlineAttr = inlineAttr s `withForeColor` c + } + +-- | Attempt to change the 'Style' of the following text.. -- --- If the terminal does not support the style change no error is produced. The style can still be --- removed. -apply_style :: Style -> InlineM () -apply_style s = modify $ flip mappend ( current_attr `with_style` s ) +-- If the terminal does not support the style change then no error is +-- produced. The style can still be removed. +applyStyle :: Style -> InlineM () +applyStyle st = modify $ \s -> + s { inlineAttr = inlineAttr s `withStyle` st + } --- | Attempt to remove the specified 'Style' from the display of the following text. +-- | Attempt to remove the specified 'Style' from the display of the +-- following text. -- --- This will fail if apply_style for the given style has not been previously called. -remove_style :: Style -> InlineM () -remove_style s_mask = modify $ \attr -> - let style' = case attr_style attr of - Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used." - KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used." - SetTo s -> s .&. complement s_mask - in attr { attr_style = SetTo style' } +-- This will fail if 'applyStyle' for the given style has not been +-- previously called. +removeStyle :: Style -> InlineM () +removeStyle sMask = modify $ \s -> + s { inlineAttr = + let style' = case attrStyle (inlineAttr s) of + Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." + KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." + SetTo st -> st .&. complement sMask + in (inlineAttr s) { attrStyle = SetTo style' } + } --- | Reset the display attributes -default_all :: InlineM () -default_all = put def_attr +-- | Reset the display attributes. +defaultAll :: InlineM () +defaultAll = modify $ \s -> s { inlineAttr = defAttr } --- | Apply the provided display attribute changes to the terminal. +-- | Apply the provided display attribute changes to the given terminal +-- output device. -- --- This also flushes the 'stdout' handle. -put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m () -put_attr_change t c = do - bounds <- display_bounds t - d <- display_context t bounds - mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t ) +-- This does not flush the terminal. +putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () +putAttrChange out c = liftIO $ do + bounds <- displayBounds out + dc <- displayContext out bounds + mfattr <- prevFattr <$> readIORef (assumedStateRef out) fattr <- case mfattr of Nothing -> do - liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d) - return $ FixedAttr default_style_mask Nothing Nothing + liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False + return $ FixedAttr defaultStyleMask Nothing Nothing Nothing Just v -> return v - let attr = execState c current_attr - attr' = limit_attr_for_display d attr - fattr' = fix_display_attr fattr attr' - diffs = display_attr_diffs fattr fattr' - liftIO $ hFlush stdout - liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs ) - ( serialize_set_attr d fattr attr' diffs ) - liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' } - inline_hack d - liftIO $ hFlush stdout + let InlineState attr urlsEnabled = execState c (InlineState currentAttr False) + attr' = limitAttrForDisplay out attr + fattr' = fixDisplayAttr fattr attr' + diffs = displayAttrDiffs fattr fattr' + outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs + modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' } + inlineHack dc +-- | Apply the provided display attributes changes to the terminal +-- output device. +-- +-- This will flush the terminal output. +putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () +putAttrChange_ out c = liftIO $ do + hFlush stdout + putAttrChange out c + hFlush stdout diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Input.hs @@ -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. + } diff --git a/src/Graphics/Vty/Input/Events.hs b/src/Graphics/Vty/Input/Events.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Input/Events.hs @@ -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. diff --git a/src/Graphics/Vty/LLInput.hs b/src/Graphics/Vty/LLInput.hs deleted file mode 100644 --- a/src/Graphics/Vty/LLInput.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- Copyright 2009-2010 Corey O'Connor -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module Graphics.Vty.LLInput ( Key(..) - , Modifier(..) - , Button(..) - , Event(..) - , initTermInput - ) - where - -import Data.Char -import Data.Maybe ( mapMaybe - ) -import Data.List( inits ) -import Data.Word -import qualified Data.Map as M( fromList, lookup ) -import qualified Data.Set as S( fromList, member ) - -import Codec.Binary.UTF8.Generic (decode) - -import Control.Monad (when) -import Control.Concurrent -import Control.Exception - -import System.Console.Terminfo - -import System.Posix.Signals.Exts -import System.Posix.Terminal -import System.Posix.IO ( stdInput - ,fdReadBuf - ,setFdOption - ,FdOption(..) - ) - -import Foreign ( alloca, poke, peek, Ptr ) - --- |Representations of non-modifier keys. -data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns - | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KNP5 | KUp | KMenu - | KLeft | KDown | KRight | KEnter - deriving (Eq,Show,Ord) - --- |Modifier keys. Key codes are interpreted such that users are more likely to --- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will --- generally correspond to the physical Alt key. -data Modifier = MShift | MCtrl | MMeta | MAlt - deriving (Eq,Show,Ord) - --- |Mouse buttons. Not yet used. -data Button = BLeft | BMiddle | BRight - deriving (Eq,Show,Ord) - --- |Generic events. -data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier] - | EvResize Int Int - deriving (Eq,Show,Ord) - -data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char] - deriving(Show) - --- | Set up the terminal for input. Returns a function which reads key --- events, and a function for shutting down the terminal access. -initTermInput :: Int -> Terminal -> IO (IO Event, IO ()) -initTermInput escDelay terminal = do - eventChannel <- newChan - inputChannel <- newChan - hadInput <- newEmptyMVar - oattr <- getTerminalAttributes stdInput - let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts, - EnableEcho, ProcessInput, ExtendedFunctions] - setTerminalAttributes stdInput nattr Immediately - set_term_timing - let inputToEventThread :: IO () - inputToEventThread = loop [] - where loop kb = case (classify kb) of - Prefix -> do c <- readChan inputChannel - loop (kb ++ [c]) - Invalid -> do c <- readChan inputChannel - loop [c] - MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s - Valid k m -> writeChan eventChannel (EvKey k m) >> loop "" - - finishAtomicInput = writeChan inputChannel '\xFFFE' - - inputThread :: IO () - inputThread = do - _ <- alloca $ \(input_buffer :: Ptr Word8) -> do - let loop = do - setFdOption stdInput NonBlockingRead False - threadWaitRead stdInput - setFdOption stdInput NonBlockingRead True - _ <- try readAll :: IO (Either IOException ()) - when (escDelay == 0) finishAtomicInput - loop - readAll = do - poke input_buffer 0 - bytes_read <- fdReadBuf stdInput input_buffer 1 - input_char <- fmap (chr . fromIntegral) $ peek input_buffer - when (bytes_read > 0) $ do - _ <- tryPutMVar hadInput () -- signal input - writeChan inputChannel input_char - readAll - loop - return () - - -- | If there is no input for some time, this thread puts '\xFFFE' in the - -- inputChannel. - noInputThread :: IO () - noInputThread = when (escDelay > 0) loop - where loop = do - takeMVar hadInput -- wait for some input - threadDelay escDelay -- microseconds - hadNoInput <- isEmptyMVar hadInput -- no input yet? - -- TODO(corey): there is a race between here and the inputThread. - when hadNoInput $ do - finishAtomicInput - loop - - - compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass - compile lst = cl' where - lst' = concat lst - pfx = S.fromList $ concatMap (init . inits . fst) $ lst' - mlst = M.fromList lst' - cl' str = case S.member str pfx of - True -> Prefix - False -> case M.lookup str mlst of - Just (k,m) -> Valid k m - Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of - (s,(k,m)) -> MisPfx k m (drop (length s) str) - - -- ANSI specific bits - - - classify, classifyTab :: [Char] -> KClass - - -- As soon as - classify "\xFFFE" = Invalid - classify s@(c:_) | ord c >= 0xC2 = - if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence - classify other = classifyTab other - - classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of - Just (unicodeChar, _) -> Valid (KASCII unicodeChar) [] - _ -> Invalid -- something bad happened; just ignore and continue. - - classifyTab = compile (caps_classify_table : ansi_classify_table) - - caps_tabls = [("khome", (KHome, [])), - ("kend", (KEnd, [])), - ("cbt", (KBackTab, [])), - ("kcud1", (KDown, [])), - ("kcuu1", (KUp, [])), - ("kcuf1", (KRight, [])), - ("kcub1", (KLeft, [])), - - ("kLFT", (KLeft, [MShift])), - ("kRIT", (KRight, [MShift])) - ] - - caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls] - - ansi_classify_table :: [[([Char], (Key, [Modifier]))]] - ansi_classify_table = - [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5 - , k "P" KPause - , k "A" KUp - , k "B" KDown - , k "C" KRight - , k "D" KLeft - , k "H" KHome - , k "F" KEnd - , k "E" KBegin - ], - - -- Support for arrows and KHome/KEnd - [("\ESC[" ++ charCnt ++ show mc++c,(s,m)) - | charCnt <- ["1;", ""], -- we can have a count or not - (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), - ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes - (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes - ], - - let k n s = ("\ESC["++show n++"~",(s,[])) - in zipWith k [2::Int,3,5,6,1,4] - [KIns,KDel,KPageUp,KPageDown,KHome,KEnd], - - let k n s = ("\ESC["++show n++";5~",(s,[MCtrl])) - in zipWith k [2::Int,3,5,6,1,4] - [KIns,KDel,KPageUp,KPageDown,KHome,KEnd], - - -- Support for simple characters. - [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ], - - -- Support for function keys (should use terminfo) - [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ], - let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in - concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ], - [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ], - - -- Ctrl+Char - [ ([toEnum x],(KASCII y,[MCtrl])) - | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']), - y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. - ], - - -- Ctrl+Meta+Char - [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ], - - -- Special support - [ -- special support for ESC - ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])), - - -- Special support for backspace - ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])), - - -- Special support for Enter - ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] - ] - - eventThreadId <- forkIO $ inputToEventThread - inputThreadId <- forkIO $ inputThread - noInputThreadId <- forkIO $ noInputThread - let pokeIO = (Catch $ do let e = error "(getsize in input layer)" - setTerminalAttributes stdInput nattr Immediately - writeChan eventChannel (EvResize e e)) - _ <- installHandler windowChange pokeIO Nothing - _ <- installHandler continueProcess pokeIO Nothing - -- TODO(corey): killThread is a bit risky for my tastes. - let uninit = do killThread eventThreadId - killThread inputThreadId - killThread noInputThreadId - _ <- installHandler windowChange Ignore Nothing - _ <- installHandler continueProcess Ignore Nothing - setTerminalAttributes stdInput oattr Immediately - return (readChan eventChannel, uninit) - -first :: (a -> b) -> (a,c) -> (b,c) -first f (x,y) = (f x, y) - -utf8Length :: (Num t, Ord a, Num a) => a -> t -utf8Length c - | c < 0x80 = 1 - | c < 0xE0 = 2 - | c < 0xF0 = 3 - | otherwise = 4 - -foreign import ccall "vty_set_term_timing" set_term_timing :: IO () diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Output.hs @@ -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 diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Output/Mock.hs @@ -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) diff --git a/src/Graphics/Vty/Picture.hs b/src/Graphics/Vty/Picture.hs --- a/src/Graphics/Vty/Picture.hs +++ b/src/Graphics/Vty/Picture.hs @@ -1,81 +1,128 @@ --- | The Picture data structure is representative of the final terminal view. --- --- This module re-exports most of the Graphics.Vty.Image and Graphics.Vty.Attributes modules. --- --- Copyright 2009-2010 Corey O'Connor -module Graphics.Vty.Picture ( module Graphics.Vty.Picture - , Image - , image_width - , image_height - , (<|>) - , (<->) - , horiz_cat - , vert_cat - , background_fill - , char - , string - , iso_10646_string - , utf8_string - , utf8_bytestring - , char_fill - , empty_image - , translate - , crop - , pad - -- | The possible display attributes used in constructing an `Image`. - , module Graphics.Vty.Attributes - ) - where +-- A 'Picture' is a background paired with a set of 'Image' layers. The +-- 'Picture' data structure is representative of the final terminal +-- view. +module Graphics.Vty.Picture + ( Picture(..) + , Cursor(..) + , Background(..) + , emptyPicture + , addToTop + , addToBottom + , picForImage + , picForLayers + , picImage + ) +where +import Graphics.Vty.Image import Graphics.Vty.Attributes -import Graphics.Vty.Image hiding ( attr ) -import Data.Word +import Control.DeepSeq --- | The type of images to be displayed using 'update'. --- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with --- reasonable defaults for pic_cursor and pic_background. +-- | A Vty picture. +-- +-- These can be constructed directly or using `picForImage`. data Picture = Picture - { pic_cursor :: Cursor - , pic_image :: Image - , pic_background :: Background - } + { picCursor :: Cursor + -- ^ The picture's cursor. + , picLayers :: [Image] + -- ^ The picture's image layers (top-most first). + , picBackground :: Background + -- ^ The picture's background to be displayed in locations with no + -- Image data. + } deriving (Eq, Show) -instance Show Picture where - show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??" +instance NFData Picture where + rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () --- | Create a picture for display for the given image. The picture will not have a displayed cursor --- and the background display attribute will be `current_attr`. -pic_for_image :: Image -> Picture -pic_for_image i = Picture - { pic_cursor = NoCursor - , pic_image = i - , pic_background = Background ' ' current_attr +-- | A picture with no cursor, background or image layers. +emptyPicture :: Picture +emptyPicture = Picture NoCursor [] ClearBackground + +-- | Add an 'Image' as the top-most layer of a 'Picture'. +addToTop :: Picture -> Image -> Picture +addToTop p i = p {picLayers = i : picLayers p} + +-- | Add an 'Image' as the bottom-most layer of a 'Picture'. +addToBottom :: Picture -> Image -> Picture +addToBottom p i = p {picLayers = picLayers p ++ [i]} + +-- | Create a picture from the given image. The picture will not have a +-- displayed cursor and no background pattern (ClearBackground) will be +-- used. +picForImage :: Image -> Picture +picForImage i = Picture + { picCursor = NoCursor + , picLayers = [i] + , picBackground = ClearBackground } --- | A picture can be configured either to not show the cursor or show the cursor at the specified --- character position. +-- | Create a picture with the given layers, top-most first. -- --- There is not a 1 to 1 map from character positions to a row and column on the screen due to --- characters that take more than 1 column. +-- The picture will not have a displayed cursor and no background +-- pattern (ClearBackgroun) will be used. +picForLayers :: [Image] -> Picture +picForLayers is = Picture + { picCursor = NoCursor + , picLayers = is + , picBackground = ClearBackground + } + +-- | A picture can be configured to hide the cursor or to show the +-- cursor at the specified character position. -- --- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the --- output region. In this case the cursor will not be shown. -data Cursor = - NoCursor - | Cursor Word Word +-- There is not a 1:1 map from character positions to a row and column +-- on the screen due to characters that take more than 1 column. +data Cursor = + -- | Hide the cursor + NoCursor + -- | Set the terminal's cursor position without displaying a cursor + -- character. This is important for accessibility with screen + -- readers where a cursor position needs to be reported but we may + -- not want to show a block cursor in that location for cosmetic + -- reasons. The boolean argument indicates whether the positioning + -- should be absolute as with 'AbsoluteCursor' ('True') or logical + -- as with 'Cursor' ('False'). + | PositionOnly !Bool !Int !Int + -- | Show the cursor at the given logical column accounting for + -- character width in the presence of multi-column characters. + | Cursor !Int !Int + -- | Show the cursor at the given absolute terminal column and row + | AbsoluteCursor !Int !Int + deriving (Eq, Show) --- | Unspecified regions are filled with the picture's background pattern. The background pattern --- can specify a character and a display attribute. If the display attribute used previously should --- be used for a background fill then use `current_attr` for the background attribute. This is the --- default background display attribute. +instance NFData Cursor where + rnf c = c `seq` () + +-- | A 'Picture' has a background pattern. The background is either: -- --- \todo The current attribute is always set to the default attributes at the start of updating the --- screen to a picture. +-- * ClearBackground, which shows the layer below or is blank if the +-- bottom layer +-- * A character and a display attribute -- --- \todo The background character *must* occupy a single column and no more. -data Background = Background - { background_char :: Char - , background_attr :: Attr +-- If the display attribute used previously should be used for a +-- background fill then use `currentAttr` for the background attribute. +data Background + = Background + { backgroundChar :: Char + , backgroundAttr :: Attr } + -- | A ClearBackground is: + -- + -- * the space character if there are remaining non-skip ops + -- + -- * End of line if there are no remaining non-skip ops. + | ClearBackground + deriving (Eq, Show) +instance NFData Background where + rnf (Background c a) = c `seq` a `seq` () + rnf ClearBackground = () + +-- | Return the top-most 'Image' layer for a picture. This is unsafe for +-- 'Picture's without at least one layer. +-- +-- This is provided for compatibility with applications that do not use +-- more than a single layer. +picImage :: Picture -> Image +picImage = head . picLayers diff --git a/src/Graphics/Vty/PictureToSpans.hs b/src/Graphics/Vty/PictureToSpans.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/PictureToSpans.hs @@ -0,0 +1,351 @@ +-- Copyright Corey O'Connor +{-# 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' diff --git a/src/Graphics/Vty/Span.hs b/src/Graphics/Vty/Span.hs --- a/src/Graphics/Vty/Span.hs +++ b/src/Graphics/Vty/Span.hs @@ -1,354 +1,144 @@ --- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NamedFieldPuns #-} +-- Copyright Corey O'Connor {-# LANGUAGE GADTs #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} --- The ops to define the content for an output region. +-- | A picture is translated into a sequences of state changes and +-- character spans. The attribute is applied to all following spans, +-- including spans of the next row. The nth element of the sequence +-- represents the nth row (from top to bottom) of the picture to render. +-- +-- A span op sequence will be defined for all rows and columns (and no +-- more) of the region provided with the picture to 'spansForPic'. module Graphics.Vty.Span - where + ( SpanOp(..) + , columnsToCharOffset + , spanOpHasWidth -import Graphics.Vty.Image -import Graphics.Vty.Picture -import Graphics.Vty.DisplayRegion + , SpanOps + , spanOpsAffectedColumns + , splitOpsAt + , dropOps -import Codec.Binary.UTF8.String ( encode ) + , DisplayOps + , displayOpsRows + , displayOpsColumns + , affectedRegion + ) +where -import Control.Monad ( forM_ ) -import Control.Monad.ST.Strict hiding ( unsafeIOToST ) -import Control.Monad.ST.Unsafe ( unsafeIOToST ) +import Graphics.Vty.Attributes (Attr) +import Graphics.Vty.Image +import Graphics.Vty.Image.Internal ( clipText ) +import qualified Data.Text.Lazy as TL import Data.Vector (Vector) -import qualified Data.Vector as Vector hiding ( take, replicate ) -import Data.Vector.Mutable ( MVector(..)) -import qualified Data.Vector.Mutable as Vector - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as BInt -import qualified Data.Foldable as Foldable -import qualified Data.String.UTF8 as UTF8 -import Data.Word - -import Foreign.Storable ( pokeByteOff ) - -{- | A picture is translated into a sequences of state changes and character spans. - - State changes are currently limited to new attribute values. The attribute is applied to all - - following spans. Including spans of the next row. The nth element of the sequence represents the - - nth row (from top to bottom) of the picture to render. - - - - A span op sequence will be defined for all rows and columns (and no more) of the region provided - - with the picture to spans_for_pic. - - - - todo: Partition attribute changes into multiple categories according to the serialized - - representation of the various attributes. - -} - -data DisplayOps = DisplayOps - { effected_region :: DisplayRegion - , display_ops :: RowOps - } - --- | vector of span operation vectors. One per row of the screen. -type RowOps = Vector SpanOps +import qualified Data.Vector as Vector -type MRowOps s = MVector s SpanOps +-- | This represents an operation on the terminal: either an attribute +-- change or the output of a text string. +data SpanOp = + -- | A span of UTF-8 text occupies a specific number of screen space + -- columns. A single UTF character does not necessarily represent 1 + -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width + -- in columns] [number of characters] [data] + TextSpan + { textSpanAttr :: !Attr + , textSpanOutputWidth :: !Int + , textSpanCharWidth :: !Int + , textSpanText :: TL.Text + } + -- | Skips the given number of columns. + | Skip !Int + -- | Marks the end of a row. Specifies how many columns are + -- remaining. These columns will not be explicitly overwritten with + -- the span ops. The terminal is require to assure the remaining + -- columns are clear. + | RowEnd !Int + deriving Eq --- | vector of span operations. executed in succession. This represents the operations required to --- render a row of the terminal. The operations in one row may effect subsequent rows. --- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground --- color is changed. +-- | A vector of span operations executed in succession. This represents +-- the operations required to render a row of the terminal. The +-- operations in one row may affect subsequent rows. For example, +-- setting the foreground color in one row will affect all subsequent +-- rows until the foreground color is changed. type SpanOps = Vector SpanOp -type MSpanOps s = MVector s SpanOp - -instance Show DisplayOps where - show (DisplayOps _ the_row_ops) - = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }" - -instance Show SpanOp where - show (AttributeChange attr) = show attr - show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw - --- | Number of columns the DisplayOps are defined for -span_ops_columns :: DisplayOps -> Word -span_ops_columns ops = region_width $ effected_region ops - --- | Number of rows the DisplayOps are defined for -span_ops_rows :: DisplayOps -> Word -span_ops_rows ops = region_height $ effected_region ops - --- | The number of columns a SpanOps effects. -span_ops_effected_columns :: SpanOps -> Word -span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops - where - span_ops_effected_columns' t (TextSpan w _ _ ) = t + w - span_ops_effected_columns' t _ = t - --- | This represents an operation on the terminal. Either an attribute change or the output of a --- text string. --- --- todo: This type may need to be restructured to increase sharing in the bytestring --- --- todo: Make foldable -data SpanOp = - AttributeChange !Attr - -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF - -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width - -- TextSpan [output width in columns] [number of characters] [data] - | TextSpan !Word !Word (UTF8.UTF8 B.ByteString) - deriving Eq +dropOps :: Int -> SpanOps -> SpanOps +dropOps w = snd . splitOpsAt w --- | The width of a single SpanOp in columns -span_op_has_width :: SpanOp -> Maybe (Word, Word) -span_op_has_width (TextSpan ow cw _) = Just (cw, ow) -span_op_has_width _ = Nothing +splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps) +splitOpsAt = splitOpsAt' + where + splitOpsAt' 0 ops = (Vector.empty, ops) + splitOpsAt' remainingColumns ops = case Vector.head ops of + t@(TextSpan {}) -> if remainingColumns >= textSpanOutputWidth t + then let (pre,post) = splitOpsAt' (remainingColumns - textSpanOutputWidth t) + (Vector.tail ops) + in (Vector.cons t pre, post) + else let preTxt = clipText (textSpanText t) 0 remainingColumns + preOp = TextSpan { textSpanAttr = textSpanAttr t + , textSpanOutputWidth = remainingColumns + , textSpanCharWidth = fromIntegral $! TL.length preTxt + , textSpanText = preTxt + } + postWidth = textSpanOutputWidth t - remainingColumns + postTxt = clipText (textSpanText t) remainingColumns postWidth + postOp = TextSpan { textSpanAttr = textSpanAttr t + , textSpanOutputWidth = postWidth + , textSpanCharWidth = fromIntegral $! TL.length postTxt + , textSpanText = postTxt + } + in ( Vector.singleton preOp + , Vector.cons postOp (Vector.tail ops) + ) + Skip w -> if remainingColumns >= w + then let (pre,post) = splitOpsAt' (remainingColumns - w) (Vector.tail ops) + in (Vector.cons (Skip w) pre, post) + else ( Vector.singleton $ Skip remainingColumns + , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops) + ) + RowEnd _ -> error "cannot split ops containing a row end" --- | returns the number of columns to the character at the given position in the span op -columns_to_char_offset :: Word -> SpanOp -> Word -columns_to_char_offset cx (TextSpan _ _ utf8_str) = - let str = UTF8.toString utf8_str - in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str -columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width" +-- | A vector of span operation vectors for display, one per row of the +-- output region. +type DisplayOps = Vector SpanOps --- | Produces the span ops that will render the given picture, possibly cropped or padded, into the --- specified region. -spans_for_pic :: Picture -> DisplayRegion -> DisplayOps -spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r) +instance Show SpanOp where + show (TextSpan attr ow cw _) = "TextSpan(" ++ show attr ++ ")(" ++ show ow ++ ", " ++ show cw ++ ")" + show (Skip ow) = "Skip(" ++ show ow ++ ")" + show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" --- | Builds a vector of row operations that will output the given picture to the terminal. +-- | The number of columns the DisplayOps are defined for. -- --- Crops to the given display region. -build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s) -build_spans pic region = do - -- First we create a mutable vector for each rows output operations. - mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty - -- \todo I think building the span operations in display order would provide better performance. - -- However, I got stuck trying to implement an algorithm that did this. This will be considered - -- as a possible future optimization. - -- - -- A depth first traversal of the image is performed. ordered according to the column range - -- defined by the image from least to greatest. The output row ops will at least have the - -- region of the image specified. Iterate over all output rows and output background fills for - -- all unspecified columns. - -- - -- The images are made into span operations from left to right. It's possible that this could - -- easily be made to assure top to bottom output as well. - if region_height region > 0 - then do - -- The ops builder recursively descends the image and outputs span ops that would - -- display that image. The number of columns remaining in this row before exceeding the - -- bounds is also provided. This is used to clip the span ops produced to the display. - -- The skip dimensions provided do....??? - _ <- row_ops_for_image mrow_ops - (pic_image pic) - (pic_background pic) - region - (0,0) - 0 - (region_width region) - (fromEnum $ region_height region) - -- Fill in any unspecified columns with the background pattern. - forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do - end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns - if end_x < region_width region - then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row - else return () - else return () - return mrow_ops +-- All spans are verified to define same number of columns. +displayOpsColumns :: DisplayOps -> Int +displayOpsColumns ops + | Vector.length ops == 0 = 0 + | otherwise = Vector.length $ Vector.head ops --- | Add the operations required to build a given image to the current set of row operations. -row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word) -row_ops_for_image mrow_ops -- the image to output the ops to - image -- the image to rasterize in column order to mrow_ops - bg -- the background fill - region -- ??? - skip_dim@(skip_row,skip_col) -- the number of rows - y -- ??? - remaining_columns -- ??? - remain_rows - | remaining_columns == 0 = return skip_dim - | remain_rows == 0 = return skip_dim - | y >= fromEnum (region_height region) = return skip_dim - | otherwise = case image of - EmptyImage -> return skip_dim - -- The width provided is the number of columns this text span will occupy when displayed. - -- if this is greater than the number of remaining columsn the output has to be produced a - -- character at a time. - HorizText a text_str _ _ -> do - if skip_row > 0 - then return (skip_row - 1, skip_col) - else do - skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns - return (skip_row, skip_col') - VertJoin top_image bottom_image _ _ -> do - (skip_row',skip_col') <- row_ops_for_image mrow_ops - top_image - bg - region - skip_dim - y - remaining_columns - remain_rows - let top_height = (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row') - (skip_row'',skip_col'') <- row_ops_for_image mrow_ops - bottom_image - bg - region - (skip_row', skip_col) - (y + top_height) - remaining_columns - (max 0 $ remain_rows - top_height) - return (skip_row'', min skip_col' skip_col'') - HorizJoin l r _ _ -> do - (skip_row',skip_col') <- row_ops_for_image mrow_ops l bg region skip_dim y remaining_columns remain_rows - -- Don't output the right part unless there is at least a single column left after - -- outputting the left part. - if image_width l - (skip_col - skip_col') > remaining_columns - then return (skip_row,skip_col') - else do - (skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col')) remain_rows - return (min skip_row' skip_row'', skip_col'') - BGFill width height -> do - let min_height = if y + (fromEnum height) > (fromEnum $! region_height region) - then region_height region - (toEnum y) - else min height (toEnum remain_rows) - min_width = min width remaining_columns - actual_height = if skip_row > min_height - then 0 - else min_height - skip_row - actual_width = if skip_col > min_width - then 0 - else min_width - skip_col - forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y' - let skip_row' = if actual_height > skip_row - then 0 - else skip_row - min_height - skip_col' = if actual_width > skip_col - then 0 - else skip_col - min_width - return (skip_row',skip_col') - Translation (dx,dy) i -> do - if dx < 0 - -- Translation left - -- Extract the delta and add it to skip_col. - then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns remain_rows - -- Translation right - else if dy < 0 - -- Translation up - -- Extract the delta and add it to skip_row. - then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns remain_rows - -- Translation down - -- Pad the start of lines and above the image with a - -- background_fill image - else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns remain_rows - where - dw = toEnum $ abs dx - dh = toEnum $ abs dy - ow = image_width image - ih = image_height i - ImageCrop (max_w,max_h) i -> - row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows $ fromEnum max_h) - ImagePad (min_w,min_h) i -> do - let hpad = if image_width i < min_w - then background_fill (min_w - image_width i) (image_height i) - else empty_image - let vpad = if image_height i < min_h - then background_fill (image_width i) (min_h - image_height i) - else empty_image - row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns remain_rows +-- | The number of rows the DisplayOps are defined for. +displayOpsRows :: DisplayOps -> Int +displayOpsRows = Vector.length -snoc_text_span :: Attr -- the display attributes of the text span - -> DisplayString -- the text to output - -> MRowOps s -- the display operations to add to - -> Word -- the number of display columns in the text span to - -- skip before outputting - -> Int -- the row of the display operations to add to - -> Word -- the number of columns from the next column to be - -- defined to the end of the display for the row. - -> ST s Word -snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do - {-# SCC "snoc_text_span-pre" #-} snoc_op mrow_ops y $! AttributeChange a - -- At most a text span will consist of remaining_columns characters - -- we keep track of the position of the next character. - let max_len :: Int = fromEnum remaining_columns - mspan_chars <- Vector.new max_len - ( used_display_columns, display_columns_skipped, used_char_count ) - <- {-# SCC "snoc_text_span-foldlM" #-} Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str - -- once all characters have been output to mspan_chars we grab the used head - out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars - -- convert to UTF8 bytestring. - -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold - -- contained in fromString with the unfold in toList. No biggy right now then. - {-# SCC "snoc_text_span-post" #-} snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count) - $! UTF8.fromString - $! Vector.toList out_text - return $ columns_to_skip - display_columns_skipped - where - build_text_span mspan_chars (!used_display_columns, !display_columns_skipped, !used_char_count) - (out_char, char_display_width) = {-# SCC "build_text_span" #-} - -- Only valid if the maximum width of a character is 2 display columns. - -- XXX: Optimize into a skip pass then clipped fill pass - if display_columns_skipped == columns_to_skip - then if used_display_columns == remaining_columns - then return $! ( used_display_columns, display_columns_skipped, used_char_count ) - else if ( used_display_columns + char_display_width ) > remaining_columns - then do - Vector.unsafeWrite mspan_chars used_char_count '…' - return $! ( used_display_columns + 1 - , display_columns_skipped - , used_char_count + 1 - ) - else do - Vector.unsafeWrite mspan_chars used_char_count out_char - return $! ( used_display_columns + char_display_width - , display_columns_skipped - , used_char_count + 1 - ) - else if (display_columns_skipped + char_display_width) > columns_to_skip - then do - Vector.unsafeWrite mspan_chars used_char_count '…' - return $! ( used_display_columns + 1 - , columns_to_skip - , used_char_count + 1 - ) - else return $ ( used_display_columns - , display_columns_skipped + char_display_width - , used_char_count - ) +affectedRegion :: DisplayOps -> DisplayRegion +affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) --- | Add a background fill of the given column width to the row display operations. --- --- This has a fast path for background characters that are a single column and a single byte. --- Otherwise this has to compute the width of the background character and replicate a sequence of --- bytes to fill in the required width. -snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s () -snoc_bg_fill _row_ops _bg 0 _row - = return () -snoc_bg_fill mrow_ops (Background c back_attr) fill_length row - = do - snoc_op mrow_ops row $ AttributeChange back_attr - -- By all likelyhood the background character will be an ASCII character. Which is a single - -- byte in utf8. Optimize for this special case. - utf8_bs <- if c <= (toEnum 255 :: Char) - then - let !(c_byte :: Word8) = BInt.c2w c - in unsafeIOToST $ do - BInt.create ( fromEnum fill_length ) - $ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte) - [0 .. fromEnum (fill_length - 1)] - else - let !(c_bytes :: [Word8]) = encode [c] - in unsafeIOToST $ do - BInt.create (fromEnum fill_length * length c_bytes) - $ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b) - $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes) - snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs) +-- | The number of columns a SpanOps affects. +spanOpsAffectedColumns :: SpanOps -> Int +spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps + where + spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w + spanOpsAffectedColumns' t (Skip w) = t + w + spanOpsAffectedColumns' t (RowEnd w) = t + w --- | snocs the operation to the operations for the given row. -snoc_op :: MRowOps s -> Int -> SpanOp -> ST s () -snoc_op !mrow_ops !row !op = do - ops <- Vector.read mrow_ops row - let ops' = Vector.snoc ops op - Vector.write mrow_ops row ops' +-- | The width of a single SpanOp in columns. +spanOpHasWidth :: SpanOp -> Maybe (Int, Int) +spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow) +spanOpHasWidth (Skip ow) = Just (ow,ow) +spanOpHasWidth (RowEnd ow) = Just (ow,ow) +-- | The number of columns to the character at the given position in the +-- span op. +columnsToCharOffset :: Int -> SpanOp -> Int +columnsToCharOffset cx (TextSpan _ _ _ utf8Str) = + wctlwidth (TL.take (fromIntegral cx) utf8Str) +columnsToCharOffset cx (Skip _) = cx +columnsToCharOffset cx (RowEnd _) = cx diff --git a/src/Graphics/Vty/Terminal.hs b/src/Graphics/Vty/Terminal.hs deleted file mode 100644 --- a/src/Graphics/Vty/Terminal.hs +++ /dev/null @@ -1,137 +0,0 @@ --- | Generic Terminal interface. --- --- Defines the common interface supported by all terminals. --- --- See also: --- --- 1. Graphics.Vty.Terminal: This instantiates an abtract interface to the terminal interface based --- on the TERM and COLORTERM environment variables. --- --- 2. Graphics.Vty.Terminal.Generic: Defines the generic interface all terminals need to implement. --- --- 3. Graphics.Vty.Terminal.TerminfoBased: Defines a terminal instance that uses terminfo for all --- control strings. No attempt is made to change the character set to UTF-8 for these terminals. --- I don't know a way to reliably determine if that is required or how to do so. --- --- 4. Graphics.Vty.Terminal.XTermColor: This module contains an interface suitable for xterm-like --- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many --- control codes as possible. --- --- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE ScopedTypeVariables #-} -module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal - , Terminal(..) - , TerminalHandle(..) - , DisplayHandle(..) - , output_picture - , display_context - ) - where - - -import Graphics.Vty.Terminal.Generic -import Graphics.Vty.Terminal.MacOSX as MacOSX -import Graphics.Vty.Terminal.XTermColor as XTermColor -import Graphics.Vty.Terminal.TerminfoBased as TerminfoBased - -import Control.Applicative -import Control.Exception ( SomeException, try ) -import Control.Monad.Trans - -import Data.List ( isPrefixOf ) -import Data.Word - -import System.Environment - --- | Returns a TerminalHandle (an abstract Terminal instance) for the current terminal. --- --- The specific Terminal implementation used is hidden from the API user. All terminal --- implementations are assumed to perform more, or less, the same. Currently all implementations use --- terminfo for at least some terminal specific information. This is why platforms without terminfo --- are not supported. However, as mentioned before, any specifics about it being based on terminfo --- are hidden from the API user. If a terminal implementation is developed for a terminal for a --- platform without terminfo support then Vty should work as expected on that terminal. --- --- Selection of a terminal is done as follows: --- --- * If TERM == xterm --- then the terminal might be one of the Mac OS X .app terminals. Check if that might be --- the case and use MacOSX if so. --- otherwise use XTermColor. --- --- * for any other TERM value TerminfoBased is used. --- --- --- The terminal has to be determined dynamically at runtime. To satisfy this requirement all --- terminals instances are lifted into an abstract terminal handle via existential qualification. --- This implies that the only equations that can used are those in the terminal class. --- --- To differentiate between Mac OS X terminals this uses the TERM_PROGRAM environment variable. --- However, an xterm started by Terminal or iTerm *also* has TERM_PROGRAM defined since the --- environment variable is not reset/cleared by xterm. However a Terminal.app or iTerm.app started --- from an xterm under X11 on mac os x will likely be done via open. Since this does not propogate --- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true --- Terminal.app or iTerm.app session. --- --- --- The file descriptor used for output will a duplicate of the current stdout file descriptor. --- --- todo: add an implementation for windows that does not depend on terminfo. Should be installable --- with only what is provided in the haskell platform. --- --- todo: The Terminal interface does not provide any input support. -terminal_handle :: ( Applicative m, MonadIO m ) => m TerminalHandle -terminal_handle = do - term_type <- liftIO $ getEnv "TERM" - t <- if "xterm" `isPrefixOf` term_type - then do - maybe_terminal_app <- get_env "TERM_PROGRAM" - case maybe_terminal_app of - Nothing - -> XTermColor.terminal_instance term_type >>= new_terminal_handle - Just v | v == "Apple_Terminal" || v == "iTerm.app" - -> do - maybe_xterm <- get_env "XTERM_VERSION" - case maybe_xterm of - Nothing -> MacOSX.terminal_instance v >>= new_terminal_handle - Just _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle - -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app - -- like terminal? - _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle - -- Not an xterm-like terminal. try for generic terminfo. - else TerminfoBased.terminal_instance term_type >>= new_terminal_handle - return t - where - get_env var = do - mv <- liftIO $ try $ getEnv var - case mv of - Left (_e :: SomeException) -> return $ Nothing - Right v -> return $ Just v - --- | Sets the cursor position to the given output column and row. --- --- This is not necessarially the same as the character position with the same coordinates. --- Characters can be a variable number of columns in width. --- --- Currently, the only way to set the cursor position to a given character coordinate is to specify --- the coordinate in the Picture instance provided to output_picture or refresh. -set_cursor_pos :: MonadIO m => TerminalHandle -> Word -> Word -> m () -set_cursor_pos t x y = do - bounds <- display_bounds t - d <- display_context t bounds - liftIO $ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y) - --- | Hides the cursor -hide_cursor :: MonadIO m => TerminalHandle -> m () -hide_cursor t = do - bounds <- display_bounds t - d <- display_context t bounds - liftIO $ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d) - --- | Shows the cursor -show_cursor :: MonadIO m => TerminalHandle -> m () -show_cursor t = do - bounds <- display_bounds t - d <- display_context t bounds - liftIO $ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d) - diff --git a/src/Graphics/Vty/Terminal/Debug.hs b/src/Graphics/Vty/Terminal/Debug.hs deleted file mode 100644 --- a/src/Graphics/Vty/Terminal/Debug.hs +++ /dev/null @@ -1,121 +0,0 @@ --- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -module Graphics.Vty.Terminal.Debug ( DebugTerminal(..) - , DebugDisplay(..) - , terminal_instance - , dehandle - ) - where - -import Graphics.Vty.DisplayRegion -import Graphics.Vty.Terminal.Generic - -import Control.Applicative -import Control.Monad.Trans -import Control.Monad.State.Strict - -import qualified Data.ByteString.UTF8 as BS -import qualified Data.ByteString as BSCore -import Data.IORef -import qualified Data.Sequence as Seq -import qualified Data.String.UTF8 as UTF8 -import Data.Word - -import Foreign.Marshal.Array ( peekArray ) -import Foreign.Ptr ( plusPtr ) -import Foreign.Storable ( poke ) - -import System.IO - -import Unsafe.Coerce - --- | The debug display terminal produces a string representation of the requested picture. There is --- *not* an isomorphism between the string representation and the picture. The string --- representation is a simplification of the picture that is only useful in debugging VTY without --- considering terminal specific issues. --- --- The debug implementation is useful in manually determining if the sequence of terminal operations --- matches the expected sequence. So requirement of the produced representation is simplicity in --- parsing the text representation and determining how the picture was mapped to terminal --- operations. --- --- All terminals support the operations specified in the Terminal class defined in --- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad --- class there exists a monoid that defines it's algebra. The string representation is a sequence of --- identifiers where each identifier is the name of an operation in the algebra. - -data DebugTerminal = DebugTerminal - { debug_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString) - , debug_terminal_bounds :: DisplayRegion - } - -instance Terminal DebugTerminal where - terminal_ID _t = "debug_terminal" - release_terminal _t = return () - reserve_display _t = return () - release_display _t = return () - display_bounds t = return $ debug_terminal_bounds t - display_terminal_instance t r c = return $ c (DebugDisplay r) - output_byte_buffer t out_buffer buffer_size - = liftIO $ do - putStrLn $ "output_byte_buffer ?? " ++ show buffer_size - peekArray (fromEnum buffer_size) out_buffer - >>= return . UTF8.fromRep . BSCore.pack - >>= writeIORef (debug_terminal_last_output t) - - output_handle t = return stdout - -data DebugDisplay = DebugDisplay - { debug_display_bounds :: DisplayRegion - } - -terminal_instance :: ( Applicative m, MonadIO m ) => DisplayRegion -> m TerminalHandle -terminal_instance r = do - output_ref <- liftIO $ newIORef undefined - new_terminal_handle $ DebugTerminal output_ref r - -dehandle :: TerminalHandle -> DebugTerminal -dehandle (TerminalHandle t _) = unsafeCoerce t - -instance DisplayTerminal DebugDisplay where - -- | Provide the current bounds of the output terminal. - context_region d = debug_display_bounds d - - -- | A cursor move is always visualized as the single character 'M' - move_cursor_required_bytes _d _x _y = 1 - - -- | A cursor move is always visualized as the single character 'M' - serialize_move_cursor _d _x _y ptr = do - liftIO $ poke ptr (toEnum $ fromEnum 'M') - return $ ptr `plusPtr` 1 - - -- | Show cursor is always visualized as the single character 'S' - show_cursor_required_bytes _d = 1 - - -- | Show cursor is always visualized as the single character 'S' - serialize_show_cursor _d ptr = do - liftIO $ poke ptr (toEnum $ fromEnum 'S') - return $ ptr `plusPtr` 1 - - -- | Hide cursor is always visualized as the single character 'H' - hide_cursor_required_bytes _d = 1 - - -- | Hide cursor is always visualized as the single character 'H' - serialize_hide_cursor _d ptr = do - liftIO $ poke ptr (toEnum $ fromEnum 'H') - return $ ptr `plusPtr` 1 - - -- | An attr change is always visualized as the single character 'A' - attr_required_bytes _d _fattr _diffs _attr = 1 - - -- | An attr change is always visualized as the single character 'A' - serialize_set_attr _d _fattr _diffs _attr ptr = do - liftIO $ poke ptr (toEnum $ fromEnum 'A') - return $ ptr `plusPtr` 1 - - default_attr_required_bytes _d = 1 - serialize_default_attr _d ptr = do - liftIO $ poke ptr (toEnum $ fromEnum 'D') - return $ ptr `plusPtr` 1 - diff --git a/src/Graphics/Vty/Terminal/Generic.hs b/src/Graphics/Vty/Terminal/Generic.hs deleted file mode 100644 --- a/src/Graphics/Vty/Terminal/Generic.hs +++ /dev/null @@ -1,417 +0,0 @@ --- Copyright 2009-2011 Corey O'Connor -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic - , OutputBuffer - ) - where - -import Data.Marshalling - -import Graphics.Vty.Picture -import Graphics.Vty.Span -import Graphics.Vty.DisplayRegion - -import Graphics.Vty.DisplayAttributes - -import Control.Monad ( liftM ) -import Control.Monad.Trans - -import qualified Data.ByteString.Internal as BSCore -import Data.IORef -import Data.String.UTF8 hiding ( foldl ) -import qualified Data.Vector as Vector - -import System.IO - --- | An handle to a terminal that hides the implementation. -data TerminalHandle where - TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle - -state_ref :: TerminalHandle -> IORef TerminalState -state_ref (TerminalHandle _ s_ref) = s_ref - -new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle -new_terminal_handle t = do - s_ref <- liftIO $ newIORef initial_terminal_state - return $ TerminalHandle t s_ref - --- | The current terminal state. This may not exactly be known. -data TerminalState = TerminalState - { known_fattr :: Maybe FixedAttr - } - --- | Initially we know nothing about a terminal's state. -initial_terminal_state :: TerminalState -initial_terminal_state = TerminalState Nothing - -class Terminal t where - -- | Text identifier for the terminal. Used for debugging. - terminal_ID :: t -> String - -- | - release_terminal :: MonadIO m => t -> m () - -- | Clear the display and initialize the terminal to some initial display state. - -- - -- The expectation of a program is that the display starts in some initial state. - -- The initial state would consist of fixed values: - -- - cursor at top left - -- - UTF-8 character encoding - -- - drawing characteristics are the default - -- The abstract operation I think all these behaviors are instances of is reserving exclusive - -- access to a display such that: - -- - The previous state cannot be determined - -- - When exclusive access to a display is release the display returns to the previous state. - reserve_display :: MonadIO m => t -> m () - - -- | Return the display to the state before reserve_display - -- If no previous state then set the display state to the initial state. - release_display :: MonadIO m => t -> m () - - -- | Returns the current display bounds. - display_bounds :: MonadIO m => t -> m DisplayRegion - - -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle - -- constructor. - display_terminal_instance :: MonadIO m - => t - -> DisplayRegion - -> (forall d. DisplayTerminal d => d -> DisplayHandle) - -> m DisplayHandle - - -- | Output the byte buffer of the specified size to the terminal device. The size is equal to - -- end_ptr - start_ptr - output_byte_buffer :: t -> OutputBuffer -> Word -> IO () - - -- | Handle of output device - output_handle :: t -> IO Handle - -instance Terminal TerminalHandle where - terminal_ID (TerminalHandle t _) = terminal_ID t - release_terminal (TerminalHandle t _) = release_terminal t - reserve_display (TerminalHandle t _) = reserve_display t - release_display (TerminalHandle t _) = release_display t - display_bounds (TerminalHandle t _) = display_bounds t - display_terminal_instance (TerminalHandle t _) = display_terminal_instance t - output_byte_buffer (TerminalHandle t _) = output_byte_buffer t - output_handle (TerminalHandle t _) = output_handle t - -data DisplayHandle where - DisplayHandle :: forall d . DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle - --- | Acquire display access to the given region of the display. --- Currently all regions have the upper left corner of (0,0) and the lower right corner at --- (max display_width provided_width, max display_height provided_height) -display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle -display_context t b = do - s <- initial_display_state - display_terminal_instance t b (\ d -> DisplayHandle d t s) - -data DisplayState = DisplayState - { previous_output_ref :: IORef (Maybe DisplayOps) - } - -initial_display_state :: MonadIO m => m DisplayState -initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing - -class DisplayTerminal d where - -- | Provide the bounds of the display context. - context_region :: d -> DisplayRegion - - -- | Maximum number of colors supported by the context. - context_color_count :: d -> Word - - -- | sets the output position to the specified row and column. Where the number of bytes - -- required for the control codes can be specified seperate from the actual byte sequence. - move_cursor_required_bytes :: d -> Word -> Word -> Word - serialize_move_cursor :: MonadIO m => d -> Word -> Word -> OutputBuffer -> m OutputBuffer - - show_cursor_required_bytes :: d -> Word - serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer - - hide_cursor_required_bytes :: d -> Word - serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer - - -- | Assure the specified output attributes will be applied to all the following text until the - -- next output attribute change. Where the number of bytes required for the control codes can - -- be specified seperate from the actual byte sequence. The required number of bytes must be - -- at least the maximum number of bytes required by any attribute changes. The serialization - -- equations must provide the ptr to the next byte to be specified in the output buffer. - -- - -- The currently applied display attributes are provided as well. The Attr data type can - -- specify the style or color should not be changed from the currently applied display - -- attributes. In order to support this the currently applied display attributes are required. - -- In addition it may be possible to optimize the state changes based off the currently applied - -- display attributes. - attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Word - serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer - - -- | Reset the display attributes to the default display attributes - default_attr_required_bytes :: d -> Word - serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer - - -- | See Graphics.Vty.Terminal.XTermColor.inline_hack - inline_hack :: MonadIO m => d -> m () - inline_hack _d = return () - - -instance DisplayTerminal DisplayHandle where - context_region (DisplayHandle d _ _) = context_region d - context_color_count (DisplayHandle d _ _) = context_color_count d - move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d - serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d - show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d - serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d - hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d - serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d - attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d - serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d - default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d - serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d - inline_hack (DisplayHandle d _ _) = inline_hack d - --- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory. -utf8_text_required_bytes :: UTF8 BSCore.ByteString -> Word -utf8_text_required_bytes str = - let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str) - in toEnum src_bytes_length - --- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory. -serialize_utf8_text :: MonadIO m => UTF8 BSCore.ByteString -> OutputBuffer -> m OutputBuffer -serialize_utf8_text str dest_ptr = - let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str) - in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do - let src_ptr' = src_ptr `plusPtr` src_ptr_offset - BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length) - return (dest_ptr `plusPtr` src_bytes_length) - - --- | Displays the given `Picture`. --- --- 0. The image is cropped to the display size. --- --- 1. Converted into a sequence of attribute changes and text spans. --- --- 2. The cursor is hidden. --- --- 3. Serialized to the display. --- --- 4. The cursor is then shown and positioned or kept hidden. --- --- --- todo: specify possible IO exceptions. --- abstract from IO monad to a MonadIO instance. -output_picture :: MonadIO m => DisplayHandle -> Picture -> m () -output_picture (DisplayHandle d t s) pic = do - let !r = context_region d - let !ops = spans_for_pic pic r - let !initial_attr = FixedAttr default_style_mask Nothing Nothing - -- Diff the previous output against the requested output. Differences are currently on a per-row - -- basis. - diffs :: [Bool] - <- liftIO ( readIORef (previous_output_ref s) ) - >>= \mprevious_ops -> case mprevious_ops of - Nothing - -> return $ replicate ( fromEnum $ region_height $ effected_region ops ) - True - Just previous_ops - -> if effected_region previous_ops /= effected_region ops - then return $ replicate ( fromEnum $ region_height $ effected_region ops ) - True - else return $ zipWith (/=) ( Vector.toList $ display_ops previous_ops ) - ( Vector.toList $ display_ops ops ) - - -- determine the number of bytes required to completely serialize the output ops. - let total = hide_cursor_required_bytes d - + default_attr_required_bytes d - + required_bytes d initial_attr diffs ops - + case pic_cursor pic of - NoCursor -> 0 - Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic - ( ox, oy ) = char_to_output_pos m ( x, y ) - in show_cursor_required_bytes d - + move_cursor_required_bytes d ox oy - - -- ... then serialize - liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do - ptr <- serialize_hide_cursor d start_ptr - ptr' <- serialize_default_attr d ptr - ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops - end_ptr <- case pic_cursor pic of - NoCursor -> return ptr'' - Cursor x y -> do - let m = cursor_output_map ops $ pic_cursor pic - (ox, oy) = char_to_output_pos m (x,y) - serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy - -- todo: How to handle exceptions? - case end_ptr `minusPtr` start_ptr of - count | count < 0 -> fail "End pointer before start of buffer." - | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total) - | otherwise -> output_byte_buffer t start_ptr (toEnum count) - -- Cache the output spans. - liftIO $ writeIORef (previous_output_ref s) (Just ops) - return () - -required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Word -required_bytes d in_fattr diffs ops = - let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops ) - in n - where - required_bytes' (y, current_sum, fattr, True : diffs') span_ops - = let (s, fattr') = span_ops_required_bytes d y fattr span_ops - in ( y + 1, s + current_sum, fattr', diffs' ) - required_bytes' (y, current_sum, fattr, False : diffs') _span_ops - = ( y + 1, current_sum, fattr, diffs' ) - required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops - = error "shouldn't be possible" - -span_ops_required_bytes :: DisplayTerminal d => d -> Word -> FixedAttr -> SpanOps -> (Word, FixedAttr) -span_ops_required_bytes d y in_fattr span_ops = - -- The first operation is to set the cursor to the start of the row - let header_required_bytes = move_cursor_required_bytes d 0 y - -- then the span ops are serialized in the order specified - in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op - in (c + current_sum, fattr') - ) - (header_required_bytes, in_fattr) - span_ops - -span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr) -span_op_required_bytes d fattr (AttributeChange attr) = - let attr' = limit_attr_for_display d attr - diffs = display_attr_diffs fattr fattr' - c = attr_required_bytes d fattr attr' diffs - fattr' = fix_display_attr fattr attr' - in (c, fattr') -span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr) - -serialize_output_ops :: ( MonadIO m, DisplayTerminal d ) - => d - -> OutputBuffer - -> FixedAttr - -> [Bool] - -> DisplayOps - -> m OutputBuffer -serialize_output_ops d start_ptr in_fattr diffs ops = do - (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops' - ( 0, start_ptr, in_fattr, diffs ) - ( display_ops ops ) - return end_ptr - where - serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops - = serialize_span_ops d y out_ptr fattr span_ops - >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) ) - serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops - = return ( y + 1, out_ptr, fattr, diffs' ) - serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops - = error "shouldn't be possible" - -serialize_span_ops :: ( MonadIO m, DisplayTerminal d ) - => d - -> Word - -> OutputBuffer - -> FixedAttr - -> SpanOps - -> m (OutputBuffer, FixedAttr) -serialize_span_ops d y out_ptr in_fattr span_ops = do - -- The first operation is to set the cursor to the start of the row - out_ptr' <- serialize_move_cursor d 0 y out_ptr - -- then the span ops are serialized in the order specified - Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr ) - (out_ptr', in_fattr) - span_ops - -serialize_span_op :: ( MonadIO m, DisplayTerminal d ) - => d - -> SpanOp - -> OutputBuffer - -> FixedAttr - -> m (OutputBuffer, FixedAttr) -serialize_span_op d (AttributeChange attr) out_ptr fattr = do - let attr' = limit_attr_for_display d attr - fattr' = fix_display_attr fattr attr' - diffs = display_attr_diffs fattr fattr' - out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr - return (out_ptr', fattr') -serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do - out_ptr' <- serialize_utf8_text str out_ptr - return (out_ptr', fattr) - -marshall_to_terminal :: ( Terminal t ) - => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO () -marshall_to_terminal t c f = do - start_ptr <- mallocBytes (fromEnum c) - -- - -- todo: capture exceptions? - end_ptr <- f start_ptr - case end_ptr `minusPtr` start_ptr of - count | count < 0 -> fail "End pointer before start pointer." - | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c) - | otherwise -> output_byte_buffer t start_ptr (toEnum count) - free start_ptr - return () - --- | The cursor position is given in X,Y character offsets. Due to multi-column characters this --- needs to be translated to column, row positions. -data CursorOutputMap = CursorOutputMap - { char_to_output_pos :: (Word, Word) -> (Word, Word) - } - -cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap -cursor_output_map span_ops _cursor = CursorOutputMap - { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy) - } - -cursor_column_offset :: DisplayOps -> Word -> Word -> Word -cursor_column_offset span_ops cx cy = - let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy) - (out_offset, _, _) - = Vector.foldl' ( \(d, current_cx, done) op -> - if done then (d, current_cx, done) else case span_op_has_width op of - Nothing -> (d, current_cx, False) - Just (cw, ow) -> case compare cx (current_cx + cw) of - GT -> ( d + ow - , current_cx + cw - , False - ) - EQ -> ( d + ow - , current_cx + cw - , True - ) - LT -> ( d + columns_to_char_offset (cx - current_cx) op - , current_cx + cw - , True - ) - ) - (0, 0, False) - cursor_row_ops - in out_offset - --- | Not all terminals support all display attributes. This filters a display attribute to what the --- given terminal can display. -limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr -limit_attr_for_display d attr - = attr { attr_fore_color = clamp_color $ attr_fore_color attr - , attr_back_color = clamp_color $ attr_back_color attr - } - where - clamp_color Default = Default - clamp_color KeepCurrent = KeepCurrent - clamp_color (SetTo c) = clamp_color' c - clamp_color' (ISOColor v) - | context_color_count d < 8 = Default - | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8) - | otherwise = SetTo $ ISOColor v - clamp_color' (Color240 v) - -- TODO: Choose closes ISO color? - | context_color_count d < 8 = Default - | context_color_count d < 16 = Default - | context_color_count d == 240 = SetTo $ Color240 v - | otherwise - = let p :: Double = fromIntegral v / 240.0 - v' = floor $ p * (fromIntegral $ context_color_count d) - in SetTo $ Color240 v' - diff --git a/src/Graphics/Vty/Terminal/MacOSX.hs b/src/Graphics/Vty/Terminal/MacOSX.hs deleted file mode 100644 --- a/src/Graphics/Vty/Terminal/MacOSX.hs +++ /dev/null @@ -1,102 +0,0 @@ --- Copyright 2009-2010 Corey O'Connor --- The standard Mac OS X terminals Terminal.app and iTerm both declare themselves to be --- "xterm-color" by default. However the terminfo database for xterm-color included with OS X is --- incomplete. --- --- This terminal implementation modifies the standard terminfo terminal as required for complete OS --- X support. -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -module Graphics.Vty.Terminal.MacOSX ( terminal_instance - ) - where - -import Graphics.Vty.Terminal.Generic -import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased - -import Control.Applicative -import Control.Monad.Trans - -import System.IO - --- | A Mac terminal is assumed to be an xterm based terminal. -data Term = Term - { super_term :: TerminalHandle - , term_app :: String - } - --- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier --- "xterm-256color" is used. --- --- This effects the terminfo lookup. -terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term -terminal_instance v = do - let base_term "iTerm.app" = "xterm-256color" - base_term _ = "xterm" - t <- TerminfoBased.terminal_instance (base_term v) >>= new_terminal_handle - return $ Term t v - -flushed_put :: MonadIO m => String -> m () -flushed_put str = do - liftIO $ hPutStr stdout str - liftIO $ hFlush stdout - --- | Terminal.app requires the xterm-color smcup and rmcup caps. Not the generic xterm ones. --- Otherwise, Terminal.app expects the xterm caps. -smcup_str, rmcup_str :: String -smcup_str = "\ESC7\ESC[?47h" -rmcup_str = "\ESC[2J\ESC[?47l\ESC8" - --- | iTerm needs a clear screen after smcup as well. -clear_screen_str :: String -clear_screen_str = "\ESC[H\ESC[2J" - -instance Terminal Term where - terminal_ID t = term_app t ++ " :: MacOSX" - - release_terminal t = do - release_terminal $ super_term t - - reserve_display _t = do - flushed_put smcup_str - flushed_put clear_screen_str - - release_display _t = do - flushed_put rmcup_str - - display_terminal_instance t b c = do - d <- display_context (super_term t) b - return $ c (DisplayContext d) - - display_bounds t = display_bounds (super_term t) - - output_byte_buffer t = output_byte_buffer (super_term t) - - output_handle t = output_handle (super_term t) - -data DisplayContext = DisplayContext - { super_display :: DisplayHandle - } - -instance DisplayTerminal DisplayContext where - context_region d = context_region (super_display d) - context_color_count d = context_color_count (super_display d) - - move_cursor_required_bytes d = move_cursor_required_bytes (super_display d) - serialize_move_cursor d = serialize_move_cursor (super_display d) - - show_cursor_required_bytes d = show_cursor_required_bytes (super_display d) - serialize_show_cursor d = serialize_show_cursor (super_display d) - - hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d) - serialize_hide_cursor d = serialize_hide_cursor (super_display d) - - attr_required_bytes d = attr_required_bytes (super_display d) - serialize_set_attr d = serialize_set_attr (super_display d) - - default_attr_required_bytes d = default_attr_required_bytes (super_display d) - serialize_default_attr d = serialize_default_attr (super_display d) - diff --git a/src/Graphics/Vty/Terminal/TerminfoBased.hs b/src/Graphics/Vty/Terminal/TerminfoBased.hs deleted file mode 100644 --- a/src/Graphics/Vty/Terminal/TerminfoBased.hs +++ /dev/null @@ -1,437 +0,0 @@ --- Copyright Corey O'Connor (coreyoconnor@gmail.com) -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-} -module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance - ) - where - -import Data.Terminfo.Parse -import Data.Terminfo.Eval - -import Graphics.Vty.Attributes -import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Terminal.Generic -import Graphics.Vty.DisplayRegion - -import Control.Applicative -import Control.Monad ( foldM ) -import Control.Monad.Trans - -import Data.Bits ( (.&.) ) -import Data.Maybe ( isJust, isNothing, fromJust ) -import Data.Word - -import Foreign.C.Types ( CLong(..) ) - -import GHC.IO.Handle - -import qualified System.Console.Terminfo as Terminfo -import System.IO - -data Term = Term - { term_info_ID :: String - , term_info :: Terminfo.Terminal - , smcup :: Maybe CapExpression - , rmcup :: Maybe CapExpression - , cup :: CapExpression - , cnorm :: CapExpression - , civis :: CapExpression - , set_fore_color :: CapExpression - , set_back_color :: CapExpression - , set_default_attr :: CapExpression - , clear_screen :: CapExpression - , display_attr_caps :: DisplayAttrCaps - , term_handle :: Handle - } - -data DisplayAttrCaps = DisplayAttrCaps - { set_attr_states :: Maybe CapExpression - , enter_standout :: Maybe CapExpression - , exit_standout :: Maybe CapExpression - , enter_underline :: Maybe CapExpression - , exit_underline :: Maybe CapExpression - , enter_reverse_video :: Maybe CapExpression - , enter_dim_mode :: Maybe CapExpression - , enter_bold_mode :: Maybe CapExpression - } - -marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO () -marshall_cap_to_terminal t cap_selector cap_params = do - marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params ) - ( serialize_cap_expression (cap_selector t) cap_params ) - return () - -{- | Uses terminfo for all control codes. While this should provide the most compatible terminal - - terminfo does not support some features that would increase efficiency and improve compatibility: - - * determine the character encoding supported by the terminal. Should this be taken from the LANG - - environment variable? - - * Provide independent string capabilities for all display attributes. - - - - - - todo: Some display attributes like underline and bold have independent string capabilities that - - should be used instead of the generic "sgr" string capability. - -} -terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term -terminal_instance in_ID = do - ti <- liftIO $ Terminfo.setupTerm in_ID - let require_cap str - = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of - Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\"" - Just cap_str -> do - parse_result <- parse_cap_expression cap_str - case parse_result of - Left e -> fail $ show e - Right cap -> return cap - probe_cap cap_name - = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of - Nothing -> return Nothing - Just cap_str -> do - parse_result <- parse_cap_expression cap_str - case parse_result of - Left e -> fail $ show e - Right cap -> return $ Just cap - the_handle <- liftIO $ hDuplicate stdout - pure Term - <*> pure in_ID - <*> pure ti - <*> probe_cap "smcup" - <*> probe_cap "rmcup" - <*> require_cap "cup" - <*> require_cap "cnorm" - <*> require_cap "civis" - <*> require_cap "setaf" - <*> require_cap "setab" - <*> require_cap "sgr0" - <*> require_cap "clear" - <*> current_display_attr_caps ti - <*> pure the_handle - -current_display_attr_caps :: ( Applicative m, MonadIO m ) - => Terminfo.Terminal - -> m DisplayAttrCaps -current_display_attr_caps ti - = pure DisplayAttrCaps - <*> probe_cap "sgr" - <*> probe_cap "smso" - <*> probe_cap "rmso" - <*> probe_cap "smul" - <*> probe_cap "rmul" - <*> probe_cap "rev" - <*> probe_cap "dim" - <*> probe_cap "bold" - where probe_cap cap_name - = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of - Nothing -> return Nothing - Just cap_str -> do - parse_result <- parse_cap_expression cap_str - case parse_result of - Left e -> fail $ show e - Right cap -> return $ Just cap - -instance Terminal Term where - terminal_ID t = term_info_ID t ++ " :: TerminfoBased" - - release_terminal t = liftIO $ do - marshall_cap_to_terminal t set_default_attr [] - marshall_cap_to_terminal t cnorm [] - hClose $ term_handle t - return () - - reserve_display t = liftIO $ do - if (isJust $ smcup t) - then marshall_cap_to_terminal t (fromJust . smcup) [] - else return () - -- Screen on OS X does not appear to support smcup? - -- To approximate the expected behavior: clear the screen and then move the mouse to the - -- home position. - hFlush stdout - marshall_cap_to_terminal t clear_screen [] - return () - - release_display t = liftIO $ do - if (isJust $ rmcup t) - then marshall_cap_to_terminal t (fromJust . rmcup) [] - else return () - marshall_cap_to_terminal t cnorm [] - return () - - display_terminal_instance t b c = do - let color_count - = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of - Nothing -> 8 - Just v -> toEnum v - return $ c (DisplayContext b t color_count) - - display_bounds _t = do - raw_size <- liftIO $ get_window_size - case raw_size of - ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size - | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h) - - -- | Output the byte buffer of the specified size to the terminal device. - output_byte_buffer t out_ptr out_byte_count = do - -- if the out fd is actually the same as stdout's then a - -- flush is required *before* the c_output_byte_buffer call - -- otherwise there may still be data in GHC's internal stdout buffer. - -- _ <- handleToFd stdout - hPutBuf (term_handle t) out_ptr (fromEnum out_byte_count) - hFlush (term_handle t) - - output_handle t = return (term_handle t) - -foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size - :: IO CLong - -get_window_size :: IO (Int,Int) -get_window_size = do - (a,b) <- (`divMod` 65536) `fmap` c_get_window_size - return (fromIntegral b, fromIntegral a) - -data DisplayContext = DisplayContext - { bounds :: DisplayRegion - , term :: Term - , supported_colors :: Word - } - -instance DisplayTerminal DisplayContext where - context_region d = bounds d - - context_color_count d = supported_colors d - - move_cursor_required_bytes d x y - = cap_expression_required_bytes (cup $ term d) [y, x] - serialize_move_cursor d x y out_ptr - = liftIO $ serialize_cap_expression (cup $ term d) [y, x] out_ptr - - show_cursor_required_bytes d - = cap_expression_required_bytes (cnorm $ term d) [] - serialize_show_cursor d out_ptr - = liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr - - hide_cursor_required_bytes d - = cap_expression_required_bytes (civis $ term d) [] - serialize_hide_cursor d out_ptr - = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr - - -- | Instead of evaluating all the rules related to setting display attributes twice (once in - -- required bytes and again in serialize) or some memoization scheme just return a size - -- requirement as big the longest possible control string. - -- - -- Which is assumed to the be less than 512 for now. - -- - -- \todo Not verified as safe and wastes memory. - attr_required_bytes _d _prev_attr _req_attr _diffs = 512 - - -- | Portably setting the display attributes is a giant pain in the ass. - -- - -- If the terminal supports the sgr capability (which sets the on/off state of each style - -- directly ; and, for no good reason, resets the colors to the default) this procedure is used: - -- - -- 0. set the style attributes. This resets the fore and back color. - -- 1, If a foreground color is to be set then set the foreground color - -- 2. likewise with the background color - -- - -- If the terminal does not support the sgr cap then: - -- if there is a change from an applied color to the default (in either the fore or back color) - -- then: - -- 0. reset all display attributes (sgr0) - -- 1. enter required style modes - -- 2. set the fore color if required - -- 3. set the back color if required - -- - -- Entering the required style modes could require a reset of the display attributes. If this is - -- the case then the back and fore colors always need to be set if not default. - -- - -- This equation implements the above logic. - serialize_set_attr d prev_attr req_attr diffs out_ptr = do - case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of - -- The only way to reset either color, portably, to the default is to use either the set - -- state capability or the set default capability. - True -> do - case req_display_cap_seq_for ( display_attr_caps $ term d ) - ( fixed_style attr ) - ( style_to_apply_seq $ fixed_style attr ) - of - EnterExitSeq caps - -- only way to reset a color to the defaults - -> serialize_default_attr d out_ptr - >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps) - >>= set_colors - SetState state - -- implicitly resets the colors to the defaults - -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states - $ display_attr_caps - $ term d - ) - ( sgr_args_for_state state ) - out_ptr - >>= set_colors - -- Otherwise the display colors are not changing or changing between two non-default - -- points. - False -> do - -- Still, it could be the case that the change in display attributes requires the - -- colors to be reset because the required capability was not available. - case req_display_cap_seq_for ( display_attr_caps $ term d ) - ( fixed_style attr ) - ( style_diffs diffs ) - of - -- Really, if terminals were re-implemented with modern concepts instead of - -- bowing down to 40 yr old dumb terminal requirements this would be the - -- only case ever reached! - -- Changes the style and color states according to the differences with the - -- currently applied states. - EnterExitSeq caps - -> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps ) - >>= apply_color_diff set_fore_color ( fore_color_diff diffs ) - >>= apply_color_diff set_back_color ( back_color_diff diffs ) - SetState state - -- implicitly resets the colors to the defaults - -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states - $ display_attr_caps - $ term d - ) - ( sgr_args_for_state state ) - out_ptr - >>= set_colors - where - attr = fix_display_attr prev_attr req_attr - set_colors ptr = do - ptr' <- case fixed_fore_color attr of - Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d ) - [ ansi_color_index c ] - ptr - Nothing -> return ptr - ptr'' <- case fixed_back_color attr of - Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d ) - [ ansi_color_index c ] - ptr' - Nothing -> return ptr' - return ptr'' - apply_color_diff _f NoColorChange ptr - = return ptr - apply_color_diff _f ColorToDefault _ptr - = fail "ColorToDefault is not a possible case for apply_color_diffs" - apply_color_diff f ( SetColor c ) ptr - = liftIO $ serialize_cap_expression ( f $ term d ) - [ ansi_color_index c ] - ptr - - default_attr_required_bytes d - = cap_expression_required_bytes (set_default_attr $ term d) [] - serialize_default_attr d out_ptr = do - liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr - --- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not --- be supported by the terminal. --- --- This takes a Color which clearly identifies which pallete to use and computes the index --- into the full 256 color pallete. -ansi_color_index :: Color -> Word -ansi_color_index (ISOColor v) = toEnum $ fromEnum v -ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v ) - -{- | The sequence of terminfo caps to apply a given style are determined according to these rules. - - - - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than - - the full set display attribute state capability. - - - - 2. If a mode is supposed to be removed but there is not an exit capability defined then the - - display attributes are reset to defaults then the display attribute state is set. - - - - 3. If a mode is supposed to be applied but there is not an enter capability defined then then - - display attribute state is set if possible. Otherwise the mode is not applied. - - - - 4. If the display attribute state is being set then just update the arguments to that for any - - apply/remove. - - - -} -data DisplayAttrSeq - = EnterExitSeq [CapExpression] - | SetState DisplayAttrState - -data DisplayAttrState = DisplayAttrState - { apply_standout :: Bool - , apply_underline :: Bool - , apply_reverse_video :: Bool - , apply_blink :: Bool - , apply_dim :: Bool - , apply_bold :: Bool - } - -sgr_args_for_state :: DisplayAttrState -> [CapParam] -sgr_args_for_state attr_state = map (\b -> if b then 1 else 0) - [ apply_standout attr_state - , apply_underline attr_state - , apply_reverse_video attr_state - , apply_blink attr_state - , apply_dim attr_state - , apply_bold attr_state - , False -- invis - , False -- protect - , False -- alt char set - ] - -req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq -req_display_cap_seq_for caps s diffs - -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap - -- then either the state needs to be set or the attribute change ignored. - = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of - -- If all the diffs have an enter-exit cap then just use those - ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs - -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out - -- all unsupported diffs and just apply the rest - ( True, False ) -> EnterExitSeq $ map enter_exit_cap - $ filter (not . no_enter_exit_cap) diffs - -- if not all the diffs have an enter-exit can and there is a set state cap then just use - -- the set state cap. - ( True, True ) -> SetState $ state_for_style s - where - no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps - no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps - no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps - no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps - no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps - no_enter_exit_cap RemoveReverseVideo = True - no_enter_exit_cap ApplyBlink = True - no_enter_exit_cap RemoveBlink = True - no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps - no_enter_exit_cap RemoveDim = True - no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps - no_enter_exit_cap RemoveBold = True - enter_exit_cap ApplyStandout = fromJust $ enter_standout caps - enter_exit_cap RemoveStandout = fromJust $ exit_standout caps - enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps - enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps - enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps - enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps - enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps - enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one." - -state_for_style :: Style -> DisplayAttrState -state_for_style s = DisplayAttrState - { apply_standout = is_style_set standout - , apply_underline = is_style_set underline - , apply_reverse_video = is_style_set reverse_video - , apply_blink = is_style_set blink - , apply_dim = is_style_set dim - , apply_bold = is_style_set bold - } - where is_style_set = has_style s - -style_to_apply_seq :: Style -> [StyleStateChange] -style_to_apply_seq s = concat - [ apply_if_required ApplyStandout standout - , apply_if_required ApplyUnderline underline - , apply_if_required ApplyReverseVideo reverse_video - , apply_if_required ApplyBlink blink - , apply_if_required ApplyDim dim - , apply_if_required ApplyBlink bold - ] - where - apply_if_required ap flag - = if 0 == ( flag .&. s ) - then [] - else [ ap ] - diff --git a/src/Graphics/Vty/Terminal/XTermColor.hs b/src/Graphics/Vty/Terminal/XTermColor.hs deleted file mode 100644 --- a/src/Graphics/Vty/Terminal/XTermColor.hs +++ /dev/null @@ -1,109 +0,0 @@ --- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -module Graphics.Vty.Terminal.XTermColor ( terminal_instance - ) - where - -import Graphics.Vty.Terminal.Generic -import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased - -import Control.Applicative -import Control.Monad.Trans - -import qualified Data.String.UTF8 as UTF8 - -import System.IO - --- | An xterm color based terminal is some variant paired with a standard TerminfoBased terminal --- interface. --- --- For the most part, xterm terminals just use the TerminfoBased implementation. -data XTermColor = XTermColor - { xterm_variant :: String - , super_term :: TerminalHandle - } - --- | Initialize the display to UTF-8. -terminal_instance :: ( Applicative m, MonadIO m ) => String -> m XTermColor -terminal_instance variant = do - -- If the terminal variant is xterm-color use xterm instead since, more often than not, - -- xterm-color is broken. - let variant' = if variant == "xterm-color" then "xterm" else variant - flushed_put set_utf8_char_set - t <- TerminfoBased.terminal_instance variant' >>= new_terminal_handle - return $ XTermColor variant' t - --- | Output immediately followed by a flush. --- --- \todo move out of this module. -flushed_put :: MonadIO m => String -> m () -flushed_put str = do - liftIO $ hPutStr stdout str - liftIO $ hFlush stdout - --- | These sequences set xterm based terminals to UTF-8 output. --- --- \todo I don't know of a terminfo cap that is equivalent to this. -set_utf8_char_set, set_default_char_set :: String -set_utf8_char_set = "\ESC%G" -set_default_char_set = "\ESC%@" - -instance Terminal XTermColor where - terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor" - - release_terminal t = do - flushed_put set_default_char_set - release_terminal $ super_term t - - reserve_display t = reserve_display (super_term t) - - release_display t = release_display (super_term t) - - display_terminal_instance t b c = do - d <- display_context (super_term t) b - return $ c (DisplayContext d) - - display_bounds t = display_bounds (super_term t) - - output_byte_buffer t = output_byte_buffer (super_term t) - - output_handle t = output_handle (super_term t) - -data DisplayContext = DisplayContext - { super_display :: DisplayHandle - } - -instance DisplayTerminal DisplayContext where - context_region d = context_region (super_display d) - - context_color_count d = context_color_count (super_display d) - - move_cursor_required_bytes d = move_cursor_required_bytes (super_display d) - serialize_move_cursor d = serialize_move_cursor (super_display d) - - show_cursor_required_bytes d = show_cursor_required_bytes (super_display d) - serialize_show_cursor d = serialize_show_cursor (super_display d) - - hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d) - serialize_hide_cursor d = serialize_hide_cursor (super_display d) - - attr_required_bytes d = attr_required_bytes (super_display d) - serialize_set_attr d = serialize_set_attr (super_display d) - - default_attr_required_bytes d = default_attr_required_bytes (super_display d) - serialize_default_attr d = serialize_default_attr (super_display d) - - -- | I think xterm is broken: Reseting the background color as the first bytes serialized on a - -- new line does not effect the background color xterm uses to clear the line. Which is used - -- *after* the next newline. - inline_hack d = do - let t = case super_display d of - DisplayHandle _ t_ _ -> t_ - let s_utf8 = UTF8.fromString "\ESC[K" - liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8) - ( serialize_utf8_text s_utf8 ) - diff --git a/src/Graphics/Vty/UnicodeWidthTable/IO.hs b/src/Graphics/Vty/UnicodeWidthTable/IO.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/UnicodeWidthTable/IO.hs @@ -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 diff --git a/src/Graphics/Vty/UnicodeWidthTable/Install.hs b/src/Graphics/Vty/UnicodeWidthTable/Install.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/UnicodeWidthTable/Install.hs @@ -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 () diff --git a/src/Graphics/Vty/UnicodeWidthTable/Main.hs b/src/Graphics/Vty/UnicodeWidthTable/Main.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/UnicodeWidthTable/Main.hs @@ -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 "" (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 diff --git a/src/Graphics/Vty/UnicodeWidthTable/Query.hs b/src/Graphics/Vty/UnicodeWidthTable/Query.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/UnicodeWidthTable/Query.hs @@ -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 + } diff --git a/src/Graphics/Vty/UnicodeWidthTable/Types.hs b/src/Graphics/Vty/UnicodeWidthTable/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/UnicodeWidthTable/Types.hs @@ -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) diff --git a/test/Verify.hs b/test/Verify.hs deleted file mode 100644 --- a/test/Verify.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module Verify ( module Verify - , module Test.QuickCheck - , succeeded - , failed - , result - , monadicIO - , liftIO - , liftBool - , Test(..) - , Prop.Result(..) - ) - where - -import Distribution.TestSuite hiding ( Result(..) ) -import qualified Distribution.TestSuite as TS - -import Test.QuickCheck hiding ( Result(..) ) -import qualified Test.QuickCheck as QC -import Test.QuickCheck.Property hiding ( Result(..) ) -import qualified Test.QuickCheck.Property as Prop -import Test.QuickCheck.Monadic ( monadicIO ) - -import qualified Codec.Binary.UTF8.String as UTF8 - -import Control.Monad.State.Strict - -import Data.IORef -import Data.Word - -import Numeric ( showHex ) - -import System.IO -import System.Random - -verify :: Testable t => String -> t -> Test -verify test_name p = Test $ TestInstance - { name = test_name - , run = do - qc_result <- quickCheckResult p - case qc_result of - QC.Success {..} -> return $ Finished TS.Pass - _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message" - , tags = [] - , options = [] - , setOption = \_ _ -> Left "no options supported" - } - -data SingleColumnChar = SingleColumnChar Char - deriving (Show, Eq) - -instance Arbitrary SingleColumnChar where - arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E] - -data DoubleColumnChar = DoubleColumnChar Char - deriving (Eq) - -instance Show DoubleColumnChar where - show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c] - -instance Arbitrary DoubleColumnChar where - arbitrary = elements $ map DoubleColumnChar $ - [ toEnum 0x3040 .. toEnum 0x3098 ] - ++ [ toEnum 0x309B .. toEnum 0xA4CF ] - -liftIOResult :: Testable prop => IO prop -> Property -liftIOResult = morallyDubiousIOProperty - -#if __GLASGOW_HASKELL__ <= 701 -instance Random Word where - random g = - let (i :: Int, g') = random g - in (toEnum i, g') - randomR (l,h) g = - let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g - in (toEnum i, g') -#endif - diff --git a/test/Verify/Data/Terminfo/Parse.hs b/test/Verify/Data/Terminfo/Parse.hs deleted file mode 100644 --- a/test/Verify/Data/Terminfo/Parse.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse - , module Data.Terminfo.Parse - ) - where - -import Data.Terminfo.Parse -import Data.Terminfo.Eval -import Verify - -import Data.Word - -import Numeric - -instance Show CapExpression where - show c - = "CapExpression { " ++ show (cap_ops c) ++ " }" - ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]" - ++ " <= " ++ show (source_string c) - -hex_dump :: [Word8] -> String -hex_dump bytes = foldr (\b s -> showHex b s) "" bytes - -data NonParamCapString = NonParamCapString String - deriving Show - -instance Arbitrary NonParamCapString where - arbitrary - = ( do - s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%') - return $ NonParamCapString s - ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) - -data LiteralPercentCap = LiteralPercentCap String [Word8] - deriving ( Show ) - -instance Arbitrary LiteralPercentCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - (s', bytes) <- insert_escape_op "%" [toEnum $ fromEnum '%'] s - return $ LiteralPercentCap s' bytes - ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) - -data IncFirstTwoCap = IncFirstTwoCap String [Word8] - deriving ( Show ) - -instance Arbitrary IncFirstTwoCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - (s', bytes) <- insert_escape_op "i" [] s - return $ IncFirstTwoCap s' bytes - ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) - -data PushParamCap = PushParamCap String Word [Word8] - deriving ( Show ) - -instance Arbitrary PushParamCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - n :: Word <- choose (1,9) >>= return . toEnum - (s', bytes) <- insert_escape_op ("p" ++ show n) [] s - return $ PushParamCap s' n bytes - ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) - -data DecPrintCap = DecPrintCap String Word [Word8] - deriving ( Show ) - -instance Arbitrary DecPrintCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - n :: Word <- choose (1,9) >>= return . toEnum - (s', bytes) <- insert_escape_op ("p" ++ show n ++ "%d") [] s - return $ DecPrintCap s' n bytes - ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) - -insert_escape_op op_str repl_bytes s = do - insert_points <- listOf1 $ elements [0 .. length s - 1] - let s' = f s ('%' : op_str) - remaining_bytes = f (map (toEnum . fromEnum) s) repl_bytes - f in_vs out_v = concat [ vs - | vi <- zip in_vs [0 .. length s - 1] - , let vs = fst vi : ( if snd vi `elem` insert_points - then out_v - else [] - ) - ] - return (s', remaining_bytes) - -is_bytes_op :: CapOp -> Bool -is_bytes_op (Bytes {}) = True --- is_bytes_op _ = False - -bytes_for_range cap offset c - = take (fromEnum c) - $ drop (fromEnum offset) - $ ( map ( toEnum . fromEnum ) $! source_string cap ) - -collect_bytes :: CapExpression -> [Word8] -collect_bytes e = concat [ bytes - | Bytes offset c _ <- cap_ops e - , let bytes = bytes_for_range e offset c - ] - - -verify_bytes_equal :: [Word8] -> [Word8] -> Result -verify_bytes_equal out_bytes expected_bytes - = if out_bytes == expected_bytes - then succeeded - else failed - { reason = "out_bytes [" - ++ hex_dump out_bytes - ++ "] /= expected_bytes [" - ++ hex_dump expected_bytes - ++ "]" - } - diff --git a/test/Verify/Graphics/Vty/Attributes.hs b/test/Verify/Graphics/Vty/Attributes.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Attributes.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes - , module Graphics.Vty.Attributes - ) - where - -import Graphics.Vty.Attributes -import Verify - -import Data.List ( delete ) - --- Limit the possible attributes to just a few for now. -possible_attr_mods :: [ AttrOp ] -possible_attr_mods = - [ set_bold_op - , id_op - ] - -instance Arbitrary Attr where - arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr - -data DiffAttr = DiffAttr Attr Attr - -instance Arbitrary DiffAttr where - arbitrary = do - op0 <- elements possible_attr_mods - let possible_attr_mods' = delete op0 possible_attr_mods - op1 <- elements possible_attr_mods' - return $ DiffAttr (apply_op op0 def_attr) (apply_op op1 def_attr) - -data AttrOp = AttrOp String (Attr -> Attr) - -instance Eq AttrOp where - AttrOp n0 _ == AttrOp n1 _ = n0 == n1 - -set_bold_op = AttrOp "set_bold" (flip with_style bold) -id_op = AttrOp "id" id - -apply_op :: AttrOp -> Attr -> Attr -apply_op (AttrOp _ f) a = f a - diff --git a/test/Verify/Graphics/Vty/DisplayRegion.hs b/test/Verify/Graphics/Vty/DisplayRegion.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/DisplayRegion.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion - , module Graphics.Vty.DisplayRegion - , DebugWindow(..) - ) - where - -import Graphics.Vty.Debug -import Graphics.Vty.DisplayRegion - -import Verify - -import Data.Word - -data EmptyWindow = EmptyWindow DebugWindow - -instance Arbitrary EmptyWindow where - arbitrary = return $ EmptyWindow (DebugWindow (0 :: Word) (0 :: Word)) - -instance Show EmptyWindow where - show (EmptyWindow _) = "EmptyWindow" - -instance Arbitrary DebugWindow where - arbitrary = do - w <- choose (1,1024) - h <- choose (1,1024) - return $ DebugWindow w h - diff --git a/test/Verify/Graphics/Vty/Image.hs b/test/Verify/Graphics/Vty/Image.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Image.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DisambiguateRecordFields #-} -module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image - , module Graphics.Vty.Image - ) - where - -import Verify.Graphics.Vty.Attributes -import Graphics.Vty.Debug.Image -import Graphics.Vty.Image - -import Verify - -import Data.Word - -data UnitImage = UnitImage Char Image - -instance Arbitrary UnitImage where - arbitrary = do - SingleColumnChar c <- arbitrary - return $ UnitImage c (char def_attr c) - -instance Show UnitImage where - show (UnitImage c _) = "UnitImage " ++ show c - -data DefaultImage = DefaultImage Image ImageConstructLog - -instance Show DefaultImage where - show (DefaultImage i image_log) - = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i) ++ " " ++ show image_log - -instance Arbitrary DefaultImage where - arbitrary = do - i <- return $ char def_attr 'X' -- elements forward_image_ops >>= return . (\op -> op empty_image) - return $ DefaultImage i [] - -data SingleRowSingleAttrImage - = SingleRowSingleAttrImage - { expected_attr :: Attr - , expected_columns :: Word - , row_image :: Image - } - -instance Show SingleRowSingleAttrImage where - show (SingleRowSingleAttrImage attr columns image) - = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )" - -instance Arbitrary SingleRowSingleAttrImage where - arbitrary = do - -- The text must contain at least one character. Otherwise the image simplifies to the - -- IdImage which has a height of 0. If this is to represent a single row then the height - -- must be 1 - single_column_row_text <- resize 128 (listOf1 arbitrary) - attr <- arbitrary - return $ SingleRowSingleAttrImage - attr - ( fromIntegral $ length single_column_row_text ) - ( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] ) - -data SingleRowTwoAttrImage - = SingleRowTwoAttrImage - { part_0 :: SingleRowSingleAttrImage - , part_1 :: SingleRowSingleAttrImage - , join_image :: Image - } deriving Show - -instance Arbitrary SingleRowTwoAttrImage where - arbitrary = do - p0 <- arbitrary - p1 <- arbitrary - return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1) - -data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack - { stack_image :: Image - , stack_source_images :: [SingleRowSingleAttrImage] - , stack_width :: Word - , stack_height :: Word - } - deriving Show - -instance Arbitrary SingleAttrSingleSpanStack where - arbitrary = do - image_list <- resize 128 (listOf1 arbitrary) - let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ] - return $ SingleAttrSingleSpanStack - image - image_list - ( maximum $ map expected_columns image_list ) - ( toEnum $ length image_list ) - diff --git a/test/Verify/Graphics/Vty/Picture.hs b/test/Verify/Graphics/Vty/Picture.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Picture.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture - , module Graphics.Vty.Picture - ) - where - -import Graphics.Vty.Picture -import Graphics.Vty.Debug - -import Verify.Graphics.Vty.Attributes -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.DisplayRegion - -import Verify - -data DefaultPic = DefaultPic - { default_pic :: Picture - , default_win :: DebugWindow - , default_construct_log :: ImageConstructLog - } - -instance Show DefaultPic where - show (DefaultPic pic win image_log) - = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n\t" ++ show image_log ++ "\n" - -instance Arbitrary DefaultPic where - arbitrary = do - DefaultImage image image_construct_events <- arbitrary - let win = DebugWindow (image_width image) (image_height image) - return $ DefaultPic (pic_for_image image) - win - image_construct_events - -data PicWithBGAttr = PicWithBGAttr - { with_attr_pic :: Picture - , with_attr_win :: DebugWindow - , with_attr_construct_log :: ImageConstructLog - , with_attr_specified_attr :: Attr - } deriving ( Show ) - -instance Arbitrary PicWithBGAttr where - arbitrary = do - DefaultImage image image_construct_events <- arbitrary - let win = DebugWindow (image_width image) (image_height image) - attr <- arbitrary - return $ PicWithBGAttr (pic_for_image image) - win - image_construct_events - attr - diff --git a/test/Verify/Graphics/Vty/Span.hs b/test/Verify/Graphics/Vty/Span.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Span.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span - , module Graphics.Vty.Span - ) - where - -import Graphics.Vty.Debug -import Graphics.Vty.Span - -import Verify.Graphics.Vty.Picture - -import Data.Word - -import Verify - -is_attr_span_op :: SpanOp -> Bool -is_attr_span_op AttributeChange {} = True -is_attr_span_op _ = False - -verify_all_spans_have_width i spans w - = case all_spans_have_width spans w of - True -> succeeded - False -> failed { reason = "Not all spans contained operations defining exactly " - ++ show w - ++ " columns of output -\n" - ++ show i - ++ "\n->\n" - ++ show spans - } - diff --git a/test/VerifyAttributeOps.hs b/test/VerifyAttributeOps.hs deleted file mode 100644 --- a/test/VerifyAttributeOps.hs +++ /dev/null @@ -1,9 +0,0 @@ -module VerifyAttributeOps where - -import Verify.Graphics.Vty.Attributes - -import Verify - -tests :: IO [Test] -tests = return [] - diff --git a/test/VerifyDisplayAttributes.hs b/test/VerifyDisplayAttributes.hs deleted file mode 100644 --- a/test/VerifyDisplayAttributes.hs +++ /dev/null @@ -1,9 +0,0 @@ -module VerifyDisplayAttributes where - -import Verify.Graphics.Vty.DisplayAttributes -import Verify.Graphics.Vty.Attributes - -import Verify - -tests :: IO [Test] -tests = return [] diff --git a/test/VerifyEmptyImageProps.hs b/test/VerifyEmptyImageProps.hs deleted file mode 100644 --- a/test/VerifyEmptyImageProps.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module VerifyEmptyImageProps where - -import Verify - --- should be exported by Graphics.Vty.Picture -import Graphics.Vty.Picture ( Image, empty_image ) - -tests :: IO [Test] -tests = do - -- should provide an image type. - let _ :: Image = empty_image - return [] - diff --git a/test/VerifyEvalTerminfoCaps.hs b/test/VerifyEvalTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyEvalTerminfoCaps.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyEvalTerminfoCaps where - -import Data.Marshalling - -import Data.Terminfo.Eval -import Data.Terminfo.Parse -import Control.DeepSeq - -import qualified System.Console.Terminfo as Terminfo - -import Verify - -import Control.Applicative ( (<$>) ) -import Control.Exception ( try, SomeException(..) ) - -import Control.Monad ( mapM_, forM, forM_ ) - -import Data.Maybe ( fromJust ) -import Data.Word - -import Numeric - --- A list of terminals that ubuntu includes a terminfo cap file for. --- Assuming that is a good place to start. -terminals_of_interest = - [ "wsvt25" - , "wsvt25m" - , "vt52" - , "vt100" - , "vt220" - , "vt102" - , "xterm-r5" - , "xterm-xfree86" - , "xterm-r6" - , "xterm-256color" - , "xterm-vt220" - , "xterm-debian" - , "xterm-mono" - , "xterm-color" - , "xterm" - , "mach" - , "mach-bold" - , "mach-color" - , "linux" - , "ansi" - , "hurd" - , "Eterm" - , "pcansi" - , "screen-256color" - , "screen-bce" - , "screen-s" - , "screen-w" - , "screen" - , "screen-256color-bce" - , "sun" - , "rxvt" - , "rxvt-unicode" - , "rxvt-basic" - , "cygwin" - , "cons25" - , "dumb" - ] - --- If a terminal defines one of the caps then it's expected to be parsable. -caps_of_interest = - [ "cup" - , "sc" - , "rc" - , "setf" - , "setb" - , "setaf" - , "setab" - , "op" - , "cnorm" - , "civis" - , "smcup" - , "rmcup" - , "clear" - , "hpa" - , "vpa" - , "sgr" - , "sgr0" - ] - -from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) - -tests :: IO [Test] -tests = do - eval_buffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-) - fmap concat $ forM terminals_of_interest $ \term_name -> do - putStrLn $ "adding tests for terminal: " ++ term_name - mti <- try $ Terminfo.setupTerm term_name - case mti of - Left (_e :: SomeException) - -> return [] - Right ti -> do - fmap concat $ forM caps_of_interest $ \cap_name -> do - case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of - Just cap_def -> do - putStrLn $ "\tadding test for cap: " ++ cap_name - let test_name = term_name ++ "(" ++ cap_name ++ ")" - parse_result <- parse_cap_expression cap_def - case parse_result of - Left error -> return [ verify test_name ( failed { reason = "parse error " ++ show error } ) ] - Right !cap_expr -> return [ verify test_name ( verify_eval_cap eval_buffer cap_expr ) ] - Nothing -> do - return [] - -{-# NOINLINE verify_eval_cap #-} -verify_eval_cap :: Ptr Word8 -> CapExpression -> Int -> Property -verify_eval_cap eval_buffer expr !junk_int = do - forAll (vector 9) $ \input_values -> - let !byte_count = cap_expression_required_bytes expr input_values - in liftIOResult $ do - let start_ptr :: Ptr Word8 = eval_buffer - forM_ [0..100] $ \i -> serialize_cap_expression expr input_values start_ptr - end_ptr <- serialize_cap_expression expr input_values start_ptr - case end_ptr `minusPtr` start_ptr of - count | count < 0 -> - return $ failed { reason = "End pointer before start pointer." } - | toEnum count > byte_count -> - return $ failed { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byte_count) - } - | otherwise -> - return succeeded - diff --git a/test/VerifyImageOps.hs b/test/VerifyImageOps.hs deleted file mode 100644 --- a/test/VerifyImageOps.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module VerifyImageOps where - -import Graphics.Vty.Attributes -import Verify.Graphics.Vty.Image - -import Verify - -import Data.Word - -two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool -two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) = - image_width (char def_attr c1 <|> char def_attr c2) == 2 - -many_sw_horiz_concat :: [SingleColumnChar] -> Bool -many_sw_horiz_concat cs = - let chars = [ char | SingleColumnChar char <- cs ] - l = fromIntegral $ length cs - in image_width ( horiz_cat $ map (char def_attr) chars ) == l - -two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool -two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) = - image_height (char def_attr c1 <-> char def_attr c2) == 2 - -horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool -horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = - (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 - == - char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2) - -two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool -two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = - image_width (char def_attr c1 <|> char def_attr c2) == 4 - -many_dw_horiz_concat :: [DoubleColumnChar] -> Bool -many_dw_horiz_concat cs = - let chars = [ char | DoubleColumnChar char <- cs ] - l = fromIntegral $ length cs - in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2 - -two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool -two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = - image_height (char def_attr c1 <-> char def_attr c2) == 2 - -horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool -horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = - (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 - == - char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2) - -vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool -vert_contat_single_row (NonEmpty stack) = - let expected_height :: Word = fromIntegral $ length stack - stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ] - in image_height stack_image == expected_height - -disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) = - let expected_height :: Word = fromIntegral $ max (length stack_0) (length stack_1) - stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] - stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] - in image_height (stack_image_0 <|> stack_image_1) == expected_height - - -disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) = - let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] - stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] - image = stack_image_0 <|> stack_image_1 - expected_height = image_height image - in case image of - HorizJoin {} -> ( expected_height == (image_height $ part_left image) ) - && - ( expected_height == (image_height $ part_right image) ) - _ -> True - -disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) = - let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images) - stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] - stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] - stack_0_image = vert_cat stack_0_images - stack_1_image = vert_cat stack_1_images - image = stack_0_image <-> stack_1_image - in image_width image == expected_width - -disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) = - let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images) - stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] - stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] - stack_0_image = vert_cat stack_0_images - stack_1_image = vert_cat stack_1_images - image = stack_0_image <-> stack_1_image - in case image of - VertJoin {} -> ( expected_width == (image_width $ part_top image) ) - && - ( expected_width == (image_width $ part_bottom image) ) - _ -> True - -tests :: IO [Test] -tests = return - [ verify "two_sw_horiz_concat" two_sw_horiz_concat - , verify "many_sw_horiz_concat" many_sw_horiz_concat - , verify "two_sw_vert_concat" two_sw_vert_concat - , verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc - , verify "many_dw_horiz_concat" many_dw_horiz_concat - , verify "two_dw_horiz_concat" two_dw_horiz_concat - , verify "two_dw_vert_concat" two_dw_vert_concat - , verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc - , verify "single row vert concats to correct height" vert_contat_single_row - , verify "disjoint_height_horiz_join" disjoint_height_horiz_join - , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill - , verify "disjoint_width_vert_join" disjoint_width_vert_join - , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill - ] - diff --git a/test/VerifyImageTrans.hs b/test/VerifyImageTrans.hs deleted file mode 100644 --- a/test/VerifyImageTrans.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module VerifyImageTrans where - -import Verify.Graphics.Vty.Image - -import Verify - -import Data.Word - -is_horiz_text_of_columns :: Image -> Word -> Bool -is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w -is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w -is_horiz_text_of_columns _image _expected_w = False - -verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool -verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) = - is_horiz_text_of_columns image char_count - -verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool -verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0) - (SingleRowSingleAttrImage attr1 char_count1 _image1) - i - ) - | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1) - | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1) - -tests :: IO [Test] -tests = return - [ verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies - , verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies - ] - diff --git a/test/VerifyInline.hs b/test/VerifyInline.hs deleted file mode 100644 --- a/test/VerifyInline.hs +++ /dev/null @@ -1,23 +0,0 @@ -module VerifyInline where - -import Graphics.Vty.Inline -import Graphics.Vty.Terminal - -import Verify - -import Distribution.TestSuite - -tests :: IO [Test] -tests = return - [ Test $ TestInstance - { name = "verify vty inline" - , run = do - t <- terminal_handle - put_attr_change t $ default_all - return $ Finished Pass - , tags = [] - , options = [] - , setOption = \_ _ -> Left "no options supported" - } - ] - diff --git a/test/VerifyMockTerminal.hs b/test/VerifyMockTerminal.hs deleted file mode 100644 --- a/test/VerifyMockTerminal.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module VerifyMockTerminal where - -import Verify.Graphics.Vty.DisplayRegion -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Span -import Graphics.Vty.Terminal -import Graphics.Vty.Terminal.Debug - -import Graphics.Vty.Debug - -import Verify - -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.String.UTF8 as UTF8 - -import System.IO - -unit_image_unit_bounds :: UnitImage -> Property -unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do - t <- terminal_instance (DisplayRegion 1 1) - d <- display_bounds t >>= display_context t - let pic = pic_for_image i - output_picture d pic - return succeeded - -unit_image_arb_bounds :: UnitImage -> DebugWindow -> Property -unit_image_arb_bounds (UnitImage _ i) (DebugWindow w h) = liftIOResult $ do - t <- terminal_instance (DisplayRegion w h) - d <- display_bounds t >>= display_context t - let pic = pic_for_image i - output_picture d pic - return succeeded - -single_T_row :: DebugWindow -> Property -single_T_row (DebugWindow w h) = liftIOResult $ do - t <- terminal_instance (DisplayRegion w h) - d <- display_bounds t >>= display_context t - -- create an image that contains just the character T repeated for a single row - let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T') - pic = (pic_for_image i) { pic_background = Background 'B' def_attr } - output_picture d pic - out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep - -- The UTF8 string that represents the output bytes a single line containing the T string: - let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T' - -- Followed by h - 1 lines of a change to the background attribute and then the background - -- character - ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B') - expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected - if out_bytes /= expected_bytes - then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } - else return succeeded - -many_T_rows :: DebugWindow -> Property -many_T_rows (DebugWindow w h) = liftIOResult $ do - t <- terminal_instance (DisplayRegion w h) - d <- display_bounds t >>= display_context t - -- create an image that contains the character 'T' repeated for all the rows - let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T') - pic = (pic_for_image i) { pic_background = Background 'B' def_attr } - output_picture d pic - out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w 'T's - let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') - expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected - if out_bytes /= expected_bytes - then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } - else return succeeded - -many_T_rows_cropped_width :: DebugWindow -> Property -many_T_rows_cropped_width (DebugWindow w h) = liftIOResult $ do - t <- terminal_instance (DisplayRegion w h) - d <- display_bounds t >>= display_context t - -- create an image that contains the character 'T' repeated for all the rows - let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T') - pic = (pic_for_image i) { pic_background = Background 'B' def_attr } - output_picture d pic - out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w 'T's - let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') - expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected - if out_bytes /= expected_bytes - then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } - else return succeeded - -many_T_rows_cropped_height :: DebugWindow -> Property -many_T_rows_cropped_height (DebugWindow w h) = liftIOResult $ do - t <- terminal_instance (DisplayRegion w h) - d <- display_bounds t >>= display_context t - -- create an image that contains the character 'T' repeated for all the rows - let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T') - pic = (pic_for_image i) { pic_background = Background 'B' def_attr } - output_picture d pic - out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w count 'T's - let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') - expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected - if out_bytes /= expected_bytes - then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } - else return succeeded - -tests :: IO [Test] -tests = return [ verify "unit_image_unit_bounds" unit_image_unit_bounds - , verify "unit_image_arb_bounds" unit_image_arb_bounds - , verify "single_T_row" single_T_row - , verify "many_T_rows" many_T_rows - , verify "many_T_rows_cropped_width" many_T_rows_cropped_width - , verify "many_T_rows_cropped_height" many_T_rows_cropped_height - ] - diff --git a/test/VerifyParseTerminfoCaps.hs b/test/VerifyParseTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyParseTerminfoCaps.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyParseTerminfoCaps where - -import Prelude hiding ( catch ) - -import qualified System.Console.Terminfo as Terminfo - -import Verify.Data.Terminfo.Parse -import Verify - -import Control.Applicative ( (<$>) ) -import Control.Exception ( try, SomeException(..) ) -import Control.Monad ( mapM_, forM, forM_ ) - -import Data.Maybe ( catMaybes, fromJust ) -import Data.Word - -import Numeric - --- A list of terminals that ubuntu includes a terminfo cap file for. --- Assuming that is a good place to start. -terminals_of_interest = - [ "wsvt25" - , "wsvt25m" - , "vt52" - , "vt100" - , "vt220" - , "vt102" - , "xterm-r5" - , "xterm-xfree86" - , "xterm-r6" - , "xterm-256color" - , "xterm-vt220" - , "xterm-debian" - , "xterm-mono" - , "xterm-color" - , "xterm" - , "mach" - , "mach-bold" - , "mach-color" - , "linux" - , "ansi" - , "hurd" - , "Eterm" - , "pcansi" - , "screen-256color" - , "screen-bce" - , "screen-s" - , "screen-w" - , "screen" - , "screen-256color-bce" - , "sun" - , "rxvt" - , "rxvt-unicode" - , "rxvt-basic" - , "cygwin" - , "cons25" - , "dumb" - ] - --- If a terminal defines one of the caps then it's expected to be parsable. -caps_of_interest = - [ "cup" - , "sc" - , "rc" - , "setf" - , "setb" - , "setaf" - , "setab" - , "op" - , "cnorm" - , "civis" - , "smcup" - , "rmcup" - , "clear" - , "hpa" - , "vpa" - , "sgr" - , "sgr0" - ] - -from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) - -tests :: IO [Test] -tests = do - parse_tests <- concat <$> forM terminals_of_interest ( \term_name -> do - putStrLn $ "testing parsing of caps for terminal: " ++ term_name - mti <- liftIO $ try $ Terminfo.setupTerm term_name - case mti of - Left (_e :: SomeException) - -> return [] - Right ti -> do - concat <$> forM caps_of_interest ( \cap_name -> do - liftIO $ putStrLn $ "\tparsing cap: " ++ cap_name - case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of - Just cap_def -> do - return [ verify ( "\tparse cap " ++ cap_name ++ " -> " ++ show cap_def ) - ( verify_parse_cap cap_def $ const (return succeeded) ) ] - Nothing -> do - return [] - ) - ) - -- The quickcheck tests - return $ [ verify "parse_non_paramaterized_caps" non_paramaterized_caps - , verify "parse cap string with literal %" literal_percent_caps - , verify "parse cap string with %i op" inc_first_two_caps - , verify "parse cap string with %pN op" push_param_caps - ] ++ parse_tests - -verify_parse_cap cap_string on_parse = liftIOResult $ do - parse_result <- parse_cap_expression cap_string - case parse_result of - Left error -> return $ failed { reason = "parse error " ++ show error } - Right e -> on_parse e - -non_paramaterized_caps (NonParamCapString cap) = do - verify_parse_cap cap $ \e -> - let expected_count :: Word8 = toEnum $ length cap - expected_bytes = map (toEnum . fromEnum) cap - out_bytes = bytes_for_range e 0 expected_count - in return $ verify_bytes_equal out_bytes expected_bytes - -literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do - verify_parse_cap cap_string $ \e -> - let expected_count :: Word8 = toEnum $ length expected_bytes - out_bytes = collect_bytes e - in return $ verify_bytes_equal out_bytes expected_bytes - -inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do - verify_parse_cap cap_string $ \e -> - let expected_count :: Word8 = toEnum $ length expected_bytes - out_bytes = collect_bytes e - in return $ verify_bytes_equal out_bytes expected_bytes - -push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do - verify_parse_cap cap_string $ \e -> - let expected_count :: Word8 = toEnum $ length expected_bytes - out_bytes = collect_bytes e - out_param_count = param_count e - in return $ if out_param_count == expected_param_count - then verify_bytes_equal out_bytes expected_bytes - else failed { reason = "out param count /= expected param count" } - -dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do - verify_parse_cap cap_string $ \e -> - let expected_count :: Word8 = toEnum $ length expected_bytes - out_bytes = collect_bytes e - out_param_count = param_count e - in return $ if out_param_count == expected_param_count - then verify_bytes_equal out_bytes expected_bytes - else failed { reason = "out param count /= expected param count" } - -print_cap ti cap_name = do - putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name) - -print_expression ti cap_name = do - parse_result <- parse_cap_expression $ from_capname ti cap_name - putStrLn $ cap_name ++ ": " ++ show parse_result - diff --git a/test/VerifyPictureOps.hs b/test/VerifyPictureOps.hs deleted file mode 100644 --- a/test/VerifyPictureOps.hs +++ /dev/null @@ -1,8 +0,0 @@ -module VerifyPictureOps where - -import Graphics.Vty.Picture ( translate ) - -import Verify - -tests :: IO [Test] -tests = return [] diff --git a/test/VerifyPictureToSpan.hs b/test/VerifyPictureToSpan.hs deleted file mode 100644 --- a/test/VerifyPictureToSpan.hs +++ /dev/null @@ -1,10 +0,0 @@ -module VerifyPictureToSpan where - -import Graphics.Vty.Picture -import Graphics.Vty.Span -import Graphics.Vty.PictureToSpans - -import Verify - -tests :: IO [Test] -tests = return [] diff --git a/test/VerifySpanOps.hs b/test/VerifySpanOps.hs deleted file mode 100644 --- a/test/VerifySpanOps.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifySpanOps where - -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Span -import Verify.Graphics.Vty.DisplayRegion - -import Graphics.Vty.Debug - -import Verify - -import qualified Data.Vector as Vector - -unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool -unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) = - let p = pic_for_image i - spans = spans_for_pic p (region_for_window w) - in span_ops_columns spans == 0 && span_ops_rows spans == 0 - -unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool -unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) = - let p = pic_for_image i - spans = spans_for_pic p (region_for_window w) - in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 ) - -horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool -horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = - let p = pic_for_image i - spans = spans_for_pic p (region_for_window w) - in span_ops_columns spans == 0 && span_ops_rows spans == 0 - -horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool -horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = - let p = pic_for_image i - spans = spans_for_pic p (region_for_window w) - in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 ) - -horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result -horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = - let p = pic_for_image i - w = DebugWindow c 1 - spans = spans_for_pic p (region_for_window w) - in verify_all_spans_have_width i spans c - -horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool -horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = - let p = pic_for_image i - w = DebugWindow c 1 - spans = spans_for_pic p (region_for_window w) - in span_ops_effected_rows spans == 1 - -horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result -horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = - let p = pic_for_image i - lesser_width = c `div` 2 - w = DebugWindow lesser_width 1 - spans = spans_for_pic p (region_for_window w) - in verify_all_spans_have_width i spans lesser_width - -single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result -single_attr_single_span_stack_cropped_0 stack = - let p = pic_for_image (stack_image stack) - w = DebugWindow (stack_width stack `div` 2) (stack_height stack) - spans = spans_for_pic p (region_for_window w) - in verify_all_spans_have_width (stack_image stack) spans (stack_width stack `div` 2) - -single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool -single_attr_single_span_stack_cropped_1 stack = - let p = pic_for_image (stack_image stack) - expected_row_count = stack_height stack `div` 2 - w = DebugWindow (stack_width stack) expected_row_count - spans = spans_for_pic p (region_for_window w) - actual_row_count = span_ops_effected_rows spans - in expected_row_count == actual_row_count - -single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result -single_attr_single_span_stack_cropped_2 stack_0 stack_1 = - let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1) - w = DebugWindow (stack_width stack_0) (image_height (pic_image p)) - spans = spans_for_pic p (region_for_window w) - in verify_all_spans_have_width (pic_image p) spans (stack_width stack_0) - -single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool -single_attr_single_span_stack_cropped_3 stack_0 stack_1 = - let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1) - w = DebugWindow (image_width (pic_image p)) expected_row_count - spans = spans_for_pic p (region_for_window w) - expected_row_count = image_height (pic_image p) `div` 2 - actual_row_count = span_ops_effected_rows spans - in expected_row_count == actual_row_count - -single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result -single_attr_single_span_stack_cropped_4 stack_0 stack_1 = - let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1) - w = DebugWindow expected_width (image_height (pic_image p)) - spans = spans_for_pic p (region_for_window w) - expected_width = image_width (pic_image p) `div` 2 - in verify_all_spans_have_width (pic_image p) spans expected_width - -single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool -single_attr_single_span_stack_cropped_5 stack_0 stack_1 = - let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1) - w = DebugWindow (image_width (pic_image p)) (stack_height stack_0) - spans = spans_for_pic p (region_for_window w) - expected_row_count = stack_height stack_0 - actual_row_count = span_ops_effected_rows spans - in expected_row_count == actual_row_count - -horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result -horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = - let p = pic_for_image i - -- SingleRowSingleAttrImage always has width >= 1 - greater_width = c * 2 - w = DebugWindow greater_width 1 - spans = spans_for_pic p (region_for_window w) - in verify_all_spans_have_width i spans greater_width - -arb_image_is_cropped :: DefaultImage -> DebugWindow -> Bool -arb_image_is_cropped (DefaultImage image _) win@(DebugWindow w h) = - let pic = pic_for_image image - spans = spans_for_pic pic (region_for_window win) - in ( span_ops_effected_rows spans == h ) && ( all_spans_have_width spans w ) - -span_ops_actually_fill_rows :: DefaultPic -> Bool -span_ops_actually_fill_rows (DefaultPic pic win _) = - let spans = spans_for_pic pic (region_for_window win) - expected_row_count = region_height (region_for_window win) - actual_row_count = span_ops_effected_rows spans - in expected_row_count == actual_row_count - -span_ops_actually_fill_columns :: DefaultPic -> Bool -span_ops_actually_fill_columns (DefaultPic pic win _) = - let spans = spans_for_pic pic (region_for_window win) - expected_column_count = region_width (region_for_window win) - in all_spans_have_width spans expected_column_count - -first_span_op_sets_attr :: DefaultPic -> Bool -first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } = - let spans = spans_for_pic pic (region_for_window win) - in all ( is_attr_span_op . Vector.head ) ( Vector.toList $ display_ops spans ) - -single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result -single_attr_single_span_stack_op_coverage stack = - let p = pic_for_image (stack_image stack) - w = DebugWindow (stack_width stack) (stack_height stack) - spans = spans_for_pic p (region_for_window w) - in verify_all_spans_have_width (stack_image stack) spans (stack_width stack) - -tests :: IO [Test] -tests = return - [ verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0 - , verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1 - , verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0 - , verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1 - , verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0 - , verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1 - , verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0 - , verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0 - , verify "arbitrary image is padded or cropped" arb_image_is_cropped - , verify "The span ops actually define content for all the rows in the output region" span_ops_actually_fill_rows - , verify "The span ops actually define content for all the columns in the output region" span_ops_actually_fill_columns - , verify "first span op is always to set the text attribute" first_span_op_sets_attr - , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" - single_attr_single_span_stack_op_coverage - , verify "a single attr text span is cropped when window size < size of stack image [width]" - single_attr_single_span_stack_cropped_0 - , verify "a single attr text span is cropped when window size < size of stack image [height]" - single_attr_single_span_stack_cropped_1 - , verify "single attr text span <|> single attr text span cropped. [width]" - single_attr_single_span_stack_cropped_2 - , verify "single attr text span <|> single attr text span cropped. [height]" - single_attr_single_span_stack_cropped_3 - , verify "single attr text span <-> single attr text span cropped. [width]" - single_attr_single_span_stack_cropped_4 - , verify "single attr text span <-> single attr text span cropped. [height]" - single_attr_single_span_stack_cropped_5 - ] - diff --git a/test/VerifyUtf8Width.hs b/test/VerifyUtf8Width.hs deleted file mode 100644 --- a/test/VerifyUtf8Width.hs +++ /dev/null @@ -1,18 +0,0 @@ -module VerifyUtf8Width where -import Verify - -import Graphics.Vty.Attributes -import Graphics.Vty.Picture - -sw_is_1_column :: SingleColumnChar -> Bool -sw_is_1_column (SingleColumnChar c) = image_width (char def_attr c) == 1 - -dw_is_2_column :: DoubleColumnChar -> Bool -dw_is_2_column (DoubleColumnChar c) = image_width (char def_attr c) == 2 - -tests :: IO [Test] -tests = return - [ verify "sw_is_1_column" sw_is_1_column - , verify "dw_is_2_column" dw_is_2_column - ] - diff --git a/test/interactive_terminal_test.hs b/test/interactive_terminal_test.hs deleted file mode 100644 --- a/test/interactive_terminal_test.hs +++ /dev/null @@ -1,954 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Main where - -import Graphics.Vty -import Graphics.Vty.Attributes -import Graphics.Vty.Inline -import Graphics.Vty.Picture -import Graphics.Vty.Terminal -import Graphics.Vty.DisplayRegion - -import Control.Exception -import Control.Monad - -import Data.List ( lookup ) -import Data.Maybe ( isJust, fromJust ) -import Data.Monoid -import Data.String.QQ -import Data.Word - -import Foreign.Marshal.Array - -import qualified System.Environment as Env - -import System.IO ( hFlush, hPutStr, hPutBuf, stdout ) - -main = do - print_intro - -output_file_path = "test_results.list" - -print_intro = do - putStr $ [s| -This is an interactive verification program for the terminal input and output -support of the VTY library. This will ask a series of questions about what you -see on screen. The goal is to verify that VTY's output and input support -performs as expected with your terminal. - -This program produces a file named - |] ++ output_file_path ++ [s| -in the current directory that contains the results for each test assertion. This -can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve -support for your terminal. No personal information is contained in the report. - -Each test follows, more or less, the following format: - 0. A description of the test is printed which will include a detailed - description of what VTY is going to try and what the expected results are. - Press return to move on. - 1. The program will produce some output or ask for you to press a key. - 2. You will then be asked to confirm if the behavior matched the provided - description. Just pressing enter implies the default response that - everything was as expected. - -All the tests assume the following about the terminal display: - 0. The terminal display will not be resized during a test and is at least 80 - characters in width. - 1. The terminal display is using a monospaced font for both single width and - double width characters. - 2. A double width character is displayed with exactly twice the width of a - single column character. This may require adjusting the font used by the - terminal. At least, that is the case using xterm. - 3. Fonts are installed, and usable by the terminal, that define glyphs for - a good range of the unicode characters. Each test involving unicode display - describes the expected appearance of each glyph. - -Thanks for the help! :-D -To exit the test early enter "q" anytime at the following menu screen. - -If any test failed then please post an issue to - https://github.com/coreyoconnor/vty/issues -with the test_results.list file pasted into the issue. The issue summary can -mention the specific tests that failed or just say "interactive terminal test -failure". -|] - wait_for_return - results <- do_test_menu 1 - env_attributes <- mapM ( \env_name -> Control.Exception.catch - ( Env.getEnv env_name >>= return . (,) env_name ) - ( \ (_ :: SomeException) -> return (env_name, "") ) - ) - [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ] - t <- terminal_handle - let results_txt = show env_attributes ++ "\n" - ++ terminal_ID t ++ "\n" - ++ show results ++ "\n" - release_terminal t - writeFile output_file_path results_txt - -wait_for_return = do - putStr "\n(press return to continue)" - hFlush stdout - getLine - -test_menu :: [(String, Test)] -test_menu = zip (map show [1..]) all_tests - -do_test_menu :: Int -> IO [(String, Bool)] -do_test_menu next_ID - | next_ID > length all_tests = do - putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com" - return [] - | otherwise = do - display_test_menu - putStrLn $ "Press return to start with #" ++ show next_ID ++ "." - putStrLn "Enter a test number to perform only that test." - putStrLn "q (or control-C) to quit." - putStr "> " - hFlush stdout - s <- getLine >>= return . filter (/= '\n') - case s of - "q" -> return mempty - "" -> do - r <- run_test $ show next_ID - rs <- do_test_menu ( next_ID + 1 ) - return $ r : rs - i | isJust ( lookup i test_menu ) -> do - r <- run_test i - rs <- do_test_menu ( read i + 1 ) - return $ r : rs - where - display_test_menu - = mapM_ display_test_menu' test_menu - display_test_menu' ( i, t ) - = putStrLn $ ( if i == show next_ID - then "> " - else " " - ) ++ i ++ ". " ++ test_name t - -run_test :: String -> IO (String, Bool) -run_test i = do - let t = fromJust $ lookup i test_menu - print_summary t - wait_for_return - test_action t - r <- confirm_results t - return (test_ID t, r) - -default_success_confirm_results = do - putStr "\n" - putStr "[Y/n] " - hFlush stdout - r <- getLine - case r of - "" -> return True - "y" -> return True - "Y" -> return True - "n" -> return False - -data Test = Test - { test_name :: String - , test_ID :: String - , test_action :: IO () - , print_summary :: IO () - , confirm_results :: IO Bool - } - -all_tests - = [ reserve_output_test - , display_bounds_test_0 - , display_bounds_test_1 - , display_bounds_test_2 - , display_bounds_test_3 - , unicode_single_width_0 - , unicode_single_width_1 - , unicode_double_width_0 - , unicode_double_width_1 - , attributes_test_0 - , attributes_test_1 - , attributes_test_2 - , attributes_test_3 - , attributes_test_4 - , attributes_test_5 - , inline_test_0 - , inline_test_1 - , inline_test_2 - , cursor_hide_test_0 - ] - -reserve_output_test = Test - { test_name = "Initialize and reserve terminal output then restore previous state." - , test_ID = "reserve_output_test" - , test_action = do - t <- terminal_handle - reserve_display t - putStrLn "Line 1" - putStrLn "Line 2" - putStrLn "Line 3" - putStrLn "Line 4 (press return)" - hFlush stdout - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. Four lines of text should be visible. - 1. The cursor should be visible and at the start of the fifth line. - -After return is pressed for the second time this test then: - * The screen containing the test summary should be restored; - * The cursor is visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -display_bounds_test_0 = Test - { test_name = "Verify display bounds are correct test 0: Using spaces." - , test_ID = "display_bounds_test_0" - , test_action = do - t <- terminal_handle - reserve_display t - DisplayRegion w h <- display_bounds t - let row_0 = replicate (fromEnum w) 'X' ++ "\n" - row_h = replicate (fromEnum w - 1) 'X' - row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n" - image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h - putStr image - hFlush stdout - getLine - release_display t - release_terminal t - return () - , print_summary = display_bounds_test_summary True - , confirm_results = generic_output_match_confirm - } - -display_bounds_test_1 = Test - { test_name = "Verify display bounds are correct test 0: Using cursor movement." - , test_ID = "display_bounds_test_1" - , test_action = do - t <- terminal_handle - reserve_display t - DisplayRegion w h <- display_bounds t - set_cursor_pos t 0 0 - let row_0 = replicate (fromEnum w) 'X' ++ "\n" - putStr row_0 - forM_ [1 .. h - 2] $ \y -> do - set_cursor_pos t 0 y - putStr "X" - hFlush stdout - set_cursor_pos t (w - 1) y - putStr "X" - hFlush stdout - set_cursor_pos t 0 (h - 1) - let row_h = replicate (fromEnum w - 1) 'X' - putStr row_h - hFlush stdout - getLine - release_display t - release_terminal t - return () - , print_summary = display_bounds_test_summary True - , confirm_results = generic_output_match_confirm - } - -display_bounds_test_2 = Test - { test_name = "Verify display bounds are correct test 0: Using Image ops." - , test_ID = "display_bounds_test_2" - , test_action = do - t <- terminal_handle - reserve_display t - bounds@(DisplayRegion w h) <- display_bounds t - let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X') - middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row - middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X') - end_row = first_row - image = first_row <-> middle_rows <-> end_row - pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) } - d <- display_context t bounds - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = display_bounds_test_summary True - , confirm_results = generic_output_match_confirm - } - -display_bounds_test_3 = Test - { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos." - , test_ID = "display_bounds_test_3" - , test_action = do - t <- terminal_handle - reserve_display t - DisplayRegion w h <- display_bounds t - hide_cursor t - set_cursor_pos t 0 0 - let row_0 = replicate (fromEnum w) 'X' - putStrLn row_0 - forM_ [1 .. h - 2] $ \y -> do - set_cursor_pos t 0 y - putStr "X" - hFlush stdout - set_cursor_pos t (w - 1) y - putStr "X" - hFlush stdout - set_cursor_pos t 0 (h - 1) - let row_h = row_0 - putStr row_h - hFlush stdout - getLine - show_cursor t - release_display t - release_terminal t - return () - , print_summary = display_bounds_test_summary False - , confirm_results = generic_output_match_confirm - } - -display_bounds_test_summary has_cursor = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. -|] - if has_cursor - then putStr " 1. The cursor will be visible." - else putStr " 1. The cursor will NOT be visible." - putStr [s| - 2. The border of the display will be outlined in Xs. - So if - and | represented the edge of the terminal window: - |-------------| - |XXXXXXXXXXXXX| - |X X||] - - if has_cursor - then putStr $ [s| - |XXXXXXXXXXXXC| |] - else putStr $ [s| - |XXXXXXXXXXXXX| |] - - putStr $ [s| - |-------------| - - ( Where C is the final position of the cursor. There may be an X drawn - under the cursor. ) - 3. The display will remain in this state until return is pressed again. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - -generic_output_match_confirm = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - --- Explicitely definethe bytes that encode each example text. --- This avoids any issues with how the compiler represents string literals. --- --- This document is UTF-8 encoded so the UTF-8 string is still included for --- reference --- --- It's assumed the compiler will at least not barf on UTF-8 encoded text in --- comments ;-) --- --- txt_0 = ↑↑↓↓←→←→BA - -utf8_txt_0 :: [[Word8]] -utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ] - , [ 0xe2 , 0x86 , 0x91 ] - , [ 0xe2 , 0x86 , 0x93 ] - , [ 0xe2 , 0x86 , 0x93 ] - , [ 0xe2 , 0x86 , 0x90 ] - , [ 0xe2 , 0x86 , 0x92 ] - , [ 0xe2 , 0x86 , 0x90 ] - , [ 0xe2 , 0x86 , 0x92 ] - , [ 0x42 ] - , [ 0x41 ] - ] - -iso_10646_txt_0 :: String -iso_10646_txt_0 = map toEnum - [ 8593 - , 8593 - , 8595 - , 8595 - , 8592 - , 8594 - , 8592 - , 8594 - , 66 - , 65 - ] - -unicode_single_width_0 = Test - { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)" - , test_ID = "unicode_single_width_0" - , test_action = do - t <- terminal_handle - reserve_display t - hide_cursor t - withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout) - hPutStr stdout "\n" - hPutStr stdout "0123456789\n" - hFlush stdout - getLine - release_display t - release_terminal t - return () - , print_summary = unicode_single_width_summary - , confirm_results = generic_output_match_confirm - } - -unicode_single_width_1 = Test - { test_name = "Verify terminal can display unicode single-width characters. (Image ops)" - , test_ID = "unicode_single_width_1" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = line_0 <-> line_1 - line_0 = iso_10646_string def_attr iso_10646_txt_0 - line_1 = string def_attr "0123456789" - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = unicode_single_width_summary - , confirm_results = generic_output_match_confirm - } - -unicode_single_width_summary = putStr [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. Two horizontal lines of text will be displayed: - a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph - will occupy one column of space. The order and appearance of the glyphs - will be: - | column | appearance | - ========================== - | 0 | up arrow | - | 1 | up arrow | - | 2 | down arrow | - | 3 | down arrow | - | 4 | left arrow | - | 5 | right arrow | - | 6 | left arrow | - | 7 | right arrow | - | 8 | B | - | 9 | A | - ( see: http://en.wikipedia.org/wiki/Arrow_(symbol) ) - b. The second will be: 0123456789. - -Verify: - * The far right extent of the glyphs on both lines are equal; - * The glyphs are as described. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - --- The second example is a unicode string containing double-width glyphs --- 你好吗 -utf8_txt_1 :: [[Word8]] -utf8_txt_1 = [ [0xe4,0xbd,0xa0] - , [0xe5,0xa5,0xbd] - , [0xe5,0x90,0x97] - ] - -iso_10646_txt_1 :: String -iso_10646_txt_1 = map toEnum [20320,22909,21527] - -unicode_double_width_0 = Test - { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)" - , test_ID = "unicode_double_width_0" - , test_action = do - t <- terminal_handle - reserve_display t - hide_cursor t - withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout) - hPutStr stdout "\n" - hPutStr stdout "012345\n" - hFlush stdout - getLine - release_display t - release_terminal t - return () - , print_summary = unicode_double_width_summary - , confirm_results = generic_output_match_confirm - } - -unicode_double_width_1 = Test - { test_name = "Verify terminal can display unicode double-width characters. (Image ops)" - , test_ID = "unicode_double_width_1" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = line_0 <-> line_1 - line_0 = iso_10646_string def_attr iso_10646_txt_1 - line_1 = string def_attr "012345" - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = unicode_double_width_summary - , confirm_results = generic_output_match_confirm - } - -unicode_double_width_summary = putStr [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. Two horizontal lines of text will be displayed: - a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph - will occupy two columns of space. The order and appearance of the glyphs - will be: - | column | appearance | - ====================================== - | 0 | first half of ni3 | - | 1 | second half of ni3 | - | 2 | first half of hao3 | - | 3 | second half of hao3 | - | 4 | first half of ma | - | 5 | second half of ma | - b. The second will be: 012345. - -Verify: - * The far right extent of the glyphs on both lines are equal; - * The glyphs are as described. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - -all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ] - [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ] - -all_bright_colors - = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ] - [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ] - -attributes_test_0 = Test - { test_name = "Character attributes: foreground colors." - , test_ID = "attributes_test_0" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = border <|> column_0 <|> border <|> column_1 <|> border - column_0 = vert_cat $ map line_with_color all_colors - border = vert_cat $ replicate (length all_colors) $ string def_attr " | " - column_1 = vert_cat $ map (string def_attr . snd) all_colors - line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. 9 lines of text in two columns will be drawn. The first column will be a - name of a standard color (for an 8 color terminal) rendered in that color. - For instance, one line will be the word "magenta" and that word should be - rendered in the magenta color. The second column will be the name of a - standard color rendered with the default attributes. - -Verify: - * In the first column: The foreground color matches the named color. - * The second column: All text is rendered with the default attributes. - * The vertical bars used in each line to mark the border of a column are - lined up. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -attributes_test_1 = Test - { test_name = "Character attributes: background colors." - , test_ID = "attributes_test_1" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = border <|> column_0 <|> border <|> column_1 <|> border - column_0 = vert_cat $ map line_with_color all_colors - border = vert_cat $ replicate (length all_colors) $ string def_attr " | " - column_1 = vert_cat $ map (string def_attr . snd) all_colors - line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. 9 lines of text in two columns will be drawn. The first column will - contain be a name of a standard color for an 8 color terminal rendered with - the default foreground color with a background the named color. For - instance, one line will contain be the word "magenta" and the word should - be rendered in the default foreground color over a magenta background. The - second column will be the name of a standard color rendered with the default - attributes. - -Verify: - * The first column: The background color matches the named color. - * The second column: All text is rendered with the default attributes. - * The vertical bars used in each line to mark the border of a column are - lined up. - -Note: I haven't decided if, in this case, the background color should extend to -fills added for alignment. Right now the selected background color is only -applied to the background where the word is actually rendered. Since each word -is not of the same length VTY adds background fills to make the width of each -row effectively the same. These added fills are all currently rendered with the -default background pattern. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -attributes_test_2 = Test - { test_name = "Character attributes: Vivid foreground colors." - , test_ID = "attributes_test_2" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = horiz_cat [border, column_0, border, column_1, border, column_2, border] - border = vert_cat $ replicate (length all_colors) $ string def_attr " | " - column_0 = vert_cat $ map line_with_color_0 all_colors - column_1 = vert_cat $ map line_with_color_1 all_bright_colors - column_2 = vert_cat $ map (string def_attr . snd) all_colors - line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name - line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. 9 lines of text in three columns will be drawn: - a. The first column will be a name of a standard color (for an 8 color - terminal) rendered with that color as the foreground color. - b. The next column will be also be the name of a standard color rendered - with that color as the foreground color but the shade used should be - more vivid than the shade used in the first column. - c. The final column will be the name of a color rendered with the - default attributes. - -For instance, one line will be the word "magenta" and that word should be -rendered in the magenta color. - -I'm not actually sure exactly what "vivid" means in this context. For xterm the -vivid colors are brighter. - -Verify: - * The first column: The foreground color matches the named color. - * The second column: The foreground color matches the named color but is - more vivid than the color used in the first column. - * The third column: All text is rendered with the default attributes. - * The vertical bars used in each line to mark the border of a column are - lined up. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -attributes_test_3 = Test - { test_name = "Character attributes: Vivid background colors." - , test_ID = "attributes_test_3" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = horiz_cat [border, column_0, border, column_1, border, column_2, border] - border = vert_cat $ replicate (length all_colors) $ string def_attr " | " - column_0 = vert_cat $ map line_with_color_0 all_colors - column_1 = vert_cat $ map line_with_color_1 all_bright_colors - column_2 = vert_cat $ map (string def_attr . snd) all_colors - line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name - line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. 9 lines of text in three columns will be drawn: - a. The first column will contain be a name of a standard color for an 8 - color terminal rendered with the default foreground color with a - background the named color. - b. The first column will contain be a name of a standard color for an 8 - color terminal rendered with the default foreground color with the - background a vivid version of the named color. - c. The third column will be the name of a standard color rendered with - the default attributes. - -For instance, one line will contain be the word "magenta" and the word should -be rendered in the default foreground color over a magenta background. - -I'm not actually sure exactly what "vivid" means in this context. For xterm the -vivid colors are brighter. - -Verify: - * The first column: The background color matches the named color. - * The second column: The background color matches the named color and is - more vivid than the color used in the first column. - * The third column column: All text is rendered with the default attributes. - * The vertical bars used in each line to mark the border of a column are - lined up. - -Note: I haven't decided if, in this case, the background color should extend to -fills added for alignment. Right now the selected background color is only -applied to the background where the word is actually rendered. Since each word -is not of the same length VTY adds background fills to make the width of each -row effectively the same. These added fills are all currently rendered with the -default background pattern. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -attr_combos = - [ ( "default", id ) - , ( "bold", flip with_style bold ) - , ( "blink", flip with_style blink ) - , ( "underline", flip with_style underline ) - , ( "bold + blink", flip with_style (bold + blink) ) - , ( "bold + underline", flip with_style (bold + underline) ) - , ( "underline + blink", flip with_style (underline + blink) ) - , ( "bold + blink + underline", flip with_style (bold + blink + underline) ) - ] - -attributes_test_4 = Test - { test_name = "Character attributes: Bold; Blink; Underline." - , test_ID = "attributes_test_4" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = horiz_cat [border, column_0, border, column_1, border] - border = vert_cat $ replicate (length attr_combos) $ string def_attr " | " - column_0 = vert_cat $ map line_with_attrs attr_combos - column_1 = vert_cat $ map (string def_attr . fst) attr_combos - line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. 8 rows of text in two columns. - The rows will contain the following text: - default - bold - blink - underline - bold + blink - bold + underline - underline + blink - bold + blink + underline - The first column will be rendered with the described attributes. The second - column will be rendered with the default attributes. - -Verify: - * The vertical bars used in each line to mark the border of a column are - lined up. - * The text in the first column is rendered as described. - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -attributes_test_5 = Test - { test_name = "Character attributes: 240 color palette" - , test_ID = "attributes_test_5" - , test_action = do - t <- terminal_handle - reserve_display t - let pic = pic_for_image image - image = vert_cat $ map horiz_cat $ split_color_images color_images - color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239] - split_color_images [] = [] - split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is)) - d <- display_bounds t >>= display_context t - output_picture d pic - getLine - release_display t - release_terminal t - return () - , print_summary = do - putStr $ [s| -Once return is pressed: - 0. The screen will be cleared. - 1. The cursor will be hidden. - 2. A 20 character wide and 12 row high block of color squares. This should look like a palette - of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it... - -Verify: - -After return is pressed for the second time: - 0. The screen containing the test summary should be restored. - 1. The cursor should be visible. -|] - , confirm_results = do - putStr $ [s| -Did the test output match the description? -|] - default_success_confirm_results - } - -inline_test_0 = Test - { test_name = "Verify styled output can be performed without clearing the screen." - , test_ID = "inline_test_0" - , test_action = do - t <- terminal_handle - putStrLn "line 1." - put_attr_change t $ back_color red >> apply_style underline - putStrLn "line 2." - put_attr_change t $ default_all - putStrLn "line 3." - release_terminal t - return () - , print_summary = putStr $ [s| -lines are in order. -The second line "line 2" should have a red background and the text underline. -The third line "line 3" should be drawn in the same style as the first line. -|] - - , confirm_results = generic_output_match_confirm - } - -inline_test_1 = Test - { test_name = "Verify styled output can be performed without clearing the screen." - , test_ID = "inline_test_1" - , test_action = do - t <- terminal_handle - putStr "Not styled. " - put_attr_change t $ back_color red >> apply_style underline - putStr " Styled! " - put_attr_change t $ default_all - putStrLn "Not styled." - release_terminal t - return () - , print_summary = putStr $ [s| -|] - - , confirm_results = generic_output_match_confirm - } - -inline_test_2 = Test - { test_name = "Verify styled output can be performed without clearing the screen." - , test_ID = "inline_test_1" - , test_action = do - t <- terminal_handle - putStr "Not styled. " - put_attr_change t $ back_color red >> apply_style underline - putStr " Styled! " - put_attr_change t $ default_all - putStr "Not styled.\n" - release_terminal t - return () - , print_summary = putStr $ [s| -|] - , confirm_results = generic_output_match_confirm - } - -cursor_hide_test_0 :: Test -cursor_hide_test_0 = Test - { test_name = "Verify the cursor is hid and re-shown. issue #7" - , test_ID = "cursor_hide_test_0" - , test_action = do - vty <- mkVty - show_cursor $ terminal vty - set_cursor_pos (terminal vty) 5 5 - next_event vty - hide_cursor $ terminal vty - next_event vty - shutdown vty - return () - , print_summary = putStr $ [s| - 1. verify the cursor is displayed. - 2. press enter - 3. verify the cursor is hid. - 4. press enter. - 5. the display should return to the state before the test. -|] - , confirm_results = generic_output_match_confirm - } - diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,640 +1,86 @@ name: vty -version: 4.7.5 +version: 6.6 license: BSD3 license-file: LICENSE author: AUTHORS -maintainer: Corey O'Connor (coreyoconnor@gmail.com) -homepage: https://github.com/coreyoconnor/vty +maintainer: Jonathan Daugherty (cygnus@foobox.com) +homepage: https://github.com/jtdaugherty/vty category: User Interfaces synopsis: A simple terminal UI library description: - vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, have no - confusing corner cases, and good support for common terminal types. - . - Included in the source distribution is a program test/interactive_terminal_test.hs that - demonstrates the various features. - . - If your terminal is not behaving as expected the results of the vty-interactive-terminal-test - executable should be sent to the Vty maintainter to aid in debugging the issue. - . - Notable infelicities: Sometimes poor efficiency; Assumes UTF-8 character encoding support by the - terminal; - . - Project is hosted on github.com: https://github.com/coreyoconnor/vty + vty is terminal GUI library in the niche of ncurses. It is intended to + be easy to use and to provide good support for common terminal types. . - git clone git://github.com/coreyoconnor/vty.git + See the example programs in the @vty-crossplatform@ package examples + on how to use the library. . © 2006-2007 Stefan O'Rear; BSD3 license. . © Corey O'Connor; BSD3 license. --- the test suites require >= 1.17.0 -cabal-version: >= 1.14.0 -build-type: Simple -data-files: README, - TODO, + . + © Jonathan Daugherty; BSD3 license. +cabal-version: 1.18 +build-type: Simple +extra-doc-files: README.md, AUTHORS, - CHANGELOG, + CHANGELOG.md, LICENSE +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, + GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.4, GHC==9.10.1, + GHC==9.12.1 +source-repository head + type: git + location: https://github.com/jtdaugherty/vty.git + library default-language: Haskell2010 - build-depends: base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - - exposed-modules: Graphics.Vty - Graphics.Vty.Attributes - Graphics.Vty.DisplayRegion - Graphics.Vty.Image - Graphics.Vty.Inline - Graphics.Vty.LLInput - Graphics.Vty.Picture - Graphics.Vty.Terminal - Codec.Binary.UTF8.Width - - other-modules: Data.Marshalling - Data.Terminfo.Parse - Data.Terminfo.Eval - Graphics.Vty.Attributes.Color - Graphics.Vty.Attributes.Color240 - Graphics.Vty.DisplayAttributes - Graphics.Vty.Span - Graphics.Vty.Terminal.Generic - Graphics.Vty.Terminal.MacOSX - Graphics.Vty.Terminal.XTermColor - Graphics.Vty.Terminal.TerminfoBased - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - include-dirs: cbits - hs-source-dirs: src - - ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 - - ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 - - cc-options: -O2 - -test-suite verify-attribute-ops - default-language: Haskell2010 - type: detailed-0.9 - hs-source-dirs: src test - test-module: VerifyAttributeOps - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, + ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10 + ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 + build-depends: base >= 4.8 && < 5, + blaze-builder >= 0.3.3.2 && < 0.5, bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-using-mock-terminal - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test + deepseq >= 1.1 && < 1.6, + microlens < 0.6, + microlens-mtl, + mtl >= 1.1.1.0 && < 2.4, + stm, + text >= 0.11.3, + utf8-string >= 0.3.1 && < 1.1, + vector >= 0.7, + binary, + parsec, + filepath, + directory - test-module: VerifyMockTerminal + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.16, + fail - other-modules: Graphics.Vty + exposed-modules: Graphics.Text.Width + Graphics.Vty Graphics.Vty.Attributes - Graphics.Vty.DisplayAttributes - Graphics.Vty.DisplayRegion - Graphics.Vty.Image - Graphics.Vty.Picture - Graphics.Vty.Span - Graphics.Vty.Terminal - Graphics.Vty.Terminal.Generic - Graphics.Vty.Terminal.Debug + Graphics.Vty.Attributes.Color + Graphics.Vty.Attributes.Color240 + Graphics.Vty.Config Graphics.Vty.Debug - Graphics.Vty.Debug.Image - Codec.Binary.UTF8.Width - Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.DisplayRegion - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-display-attributes - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyDisplayAttributes - - other-modules: Graphics.Vty - Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes - Graphics.Vty.DisplayRegion - Graphics.Vty.Image - Graphics.Vty.Picture - Graphics.Vty.Span - Graphics.Vty.Terminal - Graphics.Vty.Terminal.Generic - Graphics.Vty.Terminal.Debug - Graphics.Vty.Debug - Graphics.Vty.Debug.Image - Codec.Binary.UTF8.Width - Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.DisplayRegion - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-empty-image-props - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyEmptyImageProps - - other-modules: Graphics.Vty.Picture - Verify - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-eval-terminfo-caps - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyEvalTerminfoCaps - - other-modules: Data.Terminfo.Parse - Data.Terminfo.Eval - Data.Marshalling - Codec.Binary.UTF8.Width - Verify - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-image-ops - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyImageOps - - other-modules: Graphics.Vty.Attributes - Graphics.Vty.DisplayAttributes - Graphics.Vty.DisplayRegion - Graphics.Vty.Image - Graphics.Vty.Picture - Graphics.Vty.Span - Graphics.Vty.Debug.Image - Codec.Binary.UTF8.Width - Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Image - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-image-trans - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyImageTrans - - other-modules: Graphics.Vty.Attributes - Graphics.Vty.Debug.Image - Graphics.Vty.Image - Codec.Binary.UTF8.Width - Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Image - - c-sources: cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-inline - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyInline - - other-modules: Codec.Binary.UTF8.Width - Data.Terminfo.Eval - Data.Terminfo.Parse - Data.Marshalling - Graphics.Vty.Attributes - Graphics.Vty.DisplayAttributes - Graphics.Vty.DisplayRegion + Graphics.Vty.Error Graphics.Vty.Image + Graphics.Vty.Image.Internal Graphics.Vty.Inline - Graphics.Vty.Span - Graphics.Vty.Terminal - Graphics.Vty.Terminal.Generic - Graphics.Vty.Terminal.MacOSX - Graphics.Vty.Terminal.TerminfoBased - Graphics.Vty.Terminal.XTermColor - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-parse-terminfo-caps - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyParseTerminfoCaps - - other-modules: Data.Terminfo.Parse - Verify - Verify.Data.Terminfo.Parse - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-picture-ops - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyPictureOps - - other-modules: Graphics.Vty.Picture - Verify - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-picture-to-span - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyPictureToSpan - - other-modules: Graphics.Vty - Graphics.Vty.Attributes - Graphics.Vty.DisplayAttributes - Graphics.Vty.DisplayRegion - Graphics.Vty.Image - Graphics.Vty.Picture - Graphics.Vty.Span - Graphics.Vty.Terminal - Graphics.Vty.Terminal.Generic - Graphics.Vty.Terminal.Debug - Graphics.Vty.Debug - Graphics.Vty.Debug.Image - Codec.Binary.UTF8.Width - Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.DisplayRegion - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-span-ops - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifySpanOps - - other-modules: Graphics.Vty - Graphics.Vty.Attributes - Graphics.Vty.DisplayAttributes - Graphics.Vty.DisplayRegion - Graphics.Vty.Image + Graphics.Vty.Input + Graphics.Vty.Input.Events + Graphics.Vty.Output + Graphics.Vty.Output.Mock Graphics.Vty.Picture + Graphics.Vty.PictureToSpans Graphics.Vty.Span - Graphics.Vty.Terminal - Graphics.Vty.Terminal.Generic - Graphics.Vty.Terminal.Debug - Graphics.Vty.Debug - Graphics.Vty.Debug.Image - Codec.Binary.UTF8.Width - Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.DisplayRegion - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -test-suite verify-utf8-width - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: src test - - test-module: VerifyUtf8Width - - other-modules: Codec.Binary.UTF8.Width - Graphics.Vty.Attributes - Graphics.Vty.Image - Verify - + Graphics.Vty.UnicodeWidthTable.IO + Graphics.Vty.UnicodeWidthTable.Install + Graphics.Vty.UnicodeWidthTable.Main + Graphics.Vty.UnicodeWidthTable.Query + Graphics.Vty.UnicodeWidthTable.Types c-sources: cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: Cabal == 1.17.*, - QuickCheck >= 2.4, - random == 1.0.*, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - -executable vty-interactive-terminal-test - main-is: interactive_terminal_test.hs - - default-language: Haskell2010 - - hs-source-dirs: src test - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - build-depends: base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.4, - ghc-prim, - mtl >= 1.1.1.0 && < 2.2, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, - string-qq, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7 - --- Bench.hs --- Bench2.hs --- BenchRenderChar.hs --- ControlTable.hs --- HereDoc.hs --- Test.hs --- Test2.hs --- Verify.hs --- Verify/Data/Terminfo/Parse.hs --- Verify/Graphics/Vty/Attributes.hs --- Verify/Graphics/Vty/DisplayRegion.hs --- Verify/Graphics/Vty/Image.hs --- Verify/Graphics/Vty/Picture.hs --- Verify/Graphics/Vty/Span.hs --- vty_inline_example.hs --- vty_issue_18.hs --- yi_issue_264.hs -