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 @@ -17,4 +19,4 @@ * Yoshikuni Jujo * Dmitry Ivanov -Plus others.. Check the git log for a full list. +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,260 +0,0 @@ -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.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/Demo.hs b/Demo.hs deleted file mode 100644 --- a/Demo.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Main where - -import Graphics.Vty - -import Control.Applicative hiding ((<|>)) -import Control.Arrow -import Control.Monad.RWS - -import Data.Default (def) -import Data.Sequence (Seq, (<|) ) -import qualified Data.Sequence as Seq -import Data.Foldable - -eventBufferSize = 1000 - -type App = RWST Vty () (Seq String) IO - -main = do - vty <- if True -- change to false for emacs-like input processing - then mkVty def - else mkVty (def { vmin = Just 2, vtime = Just 300 } ) - _ <- execRWST (vtyInteract False) vty Seq.empty - shutdown vty - -vtyInteract :: Bool -> App () -vtyInteract shouldExit = do - updateDisplay - unless shouldExit $ handleNextEvent >>= vtyInteract - -introText = vertCat $ map (string defAttr) - [ "this line is hidden by the top layer" - , "The vty demo program will echo the events generated by the pressed keys." - , "Below there is a 240 color box." - , "Followed by a description of the 16 color pallete." - , "If the 240 color box is not visible then the terminal" - , "claims 240 colors are not supported." - , "Try setting TERM to xterm-256color" - , "This text is on a lower layer than the event list." - , "Which means it'll be hidden soon." - , "Bye!" - , "Great Faith in the ¯\\_(ツ)_/¯" - , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" - ] - -colorbox_240 :: Image -colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages - where - colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239] - splitColorImages [] = [] - splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) - -colorbox_16 :: Image -colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border - where - column0 = vertCat $ map lineWithColor normal - column1 = vertCat $ map lineWithColor bright - border = vertCat $ replicate (length normal) $ string defAttr " | " - column2 = vertCat $ map (string defAttr . snd) normal - lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName - normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ] - [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ] - bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue - , brightMagenta, brightCyan, brightWhite ] - [ "bright black", "bright red", "bright green", "bright yellow" - , "bright blue", "bright magenta", "bright cyan", "bright white" ] - -updateDisplay :: App () -updateDisplay = do - let info = string (defAttr `withForeColor` black `withBackColor` green) - "Press ESC to exit. Events for keys below." - eventLog <- foldMap (string defAttr) <$> get - let pic = picForImage (info <-> eventLog) - `addToBottom` (introText <-> colorbox_240 <|> colorbox_16) - vty <- ask - liftIO $ update vty pic - -handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent - where - handleEvent e = do - modify $ (<|) (show e) >>> Seq.take eventBufferSize - return $ e == EvKey KEsc [] - 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.md b/README.md --- a/README.md +++ b/README.md @@ -1,112 +1,173 @@ -[![Build Status](https://travis-ci.org/coreyoconnor/vty.png)](https://travis-ci.org/coreyoconnor/vty) - -`vty` is a terminal interface library. - -This project is hosted on github.com: https://github.com/coreyoconnor/vty +[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty) -Install via `git` with: +`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. -``` -git clone git://github.com/coreyoconnor/vty.git -``` +`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: -Install via `cabal` with: +* [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 -``` -cabal install vty -``` +# How to use Vty -# Features +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. -* Support for a large number of terminals. vt100, ansi, hurd, linux, screen etc - etc. Anything with a sufficient terminfo entry. +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. -* Automatic handling of window resizes. +# Implementing support for a new platform -* If the terminal support UTF-8 then vty supports Unicode output. +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`. -* Handles multi-column glyphs. (Requires user to properly configure terminal.) +# Features -* Efficient output. Output buffering and terminal state changes are minimized. +* Provides an efficient output algorithm. Output buffering and terminal + state changes are minimized. -* Minimizes repaint area. Virtually eliminating the flicker problems that - plagues ncurses programs. +* Automatically handles window resizes. -* A pure, compositional interface for efficiently constructing display images. +* Minimizes repaint area, which virtually eliminates the flicker + problems that plague ncurses programs. -* Automatically decodes keyboard keys into (key,[modifier]) tuples. +* Provides a pure, compositional interface for efficiently constructing + display images. * Automatically supports refresh on Ctrl-L. -* Automatically supports timeout after for lone ESC. The timeout is - customizable. +* Provides extensible input and output interfaces. -* Interface is designed for easy compatible extension. +* Properly handles cleanup (but not due to signals). -* Supports ANSI graphics modes (SGR as defined in console_codes(4)) with a - type-safe interface. Gracefull fallback for terminals that do not support, or - partially support the standard ANSI graphics modes. +* Provides a comprehensive test suite. -* Properly handles cleanup, but not due to signals. +* Supports "normal" and "extended" (SGR) mouse modes as described at + http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking -* Comprehensive test suite. +* Supports bracketed paste mode as described at + http://cirw.in/blog/bracketed-paste -# Known Issues +* 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. -* Terminals have numerous quirks and bugs. vty picks what works best for the - author in ambigious, or buggy situations. +# Development Notes -* Signal handling of STOP, TERM and INT are non existent. +Vty uses threads internally, so programs made with Vty need to be +compiled with the threaded runtime using the GHC `-threaded` option. -* The character encoding of the terminal is assumed to be UTF-8 if - unicode is used. +# Multi-Column Character Support -* Terminfo is assumed to be correct unless there is an override configured. - Some terminals will not have correct special key support (shifted F10 etc). - See Config for customizing vty's behavior for a particular terminal. +Vty 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. -* Uses the TIOCGWINSZ ioctl to find the current window size, which appears to be - limited to Linux and BSD. +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. -# Platform Support +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. -## Posix Terminals +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. -Uses terminfo to determine terminal protocol. With some special rules to handle -some omissions from terminfo. +Saved width tables can then be loaded in one of two ways: -## Windows +* 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 -cygwin only. +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., -# Development Notes +``` +widthMap "xterm" "/path/to/map.dat" +``` -## Under NixOS +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. -After installing ncurses to user env. +The tables declared in the configuration file are only ever +automatically loaded when applications set up Vty by calling +`Graphics.Vty.mkVty`. -~~~ -LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib -LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build -LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test -~~~ +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. -## Coverage +# Contributing -As of last testing, profiling causes issues with coverage when enabled. To -evaluate coverage configure as follows: +If you decide to contribute, that's great! Here are some guidelines you +should consider to make submitting patches easier for all concerned: -~~~ -rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \ - --disable-library-profiling \ - --disable-executable-profiling -~~~ + - 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. -## Profiling +# Further Reading +Good sources of documentation for terminal programming are: -~~~ -rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \ - --enable-library-profiling \ - --enable-executable-profiling -~~~ +* 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(int fd) { - struct winsize w; - if (ioctl (fd, 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,13 +0,0 @@ -#include -#include -#include -#include - -void vty_set_term_timing(int fd, int vmin, int vtime) -{ - struct termios trm; - tcgetattr(fd, &trm); - trm.c_cc[VMIN] = vmin; - trm.c_cc[VTIME] = vtime; - tcsetattr(fd, TCSANOW, &trm); -} diff --git a/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs b/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs deleted file mode 100644 --- a/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyAttributeOps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs b/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs deleted file mode 100644 --- a/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyCropSpanGeneration ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs b/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs deleted file mode 100644 --- a/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyDisplayAttributes ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs b/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs deleted file mode 100644 --- a/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyEmptyImageProps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs b/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs deleted file mode 100644 --- a/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyEvalTerminfoCaps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs b/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs deleted file mode 100644 --- a/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyImageOps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs b/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs deleted file mode 100644 --- a/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyImageTrans ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs b/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs deleted file mode 100644 --- a/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyInline ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs b/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs deleted file mode 100644 --- a/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyLayersSpanGeneration ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs b/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs deleted file mode 100644 --- a/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyParseTerminfoCaps ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs b/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs deleted file mode 100644 --- a/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifySimpleSpanGeneration ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs b/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs deleted file mode 100644 --- a/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyOutput ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs b/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs deleted file mode 100644 --- a/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyUsingMockTerminal ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs b/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs deleted file mode 100644 --- a/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import VerifyUtf8Width ( tests ) -main :: IO () -main = stubMain tests diff --git a/src/Codec/Binary/UTF8/Debug.hs b/src/Codec/Binary/UTF8/Debug.hs deleted file mode 100644 --- a/src/Codec/Binary/UTF8/Debug.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- Copyright 2009 Corey O'Connor -module Codec.Binary.UTF8.Debug - where - -import Codec.Binary.UTF8.String ( encode ) - -import Data.Word - -import Numeric - --- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the --- corresponding UTF8 byte sequence -utf8FromIso :: [Int] -> [Word8] -utf8FromIso = encode . map toEnum - -ppUtf8 :: [Int] -> IO () -ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso - 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,140 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -{- Evaluates the paramaterized terminfo string capability with the given parameters. - - - -} -module Data.Terminfo.Eval (writeCapExpr) - where - -import Blaze.ByteString.Builder.Word -import Blaze.ByteString.Builder -import Data.Terminfo.Parse - -import Control.Monad.Identity -import Control.Monad.State.Strict -import Control.Monad.Writer - -import Data.Bits ((.|.), (.&.), xor) -import Data.List - -import qualified Data.Vector.Unboxed as Vector - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Word -#endif - --- | capability evaluator state -data EvalState = EvalState - { evalStack :: ![CapParam] - , evalExpression :: !CapExpression - , evalParams :: ![CapParam] - } - -type Eval a = StateT EvalState (Writer Write) a - -pop :: Eval CapParam -pop = do - s <- get - let v : stack' = evalStack s - s' = s { evalStack = stack' } - put s' - return v - -readParam :: Word -> Eval CapParam -readParam pn = do - !params <- get >>= return . evalParams - return $! genericIndex params pn - -push :: CapParam -> Eval () -push !v = do - s <- get - let s' = s { evalStack = v : evalStack s } - put s' - -applyParamOps :: CapExpression -> [CapParam] -> [CapParam] -applyParamOps cap params = foldl applyParamOp params (paramOps cap) - -applyParamOp :: [CapParam] -> ParamOp -> [CapParam] -applyParamOp params IncFirstTwo = map (+ 1) params - -writeCapExpr :: CapExpression -> [CapParam] -> Write -writeCapExpr cap params = - let params' = applyParamOps cap params - s0 = EvalState [] cap params' - in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0) - -writeCapOps :: CapOps -> Eval () -writeCapOps ops = mapM_ writeCapOp ops - -writeCapOp :: CapOp -> Eval () -writeCapOp (Bytes !offset !count) = do - !cap <- get >>= return . evalExpression - let bytes = Vector.take count $ Vector.drop offset (capBytes cap) - Vector.forM_ bytes $ tell.writeWord8 -writeCapOp DecOut = do - p <- pop - forM_ (show p) $ tell.writeWord8.toEnum.fromEnum -writeCapOp CharOut = do - pop >>= tell.writeWord8.toEnum.fromEnum -writeCapOp (PushParam pn) = do - readParam pn >>= push -writeCapOp (PushValue v) = do - push v -writeCapOp (Conditional expr parts) = do - writeCapOps expr - writeContitionalParts parts - where - writeContitionalParts [] = return () - writeContitionalParts ((trueOps, falseOps) : falseParts) = do - -- (man 5 terminfo) - -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the - -- stack, testing if it is nonzero (true). If it is zero (false), control - -- passes to the %e (else) part. - v <- pop - if v /= 0 - then writeCapOps trueOps - else do - writeCapOps falseOps - writeContitionalParts falseParts - -writeCapOp BitwiseOr = do - v0 <- pop - v1 <- pop - push $ v0 .|. v1 -writeCapOp BitwiseAnd = do - v0 <- pop - v1 <- pop - push $ v0 .&. v1 -writeCapOp BitwiseXOr = do - v1 <- pop - v0 <- pop - push $ v0 `xor` v1 -writeCapOp ArithPlus = do - v1 <- pop - v0 <- pop - push $ v0 + v1 -writeCapOp ArithMinus = do - v1 <- pop - v0 <- pop - push $ v0 - v1 -writeCapOp CompareEq = do - v1 <- pop - v0 <- pop - push $ if v0 == v1 then 1 else 0 -writeCapOp CompareLt = do - v1 <- pop - v0 <- pop - push $ if v0 < v1 then 1 else 0 -writeCapOp CompareGt = do - v1 <- pop - v0 <- pop - push $ if v0 > v1 then 1 else 0 - 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,348 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -funbox-strict-fields -O #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Data.Terminfo.Parse ( module Data.Terminfo.Parse - , Text.Parsec.ParseError - ) - where - -import Control.Monad ( liftM ) -import Control.DeepSeq - -import Data.Word -import qualified Data.Vector.Unboxed as Vector - -import Numeric (showHex) - -import Text.Parsec - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -data CapExpression = CapExpression - { capOps :: !CapOps - , capBytes :: !(Vector.Vector Word8) - , sourceString :: !String - , paramCount :: !Int - , paramOps :: !ParamOps - } deriving (Eq) - -instance Show CapExpression where - show c - = "CapExpression { " ++ show (capOps c) ++ " }" - ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]" - ++ " <= " ++ show (sourceString c) - where - hexDump :: [Word8] -> String - hexDump = foldr (\b s -> showHex b s) "" - -instance NFData CapExpression where - rnf (CapExpression ops !_bytes !str !c !pOps) - = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps - -type CapParam = Word - -type CapOps = [CapOp] -data CapOp = - Bytes !Int !Int -- offset count - | DecOut | CharOut - -- This stores a 0-based index to the parameter. However the operation that implies this op is - -- 1-based - | PushParam !Word | PushValue !Word - -- The conditional parts are the sequence of (%t expression, %e expression) pairs. - -- The %e expression may be NOP - | Conditional - { conditionalExpr :: !CapOps - , conditionalParts :: ![(CapOps, CapOps)] - } - | BitwiseOr | BitwiseXOr | BitwiseAnd - | ArithPlus | ArithMinus - | CompareEq | CompareLt | CompareGt - deriving (Show, Eq) - -instance NFData CapOp where - rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount - rnf (PushParam pn) = rnf pn - rnf (PushValue v) = rnf v - rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts - rnf BitwiseOr = () - rnf BitwiseXOr = () - rnf BitwiseAnd = () - rnf ArithPlus = () - rnf ArithMinus = () - rnf CompareEq = () - rnf CompareLt = () - rnf CompareGt = () - rnf DecOut = () - rnf CharOut = () - -type ParamOps = [ParamOp] -data ParamOp = - IncFirstTwo - deriving (Show, Eq) - -instance NFData ParamOp where - rnf IncFirstTwo = () - -parseCapExpression :: String -> Either ParseError CapExpression -parseCapExpression capString = - let v = runParser capExpressionParser - initialBuildState - "terminfo cap" - capString - in case v of - Left e -> Left e - Right buildResults -> Right $ constructCapExpression capString buildResults - -constructCapExpression :: [Char] -> BuildResults -> CapExpression -constructCapExpression capString buildResults = - let expr = CapExpression - { capOps = outCapOps buildResults - -- The cap bytes are the lower 8 bits of the input string's characters. - -- \todo Verify the input string actually contains an 8bit byte per character. - , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString - , sourceString = capString - , paramCount = outParamCount buildResults - , paramOps = outParamOps buildResults - } - in rnf expr `seq` expr - -type CapParser a = Parsec String BuildState a - -capExpressionParser :: CapParser BuildResults -capExpressionParser = do - rs <- many $ paramEscapeParser <|> bytesOpParser - return $ mconcat rs - -paramEscapeParser :: CapParser BuildResults -paramEscapeParser = do - _ <- char '%' - incOffset 1 - literalPercentParser <|> paramOpParser - -literalPercentParser :: CapParser BuildResults -literalPercentParser = do - _ <- char '%' - startOffset <- getState >>= return . nextOffset - incOffset 1 - return $ BuildResults 0 [Bytes startOffset 1] [] - -paramOpParser :: CapParser BuildResults -paramOpParser - = incrementOpParser - <|> pushOpParser - <|> decOutParser - <|> charOutParser - <|> conditionalOpParser - <|> bitwiseOpParser - <|> arithOpParser - <|> literalIntOpParser - <|> compareOpParser - <|> charConstParser - -incrementOpParser :: CapParser BuildResults -incrementOpParser = do - _ <- char 'i' - incOffset 1 - return $ BuildResults 0 [] [ IncFirstTwo ] - -pushOpParser :: CapParser BuildResults -pushOpParser = do - _ <- char 'p' - paramN <- digit >>= return . (\d -> read [d]) - incOffset 2 - return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] [] - -decOutParser :: CapParser BuildResults -decOutParser = do - _ <- char 'd' - incOffset 1 - return $ BuildResults 0 [ DecOut ] [] - -charOutParser :: CapParser BuildResults -charOutParser = do - _ <- char 'c' - incOffset 1 - return $ BuildResults 0 [ CharOut ] [] - -conditionalOpParser :: CapParser BuildResults -conditionalOpParser = do - _ <- char '?' - incOffset 1 - condPart <- manyExpr conditionalTrueParser - parts <- manyP - ( do - truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser - , conditionalFalseParser - ] - falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser - , conditionalTrueParser - ] - return ( truePart, falsePart ) - ) - conditionalEndParser - - let trueParts = map fst parts - falseParts = map snd parts - BuildResults n cond condParamOps = condPart - - let n' = maximum $ n : map outParamCount trueParts - n'' = maximum $ n' : map outParamCount falseParts - - let trueOps = map outCapOps trueParts - falseOps = map outCapOps falseParts - condParts = zip trueOps falseOps - - let trueParamOps = mconcat $ map outParamOps trueParts - falseParamOps = mconcat $ map outParamOps falseParts - pOps = mconcat [condParamOps, trueParamOps, falseParamOps] - - return $ BuildResults n'' [ Conditional cond condParts ] pOps - - where - manyP !p !end = choice - [ try end >> return [] - , do !v <- p - !vs <- manyP p end - return $! v : vs - ] - manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end - -conditionalTrueParser :: CapParser () -conditionalTrueParser = do - _ <- string "%t" - incOffset 2 - -conditionalFalseParser :: CapParser () -conditionalFalseParser = do - _ <- string "%e" - incOffset 2 - -conditionalEndParser :: CapParser () -conditionalEndParser = do - _ <- string "%;" - incOffset 2 - -bitwiseOpParser :: CapParser BuildResults -bitwiseOpParser - = bitwiseOrParser - <|> bitwiseAndParser - <|> bitwiseXorParser - -bitwiseOrParser :: CapParser BuildResults -bitwiseOrParser = do - _ <- char '|' - incOffset 1 - return $ BuildResults 0 [ BitwiseOr ] [ ] - -bitwiseAndParser :: CapParser BuildResults -bitwiseAndParser = do - _ <- char '&' - incOffset 1 - return $ BuildResults 0 [ BitwiseAnd ] [ ] - -bitwiseXorParser :: CapParser BuildResults -bitwiseXorParser = do - _ <- char '^' - incOffset 1 - return $ BuildResults 0 [ BitwiseXOr ] [ ] - -arithOpParser :: CapParser BuildResults -arithOpParser - = plusOp - <|> minusOp - where - plusOp = do - _ <- char '+' - incOffset 1 - return $ BuildResults 0 [ ArithPlus ] [ ] - minusOp = do - _ <- char '-' - incOffset 1 - return $ BuildResults 0 [ ArithMinus ] [ ] - -literalIntOpParser :: CapParser BuildResults -literalIntOpParser = do - _ <- char '{' - incOffset 1 - nStr <- many1 digit - incOffset $ toEnum $ length nStr - let n :: Word = read nStr - _ <- char '}' - incOffset 1 - return $ BuildResults 0 [ PushValue n ] [ ] - -compareOpParser :: CapParser BuildResults -compareOpParser - = compareEqOp - <|> compareLtOp - <|> compareGtOp - where - compareEqOp = do - _ <- char '=' - incOffset 1 - return $ BuildResults 0 [ CompareEq ] [ ] - compareLtOp = do - _ <- char '<' - incOffset 1 - return $ BuildResults 0 [ CompareLt ] [ ] - compareGtOp = do - _ <- char '>' - incOffset 1 - return $ BuildResults 0 [ CompareGt ] [ ] - -bytesOpParser :: CapParser BuildResults -bytesOpParser = do - bytes <- many1 $ satisfy (/= '%') - startOffset <- getState >>= return . nextOffset - let !c = length bytes - !s <- getState - let s' = s { nextOffset = startOffset + c } - setState s' - return $ BuildResults 0 [Bytes startOffset c] [] - -charConstParser :: CapParser BuildResults -charConstParser = do - _ <- char '\'' - charValue <- liftM (toEnum . fromEnum) anyChar - _ <- char '\'' - incOffset 3 - return $ BuildResults 0 [ PushValue charValue ] [ ] - -data BuildState = BuildState - { nextOffset :: Int - } - -incOffset :: Int -> CapParser () -incOffset n = do - s <- getState - let s' = s { nextOffset = nextOffset s + n } - setState s' - -initialBuildState :: BuildState -initialBuildState = BuildState 0 - -data BuildResults = BuildResults - { outParamCount :: !Int - , outCapOps :: !CapOps - , outParamOps :: !ParamOps - } - -instance Monoid BuildResults where - mempty = BuildResults 0 [] [] - v0 `mappend` v1 - = BuildResults - { outParamCount = (outParamCount v0) `max` (outParamCount v1) - , outCapOps = (outCapOps v0) `mappend` (outCapOps v1) - , outParamOps = (outParamOps v0) `mappend` (outParamOps v1) - } - diff --git a/src/Graphics/Text/Width.hs b/src/Graphics/Text/Width.hs --- a/src/Graphics/Text/Width.hs +++ b/src/Graphics/Text/Width.hs @@ -1,34 +1,64 @@ -- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE #-} {-# LANGUAGE ForeignFunctionInterface #-} -module Graphics.Text.Width ( wcwidth - , wcswidth - , safeWcwidth - , safeWcswidth - ) - where +-- | 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 = sum . map wcwidth +wcswidth = foldl' (\l c -> wcwidth c + l) 0 +{-# INLINE [1] wcswidth #-} --- 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. +wctwidth :: T.Text -> Int +wctwidth = T.foldl' (\l c -> wcwidth c + l) 0 --- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width +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 c = case wcwidth c of - i | i < 0 -> 0 - | otherwise -> i +safeWcwidth = max 0 . wcwidth --- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width +-- | Returns the display width of a string. Assumes all characters with +-- unknown widths are 0 width. safeWcswidth :: String -> Int -safeWcswidth str = case wcswidth str of - i | i < 0 -> 0 - | otherwise -> i +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,182 +1,249 @@ --- | Vty supports input and output to terminal devices. --- --- - Input to the terminal is provided to the app as a sequence of 'Event's. --- --- - The output is defined by a 'Picture'. Which is one or more layers of 'Image's. --- --- - The module "Graphics.Vty.Image" provides a number of constructor equations that will build --- correct 'Image' values. See 'string', '<|>', and '<->' for starters. --- --- - The constructors in "Graphics.Vty.Image.Internal" should not be used. --- --- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes". --- --- See the vty-examples package for a number of examples. --- --- @ --- import "Graphics.Vty" --- --- main = do --- cfg <- 'standardIOConfig' --- vty <- 'mkVty' cfg --- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\" --- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\" --- img = line0 '<->' line1 --- pic = 'picForImage' img --- 'update' vty pic --- e <- 'nextEvent' vty --- 'shutdown' vty --- 'print' (\"Last event was: \" '++' 'show' e) --- @ --- --- Good sources of documentation for terminal programming are: +{-# 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) -- --- - -module Graphics.Vty ( Vty(..) - , mkVty - , module Graphics.Vty.Config - , module Graphics.Vty.Input - , module Graphics.Vty.Output - , module Graphics.Vty.Picture - , DisplayRegion - ) - where - -import Graphics.Vty.Prelude +-- Vty uses threads internally, so programs made with Vty must be +-- compiled with the threaded runtime using the GHC @-threaded@ option. +module Graphics.Vty + ( Vty(..) + , setWindowTitle + , installCustomWidthTable + , mkVtyFromPair + , module Graphics.Vty.Config + , module Graphics.Vty.Input + , module Graphics.Vty.Input.Events + , module Graphics.Vty.Output + , module Graphics.Vty.Picture + , module Graphics.Vty.Image + , module Graphics.Vty.Attributes + ) +where import Graphics.Vty.Config import Graphics.Vty.Input +import Graphics.Vty.Input.Events import Graphics.Vty.Output import Graphics.Vty.Picture +import Graphics.Vty.Image +import Graphics.Vty.Attributes +import Graphics.Vty.UnicodeWidthTable.IO +import Graphics.Vty.UnicodeWidthTable.Install +import qualified Control.Exception as E +import Control.Monad (when) import Control.Concurrent.STM import Data.IORef -import Data.Monoid +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif --- | The main object. At most one should be created. --- --- The use of Vty typically follows this process: +-- | A 'Vty' value represents a handle to the Vty library that the +-- application must create in order to use Vty. -- --- 0. initialize vty +-- The use of this library typically follows this process: -- --- 1. use the update equation of Vty to display a picture +-- 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. repeat +-- 2. Use 'update' to display a picture. -- --- 3. shutdown vty. +-- 3. Use 'nextEvent' to get the next input event. -- --- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe". +-- 4. Depending on the event, go to 2 or 5. -- --- 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. +-- 5. Shutdown Vty and restore the terminal state with 'shutdown'. At +-- this point the 'Vty' handle cannot be used again. -- --- \todo Remove explicit `shutdown` requirement. -data Vty = Vty - { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context - -- implicitly managed by Vty. The managed display context is reset on resize. - update :: Picture -> IO () - -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event - -- is a 'EvResize'. - , nextEvent :: IO Event - -- | The input interface. See 'Input' - , inputIface :: Input - -- | The output interface. See 'Output' - , outputIface :: Output - -- | Refresh the display. 'nextEvent' will refresh the display if a resize occurs. - -- If other programs output to the terminal and mess up the display then the application 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 () - } +-- 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 + } --- | Set up the state object for using vty. At most one state object should be --- created at a time for a given terminal device. --- --- The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence. --- See "Graphics.Vty.Config" +-- | Attempt to load and install a custom character width table into +-- this process. -- --- For most applications @mkVty def@ is sufficient. -mkVty :: Config -> IO Vty -mkVty appConfig = do - config <- (<> appConfig) <$> userConfig - input <- inputForConfig config - out <- outputForConfig config - intMkVty input out +-- 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" -intMkVty :: Input -> Output -> IO Vty -intMkVty input out = do + customInstalled <- isCustomTableReady + when (not customInstalled) $ do + case tblName of + Nothing -> + doLog "No terminal name given in the configuration, skipping load" + Just name -> + case lookup name widthMaps of + Nothing -> + doLog $ "Width table " <> show name <> " not found in custom character width mapping list" + Just path -> do + tableResult <- E.try $ readUnicodeWidthTable path + case tableResult of + Left (e::E.SomeException) -> + doLog $ "Error reading custom character width table " <> + "at " <> show path <> ": " <> show e + Right (Left msg) -> + doLog $ "Error reading custom character width table " <> + "at " <> show path <> ": " <> msg + Right (Right table) -> do + installResult <- E.try $ installUnicodeWidthTable table + case installResult of + Left (e::E.SomeException) -> + doLog $ "Error installing unicode table (" <> + show path <> ": " <> show e + Right () -> + doLog $ "Successfully installed Unicode width table " <> + " from " <> show path + +-- | Build a 'Vty' handle from an input/output pair. +-- +-- This is exposed for Vty platform package implementors; application +-- developers should never need to call this, and should instead call +-- @mkVty@ or equivalent from their platform package of choice. +mkVtyFromPair :: Input -> Output -> IO Vty +mkVtyFromPair input out = do reserveDisplay out + + shutdownVar <- newTVarIO False let shutdownIo = do - shutdownInput input - releaseDisplay out - releaseTerminal out + alreadyShutdown <- atomically $ swapTVar shutdownVar True + when (not alreadyShutdown) $ do + shutdownInput input + releaseDisplay out + releaseTerminal out + + shutdownStatus = readTVarIO shutdownVar + lastPicRef <- newIORef Nothing lastUpdateRef <- newIORef Nothing let innerUpdate inPic = do - b@(w,h) <- displayBounds out - let cursor = picCursor inPic - inPic' = case cursor of - Cursor x y -> - let - x' = case x of - _ | x < 0 -> 0 - | x >= w -> w - 1 - | otherwise -> x - y' = case y of - _ | y < 0 -> 0 - | y >= h -> h - 1 - | otherwise -> y - in inPic { picCursor = Cursor x' y' } - _ -> inPic + b <- displayBounds out mlastUpdate <- readIORef lastUpdateRef updateData <- case mlastUpdate of Nothing -> do dc <- displayContext out b - outputPicture dc inPic' + outputPicture dc inPic return (b, dc) Just (lastBounds, lastContext) -> do if b /= lastBounds then do dc <- displayContext out b - outputPicture dc inPic' + outputPicture dc inPic return (b, dc) else do - outputPicture lastContext inPic' + outputPicture lastContext inPic return (b, lastContext) writeIORef lastUpdateRef $ Just updateData - writeIORef lastPicRef $ Just inPic' + writeIORef lastPicRef $ Just inPic - let innerRefresh - = writeIORef lastUpdateRef Nothing - >> readIORef lastPicRef - >>= maybe ( return () ) ( \pic -> innerUpdate 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 <- atomically $ readTChan $ _eventChannel input - case k of - (EvResize _ _) -> innerRefresh - >> displayBounds out - >>= return . (\(w,h)-> EvResize w h) - _ -> return k + mkResize = uncurry EvResize <$> displayBounds out + translateInternalEvent ResumeAfterInterrupt = mkResize + translateInternalEvent (InputEvent e) = return e + + gkey = do + e <- atomically $ readTChan $ eventChannel input + translateInternalEvent e + gkey' = do + mEv <- atomically $ tryReadTChan $ eventChannel input + case mEv of + Just e -> Just <$> translateInternalEvent e + Nothing -> return Nothing + return $ Vty { update = innerUpdate , nextEvent = gkey + , nextEventNonblocking = gkey' , inputIface = input , outputIface = out , refresh = innerRefresh , shutdown = shutdownIo + , isShutdown = shutdownStatus } +-- | Set the terminal window title string. +setWindowTitle :: Vty -> String -> IO () +setWindowTitle vty title = + setOutputWindowTitle (outputIface vty) title 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,68 +1,89 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} -- | Display attributes -- --- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes: +-- Attributes have three components: a foreground color, a background +-- color, and a style mask. The simplest attribute is the default +-- attribute, or 'defAttr'. Attributes can be modified with +-- 'withForeColor', 'withBackColor', and 'withStyle', e.g., -- -- @ --- defAttr `withForeColor` red +-- defAttr \`withForeColor\` red -- @ -- --- Is the attribute that will set the foreground color to red and the background color to the --- default. --- --- This can then be used to build an image wiht a red foreground like so: +-- '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" +-- string (defAttr \`withForeColor\` red) "this text will be red" -- @ -- --- The default attributes set by 'defAttr' have a presentation determined by the terminal. This is --- not something VTY can control. The user is free to define the color scheme of the terminal as --- they see fit. Up to the limits of the terminal anyways. --- --- The value 'currentAttr' will keep the attributes of whatever was output previously. +-- 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. -- --- \todo This API is very verbose IMO. I'd like something more succinct. -module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes - , module Graphics.Vty.Attributes.Color - , module Graphics.Vty.Attributes.Color240 - ) - where +-- 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.Default +import Data.Text (Text) import Data.Word +import GHC.Generics import Graphics.Vty.Attributes.Color -import Graphics.Vty.Attributes.Color240 -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - --- | A display attribute defines the Color and Style of all the characters rendered after the --- attribute is applied. +-- | 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. +-- 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) - } deriving ( Eq, Show, Read ) + , 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. +-- 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 @@ -79,85 +100,47 @@ -- __ - 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. -instance Monoid Attr where - mempty = Attr mempty mempty mempty - mappend attr0 attr1 = - Attr ( attrStyle attr0 `mappend` attrStyle attr1 ) - ( attrForeColor attr0 `mappend` attrForeColor attr1 ) - ( attrBackColor attr0 `mappend` attrBackColor attr1 ) - --- | 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 { 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, Read v ) => !v -> MaybeDefault v - -deriving instance Eq v => Eq (MaybeDefault v) -deriving instance Eq v => Show (MaybeDefault v) -deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v) - -instance Eq v => 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 -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 +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 -- @@ -171,21 +154,27 @@ -- -- * bold/bright -- --- ( The invisible, protect, and altcharset display attributes some terminals support are not --- supported via VTY.) -standout, underline, reverseVideo, 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 -reverseVideo = 0x04 +reverseVideo = 0x04 blink = 0x08 dim = 0x10 bold = 0x20 +italic = 0x40 +strikethrough = 0x80 defaultStyleMask :: Style defaultStyleMask = 0x00 styleMask :: Attr -> Word8 -styleMask attr +styleMask attr = case attrStyle attr of Default -> 0 KeepCurrent -> 0 @@ -205,23 +194,35 @@ -- | Add the given style attribute 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. -defAttr :: Attr -defAttr = 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 } -instance Default Attr where - def = defAttr +-- | 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. +-- | Keeps the style, background color and foreground color that was +-- previously set. Used to override some part of the previous style. -- -- EG: current_style `withForeColor` brightMagenta -- --- Would be the currently applied style (be it underline, bold, etc) but with the foreground color --- set to brightMagenta. +-- 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 - +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 +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 --- | 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. -rgbColor :: Integral i => i -> i -> i -> Color -rgbColor r g b +-- 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 = 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." + | 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 --- a/src/Graphics/Vty/Config.hs +++ b/src/Graphics/Vty/Config.hs @@ -1,24 +1,28 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE KindSignatures #-} --- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can --- be used to customize vty for a user's system. +-- | 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. -- --- The 'Config' provided is mappend'd to 'Config's loaded from @'getAppUserDataDirectory'/config@ --- and @$VTY_CONFIG_FILE@. The @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the --- application provided 'Config'. +-- = Debug -- --- Lines in config files that fail to parse are ignored. Later entries take precedence over --- earlier. +-- == @colorMode@ -- --- For all directives: --- +-- Format: +-- -- @ --- string := \"\\\"\" chars+ \"\\\"\" +-- colorMode \"|FullColor>\" -- @ -- --- = Debug +-- 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@ -- @@ -28,8 +32,8 @@ -- \"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. +-- 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 -- @@ -39,14 +43,14 @@ -- -- @ -- \"map\" term string key modifier_list --- where +-- where -- key := KEsc | KChar Char | KBS ... (same as 'Key') -- modifier_list := \"[\" modifier+ \"]\" -- modifier := MShift | MCtrl | MMeta | MAlt -- term := "_" | string -- @ -- --- EG: If the contents are +-- E.g., if the contents are -- -- @ -- map _ \"\\ESC[B\" KUp [] @@ -54,231 +58,381 @@ -- 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@. +-- 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. +-- 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@. -- --- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings. Add corrected mappings to --- .vty/config +-- = Unicode Character Width Maps -- -module Graphics.Vty.Config where +-- == @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 -#if __GLASGOW_HASKELL__ > 704 + , vtyConfigPath + , widthTableFilename + , vtyDataDirectory + , terminalWidthTablePath + , vtyConfigFileEnvName + + , ConfigUpdateResult(..) + , addConfigWidthMap + ) +where + import Prelude -#else -import Prelude hiding (catch) -#endif import Control.Applicative hiding (many) import Control.Exception (catch, IOException) -import Control.Monad (void) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer +import Control.Monad (liftM, guard, void) import qualified Data.ByteString as BS -import Data.Default -import Data.Monoid +#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 System.Directory (getAppUserDataDirectory) -import System.Posix.Env (getEnv) -import System.Posix.IO (stdInput, stdOutput) -import System.Posix.Types (Fd(..)) +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. +-- | 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)] -data Config = Config - { - -- | The default is 1 character. - vmin :: Maybe Int - -- | The default is 100 milliseconds, 0.1 seconds. - , vtime :: Maybe Int - -- | Debug information is appended to this file if not Nothing. - , debugLog :: Maybe FilePath - -- | 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. - , inputMap :: InputMap - -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput' - , inputFd :: Maybe Fd - -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput' - , outputFd :: Maybe Fd - -- | The terminal name used to look up terminfo capabilities. - -- The default is the value of the TERM environment variable. - , termName :: Maybe String - } deriving (Show, Eq) +-- | A Vty core library configuration. Platform-specific details are not +-- included in the VtyUserConfig. +data VtyUserConfig = + VtyUserConfig { configDebugLog :: Maybe FilePath + -- ^ Debug information is appended to this file if not + -- Nothing. + , configInputMap :: InputMap + -- ^ The (input byte, output event) pairs extend the internal + -- input table of VTY and the table from terminfo. + -- + -- See "Graphics.Vty.Config" module documentation for + -- documentation of the @map@ directive. + , configTermWidthMaps :: [(String, FilePath)] + -- ^ Terminal width map files. + , configAllowCustomUnicodeWidthTables :: Maybe Bool + -- ^ Whether to permit custom Unicode width table loading by + -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that + -- table loading should not be performed. Other values permit + -- table loading. + -- + -- If a table load is attempted and fails, information + -- about the failure will be logged to the debug log if the + -- configuration specifies one. If no custom table is loaded + -- (or if a load fails), the built-in character width table + -- will be used. + , configPreferredColorMode :: Maybe ColorMode + -- ^ Preferred color mode. If set, this should + -- override platform color mode detection. + } + deriving (Show, Eq) -instance Default Config where - def = mempty +defaultConfig :: VtyUserConfig +defaultConfig = mempty -instance Monoid Config where - mempty = Config - { vmin = Nothing - , vtime = Nothing - , debugLog = mempty - , inputMap = mempty - , inputFd = Nothing - , outputFd = Nothing - , termName = Nothing - } - mappend c0 c1 = Config +instance Semigroup VtyUserConfig where + c0 <> c1 = -- latter config takes priority for everything but inputMap - { vmin = vmin c1 <|> vmin c0 - , vtime = vtime c1 <|> vtime c0 - , debugLog = debugLog c1 <|> debugLog c0 - , inputMap = inputMap c0 <> inputMap c1 - , inputFd = inputFd c1 <|> inputFd c0 - , outputFd = outputFd c1 <|> outputFd c0 - , termName = termName c1 <|> termName c0 - } + 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 + } -type ConfigParser s a = ParsecT s () (Writer Config) a +instance Monoid VtyUserConfig where + mempty = + VtyUserConfig { configDebugLog = mempty + , configInputMap = mempty + , configTermWidthMaps = [] + , configAllowCustomUnicodeWidthTables = Nothing + , configPreferredColorMode = Nothing + } +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif --- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@ -userConfig :: IO Config +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 <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile - overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE" + configFile <- vtyConfigPath >>= parseConfigFile + overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< + lookupEnv vtyConfigFileEnvName let base = configFile <> overrideConfig mappend base <$> overrideEnvConfig -overrideEnvConfig :: IO Config -overrideEnvConfig = do - d <- getEnv "VTY_DEBUG_LOG" - return $ def { debugLog = d } +widthTableFilename :: String -> String +widthTableFilename term = "width_table_" <> term <> ".dat" -standardIOConfig :: IO Config -standardIOConfig = do - Just t <- getEnv "TERM" - return $ def { vmin = Just 1 - , vtime = Just 100 - , inputFd = Just stdInput - , outputFd = Just stdOutput - , termName = Just t - } +termVariable :: String +termVariable = "TERM" -parseConfigFile :: FilePath -> IO Config +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 def) + (\(_ :: IOException) -> return defaultConfig) -runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config -runParseConfig name = execWriter . runParserT parseConfig () name +runParseConfig :: String -> BS.ByteString -> VtyUserConfig +runParseConfig name cfgTxt = + case runParser parseConfig () name cfgTxt of + Right cfg -> cfg + Left{} -> defaultConfig --- I tried to use the haskellStyle here but that was specialized (without requirement?) to the --- String stream type. -configLanguage :: Stream s m Char => P.GenLanguageDef s u m +------------------------------------------------------------------------ + +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 ":!#$%&*+./<=>?@\\^|-~" + { commentStart = "{-" + , commentEnd = "-}" + , commentLine = "--" + , nestedComments = True + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter configLanguage + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" , reservedOpNames = [] - , reservedNames = [] - , caseSensitive = True + , reservedNames = [] + , caseSensitive = True } -configLexer :: Stream s m Char => P.GenTokenParser s u m +configLexer :: Monad m => P.GenTokenParser BS.ByteString () m configLexer = P.makeTokenParser configLanguage -mapDecl :: forall s u (m :: * -> *). - (Monad m, Stream s (WriterT Config m) Char) => - ParsecT s u (WriterT Config m) () +mapDecl :: Parser VtyUserConfig mapDecl = do - void $ string "map" - P.whiteSpace configLexer + "map" <- P.identifier configLexer termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing) <|> (Just <$> P.stringLiteral configLexer) - bytes <- P.stringLiteral configLexer - key <- parseKey - modifiers <- parseModifiers - lift $ tell $ def { inputMap = [(termIdent, bytes, EvKey key modifiers)] } - --- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read --- instance? Generics? -parseKey :: forall s u (m :: * -> *). - Stream s m Char => - ParsecT s u m Key -parseKey = do - key <- P.identifier configLexer - case key of - "KChar" -> KChar <$> P.charLiteral configLexer - "KFun" -> KFun . fromInteger <$> P.natural configLexer - "KEsc" -> return KEsc - "KBS" -> return KBS - "KEnter" -> return KEnter - "KLeft" -> return KLeft - "KRight" -> return KRight - "KUp" -> return KUp - "KDown" -> return KDown - "KUpLeft" -> return KUpLeft - "KUpRight" -> return KUpRight - "KDownLeft" -> return KDownLeft - "KDownRight" -> return KDownRight - "KCenter" -> return KCenter - "KBackTab" -> return KBackTab - "KPrtScr" -> return KPrtScr - "KPause" -> return KPause - "KIns" -> return KIns - "KHome" -> return KHome - "KPageUp" -> return KPageUp - "KDel" -> return KDel - "KEnd" -> return KEnd - "KPageDown" -> return KPageDown - "KBegin" -> return KBegin - "KMenu" -> return KMenu - _ -> fail $ key ++ " is not a valid key identifier" + bytes <- P.stringLiteral configLexer + key <- parseValue + modifiers <- parseValue + return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] } -parseModifiers :: forall s u (m :: * -> *). - Stream s m Char => - ParsecT s u m [Modifier] -parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",") +debugLogDecl :: Parser VtyUserConfig +debugLogDecl = do + "debugLog" <- P.identifier configLexer + path <- P.stringLiteral configLexer + return defaultConfig { configDebugLog = Just path } -parseModifier :: forall s u (m :: * -> *). - Stream s m Char => - ParsecT s u m Modifier -parseModifier = do - m <- P.identifier configLexer - case m of - "KMenu" -> return MShift - "MCtrl" -> return MCtrl - "MMeta" -> return MMeta - "MAlt" -> return MAlt - _ -> fail $ m ++ " is not a valid modifier identifier" +colorModeDecl :: Parser VtyUserConfig +colorModeDecl = do + "colorMode" <- P.identifier configLexer + mode <- P.stringLiteral configLexer + return defaultConfig { configPreferredColorMode = readMaybe mode } -debugLogDecl :: forall s u (m :: * -> *). - (Monad m, Stream s (WriterT Config m) Char) => - ParsecT s u (WriterT Config m) () -debugLogDecl = do - void $ string "debugLog" - P.whiteSpace configLexer +widthMapDecl :: Parser VtyUserConfig +widthMapDecl = do + "widthMap" <- P.identifier configLexer + tName <- P.stringLiteral configLexer path <- P.stringLiteral configLexer - lift $ tell $ def { debugLog = Just path } + return defaultConfig { configTermWidthMaps = [(tName, path)] } -ignoreLine :: forall s u (m :: * -> *). - Stream s m Char => ParsecT s u m () +ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline -parseConfig :: forall s u (m :: * -> *). - (Monad m, Stream s (WriterT Config m) Char) => - ParsecT s u (WriterT Config m) () -parseConfig = void $ many $ do +parseConfig :: Parser VtyUserConfig +parseConfig = liftM mconcat $ many $ do P.whiteSpace configLexer - let directives = [mapDecl, debugLogDecl] - try (choice directives) <|> ignoreLine + 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,29 +1,34 @@ -- Copyright 2009-2010 Corey O'Connor -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.Prelude - import Graphics.Vty.Attributes -import Graphics.Vty.Debug.Image +import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Span -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector -rowOpsEffectedColumns :: DisplayOps -> [Int] -rowOpsEffectedColumns ops - = Vector.toList $ Vector.map spanOpsEffectedColumns ops +rowOpsAffectedColumns :: DisplayOps -> [Int] +rowOpsAffectedColumns ops + = Vector.toList $ Vector.map spanOpsAffectedColumns ops allSpansHaveWidth :: DisplayOps -> Int -> Bool allSpansHaveWidth ops expected - = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops + = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops -spanOpsEffectedRows :: DisplayOps -> Int -spanOpsEffectedRows ops +spanOpsAffectedRows :: DisplayOps -> Int +spanOpsAffectedRows ops = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops)) - + type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr @@ -37,4 +42,3 @@ 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 @@ -{-# OPTIONS_HADDOCK hide #-} -module Graphics.Vty.Debug.Image where - -import Graphics.Vty.Image - -type ImageConstructLog = [ImageConstructEvent] -data ImageConstructEvent = ImageConstructEvent - deriving ( Show, Eq ) - -forwardImageOps :: [Image -> Image] -forwardImageOps = map forwardTransform debugImageOps - -forwardTransform, reverseTransform :: ImageOp -> (Image -> Image) - -forwardTransform (ImageOp f _) = f -reverseTransform (ImageOp _ r) = r - -data ImageOp = ImageOp ImageEndo ImageEndo -type ImageEndo = Image -> Image - -debugImageOps :: [ImageOp] -debugImageOps = - [ idImageOp - -- , renderSingleColumnCharOp - -- , renderDoubleColumnCharOp - ] - -idImageOp :: ImageOp -idImageOp = ImageOp id id - --- renderCharOp :: ImageOp --- renderCharOp = ImageOp id id 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,31 +1,38 @@ -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif +{-# LANGUAGE CPP #-} module Graphics.Vty.DisplayAttributes - where + ( DisplayAttrDiff(..) + , StyleStateChange(..) + , DisplayColorDiff(..) + , URLDiff(..) + , fixDisplayAttr + , displayAttrDiffs + ) +where import Graphics.Vty.Attributes import Data.Bits ((.&.)) - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..), mconcat) +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. fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr fixDisplayAttr fattr attr = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr)) (fixColor (fixedForeColor fattr) (attrForeColor attr)) (fixColor (fixedBackColor fattr) (attrBackColor attr)) + (fixURL (fixedURL fattr) (attrURL attr)) where fixStyle _s Default = defaultStyleMask fixStyle s KeepCurrent = s @@ -33,43 +40,56 @@ 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 { styleDiffs :: [StyleStateChange] , foreColorDiff :: DisplayColorDiff , backColorDiff :: DisplayColorDiff + , urlDiff :: URLDiff } deriving (Show) -instance Monoid DisplayAttrDiff where - mempty = DisplayAttrDiff [] NoColorChange NoColorChange - mappend d0 d1 = +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) - in DisplayAttrDiff ds fcd bcd + ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1) + in DisplayAttrDiff ds fcd bcd ud +instance Monoid DisplayAttrDiff where + mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + -- | Used in the computation of a final style attribute change. --- --- TODO(corey): not really a simplify but a monoid instance. 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. +-- | Consider two display color attributes diffs. What display color +-- attribute diff are these equivalent to? simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplifyColorDiffs _cd ColorToDefault = ColorToDefault simplifyColorDiffs cd NoColorChange = cd simplifyColorDiffs _cd (SetColor !c) = SetColor c +-- | Consider two URL changes, which are mostly going to be the latter +-- unless the latter specifies no change. +simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff +simplifyUrlDiffs ud NoLinkChange = ud +simplifyUrlDiffs _ ud = ud + -- | Difference between two display color attribute changes. data DisplayColorDiff = ColorToDefault @@ -77,11 +97,15 @@ | SetColor !Color 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 @@ -94,15 +118,28 @@ | RemoveBold deriving (Show, Eq) --- | Determines the diff between two display&color attributes. This diff determines the operations --- that actually get output to the terminal. +-- Setting and unsetting hyperlinks +data URLDiff + = LinkTo !ByteString + | NoLinkChange + | EndLink + deriving (Show, Eq) + +-- | Determines the diff between two display&color attributes. This diff +-- determines the operations that actually get output to the terminal. displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff displayAttrDiffs attr attr' = DisplayAttrDiff { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr') , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr') , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr') + , urlDiff = diffURL (fixedURL attr) (fixedURL attr') } +diffURL :: Maybe Text -> Maybe Text -> URLDiff +diffURL Nothing Nothing = NoLinkChange +diffURL (Just _) Nothing = EndLink +diffURL _ (Just url) = LinkTo (encodeUtf8 url) + diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff diffColor Nothing (Just c') = SetColor c' diffColor (Just c) (Just c') @@ -116,6 +153,8 @@ = 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 diff --git a/src/Graphics/Vty/Error.hs b/src/Graphics/Vty/Error.hs --- a/src/Graphics/Vty/Error.hs +++ b/src/Graphics/Vty/Error.hs @@ -1,8 +1,11 @@ module Graphics.Vty.Error - where + ( VtyException(..) + ) +where -- | The type of exceptions specific to vty. -- --- These have fully qualified names by default since, IMO, exception handling requires this. +-- 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,48 +1,62 @@ -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -module Graphics.Vty.Image ( DisplayText - , Image - , imageWidth - , imageHeight - , horizJoin - , (<|>) - , vertJoin - , (<->) - , horizCat - , vertCat - , backgroundFill - , text - , text' - , char - , string - , iso10646String - , utf8String - , utf8Bytestring - , utf8Bytestring' - , charFill - , emptyImage - , safeWcwidth - , safeWcswidth - , wcwidth - , wcswidth - , crop - , cropRight - , cropLeft - , cropBottom - , cropTop - , pad - , resize - , resizeWidth - , resizeHeight - , translate - , translateX - , translateY - -- | 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 Graphics.Vty.Image.Internal @@ -56,120 +70,163 @@ import qualified Data.Text.Lazy.Encoding as TL import Data.Word +-- | A region of the display (first width, then height) +type DisplayRegion = (Int,Int) + +regionWidth :: DisplayRegion -> Int +regionWidth = fst + +regionHeight :: DisplayRegion -> Int +regionHeight = snd + infixr 5 <|> infixr 4 <-> --- | An area of the picture's bacground (See Background) of w columns and h rows. -backgroundFill :: Int -> Int -> Image -backgroundFill 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 --- | Combines two images horizontally. Alias for horizJoin +-- | Combines two images horizontally. This is an alias for 'horizJoin'. -- -- infixr 5 (<|>) :: Image -> Image -> Image (<|>) = horizJoin --- | Combines two images vertically. Alias for vertJoin +-- | Combines two images vertically. This is an alias for 'vertJoin'. -- -- infixr 4 (<->) :: Image -> Image -> Image (<->) = vertJoin --- | Compose any number of images horizontally. +-- | Compose any number of images together horizontally, with the first +-- in the list being leftmost. horizCat :: [Image] -> Image horizCat = foldr horizJoin EmptyImage --- | Compose any number of images vertically. +-- | Compose any number of images vertically, with the first in the list +-- being topmost. vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage --- | A Data.Text.Lazy value +-- | 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 - | TL.length txt == 0 = EmptyImage - | otherwise = let displayWidth = safeWcswidth (TL.unpack txt) - in HorizText a txt displayWidth (fromIntegral $! TL.length txt) +text a txt = let displayWidth = safeWctlwidth txt + in HorizText a txt displayWidth (fromIntegral $! TL.length txt) --- | A Data.Text value +-- | 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 - | T.length txt == 0 = EmptyImage - | otherwise = let displayWidth = safeWcswidth (T.unpack txt) - in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) +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 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 iso10646String or string. --- +-- 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 _ [] = EmptyImage iso10646String a str = let displayWidth = safeWcswidth str in HorizText a (TL.pack str) displayWidth (length str) --- | 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. +-- | 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 = iso10646String --- | A string of characters layed out on a single row. The input is assumed to be the bytes for --- UTF-8 encoded text. +-- | 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) --- | Renders a UTF-8 encoded lazy bytestring. +-- | Make an 'Image' from a UTF-8 encoded lazy bytestring. utf8Bytestring :: Attr -> BL.ByteString -> Image utf8Bytestring a bs = text a (TL.decodeUtf8 bs) --- | Renders a UTF-8 encoded strict bytestring. +-- | Make an 'Image' from a UTF-8 encoded strict bytestring. utf8Bytestring' :: Attr -> B.ByteString -> Image utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) --- | creates a fill of the specified character. The dimensions are in number of characters wide and --- number of rows high. -charFill :: Integral d => Attr -> Char -> d -> d -> Image -charFill _a _c 0 _h = EmptyImage -charFill _a _c _w 0 = EmptyImage -charFill a c w h = - vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth - where - txt = TL.replicate (fromIntegral w) (TL.singleton c) - displayWidth = safeWcwidth c * (fromIntegral w) - charWidth = fromIntegral w +-- | 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 --- | The empty image. Useful for fold combinators. These occupy no space nor define any display --- attributes. -emptyImage :: Image + charWidth :: Num a => a + charWidth = fromIntegral w + +-- | The empty image. Useful for fold combinators. These occupy no space +-- and do not affect display attributes. +emptyImage :: Image emptyImage = EmptyImage --- | pad the given image. This adds background character fills to the left, top, right, bottom. --- The pad values are how many display columns or rows to add. -pad :: Int -> Int -> Int -> Int -> Image -> Image +-- | 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 - -- TODO: uh. + 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 @@ -184,40 +241,53 @@ where w = imageWidth i + l h = imageHeight i --- | translates an image by padding or cropping the left and top. First param is amount to translate --- left. Second param is amount to translate top. +-- | Translates an image by padding or cropping the left and top. -- --- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than --- (0,0) will crop the image. -translate :: Int -> Int -> Image -> Image +-- If translation offsets are negative then the image is cropped. +translate :: Int + -- ^ The horizontal translation offset (can be negative) + -> Int + -- ^ The vertical translation offset (can be negative) + -> Image + -- ^ The image to translate. + -> Image translate x y i = translateX x (translateY y i) --- | translates an image by padding or cropping the left +-- | Translates an image by padding or cropping its left side. translateX :: Int -> Image -> Image translateX x i - | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i) + | x < 0 && (abs x > imageWidth i) = emptyImage + | x < 0 = cropLeft (imageWidth i + x) i | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h --- | translates an image by padding or cropping the top +-- | Translates an image by padding or cropping its top. translateY :: Int -> Image -> Image translateY y i - | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s) + | y < 0 && (abs y > imageHeight i) = emptyImage + | y < 0 = cropTop (imageHeight i + y) i | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) --- | Ensure an image is no larger than the provided size. If the image is larger then crop the right --- or bottom. +-- | Ensure an image is no larger than the provided size. If the image +-- is larger then crop the right or bottom. -- --- This is transformed to a vertical crop from the bottom followed by horizontal crop from the --- right. -crop :: Int -> Int -> Image -> Image +-- This is equivalent to a vertical crop from the bottom followed by +-- horizontal crop from the right. +crop :: Int + -- ^ Cropping width + -> Int + -- ^ Cropping height + -> Image + -- ^ The image to crop + -> Image crop 0 _ _ = EmptyImage crop _ 0 _ = EmptyImage crop w h i = cropBottom h (cropRight w i) --- | crop the display height. If the image is less than or equal in height then this operation has --- no effect. Otherwise the image is cropped from the bottom. +-- | 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 @@ -225,15 +295,15 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropBottom {croppedImage, outputWidth, outputHeight}) - | outputHeight <= h = i - | otherwise = CropBottom croppedImage outputWidth h + go i@(Crop {outputHeight}) + = i {outputHeight = min h outputHeight} go i | h >= imageHeight i = i - | otherwise = CropBottom i (imageWidth i) h + | otherwise = Crop i 0 0 (imageWidth i) h --- | ensure the image is no wider than the given width. If the image is wider then crop the right --- side. +-- | 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 @@ -241,15 +311,15 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropRight {croppedImage, outputWidth, outputHeight}) - | outputWidth <= w = i - | otherwise = CropRight croppedImage w outputHeight + go i@(Crop {outputWidth}) + = i {outputWidth = min w outputWidth} go i | w >= imageWidth i = i - | otherwise = CropRight i w (imageHeight i) + | otherwise = Crop i 0 0 w (imageHeight i) --- | ensure the image is no wider than the given width. If the image is wider then crop the left --- side. +-- | 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 @@ -257,17 +327,17 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) - | outputWidth <= w = i - | otherwise = - let leftSkip' = leftSkip + outputWidth - w - in CropLeft croppedImage leftSkip' w outputHeight + go i@(Crop {leftSkip, outputWidth}) = + let delta = max 0 (outputWidth - w) + in i { leftSkip = leftSkip + delta + , outputWidth = outputWidth - delta } go i | imageWidth i <= w = i - | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i) + | otherwise = Crop i (imageWidth i - w) 0 w (imageHeight i) --- | crop the display height. If the image is less than or equal in height then this operation has --- no effect. Otherwise the image is cropped from the top. +-- | 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 @@ -275,33 +345,32 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight}) - | outputHeight <= h = i - | otherwise = - let topSkip' = topSkip + outputHeight - h - in CropTop croppedImage topSkip' outputWidth h + go i@(Crop {topSkip, outputHeight}) = + let delta = max 0 (outputHeight - h) + in i { topSkip = topSkip + delta + , outputHeight = outputHeight - delta } go i | imageHeight i <= h = i - | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h + | otherwise = Crop i 0 (imageHeight i - h) (imageWidth i) h --- | Generic resize. Pads and crops as required to assure the given display width and height. --- This is biased to pad/crop the right and bottom. +-- | 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 the right. +-- | 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 the bottom. +-- | 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 --- a/src/Graphics/Vty/Image/Internal.hs +++ b/src/Graphics/Vty/Image/Internal.hs @@ -1,55 +1,51 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif +module Graphics.Vty.Image.Internal + ( Image(..) + , imageHeight + , imageWidth + , horizJoin + , vertJoin -module Graphics.Vty.Image.Internal where + , ppImageStructure + , clipText + ) +where import Graphics.Vty.Attributes import Graphics.Text.Width -import Control.DeepSeq +import GHC.Generics -import qualified Data.Text.Lazy as TL +import Control.DeepSeq -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) #endif - --- | A display text is a Data.Text.Lazy --- --- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each --- application probably uses a single type. Perhaps parameterize the entire vty interface by the --- input text type? --- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance --- for the usual case of appending a bunch of characters with the same attribute together. -type DisplayText = TL.Text +import qualified Data.Text.Lazy as TL --- TODO: store a skip list in HorizText(?) --- TODO: represent display strings containing chars that are not 1 column chars as a separate --- display string value? -clipText :: DisplayText -> Int -> Int -> DisplayText +clipText :: TL.Text -> Int -> Int -> TL.Text clipText txt leftSkip rightClip = -- CPS would clarify this I think let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0 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) - clipForCharWidth 0 _ n = (n, False) + -- 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, True) - | w == cw = (n+1, False) - | w > cw = clipForCharWidth (w - cw) (TL.tail t) (n + 1) + | w < cw = (n, w /= 0) + | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1) where cw = safeWcwidth (TL.head t) - clipForCharWidth _ _ _ = error "clipForCharWidth applied to undefined" in txt'' --- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to --- create instances. +-- | This is the internal representation of Images. Use the constructors +-- in "Graphics.Vty.Image" to create instances. -- -- Images are: -- @@ -62,114 +58,72 @@ -- * a cropped image -- -- * an empty image of no size or content. -data Image = - -- | A horizontal text span is always >= 1 column and has a row height of 1. +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 :: DisplayText - -- | The number of display columns for the text. Always > 0. + -- | 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. Always > 0. + -- | 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. + -- | 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 + { partLeft :: Image , partRight :: Image - , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 1 - , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0 + , 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. + -- | 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 + , 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. + -- | 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 horizontally to a size by reducing the size from the right. - | CropRight - { croppedImage :: Image - -- | Always < imageWidth croppedImage > 0 - , outputWidth :: Int - , outputHeight :: Int -- ^ imageHeight croppedImage - } - -- | Crop an image horizontally to a size by reducing the size from the left. - | CropLeft + -- | Crop an image + | Crop { croppedImage :: Image - -- | Always < imageWidth croppedImage > 0 , leftSkip :: Int - -- | Always < imageWidth croppedImage > 0 - , outputWidth :: Int - , outputHeight :: Int - } - -- | Crop an image vertically to a size by reducing the size from the bottom - | CropBottom - { croppedImage :: Image - -- | imageWidth croppedImage - , outputWidth :: Int - -- | height image is cropped to. Always < imageHeight croppedImage > 0 - , outputHeight :: Int - } - -- | Crop an image vertically to a size by reducing the size from the top - | CropTop - { croppedImage :: Image - -- | Always < imageHeight croppedImage > 0 , topSkip :: Int - -- | imageWidth croppedImage , outputWidth :: Int - -- | Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | The empty image -- - -- The combining operators identity constant. + -- The combining operators identity constant. -- EmptyImage <|> a = a -- EmptyImage <-> a = a - -- + -- -- Any image of zero size equals the empty image. | EmptyImage - deriving Eq - -instance Show Image where - show ( HorizText { attr, displayText, outputWidth, charWidth } ) - = "HorizText " ++ show displayText - ++ "@(" ++ show attr ++ "," - ++ show outputWidth ++ "," - ++ show charWidth ++ ")" - show ( BGFill { outputWidth, outputHeight } ) - = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")" - show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } ) - = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")" - show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } ) - = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")" - show ( CropRight { croppedImage, outputWidth, outputHeight } ) - = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]" - ++ " (" ++ show croppedImage ++ ")" - show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } ) - = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]" - ++ " (" ++ show croppedImage ++ ")" - show ( CropBottom { croppedImage, outputWidth, outputHeight } ) - = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]" - ++ " (" ++ show croppedImage ++ ")" - show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } ) - = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]" - ++ " (" ++ show croppedImage ++ ")" - show ( EmptyImage ) = "EmptyImage" + deriving (Eq, Generic, Show, Read) -- | pretty print just the structure of an image. ppImageStructure :: Image -> String -ppImageStructure inImg = go 0 inImg +ppImageStructure = go 0 where go indent img = tab indent ++ pp indent img tab indent = concat $ replicate indent " " @@ -182,76 +136,65 @@ = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n" ++ go (i+1) t ++ "\n" ++ go (i+1) b - pp i (CropRight {croppedImage, outputWidth, outputHeight}) - = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" - ++ go (i+1) croppedImage - pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) - = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" - ++ go (i+1) croppedImage - pp i (CropBottom {croppedImage, outputWidth, outputHeight}) - = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" - ++ go (i+1) croppedImage - pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight}) - = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n" + pp i (Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight}) + = "Crop(" ++ show leftSkip ++ "," ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp _ EmptyImage = "EmptyImage" - + instance NFData Image where rnf EmptyImage = () - rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` () - rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` () - rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` () - rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` () + rnf (Crop i x y w h) = i `deepseq` x `seq` y `seq` w `seq` h `seq` () rnf (BGFill w h) = w `seq` h `seq` () rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` () rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` () 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. +-- | 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 CropRight { outputWidth = w } = w -imageWidth CropLeft { outputWidth = w } = w -imageWidth CropBottom { outputWidth = w } = w -imageWidth CropTop { outputWidth = w } = w +imageWidth Crop { outputWidth = w } = w imageWidth EmptyImage = 0 --- | The height of an Image. This is the number of display rows the image will occupy. +-- | 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 CropRight { outputHeight = h } = h -imageHeight CropLeft { outputHeight = h } = h -imageHeight CropBottom { outputHeight = h } = h -imageHeight CropTop { outputHeight = h } = h +imageHeight Crop { outputHeight = h } = h imageHeight EmptyImage = 0 --- | Append in the Monoid instance is equivalent to <->. +-- | 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 - mappend = vertJoin +#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 --- missmatch will be filled with the background pattern. +-- Combines text chunks where possible. Assures outputWidth and +-- outputHeight properties are not violated. -- --- TODO: the bg fill is biased towards top to bottom languages(?) +-- 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) - -- TODO: assumes horiz text height is always 1 + -- 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 @@ -273,19 +216,19 @@ -- | 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. --- --- TODO: the bg fill is biased towards right to left languages(?) +-- 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 + -- 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. + -- 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 @@ -299,4 +242,3 @@ 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,45 +1,39 @@ --- | 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. -- -- @ -- putStr \"Not styled. \" -- putAttrChange_ $ do --- backColor red +-- backColor red -- applyStyle underline -- putStr \" Styled! \" -- putAttrChange_ $ defaultAll -- putStrLn \"Not styled.\" -- @ -- --- 'putAttrChange' outputs the control codes to the terminal device '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' +-- '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 CPP #-} -{-# LANGUAGE BangPatterns #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Graphics.Vty.Inline ( module Graphics.Vty.Inline - , withVty - ) - where +module Graphics.Vty.Inline + ( module Graphics.Vty.Inline + ) +where import Graphics.Vty import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Inline.Unsafe -import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder (writeToByteString) @@ -50,44 +44,55 @@ import System.IO -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Monoid ( mappend ) -#endif +type InlineM v = State InlineState v -type InlineM v = State Attr v +data InlineState = + InlineState { inlineAttr :: Attr + , inlineUrlsEnabled :: Bool + } --- | Set the background color to the provided 'Color' +-- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM () -backColor c = modify $ flip mappend ( currentAttr `withBackColor` c ) +backColor c = modify $ \s -> + s { inlineAttr = inlineAttr s `withBackColor` c + } --- | Set the foreground color to the provided 'Color' +-- | Set the foreground color to the provided 'Color'. foreColor :: Color -> InlineM () -foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c ) +foreColor c = modify $ \s -> + s { inlineAttr = inlineAttr s `withForeColor` c + } --- | Attempt to change the 'Style' of the following text. +-- | 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. +-- If the terminal does not support the style change then no error is +-- produced. The style can still be removed. applyStyle :: Style -> InlineM () -applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s ) +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 applyStyle for the given style has not been previously called. +-- This will fail if 'applyStyle' for the given style has not been +-- previously called. removeStyle :: Style -> InlineM () -removeStyle sMask = modify $ \attr -> - let style' = case attrStyle attr of - Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." - KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." - SetTo s -> s .&. complement sMask - in attr { attrStyle = SetTo style' } +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 +-- | Reset the display attributes. defaultAll :: InlineM () -defaultAll = put defAttr +defaultAll = modify $ \s -> s { inlineAttr = defAttr } --- | Apply the provided display attribute changes to the given terminal output device. +-- | Apply the provided display attribute changes to the given terminal +-- output device. -- -- This does not flush the terminal. putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () @@ -97,23 +102,23 @@ mfattr <- prevFattr <$> readIORef (assumedStateRef out) fattr <- case mfattr of Nothing -> do - liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc - return $ FixedAttr defaultStyleMask Nothing Nothing + liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False + return $ FixedAttr defaultStyleMask Nothing Nothing Nothing Just v -> return v - let attr = execState c currentAttr + 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 fattr attr' diffs + 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 that was current at --- the time this was first used. Which, for most use cases, is the current terminal. +-- | Apply the provided display attributes changes to the terminal +-- output device. -- -- This will flush the terminal output. -putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m () -putAttrChange_ c = liftIO $ withOutput $ \out -> do +putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () +putAttrChange_ out c = liftIO $ do hFlush stdout putAttrChange out c hFlush stdout diff --git a/src/Graphics/Vty/Inline/Unsafe.hs b/src/Graphics/Vty/Inline/Unsafe.hs deleted file mode 100644 --- a/src/Graphics/Vty/Inline/Unsafe.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Graphics.Vty.Inline.Unsafe where - -import Graphics.Vty - -import Data.Default -import Data.Monoid -import Data.IORef - -import GHC.IO.Handle (hDuplicate) - -import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering)) - -import System.IO.Unsafe - -import System.Posix.IO (handleToFd) - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif - -globalVty :: IORef (Maybe Vty) -{-# NOINLINE globalVty #-} -globalVty = unsafePerformIO $ newIORef Nothing - -globalOutput :: IORef (Maybe Output) -{-# NOINLINE globalOutput #-} -globalOutput = unsafePerformIO $ newIORef Nothing - -mkDupeConfig :: IO Config -mkDupeConfig = do - hSetBuffering stdout NoBuffering - hSetBuffering stdin NoBuffering - stdinDupe <- hDuplicate stdin >>= handleToFd - stdoutDupe <- hDuplicate stdout >>= handleToFd - return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe } - --- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance. --- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'. --- --- This instance will use duplicates of the stdin and stdout Handles. -withVty :: (Vty -> IO b) -> IO b -withVty f = do - mvty <- readIORef globalVty - vty <- case mvty of - Nothing -> do - vty <- mkDupeConfig >>= mkVty - writeIORef globalVty (Just vty) - return vty - Just vty -> return vty - f vty - -withOutput :: (Output -> IO b) -> IO b -withOutput f = do - mout <- readIORef globalOutput - out <- case mout of - Nothing -> do - config <- mappend <$> userConfig <*> mkDupeConfig - out <- outputForConfig config - writeIORef globalOutput (Just out) - return out - Just out -> return out - f out diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs --- a/src/Graphics/Vty/Input.hs +++ b/src/Graphics/Vty/Input.hs @@ -1,206 +1,32 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - --- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can --- then be used to read 'Event's from the terminal. --- --- The history of terminals has resulted in a broken input process. Some keys and combinations will --- not reliably map to the expected events by any terminal program. Even those not using vty. There --- is no 1:1 mapping from key events to bytes read from the terminal input device. In very limited --- cases the terminal and vty's input process can be customized to resolve these issues. --- --- See "Graphics.Vty.Config" for how to configure vty's input processing. Customizing terminfo and --- the terminal is beyond the scope of this documentation. --- --- = VTY's Implementation --- --- One can get the brain rot trying to understand all this. So, as far as I can care... --- --- There are two input modes: --- --- 1. 7 bit --- --- 2. 8 bit --- --- 7 bit input is the default and the expected in most use cases. This is what vty uses. --- --- == 7 bit input encoding --- --- Control key combinations are represented by masking the two high bits of the 7bit input. Back in --- the day the control key actually grounded the two high bit wires: 6 and 7. This is why --- control key combos map to single character events: The input bytes are identical. The input byte --- is the bit encoding of the character with bits 6 and 7 masked. Bit 6 is set by shift. Bit 6 and --- 7 are masked by control. EG: --- --- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become `00001001`. Which is the ASCII --- and UTF-8 encoding of the tab key. --- --- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero which makes `0000011` and --- is the "End of Text" code. --- --- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This is the value 1 with bit 7 --- set and 6 unset. --- --- * Hypothesis: Bit 6 is unset by upper case letters because, initially, there were only upper case --- letters used and a 5 bit encoding. --- --- == 8 bit encoding --- --- The 8th bit was originally used for parity checking. Useless for emulators. Some terminal --- emulators support a 8 bit input encoding. While this provides some advantages the actual usage is --- low. Most systems use 7bit mode but recognize 8bit control characters when escaped. This is what --- vty does. --- --- == Escaped Control Keys --- --- Using 7 bit input encoding the @ESC@ byte can signal the start of an encoded control key. To --- differentiate a single @ESC@ eventfrom a control key the timing of the input is used. --- --- 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'. --- --- 2. control keys that contain @ESC@ in their encoding: The @ESC byte; followed by more bytes read --- within 'singleEscPeriod'. All bytes up until the next valid input block are passed to the --- classifier. --- --- If the current runtime is the threaded runtime then the terminal's @VMIN@ and @VTIME@ behavior --- reliably implement the above rules. If the current runtime does not support forkOS then there is --- currently no implementation. --- --- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop which did tricky things with --- non-blocking reads and timers. The implementation was not reliable. A reliable implementation is --- possible, but there are no plans to implement this. --- --- == Unicode Input and Escaped Control Key Sequences --- --- The input encoding determines how UTF-8 encoded characters are recognize. --- --- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is a superset of ASCII. UTF-8 does --- not overlap escaped control key sequences. However, the escape key must be differentiated from --- escaped control key sequences by the timing of the input bytes. --- --- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not require using the timing of --- input bytes to differentiate the escape key. Many terminals do not support 8 bit mode. --- --- == Terminfo --- --- The terminfo system is used to determine how some keys are encoded. Terminfo is incomplete. In --- some cases terminfo is incorrect. Vty assumes terminfo is correct but provides a mechanism to --- override terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'. --- --- == Terminal Input is Broken --- --- Clearly terminal input has fundemental issues. There is no easy way to reliably resolve these --- issues. --- --- One resolution would be to ditch standard terminal interfaces entirely and just go directly to --- scancodes. A reasonable option for vty if everybody used the linux kernel console. I hear GUIs --- are popular these days. Sadly, GUI terminal emulators don't provide access to scancodes AFAIK. --- --- All is lost? Not really. "Graphics.Vty.Config" supports customizing the input byte to event --- mapping and xterm supports customizing the scancode to input byte mapping. With a lot of work a --- user's system can be set up to encode all the key combos in an almost-sane manner. --- --- There are other tricky work arounds that can be done. I have no interest in implementing most of --- these. They are not really worth the time. --- --- == Terminal Output is Also Broken --- --- This isn't the only odd aspect of terminals due to historical aspects that no longer apply. EG: --- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes --- the control sequence to output red, for instance) This is to account for the slow speed of --- hardcopy teletype interfaces. Cause, uh, we totally still use those. --- --- The output encoding of colors and attributes are also rife with issues. --- --- == See also --- --- * http://www.leonerd.org.uk/hacks/fixterms/ --- --- In my experience this cannot resolve the issues without changes to the terminal emulator and --- device. -module Graphics.Vty.Input ( Key(..) - , Modifier(..) - , Button(..) - , Event(..) - , Input(..) - , inputForConfig - ) - where +-- | This module provides the input abstraction for Vty. +module Graphics.Vty.Input + ( Input(..) + , module Graphics.Vty.Input.Events + ) +where -import Graphics.Vty.Config import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Loop -import Graphics.Vty.Input.Terminfo - -import Control.Concurrent.STM -import Control.Lens - -import qualified System.Console.Terminfo as Terminfo -import System.Posix.Signals.Exts - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Functor ((<$>)) -import Data.Monoid -#else -import Data.Monoid ((<>)) -#endif +import Control.Concurrent.STM (TChan) --- | Set up the terminal with file descriptor `inputFd` for input. Returns a 'Input'. --- --- The table used to determine the 'Events' to produce for the input bytes comes from --- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from --- 'inputMap'. --- --- The terminal device is configured with the attributes: --- --- * IXON disabled --- - disables software flow control on outgoing data. This stops the process from being --- suspended if the output terminal cannot keep up. I presume this has little effect these --- days. I hope this means that output will be buffered if the terminal cannot keep up. In the --- old days the output might of been dropped? --- --- "raw" mode is used for input. --- --- * ISIG disabled --- - enables keyboard combinations that result in signals. TODO: should probably be a dynamic --- option. --- --- * ECHO disabled --- - input is not echod to the output. TODO: should be a dynamic option. --- --- * ICANON disabled --- - canonical mode (line mode) input is not used. TODO: should be a dynamic option. --- --- * IEXTEN disabled --- - extended functions are disabled. TODO: I don't know what those are. --- -inputForConfig :: Config -> IO Input -inputForConfig config@Config{ termName = Just termName - , inputFd = Just termFd - , vmin = Just _ - , vtime = Just _ - , .. } = do - terminal <- Terminfo.setupTerm termName - let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName] - activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides - (setAttrs,unsetAttrs) <- attributeControl termFd - setAttrs - input <- initInput config activeInputMap - let pokeIO = Catch $ do - let e = error "vty internal failure: this value should not propagate to users" - setAttrs - atomically $ writeTChan (input^.eventChannel) (EvResize e e) - _ <- installHandler windowChange pokeIO Nothing - _ <- installHandler continueProcess pokeIO Nothing - return $ input - { shutdownInput = do - shutdownInput input - _ <- installHandler windowChange Ignore Nothing - _ <- installHandler continueProcess Ignore Nothing - unsetAttrs - } -inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig +-- | The library's input-processing abstraction. Platform-specific +-- implementations must implement an 'Input' and provide it to +-- 'Graphics.Vty.mkVtyFromPair'. +data Input = + Input { eventChannel :: TChan InternalEvent + -- ^ A channel of events generated by input processing. The + -- input implementation must write its input events to this + -- channel; the Vty event loop will read from this channel + -- and provide the events to the user's application via + -- 'nextEvent'. + , shutdownInput :: IO () + -- ^ Shut down the input processing. As part of shutting down + -- the input, this should also restore the input state if + -- appropriate. + , restoreInputState :: IO () + -- ^ Restore the terminal's input state to what it was prior + -- to configuring the input for Vty. This should be done as + -- part of 'shutdownInput' but is exposed in case it needs to + -- be used directly. + , inputLogMsg :: String -> IO () + -- ^ Log the specified message. + } diff --git a/src/Graphics/Vty/Input/Classify.hs b/src/Graphics/Vty/Input/Classify.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Classify.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- This makes a kind of tri. Has space efficiency issues with large input blocks. --- Likely building a parser and just applying that would be better. --- I did not write this so I might just rewrite it for better understanding. Which is not the best --- of reasons. --- TODO: measure and rewrite if required. --- TODO: The ClassifyMap interface requires this code to always assure later entries override --- earlier. -module Graphics.Vty.Input.Classify - ( classify - , KClass(..) - ) where - -import Graphics.Vty.Input.Events - -import Codec.Binary.UTF8.Generic (decode) - -import Data.List(inits) -import qualified Data.Map as M( fromList, lookup ) -import Data.Maybe ( mapMaybe ) -import qualified Data.Set as S( fromList, member ) - -import Data.Char -import Data.Word - -data KClass - = Valid Event [Char] - | Invalid - | Prefix - deriving(Show, Eq) - -compile :: ClassifyMap -> [Char] -> KClass -compile table = cl' where - -- take all prefixes and create a set of these - prefixSet = S.fromList $ concatMap (init . inits . fst) $ table - maxValidInputLength = maximum (map (length . fst) table) - eventForInput = M.fromList table - cl' [] = Prefix - cl' inputBlock = case M.lookup inputBlock eventForInput of - -- if the inputBlock is exactly what is expected for an event then consume the whole - -- block and return the event - Just e -> Valid e [] - Nothing -> case S.member inputBlock prefixSet of - True -> Prefix - -- look up progressively smaller tails of the input block until an event is found - -- The assumption is that the event that consumes the most input bytes should be - -- produced. - -- The test verifyFullSynInputToEvent2x verifies this. - -- H: There will always be one match. The prefixSet contains, by definition, all - -- prefixes of an event. - False -> - let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock - in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of - (s,e) : _ -> Valid e (drop (length s) inputBlock) - -- neither a prefix or a full event. - -- TODO: debug log - [] -> Invalid - -classify :: ClassifyMap -> [Char] -> KClass -classify table = - let standardClassifier = compile table - in \s -> case s of - c:cs | ord c >= 0xC2 -> classifyUtf8 c cs - _ -> standardClassifier s - -classifyUtf8 :: Char -> [Char] -> KClass -classifyUtf8 c cs = - let n = utf8Length (ord c) - (codepoint,rest) = splitAt n (c:cs) - - codepoint8 :: [Word8] - codepoint8 = map (fromIntegral . ord) codepoint - - in case decode codepoint8 of - _ | n < length codepoint -> Prefix - Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest - Nothing -> Invalid -- something bad happened; just ignore and continue. - -utf8Length :: (Num t, Ord a, Num a) => a -> t -utf8Length c - | c < 0x80 = 1 - | c < 0xE0 = 2 - | c < 0xF0 = 3 - | otherwise = 4 diff --git a/src/Graphics/Vty/Input/Events.hs b/src/Graphics/Vty/Input/Events.hs --- a/src/Graphics/Vty/Input/Events.hs +++ b/src/Graphics/Vty/Input/Events.hs @@ -1,41 +1,100 @@ -module Graphics.Vty.Input.Events where +{-# 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. +-- * 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. +-- * 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 Char | KBS | KEnter +-- * 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 Int | KBackTab | KPrtScr | KPause | KIns + | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu - deriving (Eq,Show,Read,Ord) + deriving (Eq, Show, Read, Ord, Generic) --- | 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. +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) + deriving (Eq, Show, Read, Ord, Generic) +instance NFData Modifier + -- | Mouse buttons. --- --- \todo not supported. -data Button = BLeft | BMiddle | BRight - deriving (Eq,Show,Ord) +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] - -- | \todo mouse events are not supported - | EvMouse Int Int Button [Modifier] - -- | if read from 'eventChannel' this is the size at the time of the signal. If read from - -- 'nextEvent' this is the size at the time the event was processed by Vty. Typically these are - -- the same, but if somebody is resizing the terminal quickly they can be different. + -- ^ 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 - deriving (Eq,Show,Ord) + -- 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/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Loop.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} --- | The input layer used to be a single function that correctly accounted for the non-threaded --- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with --- a more straightforward parser. The non-threaded runtime is no longer supported. --- --- This is an example of an algorithm where code coverage could be high, even 100%, but the --- behavior is still under tested. I should collect more of these examples... --- --- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html -module Graphics.Vty.Input.Loop where - -import Graphics.Vty.Config -import Graphics.Vty.Input.Classify -import Graphics.Vty.Input.Events - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (mask, try, SomeException) -import Control.Lens -import Control.Monad (when, mzero, forM_) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State (StateT(..), evalStateT) -import Control.Monad.Trans.Reader (ReaderT(..)) - -import Data.Char -import Data.IORef -import Data.Word (Word8) - -import Foreign ( allocaArray, peekArray, Ptr ) -import Foreign.C.Types (CInt(..)) - -import System.IO -import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..)) -import System.Posix.Terminal -import System.Posix.Types (Fd(..)) - -import Text.Printf (hPrintf) - -data Input = Input - { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh - -- the display if the next event is an 'EvResize'. - _eventChannel :: TChan Event - -- | Shuts down the input processing. This should return the terminal input state to before - -- the input initialized. - , shutdownInput :: IO () - -- | Changes to this value are reflected after the next event. - , _configRef :: IORef Config - -- | input debug log - , _inputDebug :: Maybe Handle - } - -makeLenses ''Input - -data InputBuffer = InputBuffer - { _ptr :: Ptr Word8 - , _size :: Int - } - -makeLenses ''InputBuffer - -data InputState = InputState - { _unprocessedBytes :: String - , _appliedConfig :: Config - , _inputBuffer :: InputBuffer - , _classifier :: String -> KClass - } - -makeLenses ''InputState - -type InputM a = StateT InputState (ReaderT Input IO) a - -logMsg :: String -> InputM () -logMsg msg = do - d <- view inputDebug - case d of - Nothing -> return () - Just h -> liftIO $ hPutStrLn h msg >> hFlush h - --- this must be run on an OS thread dedicated to this input handling. --- otherwise the terminal timing read behavior will block the execution of the lightweight threads. -loopInputProcessor :: InputM () -loopInputProcessor = do - readFromDevice >>= addBytesToProcess - validEvents <- many parseEvent - forM_ validEvents emit - dropInvalid - loopInputProcessor - -addBytesToProcess :: String -> InputM () -addBytesToProcess block = unprocessedBytes <>= block - -emit :: Event -> InputM () -emit event = do - logMsg $ "parsed event: " ++ show event - view eventChannel >>= liftIO . atomically . flip writeTChan event - --- The timing requirements are assured by the VMIN and VTIME set for the device. --- --- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case --- satisfies precondition. --- TODO: When under the non-threaded runtime emulate VMIN and VTIME -readFromDevice :: InputM String -readFromDevice = do - newConfig <- view configRef >>= liftIO . readIORef - oldConfig <- use appliedConfig - let Just fd = inputFd newConfig - when (newConfig /= oldConfig) $ do - logMsg $ "new config: " ++ show newConfig - liftIO $ applyConfig fd newConfig - appliedConfig .= newConfig - bufferPtr <- use $ inputBuffer.ptr - maxBytes <- use $ inputBuffer.size - stringRep <- liftIO $ do - -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses - -- this provides a location to be interrupted prior to the foreign call. If there is input - -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime - -- terminal setting. - threadWaitRead fd - bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes) - if bytesRead > 0 - then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr - else return [] - when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep - return stringRep - -applyConfig :: Fd -> Config -> IO () -applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime }) - = setTermTiming fd theVmin (theVtime `div` 100) -applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration" - -parseEvent :: InputM Event -parseEvent = do - c <- use classifier - b <- use unprocessedBytes - case c b of - Valid e remaining -> do - logMsg $ "valid parse: " ++ show e - logMsg $ "remaining: " ++ show remaining - unprocessedBytes .= remaining - return e - _ -> mzero - -dropInvalid :: InputM () -dropInvalid = do - c <- use classifier - b <- use unprocessedBytes - when (c b == Invalid) $ do - logMsg "dropping input bytes" - unprocessedBytes .= [] - -runInputProcessorLoop :: ClassifyMap -> Input -> IO () -runInputProcessorLoop classifyTable input = do - let bufferSize = 1024 - allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do - s0 <- InputState [] <$> readIORef (_configRef input) - <*> pure (InputBuffer bufferPtr bufferSize) - <*> pure (classify classifyTable) - runReaderT (evalStateT loopInputProcessor s0) input - -attributeControl :: Fd -> IO (IO (), IO ()) -attributeControl fd = do - original <- getTerminalAttributes fd - let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts - , EnableEcho, ProcessInput, ExtendedFunctions - ] - let setAttrs = setTerminalAttributes fd vtyMode Immediately - unsetAttrs = setTerminalAttributes fd original Immediately - return (setAttrs,unsetAttrs) - -logInitialInputState :: Input -> ClassifyMap -> IO() -logInitialInputState input classifyTable = case _inputDebug input of - Nothing -> return () - Just h -> do - Config{ vmin = Just theVmin - , vtime = Just theVtime - , termName = Just theTerm, .. } <- readIORef $ _configRef input - _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime)) - forM_ classifyTable $ \i -> case i of - (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm) - (show inBytes) - (show k) - (show mods) - _ -> return () - -initInput :: Config -> ClassifyMap -> IO Input -initInput config classifyTable = do - let Just fd = inputFd config - setFdOption fd NonBlockingRead False - applyConfig fd config - stopSync <- newEmptyMVar - input <- Input <$> atomically newTChan - <*> pure (return ()) - <*> newIORef config - <*> maybe (return Nothing) - (\f -> Just <$> openFile f AppendMode) - (debugLog config) - logInitialInputState input classifyTable - inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input) - (\_ -> putMVar stopSync ()) - let killAndWait = do - killThread inputThread - takeMVar stopSync - return $ input { shutdownInput = killAndWait } - -foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO () - -forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId -forkOSFinally action and_then = - mask $ \restore -> forkOS $ try (restore action) >>= and_then diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Terminfo.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Graphics.Vty.Input.Terminfo where - -import Graphics.Vty.Input.Events -import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT - -import Control.Arrow -import System.Console.Terminfo - --- | queries the terminal for all capability based input sequences then adds on a terminal dependent --- input sequence mapping. --- --- For reference see: --- --- * http://vimdoc.sourceforge.net/htmldoc/term.html --- --- * vim74/src/term.c --- --- * http://invisible-island.net/vttest/ --- --- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html --- --- This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect. --- Vty assumes that the an internal terminfo table added to the system provided terminfo table is --- correct. --- --- 1. build terminfo table for all caps. Missing caps are not added. --- --- 2. add tables for visible chars, esc, del plus ctrl and meta --- --- 3. add internally defined table for given terminal type. --- --- Precedence is currently implicit in the 'compile' algorithm. Which is a bit odd. --- --- \todo terminfo meta is not supported. --- \todo no 8bit -classifyMapForTerm :: String -> Terminal -> ClassifyMap -classifyMapForTerm termName term = - concat $ capsClassifyMap term keysFromCapsTable - : universalTable - : termSpecificTables termName - --- | key table applicable to all terminals. --- --- TODO: some probably only applicable to ANSI/VT100 terminals. -universalTable :: ClassifyMap -universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys] - -capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap -capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table] - where extractCap = first (getCapability terminal . tiGetStr) - --- | tables specific to a given terminal that are not derivable from terminfo. --- --- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier. -termSpecificTables :: String -> [ClassifyMap] -termSpecificTables _termName = ANSIVT.classifyTable - --- | Visible characters in the ISO-8859-1 and UTF-8 common set. --- --- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this --- classify table is reached. --- --- TODO: resolve --- 1. start at ' '. The earlier characters are all 'ctrlChar' -visibleChars :: ClassifyMap -visibleChars = [ ([x], EvKey (KChar x) []) - | x <- [' ' .. toEnum 0xC1] - ] - --- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char. --- --- \todo resolve CTRL-i is the same as tab -ctrlChars :: ClassifyMap -ctrlChars = - [ ([toEnum x],EvKey (KChar y) [MCtrl]) - | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']) - , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. - , y /= 'h' -- CTRL-h should not hide BS - ] - --- | Ctrl+Meta+Char -ctrlMetaChars :: ClassifyMap -ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars - --- | esc, meta esc, delete, meta delete, enter, meta enter -specialSupportKeys :: ClassifyMap -specialSupportKeys = - [ -- special support for ESC - ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta]) - -- Special support for backspace - , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]) - -- Special support for Enter - , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter []) - -- explicit support for tab - , ("\t", EvKey (KChar '\t') []) - ] - --- | classify table directly generated from terminfo cap strings --- --- these are: --- --- * ka1 - keypad up-left --- --- * ka3 - keypad up-right --- --- * kb2 - keypad center --- --- * kbs - keypad backspace --- --- * kbeg - begin --- --- * kcbt - back tab --- --- * kc1 - keypad left-down --- --- * kc3 - keypad right-down --- --- * kdch1 - delete --- --- * kcud1 - down --- --- * kend - end --- --- * kent - enter --- --- * kf0 - kf63 - function keys --- --- * khome - KHome --- --- * kich1 - insert --- --- * kcub1 - left --- --- * knp - next page (page down) --- --- * kpp - previous page (page up) --- --- * kcuf1 - right --- --- * kDC - shift delete --- --- * kEND - shift end --- --- * kHOM - shift home --- --- * kIC - shift insert --- --- * kLFT - shift left --- --- * kRIT - shift right --- --- * kcuu1 - up -keysFromCapsTable :: ClassifyMap -keysFromCapsTable = - [ ("ka1", EvKey KUpLeft []) - , ("ka3", EvKey KUpRight []) - , ("kb2", EvKey KCenter []) - , ("kbs", EvKey KBS []) - , ("kbeg", EvKey KBegin []) - , ("kcbt", EvKey KBackTab []) - , ("kc1", EvKey KDownLeft []) - , ("kc3", EvKey KDownRight []) - , ("kdch1", EvKey KDel []) - , ("kcud1", EvKey KDown []) - , ("kend", EvKey KEnd []) - , ("kent", EvKey KEnter []) - , ("khome", EvKey KHome []) - , ("kich1", EvKey KIns []) - , ("kcub1", EvKey KLeft []) - , ("knp", EvKey KPageDown []) - , ("kpp", EvKey KPageUp []) - , ("kcuf1", EvKey KRight []) - , ("kDC", EvKey KDel [MShift]) - , ("kEND", EvKey KEnd [MShift]) - , ("kHOM", EvKey KHome [MShift]) - , ("kIC", EvKey KIns [MShift]) - , ("kLFT", EvKey KLeft [MShift]) - , ("kRIT", EvKey KRight [MShift]) - , ("kcuu1", EvKey KUp []) - ] ++ functionKeyCapsTable - --- | cap names for function keys -functionKeyCapsTable :: ClassifyMap -functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) []) diff --git a/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs b/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo. --- --- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often --- use VT50 input bytes regardless of declared terminal type. This provides compatibility with --- programs that don't follow terminfo. -module Graphics.Vty.Input.Terminfo.ANSIVT where - -import Graphics.Vty.Input.Events - --- | Encoding for navigation keys. --- --- TODO: This is not the same as the input bytes pulled from teh caps table. -navKeys0 :: ClassifyMap -navKeys0 = - [ k "G" KCenter - , k "P" KPause - , k "A" KUp - , k "B" KDown - , k "C" KRight - , k "D" KLeft - , k "H" KHome - , k "F" KEnd - , k "E" KBegin - ] - where k c s = ("\ESC["++c,EvKey s []) - --- | encoding for shift, meta and ctrl plus arrows/home/end -navKeys1 :: ClassifyMap -navKeys1 = - [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m) - | charCnt <- ["1;", ""], -- we can have a count or not - (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), - ([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 - ] - --- | encoding for ins, del, pageup, pagedown, home, end -navKeys2 :: ClassifyMap -navKeys2 = - let k n s = ("\ESC["++show n++"~",EvKey s []) - in zipWith k [2::Int,3,5,6,1,4] - [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] - --- | encoding for ctrl + ins, del, pageup, pagedown, home, end -navKeys3 :: ClassifyMap -navKeys3 = - let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl]) - in zipWith k [2::Int,3,5,6,1,4] - [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] - --- | encoding for shift plus function keys --- --- According to --- --- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html --- --- This encoding depends on the terminal. -functionKeys1 :: ClassifyMap -functionKeys1 = - let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in - concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ] - --- | encoding for meta plus char --- --- TODO: resolve - --- --- 1. removed 'ESC' from second list due to duplication with "special_support_keys". --- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is --- the same as ESC should examine km and current encoding. --- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by --- special_support_keys. -functionKeys2 :: ClassifyMap -functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta]) - | x <- '\t':[' ' .. '~'] - , x /= '[' - ] - -classifyTable :: [ClassifyMap] -classifyTable = - [ navKeys0 - , navKeys1 - , navKeys2 - , navKeys3 - , functionKeys1 - , functionKeys2 - ] - diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs --- a/src/Graphics/Vty/Output.hs +++ b/src/Graphics/Vty/Output.hs @@ -1,97 +1,367 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} --- | Output interface. --- --- Access to the current terminal or a specific terminal device. --- --- See also: --- --- 1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based --- on the TERM and COLORTERM environment variables. --- --- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement. --- --- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance that uses terminfo for all --- control strings. No attempt is made to change the character set to UTF-8 for these terminals. --- I don't know a way to reliably determine if that is required or how to do so. --- --- 4. "Graphics.Vty.Output.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. -module Graphics.Vty.Output ( module Graphics.Vty.Output - , Output(..) -- \todo hide constructors - , AssumedState(..) - , DisplayContext(..) -- \todo hide constructors - , outputPicture - , displayContext - ) - where - -import Graphics.Vty.Prelude - -import Graphics.Vty.Config - -import Graphics.Vty.Output.Interface -import Graphics.Vty.Output.XTermColor as XTermColor -import Graphics.Vty.Output.TerminfoBased as TerminfoBased +{-# 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 (writeToByteString) +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 Control.Monad.Trans +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 -import Data.List (isPrefixOf) -import Data.Monoid ((<>)) +-- | 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) --- | Returns a `Output` for the terminal specified in `Config` --- --- The specific Output implementation used is hidden from the API user. All terminal implementations --- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at --- least some terminal specific information. --- --- Specifics about it being based on terminfo are hidden from the API user. If a terminal --- implementation is developed for a terminal without terminfo support then Vty should work as --- expected on that terminal. --- --- Selection of a terminal is done as follows: --- --- * If TERM == xterm use XTermColor. --- * for any other TERM value TerminfoBased is used. --- --- \todo add an implementation for windows that does not depend on terminfo. Should be installable --- with only what is provided in the haskell platform. Use ansi-terminal -outputForConfig :: Config -> IO Output -outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do - t <- if "xterm" `isPrefixOf` termName - then XTermColor.reserveTerminal termName fd - -- Not an xterm-like terminal. try for generic terminfo. - else TerminfoBased.reserveTerminal termName fd - return t -outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig +-- | The library's device output abstraction. Platform-specific +-- implementations must implement an 'Output' and provide it to +-- 'Graphics.Vty.mkVtyFromPair'. +data Output = Output + { -- | Text identifier for the output device. Used for debugging. + terminalID :: String + -- | Release the terminal just prior to application exit and reset + -- it to its state prior to application startup. + , releaseTerminal :: IO () + -- | Clear the display and initialize the terminal to some initial + -- display state. + -- + -- The expectation of a program is that the display starts in some + -- The initial state. initial state would consist of fixed values: + -- + -- - cursor at top left + -- - UTF-8 character encoding + -- - drawing characteristics are the default + , reserveDisplay :: IO () + -- | Return the display to the state before `reserveDisplay` If no + -- previous state then set the display state to the initial state. + , releaseDisplay :: IO () + -- | Sets the current display bounds (width, height). + , setDisplayBounds :: (Int, Int) -> IO () + -- | Returns the current display bounds. + , displayBounds :: IO DisplayRegion + -- | Output the bytestring to the terminal device. + , outputByteBuffer :: BS.ByteString -> IO () + -- | Specifies whether the cursor can be shown / hidden. + , supportsCursorVisibility :: Bool + -- | Indicates support for terminal modes for this output device. + , supportsMode :: Mode -> Bool + -- | Enables or disables a mode (does nothing if the mode is + -- unsupported). + , setMode :: Mode -> Bool -> IO () + -- | Returns whether a mode is enabled. + , getModeStatus :: Mode -> IO Bool + , assumedStateRef :: IORef AssumedState + -- | Acquire display access to the given region of the display. + -- Currently all regions have the upper left corner of (0,0) and + -- the lower right corner at (max displayWidth providedWidth, max + -- displayHeight providedHeight) + , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext + -- | Ring the terminal bell if supported. + , ringTerminalBell :: IO () + -- | Returns whether the terminal has an audio bell feature. + , supportsBell :: IO Bool + -- | Returns whether the terminal supports italicized text. + -- + -- This is terminal-dependent and should make a best effort to + -- determine whether this feature is supported, but even if the + -- terminal advertises support (e.g. via terminfo) that might not + -- be a reliable indicator of whether the feature will work as + -- desired. + , supportsItalics :: IO Bool + -- | Returns whether the terminal supports strikethrough text. + -- + -- This is terminal-dependent and should make a best effort to + -- determine whether this feature is supported, but even if the + -- terminal advertises support (e.g. via terminfo) that might not + -- be a reliable indicator of whether the feature will work as + -- desired. + , supportsStrikethrough :: IO Bool + -- | Returns how many colors the terminal supports. + , outputColorMode :: ColorMode + -- | Set the output's window title, if any. + , setOutputWindowTitle :: String -> IO () + } -- | Sets the cursor position to the given output column and row. -- --- This is not necessarially the same as the character position with the same coordinates. --- Characters can be a variable number of columns in width. +-- 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 :: MonadIO m => Output -> Int -> Int -> m () +-- 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 - liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y + outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y --- | Hides the cursor -hideCursor :: MonadIO m => Output -> m () +-- | Hides the cursor. +hideCursor :: Output -> IO () hideCursor t = do bounds <- displayBounds t dc <- displayContext t bounds - liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc + outputByteBuffer t $ writeToByteString $ writeHideCursor dc --- | Shows the cursor -showCursor :: MonadIO m => Output -> m () +-- | Shows the cursor. +showCursor :: Output -> IO () showCursor t = do bounds <- displayBounds t dc <- displayContext t bounds - liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc + 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/Interface.hs b/src/Graphics/Vty/Output/Interface.hs deleted file mode 100644 --- a/src/Graphics/Vty/Output/Interface.hs +++ /dev/null @@ -1,265 +0,0 @@ --- Copyright Corey O'Connor --- General philosophy is: MonadIO is for equations exposed to clients. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -module Graphics.Vty.Output.Interface -where - -import Graphics.Vty.Prelude - -import Graphics.Vty.Picture -import Graphics.Vty.PictureToSpans -import Graphics.Vty.Span - -import Graphics.Vty.DisplayAttributes - -import Blaze.ByteString.Builder (Write, writeToByteString) -import Blaze.ByteString.Builder.ByteString (writeByteString) - -import Control.Monad.Trans - -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Vector as Vector - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (mempty, mappend) -#endif - -data Output = Output - { -- | Text identifier for the output device. Used for debugging. - terminalID :: String - , releaseTerminal :: forall m. MonadIO m => 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 released the display returns to the previous state. - , reserveDisplay :: forall m. MonadIO m => m () - -- | Return the display to the state before `reserveDisplay` - -- If no previous state then set the display state to the initial state. - , releaseDisplay :: forall m. MonadIO m => m () - -- | Returns the current display bounds. - , displayBounds :: forall m. MonadIO m => m DisplayRegion - -- | Output the byte string to the terminal device. - , outputByteBuffer :: BS.ByteString -> IO () - -- | Maximum number of colors supported by the context. - , contextColorCount :: Int - -- | if the cursor can be shown / hidden - , supportsCursorVisibility :: 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 :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext - } - -displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext -displayContext t = liftIO . 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 - -- | 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. - , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write - -- | Reset the display attributes to the default display attributes - , writeDefaultAttr :: 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`. --- --- 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. -outputPicture :: MonadIO m => DisplayContext -> Picture -> m () -outputPicture dc pic = liftIO $ do - as <- readIORef (assumedStateRef $ contextDevice dc) - let manipCursor = supportsCursorVisibility (contextDevice dc) - r = contextRegion dc - ops = displayOpsForPic pic r - initialAttr = FixedAttr defaultStyleMask Nothing Nothing - -- Diff the previous output against the requested output. Differences are currently on a per-row - -- basis. - -- \todo handle resizes that crop the dominate directions better. - diffs :: [Bool] = case prevOutputOps as of - Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True - Just previousOps -> if effectedRegion previousOps /= effectedRegion ops - then replicate (displayOpsRows ops) True - else zipWith (/=) (Vector.toList previousOps) - (Vector.toList ops) - -- build the Write corresponding to the output image - out = (if manipCursor then writeHideCursor dc else mempty) - `mappend` writeOutputOps dc initialAttr diffs ops - `mappend` - (case picCursor pic of - _ | not manipCursor -> mempty - NoCursor -> mempty - Cursor x y -> - let m = cursorOutputMap ops $ picCursor pic - (ox, oy) = charToOutputPos m (x,y) - in writeShowCursor dc `mappend` writeMoveCursor dc ox oy - ) - -- ... then serialize - outputByteBuffer (contextDevice dc) (writeToByteString out) - -- Cache the output spans. - let as' = as { prevOutputOps = Just ops } - writeIORef (assumedStateRef $ contextDevice dc) as' - -writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write -writeOutputOps 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 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 :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write -writeSpanOps 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 - -- then the span ops are serialized in the order specified - in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of - (opOut, fattr') -> (out `mappend` opOut, fattr') - ) - (start, initialAttr) - spanOps - -writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr) -writeSpanOp dc (TextSpan attr _ _ str) fattr = - let attr' = limitAttrForDisplay (contextDevice dc) attr - fattr' = fixDisplayAttr fattr attr' - diffs = displayAttrDiffs fattr fattr' - out = writeSetAttr dc fattr attr' diffs - `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str) - in (out, fattr') -writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip" -writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr) - --- | The cursor position is given in X,Y character offsets. Due to multi-column characters this --- needs to be translated to column, row positions. -data CursorOutputMap = CursorOutputMap - { charToOutputPos :: (Int, Int) -> (Int, Int) - } - -cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap -cursorOutputMap spanOps _cursor = CursorOutputMap - { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy) - } - -cursorColumnOffset :: DisplayOps -> Int -> Int -> Int -cursorColumnOffset ops cx cy = - let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy) - (outOffset, _, _) - = Vector.foldl' ( \(d, currentCx, done) op -> - if done then (d, currentCx, done) else case spanOpHasWidth op of - Nothing -> (d, currentCx, False) - Just (cw, ow) -> case compare cx (currentCx + cw) of - GT -> ( d + ow - , currentCx + cw - , False - ) - EQ -> ( d + ow - , currentCx + cw - , True - ) - LT -> ( d + columnsToCharOffset (cx - currentCx) op - , currentCx + cw - , True - ) - ) - (0, 0, False) - cursorRowOps - in outOffset - --- | Not all terminals support all display attributes. This filters a display attribute to what the --- given terminal can display. -limitAttrForDisplay :: Output -> Attr -> Attr -limitAttrForDisplay t attr - = attr { attrForeColor = clampColor $ attrForeColor attr - , attrBackColor = clampColor $ attrBackColor attr - } - where - clampColor Default = Default - clampColor KeepCurrent = KeepCurrent - clampColor (SetTo c) = clampColor' c - clampColor' (ISOColor v) - | contextColorCount t < 8 = Default - | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8) - | otherwise = SetTo $ ISOColor v - clampColor' (Color240 v) - -- TODO: Choose closes ISO color? - | contextColorCount t < 8 = Default - | contextColorCount t < 16 = Default - | contextColorCount t <= 256 = SetTo $ Color240 v - | otherwise - = let p :: Double = fromIntegral v / 240.0 - v' = floor $ p * (fromIntegral $ contextColorCount t) - in SetTo $ Color240 v' diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs --- a/src/Graphics/Vty/Output/Mock.hs +++ b/src/Graphics/Vty/Output/Mock.hs @@ -1,14 +1,18 @@ -- 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 nice for some tests. -module Graphics.Vty.Output.Mock ( MockData, mockTerminal ) - where - -import Graphics.Vty.Prelude +-- | 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.Output.Interface +import Graphics.Vty.Image (DisplayRegion) +import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16)) +import Graphics.Vty.Output import Blaze.ByteString.Builder.Word (writeWord8) @@ -20,18 +24,20 @@ 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 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. So requirement of the produced representation is simplicity in --- parsing the text representation and determining how the picture was mapped to terminal --- operations. +-- 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. +-- 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 @@ -41,30 +47,44 @@ , 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 - , contextColorCount = 16 , supportsCursorVisibility = True + , supportsMode = const False + , setMode = const $ const $ return () + , getModeStatus = const $ return False , assumedStateRef = newAssumedStateRef + , outputColorMode = ColorMode16 + , setOutputWindowTitle = const $ return () , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual - -- A cursor move is always visualized as the single character 'M' + -- 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' + -- 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' + -- 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 = writeWord8 $ toEnum $ fromEnum 'D' - -- row end is always visualized as the single character 'E' + -- 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/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs deleted file mode 100644 --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ /dev/null @@ -1,470 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} -{-# CFILES gwinsz.c #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - --- | Terminfo based terminal handling. --- --- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I --- have easy access to then color support is entirely based of the docs. Probably with some --- assumptions mixed in. --- --- Copyright Corey O'Connor (coreyoconnor@gmail.com) -module Graphics.Vty.Output.TerminfoBased ( reserveTerminal ) - where - -import Graphics.Vty.Prelude - -import Data.ByteString.Internal (toForeignPtr) -import Data.Terminfo.Parse -import Data.Terminfo.Eval - -import Graphics.Vty.Attributes -import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Output.Interface - -import Blaze.ByteString.Builder (Write, writeToByteString) - -import Control.Monad.Trans - -import Data.Bits ((.&.)) -import Data.IORef -import Data.Maybe (isJust, isNothing, fromJust) -import Data.Word - -import Foreign.C.Types ( CInt(..), CLong(..) ) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, plusPtr) - -import qualified System.Console.Terminfo as Terminfo -import System.Posix.IO (fdWriteBuf) -import System.Posix.Types (Fd(..)) - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable (foldMap) -import Data.Monoid -#endif - -data TerminfoCaps = TerminfoCaps - { smcup :: Maybe CapExpression - , rmcup :: Maybe CapExpression - , cup :: CapExpression - , cnorm :: Maybe CapExpression - , civis :: Maybe CapExpression - , supportsNoColors :: Bool - , useAltColorMap :: Bool - , setForeColor :: CapExpression - , setBackColor :: CapExpression - , setDefaultAttr :: CapExpression - , clearScreen :: CapExpression - , clearEol :: CapExpression - , displayAttrCaps :: DisplayAttrCaps - } - -data DisplayAttrCaps = DisplayAttrCaps - { setAttrStates :: Maybe CapExpression - , enterStandout :: Maybe CapExpression - , exitStandout :: Maybe CapExpression - , enterUnderline :: Maybe CapExpression - , exitUnderline :: Maybe CapExpression - , enterReverseVideo :: Maybe CapExpression - , enterDimMode :: Maybe CapExpression - , enterBoldMode :: Maybe CapExpression - } - --- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422 --- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried. -fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int -fdWriteAll outFd ptr len count - | len < 0 = fail "fdWriteAll: len is less than 0" - | len == 0 = return count - | otherwise = do - writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len) - let len' = len - writeCount - ptr' = ptr `plusPtr` writeCount - count' = count + writeCount - fdWriteAll outFd ptr' len' count' - -sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO () -sendCapToTerminal t cap capParams = do - outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams - -{- | 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. - -} -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output -reserveTerminal termName outFd = liftIO $ do - ti <- Terminfo.setupTerm termName - -- assumes set foreground always implies set background exists. - -- if set foreground is not set then all color changing style attributes are filtered. - msetaf <- probeCap ti "setaf" - msetf <- probeCap ti "setf" - let (noColors, useAlt, setForeCap) - = case msetaf of - Just setaf -> (False, False, setaf) - Nothing -> case msetf of - Just setf -> (False, True, setf) - Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName) - msetab <- probeCap ti "setab" - msetb <- probeCap ti "setb" - let set_back_cap - = case msetab of - Nothing -> case msetb of - Just setb -> setb - Nothing -> error $ "no back color support for terminal " ++ termName - Just setab -> setab - terminfoCaps <- pure TerminfoCaps - <*> probeCap ti "smcup" - <*> probeCap ti "rmcup" - <*> requireCap ti "cup" - <*> probeCap ti "cnorm" - <*> probeCap ti "civis" - <*> pure noColors - <*> pure useAlt - <*> pure setForeCap - <*> pure set_back_cap - <*> requireCap ti "sgr0" - <*> requireCap ti "clear" - <*> requireCap ti "el" - <*> currentDisplayAttrCaps ti - newAssumedStateRef <- newIORef initialAssumedState - let t = Output - { terminalID = termName - , releaseTerminal = liftIO $ do - sendCap setDefaultAttr [] - maybeSendCap cnorm [] - , reserveDisplay = liftIO $ do - -- If there is no support for smcup: Clear the screen and then move the mouse to the - -- home position to approximate the behavior. - maybeSendCap smcup [] - sendCap clearScreen [] - , releaseDisplay = liftIO $ do - maybeSendCap rmcup [] - maybeSendCap cnorm [] - , displayBounds = do - rawSize <- liftIO $ getWindowSize outFd - case rawSize of - (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize - | otherwise -> return (w,h) - , outputByteBuffer = \outBytes -> do - let (fptr, offset, len) = toForeignPtr outBytes - actualLen <- withForeignPtr fptr - $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0 - when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer " - ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen - ++ " Please report this bug to vty project." - , contextColorCount - = case supportsNoColors terminfoCaps of - False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of - Nothing -> 8 - Just v -> toEnum v - True -> 1 - , supportsCursorVisibility = isJust $ civis terminfoCaps - , assumedStateRef = newAssumedStateRef - -- I think fix would help assure tActual is the only reference. I was having issues - -- tho. - , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps - } - sendCap s = sendCapToTerminal t (s terminfoCaps) - maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) - return t - -requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression -requireCap ti capName - = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\"" - Just capStr -> parseCap capStr - -probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression) -probeCap ti capName - = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Nothing -> return Nothing - Just capStr -> Just <$> parseCap capStr - -parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression -parseCap capStr = do - case parseCapExpression capStr of - Left e -> fail $ show e - Right cap -> return cap - -currentDisplayAttrCaps :: ( Applicative m, MonadIO m ) - => Terminfo.Terminal - -> m DisplayAttrCaps -currentDisplayAttrCaps ti - = pure DisplayAttrCaps - <*> probeCap ti "sgr" - <*> probeCap ti "smso" - <*> probeCap ti "rmso" - <*> probeCap ti "smul" - <*> probeCap ti "rmul" - <*> probeCap ti "rev" - <*> probeCap ti "dim" - <*> probeCap ti "bold" - -foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong - -getWindowSize :: Fd -> IO (Int,Int) -getWindowSize fd = do - (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd - return (fromIntegral b, fromIntegral a) - -terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext -terminfoDisplayContext tActual terminfoCaps r = return dc - where dc = DisplayContext - { contextDevice = tActual - , contextRegion = r - , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x] - , writeShowCursor = case cnorm terminfoCaps of - Nothing -> error "this terminal does not support show cursor" - Just c -> writeCapExpr c [] - , writeHideCursor = case civis terminfoCaps of - Nothing -> error "this terminal does not support hide cursor" - Just c -> writeCapExpr c [] - , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps - , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) [] - , writeRowEnd = writeCapExpr (clearEol terminfoCaps) [] - , inlineHack = return () - } - --- | 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. --- --- \todo This assumes the removal of color changes in the display attributes is done as expected --- with noColors == True. See `limitAttrForDisplay` --- --- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I --- haven't measured this or even examined terminal implementations. *shrug* -terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write -terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do - case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of - -- The only way to reset either color, portably, to the default is to use either the set - -- state capability or the set default capability. - True -> do - case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) - (fixedStyle attr ) - (styleToApplySeq $ fixedStyle attr) of - -- only way to reset a color to the defaults - EnterExitSeq caps -> writeDefaultAttr dc - `mappend` - foldMap (\cap -> writeCapExpr cap []) caps - `mappend` - setColors - -- implicitly resets the colors to the defaults - SetState state -> writeCapExpr (fromJust $ setAttrStates - $ displayAttrCaps - $ terminfoCaps - ) - (sgrArgsForState state) - `mappend` - setColors - -- Otherwise the display colors are not changing or changing between two non-default - -- points. - False -> do - -- Still, it could be the case that the change in display attributes requires the - -- colors to be reset because the required capability was not available. - case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) - (fixedStyle attr) - (styleDiffs diffs) of - -- Really, if terminals were re-implemented with modern concepts instead of bowing - -- down to 40 yr old dumb terminal requirements this would be the only case ever - -- reached! Changes the style and color states according to the differences with - -- the currently applied states. - EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps - `mappend` - writeColorDiff setForeColor (foreColorDiff diffs) - `mappend` - writeColorDiff setBackColor (backColorDiff diffs) - -- implicitly resets the colors to the defaults - SetState state -> writeCapExpr (fromJust $ setAttrStates - $ displayAttrCaps terminfoCaps - ) - (sgrArgsForState state) - `mappend` setColors - where - colorMap = case useAltColorMap terminfoCaps of - False -> ansiColorIndex - True -> altColorIndex - attr = fixDisplayAttr prevAttr reqAttr - setColors = - (case fixedForeColor attr of - Just c -> writeCapExpr (setForeColor terminfoCaps) - [toEnum $ colorMap c] - Nothing -> mempty) - `mappend` - (case fixedBackColor attr of - Just c -> writeCapExpr (setBackColor terminfoCaps) - [toEnum $ colorMap c] - Nothing -> mempty) - writeColorDiff _f NoColorChange - = mempty - writeColorDiff _f ColorToDefault - = error "ColorToDefault is not a possible case for applyColorDiffs" - writeColorDiff f (SetColor c) - = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c] - --- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not --- be supported by the terminal. --- --- This takes a Color which clearly identifies which pallete to use and computes the index --- into the full 256 color pallete. -ansiColorIndex :: Color -> Int -ansiColorIndex (ISOColor v) = fromEnum v -ansiColorIndex (Color240 v) = 16 + fromEnum v - --- | For terminals without setaf/setab --- --- See table in `man terminfo` --- Will error if not in table. -altColorIndex :: Color -> Int -altColorIndex (ISOColor 0) = 0 -altColorIndex (ISOColor 1) = 4 -altColorIndex (ISOColor 2) = 2 -altColorIndex (ISOColor 3) = 6 -altColorIndex (ISOColor 4) = 1 -altColorIndex (ISOColor 5) = 5 -altColorIndex (ISOColor 6) = 3 -altColorIndex (ISOColor 7) = 7 -altColorIndex (ISOColor v) = fromEnum v -altColorIndex (Color240 v) = 16 + fromEnum v - -{- | The sequence of terminfo caps to apply a given style are determined according to these rules. - - - - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than - - the full set display attribute state capability. - - - - 2. If a mode is supposed to be removed but there is not an exit capability defined then the - - display attributes are reset to defaults then the display attribute state is set. - - - - 3. If a mode is supposed to be applied but there is not an enter capability defined then then - - display attribute state is set if possible. Otherwise the mode is not applied. - - - - 4. If the display attribute state is being set then just update the arguments to that for any - - apply/remove. - - - -} -data DisplayAttrSeq - = EnterExitSeq [CapExpression] - | SetState DisplayAttrState - -data DisplayAttrState = DisplayAttrState - { applyStandout :: Bool - , applyUnderline :: Bool - , applyReverseVideo :: Bool - , applyBlink :: Bool - , applyDim :: Bool - , applyBold :: Bool - } - -sgrArgsForState :: DisplayAttrState -> [CapParam] -sgrArgsForState attrState = map (\b -> if b then 1 else 0) - [ applyStandout attrState - , applyUnderline attrState - , applyReverseVideo attrState - , applyBlink attrState - , applyDim attrState - , applyBold attrState - , False -- invis - , False -- protect - , False -- alt char set - ] - -reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq -reqDisplayCapSeqFor caps s diffs - -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap - -- then either the state needs to be set or the attribute change ignored. - = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of - -- If all the diffs have an enter-exit cap then just use those - ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs - -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out - -- all unsupported diffs and just apply the rest - ( True, False ) -> EnterExitSeq $ map enterExitCap - $ filter (not . noEnterExitCap) diffs - -- if not all the diffs have an enter-exit can and there is a set state cap then just use - -- the set state cap. - ( True, True ) -> SetState $ stateForStyle s - where - noEnterExitCap ApplyStandout = isNothing $ enterStandout caps - noEnterExitCap RemoveStandout = isNothing $ exitStandout caps - noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps - noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps - noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps - noEnterExitCap RemoveReverseVideo = True - noEnterExitCap ApplyBlink = True - noEnterExitCap RemoveBlink = True - noEnterExitCap ApplyDim = isNothing $ enterDimMode caps - noEnterExitCap RemoveDim = True - noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps - noEnterExitCap RemoveBold = True - enterExitCap ApplyStandout = fromJust $ enterStandout caps - enterExitCap RemoveStandout = fromJust $ exitStandout caps - enterExitCap ApplyUnderline = fromJust $ enterUnderline caps - enterExitCap RemoveUnderline = fromJust $ exitUnderline caps - enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps - enterExitCap ApplyDim = fromJust $ enterDimMode caps - enterExitCap ApplyBold = fromJust $ enterBoldMode caps - enterExitCap _ = error "enterExitCap applied to diff that was known not to have one." - -stateForStyle :: Style -> DisplayAttrState -stateForStyle s = DisplayAttrState - { applyStandout = isStyleSet standout - , applyUnderline = isStyleSet underline - , applyReverseVideo = isStyleSet reverseVideo - , applyBlink = isStyleSet blink - , applyDim = isStyleSet dim - , applyBold = isStyleSet bold - } - where isStyleSet = hasStyle s - -styleToApplySeq :: Style -> [StyleStateChange] -styleToApplySeq s = concat - [ applyIfRequired ApplyStandout standout - , applyIfRequired ApplyUnderline underline - , applyIfRequired ApplyReverseVideo reverseVideo - , applyIfRequired ApplyBlink blink - , applyIfRequired ApplyDim dim - , applyIfRequired ApplyBlink bold - ] - where - applyIfRequired op flag - = if 0 == (flag .&. s) - then [] - else [op] - diff --git a/src/Graphics/Vty/Output/XTermColor.hs b/src/Graphics/Vty/Output/XTermColor.hs deleted file mode 100644 --- a/src/Graphics/Vty/Output/XTermColor.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - --- Copyright 2009-2010 Corey O'Connor -module Graphics.Vty.Output.XTermColor ( reserveTerminal ) - where - -import Graphics.Vty.Output.Interface -import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased - -import Blaze.ByteString.Builder (writeToByteString) -import Blaze.ByteString.Builder.Word (writeWord8) - -import Control.Monad (void) -import Control.Monad.Trans - -import System.Posix.IO (fdWrite) -import System.Posix.Types (Fd) - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Foldable (foldMap) -#endif - --- | Initialize the display to UTF-8. -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output -reserveTerminal variant outFd = liftIO $ do - let flushedPut = void . fdWrite outFd - -- If the terminal variant is xterm-color use xterm instead since, more often than not, - -- xterm-color is broken. - let variant' = if variant == "xterm-color" then "xterm" else variant - flushedPut setUtf8CharSet - t <- TerminfoBased.reserveTerminal variant' outFd - let t' = t - { terminalID = terminalID t ++ " (xterm-color)" - , releaseTerminal = do - liftIO $ flushedPut setDefaultCharSet - releaseTerminal t - , mkDisplayContext = \tActual r -> do - dc <- mkDisplayContext t tActual r - return $ dc { inlineHack = xtermInlineHack t' } - } - return t' - --- | These sequences set xterm based terminals to UTF-8 output. --- --- \todo I don't know of a terminfo cap that is equivalent to this. -setUtf8CharSet, setDefaultCharSet :: String -setUtf8CharSet = "\ESC%G" -setDefaultCharSet = "\ESC%@" - --- | I think xterm is broken: Reseting the background color as the first bytes serialized on a --- new line does not effect the background color xterm uses to clear the line. Which is used --- *after* the next newline. -xtermInlineHack :: Output -> IO () -xtermInlineHack t = do - let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K" - outputByteBuffer t $ writeToByteString writeReset - 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,105 +1,128 @@ -{-# LANGUAGE BangPatterns #-} --- | The 'Picture' data structure is representative of the final terminal view. --- --- A 'Picture' is a background paired with a layer of 'Image's. -module Graphics.Vty.Picture ( module Graphics.Vty.Picture - , module Graphics.Vty.Image - ) - 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 Control.DeepSeq --- | The type of images to be displayed using 'update'. +-- | A Vty picture. -- --- Can be constructed directly or using `picForImage`. Which provides an initial instance with --- reasonable defaults for picCursor and picBackground. +-- These can be constructed directly or using `picForImage`. data Picture = Picture { picCursor :: Cursor + -- ^ The picture's cursor. , picLayers :: [Image] + -- ^ The picture's image layers (top-most first). , picBackground :: Background - } - -instance Show Picture where - show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??" + -- ^ The picture's background to be displayed in locations with no + -- Image data. + } deriving (Eq, Show) instance NFData Picture where rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () --- | a picture with no cursor, background or image layers +-- | A picture with no cursor, background or image layers. emptyPicture :: Picture emptyPicture = Picture NoCursor [] ClearBackground --- | The given 'Image' is added as the top layer of the 'Picture' +-- | Add an 'Image' as the top-most layer of a 'Picture'. addToTop :: Picture -> Image -> Picture addToTop p i = p {picLayers = i : picLayers p} --- | The given 'Image' is added as the bottom layer of the 'Picture' +-- | 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 for display for the given image. The picture will not have a displayed cursor --- and no background pattern (ClearBackground) will be used. +-- | 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 +picForImage i = Picture { picCursor = NoCursor , picLayers = [i] , picBackground = ClearBackground } --- | Create a picture for display with the given layers. Ordered top to bottom. +-- | Create a picture with the given layers, top-most first. -- --- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be --- used. --- --- The first 'Image' is the top layer. +-- The picture will not have a displayed cursor and no background +-- pattern (ClearBackgroun) will be used. picForLayers :: [Image] -> Picture -picForLayers is = Picture +picForLayers is = Picture { picCursor = NoCursor , picLayers = is , picBackground = ClearBackground } --- | A picture can be configured either to not show the cursor or show the cursor at the specified --- character position. --- --- 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. +-- | 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 Int Int +-- There is not a 1:1 map from character positions to a row and column +-- on the screen due to characters that take more than 1 column. +data Cursor = + -- | Hide the cursor + NoCursor + -- | Set the terminal's cursor position without displaying a cursor + -- character. This is important for accessibility with screen + -- readers where a cursor position needs to be reported but we may + -- not want to show a block cursor in that location for cosmetic + -- reasons. The boolean argument indicates whether the positioning + -- should be absolute as with 'AbsoluteCursor' ('True') or logical + -- as with 'Cursor' ('False'). + | PositionOnly !Bool !Int !Int + -- | Show the cursor at the given logical column accounting for + -- character width in the presence of multi-column characters. + | Cursor !Int !Int + -- | Show the cursor at the given absolute terminal column and row + | AbsoluteCursor !Int !Int + deriving (Eq, Show) instance NFData Cursor where - rnf NoCursor = () - rnf (Cursor w h) = w `seq` h `seq` () + rnf c = c `seq` () --- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the --- layer below or is blank if the bottom layer. Or the background pattern is a character and a --- display attribute. If the display attribute used previously should be used for a background fill --- then use `currentAttr` for the background attribute. +-- | 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 +-- +-- If the display attribute used previously should be used for a +-- background fill then use `currentAttr` for the background attribute. data Background - = Background + = Background { backgroundChar :: Char , backgroundAttr :: Attr } - -- | A ClearBackground is: + -- | 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 = () --- | Compatibility with applications that do not use more than a single layer. +-- | 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 --- a/src/Graphics/Vty/PictureToSpans.hs +++ b/src/Graphics/Vty/PictureToSpans.hs @@ -1,35 +1,27 @@ -- Copyright Corey O'Connor {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -#ifndef MIN_VERSION_base -#defined MIN_VERSION_base(x,y,z) 1 -#endif - -{- | Transforms an image into rows of operations. - -} -module Graphics.Vty.PictureToSpans where - -import Graphics.Vty.Prelude +-- | 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 Control.Lens hiding ( op ) +import Lens.Micro +import Lens.Micro.Mtl +import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) - -#if __GLASGOW_HASKELL__ < 708 -import Control.Monad.ST.Strict hiding ( unsafeIOToST ) -#else import Control.Monad.ST.Strict -#endif import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..)) @@ -37,70 +29,77 @@ import qualified Data.Text.Lazy as TL -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (mappend) -#endif - type MRowOps s = MVector s SpanOps -type MSpanOps s = MVector s SpanOp - -- transform plus clip. More or less. data BlitState = BlitState - -- we always snoc to the operation vectors. Thus the columnOffset = 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. + -- 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. + -- 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. + -- 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 } -makeLenses ''BlitState +columnOffset :: Lens' BlitState Int +columnOffset = lens _columnOffset (\e v -> e { _columnOffset = v }) +rowOffset :: Lens' BlitState Int +rowOffset = lens _rowOffset (\e v -> e { _rowOffset = v }) + +skipColumns :: Lens' BlitState Int +skipColumns = lens _skipColumns (\e v -> e { _skipColumns = v }) + +skipRows :: Lens' BlitState Int +skipRows = lens _skipRows (\e v -> e { _skipRows = v }) + +remainingColumns :: Lens' BlitState Int +remainingColumns = lens _remainingColumns (\e v -> e { _remainingColumns = v }) + +remainingRows :: Lens' BlitState Int +remainingRows = lens _remainingRows (\e v -> e { _remainingRows = v }) + data BlitEnv s = BlitEnv { _region :: DisplayRegion , _mrowOps :: MRowOps s } -makeLenses ''BlitEnv +region :: Lens' (BlitEnv s) DisplayRegion +region = lens _region (\e r -> e { _region = r }) +mrowOps :: Lens' (BlitEnv s) (MRowOps s) +mrowOps = lens _mrowOps (\e r -> e { _mrowOps = r }) + type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a --- | Produces the span ops that will render the given picture, possibly cropped or padded, into the --- specified region. +-- | 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) --- | Returns the DisplayOps for an image rendered to a window the size of the image. --- --- largerly used only for debugging. -displayOpsForImage :: Image -> DisplayOps -displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i) - -- | Produces the span ops for each layer then combines them. --- --- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire --- region. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0 | otherwise = do - layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic) + layerOps <- mapM (`buildSpans` r) (picLayers pic) case layerOps of - [] -> fail "empty picture" + [] -> error "empty picture" [ops] -> substituteSkips (picBackground pic) ops - -- instead of merging ops after generation the merging can be performed as part of - -- snocOp. + -- 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 @@ -109,23 +108,25 @@ 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 - -- todo: or does it? + -- 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. + -- 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. + -- At this point we decide if the background character is single + -- column or not. obviously, single column is easier. case safeWcwidth backgroundChar of - w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar + w | w == 0 -> error $ "invalid background character " ++ show backgroundChar | w == 1 -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row @@ -147,12 +148,12 @@ MVector.write upper row rowOps return upper --- fugly mergeRowUnder :: SpanOps -> SpanOps -> SpanOps -mergeRowUnder upperRowOps lowerRowOps = - onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps +mergeRowUnder upperRowOps = + onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) where - -- H: it will never be the case that we are out of upper ops before lower ops. + -- 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 @@ -171,7 +172,7 @@ swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f - where f (Skip ow) = let txt = TL.pack $ replicate ow c + where f (Skip ow) = let txt = TL.take (toEnum ow) $ TL.repeat c in TextSpan a ow ow txt f v = v @@ -187,30 +188,32 @@ in TextSpan a ow cw txt f v = v --- | Builds a vector of row operations that will output the given picture to the terminal. +-- | Builds a vector of row operations that will output the given +-- picture to the terminal. -- -- Crops to the given display region. --- --- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer. 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 - -- \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. + -- 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. + -- 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. + -- 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. + -- 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. @@ -221,7 +224,8 @@ return () return outOps --- | Add the operations required to build a given image to the current set of row operations. +-- | 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 @@ -229,23 +233,22 @@ isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s - | s ^. remainingColumns <= 0 = True - | s ^. remainingRows <= 0 = True + | s ^. remainingColumns <= 0 = True + | s ^. remainingRows <= 0 = True | s ^. skipColumns >= imageWidth i = True | s ^. skipRows >= imageHeight i = True | otherwise = False --- | This adds an image that might be partially clipped to the output ops. --- --- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom --- implementations are odd. They pass the current tests but something seems terribly wrong about all --- this. +-- | 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. -- --- \todo prove this cannot be called in an out of bounds case. addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do - -- TODO: assumption that text spans are only 1 row high. + -- This assumes that text spans are only 1 row high. s <- use skipRows when (s < 1) $ do leftClip <- use skipColumns @@ -257,43 +260,35 @@ in addUnclippedText a textStr' else addUnclippedText a textStr addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do - addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset - (imageHeight topImage) - topImage - bottomImage - oh + when (imageHeight topImage + imageHeight bottomImage > 0) $ + addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset + (imageHeight topImage) + topImage + bottomImage + oh addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do - addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset - (imageWidth leftImage) - leftImage - rightImage - ow + 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 CropRight {croppedImage, outputWidth} = do - s <- use skipColumns - r <- use remainingColumns - let x = outputWidth - s - when (x < r) $ remainingColumns .= x - addMaybeClipped croppedImage -addMaybeClipped CropLeft {croppedImage, leftSkip} = do +addMaybeClipped Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight} = do + sx <- use skipColumns skipColumns += leftSkip - addMaybeClipped croppedImage -addMaybeClipped CropBottom {croppedImage, outputHeight} = do - s <- use skipRows - r <- use remainingRows - let x = outputHeight - s - when (x < r) $ remainingRows .= x - addMaybeClipped croppedImage -addMaybeClipped CropTop {croppedImage, topSkip} = do + modifying remainingColumns (min (outputWidth - sx)) + sy <- use skipRows skipRows += topSkip + modifying remainingRows (min (outputHeight - sy)) addMaybeClipped croppedImage -addMaybeClippedJoin :: forall s . String +addMaybeClippedJoin :: forall s . String -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int @@ -304,14 +299,13 @@ -> BlitM s () addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do state <- get - when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0" + when (state^.remaining <= 0) $ error $ name ++ " with remaining <= 0" case state^.skip of - s -- TODO: check if clipped in other dim. if not use addUnclipped - | s >= size -> fail $ name ++ " on fully clipped" - | s == 0 -> if state^.remaining > i0Dim + s | s > size -> put $ state & skip %~ subtract size + | s == 0 -> if state^.remaining > i0Dim then do addMaybeClipped i0 - put $ state & offset +~ i0Dim & remaining -~ i0Dim + put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim addMaybeClipped i1 else addMaybeClipped i0 | s < i0Dim -> @@ -320,26 +314,26 @@ then addMaybeClipped i0 else do addMaybeClipped i0 - put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0 + put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0 addMaybeClipped i1 | s >= i0Dim -> do - put $ state & skip -~ i0Dim + put $ state & skip %~ subtract i0Dim addMaybeClipped i1 - _ -> fail $ name ++ " has unhandled skip class" + _ -> error $ name ++ " has unhandled skip class" -addUnclippedText :: Attr -> DisplayText -> BlitM s () +addUnclippedText :: Attr -> TL.Text -> BlitM s () addUnclippedText a txt = do let op = TextSpan a usedDisplayColumns (fromIntegral $ TL.length txt) txt - usedDisplayColumns = wcswidth $ TL.unpack 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 = spanOpsEffectedColumns rowOps + let endX = spanOpsAffectedColumns rowOps when (endX < regionWidth displayRegion) $ do let ow = regionWidth displayRegion - endX snocOp (Skip ow) row @@ -352,6 +346,6 @@ lift $ lift $ do ops <- MVector.read theMrowOps row let ops' = Vector.snoc ops op - when (spanOpsEffectedColumns ops' > regionWidth theRegion) - $ fail $ "row " ++ show row ++ " now exceeds region width" + when (spanOpsAffectedColumns ops' > regionWidth theRegion) + $ error $ "row " ++ show row ++ " now exceeds region width" MVector.write theMrowOps row ops' diff --git a/src/Graphics/Vty/Prelude.hs b/src/Graphics/Vty/Prelude.hs deleted file mode 100644 --- a/src/Graphics/Vty/Prelude.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | Prelude for Vty modules. Not particularly useful outside of Vty. -module Graphics.Vty.Prelude ( module Graphics.Vty.Prelude - , module Control.Applicative - , module Control.Monad - ) -where - -import Control.Applicative hiding ((<|>)) -import Control.Monad - --- | Named alias for a Int pair -type DisplayRegion = (Int,Int) - -regionWidth :: DisplayRegion -> Int -regionWidth = fst - -regionHeight :: DisplayRegion -> Int -regionHeight = snd 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,23 +1,30 @@ -- Copyright Corey O'Connor -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} -{- | 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 `spansForPic`. - - - - todo: Partition attribute changes into multiple categories according to the serialized - - representation of the various attributes. - -} +-- | 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.Prelude + , SpanOps + , spanOpsAffectedColumns + , splitOpsAt + , dropOps + , DisplayOps + , displayOpsRows + , displayOpsColumns + , affectedRegion + ) +where + +import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) @@ -25,40 +32,40 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector --- | This represents an operation on the terminal. Either an attribute change or the output of a --- text string. +-- | 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 necessarially represent 1 colunm. See Codec.Binary.UTF8.Width - -- TextSpan [Attr] [output width in columns] [number of characters] [data] - TextSpan + -- | 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 :: DisplayText + , textSpanText :: TL.Text } - -- | Skips the given number of columns - -- A skip is transparent.... maybe? I am not sure how attribute changes interact. - -- todo: separate from this type. + -- | 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 + -- | 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. - -- todo: separate from this type. | 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 dropOps :: Int -> SpanOps -> SpanOps dropOps w = snd . splitOpsAt w splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps) -splitOpsAt inW inOps = splitOpsAt' inW inOps +splitOpsAt = splitOpsAt' where splitOpsAt' 0 ops = (Vector.empty, ops) splitOpsAt' remainingColumns ops = case Vector.head ops of @@ -89,9 +96,9 @@ , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops) ) RowEnd _ -> error "cannot split ops containing a row end" - --- | vector of span operation vectors for display. One per row of the output region. +-- | A vector of span operation vectors for display, one per row of the +-- output region. type DisplayOps = Vector SpanOps instance Show SpanOp where @@ -99,40 +106,39 @@ show (Skip ow) = "Skip(" ++ show ow ++ ")" show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" --- | Number of columns the DisplayOps are defined for +-- | The number of columns the DisplayOps are defined for. -- --- All spans are verified to define same number of columns. See: VerifySpanOps +-- All spans are verified to define same number of columns. displayOpsColumns :: DisplayOps -> Int -displayOpsColumns ops +displayOpsColumns ops | Vector.length ops == 0 = 0 | otherwise = Vector.length $ Vector.head ops --- | Number of rows the DisplayOps are defined for +-- | The number of rows the DisplayOps are defined for. displayOpsRows :: DisplayOps -> Int -displayOpsRows ops = Vector.length ops +displayOpsRows = Vector.length -effectedRegion :: DisplayOps -> DisplayRegion -effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) +affectedRegion :: DisplayOps -> DisplayRegion +affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) --- | The number of columns a SpanOps effects. -spanOpsEffectedColumns :: SpanOps -> Int -spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps - where - spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w - spanOpsEffectedColumns' t (Skip w) = t + w - spanOpsEffectedColumns' t (RowEnd w) = t + w +-- | The number of columns a SpanOps affects. +spanOpsAffectedColumns :: SpanOps -> Int +spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps + where + spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w + spanOpsAffectedColumns' t (Skip w) = t + w + spanOpsAffectedColumns' t (RowEnd w) = t + w --- | The width of a single SpanOp in columns +-- | 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) --- | returns the number of columns to the character at the given position in the span op +-- | The number of columns to the character at the given position in the +-- span op. columnsToCharOffset :: Int -> SpanOp -> Int columnsToCharOffset cx (TextSpan _ _ _ utf8Str) = - let str = TL.unpack utf8Str - in wcswidth (take cx str) + wctlwidth (TL.take (fromIntegral cx) utf8Str) columnsToCharOffset cx (Skip _) = cx columnsToCharOffset cx (RowEnd _) = cx - 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,100 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module Verify ( module Verify - , module Control.Applicative - , module Control.DeepSeq - , module Control.Exception - , module Control.Monad - , module Test.QuickCheck - , module Test.QuickCheck.Modifiers - , module Text.Printf - , succeeded - , failed - , monadicIO - , liftIO - , liftBool - , Test(..) - , Prop.Result(..) - ) - where - -import Control.Exception ( bracket, try, SomeException(..) ) - -import Distribution.TestSuite hiding ( Result(..) ) -import qualified Distribution.TestSuite as TS - -import Test.QuickCheck hiding ( Result(..) ) -import qualified Test.QuickCheck as QC -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Property hiding ( Result(..) ) -import qualified Test.QuickCheck.Property as Prop -import Test.QuickCheck.Monadic ( monadicIO ) - -import Text.Printf - -import qualified Codec.Binary.UTF8.String as UTF8 - -import Control.Applicative hiding ( (<|>) ) -import Control.DeepSeq -import Control.Monad ( forM, mapM, mapM_, forM_ ) -import Control.Monad.State.Strict - -import Numeric ( showHex ) - -verify :: Testable t => String -> t -> Test -verify testName p = Test $ TestInstance - { name = testName - , run = do - qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p - case qcResult of - QC.Success {..} -> return $ Finished TS.Pass - QC.Failure {numShrinks,reason} -> return $ Finished - $ TS.Fail $ "After " - ++ show numShrinks ++ " shrinks determined failure to be: " - ++ show reason - _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message" - , tags = [] - , options = [] - , setOption = \_ _ -> Left "no options supported" - } - -data SingleColumnChar = SingleColumnChar Char - deriving (Show, Eq) - -instance Arbitrary SingleColumnChar where - arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E] - -data DoubleColumnChar = DoubleColumnChar Char - deriving (Eq) - -instance Show DoubleColumnChar where - show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c] - -instance Arbitrary DoubleColumnChar where - arbitrary = elements $ map DoubleColumnChar $ - [ toEnum 0x3040 .. toEnum 0x3098 ] - ++ [ toEnum 0x309B .. toEnum 0xA4CF ] - -liftIOResult :: Testable prop => IO prop -> Property -liftIOResult = ioProperty - -#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 - -data Bench where - Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench - 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,112 +0,0 @@ -module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse - , module Data.Terminfo.Parse - ) - where - -import Data.Terminfo.Parse -import Data.Terminfo.Eval -import Verify - -import Data.Word -import qualified Data.Vector.Unboxed as Vector - -import Numeric - -hexDump :: [Word8] -> String -hexDump bytes = foldr (\b s -> showHex b s) "" bytes - -data NonParamCapString = NonParamCapString String - deriving Show - -instance Arbitrary NonParamCapString where - arbitrary - = ( do - s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%') - return $ NonParamCapString s - ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) - -data LiteralPercentCap = LiteralPercentCap String [Word8] - deriving ( Show ) - -instance Arbitrary LiteralPercentCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s - return $ LiteralPercentCap s' bytes - ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) - -data IncFirstTwoCap = IncFirstTwoCap String [Word8] - deriving ( Show ) - -instance Arbitrary IncFirstTwoCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - (s', bytes) <- insertEscapeOp "i" [] s - return $ IncFirstTwoCap s' bytes - ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) - -data PushParamCap = PushParamCap String Int [Word8] - deriving ( Show ) - -instance Arbitrary PushParamCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - n <- choose (1,9) - (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s - return $ PushParamCap s' n bytes - ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) - -data DecPrintCap = DecPrintCap String Int [Word8] - deriving ( Show ) - -instance Arbitrary DecPrintCap where - arbitrary - = ( do - NonParamCapString s <- arbitrary - n <- choose (1,9) - (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s - return $ DecPrintCap s' n bytes - ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) - -insertEscapeOp opStr replBytes s = do - insertPoints <- listOf1 $ elements [0 .. length s - 1] - let s' = f s ('%' : opStr) - remainingBytes = f (map (toEnum . fromEnum) s) replBytes - f inVs out_v = concat [ vs - | vi <- zip inVs [0 .. length s - 1] - , let vs = fst vi : ( if snd vi `elem` insertPoints - then out_v - else [] - ) - ] - return (s', remainingBytes) - -isBytesOp :: CapOp -> Bool -isBytesOp (Bytes {}) = True --- isBytesOp _ = False - -bytesForRange cap offset count - = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap - -collectBytes :: CapExpression -> [Word8] -collectBytes e = concat [ bytes - | Bytes offset count <- capOps e - , let bytes = bytesForRange e offset count - ] - - -verifyBytesEqual :: [Word8] -> [Word8] -> Result -verifyBytesEqual outBytes expectedBytes - = if outBytes == expectedBytes - then succeeded - else failed - { reason = "outBytes [" - ++ hexDump outBytes - ++ "] /= expectedBytes [" - ++ hexDump expectedBytes - ++ "]" - } - 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,73 +0,0 @@ -module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes - , module Graphics.Vty.Attributes - ) - where - -import Graphics.Vty.Attributes -import Verify - -import Data.List ( delete ) - -allColors :: [Color] -allColors = - [ black - , red - , green - , yellow - , blue - , magenta - , cyan - , white - , brightBlack - , brightRed - , brightGreen - , brightYellow - , brightBlue - , brightMagenta - , brightCyan - , brightWhite - ] ++ map Color240 [0..239] - -allStyles :: [Style] -allStyles = - [ standout - , underline - , reverseVideo - , blink - , dim - , bold - ] - --- Limit the possible attributes to just a few for now. -possibleAttrMods :: [ AttrOp ] -possibleAttrMods = - [ idOp - ] ++ map setForeColorOp allColors - ++ map setBackColorOp allColors - ++ map setStyleOp allStyles - -instance Arbitrary Attr where - arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr - -data DiffAttr = DiffAttr Attr Attr - -instance Arbitrary DiffAttr where - arbitrary = do - op0 <- elements possibleAttrMods - let possibleAttrMods' = delete op0 possibleAttrMods - op1 <- elements possibleAttrMods' - return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr) - -data AttrOp = AttrOp String (Attr -> Attr) - -instance Eq AttrOp where - AttrOp n0 _ == AttrOp n1 _ = n0 == n1 - -setStyleOp s = AttrOp "set_style" (flip withStyle s) -setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c) -setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c) -idOp = AttrOp "id" id - -applyOp :: AttrOp -> Attr -> Attr -applyOp (AttrOp _ f) a = f a - diff --git a/test/Verify/Graphics/Vty/DisplayAttributes.hs b/test/Verify/Graphics/Vty/DisplayAttributes.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/DisplayAttributes.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes - , module Graphics.Vty.DisplayAttributes - ) - where - -import Graphics.Vty.DisplayAttributes -import Verify - 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,218 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DisambiguateRecordFields #-} -module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image - , module Graphics.Vty.Image - ) - where - -import Verify.Graphics.Vty.Attributes -import Graphics.Vty.Image -import Graphics.Vty.Image.Internal - -import Verify - -data UnitImage = UnitImage Char Image - -instance Arbitrary UnitImage where - arbitrary = do - SingleColumnChar c <- arbitrary - a <- arbitrary - return $ UnitImage c (char a c) - -instance Show UnitImage where - show (UnitImage c _) = "UnitImage " ++ show c - -data DefaultImage = DefaultImage Image - -instance Show DefaultImage where - show (DefaultImage i) - = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i) - -instance Arbitrary DefaultImage where - arbitrary = do - i <- return $ char defAttr 'X' - return $ DefaultImage i - -data SingleRowSingleAttrImage - = SingleRowSingleAttrImage - { expectedAttr :: Attr - , expectedColumns :: Int - , rowImage :: Image - } - -instance Show SingleRowSingleAttrImage where - show (SingleRowSingleAttrImage attr columns image) - = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )" - -newtype WidthResize = WidthResize (Image -> (Image, Int)) - -instance Arbitrary WidthResize where - arbitrary = do - WidthResize f <- arbitrary - w <- choose (1,64) - oneof $ map (return . WidthResize) - [ \i -> (i, imageWidth i) - , \i -> (resizeWidth w $ fst $ f i, w) - , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w) - , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w) - ] - -newtype HeightResize = HeightResize (Image -> (Image, Int)) - -instance Arbitrary HeightResize where - arbitrary = do - HeightResize f <- arbitrary - h <- choose (1,64) - oneof $ map (return . HeightResize) - [ \i -> (i, imageHeight i) - , \i -> (resizeHeight h $ fst $ f i, h) - , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h) - , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h) - ] - -newtype ImageResize = ImageResize (Image -> (Image, (Int, Int))) - -instance Arbitrary ImageResize where - arbitrary = oneof - [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) - , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) - , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) - , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) - , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) - , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) - , do - ImageResize f <- arbitrary - WidthResize g <- arbitrary - return $! ImageResize $! \i -> - let (i0, (_, outHeight)) = f i - gI = g i0 - in (fst gI, (snd gI, outHeight)) - , do - ImageResize f <- arbitrary - HeightResize g <- arbitrary - return $! ImageResize $! \i -> - let (i0, (outWidth, _)) = f i - gI = g i0 - in (fst gI, (outWidth, snd gI)) - ] - - -instance Arbitrary SingleRowSingleAttrImage where - arbitrary = do - -- The text must contain at least one character. Otherwise the image simplifies to the - -- IdImage which has a height of 0. If this is to represent a single row then the height - -- must be 1 - singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary) - a <- arbitrary - let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText] - outWidth = length singleColumnRowText - return $ SingleRowSingleAttrImage a outWidth outImage - -data SingleRowTwoAttrImage - = SingleRowTwoAttrImage - { part0 :: SingleRowSingleAttrImage - , part1 :: SingleRowSingleAttrImage - , joinImage :: Image - } deriving Show - -instance Arbitrary SingleRowTwoAttrImage where - arbitrary = do - p0 <- arbitrary - p1 <- arbitrary - return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1) - -data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack - { stackImage :: Image - , stackSourceImages :: [SingleRowSingleAttrImage] - , stackWidth :: Int - , stackHeight :: Int - } - deriving Show - -instance Arbitrary SingleAttrSingleSpanStack where - arbitrary = do - imageList <- Verify.resize 16 (listOf1 arbitrary) - return $ mkSingleAttrSingleSpanStack imageList - shrink s = do - imageList <- shrink $ stackSourceImages s - if null imageList - then [] - else return $ mkSingleAttrSingleSpanStack imageList - -mkSingleAttrSingleSpanStack imageList = - let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ] - in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList) - (toEnum $ length imageList) - -instance Arbitrary Image where - arbitrary = oneof - [ return EmptyImage - , do - SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary - ImageResize f <- Verify.resize 2 arbitrary - return $! fst $! f stackImage - , do - SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary - ImageResize f <- Verify.resize 2 arbitrary - return $! fst $! f stackImage - , do - i0 <- arbitrary - i1 <- arbitrary - let i = i0 <|> i1 - ImageResize f <- Verify.resize 2 arbitrary - return $! fst $! f i - , do - i0 <- arbitrary - i1 <- arbitrary - let i = i0 <-> i1 - ImageResize f <- Verify.resize 2 arbitrary - return $! fst $! f i - ] - {- - shrink i@(HorizJoin {partLeft, partRight}) = do - let !i_alt = backgroundFill (imageWidth i) (imageHeight i) - !partLeft' <- shrink partLeft - !partRight' <- shrink partRight - [i_alt, partLeft' <|> partRight'] - shrink i@(VertJoin {partTop, partBottom}) = do - let !i_alt = backgroundFill (imageWidth i) (imageHeight i) - !partTop' <- shrink partTop - !partBottom' <- shrink partBottom - [i_alt, partTop' <-> partBottom'] - shrink i@(CropRight {croppedImage, outputWidth}) = do - let !i_alt = backgroundFill (imageWidth i) (imageHeight i) - [i_alt, croppedImage] - shrink i@(CropLeft {croppedImage, leftSkip, outputWidth}) = do - let !i_alt = backgroundFill (imageWidth i) (imageHeight i) - [i_alt, croppedImage] - shrink i@(CropBottom {croppedImage, outputHeight}) = do - let !i_alt = backgroundFill (imageWidth i) (imageHeight i) - [i_alt, croppedImage] - shrink i@(CropTop {croppedImage, topSkip, outputHeight}) = do - let !i_alt = backgroundFill (imageWidth i) (imageHeight i) - [i_alt, croppedImage] - shrink i = [emptyImage, backgroundFill (imageWidth i) (imageHeight i)] - -} - -data CropOperation - = CropFromLeft - | CropFromRight - | CropFromTop - | CropFromBottom - deriving (Eq, Show) - -instance Arbitrary CropOperation where - arbitrary = oneof $ map return [CropFromLeft, CropFromRight, CropFromTop, CropFromBottom] - -data Translation = Translation Image (Int, Int) Image - deriving (Eq, Show) - -instance Arbitrary Translation where - arbitrary = do - i <- arbitrary - x <- arbitrary `suchThat` (> 0) - y <- arbitrary `suchThat` (> 0) - let i' = translate x y i - return $ Translation i (x,y) i' - diff --git a/test/Verify/Graphics/Vty/Output.hs b/test/Verify/Graphics/Vty/Output.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Output.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Verify.Graphics.Vty.Output where - -import Control.Applicative ((<$>)) - -import Graphics.Vty.Output.Mock - -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.String.UTF8 as UTF8 - -import Test.QuickCheck.Property - --- A list of terminals that should be supported. --- This started with a list of terminals ubuntu supported. Then those terminals that really could --- not be supported were removed. Then a few more were pruned until a reasonable looking set was --- made. -terminalsOfInterest :: [String] -terminalsOfInterest = - [ "vt100" - , "vt220" - , "vt102" - , "xterm-r5" - , "xterm-xfree86" - , "xterm-r6" - , "xterm-256color" - , "xterm-vt220" - , "xterm-debian" - , "xterm-mono" - , "xterm-color" - , "xterm" - , "mach" - , "mach-bold" - , "mach-color" - , "linux" - , "ansi" - , "hurd" - , "Eterm" - , "pcansi" - , "screen-256color" - , "screen-bce" - , "screen-s" - , "screen-w" - , "screen" - , "screen-256color-bce" - , "sun" - , "rxvt" - , "rxvt-unicode" - , "rxvt-basic" - , "cygwin" - ] - -compareMockOutput :: MockData -> String -> IO Result -compareMockOutput mockData expectedStr = do - outStr <- UTF8.toString <$> readIORef mockData - if outStr /= expectedStr - then return $ failed { reason = "bytes\n" ++ outStr - ++ "\nare not the expected bytes\n" - ++ expectedStr - } - else return succeeded - 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,52 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture - , module Graphics.Vty.Picture - ) - where - -import Verify.Graphics.Vty.Prelude - -import Graphics.Vty.Picture -import Graphics.Vty.Debug - -import Verify.Graphics.Vty.Attributes -import Verify.Graphics.Vty.Image - -import Verify - -data DefaultPic = DefaultPic - { defaultPic :: Picture - , defaultWin :: MockWindow - } - -instance Show DefaultPic where - show (DefaultPic pic win) - = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n" - -instance Arbitrary DefaultPic where - arbitrary = do - DefaultImage image <- arbitrary - let win = MockWindow (imageWidth image) (imageHeight image) - return $ DefaultPic (picForImage image) - win - -data PicWithBGAttr = PicWithBGAttr - { withAttrPic :: Picture - , withAttrWin :: MockWindow - , withAttrSpecifiedAttr :: Attr - } deriving ( Show ) - -instance Arbitrary PicWithBGAttr where - arbitrary = do - DefaultImage image <- arbitrary - let win = MockWindow (imageWidth image) (imageHeight image) - attr <- arbitrary - return $ PicWithBGAttr (picForImage image) - win - attr - -instance Arbitrary Picture where - arbitrary = do - layers <- Verify.resize 20 (listOf1 arbitrary) - return $ picForLayers layers - diff --git a/test/Verify/Graphics/Vty/Prelude.hs b/test/Verify/Graphics/Vty/Prelude.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Prelude.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude - , module Graphics.Vty.Prelude - , MockWindow(..) - ) - where - -import Graphics.Vty.Prelude - -import Graphics.Vty.Debug - -import Verify - -data EmptyWindow = EmptyWindow MockWindow - -instance Arbitrary EmptyWindow where - arbitrary = return $ EmptyWindow (MockWindow (0 :: Int) (0 :: Int)) - -instance Show EmptyWindow where - show (EmptyWindow _) = "EmptyWindow" - -instance Arbitrary MockWindow where - arbitrary = do - w <- choose (1,1024) - h <- choose (1,1024) - return $ MockWindow w h - 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,37 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span - , module Graphics.Vty.Span - ) - where - -import Graphics.Vty.Debug -import Graphics.Vty.Span - -import Verify.Graphics.Vty.Picture - -import qualified Data.Vector as Vector -import Data.Word - -import Verify - -isAttrSpanOp :: SpanOp -> Bool -isAttrSpanOp TextSpan {} = True -isAttrSpanOp _ = False - -verifyAllSpansHaveWidth i spans w - = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans) - in case any ((== True) . fst) v of - False -> succeeded - True -> failed { reason = "Not all spans contained operations defining exactly " - ++ show w - ++ " columns of output - \n" - ++ (concatMap ((++ "\n") . show)) v - } - -verifyOpsEquality i_ops i_alt_ops = - if i_ops == i_alt_ops - then succeeded - else failed { reason = "ops for alternate image " ++ show i_alt_ops - ++ " are not the same as " ++ show i_ops - } - 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/VerifyConfig.hs b/test/VerifyConfig.hs deleted file mode 100644 --- a/test/VerifyConfig.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Main where - -import Graphics.Vty.Config -import Graphics.Vty.Input.Events - -import Data.Default -import Data.String.QQ - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -exampleConfig :: String -exampleConfig = [s| --- comments should be ignored. -map _ "\ESC[B" KUp [] -askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored -map _ "\ESC[1;3B" KDown [MAlt] -map "xterm" "\ESC[1;3B" KDown [MAlt] -map "xterm-256-color" "\ESC[1;3B" KDown [MAlt] -debugLog "/tmp/vty-debug.txt" -|] - -exampleConfigConfig :: Config -exampleConfigConfig = def - { debugLog = Just "/tmp/vty-debug.txt" - , inputMap = [ (Nothing, "\ESC[B", EvKey KUp []) - , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt]) - , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt]) - , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt]) - ] - } - -exampleConfigParses :: IO () -exampleConfigParses = assertEqual "example config parses as expected" - exampleConfigConfig - (runParseConfig "exampleConfig" exampleConfig) - -main :: IO () -main = defaultMain - [ testCase "example config parses" $ exampleConfigParses - ] - diff --git a/test/VerifyCropSpanGeneration.hs b/test/VerifyCropSpanGeneration.hs deleted file mode 100644 --- a/test/VerifyCropSpanGeneration.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyCropSpanGeneration where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Span - -import Graphics.Vty.Debug -import Graphics.Vty.PictureToSpans - -import Verify - -import qualified Data.Vector as Vector - -cropOpDisplayOps :: (Int -> Image -> Image) -> - Int -> Image -> (DisplayOps, Image) -cropOpDisplayOps cropOp v i = - let iOut = cropOp v i - p = picForImage iOut - w = MockWindow (imageWidth iOut) (imageHeight iOut) - in (displayOpsForPic p (regionForWindow w), iOut) - -widthCropOutputColumns :: (Int -> Image -> Image) -> - SingleAttrSingleSpanStack -> - NonNegative Int -> - Property -widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==> - let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s) - in verifyAllSpansHaveWidth iOut ops w - -heightCropOutputColumns :: (Int -> Image -> Image) -> - SingleAttrSingleSpanStack -> - NonNegative Int -> - Property -heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==> - let (ops, _) = cropOpDisplayOps cropOp h (stackImage s) - in displayOpsRows ops == h - -cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropRightOutputColumns = widthCropOutputColumns cropRight - -cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropLeftOutputColumns = widthCropOutputColumns cropLeft - -cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropTopOutputRows = heightCropOutputColumns cropTop - -cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropBottomOutputRows = heightCropOutputColumns cropBottom - --- TODO: known benign failure. -cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property -cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==> - let i = stackImage stack - -- the right part is made by cropping the image from the left. - iR = cropLeft (imageWidth i `div` 2) i - -- the left part is made by cropping the image from the right - iL = cropRight (imageWidth i `div` 2) i - iAlt = iL <|> iR - iOps = displayOpsForImage i - iAltOps = displayOpsForImage iAlt - in verifyOpsEquality iOps iAltOps - -cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property -cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==> - let i = stackImage stack - -- the top part is made by cropping the image from the bottom. - iT = cropBottom (imageHeight i `div` 2) i - -- the bottom part is made by cropping the image from the top. - iB = cropTop (imageHeight i `div` 2) i - iAlt = iT <-> iB - in displayOpsForImage i == displayOpsForImage iAlt - -tests :: IO [Test] -tests = return - [ verify "cropping from the bottom produces display operations covering the expected rows" - cropBottomOutputRows - , verify "cropping from the top produces display operations covering the expected rows" - cropTopOutputRows - , verify "cropping from the left produces display operations covering the expected columns" - cropLeftOutputColumns - , verify "cropping from the right produces display operations covering the expected columns" - cropRightOutputColumns - -- TODO: known benign failure. - -- , verify "the output of a stack is the same as that stack cropped left & right and joined together" - -- cropRightAndLeftRejoinedEquivalence - , verify "the output of a stack is the same as that stack cropped top & bottom and joined together" - cropTopAndBottomRejoinedEquivalence - ] - 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,13 +0,0 @@ -module VerifyEmptyImageProps where - -import Verify - --- should be exported by Graphics.Vty.Picture -import Graphics.Vty.Picture ( Image, emptyImage ) - -tests :: IO [Test] -tests = do - -- should provide an image type. - let _ :: Image = emptyImage - return [] - diff --git a/test/VerifyEvalTerminfoCaps.hs b/test/VerifyEvalTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyEvalTerminfoCaps.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyEvalTerminfoCaps where - -import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound) -import Data.Terminfo.Eval -import Data.Terminfo.Parse -import Control.DeepSeq - -import qualified System.Console.Terminfo as Terminfo - -import Verify -import Verify.Graphics.Vty.Output - -import Control.Applicative ( (<$>) ) -import Control.Exception ( try, SomeException(..) ) - -import Control.Monad ( mapM_, forM, forM_ ) - -import Data.Maybe ( fromJust ) -import Data.Word - -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, minusPtr) -import Numeric - --- If a terminal defines one of the caps then it's expected to be parsable. -capsOfInterest = - [ "cup" - , "sc" - , "rc" - , "setf" - , "setb" - , "setaf" - , "setab" - , "op" - , "cnorm" - , "civis" - , "smcup" - , "rmcup" - , "clear" - , "hpa" - , "vpa" - , "sgr" - , "sgr0" - ] - -fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) - -tests :: IO [Test] -tests = do - evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-) - fmap concat $ forM terminalsOfInterest $ \termName -> do - putStrLn $ "adding tests for terminal: " ++ termName - mti <- try $ Terminfo.setupTerm termName - case mti of - Left (_e :: SomeException) - -> return [] - Right ti -> do - fmap concat $ forM capsOfInterest $ \capName -> do - case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Just capDef -> do - putStrLn $ "\tadding test for cap: " ++ capName - let testName = termName ++ "(" ++ capName ++ ")" - case parseCapExpression capDef of - Left error -> return [verify testName (failed {reason = "parse error " ++ show error})] - Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)] - Nothing -> do - return [] - -{-# NOINLINE verifyEvalCap #-} -verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property -verifyEvalCap evalBuffer expr !junkInt = do - forAll (vector 9) $ \inputValues -> - let write = writeCapExpr expr inputValues - !byteCount = getBound write - in liftIOResult $ do - let startPtr :: Ptr Word8 = evalBuffer - forM_ [0..100] $ \i -> runWrite write startPtr - endPtr <- runWrite write startPtr - case endPtr `minusPtr` startPtr of - count | count < 0 -> - return $ failed { reason = "End pointer before start pointer." } - | toEnum count > byteCount -> - return $ failed { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byteCount) - } - | otherwise -> - return succeeded - diff --git a/test/VerifyImageOps.hs b/test/VerifyImageOps.hs deleted file mode 100644 --- a/test/VerifyImageOps.hs +++ /dev/null @@ -1,174 +0,0 @@ -module VerifyImageOps where - -import Graphics.Vty.Attributes -import Graphics.Vty.Image.Internal -import Verify.Graphics.Vty.Image - -import Verify - -import Control.DeepSeq - -twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool -twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) = - imageWidth (char defAttr c1 <|> char defAttr c2) == 2 - -manySwHorizConcat :: [SingleColumnChar] -> Bool -manySwHorizConcat cs = - let chars = [ char | SingleColumnChar char <- cs ] - l = fromIntegral $ length cs - in imageWidth ( horizCat $ map (char defAttr) chars ) == l - -twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool -twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) = - imageHeight (char defAttr c1 <-> char defAttr c2) == 2 - -horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool -horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = - (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 - == - char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) - -twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool -twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = - imageWidth (char defAttr c1 <|> char defAttr c2) == 4 - -manyDwHorizConcat :: [DoubleColumnChar] -> Bool -manyDwHorizConcat cs = - let chars = [ char | DoubleColumnChar char <- cs ] - l = fromIntegral $ length cs - in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2 - -twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool -twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = - imageHeight (char defAttr c1 <-> char defAttr c2) == 2 - -horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool -horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = - (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 - == - char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) - -vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool -vertContatSingleRow (NonEmpty stack) = - let expectedHeight :: Int = length stack - stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ] - in imageHeight stackImage == expectedHeight - -disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) = - let expectedHeight :: Int = max (length stack0) (length stack1) - stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - in imageHeight (stackImage0 <|> stackImage1) == expectedHeight - - -disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = - let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - image = stackImage0 <|> stackImage1 - expectedHeight = imageHeight image - in case image of - HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) ) - && - ( expectedHeight == (imageHeight $ partRight image) ) - _ -> True - -disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) = - let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) - stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - stack0Image = vertCat stack0Images - stack1Image = vertCat stack1Images - image = stack0Image <-> stack1Image - in imageWidth image == expectedWidth - -disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = - let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) - stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - stack0Image = vertCat stack0Images - stack1Image = vertCat stack1Images - image = stack0Image <-> stack1Image - in case image of - VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) ) - && - ( expectedWidth == (imageWidth $ partBottom image) ) - _ -> True - -translationIsLinearOnOutSize :: Translation -> Bool -translationIsLinearOnOutSize (Translation i (x,y) i') = - imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y - -paddingIsLinearOnOutSize :: Image -> Gen Bool -paddingIsLinearOnOutSize i = do - l <- offset - t <- offset - r <- offset - b <- offset - let i' = pad l t r b i - return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b - where offset = choose (1,1024) - -cropLeftLimitsWidth :: Image -> Int -> Property -cropLeftLimitsWidth i v = v >= 0 ==> - v >= imageWidth (cropLeft v i) - -cropRightLimitsWidth :: Image -> Int -> Property -cropRightLimitsWidth i v = v >= 0 ==> - v >= imageWidth (cropRight v i) - -cropTopLimitsHeight :: Image -> Int -> Property -cropTopLimitsHeight i v = v >= 0 ==> - v >= imageHeight (cropTop v i) - -cropBottomLimitsHeight :: Image -> Int -> Property -cropBottomLimitsHeight i v = v >= 0 ==> - v >= imageHeight (cropBottom v i) - --- rediculous tests just to satisfy my desire for nice code coverage :-P -canShowImage :: Image -> Bool -canShowImage i = length (show i) > 0 - -canRnfImage :: Image -> Bool -canRnfImage i = rnf i == () - -canPpImage :: Image -> Bool -canPpImage i = length (ppImageStructure i) > 0 - -tests :: IO [Test] -tests = return - [ verify "twoSwHorizConcat" twoSwHorizConcat - , verify "manySwHorizConcat" manySwHorizConcat - , verify "twoSwVertConcat" twoSwVertConcat - , verify "horizConcatSwAssoc" horizConcatSwAssoc - , verify "manyDwHorizConcat" manyDwHorizConcat - , verify "twoDwHorizConcat" twoDwHorizConcat - , verify "twoDwVertConcat" twoDwVertConcat - , verify "horizConcatDwAssoc" horizConcatDwAssoc - , verify "single row vert concats to correct height" vertContatSingleRow - , verify "disjointHeightHorizJoin" disjointHeightHorizJoin - , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill - , verify "disjointWidthVertJoin" disjointWidthVertJoin - , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill - , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize - , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize - , verify "crop left limits width" cropLeftLimitsWidth - , verify "crop right limits width" cropRightLimitsWidth - , verify "crop top limits height" cropTopLimitsHeight - , verify "crop bottom limits height" cropBottomLimitsHeight - , verify "can show image" canShowImage - , verify "can rnf image" canRnfImage - , verify "can pp image" canPpImage - ] - diff --git a/test/VerifyImageTrans.hs b/test/VerifyImageTrans.hs deleted file mode 100644 --- a/test/VerifyImageTrans.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module VerifyImageTrans where - -import Verify.Graphics.Vty.Image - -import Graphics.Vty.Image.Internal - -import Verify - -import Data.Word - -isHorizTextOfColumns :: Image -> Int -> Bool -isHorizTextOfColumns (HorizText { outputWidth = inW }) expectedW = inW == expectedW -isHorizTextOfColumns (BGFill { outputWidth = inW }) expectedW = inW == expectedW -isHorizTextOfColumns _image _expectedW = False - -verifyHorizContatWoAttrChangeSimplifies :: SingleRowSingleAttrImage -> Bool -verifyHorizContatWoAttrChangeSimplifies (SingleRowSingleAttrImage _attr charCount image) = - isHorizTextOfColumns image charCount - -verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool -verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0) - (SingleRowSingleAttrImage attr1 charCount1 _image1) - i - ) - | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1) - | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1) - -tests :: IO [Test] -tests = return - [ verify "verifyHorizContatWoAttrChangeSimplifies" verifyHorizContatWoAttrChangeSimplifies - , verify "verifyHorizContatWAttrChangeSimplifies" verifyHorizContatWAttrChangeSimplifies - ] - diff --git a/test/VerifyInline.hs b/test/VerifyInline.hs deleted file mode 100644 --- a/test/VerifyInline.hs +++ /dev/null @@ -1,31 +0,0 @@ -module VerifyInline where - -import Graphics.Vty.Inline -import Graphics.Vty.Output -import Graphics.Vty.Output.TerminfoBased as TerminfoBased - -import Verify.Graphics.Vty.Output - -import Verify - -import Distribution.TestSuite - -import System.IO - -tests :: IO [Test] -tests = concat <$> forM terminalsOfInterest (\termName -> return $ - [ Test $ TestInstance - { name = "verify vty inline" - , run = do - {- disabled because I cannot get useful output out of cabal why this fails. - nullOut <- openFile "/dev/null" WriteMode - t <- TerminfoBased.reserveTerminal termName nullOut - putAttrChange t $ default_all - releaseTerminal t - -} - return $ Finished Pass - , tags = [] - , options = [] - , setOption = \_ _ -> Left "no options supported" - } - ]) diff --git a/test/VerifyLayersSpanGeneration.hs b/test/VerifyLayersSpanGeneration.hs deleted file mode 100644 --- a/test/VerifyLayersSpanGeneration.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyLayersSpanGeneration where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Span - -import Graphics.Vty.Debug -import Graphics.Vty.PictureToSpans - -import Verify - -import qualified Data.Vector as Vector - -largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -largerHorizSpanOcclusion row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0) - expectedOps = displayOpsForImage iLarger - p = picForLayers [iLarger, iSmaller] - ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger) - in verifyOpsEquality expectedOps ops - --- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the --- second row rendered as a bottom layer with a background fill where the first row would be. -vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -vertStackLayerEquivalence0 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <-> i1 - p = picForImage i - iLower = backgroundFill (imageWidth i0) 1 <-> i1 - pLayered = picForLayers [i0, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - -vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -vertStackLayerEquivalence1 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <-> i1 - p = picForImage i - iLower = i0 <-> backgroundFill (imageWidth i1) 1 - iUpper = backgroundFill (imageWidth i0) 1 <-> i1 - pLayered = picForLayers [iUpper, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - --- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the --- second row rendered as a bottom layer with a background fill where the first row would be. -horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -horizJoinLayerEquivalence0 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <|> i1 - p = picForImage i - iLower = backgroundFill (imageWidth i0) 1 <|> i1 - pLayered = picForLayers [i0, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - -horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -horizJoinLayerEquivalence1 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <|> i1 - p = picForImage i - iLower = i0 <|> backgroundFill (imageWidth i1) 1 - iUpper = backgroundFill (imageWidth i0) 1 <|> i1 - pLayered = picForLayers [iUpper, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - -horizJoinAlternate0 :: Result -horizJoinAlternate0 = - let size = 4 - str0 = replicate size 'a' - str1 = replicate size 'b' - i0 = string defAttr str0 - i1 = string defAttr str1 - i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1) - layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1 - layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1 - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic (picForLayers [layer0, layer1]) - (imageWidth i,imageHeight i) - in verifyOpsEquality expectedOps opsLayered - -horizJoinAlternate1 :: Result -horizJoinAlternate1 = - let size = 4 - str0 = replicate size 'a' - str1 = replicate size 'b' - i0 = string defAttr str0 - i1 = string defAttr str1 - i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1) - layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic (picForLayers layers) - (imageWidth i,imageHeight i) - in verifyOpsEquality expectedOps opsLayered - -tests :: IO [Test] -tests = return - [ verify "a larger horiz span occludes a smaller span on a lower layer" - largerHorizSpanOcclusion - , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)" - vertStackLayerEquivalence0 - , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)" - vertStackLayerEquivalence1 - -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)" - -- horizJoinLayerEquivalence0 - -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)" - -- horizJoinLayerEquivalence1 - -- , verify "alternating images using joins is the same as alternating images using layers (0)" - -- horizJoinAlternate0 - -- , verify "alternating images using joins is the same as alternating images using layers (1)" - -- horizJoinAlternate1 - ] - diff --git a/test/VerifyOutput.hs b/test/VerifyOutput.hs deleted file mode 100644 --- a/test/VerifyOutput.hs +++ /dev/null @@ -1,55 +0,0 @@ -{- We setup the environment to envoke certain terminals of interest. - - This assumes appropriate definitions exist in the current environment for the terminals of - - interest. - -} -module VerifyOutput where -import Verify - -import Graphics.Vty - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Output - -import Control.Monad - -import Data.Default - -import qualified System.Console.Terminfo as Terminfo -import System.Posix.Env -import System.Posix.IO - -tests :: IO [Test] -tests = concat <$> forM terminalsOfInterest (\termName -> do - -- check if that terminfo exists - -- putStrLn $ "testing end to end for terminal: " ++ termName - mti <- try $ Terminfo.setupTerm termName - case mti of - Left (_ :: SomeException) -> return [] - Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture") - (smokeTestTermNonMac termName) - ] - ) - -smokeTestTermNonMac :: String -> Image -> Property -smokeTestTermNonMac termName i = liftIOResult $ do - smokeTestTerm termName i - -smokeTestTerm :: String -> Image -> IO Result -smokeTestTerm termName i = do - nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags - t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName } - -- putStrLn $ "context color count: " ++ show (contextColorCount t) - reserveDisplay t - dc <- displayContext t (100,100) - -- always show the cursor to produce tests for terminals with no cursor support. - let pic = (picForImage i) { picCursor = Cursor 0 0 } - outputPicture dc pic - setCursorPos t 0 0 - when (supportsCursorVisibility t) $ do - hideCursor t - showCursor t - releaseDisplay t - releaseTerminal t - closeFd nullOut - return succeeded - diff --git a/test/VerifyParseTerminfoCaps.hs b/test/VerifyParseTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyParseTerminfoCaps.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module VerifyParseTerminfoCaps where - -import Prelude hiding ( catch ) - -import qualified System.Console.Terminfo as Terminfo - -import Verify.Data.Terminfo.Parse -import Verify.Graphics.Vty.Output -import Verify - -import Data.Maybe ( catMaybes, fromJust ) -import Data.Word - -import Numeric - --- If a terminal defines one of the caps then it's expected to be parsable. --- TODO: reduce duplication with terminfo terminal implementation. -capsOfInterest = - [ "cup" - , "sc" - , "rc" - , "setf" - , "setb" - , "setaf" - , "setab" - , "op" - , "cnorm" - , "civis" - , "smcup" - , "rmcup" - , "clear" - , "hpa" - , "vpa" - , "sgr" - , "sgr0" - ] - -fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) - -tests :: IO [Test] -tests = do - parseTests <- concat <$> forM terminalsOfInterest (\termName -> - liftIO (try $ Terminfo.setupTerm termName) - >>= either (\(_e :: SomeException) -> return []) - (\ti -> concat <$> forM capsOfInterest (\capName -> do - let caseName = "\tparsing cap: " ++ capName - liftIO $ putStrLn caseName - return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Just capDef -> [verify (caseName ++ " -> " ++ show capDef) - (verifyParseCap capDef $ const succeeded)] - Nothing -> [] - ) - ) - ) - return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps - , verify "parse cap string with literal %" literalPercentCaps - , verify "parse cap string with %i op" incFirstTwoCaps - , verify "parse cap string with %pN op" pushParamCaps - ] ++ parseTests - -verifyParseCap capString onParse = - case parseCapExpression capString of - Left error -> failed { reason = "parse error " ++ show error } - Right e -> onParse e - -nonParamaterizedCaps (NonParamCapString cap) = do - verifyParseCap cap $ \e -> - let expectedBytes = map (toEnum . fromEnum) cap - outBytes = bytesForRange e 0 (length cap) - in verifyBytesEqual outBytes expectedBytes - -literalPercentCaps (LiteralPercentCap capString expectedBytes) = do - verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes - -incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do - verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes - -pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do - verifyParseCap capString $ \e -> - let outBytes = collectBytes e - outParamCount = paramCount e - in if outParamCount == expectedParamCount - then verifyBytesEqual outBytes expectedBytes - else failed { reason = "out param count /= expected param count" } - -decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do - verifyParseCap capString $ \e -> - let outBytes = collectBytes e - outParamCount = paramCount e - in if outParamCount == expectedParamCount - then verifyBytesEqual outBytes expectedBytes - else failed { reason = "out param count /= expected param count" } - -printCap ti capName = do - putStrLn $ capName ++ ": " ++ show (fromCapname ti capName) - -printExpression ti capName = do - let parseResult = parseCapExpression $ fromCapname ti capName - putStrLn $ capName ++ ": " ++ show parseResult - diff --git a/test/VerifySimpleSpanGeneration.hs b/test/VerifySimpleSpanGeneration.hs deleted file mode 100644 --- a/test/VerifySimpleSpanGeneration.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifySimpleSpanGeneration where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Span - -import Graphics.Vty.Debug -import Graphics.Vty.PictureToSpans - -import Verify - -import qualified Data.Vector as Vector - -unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool -unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) = - let p = picForImage i - ops = displayOpsForPic p (regionForWindow w) - in displayOpsColumns ops == 0 && displayOpsRows ops == 0 - -unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool -unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) = - let p = picForImage i - ops = displayOpsForPic p (regionForWindow w) - in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 ) - -horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool -horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = - let p = picForImage i - ops = displayOpsForPic p (regionForWindow w) - in displayOpsColumns ops == 0 && displayOpsRows ops == 0 - -horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool -horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = - let p = picForImage i - ops = displayOpsForPic p (regionForWindow w) - in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 ) - -horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result -horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = - let p = picForImage i - w = MockWindow c 1 - ops = displayOpsForPic p (regionForWindow w) - in verifyAllSpansHaveWidth i ops c - -horizSpanImageAndEqualWindow1 :: SingleRowSingleAttrImage -> Bool -horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = - let p = picForImage i - w = MockWindow c 1 - ops = displayOpsForPic p (regionForWindow w) - in spanOpsEffectedRows ops == 1 - -horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result -horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = - let p = picForImage i - lesserWidth = c `div` 2 - w = MockWindow lesserWidth 1 - ops = displayOpsForPic p (regionForWindow w) - in verifyAllSpansHaveWidth i ops lesserWidth - -singleAttrSingleSpanStackCropped0 :: SingleAttrSingleSpanStack -> Result -singleAttrSingleSpanStackCropped0 stack = - let p = picForImage (stackImage stack) - w = MockWindow (stackWidth stack `div` 2) (stackHeight stack) - ops = displayOpsForPic p (regionForWindow w) - in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack `div` 2) - -singleAttrSingleSpanStackCropped1 :: SingleAttrSingleSpanStack -> Bool -singleAttrSingleSpanStackCropped1 stack = - let p = picForImage (stackImage stack) - expectedRowCount = stackHeight stack `div` 2 - w = MockWindow (stackWidth stack) expectedRowCount - ops = displayOpsForPic p (regionForWindow w) - actualRowCount = spanOpsEffectedRows ops - in expectedRowCount == actualRowCount - -singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result -singleAttrSingleSpanStackCropped2 stack0 stack1 = - let p = picForImage (stackImage stack0 <|> stackImage stack1) - w = MockWindow (stackWidth stack0) (imageHeight (picImage p)) - ops = displayOpsForPic p (regionForWindow w) - in verifyAllSpansHaveWidth (picImage p) ops (stackWidth stack0) - -singleAttrSingleSpanStackCropped3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool -singleAttrSingleSpanStackCropped3 stack0 stack1 = - let p = picForImage (stackImage stack0 <|> stackImage stack1) - w = MockWindow (imageWidth (picImage p)) expectedRowCount - ops = displayOpsForPic p (regionForWindow w) - expectedRowCount = imageHeight (picImage p) `div` 2 - actualRowCount = spanOpsEffectedRows ops - in expectedRowCount == actualRowCount - -singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result -singleAttrSingleSpanStackCropped4 stack0 stack1 = - let p = picForImage (stackImage stack0 <-> stackImage stack1) - w = MockWindow expectedWidth (imageHeight (picImage p)) - ops = displayOpsForPic p (regionForWindow w) - expectedWidth = imageWidth (picImage p) `div` 2 - in verifyAllSpansHaveWidth (picImage p) ops expectedWidth - -singleAttrSingleSpanStackCropped5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool -singleAttrSingleSpanStackCropped5 stack0 stack1 = - let p = picForImage (stackImage stack0 <-> stackImage stack1) - w = MockWindow (imageWidth (picImage p)) (stackHeight stack0) - ops = displayOpsForPic p (regionForWindow w) - expectedRowCount = stackHeight stack0 - actualRowCount = spanOpsEffectedRows ops - in expectedRowCount == actualRowCount - -horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result -horizSpanImageAndGreaterWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = - let p = picForImage i - -- SingleRowSingleAttrImage always has width >= 1 - greaterWidth = c * 2 - w = MockWindow greaterWidth 1 - ops = displayOpsForPic p (regionForWindow w) - in verifyAllSpansHaveWidth i ops greaterWidth - -arbImageIsCropped :: DefaultImage -> MockWindow -> Bool -arbImageIsCropped (DefaultImage image) win@(MockWindow w h) = - let pic = picForImage image - ops = displayOpsForPic pic (regionForWindow win) - in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w ) - -spanOpsActuallyFillRows :: DefaultPic -> Bool -spanOpsActuallyFillRows (DefaultPic pic win) = - let ops = displayOpsForPic pic (regionForWindow win) - expectedRowCount = regionHeight (regionForWindow win) - actualRowCount = spanOpsEffectedRows ops - in expectedRowCount == actualRowCount - -spanOpsActuallyFillColumns :: DefaultPic -> Bool -spanOpsActuallyFillColumns (DefaultPic pic win) = - let ops = displayOpsForPic pic (regionForWindow win) - expectedColumnCount = regionWidth (regionForWindow win) - in allSpansHaveWidth ops expectedColumnCount - -firstSpanOpSetsAttr :: DefaultPic -> Bool -firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } = - let ops = displayOpsForPic pic (regionForWindow win) - in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops ) - -singleAttrSingleSpanStackOpCoverage :: SingleAttrSingleSpanStack -> Result -singleAttrSingleSpanStackOpCoverage stack = - let p = picForImage (stackImage stack) - w = MockWindow (stackWidth stack) (stackHeight stack) - ops = displayOpsForPic p (regionForWindow w) - in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack) - -imageCoverageMatchesBounds :: Image -> Result -imageCoverageMatchesBounds i = - let p = picForImage i - r = (imageWidth i,imageHeight i) - ops = displayOpsForPic p r - in verifyAllSpansHaveWidth i ops (imageWidth i) - -tests :: IO [Test] -tests = return - [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0 - , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1 - , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0 - , verify "horiz span image is cropped when window size == (0,0) [1]" horizSpanImageAndZeroWindow1 - , verify "horiz span image is not cropped when window size == size of image [width]" horizSpanImageAndEqualWindow0 - , verify "horiz span image is not cropped when window size == size of image [height]" horizSpanImageAndEqualWindow1 - , verify "horiz span image is not cropped when window size < size of image [width]" horizSpanImageAndLesserWindow0 - , verify "horiz span image is not cropped when window size > size of image [width]" horizSpanImageAndGreaterWindow0 - , verify "first span op is always to set the text attribute" firstSpanOpSetsAttr - , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" - singleAttrSingleSpanStackOpCoverage - , verify "a single attr text span is cropped when window size < size of stack image [width]" - singleAttrSingleSpanStackCropped0 - , verify "a single attr text span is cropped when window size < size of stack image [height]" - singleAttrSingleSpanStackCropped1 - , verify "single attr text span <|> single attr text span display cropped. [width]" - singleAttrSingleSpanStackCropped2 - , verify "single attr text span <|> single attr text span display cropped. [height]" - singleAttrSingleSpanStackCropped3 - , verify "single attr text span <-> single attr text span display cropped. [width]" - singleAttrSingleSpanStackCropped4 - , verify "single attr text span <-> single attr text span display cropped. [height]" - singleAttrSingleSpanStackCropped5 - , verify "an arbitrary image when rendered to a window of the same size will cover the entire window" - imageCoverageMatchesBounds - ] - diff --git a/test/VerifyUsingMockInput.hs b/test/VerifyUsingMockInput.hs deleted file mode 100644 --- a/test/VerifyUsingMockInput.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced - - are as expected. - -} -module Main where - -import Verify.Graphics.Vty.Output - -import Graphics.Vty hiding (resize) -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Loop -import Graphics.Vty.Input.Terminfo - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Lens ((^.)) -import Control.Monad - -import Data.Default -import Data.IORef -import Data.List (intersperse, reverse, nubBy) - -import System.Console.Terminfo -import System.Posix.IO -import System.Posix.Terminal (openPseudoTerminal) -import System.Posix.Types -import System.Timeout - -import Test.Framework.Providers.SmallCheck -import Test.Framework -import Test.SmallCheck -import Test.SmallCheck.Series - -import Text.Printf - --- processing a block of 16 chars is the largest I can do without taking too long to run the test. -maxBlockSize :: Int -maxBlockSize = 16 - -maxTableSize :: Int -maxTableSize = 28 - -forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m -forEachOf l = over (generate (\n -> take n l)) - -data InputEvent - = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time. - | Delay Int -- | microsecond delay - deriving Show - -type InputSpec = [InputEvent] - -type ExpectedSpec = [Event] - -synthesizeInput :: InputSpec -> Fd -> IO () -synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD") - where - f (Bytes str) = void $ fdWrite outHandle str - f (Delay t) = threadDelay t - -minDetectableDelay :: Int -minDetectableDelay = 4000 - -minTimout :: Int -minTimout = 4000000 - -testKeyDelay :: Int -testKeyDelay = minDetectableDelay * 4 - -testEscSampleDelay :: Int -testEscSampleDelay = minDetectableDelay * 2 - -genEventsUsingIoActions :: Int -> IO () -> IO () -> IO () -genEventsUsingIoActions maxDuration inputAction outputAction = do - let maxDuration' = max minTimout maxDuration - readComplete <- newEmptyMVar - writeComplete <- newEmptyMVar - _ <- forkOS $ inputAction `finally` putMVar writeComplete () - _ <- forkOS $ outputAction `finally` putMVar readComplete () - Just () <- timeout maxDuration' $ takeMVar writeComplete - Just () <- timeout maxDuration' $ takeMVar readComplete - return () - -compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool -compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents - where - compareEvents' [] [] = return True - compareEvents' [] outEvents' = do - printf "extra events %s\n" (show outEvents') :: IO () - return False - compareEvents' expectedEvents' [] = do - printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO () - printf "expected events %s\n" (show expectedEvents) :: IO () - printf "received events %s\n" (show outEvents) :: IO () - return False - compareEvents' (e : expectedEvents') (o : outEvents') - | e == o = compareEvents' expectedEvents' outEvents' - | otherwise = do - printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO () - printf "expected events %s\n" (show expectedEvents) :: IO () - printf "received events %s\n" (show outEvents) :: IO () - return False - -assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool -assertEventsFromSynInput table inputSpec expectedEvents = do - let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay - eventCount = length expectedEvents - (writeFd, readFd) <- openPseudoTerminal - (setTermAttr,_) <- attributeControl readFd - setTermAttr - let testConfig = def { inputFd = Just readFd - , termName = Just "dummy" - , vmin = Just 1 - , vtime = Just 100 - } - input <- initInput testConfig table - eventsRef <- newIORef [] - let writeWaitClose = do - synthesizeInput inputSpec writeFd - threadDelay minDetectableDelay - shutdownInput input - threadDelay minDetectableDelay - closeFd writeFd - closeFd readFd - -- drain output pipe - let readEvents = readLoop eventCount - readLoop 0 = return () - readLoop n = do - e <- atomically $ readTChan $ input^.eventChannel - modifyIORef eventsRef ((:) e) - readLoop (n - 1) - genEventsUsingIoActions maxDuration writeWaitClose readEvents - outEvents <- reverse <$> readIORef eventsRef - compareEvents inputSpec expectedEvents outEvents - -newtype InputBlocksUsingTable event - = InputBlocksUsingTable ([(String,event)] -> [(String, event)]) - -instance Show (InputBlocksUsingTable event) where - show (InputBlocksUsingTable _g) = "InputBlocksUsingTable" - -instance Monad m => Serial m (InputBlocksUsingTable event) where - series = do - n :: Int <- localDepth (const maxTableSize) series - return $ InputBlocksUsingTable $ \raw_table -> - let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table - in concat (take n (selections table)) - where - selections [] = [] - selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z) - -verifyVisibleSynInputToEvent :: Property IO -verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do - let table = visibleChars - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput universalTable input events - -verifyCapsSynInputToEvent :: Property IO -verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \termName -> monadic $ do - term <- setupTerm termName - let table = capsClassifyMap term keysFromCapsTable - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput table input events - -verifySpecialSynInputToEvent :: Property IO -verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do - let table = specialSupportKeys - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput universalTable input events - -verifyFullSynInputToEvent :: Property IO -verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \termName -> monadic $ do - term <- setupTerm termName - let table = classifyMapForTerm termName term - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput table input events - -verifyFullSynInputToEvent_2x :: Property IO -verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \termName -> monadic $ do - term <- setupTerm termName - let table = classifyMapForTerm termName term - inputSeq = gen table - events = concatMap ((\s -> [s,s]) . snd) inputSeq - keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput table input events - -main :: IO () -main = defaultMain - [ testProperty "synthesized typing of single visible chars translates to expected events" - verifyVisibleSynInputToEvent - , testProperty "synthesized typing of keys from capabilities tables translates to expected events" - verifyCapsSynInputToEvent - , testProperty "synthesized typing of hard coded special keys translates to expected events" - verifySpecialSynInputToEvent - , testProperty "synthesized typing of any key in the table translates to its paired event" - verifyFullSynInputToEvent - , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event" - verifyFullSynInputToEvent_2x - ] - diff --git a/test/VerifyUsingMockTerminal.hs b/test/VerifyUsingMockTerminal.hs deleted file mode 100644 --- a/test/VerifyUsingMockTerminal.hs +++ /dev/null @@ -1,100 +0,0 @@ -module VerifyUsingMockTerminal where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Span -import Verify.Graphics.Vty.Output -import Graphics.Vty.Output -import Graphics.Vty.Output.Mock - -import Graphics.Vty.Debug - -import Verify - -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.String.UTF8 as UTF8 - -import System.IO - -unitImageUnitBounds :: UnitImage -> Property -unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do - (_,t) <- mockTerminal (1,1) - dc <- displayBounds t >>= displayContext t - let pic = picForImage i - outputPicture dc pic - return succeeded - -unitImageArbBounds :: UnitImage -> MockWindow -> Property -unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do - (_,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - let pic = picForImage i - outputPicture dc pic - return succeeded - -singleTRow :: MockWindow -> Property -singleTRow (MockWindow w h) = liftIOResult $ do - (mockData,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains just the character T repeated for a single row - let i = horizCat $ replicate (fromEnum w) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The mock output string that represents the output bytes a single line containing the T - -- string: Followed by h - 1 lines of a change to the background attribute and then the - -- background character - let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T' - ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B') - compareMockOutput mockData expected - -manyTRows :: MockWindow -> Property -manyTRows (MockWindow w h) = liftIOResult $ do - (mockData, t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all the rows - let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w 'T's - let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') - compareMockOutput mockData expected - -manyTRowsCroppedWidth :: MockWindow -> Property -manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do - (mockData,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all the rows - let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w 'T's - let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') - compareMockOutput mockData expected - -manyTRowsCroppedHeight :: MockWindow -> Property -manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do - (mockData,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all the rows - let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an - -- attribute change. 'A', followed by w count 'T's - let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') - compareMockOutput mockData expected - -tests :: IO [Test] -tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds - , verify "unitImageArbBounds" unitImageArbBounds - , verify "singleTRow" singleTRow - , verify "manyTRows" manyTRows - , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth - , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight - ] - diff --git a/test/VerifyUtf8Width.hs b/test/VerifyUtf8Width.hs deleted file mode 100644 --- a/test/VerifyUtf8Width.hs +++ /dev/null @@ -1,28 +0,0 @@ -module VerifyUtf8Width where -import Verify - -import Graphics.Text.Width -import Graphics.Vty.Attributes -import Graphics.Vty.Picture - -swIs1Column :: SingleColumnChar -> Bool -swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1 - -dwIs2Column :: DoubleColumnChar -> Bool -dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2 - -dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool -dcStringIsEven (NonEmpty dw_list) = - even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ] - -safeWcwidthForControlChars :: Bool -safeWcwidthForControlChars = 0 == safeWcwidth '\NUL' - -tests :: IO [Test] -tests = return - [ verify "swIs1Column" swIs1Column - , verify "dwIs2Column" dwIs2Column - , verify "a string of double characters is an even width" dcStringIsEven - , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars - ] - diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,612 +1,86 @@ name: vty -version: 5.4.0 +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. - . - Developers: See the "Graphics.Vty" module. - . - Users: See the "Graphics.Vty.Config" module. - . - 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: Assumes UTF-8 character encoding support by the - terminal; Poor signal handling; Requires terminfo. - . - This project is hosted on github.com: + 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. -cabal-version: >= 1.18 + . + © Jonathan Daugherty; BSD3 license. +cabal-version: 1.18 build-type: Simple -data-files: README.md, - TODO, +extra-doc-files: README.md, AUTHORS, - CHANGELOG, + CHANGELOG.md, LICENSE -tested-with: GHC >= 7.6.2 +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, + include-dirs: cbits + hs-source-dirs: src + ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10 + ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 + build-depends: base >= 4.8 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, - containers, - data-default >= 0.5.3, - deepseq >= 1.1 && < 1.5, - directory, - filepath >= 1.0 && < 2.0, - lens >= 3.9.0.2 && < 5.0, - -- required for nice installation with yi - hashable >= 1.2, - mtl >= 1.1.1.0 && < 2.3, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, + deepseq >= 1.1 && < 1.6, + microlens < 0.6, + microlens-mtl, + mtl >= 1.1.1.0 && < 2.4, stm, - terminfo >= 0.3 && < 0.5, - transformers >= 0.3.0.0, text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 + utf8-string >= 0.3.1 && < 1.1, + vector >= 0.7, + binary, + parsec, + filepath, + directory - exposed-modules: Graphics.Vty + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.16, + fail + + exposed-modules: Graphics.Text.Width + Graphics.Vty Graphics.Vty.Attributes + Graphics.Vty.Attributes.Color + Graphics.Vty.Attributes.Color240 Graphics.Vty.Config + Graphics.Vty.Debug + Graphics.Vty.DisplayAttributes Graphics.Vty.Error Graphics.Vty.Image + Graphics.Vty.Image.Internal Graphics.Vty.Inline - Graphics.Vty.Inline.Unsafe Graphics.Vty.Input Graphics.Vty.Input.Events - Graphics.Vty.Picture - Graphics.Vty.Prelude Graphics.Vty.Output - Graphics.Text.Width - -- the modules below are only meant to be used by the tests. - Codec.Binary.UTF8.Debug - Data.Terminfo.Parse - Data.Terminfo.Eval - Graphics.Vty.Debug - Graphics.Vty.DisplayAttributes - Graphics.Vty.Image.Internal - Graphics.Vty.Input.Classify - Graphics.Vty.Input.Loop - Graphics.Vty.Input.Terminfo + Graphics.Vty.Output.Mock + Graphics.Vty.Picture Graphics.Vty.PictureToSpans Graphics.Vty.Span - Graphics.Vty.Output.Mock - Graphics.Vty.Output.Interface - Graphics.Vty.Output.XTermColor - Graphics.Vty.Output.TerminfoBased - - other-modules: Graphics.Vty.Attributes.Color - Graphics.Vty.Attributes.Color240 - Graphics.Vty.Debug.Image - Graphics.Vty.Input.Terminfo.ANSIVT - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - hs-source-dirs: src - - default-extensions: ScopedTypeVariables - ForeignFunctionInterface - - ghc-options: -O2 -funbox-strict-fields -threaded -Wall -fspec-constr -fspec-constr-count=10 - - ghc-prof-options: -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10 - - cc-options: -O2 - -executable vty-demo - main-is: Demo.hs - - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - ghc-options: -threaded - - build-depends: vty, - base >= 4 && < 5, - containers, - data-default >= 0.5.3, - lens, - mtl >= 1.1.1.0 && < 2.3 - -test-suite verify-attribute-ops - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - type: detailed-0.9 - hs-source-dirs: test - test-module: VerifyAttributeOps - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-using-mock-terminal - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyUsingMockTerminal - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-terminal - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyOutput - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - data-default >= 0.5.3, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-display-attributes - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyDisplayAttributes - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.DisplayAttributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-empty-image-props - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyEmptyImageProps - - other-modules: Verify - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-eval-terminfo-caps - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyEvalTerminfoCaps - - other-modules: Verify - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - blaze-builder >= 0.3.3.2 && < 0.5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-image-ops - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyImageOps - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Image - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-image-trans - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyImageTrans - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Image - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-inline - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyInline - - other-modules: Verify - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-parse-terminfo-caps - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyParseTerminfoCaps - - other-modules: Verify - Verify.Data.Terminfo.Parse - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-simple-span-generation - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifySimpleSpanGeneration - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - -test-suite verify-crop-span-generation - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyCropSpanGeneration - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - -test-suite verify-layers-span-generation - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyLayersSpanGeneration - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-utf8-width - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyUtf8Width - - other-modules: Verify - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-using-mock-input - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: exitcode-stdio-1.0 - - hs-source-dirs: test - - main-is: VerifyUsingMockInput.hs - - build-depends: vty, - Cabal >= 1.20, - data-default >= 0.5.3, - QuickCheck >= 2.7, - smallcheck == 1.*, - quickcheck-assertions >= 0.1.1, - test-framework == 0.8.*, - test-framework-smallcheck == 0.2.*, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - lens >= 3.9.0.2 && < 5.0, - mtl >= 1.1.1.0 && < 2.3, - stm, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - ghc-options: -threaded -Wall - -test-suite verify-config - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: exitcode-stdio-1.0 - - hs-source-dirs: test - - main-is: VerifyConfig.hs - - build-depends: vty, - Cabal >= 1.20, - data-default >= 0.5.3, - HUnit, - QuickCheck >= 2.7, - smallcheck == 1.*, - quickcheck-assertions >= 0.1.1, - test-framework == 0.8.*, - test-framework-smallcheck == 0.2.*, - test-framework-hunit, - random >= 1.0 && < 1.2, - base >= 4 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - lens >= 3.9.0.2 && < 5.0, - mtl >= 1.1.1.0 && < 2.3, - string-qq, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - ghc-options: -threaded -Wall - + Graphics.Vty.UnicodeWidthTable.IO + Graphics.Vty.UnicodeWidthTable.Install + Graphics.Vty.UnicodeWidthTable.Main + Graphics.Vty.UnicodeWidthTable.Query + Graphics.Vty.UnicodeWidthTable.Types + c-sources: cbits/mk_wcwidth.c