diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,507 +1,1113 @@ -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.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 + +6.6 +--- + +* Added support for horizontal scrolling inputs. The `Button` type in + `Graphics.Vty.Input.Events` got new constructors `BScrollLeft` and + `BScrollRight` for Vty backend implementations that support horizontal + scrolling inputs. + +6.5 +--- + +* Raised upper bound on `microlens` dependency to permit builds against + 0.5. +* Fixed the `utf8-string` dependency lower bound to account for an added + module in 0.3.1. (#279) +* Improved the allocation behavior of `swapSkipsForSingleColumnCharSpan`. + +6.4 +--- + +* Updated the behavior of character width computations when a custom + character width table has been installed. Now when a custom character + width table doesn't provide a width for a character, rather than + defaulting to 1 column, the built-in table is consulted. This change + shouldn't affect users using width tables generated by `vty-unix`'s + table-building tool since that tool generates tables that will provide + widths for all supported characters. + +6.3 +--- + +* Raise microlens upper bound to build with 0.4.14 (#278) +* Updated other bounds to permit building with GHC 9.12 (thanks Erik de + Catro Lopo) +* Removed defunct examples from project + +6.2 +--- + +Package changes: +* Update version bounds to support building with GHC 9.8 + +Bug fixes: +* Updated `PictureToSpans` module to implement its lenses manually to + avoid template haskell which has trouble on Windows and GHC 9.2 (#271) + +6.1 +--- + +API changes: +* `ColorMode` got a `Read` instance. +* The `Config` type got a new `configPreferredColorMode` field for + specifying a preferred `ColorMode`. Backend packages should respect + this field, but note that `vty` itself does not (and cannot) enact + this preference since it's up to the backend driver to configure the + color mode. +* The Vty configuration file got a new `colorMode` field whose value is + a string literal compatible with the `ColorMode` `Read` instance. + +6.0 +--- + +This release marks the beginning of multi-platform support in Vty. +Getting to this point involved removing Unix-specific functionality +from Vty and moving it to a new package, `vty-unix`. Windows support +is now provided via a `vty-windows` package. Another new package, +`vty-crossplatform`, is provided as a convenience for applications that +want to support both Unix and Windows platforms automatically at build +time. See the migration guide below for details on how to upgrade. + +**Migration guide for 6.0** + +To upgrade to this version of Vty, most people will only need to take a +few steps: + +1. Add a package dependency on `vty-unix`, `vty-windows,` or + `vty-crossplatform`, depending on the desired level of platform + support. For example, if an application only supports Unix systems, + it should depend on `vty-unix`. But if an application is intended to + work anywhere Vty works, then `vty-crossplatform` is the best choice. +2. Import `mkVty` from the platform package in step (1). (`mkVty` was + removed from the `vty` package and is now the responsibility of each + platform package.) Imports are as follows: + * `vty-unix`: `Graphics.Vty.Platform.Unix` + * `vty-windows`: `Graphics.Vty.Platform.Windows` + * `vty-crossplatform`: `Graphics.Vty.CrossPlatform` +3. Maintain any existing package dependency on `vty`; the core library + abstractions, types, and functions are still obtained from `vty` + itself. The platform packages do not re-export the core library's + modules. +4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty + user configuration since this step is no longer automatic. +5. Some configurations have been moved to `Graphics.Vty.Output`. For + example, `mouseMode` is no longer a field in `VtyUserConfig`. + Instead, use `setMode` to enable it. + +For applications using more of Vty's API than just the basic +initialization and rendering API, the full change list is provided +below. For people who want to write their own Vty platform package like +`vty-unix`, see `PLATFORM-HOWTO.md`. + +**Detailed change list for 6.0** + +* Package changes: + * The following modules got added to the `vty` library: + * `Graphics.Vty.UnicodeWidthTable.Main` + * The following modules got moved to `vty-unix`: + * `Data.Terminfo.Eval` + * `Data.Terminfo.Parse` + * The following modules got moved to `vty-unix` into the + `Graphics.Vty.Platform.Unix` module namespace (previously + `Graphics.Vty`): + * `Graphics.Vty.Input.Classify` + * `Graphics.Vty.Input.Classify.Parse` + * `Graphics.Vty.Input.Classify.Types` + * `Graphics.Vty.Input.Focus` + * `Graphics.Vty.Input.Loop` + * `Graphics.Vty.Input.Mouse` + * `Graphics.Vty.Input.Paste` + * `Graphics.Vty.Input.Terminfo` + * `Graphics.Vty.Output.TerminfoBased` + * `Graphics.Vty.Output.XTermColor` + * The following modules were removed entirely (with contents migrated + elsewhere as needed): + * `Graphics.Vty.Inline.Unsafe` + * `Graphics.Vty.Output.Interface` (migrated to + `Graphics.Vty.Output`) + * Removed library dependencies on the following packages: + * `ansi-terminal` + * `containers` + * `terminfo` + * `transformers` + * `unix` + * The following executables were moved to other packages: + * `vty-build-width-table` (moved to `vty-unix` as + `vty-unix-build-width-table`) + * `vty-mode-demo` (moved to `vty-crossplatform`) +* API changes: + * `Graphics.Vty.mkVty` moved to the `vty-unix` package's + `Graphics.Vty.Platform.Unix` module. + * Added `Graphics.Vty.mkVtyFromPair` for platform packages to + construct `Vty` handles. + * The contents of the `Graphics.Vty.Output.Interface` module were + merged into `Graphics.Vty.Output`. + * The `vty-build-width-table` tool was removed from the `vty` package, + but its core functionality is now exposed as a library for + platform packages to use to provide platform-specific tools using + `Graphics.Vty.UnicodeWidthTable.Main` and a new tool by the same + name was added to the `vty-unix` package. + * `Graphics.Vty.Events`: the `InternalEvent` type's + `ResumeAfterSignal` constructor was renamed to + `ResumeAfterInterrupt` to be a bit more abstract and + platform-agnostic. + * Removed the following lenses for fields of the `Input` type: + * `eventChannel` (was for `_eventChannel` which was then renamed to + `eventChannel`) + * `configRef` (was for `_configRef` which was then renamed to + `configRef`) + * The `Output` record type got a new field, `setOutputWindowTitle`. + * The `Input` record type got a new field, `inputLogMsg :: String -> + IO ()`, for logging to the Vty log. + * `Graphics.Vty.Config` now exposes `VtyUserConfig` instead of + `Config`. Many of its fields were Unix-specific and were + consequently moved to the `UnixSettings` type in `vty-unix` and + given a `settings` prefix. This includes `outputFd`, `inputFd`, + `vmin`, `vtime`, and `termName`. + * The `VtyUserConfig` type's fields got a `config` field name prefix. + * `inputForConfig` was moved to `vty-unix` as `buildInput` but + generally should not be needed and is exposed only for testing. + * `outputForConfig` was moved to `vty-unix` as `buildOutput` but + generally should not be needed and is exposed only for testing. +* Behavior changes: + * Since `vty` no longer implements `mkVty`, the Vty user configuration + is no longer implicitly loaded by Vty-based applications. + Instead, it is now up to the applications to call + `Graphics.Vty.Config.userConfig` to load any user-provided + configuration. + * Vty no longer implicitly attempts to load configured Unicode + width tables. It is now the responsibility of the platform packages + (such as `vty-unix`) and/or applications to load tables via + `Graphics.Vty.UnicodeWidthTable.IO` and install them via + `Graphics.Vty.UnicodeWidthTable.Install`. +* Changes to demonstration programs: + * `EventEcho`, `ModeDemo`, and `Rogue` demo programs moved to the + `vty-crossplatform` package. +* Changes to tests: + * Where appropriate, some test programs and test cases were moved to + `vty-unix` or `vty-crossplatform`. + +5.39 +---- + +Package changes: +* Now builds with `mtl-2.3.*`. + +Bug fixes: +* Fixed a long-standing issue where unused input on stdin could cause a + memory error and a crash when Vty was being initialized. (#266) + +5.38 +---- + +This release includes numerous API changes, although none of them should +break your programs. If so, please open a ticket on the Vty issue +tracker. + +Package changes: +* Support mtl 2.3 (thanks Daniel Firth) +* The test and example collections got completely overhauled to clean up + bit rot. + * Moved example programs into examples/ under a new vty-examples + package. + * Moved test suite programs out of vty.cabal and into tests/ under a + new vty-tests package. + * Cleaned up all build-depends lists in all three packages to remove + unused deps. + * Consolidated the test suite library modules into the vty-tests + library to avoid redundant compilation. + * Added build.sh to build everything in the development process to + help ensure that examples and tests don't get forgotten. + * Removeed lots of stale/unused modules in old test/ directory. +* Got vty-examples building again and resolved various warnings and + issues. + +API changes: +* All modules got explicit export lists. Prior to this release, many + modules exported everything they contained, making it difficult to + know what was really intended to be part of the public API. The new + export lists should contain everything that applications need; the + risk of breakage exists but should be minor. Please open a ticket if + you were using something that is no longer exported. It might be that + it was never supposed to be exported to begin with, or it might be + just something we need to export once again. +* Moved the `attributeControl` function from `Graphics.Vty.Input.Loop` + to `Graphics.Vty.Input`. +* Removed the `Graphics.Vty.Image.DisplayText` alias for `Text`. +* Unified the `Image` cropping constructors (thanks Fraser Tweedale) + +5.37 +---- + +* The Xterm backend is now used when `TERM` matches `rxvt` or `tmux`. +* PictureToSpans now uses `error`, not `fail`, to avoid dependence on + soon-to-be-removed `MonadFail` instance for `ST` (#248) + +5.36 +---- + + * Raised `microlens` upper bound to allow building with 0.4.13. + * Replaced incomplete `Show` output for `Picture` with a derived + instance; derived `Show` for `Cursor` and `Background`, too. + +5.35.1 +------ + +Bug fixes: + * Fixed a build issue with a test program. + +5.35 +---- + +New features: + * Add support for 24-bit color (thanks @u-quark). This change + updates Vty to look at the `COLORTERM` environment variable that is + conventionally used to advertise support for truecolor escape + sequences. The change also updates the Vty demo to demonstrate + 24-bit colors. This change also adds a new data type, `ColorMode`, + to represent the color mode in use, as well as an `Output` interface + field, `outputColorMode`, to track the active color mode and use it + to clamp emitted color escape sequences to the active color range. + +API changes: + * All types in `Graphics.Vty.Input.Events` now have strict constructor + fields. + * Internal events are now wrapped in a new `InternalEvent` type to + improve how signal handling is done. This change modifies the `Input` + type's event channel API to produce `InternalEvents`, not `Events`. + The new `InternalEvent` either wraps `Event` with the `InputEvent` + constructor (the previous behavior) or indicates that Vty resumed + after handling a signal using the `ResumeAfterSignal` constructor. + This change avoids the previous use of `EvResize` with lazy exception + arguments as a sentinel value for `ResumeAfterSignal`. + +Other enhancements: + * Bracketed paste parsing performance has been greatly improved thanks + to benchmarking and optimization work by @iphydf. As part of that + work, Vty now uses bytestrings rather than Strings internally when + parsing input to look for events. + * The `\b` value is now interpreted as `KBS` (thanks @vglfr) + +5.34 +---- + +API changes: + * Added an `NFData` instance for `Event` (thanks Mario Lang) + * Removed `Monoid` and `Semigroup` instances for `Attr` and + `MaybeDefault`. This change removed the instances because they were + misbehaved; merging `Attr` and `MaybeDefault` values with these + instances resulted in field value losses. For example, before this + change, +``` +(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green) +``` + would result in just +``` + (defAttr `withBackColor` green) +``` + because the instances were designed to favor the right-hand + arguments' fields even if they had not been explicitly set + (a consequence of the `MaybeDefault` `Semigroup` instance). + While that behavior was sensible specifically in the context of + `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made + for surprising instance behavior. Since there is actually no good way + to handle this in a `Semigroup` instance for `Attr` -- some choices + have to be made about how to merge two attributes' foreground colors, + and that won't be much better than what we had -- the instance was + just removed. + + +5.33 +---- + +API changes: +* The `Cursor` type got a new `PositionOnly` constructor for cursor + placement without visibility. + +Package changes: +* Relaxed upper bound for `random` +* Updated `microlens` bounds to allow 0.4.12 + +Other improvements: +* Various hlint-driven improvements (thanks Willem Van Onsem) +* The implementation of `color240` was improved (thanks (Willem Van + Onsem) + +5.32 +---- + +New features: + * Meta-PageUp and Meta-PageDown are now supported (#193) + * Added `supportsItalics` and `supportsStrikethrough` functions to + check for feature support in terminfo + +Bug fixes: + * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka + Nkurumeh) + +5.31 +---- + +New features and API changes: + * Added support for strikethrough mode. This change adds a new + `strikethrough` `Style` value and uses the `smxx` and `rmxx` + Terminfo capabilities to activate and deactivate strikethrough mode, + respectively. If the terminfo does not report those capabilities, + this style is ignored. + * `Output`: added the `setDisplayBounds` field to set the output + dimensions of the output handle; added an implementation of this for + the `TerminfoBased` backend. + +Other changes: + * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed. + +5.30 +---- + +New features: + * Added `Graphics.Vty.setWindowTitle` to emit an escape + sequence to set the window title, provide the terminal emulator + accepts Xterm-style title sequences. For details, see: + https://tldp.org/HOWTO/Xterm-Title-3.html + +5.29 +---- + +API changes: + * The Input type got a new field, 'restoreInputState'. This field + allows the end user to have direct access to the logic needed to + restore the terminal's input state flags. Prior to having this field, + this state restoration logic could only be invoked as part of calling + 'shutdownInput', but since that function does other things (like + killing threads) it is not advisable to call it repeatedly (which is + necessary in the use case this change is intended to support). This + can be called directly to restore the input state flags as needed, + although this is not required if 'shutdown' (or 'shutdownInput') is + called. + +Other changes: + * attributeControl: explicitly enable the ICRNL terminal mode flag (see + #187 and c572ad). + +5.28.2 +------ + +Bug fixes: + * Added a package dependency on `semigroups` for the + `vty-build-width-table` tool on older GHCs (#185) + +5.28.1 +------ + +Bug fixes: + * `installUnicodeWidthTable`: use `throwIO`, not `throw` + +5.28 +---- + +This release improves Vty's support for multi-column Unicode characters +and provides greater compatibility with a wider array of terminal +emulators. The following sections summarize the relevant changes, but an +overview of the new functionality is motivated and detailed in the new +"Multi-Column Character Support" README section. For +historical context, please also consider reading over +[#175](https://github.com/jtdaugherty/vty/issues/175). + +API changes: + * New modules were added: + * `Graphics.Vty.UnicodeWidthTable.Types` + * `Graphics.Vty.UnicodeWidthTable.IO` + * `Graphics.Vty.UnicodeWidthTable.Query` + * `Graphics.Vty.UnicodeWidthTable.Install` + * The `Config` type got a new field, `allowCustomUnicodeWidthTables`, + that controls whether `mkVty` will attempt to load a Unicode width + table if specified in the configuration. + +Configuration file changes: + * A new syntax was added to support specifying Unicode width tables on + a per-`TERM` basis. The syntax is `widthMap `. See the + documentation for `Graphics.Vty.Config` for details. Since prior + versions of this library will silently ignore any configuration file + lines they cannot parse, this change to user configuration files is + at least non-breaking for older versions of Vty. + +Other changes: + * The `mkVty` function now automatically attempts to load a custom + Unicode width table if one is specified in the configuration, + provided `allowCustomUnicodeWidthTables` is not set to `Just False`. + See the documentation for `Graphics.Vty.mkVty` for details. + * Vty now includes a command line tool, `vty-build-width-table`, that + queries the terminal emulator to construct a custom Unicode width + table and optionally update the Vty configuration file to use it. + Programs that want to use that tool's functionality may also do so + via the API exposed in the various modules listed above. + +5.27 +---- + +* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the + kernel for the current terminal's settings to obtain the character + assigned by the `stty erase` command. That can then be added to the + Vty configuration's input map to map to `KBS` (backspace) if desired. + +5.26 +---- + +* Resolved various import warnings (thanks @glguy) +* Removed the `MonadIO` constraint from the Output type's fields and + removed `MonadFail` uses (PR #177, thanks @glguy) +* Clarified documentation for ANSI colors (thanks Colby Jenn) +* `Graphics.Vty.Attributes` no longer re-exports + `Graphics.Vty.Attributes.Color` +* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks + Colby Jenn) +* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak) +* Changed from using `System.Posix.Env.getEnv` to + `System.Environment.lookupEnv` (thanks Jonathan Osser) +* Added `Graphics.Vty.Image` functions for dealing with character width + computations on `Text` values instead of `Strings`: + * `safeWctwidth` + * `safeWctlwidth` + * `wctwidth` + * `wctlwidth` + +5.25.1 +------ + +* Avoided a conflict with a Microlens 0.4.10 operator and added an + upper bound on Microlens of 0.4.11. + +5.25 +---- + +* The Vty type got a new field, isShutdown, that returns whether the + Vty handle has had its 'shutdown' function called (thanks Ian + Jeffries) +* Vty's shutdown function is now thread-safe. + +5.24.1 +------ + +* The "shutdown" method of Vty handles is now idempotent (#159) + +5.24 +---- + +* Add Generic and NFData instances for some types +* Image: remove custom Show instance, add derived Show and Read + instances +* Updated Travis build settings (thanks Eric Mertens) + +5.23.1 +------ + +* Fixed a bug where italics did not combine properly with other display + modes (#155, thanks Eric Mertens) + +5.23 +---- + +* Added support for italicized output when terminfo supports it. This + takes the form of a new Style, "italic". Note that most terminfo + descriptors do not report capabilities for italics, so support for + this will be very spotty. +* Updateed text/string function documentation to indicate that escapes + are not permitted in their inputs. + +5.22 +---- + +* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function + (thanks Brent Carmer) +* Added nextEventNonblocking function (field) to Vty type (#87) + +5.21 +---- + +* Picture and Background now provide Eq instances (thanks Jaro Reinders) +* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner) +* #142: note requirement of threaded RTS + +5.20 +---- + +API changes: +* Split up Monoid instances into Monoid and Semigroup for newer GHCs + (thanks Ryan Scott) + +5.19.1 +------ + +API changes: +* Cursor now provides an Eq instance (thanks Jaro Reinders) + +5.19 +---- + +API changes: +* URL hyperlinking (via 'withURL') is now optional and disabled by + default due to poor support on some common terminals. A new 'Mode' + constructor, 'Hyperlink', has been added to enable this feature. To + change the hyperlinking mode, use 'setMode' on the 'outputIface' of a + Vty handle. + +5.18.1 +------ + +Bug fixes: +* Reset the hyperlink state on line endings to avoid run-on hyperlinks + +5.18 +---- + +API changes: +* Added support for hyperlinking attributes (thanks Getty Ritter). This + change adds a new Attr field for containing the hyperlink to apply, + as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda + +5.17.1 +------ + +* withStyle now ignores zero arguments, leaving attribute styles + untouched if the input style is the null style + +5.17 +---- + +API changes: +* Add support for terminal focus events. This change adds a new mode + usable with setMode, Focus, that requests that the terminal send + events on focus lose/gain. This change also adds two new Event + constructors, EvLostFocus and EvGainedFocus. +* No longer enable UTF8 mouse event encoding. This encoding was not + working properly with Terminal.app, and using the other modes (SGR, + etc.) work. +* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes + #131) + +5.16 +---- + +API changes: +* Added support for mouse wheel events while in mouse mode. The Button + type got two new constructors as a result: BScrollUp and BScrollDown. + Thanks to doublescale@tutanota.com for this contribution! + +Bug fixes: +* charFill now clamps negative arguments to zero (thanks Eric Mertens!) + +5.15.1 +------ + +Package changes: +* Documentation files are now marked accordingly (thanks Michal + Suchánek) + +Bug fixes: +* translateX/Y: fix negative translations + +5.15 +---- + +Package changes: +* Discontinued support for GHC versions prior to 7.10.1. +* Removed instructions and configuration for Stack builds since they + are no longer supported. +* Clarified README mention of (lack of) Windows support (contributors + wanted, though!) +* Removed dependency on data-default (see below). + +API changes: +* Moved color definitions from Attributes to Color module. +* In lieu of data-default (Default) instances for Attr and Config, use + 'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'. +* Graphics.Vty.Output no longer re-exports + Graphics.Vty.Output.Interface. +* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its + accessors to Graphics.Vty.Image. +* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes. +* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image. + +5.14 +---- + +* addMaybeClippedJoin: instead of raising an exception when the join + is totally clipped, just reduce the clip amount and continue +* addMaybeClipped: skip blit of joins when their primary dimension is + zero +* 'string' and related text functions no longer treat an empty string + as an empty image (thanks Chris Penner). This means that now it is + possible to use 'str ""' as a non-empty image with height 1. + +5.13 +---- + +* Reverted changes in 5.12 due to disagreements between terminal + emulators and utf8proc; for more details, please see the ticket + discussion at + https://github.com/coreyoconnor/vty/issues/115 + +5.12 +---- + +* Replaced 'wcwidth' with a call to the utf8proc library's character + width function, which is much more up to date (by several Unicode + versions) and returns the right width for a much larger set of + characters. +* Added a bundled version of the utf8proc C library. + +5.11.3 +------ + +* Fix mouse event offsets in mouse-up events + +5.11.2 +------ + +* Mouse events were modified so that the upper-left corner of the window + is (0,0) rather than (1,1). + +5.11.1 +------ + +* Add Generic instance for Image +* nextEvent: stop trying to refresh on a resize event (fixes segfault + on refresh with normal cursor positioning mode) +* Remove redundant clause from clipForCharWidth (thanks Eric Mertens) +* Update maintainer + +5.11 +---- + +* Vty now raises a VtyConfigurationError exception when the TERM + evironment variable is missing (thanks Eric Mertens) +* Graphics.Vty.Config got an explicit export list to avoid accidentally + exporting internal types (thanks Eric Mertens) + +5.10 +---- + +* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This + mode provides greater control over cursor positioning by bypassing + the logical positioning provided by default. Rather than positioning + the cursor by looking at the widths of characters involved, this + constructor lets you provide a physical row and column instead. This + is useful in more sophisticated programs. (thanks Eric Mertens) +* Added a new Generic-derived config parser (thanks Eric Mertens) +* Fixed the MShift case in the configuration file parser (thanks Eric + Mertens) +* Fixed wcwidth import and matched safeWcswidth to its documented + behavior. Previously vty_mk_wcwidth was being imported with the + wrong type causing the -1 return value to be mapped to the wrong Int + value. Additionally safeWcswidth was using the unsafe character width + function and only ensuring that the final result was non-negative. + (thanks Eric Mertens) + +5.9.1 +----- + +* Vty now only emits UTF8 charset sequences in terminals without a + preexisting UTF8 declaration to avoid emitting garbage sequences + (fixes #89) + +5.9 +--- + +* Added new Output methods supportsBell and ringTerminalBell to find out + whether the output device has an audio bell and to ring it (see #102) + +5.8.1 +----- + +* Fixed "refresh" to work as advertised (see #104) + +5.8 +--- + +* API change: EvPaste input event now provides paste data as a raw + ByteString rather than a String to allow the application to decode how + best to decode it + +5.7.1 +----- + +* ModeDemo: added an explicit Control.Applicative import for older GHCs + +5.7 +--- + +* Mouse and paste modes are now off by default. +* The Config type got new fields: mouseMode and bracketedPasteMode. + These determine whether these modes are enabled initially (for + terminals that support them). +* Added a Mode type for modal terminal features (mouse events, + bracketed paste mode) that is used with new Output interface + functions: + * supportsMode :: Mode -> Bool tells whether the device supports a + mode + * setMode :: Mode -> Bool -> IO () turns a mode on or off + * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or + off +* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes + +5.6 +--- + +* Added support for normal and extended mouse modes in Xterm-like + terminals via the MouseDown and MouseUp Event constructors +* Added support for bracketed paste mode in Xterm-like terminals via + the EvPaste event constructor +* Added derived Show instances for Event and Button (thanks Felix + Hirn) +* Now TERM values containing "screen" will automatically use the + XtermColor driver rather than just TerminfoBased + +5.5.0 +----- + +* Replaced lens dependency with microlens, microlens-mtl, microlens-th + dependencies. Issue #90 + * Thanks Jonathan Daugherty +* Cabal corrections. + * Thanks Lennart Spitzner + +5.4.0 +----- + +* Changed eventChannel of Graphics.Vty.Input from Chan to + TChan. This enables clients to query if there are no pending + events. The Graphics.Vty interface nextEvent is unchanged. + Clients that use eventChannel directly will require updating. + https://github.com/coreyoconnor/vty/issues/60 + +5.3.1 +----- + +* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to + possibly breaking this on reasonable GHC versions + +5.3 +--- + +* Upgraded QuickCheck dependency to 2.7 +* The standard IO Config (standardIOConfig) was overriding any provided + application config. In addition, the inputFd and outputFd could not be + changed if mkVty was used. Fixed. +* Correct handling of display attributes at end of line. The output + attributes are set to default at the end of content for the line and + at the start of a new line. Previously the current attribute would + extend to the next start of content. This was odd to reason about and + was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi + requires the old behavior to display the selection region correctly. +* shutdown of the input thread is now performed using killThread and + synchronization on an MVar. For correct handling of the terminal read + vmin and vtime the read must be a blocking read on an OS thread. + This places a threadWaitRead, which will be interrupted by the + killThread, prior to the uninterruptable read. An alternative would be + to re-import the read foreign call as interruptable. + +5.2.11 +------ + +* deepseq bounds increased for tests. +* Clean up warnings when compiling on 7.10 + * Thanks Eric Mertens +* Avoid discarding input bytes after multi-byte encoded codepoint + * Thanks Eric Mertens + +5.2.10 +------ + +* "str" now returns EmptyImage for empty strings to match behavior of + other string-like Image constructors (fixes #74) + * Thanks Jonathan Daugherty + +5.2.9 +----- + +* dependency version bumps + * https://github.com/coreyoconnor/vty/pull/71 + * https://github.com/coreyoconnor/vty/pull/70 +* Correct/Simplify the example code + * Thanks glguy + * https://github.com/coreyoconnor/vty/pull/69 + +5.2.8 +----- + +* blaze-builder, lens, utf8-string version constraint bump + * Thanks glguy + * https://github.com/coreyoconnor/vty/pull/67 +* Do not differentiate based on TERM_PROGRAM + * https://github.com/coreyoconnor/vty/issues/68 + +5.2.7 +----- + +* lens and deepseq constraint bump + misc + * Thanks ethercrow + * https://github.com/coreyoconnor/vty/pull/66 + +5.2.6 +----- + +* lens constraint bump + * Thanks alexander-b! + * https://github.com/coreyoconnor/vty/pull/64 + +5.2.5 +----- + +* lens and random version constraint bump. + * Thanks RyanGlScott! + * https://github.com/coreyoconnor/vty/pull/62 + +5.2.4 +----- + +* removed -fpic from cc-options. No longer required. + * https://github.com/coreyoconnor/vty/issues/61 + * https://ghc.haskell.org/trac/ghc/ticket/9657 + * Thanks Fuuzetsu! + +5.2.3 +----- + +* evaluate/compile the input parsing table once instead of each + keystroke. + * https://github.com/coreyoconnor/vty/pull/59 + * Thanks ethercrow! + +5.2.2 +----- + +* When looking at input for an event, don't look too deep. + * https://github.com/coreyoconnor/vty/pull/57 + * Thanks ethercrow! + +5.2.1 +----- + +* Bump upper version bound for lens to 4.5. Thanks markus1189! + +5.2.0 +----- + +* Config structure now specifies file descriptor to use. The default + is stdInput and stdOutput file descriptors. Previously Vty used + stdInput for input and the follow code for output: + * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` + NoBuffering) + * the difference was required by Vty.Inline. Now, Vty.Inline uses + the Config structure options to acheive the same effect. +* removed: derivedVtime, derivedVmin, inputForCurrentTerminal, + inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO +* added: inputForConfig, outputForConfig +* updates to vty-rogue from jtdaugherty. Thanks! +* the oldest version of GHC tested to support vty is 7.6.2. +* the oldest version of GHC that vty compiles under is 7.4.2 + +5.1.4 +----- + +* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi! + +5.1.1 +----- + +* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke! +* jtdaugherty resolved a number of compiler warnings. Thanks! + +5.1.0 +----- + +* vmin and vtime can be specified however the application requires. + See Graphics.Vty.Config. +* fixed the processing of input when vmin is set > 1. + +5.0.0 +----- + +* The naming convention now matches: + * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions +* all projects using vty for input must be compiled with -threaded. + Please notify vty author if this is not acceptable. +* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized + vty with the default configuration. +* input handling changes + * KASCII is now KChar + * KPN5 is now KCenter + * tests exist. + * Applications can add to the input tables by setting inputMap of + the Config. See Graphics.Vty.Config + * Users can define input table extensions that will apply to all vty + applications. See Graphics.Vty.Config + * terminal timing is now handled by selecting an appropriate VTIME. + Previously this was implemented within Vty itself. This reduced + complexity in vty but provides a different meta key behavior and + implies a requirement on -threaded. + * The time vty will wait to verify an ESC byte means a single ESC + key is the singleEscPeriod of the Input Config structure. +* removed the typeclass based terminal and display context interface + in favor of a data structure of properties interface. +* renamed the Terminal interface to Output +* The default picture for an image now uses the "clear" background. + This background fills background spans with spaces or just ends the + line. + * Previously the background defaulted to the space character. This + causes issues copying text from a text editor. The text would end + up with extra spaces at the end of the line. +* Layer support + * Each layer is an image. + * The layers for a picture are a list of images. + * The first image is the top-most layer. The images are ordered from + top to bottom. + * The transparent areas for a layer are the backgroundFill areas. + backgroundFill is added to pad images when images of different + sizes are joined. + * If the background is clear there is no background layer. + * If there is a background character then the bottom layer is the + background layer. + * emptyPicture is a Picture with no layers and no cursor + * addToTop and addToBottom add a layer to the top and bottom of the + given Picture. +* compatibility improvements: + * terminfo based terminals with no cursor support are silently + accepted. The cursor visibility changes in the Picture will have + no effect. + * alternate (setf/setb) color maps supported. Though colors beyond + the first 8 are just a guess. + * added "rgbColor" for easy support of RGB specified colors. + * Both applications and users can add to the mapping used to + translate from input bytes to events. +* Additional information about input and output process can be + appended to a debug log + * Set environment variable VTY_DEBUG_LOG to path of debug log + * Or use "debugLog " config directive + * Or set 'debugLog' property of the Config provided to mkVty. +* examples moved to vty-examples package. See test directory for cabal + file. + * vty-interactive-terminal-test + * interactive test. Useful for building a bug report for vty's + author. + * test/interactive_terminal_test.hs + * vty-event-echo + * view a input event log for vty. Example of interacting with + user. + * test/EventEcho.hs + * vty-rogue + * The start of a rogue-like game. Example of layers and image + build operations. + * test/Rogue.hs + * vty-benchmark + * benchmarks vty. A series of tests that push random pictures to + the terminal. The random pictures are generated using + QuickCheck. The same generators used in the automated tests. + * test/benchmark.hs + +4.7.0.0 +------- + +API changes: +* Added Graphics.Vty.Image.crop: Ensure an image is no larger + than the specified size. +* Added Graphics.Vty.Image.pad: Ensure an image is no smaller + than the specified size. +* Added Graphics.Vty.Image.translate: Offset an image. +* Thanks Ben Boeckel for these features. + +4.2.1.0 +------- + +API changes: +* Attr record accessor fore_color changed to attr_fore_color +* Attr record accessor back_color changed to attr_back_color +* Attr record accessor style changed to attr_style +* Added an "inline" display attribute changing DSL: + * put_attr_change applies a display attribute change + immediately to a terminal + * For instance, can be used to change the display attrbiutes + of text output via putStrLn and putStr. EX: + "put_attr_change $ back_color red" will set the background + color to red. + * Changes do not apply to a Picture output via output_picture. + * See Graphics.Vty.Inline +* Moved all IO actions into any monad an instance of MonadIO + +4.0.0.1 +------- + +* binding for mk_wcswidth was incorrect. Most platforms just + magically worked due to coincidence. + +4.0.0 +----- + +API changes: +* "getSize" has been removed. Use "terminal vty >>= display_bounds" + where "vty" is an instance of the Vty data structure. +* added a "terminal" field to the Vty data structure. Accesses the + TerminalHandle associated with the Vty instance. +* Graphics.Vty.Types has undergone a number of changes. Summary: + * Partitioned into Graphics.Vty.Attributes for display attributes. + Graphics.Vty.Image for image combinators. Graphics.Vty.Picture + for final picture construction. +* Graphics.Vty.Attributes: + * "setFG" and "setBG" are now "with_fore_color" and + "with_back_color" + * All other "set.." equations similarly replaced. + * "attr" is now "def_attr", short for "default display attributes" + Also added a "current_attr" for "currently applied display + attributes" +* Graphics.Vty.Image: + * "horzcat" is now "horiz_cat" + * "vertcat" is now "vert_cat" + * "renderBS" is now "utf8_bytestring" + * "renderChar" is now "char" + * "renderFill" is now "char_fill" + * added a "utf8_string" and "string" (AKA "iso_10464_string") for + UTF-8 encoded Strings and ISO-10464 encoded Strings. String + literals in GHC have an ISO-10464 runtime representation. +* Graphics.Vty.Picture: + * exports Graphics.Vty.Image + * "pic" is now "pic_for_image" + * added API for setting background fill pattern. +* Completely rewritten output backend. + * Efficient, scanline style output span generator. Has not been + fully optimized, but good enough. + * The details required to display the desired picture on a + terminal are well encapsulated. + * Terminfo based display terminal implementation. With specialized + derivitives for xterm, Terminal.app, and iTerm.app. + * Attempts to robustly handle even terminals that don't + support all display attributes. + * I've tested the following terminals with success: iTerm.app, + Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal, + konsole, screen, linux vty. Hopefully you will be as + successfull. + * Improved unicode support. Double wide characters will display as + expected. +* 256 color support. See Graphics.Vty.Attributes.Color240. The actual + output color is adjusted according to the number of colors the + terminal supports. +* The Graphics.Vty.Image combinators no longer require matching + dimensions to arguments. Unspecified areas are filled in with a + user-customizable background pattern. See Graphics.Vty.Picture. +* output images are always cropped to display size. +* Significant code coverage by QuickCheck tests. An interactive test + for those final properties that couldn't be automatically verified. + +Issues resolved: +* "gnome terminal displays non-basic attributes as strikethrough" + * http://trac.haskell.org/vty/ticket/14 +* "Multi-byte characters are not displayed correctly on update" + * http://trac.haskell.org/vty/ticket/10 +* "Redraw does not handle rendering a line that extends beyond screen + width characters" + * http://trac.haskell.org/vty/ticket/13 +* "The <|> and <-> combinators should be more forgiving of mismatched + dimensions" + * http://trac.haskell.org/vty/ticket/9 +* "256-color support" + * http://trac.haskell.org/vty/ticket/19 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,5 @@ +BSD 3-Clause License + Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,51 +4,60 @@ interface for doing terminal I/O. Vty is supported on GHC versions 7.10.1 and up. -Install via `git` with: +`vty` and its partner packages are published on +[Hackage](https://hackage.haskell.org/). The `vty` package works in +concert with one or more *platform packages* to do terminal I/O. Each +platform package provides support for terminal I/O on a specific +platform. Known platform packages are: -``` -git clone git://github.com/jtdaugherty/vty.git -``` +* [vty-unix](https://github.com/jtdaugherty/vty-unix) - the Unix + terminal backend for Vty +* [vty-windows](https://github.com/chhackett/vty-windows) - the Windows + terminal backend for Vty +* [vty-crossplatform](https://github.com/jtdaugherty/vty-crossplatform) - + a package that builds `vty-unix` or `vty-windows` based on the build + environment -Install via `cabal` with: +# How to use Vty -``` -cabal install vty -``` +1. Add a package dependency on `vty-unix`, `vty-windows,` or + `vty-crossplatform`, depending on the desired level of platform + support. For example, if an application only supports Unix systems, + it should depend on `vty-unix`. But if an application is intended to + work anywhere Vty works, then `vty-crossplatform` is the best choice. +2. Add a package dependency on `vty`; the core library abstractions, + types, and functions are obtained from `vty` itself. The platform + packages do not re-export the core library's modules. +3. Import `mkVty` from the platform package in step (1) and use that to + construct a `Vty` handle and initialize the terminal. +4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty + user configuration since this step is not automatic. -# Features +Once you've initialized the terminal and have a `Vty` value, all of the +`vty` package's API is now ready to use to do terminal I/O. -* Supports a large number of terminals. vt100, ansi, hurd, linux, - screen, etc., or anything with a sufficient terminfo entry. +# Implementing support for a new platform -* Automatic handling of window resizes. +Although this shouldn't be necessary to do very often (if ever!), if +you would like to implement support for a new platform for Vty, see +`PLATFORM-HOWTO.md`. -* Unicode output on terminals with UTF-8 support. +# Features -* Handles multi-column glyphs. (Requires user to properly configure - terminal.) +* Provides an efficient output algorithm. Output buffering and terminal + state changes are minimized. -* Efficient output. Output buffering and terminal state changes are - minimized. +* Automatically handles window resizes. * Minimizes repaint area, which virtually eliminates the flicker problems that plague ncurses programs. -* A pure, compositional interface for efficiently constructing display - images. - -* Automatically decodes keyboard keys into (key,[modifier]) tuples. +* Provides a pure, compositional interface for efficiently constructing + display images. * Automatically supports refresh on Ctrl-L. -* Supports a keypress timeout after for lone ESC. The timeout is - customizable. - -* The interface is designed for easy extension. - -* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`) - with a type-safe interface and graceful fallback for terminals - with limited or nonexistent support for such modes. +* Provides extensible input and output interfaces. * Properly handles cleanup (but not due to signals). @@ -60,86 +69,99 @@ * Supports bracketed paste mode as described at http://cirw.in/blog/bracketed-paste +* Supports multi-column Unicode characters such as emoji characters. In + cases where Vty and your terminal emulator disagree on character + widths, Vty provides a tool `vty-build-width-table` and library + functionality to build a width table that will work for your terminal + and load it on application startup. + # Development Notes Vty uses threads internally, so programs made with Vty need to be compiled with the threaded runtime using the GHC `-threaded` option. -# Platform Support +# Multi-Column Character Support -## Posix Terminals +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 terminfo to determine terminal protocol. With some special rules to -handle some omissions from terminfo. +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. -## Windows +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. -Unsupported (but contributions and testing here are very welcome!) +Custom Unicode width tables based on your terminal emulator can +be built by using the API in `Graphics.Vty.UnicodeWidthTable`. +The process works by querying the current terminal environment to +obtain its width measurements for the entire supported Unicode +range. The results are then saved to a disk file. +Saved width tables can then be loaded in one of two ways: + +* Via the library API in `Graphics.Vty.UnicodeWidthTable.IO` +* By adding a `widthMap` directive to your Vty configuration file and + then invoking `mkVty` to initialize Vty + +The Vty configuration file supports the `widthMap` directive to allow +users to specify which custom width table should be loaded for a given +terminal type. This is done by specifying, e.g., + +``` +widthMap "xterm" "/path/to/map.dat" +``` + +where the first argument is the value that `TERM` must have in order for +the table to be loaded, and the second argument is the path to the table +file itself as generated by the two alternatives listed above. If the +Vty configuration file contains multiple matching `widthMap` directives +for the current value of `TERM`, the last one listed in the file is +used. + +The tables declared in the configuration file are only ever +automatically loaded when applications set up Vty by calling +`Graphics.Vty.mkVty`. + +Before a custom table has been loaded, calls to the library's character +width functions (e.g. `wcwidth`) will use the default built-in table. +Once a custom table has been loaded, the functions will use the new +custom table. Only one custom table load can be performed in a Vty +program. Once a custom table has been loaded, it cannot be replaced or +removed. + # Contributing If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - Patches written completely or partially by AI are unlikely to be + accepted. Please disclose any AI use. - If you want to take on big things, talk to me first; let's have a design/vision discussion before you start coding. Create a GitHub issue and we can use that as the place to hash things out. - If you make changes, make them consistent with the syntactic conventions already used in the codebase. - Please provide Haddock documentation for any changes you make. - -# Development Notes - -## Under NixOS - -### Using cabal - -After installing `ncurses` to the user environment: - -~~~ -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 -~~~ - -## Code Coverage - -As of last testing, profiling causes issues with coverage when enabled. -To evaluate coverage, configure as follows: - -~~~ -rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \ - --disable-library-profiling \ - --disable-executable-profiling -~~~ - -## Profiling - -~~~ -rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \ - --enable-library-profiling \ - --enable-executable-profiling -~~~ - -# Known Issues - -* Terminals have numerous quirks and bugs. Vty picks what works best for - the author in ambiguous or buggy situations. - -* Signal handling of STOP, TERM and INT are nonexistent. - -* The character encoding of the terminal is assumed to be UTF-8 if - unicode is used. - -* Terminfo is assumed to be correct unless there is an override - configured. Some terminals will not have correct special key support - (shifted F10 etc). See `Config` for customizing vty's behavior for a - particular terminal. - -* Uses the `TIOCGWINSZ` ioctl to find the current window size, which - appears to be limited to Linux and BSD. + - Please do NOT include package version changes in your patches. + Package version changes are only done at release time when the full + scope of a release's changes can be evaluated to determine the + appropriate version change. -# Sources +# Further Reading Good sources of documentation for terminal programming are: 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 @@ -60,7 +60,32 @@ */ #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; @@ -119,7 +144,7 @@ * in ISO 10646. */ -HsInt vty_mk_wcwidth(HsChar 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 */ @@ -201,4 +226,126 @@ (ucs >= 0xffe0 && ucs <= 0xffe6) || (ucs >= 0x20000 && ucs <= 0x2fffd) || (ucs >= 0x30000 && ucs <= 0x3fffd))); +} + +// Return the width, in terminal cells, of the specified character. +// +// If the global custom width table is present, that table will be +// consulted for the character's width. If the character is not in the +// table, this will fall back to the built-in table. If the character is +// in neither table, zero will be returned. If the custom width table is +// not present, the built-in width table will be used. +HsInt vty_mk_wcwidth(HsChar ch) +{ + if (custom_table_ready) { + if ((ch >= 0) && (ch < custom_table_size)) { + uint8_t result = custom_table[ch]; + + // The table is filled with UNUSED_CELL values for + // uninitialized ranges so we can defer to the built-in + // table in those cases. + if (result == UNUSED_CELL) { + return builtin_wcwidth(ch); + } else { + return result; + } + } else { + return -1; + } + } else { + return builtin_wcwidth(ch); + } +} + +// Initialize a custom character width table. +// +// This allocates a new character width table of the specified size +// (in characters). If a custom table has already been allocated, this +// returns 1. Otherwise it allocates a new table, initializes all of its +// entries to UNUSED_CELL, and returns zero. +// +// Note that this does *not* mark the table as ready for use. Until the +// table is marked ready, it will not be used by vty_mk_wcwidth. To mark +// the table as ready, call vty_activate_custom_table() after the table +// has been set up with calls to vty_set_custom_table_range. +int vty_init_custom_table(int size) +{ + if (custom_table == NULL) { + if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) { + custom_table_ready = 0; + custom_table = malloc(size); + memset(custom_table, UNUSED_CELL, size); + custom_table_size = size; + return 0; + } else { + return 1; + } + } else { + return 1; + } +} + +// Set the specified character range in the custom width table to the +// specified width. +// +// This function sets 'width' as the character width for all entries +// in the custom character table starting at the 'start' entry and +// including all entries up to and including 'start + size - 1'. +// +// If this succeeds, it returns zero. If it fails, it returns 1. It +// fails if the table is not allocated, marked as ready (i.e. it is in +// use and has already been populated), or if the start or size values +// are not in bounds for the table. +int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width) +{ + if ((custom_table == NULL) || + (size >= custom_table_size) || + (start >= custom_table_size) || + ((start + 1) >= (custom_table_size - size)) || + custom_table_ready) { + return 1; + } else { + memset(custom_table + start, width, size); + return 0; + } +} + +// Mark the allocated custom character width table as ready for use. +// +// After this call, further calls to vty_set_custom_table_range will +// fail. +// +// This function returns 0 if it succeeds. If it fails, it returns 1. +// It fails if the custom table is already ready or if it has not been +// allocated. +int vty_activate_custom_table() +{ + if (custom_table_ready || (custom_table == NULL)) { + return 1; + } else { + custom_table_ready = 1; + return 0; + } +} + +// Returns whether a custom character width table has been marked ready. +int vty_custom_table_ready() +{ + return custom_table_ready; +} + +// Deallocate the custom width table. +// +// This does nothing if there is no allocated custom width table, or if +// there is one but it is in use (marked ready). This is only useful if +// an initial allocation succeeds, but range population fails, after +// which point the application may want to deallocate the table to avoid +// leaving it in an intermediate state. +void vty_deallocate_custom_table() +{ + if ((custom_table != NULL) && (!custom_table_ready)) { + free(custom_table); + custom_table = NULL; + custom_table_size = 0; + } } 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/demos/Demo.hs b/demos/Demo.hs deleted file mode 100644 --- a/demos/Demo.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main where - -import Graphics.Vty - -import Control.Applicative hiding ((<|>)) -import Control.Arrow -import Control.Monad.RWS - -import Data.Sequence (Seq, (<|) ) -import qualified Data.Sequence as Seq -import Data.Foldable - -eventBufferSize = 1000 - -type App = RWST Vty () (Seq String) IO - -main = do - vty <- if True -- change to false for emacs-like input processing - then mkVty defaultConfig - else mkVty (defaultConfig { vmin = Just 2, vtime = Just 300 } ) - _ <- execRWST (vtyInteract False) vty Seq.empty - shutdown vty - -vtyInteract :: Bool -> App () -vtyInteract shouldExit = do - updateDisplay - unless shouldExit $ handleNextEvent >>= vtyInteract - -introText = vertCat $ map (string defAttr) - [ "this line is hidden by the top layer" - , "The vty demo program will echo the events generated by the pressed keys." - , "Below there is a 240 color box." - , "Followed by a description of the 16 color pallete." - , "If the 240 color box is not visible then the terminal" - , "claims 240 colors are not supported." - , "Try setting TERM to xterm-256color" - , "This text is on a lower layer than the event list." - , "Which means it'll be hidden soon." - , "Bye!" - , "Great Faith in the ¯\\_(ツ)_/¯" - , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" - ] - -colorbox_240 :: Image -colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages - where - colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239] - splitColorImages [] = [] - splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) - -colorbox_16 :: Image -colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border - where - column0 = vertCat $ map lineWithColor normal - column1 = vertCat $ map lineWithColor bright - border = vertCat $ replicate (length normal) $ string defAttr " | " - column2 = vertCat $ map (string defAttr . snd) normal - lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName - normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ] - [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ] - bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue - , brightMagenta, brightCyan, brightWhite ] - [ "bright black", "bright red", "bright green", "bright yellow" - , "bright blue", "bright magenta", "bright cyan", "bright white" ] - -updateDisplay :: App () -updateDisplay = do - let info = string (defAttr `withForeColor` black `withBackColor` green) - "Press ESC to exit. Events for keys below." - eventLog <- foldMap (string defAttr) <$> get - let pic = picForImage (info <-> eventLog) - `addToBottom` (introText <-> colorbox_240 <|> colorbox_16) - vty <- ask - liftIO $ update vty pic - -handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent - where - handleEvent e = do - modify $ (<|) (show e) >>> Seq.take eventBufferSize - return $ e == EvKey KEsc [] - diff --git a/demos/ModeDemo.hs b/demos/ModeDemo.hs deleted file mode 100644 --- a/demos/ModeDemo.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Main where - -import Control.Applicative -import Data.Monoid - -import Graphics.Vty - -mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image -mkUI (m, ms, p, ps) e = - vertCat [ string defAttr $ "Mouse mode supported: " <> show m - , string defAttr $ "Mouse mode status: " <> show ms - , string defAttr " " - , string defAttr $ "Paste mode supported: " <> show p - , string defAttr $ "Paste mode status: " <> show ps - , string defAttr " " - , string defAttr $ "Last event: " <> show e - , string defAttr " " - , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit." - ] - -main :: IO () -main = do - cfg <- standardIOConfig - vty <- mkVty cfg - - let renderUI lastE = do - let output = outputIface vty - info <- (,,,) <$> (pure $ supportsMode output Mouse) - <*> getModeStatus output Mouse - <*> (pure $ supportsMode output BracketedPaste) - <*> getModeStatus output BracketedPaste - return $ picForImage $ mkUI info lastE - - let go lastE = do - pic <- renderUI lastE - update vty pic - e <- nextEvent vty - case e of - EvKey (KChar 'q') [] -> return () - EvKey (KChar 'm') [] -> do - let output = outputIface vty - enabled <- getModeStatus output Mouse - setMode output Mouse (not enabled) - go (Just e) - EvKey (KChar 'p') [] -> do - let output = outputIface vty - enabled <- getModeStatus output BracketedPaste - setMode output BracketedPaste (not enabled) - go (Just e) - _ -> go (Just e) - - go Nothing - shutdown vty 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,18 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- Copyright 2009 Corey O'Connor -module Codec.Binary.UTF8.Debug where - -import Codec.Binary.UTF8.String ( encode ) - -import Data.Word - -import Numeric - --- | Converts an array of ISO-10646 characters (Char type) to an array --- of Word8 bytes that is the corresponding UTF8 byte sequence -utf8FromIso :: [Int] -> [Word8] -utf8FromIso = encode . map toEnum - -ppUtf8 :: [Int] -> IO () -ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso - 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,132 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} - --- | Evaluates the paramaterized terminfo string capability with the --- given parameters. -module Data.Terminfo.Eval - ( writeCapExpr - ) -where - -import Blaze.ByteString.Builder.Word -import Blaze.ByteString.Builder -import Data.Terminfo.Parse - -import Control.Monad.Identity -import Control.Monad.State.Strict -import Control.Monad.Writer - -import Data.Bits ((.|.), (.&.), xor) -import Data.List - -import qualified Data.Vector.Unboxed as Vector - --- | capability evaluator state -data EvalState = EvalState - { evalStack :: ![CapParam] - , evalExpression :: !CapExpression - , evalParams :: ![CapParam] - } - -type Eval a = StateT EvalState (Writer Write) a - -pop :: Eval CapParam -pop = do - s <- get - let v : stack' = evalStack s - s' = s { evalStack = stack' } - put s' - return v - -readParam :: Word -> Eval CapParam -readParam pn = do - !params <- get >>= return . evalParams - return $! genericIndex params pn - -push :: CapParam -> Eval () -push !v = do - s <- get - let s' = s { evalStack = v : evalStack s } - put s' - -applyParamOps :: CapExpression -> [CapParam] -> [CapParam] -applyParamOps cap params = foldl applyParamOp params (paramOps cap) - -applyParamOp :: [CapParam] -> ParamOp -> [CapParam] -applyParamOp params IncFirstTwo = map (+ 1) params - -writeCapExpr :: CapExpression -> [CapParam] -> Write -writeCapExpr cap params = - let params' = applyParamOps cap params - s0 = EvalState [] cap params' - in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0) - -writeCapOps :: CapOps -> Eval () -writeCapOps ops = mapM_ writeCapOp ops - -writeCapOp :: CapOp -> Eval () -writeCapOp (Bytes !offset !count) = do - !cap <- get >>= return . evalExpression - let bytes = Vector.take count $ Vector.drop offset (capBytes cap) - Vector.forM_ bytes $ tell.writeWord8 -writeCapOp DecOut = do - p <- pop - forM_ (show p) $ tell.writeWord8.toEnum.fromEnum -writeCapOp CharOut = do - pop >>= tell.writeWord8.toEnum.fromEnum -writeCapOp (PushParam pn) = do - readParam pn >>= push -writeCapOp (PushValue v) = do - push v -writeCapOp (Conditional expr parts) = do - writeCapOps expr - writeContitionalParts parts - where - writeContitionalParts [] = return () - writeContitionalParts ((trueOps, falseOps) : falseParts) = do - -- (man 5 terminfo) - -- Usually the %? expr part pushes a value onto the stack, - -- and %t pops it from the stack, testing if it is nonzero - -- (true). If it is zero (false), control passes to the %e - -- (else) part. - v <- pop - if v /= 0 - then writeCapOps trueOps - else do - writeCapOps falseOps - writeContitionalParts falseParts - -writeCapOp BitwiseOr = do - v0 <- pop - v1 <- pop - push $ v0 .|. v1 -writeCapOp BitwiseAnd = do - v0 <- pop - v1 <- pop - push $ v0 .&. v1 -writeCapOp BitwiseXOr = do - v1 <- pop - v0 <- pop - push $ v0 `xor` v1 -writeCapOp ArithPlus = do - v1 <- pop - v0 <- pop - push $ v0 + v1 -writeCapOp ArithMinus = do - v1 <- pop - v0 <- pop - push $ v0 - v1 -writeCapOp CompareEq = do - v1 <- pop - v0 <- pop - push $ if v0 == v1 then 1 else 0 -writeCapOp CompareLt = do - v1 <- pop - v0 <- pop - push $ if v0 < v1 then 1 else 0 -writeCapOp CompareGt = do - v1 <- pop - v0 <- pop - push $ if v0 > v1 then 1 else 0 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 BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -funbox-strict-fields -O #-} - -module Data.Terminfo.Parse - ( module Data.Terminfo.Parse - , Text.Parsec.ParseError - ) -where - -import Control.Monad ( liftM ) -import Control.DeepSeq - -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup (Semigroup(..)) -#endif -import Data.Word -import qualified Data.Vector.Unboxed as Vector - -import Numeric (showHex) - -import Text.Parsec - -data CapExpression = CapExpression - { capOps :: !CapOps - , capBytes :: !(Vector.Vector Word8) - , sourceString :: !String - , paramCount :: !Int - , paramOps :: !ParamOps - } deriving (Eq) - -instance Show CapExpression where - show c - = "CapExpression { " ++ show (capOps c) ++ " }" - ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]" - ++ " <= " ++ show (sourceString c) - where - hexDump :: [Word8] -> String - hexDump = foldr (\b s -> showHex b s) "" - -instance NFData CapExpression where - rnf (CapExpression ops !_bytes !str !c !pOps) - = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps - -type CapParam = Word - -type CapOps = [CapOp] -data CapOp = - Bytes !Int !Int -- offset count - | DecOut | CharOut - -- This stores a 0-based index to the parameter. However the - -- operation that implies this op is 1-based - | PushParam !Word | PushValue !Word - -- The conditional parts are the sequence of (%t expression, %e - -- The expression) pairs. %e expression may be NOP - | Conditional - { conditionalExpr :: !CapOps - , conditionalParts :: ![(CapOps, CapOps)] - } - | BitwiseOr | BitwiseXOr | BitwiseAnd - | ArithPlus | ArithMinus - | CompareEq | CompareLt | CompareGt - deriving (Show, Eq) - -instance NFData CapOp where - rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount - rnf (PushParam pn) = rnf pn - rnf (PushValue v) = rnf v - rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts - rnf BitwiseOr = () - rnf BitwiseXOr = () - rnf BitwiseAnd = () - rnf ArithPlus = () - rnf ArithMinus = () - rnf CompareEq = () - rnf CompareLt = () - rnf CompareGt = () - rnf DecOut = () - rnf CharOut = () - -type ParamOps = [ParamOp] -data ParamOp = - IncFirstTwo - deriving (Show, Eq) - -instance NFData ParamOp where - rnf IncFirstTwo = () - -parseCapExpression :: String -> Either ParseError CapExpression -parseCapExpression capString = - let v = runParser capExpressionParser - initialBuildState - "terminfo cap" - capString - in case v of - Left e -> Left e - Right buildResults -> Right $ constructCapExpression capString buildResults - -constructCapExpression :: [Char] -> BuildResults -> CapExpression -constructCapExpression capString buildResults = - let expr = CapExpression - { capOps = outCapOps buildResults - -- The cap bytes are the lower 8 bits of the input - -- string's characters. - , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString - , sourceString = capString - , paramCount = outParamCount buildResults - , paramOps = outParamOps buildResults - } - in rnf expr `seq` expr - -type CapParser a = Parsec String BuildState a - -capExpressionParser :: CapParser BuildResults -capExpressionParser = do - rs <- many $ paramEscapeParser <|> bytesOpParser - return $ mconcat rs - -paramEscapeParser :: CapParser BuildResults -paramEscapeParser = do - _ <- char '%' - incOffset 1 - literalPercentParser <|> paramOpParser - -literalPercentParser :: CapParser BuildResults -literalPercentParser = do - _ <- char '%' - startOffset <- getState >>= return . nextOffset - incOffset 1 - return $ BuildResults 0 [Bytes startOffset 1] [] - -paramOpParser :: CapParser BuildResults -paramOpParser - = incrementOpParser - <|> pushOpParser - <|> decOutParser - <|> charOutParser - <|> conditionalOpParser - <|> bitwiseOpParser - <|> arithOpParser - <|> literalIntOpParser - <|> compareOpParser - <|> charConstParser - -incrementOpParser :: CapParser BuildResults -incrementOpParser = do - _ <- char 'i' - incOffset 1 - return $ BuildResults 0 [] [ IncFirstTwo ] - -pushOpParser :: CapParser BuildResults -pushOpParser = do - _ <- char 'p' - paramN <- digit >>= return . (\d -> read [d]) - incOffset 2 - return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] [] - -decOutParser :: CapParser BuildResults -decOutParser = do - _ <- char 'd' - incOffset 1 - return $ BuildResults 0 [ DecOut ] [] - -charOutParser :: CapParser BuildResults -charOutParser = do - _ <- char 'c' - incOffset 1 - return $ BuildResults 0 [ CharOut ] [] - -conditionalOpParser :: CapParser BuildResults -conditionalOpParser = do - _ <- char '?' - incOffset 1 - condPart <- manyExpr conditionalTrueParser - parts <- manyP - ( do - truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser - , conditionalFalseParser - ] - falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser - , conditionalTrueParser - ] - return ( truePart, falsePart ) - ) - conditionalEndParser - - let trueParts = map fst parts - falseParts = map snd parts - BuildResults n cond condParamOps = condPart - - let n' = maximum $ n : map outParamCount trueParts - n'' = maximum $ n' : map outParamCount falseParts - - let trueOps = map outCapOps trueParts - falseOps = map outCapOps falseParts - condParts = zip trueOps falseOps - - let trueParamOps = mconcat $ map outParamOps trueParts - falseParamOps = mconcat $ map outParamOps falseParts - pOps = mconcat [condParamOps, trueParamOps, falseParamOps] - - return $ BuildResults n'' [ Conditional cond condParts ] pOps - - where - manyP !p !end = choice - [ try end >> return [] - , do !v <- p - !vs <- manyP p end - return $! v : vs - ] - manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end - -conditionalTrueParser :: CapParser () -conditionalTrueParser = do - _ <- string "%t" - incOffset 2 - -conditionalFalseParser :: CapParser () -conditionalFalseParser = do - _ <- string "%e" - incOffset 2 - -conditionalEndParser :: CapParser () -conditionalEndParser = do - _ <- string "%;" - incOffset 2 - -bitwiseOpParser :: CapParser BuildResults -bitwiseOpParser - = bitwiseOrParser - <|> bitwiseAndParser - <|> bitwiseXorParser - -bitwiseOrParser :: CapParser BuildResults -bitwiseOrParser = do - _ <- char '|' - incOffset 1 - return $ BuildResults 0 [ BitwiseOr ] [ ] - -bitwiseAndParser :: CapParser BuildResults -bitwiseAndParser = do - _ <- char '&' - incOffset 1 - return $ BuildResults 0 [ BitwiseAnd ] [ ] - -bitwiseXorParser :: CapParser BuildResults -bitwiseXorParser = do - _ <- char '^' - incOffset 1 - return $ BuildResults 0 [ BitwiseXOr ] [ ] - -arithOpParser :: CapParser BuildResults -arithOpParser - = plusOp - <|> minusOp - where - plusOp = do - _ <- char '+' - incOffset 1 - return $ BuildResults 0 [ ArithPlus ] [ ] - minusOp = do - _ <- char '-' - incOffset 1 - return $ BuildResults 0 [ ArithMinus ] [ ] - -literalIntOpParser :: CapParser BuildResults -literalIntOpParser = do - _ <- char '{' - incOffset 1 - nStr <- many1 digit - incOffset $ toEnum $ length nStr - let n :: Word = read nStr - _ <- char '}' - incOffset 1 - return $ BuildResults 0 [ PushValue n ] [ ] - -compareOpParser :: CapParser BuildResults -compareOpParser - = compareEqOp - <|> compareLtOp - <|> compareGtOp - where - compareEqOp = do - _ <- char '=' - incOffset 1 - return $ BuildResults 0 [ CompareEq ] [ ] - compareLtOp = do - _ <- char '<' - incOffset 1 - return $ BuildResults 0 [ CompareLt ] [ ] - compareGtOp = do - _ <- char '>' - incOffset 1 - return $ BuildResults 0 [ CompareGt ] [ ] - -bytesOpParser :: CapParser BuildResults -bytesOpParser = do - bytes <- many1 $ satisfy (/= '%') - startOffset <- getState >>= return . nextOffset - let !c = length bytes - !s <- getState - let s' = s { nextOffset = startOffset + c } - setState s' - return $ BuildResults 0 [Bytes startOffset c] [] - -charConstParser :: CapParser BuildResults -charConstParser = do - _ <- char '\'' - charValue <- liftM (toEnum . fromEnum) anyChar - _ <- char '\'' - incOffset 3 - return $ BuildResults 0 [ PushValue charValue ] [ ] - -data BuildState = BuildState - { nextOffset :: Int - } - -incOffset :: Int -> CapParser () -incOffset n = do - s <- getState - let s' = s { nextOffset = nextOffset s + n } - setState s' - -initialBuildState :: BuildState -initialBuildState = BuildState 0 - -data BuildResults = BuildResults - { outParamCount :: !Int - , outCapOps :: !CapOps - , outParamOps :: !ParamOps - } - -instance Semigroup BuildResults where - v0 <> v1 - = BuildResults - { outParamCount = (outParamCount v0) `max` (outParamCount v1) - , outCapOps = (outCapOps v0) <> (outCapOps v1) - , outParamOps = (outParamOps v0) <> (outParamOps v1) - } - -instance Monoid BuildResults where - mempty = BuildResults 0 [] [] -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif 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,27 +1,48 @@ -- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE #-} {-# LANGUAGE ForeignFunctionInterface #-} +-- | This module provides functions to measure the terminal column width +-- of characters and strings. +-- +-- The functions provided in this module all ultimately make calls to +-- the C implementation in @cbits/mk_wcwidth.c@. That code manages some +-- global state that carries a table of Unicode character widths. For +-- more details, see 'Graphics.Vty.UnicodeWidthTable.Install', the C +-- code, and the "Multi-Column Character Support" section of the project +-- @README@. module Graphics.Text.Width ( wcwidth , wcswidth + , wctwidth + , wctlwidth , safeWcwidth , safeWcswidth + , safeWctwidth + , safeWctlwidth ) where +import Data.List (foldl') +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int wcswidth :: String -> Int -wcswidth = 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 +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 @@ -30,4 +51,14 @@ -- | Returns the display width of a string. Assumes all characters with -- unknown widths are 0 width. safeWcswidth :: String -> Int -safeWcswidth = sum . map safeWcwidth +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,43 +1,51 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Vty provides interfaces for both terminal input and terminal -- output. -- --- - Input to the terminal is provided to the Vty application as a +-- - User input to the terminal is provided to the Vty application as a -- sequence of 'Event's. -- --- - Output is provided to Vty by the application in the form of a +-- - Output is provided to by the application to Vty in the form of a -- 'Picture'. A 'Picture' is one or more layers of 'Image's. -- 'Image' values can be built by the various constructors in -- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute) -- values in the "Graphics.Vty.Attributes" module. -- --- Vty uses threads internally, so programs made with Vty need to be --- compiled with the threaded runtime using the GHC `-threaded` option. +-- - Each platform on which Vty is supported provides a package that +-- provides Vty with access to the platform-specific terminal +-- interface. For example, on Unix systems, the @vty-unix@ package +-- must be used to initialize Vty with access to a Unix terminal. -- --- @ --- import "Graphics.Vty" +-- As a small example, the following program demonstrates the use of Vty +-- on a Unix system using the @vty-unix@ package: -- --- main = do --- cfg <- 'standardIOConfig' --- vty <- 'mkVty' cfg --- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\" --- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\" --- img = line0 '<->' line1 --- pic = 'picForImage' img --- 'update' vty pic --- e <- 'nextEvent' vty --- 'shutdown' vty --- 'print' (\"Last event was: \" '++' 'show' e) --- @ +-- > import Graphics.Vty +-- > import Graphics.Vty.Platform.Unix (mkVty) +-- > +-- > main = do +-- > vty <- mkVty defaultConfig +-- > let line0 = string (defAttr `withForeColor` green) "first line" +-- > line1 = string (defAttr `withBackColor` blue) "second line" +-- > img = line0 <-> line1 +-- > pic = picForImage img +-- > update vty pic +-- > e <- nextEvent vty +-- > shutdown vty +-- > print ("Last event was: " ++ show e) +-- +-- Vty uses threads internally, so programs made with Vty must be +-- compiled with the threaded runtime using the GHC @-threaded@ option. module Graphics.Vty ( Vty(..) - , mkVty - , Mode(..) + , setWindowTitle + , installCustomWidthTable + , mkVtyFromPair , module Graphics.Vty.Config , module Graphics.Vty.Input + , module Graphics.Vty.Input.Events , module Graphics.Vty.Output - , module Graphics.Vty.Output.Interface , module Graphics.Vty.Picture , module Graphics.Vty.Image , module Graphics.Vty.Attributes @@ -46,12 +54,16 @@ import Graphics.Vty.Config import Graphics.Vty.Input +import Graphics.Vty.Input.Events import Graphics.Vty.Output -import Graphics.Vty.Output.Interface import Graphics.Vty.Picture import Graphics.Vty.Image import Graphics.Vty.Attributes +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 @@ -59,66 +71,123 @@ import Data.Semigroup ((<>)) #endif --- | A Vty value represents a handle to the Vty library that the +-- | A 'Vty' value represents a handle to the Vty library that the -- application must create in order to use Vty. -- --- The use of Vty typically follows this process: +-- The use of this library typically follows this process: -- --- 1. Initialize vty +-- 1. Initialize Vty with the 'mkVty' implementation for your +-- platform's Vty package (e.g. @vty-unix@), or, more generically, with +-- 'mkVtyFromPair'. This takes control of (and sets up) the terminal. -- --- 2. Use 'update' to display a picture. +-- 2. Use 'update' to display a picture. -- --- 3. Use 'nextEvent' to get the next input event. +-- 3. Use 'nextEvent' to get the next input event. -- --- 4. Depending on the event, go to 2 or 5. +-- 4. Depending on the event, go to 2 or 5. -- --- 5. Shutdown vty. +-- 5. Shutdown Vty and restore the terminal state with 'shutdown'. At +-- this point the 'Vty' handle cannot be used again. -- -- Operations on Vty handles are not thread-safe. -data Vty = Vty - { -- | Outputs the given 'Picture'. - update :: Picture -> IO () - -- | Return the next 'Event' or block until one becomes available. - , nextEvent :: IO Event - -- | Non-blocking version of 'nextEvent'. - , nextEventNonblocking :: IO (Maybe Event) - -- | The input interface. See 'Input'. - , inputIface :: Input - -- | The output interface. See 'Output'. - , outputIface :: Output - -- | 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. - , refresh :: 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. - , shutdown :: IO () - } +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 + } --- | Create a Vty handle. At most one handle should be created at a time --- for a given terminal device. --- --- The specified configuration is added to the the configuration --- loaded by 'userConfig' with the 'userConfig' configuration taking --- precedence. See "Graphics.Vty.Config". +-- | Attempt to load and install a custom character width table into +-- this process. -- --- For most applications @mkVty defaultConfig@ is sufficient. -mkVty :: Config -> IO Vty -mkVty appConfig = do - config <- (<> appConfig) <$> userConfig - 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 @@ -142,7 +211,7 @@ writeIORef lastUpdateRef $ Just updateData writeIORef lastPicRef $ Just inPic - let innerRefresh = do + innerRefresh = do writeIORef lastUpdateRef Nothing bounds <- displayBounds out dc <- displayContext out bounds @@ -150,17 +219,19 @@ mPic <- readIORef lastPicRef maybe (return ()) innerUpdate mPic - let mkResize = uncurry EvResize <$> displayBounds out + mkResize = uncurry EvResize <$> displayBounds out + + translateInternalEvent ResumeAfterInterrupt = mkResize + translateInternalEvent (InputEvent e) = return e + gkey = do - k <- atomically $ readTChan $ _eventChannel input - case k of - (EvResize _ _) -> mkResize - _ -> return k + e <- atomically $ readTChan $ eventChannel input + translateInternalEvent e gkey' = do - k <- atomically $ tryReadTChan $ _eventChannel input - case k of - (Just (EvResize _ _)) -> Just <$> mkResize - _ -> return k + mEv <- atomically $ tryReadTChan $ eventChannel input + case mEv of + Just e -> Just <$> translateInternalEvent e + Nothing -> return Nothing return $ Vty { update = innerUpdate , nextEvent = gkey @@ -169,4 +240,10 @@ , 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,7 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} -- | Display attributes -- @@ -28,7 +27,9 @@ -- The value 'currentAttr' will keep the attributes of whatever was -- output previously. module Graphics.Vty.Attributes - ( Attr(..) + ( module Graphics.Vty.Attributes.Color + + , Attr(..) , FixedAttr(..) , MaybeDefault(..) , defAttr @@ -39,6 +40,7 @@ , withStyle , standout , italic + , strikethrough , underline , reverseVideo , blink @@ -54,22 +56,16 @@ -- * Setting hyperlinks , withURL - - -- * Colors - , module Graphics.Vty.Attributes.Color - , module Graphics.Vty.Attributes.Color240 ) where +import Control.DeepSeq import Data.Bits -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif import Data.Text (Text) import Data.Word +import GHC.Generics import Graphics.Vty.Attributes.Color -import Graphics.Vty.Attributes.Color240 -- | A display attribute defines the Color and Style of all the -- characters rendered after the attribute is applied. @@ -83,7 +79,7 @@ , attrForeColor :: !(MaybeDefault Color) , attrBackColor :: !(MaybeDefault Color) , attrURL :: !(MaybeDefault Text) - } deriving ( Eq, Show, Read ) + } 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 @@ -117,19 +113,6 @@ -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits. -instance Semigroup Attr where - attr0 <> attr1 = - Attr ( attrStyle attr0 <> attrStyle attr1 ) - ( attrForeColor attr0 <> attrForeColor attr1 ) - ( attrBackColor attr0 <> attrBackColor attr1 ) - ( attrURL attr0 <> attrURL attr1 ) - -instance Monoid Attr where - mempty = Attr mempty mempty mempty mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif - -- | Specifies the display attributes such that the final style and -- color values do not depend on the previously applied display -- attribute. The display attributes can still depend on the terminal's @@ -144,38 +127,20 @@ -- | The style and color attributes can either be the terminal defaults. -- Or be equivalent to the previously applied style. Or be a specific -- value. -data MaybeDefault v where - Default :: MaybeDefault v - KeepCurrent :: MaybeDefault v - SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v - -deriving instance Eq v => Eq (MaybeDefault v) -deriving instance Eq v => Show (MaybeDefault v) -deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v) - -instance Eq v => Semigroup (MaybeDefault v) where - Default <> Default = Default - Default <> KeepCurrent = Default - Default <> SetTo v = SetTo v - KeepCurrent <> Default = Default - KeepCurrent <> KeepCurrent = KeepCurrent - KeepCurrent <> SetTo v = SetTo v - SetTo _v <> Default = Default - SetTo v <> KeepCurrent = SetTo v - SetTo _ <> SetTo v = SetTo v +data MaybeDefault v = Default | KeepCurrent | SetTo !v + deriving (Eq, Read, Show) -instance Eq v => Monoid ( MaybeDefault v ) where - mempty = KeepCurrent -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif +instance (NFData v) => NFData (MaybeDefault v) where + rnf Default = () + rnf KeepCurrent = () + rnf (SetTo v) = rnf v -- | Styles are represented as an 8 bit word. Each bit in the word is 1 -- if the style attribute assigned to that bit should be applied and 0 -- if the style attribute should not be applied. type Style = Word8 --- | The 6 possible style attributes: +-- | Valid style attributes include: -- -- * standout -- @@ -191,16 +156,19 @@ -- -- * italic -- +-- * strikethrough (via the smxx/rmxx terminfo capabilities) +-- -- (The invisible, protect, and altcharset display attributes some -- terminals support are not supported via VTY.) -standout, underline, reverseVideo, blink, dim, bold, italic :: Style +standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style standout = 0x01 underline = 0x02 -reverseVideo = 0x04 +reverseVideo = 0x04 blink = 0x08 dim = 0x10 bold = 0x20 italic = 0x40 +strikethrough = 0x80 defaultStyleMask :: Style defaultStyleMask = 0x00 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,5 +1,21 @@ +{-# 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 @@ -8,6 +24,8 @@ , magenta , cyan , white + + -- | Bright/Vivid variants of the standard 8-color ANSI , brightBlack , brightRed , brightGreen @@ -16,11 +34,21 @@ , 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 @@ -36,21 +64,21 @@ -- -- The 8 ISO 6429 (ANSI) colors are as follows: -- --- 0. black +-- * black (0) -- --- 1. red +-- * red (1) -- --- 2. green +-- * green (2) -- --- 3. yellow +-- * yellow (3) -- --- 4. blue +-- * blue (4) -- --- 5. magenta +-- * magenta (5) -- --- 6. cyan +-- * cyan (6) -- --- 7. white +-- * white (7) -- -- The mapping from points in the 240 color palette to colors actually -- displayable by the terminal depends on the number of colors the @@ -59,7 +87,7 @@ -- reported then the color reproduction will be incorrect. -- -- If the terminal reports <= 16 colors then the 240 color palette --- points are only mapped to the 8 color pallete. I'm not sure of +-- points are only mapped to the 8 color palette. I'm not sure of -- the RGB points for the "bright" colors which is why they are not -- addressable via the 240 color palette. -- @@ -73,10 +101,17 @@ -- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE. -data Color = ISOColor !Word8 | Color240 !Word8 +data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8 + deriving ( Eq, Show, Read, Generic, NFData ) + +data ColorMode + = NoColor + | ColorMode8 + | ColorMode16 + | ColorMode240 !Word8 + | FullColor deriving ( Eq, Show, Read ) --- | Standard 8-color ANSI terminal color codes. black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 red = ISOColor 1 @@ -87,7 +122,6 @@ cyan = ISOColor 6 white = ISOColor 7 --- | Bright/Vivid variants of the standard 8-color ANSI brightBlack, brightRed, brightGreen, brightYellow :: Color brightBlue, brightMagenta, brightCyan, brightWhite :: Color brightBlack = ISOColor 8 @@ -98,3 +132,42 @@ 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,268 +1,59 @@ -- This header file was generated by ./256colres.pl module Graphics.Vty.Attributes.Color240 - ( rgbColor + ( rgbColorToColor240 , color240CodeToRGB ) where -import Graphics.Vty.Attributes.Color - import Data.Word (Word8) import Text.Printf -- Note: rgbColor's mapping from RGB to 240 colors was generated from -- 256colres.pl which is forked from xterm 256colres.pl. --- | Create a Vty 'Color' (in the 240 color set) from an RGB triple. --- This function is lossy in the sense that we only internally support 240 colors but the --- #RRGGBB format supports 16^3 colors. -rgbColor :: Integral i => i -> i -> i -> Color -rgbColor r g b +-- | Create a value in the Color240 set from an RGB triple. This maps +-- the input arguments to an entry in the 240-color palette depicted at: +-- +-- https://rich.readthedocs.io/en/stable/appendix/colors.html +rgbColorToColor240 :: Integral i => i -> i -> i -> Word8 +rgbColorToColor240 r g b | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" - | r == 8 && g == 8 && b == 8 = 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) 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,17 +1,29 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Vty supports a configuration file format and associated 'Config' --- data type. The 'Config' can be provided to 'mkVty' to customize the +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Vty supports a configuration file format and provides a +-- corresponding 'VtyUserConfig' data type. The 'VtyUserConfig' can be +-- provided to platform packages' @mkVty@ functions to customize the -- application's use of Vty. -- --- Lines in config files that fail to parse are ignored. Later entries --- take precedence over earlier ones. --- -- = Debug -- +-- == @colorMode@ +-- +-- Format: +-- +-- @ +-- colorMode \"|FullColor>\" +-- @ +-- +-- The preferred color mode to use, chosen from the constructors of the +-- 'ColorMode' type. If absent, the backend driver may detect and choose +-- an appropriate color mode. Implementor's note: backend packages +-- should respect this setting when it is present even when their +-- detection indicates that a different color mode should be used. +-- -- == @debugLog@ -- -- Format: @@ -54,17 +66,50 @@ -- If a debug log is requested then vty will output the current input -- table to the log in the above format. A workflow for using this is -- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for --- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@. +-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@. +-- +-- = Unicode Character Width Maps +-- +-- == @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 - , Config(..) - , VtyConfigurationError(..) + , VtyUserConfig(..) , userConfig , overrideEnvConfig - , standardIOConfig + , currentTerminalName , runParseConfig , parseConfigFile , defaultConfig + + , vtyConfigPath + , widthTableFilename + , vtyDataDirectory + , terminalWidthTablePath + , vtyConfigFileEnvName + + , ConfigUpdateResult(..) + , addConfigWidthMap ) where @@ -72,143 +117,153 @@ import Control.Applicative hiding (many) -import Control.Exception (catch, IOException, Exception(..), throwIO) +import Control.Exception (catch, IOException) import Control.Monad (liftM, guard, void) import qualified Data.ByteString as BS +#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 Data.Typeable (Typeable) +import Text.Read (readMaybe) +import Graphics.Vty.Attributes.Color (ColorMode(..)) import Graphics.Vty.Input.Events import GHC.Generics -import System.Directory (getAppUserDataDirectory) -import System.Posix.Env (getEnv) -import System.Posix.IO (stdInput, stdOutput) -import System.Posix.Types (Fd(..)) +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 --- | Type of errors that can be thrown when configuring VTY -data VtyConfigurationError - = VtyMissingTermEnvVar -- ^ TERM environment variable not set - deriving (Show, Eq, Typeable) - -instance Exception VtyConfigurationError where - displayException VtyMissingTermEnvVar = "TERM environment variable not set" - -- | Mappings from input bytes to event in the order specified. Later -- entries take precedence over earlier in the case multiple entries -- have the same byte string. type InputMap = [(Maybe String, String, Event)] --- | A Vty configuration. -data Config = Config - { - -- | The default is 1 character. - vmin :: Maybe Int - -- | The default is 100 milliseconds, 0.1 seconds. - , vtime :: Maybe Int - -- | The default is False. - , mouseMode :: Maybe Bool - -- | The default is False. - , bracketedPasteMode :: Maybe Bool - -- | 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) -defaultConfig :: Config +defaultConfig :: VtyUserConfig defaultConfig = mempty -instance Semigroup Config where - 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 - , mouseMode = mouseMode c1 - , bracketedPasteMode = bracketedPasteMode c1 - , debugLog = debugLog c1 <|> debugLog c0 - , inputMap = inputMap c0 <> inputMap c1 - , inputFd = inputFd c1 <|> inputFd c0 - , outputFd = outputFd c1 <|> outputFd c0 - , termName = termName c1 <|> termName c0 - } + VtyUserConfig { configDebugLog = + configDebugLog c1 <|> configDebugLog c0 + , configInputMap = + configInputMap c0 <> configInputMap c1 + , configTermWidthMaps = + configTermWidthMaps c1 <|> configTermWidthMaps c0 + , configAllowCustomUnicodeWidthTables = + configAllowCustomUnicodeWidthTables c1 <|> configAllowCustomUnicodeWidthTables c0 + , configPreferredColorMode = + configPreferredColorMode c1 <|> configPreferredColorMode c0 + } -instance Monoid Config where - mempty = Config - { vmin = Nothing - , vtime = Nothing - , mouseMode = Nothing - , bracketedPasteMode = Nothing - , debugLog = mempty - , inputMap = mempty - , inputFd = Nothing - , outputFd = Nothing - , termName = Nothing - } +instance Monoid VtyUserConfig where + mempty = + VtyUserConfig { configDebugLog = mempty + , configInputMap = mempty + , configTermWidthMaps = [] + , configAllowCustomUnicodeWidthTables = Nothing + , configPreferredColorMode = Nothing + } #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif --- | Load a configuration 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 defaultConfig) 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 $ defaultConfig { debugLog = d } +widthTableFilename :: String -> String +widthTableFilename term = "width_table_" <> term <> ".dat" --- | Configures VTY using defaults suitable for terminals. This function --- can raise 'VtyConfigurationError'. -standardIOConfig :: IO Config -standardIOConfig = do - mb <- getEnv "TERM" - case mb of - Nothing -> throwIO VtyMissingTermEnvVar - Just t -> - return defaultConfig - { vmin = Just 1 - , mouseMode = Just False - , bracketedPasteMode = Just False - , vtime = Just 100 - , inputFd = Just stdInput - , outputFd = Just stdOutput - , termName = Just t - } +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 defaultConfig) -runParseConfig :: String -> BS.ByteString -> Config +runParseConfig :: String -> BS.ByteString -> VtyUserConfig runParseConfig name cfgTxt = case runParser parseConfig () name cfgTxt of Right cfg -> cfg @@ -236,7 +291,7 @@ configLexer :: Monad m => P.GenTokenParser BS.ByteString () m configLexer = P.makeTokenParser configLanguage -mapDecl :: Parser Config +mapDecl :: Parser VtyUserConfig mapDecl = do "map" <- P.identifier configLexer termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing) @@ -244,21 +299,34 @@ bytes <- P.stringLiteral configLexer key <- parseValue modifiers <- parseValue - return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] } + return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] } -debugLogDecl :: Parser Config +debugLogDecl :: Parser VtyUserConfig debugLogDecl = do "debugLog" <- P.identifier configLexer path <- P.stringLiteral configLexer - return defaultConfig { debugLog = Just path } + return defaultConfig { configDebugLog = Just path } +colorModeDecl :: Parser VtyUserConfig +colorModeDecl = do + "colorMode" <- P.identifier configLexer + mode <- P.stringLiteral configLexer + return defaultConfig { configPreferredColorMode = readMaybe mode } + +widthMapDecl :: Parser VtyUserConfig +widthMapDecl = do + "widthMap" <- P.identifier configLexer + tName <- P.stringLiteral configLexer + path <- P.stringLiteral configLexer + return defaultConfig { configTermWidthMaps = [(tName, path)] } + ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline -parseConfig :: Parser Config +parseConfig :: Parser VtyUserConfig parseConfig = liftM mconcat $ many $ do P.whiteSpace configLexer - let directives = [try mapDecl, try debugLogDecl] + let directives = [try mapDecl, try debugLogDecl, try widthMapDecl, try colorModeDecl] choice directives <|> (ignoreLine >> return defaultConfig) class Parse a where parseValue :: Parser a @@ -304,3 +372,67 @@ 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,27 +1,32 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug - ( module Graphics.Vty.Debug - , module Graphics.Vty.Debug.Image + ( MockWindow(..) + , SpanConstructLog + , regionForWindow + , allSpansHaveWidth + , spanOpsAffectedColumns + , spanOpsAffectedRows + , rowOpsAffectedColumns + , isSetAttr ) where import Graphics.Vty.Attributes import Graphics.Vty.Image (DisplayRegion) -import Graphics.Vty.Debug.Image import Graphics.Vty.Span import qualified Data.Vector as Vector -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] 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 @@ -2,7 +2,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -module Graphics.Vty.DisplayAttributes where +module Graphics.Vty.DisplayAttributes + ( DisplayAttrDiff(..) + , StyleStateChange(..) + , DisplayColorDiff(..) + , URLDiff(..) + , fixDisplayAttr + , displayAttrDiffs + ) +where import Graphics.Vty.Attributes @@ -96,6 +104,8 @@ | RemoveStandout | ApplyItalic | RemoveItalic + | ApplyStrikethrough + | RemoveStrikethrough | ApplyUnderline | RemoveUnderline | ApplyReverseVideo @@ -144,6 +154,7 @@ [ styleDiff standout ApplyStandout RemoveStandout , styleDiff underline ApplyUnderline RemoveUnderline , styleDiff italic ApplyItalic RemoveItalic + , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo , styleDiff blink ApplyBlink RemoveBlink , styleDiff dim ApplyDim RemoveDim 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,4 +1,7 @@ -module Graphics.Vty.Error where +module Graphics.Vty.Error + ( VtyException(..) + ) +where -- | The type of exceptions 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,5 +1,4 @@ -- Copyright 2009-2010 Corey O'Connor -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -- | A Vty program makes 'Picture's from 'Image's. This module provides @@ -46,10 +45,13 @@ -- * Character width functions , safeWcwidth , safeWcswidth + , safeWctwidth + , safeWctlwidth , wcwidth , wcswidth + , wctwidth + , wctlwidth -- * Display Regions - , DisplayText , DisplayRegion , regionWidth , regionHeight @@ -113,16 +115,18 @@ vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage --- | Make an 'Image' from a lazy text value. This function should not be --- given a text value containing escapes. +-- | Make an 'Image' from a lazy text value. The text value should be +-- sanitized of escape sequences (ASCII 27) and carriage returns; +-- otherwise layout and attribute problems may result. text :: Attr -> TL.Text -> Image -text a txt = let displayWidth = safeWcswidth (TL.unpack txt) +text a txt = let displayWidth = safeWctlwidth txt in HorizText a txt displayWidth (fromIntegral $! TL.length txt) --- | Make an 'Image' from a text value. This function should not be --- given a text value containing escapes. +-- | Make an 'Image' from a text value. The text value should be +-- sanitized of escape sequences (ASCII 27) and carriage returns; +-- otherwise layout and attribute problems may result. text' :: Attr -> T.Text -> Image -text' a txt = let displayWidth = safeWcswidth (T.unpack txt) +text' a txt = let displayWidth = safeWctwidth txt in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) -- | Make an image from a single character. This is a standard Haskell @@ -132,10 +136,11 @@ let displayWidth = safeWcwidth c in HorizText a (TL.singleton c) displayWidth 1 --- | Make an image from a string of characters layed out on a single +-- | Make an image from a string of characters laid out on a single -- row with the same display attribute. The string is assumed to be a --- sequence of ISO-10646 characters. This function should not be given a --- string containing escapes. +-- sequence of ISO-10646 characters. The input string should be +-- sanitized of escape sequences (ASCII 27) and carriage returns; +-- otherwise layout and attribute problems may result. -- -- Note: depending on how the Haskell compiler represents string -- literals, a string literal in a UTF-8 encoded source file, for @@ -152,8 +157,7 @@ -- -- This is an alias for iso10646String since the usual case is that a -- literal string like "foo" is represented internally as a list of ISO --- 10646 31 bit characters. This function should not be given a string --- containing escapes. +-- 10646 31 bit characters. -- -- Note: Keep in mind that GHC will compile source encoded as UTF-8 -- but the literal strings, while UTF-8 encoded in the source, will be @@ -170,7 +174,7 @@ utf8Bytestring :: Attr -> BL.ByteString -> Image utf8Bytestring a bs = text a (TL.decodeUtf8 bs) --- | Make an 'Image' from a UTF-8 encoded lazy bytestring. +-- | Make an 'Image' from a UTF-8 encoded strict bytestring. utf8Bytestring' :: Attr -> B.ByteString -> Image utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) @@ -253,7 +257,7 @@ translateX :: Int -> Image -> Image translateX x i | x < 0 && (abs x > imageWidth i) = emptyImage - | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i) + | x < 0 = cropLeft (imageWidth i + x) i | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h @@ -261,7 +265,7 @@ translateY :: Int -> Image -> Image translateY y i | y < 0 && (abs y > imageHeight i) = emptyImage - | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s) + | y < 0 = cropTop (imageHeight i + y) i | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) @@ -291,12 +295,11 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropBottom {croppedImage, outputWidth, outputHeight}) - | outputHeight <= h = i - | otherwise = CropBottom croppedImage outputWidth h + go i@(Crop {outputHeight}) + = i {outputHeight = min h outputHeight} go i | h >= imageHeight i = i - | otherwise = CropBottom i (imageWidth i) h + | otherwise = Crop i 0 0 (imageWidth i) h -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise @@ -308,12 +311,11 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropRight {croppedImage, outputWidth, outputHeight}) - | outputWidth <= w = i - | otherwise = CropRight croppedImage w outputHeight + go i@(Crop {outputWidth}) + = i {outputWidth = min w outputWidth} go i | w >= imageWidth i = i - | otherwise = CropRight i w (imageHeight i) + | otherwise = Crop i 0 0 w (imageHeight i) -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise @@ -325,14 +327,13 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) - | outputWidth <= w = i - | otherwise = - let leftSkip' = leftSkip + outputWidth - w - in CropLeft croppedImage leftSkip' w outputHeight + go i@(Crop {leftSkip, outputWidth}) = + let delta = max 0 (outputWidth - w) + in i { leftSkip = leftSkip + delta + , outputWidth = outputWidth - delta } go i | imageWidth i <= w = i - | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i) + | otherwise = Crop i (imageWidth i - w) 0 w (imageHeight i) -- | Crop an image's height. If the image's height is less than or equal -- to the specified height then this operation has no effect. Otherwise @@ -344,14 +345,13 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight}) - | outputHeight <= h = i - | otherwise = - let topSkip' = topSkip + outputHeight - h - in CropTop croppedImage topSkip' outputWidth h + go i@(Crop {topSkip, outputHeight}) = + let delta = max 0 (outputHeight - h) + in i { topSkip = topSkip + delta + , outputHeight = outputHeight - delta } go i | imageHeight i <= h = i - | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h + | otherwise = Crop i 0 (imageHeight i - h) (imageWidth i) h -- | Generic resize. Pads and crops are added to ensure that the -- resulting image matches the specified dimensions. This is biased to 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 @@ -3,8 +3,18 @@ {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} -module Graphics.Vty.Image.Internal where +module Graphics.Vty.Image.Internal + ( Image(..) + , imageHeight + , imageWidth + , horizJoin + , vertJoin + , ppImageStructure + , clipText + ) +where + import Graphics.Vty.Attributes import Graphics.Text.Width @@ -17,10 +27,7 @@ #endif import qualified Data.Text.Lazy as TL --- | A display text is a Data.Text.Lazy -type DisplayText = TL.Text - -clipText :: DisplayText -> Int -> Int -> DisplayText +clipText :: TL.Text -> Int -> Int -> TL.Text clipText txt leftSkip rightClip = -- CPS would clarify this I think let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0 @@ -57,7 +64,7 @@ { attr :: Attr -- | The text to display. The display width of the text is always -- outputWidth. - , displayText :: DisplayText + , displayText :: TL.Text -- | The number of display columns for the text. , outputWidth :: Int -- | the number of characters in the text. @@ -96,42 +103,12 @@ { outputWidth :: Int -- ^ always > 0 , outputHeight :: Int -- ^ always > 0 } - -- | Crop an image horizontally to a size by reducing the size from - -- the right. - | CropRight - { croppedImage :: Image - -- | Always < imageWidth croppedImage > 0 - , outputWidth :: Int - , outputHeight :: Int -- ^ imageHeight croppedImage - } - -- | Crop an image horizontally to a size by reducing the size from - -- the left. - | CropLeft + -- | Crop an image + | Crop { croppedImage :: Image - -- | Always < imageWidth croppedImage > 0 , leftSkip :: Int - -- | Always < imageWidth croppedImage > 0 - , outputWidth :: Int - , outputHeight :: Int - } - -- | Crop an image vertically to a size by reducing the size from - -- the bottom - | CropBottom - { croppedImage :: Image - -- | imageWidth croppedImage - , outputWidth :: Int - -- | height image is cropped to. Always < imageHeight croppedImage > 0 - , outputHeight :: Int - } - -- | Crop an image vertically to a size by reducing the size from - -- the top - | CropTop - { croppedImage :: Image - -- | Always < imageHeight croppedImage > 0 , topSkip :: Int - -- | imageWidth croppedImage , outputWidth :: Int - -- | Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | The empty image @@ -142,37 +119,11 @@ -- -- Any image of zero size equals the empty image. | EmptyImage - deriving (Eq, Generic) - -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 " " @@ -185,26 +136,14 @@ = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n" ++ go (i+1) t ++ "\n" ++ go (i+1) b - pp i (CropRight {croppedImage, outputWidth, outputHeight}) - = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" - ++ go (i+1) croppedImage - pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) - = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" - ++ go (i+1) croppedImage - pp i (CropBottom {croppedImage, outputWidth, outputHeight}) - = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" - ++ go (i+1) croppedImage - pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight}) - = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n" + pp i (Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight}) + = "Crop(" ++ show leftSkip ++ "," ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp _ EmptyImage = "EmptyImage" instance NFData Image where rnf EmptyImage = () - rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` () - rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` () - rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` () - rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` () + rnf (Crop i x y w h) = i `deepseq` x `seq` y `seq` w `seq` h `seq` () rnf (BGFill w h) = w `seq` h `seq` () rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` () rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` () @@ -217,10 +156,7 @@ imageWidth HorizJoin { outputWidth = w } = w imageWidth VertJoin { outputWidth = w } = w imageWidth BGFill { outputWidth = w } = w -imageWidth CropRight { outputWidth = w } = w -imageWidth CropLeft { outputWidth = w } = w -imageWidth CropBottom { outputWidth = w } = w -imageWidth CropTop { outputWidth = w } = w +imageWidth Crop { outputWidth = w } = w imageWidth EmptyImage = 0 -- | The height of an Image. This is the number of display rows the @@ -230,10 +166,7 @@ imageHeight HorizJoin { outputHeight = h } = h imageHeight VertJoin { outputHeight = h } = h imageHeight BGFill { outputHeight = h } = h -imageHeight CropRight { outputHeight = h } = h -imageHeight CropLeft { outputHeight = h } = h -imageHeight CropBottom { outputHeight = h } = h -imageHeight CropTop { outputHeight = h } = h +imageHeight Crop { outputHeight = h } = h imageHeight EmptyImage = 0 -- | Append in the 'Semigroup' instance is equivalent to '<->'. @@ -254,7 +187,7 @@ -- -- The result image will have a width equal to the sum of the two images -- width. And the height will equal the largest height of the two --- images. The area not defined in one image due to a height missmatch +-- images. The area not defined in one image due to a height mismatch -- will be filled with the background pattern. horizJoin :: Image -> Image -> Image horizJoin EmptyImage i = i @@ -285,7 +218,7 @@ -- -- The result image will have a height equal to the sum of the heights -- of both images. The width will equal the largest width of the two --- images. The area not defined in one image due to a width missmatch +-- images. The area not defined in one image due to a width mismatch -- will be filled with the background pattern. vertJoin :: Image -> Image -> Image vertJoin EmptyImage i = i 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,5 +1,3 @@ -{-# LANGUAGE BangPatterns #-} - -- | The inline module provides a limited interface to changing the -- style of terminal output. The intention is for this interface to be -- used inline with other output systems. @@ -31,13 +29,11 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Inline ( module Graphics.Vty.Inline - , withVty ) where import Graphics.Vty import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Inline.Unsafe import Blaze.ByteString.Builder (writeToByteString) @@ -58,13 +54,13 @@ -- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM () backColor c = modify $ \s -> - s { inlineAttr = inlineAttr s `mappend` (currentAttr `withBackColor` c) + s { inlineAttr = inlineAttr s `withBackColor` c } -- | Set the foreground color to the provided 'Color'. foreColor :: Color -> InlineM () foreColor c = modify $ \s -> - s { inlineAttr = inlineAttr s `mappend` (currentAttr `withForeColor` c) + s { inlineAttr = inlineAttr s `withForeColor` c } -- | Attempt to change the 'Style' of the following text.. @@ -73,7 +69,7 @@ -- produced. The style can still be removed. applyStyle :: Style -> InlineM () applyStyle st = modify $ \s -> - s { inlineAttr = inlineAttr s `mappend` (currentAttr `withStyle` st) + s { inlineAttr = inlineAttr s `withStyle` st } -- | Attempt to remove the specified 'Style' from the display of the @@ -85,8 +81,8 @@ removeStyle sMask = modify $ \s -> s { inlineAttr = let style' = case attrStyle (inlineAttr s) of - Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." - KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." + Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." + KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." SetTo st -> st .&. complement sMask in (inlineAttr s) { attrStyle = SetTo style' } } @@ -121,8 +117,8 @@ -- output device. -- -- This will flush the terminal output. -putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m () -putAttrChange_ c = liftIO $ withOutput $ \out -> do +putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () +putAttrChange_ out c = liftIO $ do hFlush stdout putAttrChange out c hFlush stdout 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,59 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module Graphics.Vty.Inline.Unsafe where - -import Graphics.Vty - -import Data.IORef - -import GHC.IO.Handle (hDuplicate) - -import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering)) - -import System.IO.Unsafe - -import System.Posix.IO (handleToFd) - -globalVty :: IORef (Maybe Vty) -{-# NOINLINE globalVty #-} -globalVty = unsafePerformIO $ newIORef Nothing - -globalOutput :: IORef (Maybe Output) -{-# NOINLINE globalOutput #-} -globalOutput = unsafePerformIO $ newIORef Nothing - -mkDupeConfig :: IO Config -mkDupeConfig = do - hSetBuffering stdout NoBuffering - hSetBuffering stdin NoBuffering - stdinDupe <- hDuplicate stdin >>= handleToFd - stdoutDupe <- hDuplicate stdout >>= handleToFd - return $ defaultConfig { inputFd = Just stdinDupe, outputFd = Just stdoutDupe } - --- | This will create a Vty instance using 'mkVty' and execute an IO --- action provided that instance. The created Vty instance will be --- stored to the unsafe 'IORef' 'globalVty'. --- --- This instance will use duplicates of the stdin and stdout Handles. -withVty :: (Vty -> IO b) -> IO b -withVty f = do - mvty <- readIORef globalVty - vty <- case mvty of - Nothing -> do - vty <- mkDupeConfig >>= mkVty - writeIORef globalVty (Just vty) - return vty - Just vty -> return vty - f vty - -withOutput :: (Output -> IO b) -> IO b -withOutput f = do - mout <- readIORef globalOutput - out <- case mout of - Nothing -> do - config <- mappend <$> userConfig <*> mkDupeConfig - out <- outputForConfig config - writeIORef globalOutput (Just out) - return out - Just out -> return out - f out 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,185 +1,32 @@ -{-# LANGUAGE RecordWildCards #-} - --- | This module provides the input layer for Vty, including methods --- for initializing an 'Input' structure and reading 'Event's from the --- terminal. --- --- Note that due to the evolution of terminal emulators, some keys --- and combinations will not reliably map to the expected events by --- any terminal program. There is no 1:1 mapping from key events to --- bytes read from the terminal input device. In very limited cases the --- terminal and vty's input process can be customized to resolve these --- issues; see "Graphics.Vty.Config" for how to configure vty's input --- processing. --- --- = VTY's Implementation --- --- There are two input modes: --- --- 1. 7-bit --- --- 2. 8-bit --- --- The 7-bit input mode is the default and the expected mode in most use --- cases. This is what Vty uses. --- --- == 7-bit input encoding --- --- Control key combinations are represented by masking the two high bits --- of the 7-bit input. Historically the control key actually grounded --- the two high bit wires: 6 and 7. This is why control key combos --- map to single character events: the input bytes are identical. The --- input byte is the bit encoding of the character with bits 6 and 7 --- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For --- example, --- --- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become --- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key. --- --- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero --- which is `0000011` and is the "End of Text" code. --- --- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this --- is the value 1 with bit 7 set and 6 unset. --- --- * Hypothesis: Bit 6 is unset by upper case letters because, --- initially, there were only upper case letters used and a 5 bit --- encoding. --- --- == 8-bit encoding --- --- The 8th bit was originally used for parity checking which is useless --- for terminal emulators. Some terminal emulators support an 8-bit --- input encoding. While this provides some advantages, the actual usage --- is low. Most systems use 7-bit mode but recognize 8-bit control --- characters when escaped. This is what Vty does. --- --- == Escaped Control Keys --- --- Using 7-bit input encoding, the @ESC@ byte can signal the start of --- an encoded control key. To differentiate a single @ESC@ event from a --- control key, the timing of the input is used. --- --- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of --- 'VMIN' milliseconds. --- --- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte --- is followed by more bytes read within 'VMIN' milliseconds. All bytes --- up until the next valid input block are passed to the classifier. --- --- If the current runtime is the threaded runtime then the terminal's --- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If --- the current runtime does not support 'forkOS' then there is currently --- no implementation. --- --- == Unicode Input and Escaped Control Key Sequences --- --- The input encoding determines how UTF-8 encoded characters are --- recognized. --- --- * 7-bit mode: UTF-8 can be input unambiguiously. UTF-8 input is --- a superset of ASCII. UTF-8 does not overlap escaped control key --- sequences. However, the escape key must be differentiated from --- escaped control key sequences by the timing of the input bytes. --- --- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not --- require using the timing of input bytes to differentiate the escape --- key. Many terminals do not support 8-bit mode. --- --- == Terminfo --- --- The terminfo system is used to determine how some keys are encoded. --- Terminfo is incomplete and in some cases terminfo is incorrect. Vty --- assumes terminfo is correct but provides a mechanism to override --- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'. --- --- == Terminal Input is Broken --- --- Clearly terminal input has fundemental issues. There is no easy way --- to reliably resolve these issues. --- --- One resolution would be to ditch standard terminal interfaces --- entirely and just go directly to scancodes. This would be a --- reasonable option for Vty if everybody used the linux kernel console --- but for obvious reasons this is not possible. --- --- The "Graphics.Vty.Config" module supports customizing the --- input-byte-to-event mapping and xterm supports customizing the --- scancode-to-input-byte mapping. With a lot of work a user's system --- can be set up to encode all the key combos in an almost-sane manner. --- --- == See also --- --- * http://www.leonerd.org.uk/hacks/fixterms/ +-- | This module provides the input abstraction for Vty. module Graphics.Vty.Input - ( Key(..) - , Modifier(..) - , Button(..) - , Event(..) - , Input(..) - , inputForConfig + ( Input(..) + , module Graphics.Vty.Input.Events ) where -import Graphics.Vty.Config import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Loop -import Graphics.Vty.Input.Terminfo - -import Control.Concurrent.STM -import Lens.Micro - -import qualified System.Console.Terminfo as Terminfo -import System.Posix.Signals.Exts - -import Data.Monoid ((<>)) +import Control.Concurrent.STM (TChan) --- | Set up the terminal with file descriptor `inputFd` for input. --- Returns an 'Input'. --- --- The table used to determine the 'Events' to produce for the input --- bytes comes from 'classifyMapForTerm' which is then overridden by --- the the applicable entries from the configuration's 'inputMap'. --- --- The terminal device is configured with the attributes: --- --- * IXON disabled: disables software flow control on outgoing data. --- This stops the process from being suspended if the output terminal --- cannot keep up. --- --- * Raw mode is used for input. --- --- * ISIG disabled (enables keyboard combinations that result in --- signals) --- --- * ECHO disabled (input is not echoed to the output) --- --- * ICANON disabled (canonical mode (line mode) input is not used) --- --- * IEXTEN disabled (extended functions are disabled) -inputForConfig :: Config -> IO Input -inputForConfig config@Config{ termName = Just termName - , inputFd = Just termFd - , vmin = Just _ - , vtime = Just _ - , .. } = do - terminal <- Terminfo.setupTerm termName - let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName] - activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides - (setAttrs,unsetAttrs) <- attributeControl termFd - setAttrs - input <- initInput config activeInputMap - let pokeIO = Catch $ do - let e = error "vty internal failure: this value should not propagate to users" - setAttrs - atomically $ writeTChan (input^.eventChannel) (EvResize e e) - _ <- installHandler windowChange pokeIO Nothing - _ <- installHandler continueProcess pokeIO Nothing - return $ input - { shutdownInput = do - shutdownInput input - _ <- installHandler windowChange Ignore Nothing - _ <- installHandler continueProcess Ignore Nothing - unsetAttrs - } -inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig +-- | The library's input-processing abstraction. Platform-specific +-- implementations must implement an 'Input' and provide it to +-- 'Graphics.Vty.mkVtyFromPair'. +data Input = + Input { eventChannel :: TChan InternalEvent + -- ^ A channel of events generated by input processing. The + -- input implementation must write its input events to this + -- channel; the Vty event loop will read from this channel + -- and provide the events to the user's application via + -- 'nextEvent'. + , shutdownInput :: IO () + -- ^ Shut down the input processing. As part of shutting down + -- the input, this should also restore the input state if + -- appropriate. + , restoreInputState :: IO () + -- ^ Restore the terminal's input state to what it was prior + -- to configuring the input for Vty. This should be done as + -- part of 'shutdownInput' but is exposed in case it needs to + -- be used directly. + , inputLogMsg :: String -> IO () + -- ^ Log the specified message. + } 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,86 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- This makes a kind of tri. Has space efficiency issues with large --- input blocks. Likely building a parser and just applying that would --- be better. -module Graphics.Vty.Input.Classify - ( classify - , KClass(..) - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Mouse -import Graphics.Vty.Input.Focus -import Graphics.Vty.Input.Paste -import Graphics.Vty.Input.Classify.Types - -import Codec.Binary.UTF8.Generic (decode) - -import Data.List (inits) -import qualified Data.Map as M( fromList, lookup ) -import Data.Maybe ( mapMaybe ) -import qualified Data.Set as S( fromList, member ) - -import Data.Char -import Data.Word - -compile :: ClassifyMap -> [Char] -> KClass -compile table = cl' where - -- take all prefixes and create a set of these - prefixSet = S.fromList $ concatMap (init . inits . fst) $ table - maxValidInputLength = maximum (map (length . fst) table) - eventForInput = M.fromList table - cl' [] = Prefix - cl' inputBlock = case M.lookup inputBlock eventForInput of - -- if the inputBlock is exactly what is expected for an - -- event then consume the whole block and return the event - Just e -> Valid e [] - Nothing -> case S.member inputBlock prefixSet of - True -> Prefix - -- look up progressively smaller tails of the input - -- block until an event is found The assumption is that - -- the event that consumes the most input bytes should - -- be produced. - -- The test verifyFullSynInputToEvent2x verifies this. - -- H: There will always be one match. The prefixSet - -- contains, by definition, all prefixes of an event. - False -> - let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock - in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of - (s,e) : _ -> Valid e (drop (length s) inputBlock) - -- neither a prefix or a full event. - [] -> Invalid - -classify :: ClassifyMap -> [Char] -> KClass -classify table = - let standardClassifier = compile table - in \s -> case s of - _ | bracketedPasteStarted s -> - if bracketedPasteFinished s - then parseBracketedPaste s - else Prefix - _ | isMouseEvent s -> classifyMouseEvent s - _ | isFocusEvent s -> classifyFocusEvent s - c:cs | ord c >= 0xC2 -> classifyUtf8 c cs - _ -> standardClassifier s - -classifyUtf8 :: Char -> [Char] -> KClass -classifyUtf8 c cs = - let n = utf8Length (ord c) - (codepoint,rest) = splitAt n (c:cs) - - codepoint8 :: [Word8] - codepoint8 = map (fromIntegral . ord) codepoint - - in case decode codepoint8 of - _ | n < length codepoint -> Prefix - Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest - -- something bad happened; just ignore and continue. - Nothing -> Invalid - -utf8Length :: (Num t, Ord a, Num a) => a -> t -utf8Length c - | c < 0x80 = 1 - | c < 0xE0 = 2 - | c < 0xF0 = 3 - | otherwise = 4 diff --git a/src/Graphics/Vty/Input/Classify/Parse.hs b/src/Graphics/Vty/Input/Classify/Parse.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Classify/Parse.hs +++ /dev/null @@ -1,58 +0,0 @@ --- | This module provides a simple parser for parsing input event --- control sequences. -module Graphics.Vty.Input.Classify.Parse - ( Parser - , runParser - , failParse - , readInt - , readChar - , expectChar - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types - -import Control.Monad.Trans.Maybe -import Control.Monad.State - -type Parser a = MaybeT (State String) a - --- | Run a parser on a given input string. If the parser fails, return --- 'Invalid'. Otherwise return the valid event ('Valid') and the --- remaining unparsed characters. -runParser :: String -> Parser Event -> KClass -runParser s parser = - case runState (runMaybeT parser) s of - (Nothing, _) -> Invalid - (Just e, remaining) -> Valid e remaining - --- | Fail a parsing operation. -failParse :: Parser a -failParse = fail "invalid parse" - --- | Read an integer from the input stream. If an integer cannot be --- read, fail parsing. E.g. calling readInt on an input of "123abc" will --- return '123' and consume those characters. -readInt :: Parser Int -readInt = do - s <- get - case (reads :: ReadS Int) s of - [(i, rest)] -> put rest >> return i - _ -> failParse - --- | Read a character from the input stream. If one cannot be read (e.g. --- we are out of characters), fail parsing. -readChar :: Parser Char -readChar = do - s <- get - case s of - c:rest -> put rest >> return c - _ -> failParse - --- | Read a character from the input stream and fail parsing if it is --- not the specified character. -expectChar :: Char -> Parser () -expectChar c = do - c' <- readChar - if c' == c then return () else failParse diff --git a/src/Graphics/Vty/Input/Classify/Types.hs b/src/Graphics/Vty/Input/Classify/Types.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Classify/Types.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | This module exports the input classification type to avoid import --- cycles between other modules that need this. -module Graphics.Vty.Input.Classify.Types - ( KClass(..) - ) -where - -import Graphics.Vty.Input.Events - -data KClass - = Valid Event [Char] - -- ^ A valid event was parsed. Any unused characters from the input - -- stream are also provided. - | Invalid - -- ^ The input characters did not represent a valid event. - | Prefix - -- ^ The input characters form the prefix of a valid event character - -- sequence. - deriving(Show, Eq) 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,6 +1,16 @@ {-# Language DeriveGeneric #-} -module Graphics.Vty.Input.Events where +{-# Language StrictData #-} +module Graphics.Vty.Input.Events + ( Key(..) + , Modifier(..) + , Event(..) + , Button(..) + , ClassifyMap + , InternalEvent(..) + ) +where +import Control.DeepSeq import Data.ByteString import GHC.Generics @@ -14,23 +24,38 @@ -- -- * Actually, support for most of these but KEsc, KChar, KBS, and -- KEnter vary by terminal and keyboard. -data Key = KEsc | KChar Char | KBS | KEnter +data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter - | KFun Int | KBackTab | KPrtScr | KPause | KIns + | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu - deriving (Eq,Show,Read,Ord,Generic) + deriving (Eq, Show, Read, Ord, Generic) +instance NFData Key + -- | Modifier keys. Key codes are interpreted such that users are more -- likely to have Meta than Alt; for instance on the PC Linux console, -- 'MMeta' will generally correspond to the physical Alt key. data Modifier = MShift | MCtrl | MMeta | MAlt - deriving (Eq,Show,Read,Ord,Generic) + deriving (Eq, Show, Read, Ord, Generic) +instance NFData Modifier + -- | Mouse buttons. -data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown - deriving (Eq,Show,Read,Ord,Generic) +data Button + = BLeft + | BMiddle + | BRight + | BScrollUp + | BScrollDown + | BScrollLeft + -- ^ Some terminals (e.g., Kitty, Alacritty) support horizontal + -- scrolling in addition to vertical scrolling. + | BScrollRight + deriving (Eq, Show, Read, Ord, Generic) +instance NFData Button + -- | Events. data Event = EvKey Key [Modifier] @@ -44,10 +69,8 @@ -- without specifying which one; in that case, Nothing is provided. -- Otherwise Just the button released is included in the event. | EvResize Int Int - -- ^ If read from 'eventChannel' this is the size at the time of the - -- signal. If read from 'nextEvent' this is the size at the time the - -- event was processed by Vty. Typically these are the same, but if - -- somebody is resizing the terminal quickly they can be different. + -- The terminal window was resized and the size is provided in the + -- integer fields (width, height). | EvPaste ByteString -- ^ A paste event occurs when a bracketed paste input sequence is -- received. For terminals that support bracketed paste mode, these @@ -60,6 +83,18 @@ -- ^ The terminal running the application lost input focus. | EvGainedFocus -- ^ The terminal running the application gained input focus. - deriving (Eq,Show,Read,Ord,Generic) + deriving (Eq, Show, Read, Ord, Generic) +instance NFData Event + type ClassifyMap = [(String,Event)] + +-- | The type of internal events that drive the internal Vty event +-- dispatching to the application. +data InternalEvent = + ResumeAfterInterrupt + -- ^ Vty resumed operation after the process was interrupted (e.g. + -- with a signal). In practice this translates into a screen redraw + -- in the input event loop. + | InputEvent Event + -- ^ An input event was received. diff --git a/src/Graphics/Vty/Input/Focus.hs b/src/Graphics/Vty/Input/Focus.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Focus.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Graphics.Vty.Input.Focus - ( requestFocusEvents - , disableFocusEvents - , isFocusEvent - , classifyFocusEvent - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types -import Graphics.Vty.Input.Classify.Parse - -import Control.Monad.State -import Data.List (isPrefixOf) - --- | These sequences set xterm-based terminals to send focus event --- sequences. -requestFocusEvents :: String -requestFocusEvents = "\ESC[?1004h" - --- | These sequences disable focus events. -disableFocusEvents :: String -disableFocusEvents = "\ESC[?1004l" - --- | Does the specified string begin with a focus event? -isFocusEvent :: String -> Bool -isFocusEvent s = isPrefixOf focusIn s || - isPrefixOf focusOut s - -focusIn :: String -focusIn = "\ESC[I" - -focusOut :: String -focusOut = "\ESC[O" - --- | Attempt to classify an input string as a focus event. -classifyFocusEvent :: String -> KClass -classifyFocusEvent s = runParser s $ do - when (not $ isFocusEvent s) failParse - - expectChar '\ESC' - expectChar '[' - ty <- readChar - case ty of - 'I' -> return EvGainedFocus - 'O' -> return EvLostFocus - _ -> failParse 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,229 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} --- | The input layer used to be a single function that correctly --- accounted for the non-threaded runtime by emulating the terminal --- VMIN adn VTIME handling. This has been removed and replace with a --- more straightforward parser. The non-threaded runtime is no longer --- supported. --- --- This is an example of an algorithm where code coverage could be high, --- even 100%, but the behavior is still under tested. I should collect --- more of these examples... --- --- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html -module Graphics.Vty.Input.Loop where - -import Graphics.Vty.Config -import Graphics.Vty.Input.Classify -import Graphics.Vty.Input.Events - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (mask, try, SomeException) -import Lens.Micro hiding ((<>~)) -import Lens.Micro.Mtl -import Lens.Micro.TH -import Control.Monad (when, mzero, forM_) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State (StateT(..), evalStateT) -import Control.Monad.State.Class (MonadState, modify) -import Control.Monad.Trans.Reader (ReaderT(..)) - -import Data.Char -import Data.IORef -import Data.Word (Word8) - -import Foreign ( allocaArray, peekArray, Ptr ) -import Foreign.C.Types (CInt(..)) - -import System.IO -import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..)) -import System.Posix.Terminal -import System.Posix.Types (Fd(..)) - -import Text.Printf (hPrintf) - -data Input = Input - { -- | Channel of events direct from input processing. Unlike - -- 'nextEvent' this will not refresh the display if the next event - -- is an 'EvResize'. - _eventChannel :: TChan Event - -- | Shuts down the input processing. This should return the - -- terminal input state to before he input initialized. - , shutdownInput :: IO () - -- | Changes to this value are reflected after the next event. - , _configRef :: IORef Config - -- | input debug log - , _inputDebug :: Maybe Handle - } - -makeLenses ''Input - -data InputBuffer = InputBuffer - { _ptr :: Ptr Word8 - , _size :: Int - } - -makeLenses ''InputBuffer - -data InputState = InputState - { _unprocessedBytes :: String - , _appliedConfig :: Config - , _inputBuffer :: InputBuffer - , _classifier :: String -> KClass - } - -makeLenses ''InputState - -type InputM a = StateT InputState (ReaderT Input IO) a - -logMsg :: String -> InputM () -logMsg msg = do - d <- view inputDebug - case d of - Nothing -> return () - Just h -> liftIO $ hPutStrLn h msg >> hFlush h - --- this must be run on an OS thread dedicated to this input handling. --- otherwise the terminal timing read behavior will block the execution --- of the lightweight threads. -loopInputProcessor :: InputM () -loopInputProcessor = do - readFromDevice >>= addBytesToProcess - validEvents <- many parseEvent - forM_ validEvents emit - dropInvalid - loopInputProcessor - -addBytesToProcess :: String -> InputM () -addBytesToProcess block = unprocessedBytes <>= block - -emit :: Event -> InputM () -emit event = do - logMsg $ "parsed event: " ++ show event - view eventChannel >>= liftIO . atomically . flip writeTChan event - --- The timing requirements are assured by the VMIN and VTIME set for the --- device. --- --- Precondition: Under the threaded runtime. Only current use is from a --- forkOS thread. That case satisfies precondition. -readFromDevice :: InputM String -readFromDevice = do - newConfig <- view configRef >>= liftIO . readIORef - oldConfig <- use appliedConfig - let Just fd = inputFd newConfig - when (newConfig /= oldConfig) $ do - logMsg $ "new config: " ++ show newConfig - liftIO $ applyConfig fd newConfig - appliedConfig .= newConfig - bufferPtr <- use $ inputBuffer.ptr - maxBytes <- use $ inputBuffer.size - stringRep <- liftIO $ do - -- The killThread used in shutdownInput will not interrupt the - -- foreign call fdReadBuf uses this provides a location to be - -- interrupted prior to the foreign call. If there is input on - -- the FD then the fdReadBuf will return in a finite amount of - -- time due to the vtime terminal setting. - threadWaitRead fd - bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes) - if bytesRead > 0 - then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr - else return [] - when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep - return stringRep - -applyConfig :: Fd -> Config -> IO () -applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime }) - = setTermTiming fd theVmin (theVtime `div` 100) -applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration" - -parseEvent :: InputM Event -parseEvent = do - c <- use classifier - b <- use unprocessedBytes - case c b of - Valid e remaining -> do - logMsg $ "valid parse: " ++ show e - logMsg $ "remaining: " ++ show remaining - unprocessedBytes .= remaining - return e - _ -> mzero - -dropInvalid :: InputM () -dropInvalid = do - c <- use classifier - b <- use unprocessedBytes - when (c b == Invalid) $ do - logMsg "dropping input bytes" - unprocessedBytes .= [] - -runInputProcessorLoop :: ClassifyMap -> Input -> IO () -runInputProcessorLoop classifyTable input = do - let bufferSize = 1024 - allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do - s0 <- InputState [] <$> readIORef (_configRef input) - <*> pure (InputBuffer bufferPtr bufferSize) - <*> pure (classify classifyTable) - runReaderT (evalStateT loopInputProcessor s0) input - -attributeControl :: Fd -> IO (IO (), IO ()) -attributeControl fd = do - original <- getTerminalAttributes fd - let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts - , EnableEcho, ProcessInput, ExtendedFunctions - ] - let setAttrs = setTerminalAttributes fd vtyMode Immediately - unsetAttrs = setTerminalAttributes fd original Immediately - return (setAttrs,unsetAttrs) - -logInitialInputState :: Input -> ClassifyMap -> IO() -logInitialInputState input classifyTable = case _inputDebug input of - Nothing -> return () - Just h -> do - Config{ vmin = Just theVmin - , vtime = Just theVtime - , termName = Just theTerm, .. } <- readIORef $ _configRef input - _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime)) - forM_ classifyTable $ \i -> case i of - (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm) - (show inBytes) - (show k) - (show mods) - _ -> return () - -initInput :: Config -> ClassifyMap -> IO Input -initInput config classifyTable = do - let Just fd = inputFd config - setFdOption fd NonBlockingRead False - applyConfig fd config - stopSync <- newEmptyMVar - input <- Input <$> atomically newTChan - <*> pure (return ()) - <*> newIORef config - <*> maybe (return Nothing) - (\f -> Just <$> openFile f AppendMode) - (debugLog config) - logInitialInputState input classifyTable - inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input) - (\_ -> putMVar stopSync ()) - let killAndWait = do - killThread inputThread - takeMVar stopSync - return $ input { shutdownInput = killAndWait } - -foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO () - -forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId -forkOSFinally action and_then = - mask $ \restore -> forkOS $ try (restore action) >>= and_then - -(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () -l <>= a = modify (l <>~ a) - -(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t -l <>~ n = over l (`mappend` n) diff --git a/src/Graphics/Vty/Input/Mouse.hs b/src/Graphics/Vty/Input/Mouse.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Mouse.hs +++ /dev/null @@ -1,161 +0,0 @@ --- | This module provides parsers for mouse events for both "normal" and --- "extended" modes. This implementation was informed by --- --- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking -module Graphics.Vty.Input.Mouse - ( requestMouseEvents - , disableMouseEvents - , isMouseEvent - , classifyMouseEvent - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types -import Graphics.Vty.Input.Classify.Parse - -import Control.Monad.State -import Data.List (isPrefixOf) -import Data.Maybe (catMaybes) -import Data.Bits ((.&.)) - --- A mouse event in SGR extended mode is --- --- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m') --- --- where --- --- * B is the number with button and modifier bits set, --- * X is the X coordinate of the event starting at 1 --- * Y is the Y coordinate of the event starting at 1 --- * the final character is 'M' for a press, 'm' for a release - --- | These sequences set xterm-based terminals to send mouse event --- sequences. -requestMouseEvents :: String -requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h" - --- | These sequences disable mouse events. -disableMouseEvents :: String -disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l" - --- | Does the specified string begin with a mouse event? -isMouseEvent :: String -> Bool -isMouseEvent s = isSGREvent s || isNormalEvent s - -isSGREvent :: String -> Bool -isSGREvent = isPrefixOf sgrPrefix - -sgrPrefix :: String -sgrPrefix = "\ESC[M" - -isNormalEvent :: String -> Bool -isNormalEvent = isPrefixOf normalPrefix - -normalPrefix :: String -normalPrefix = "\ESC[<" - --- Modifier bits: -shiftBit :: Int -shiftBit = 4 - -metaBit :: Int -metaBit = 8 - -ctrlBit :: Int -ctrlBit = 16 - --- These bits indicate the buttons involved: -buttonMask :: Int -buttonMask = 67 - -leftButton :: Int -leftButton = 0 - -middleButton :: Int -middleButton = 1 - -rightButton :: Int -rightButton = 2 - -scrollUp :: Int -scrollUp = 64 - -scrollDown :: Int -scrollDown = 65 - -hasBitSet :: Int -> Int -> Bool -hasBitSet val bit = val .&. bit > 0 - --- | Attempt to lassify an input string as a mouse event. -classifyMouseEvent :: String -> KClass -classifyMouseEvent s = runParser s $ do - when (not $ isMouseEvent s) failParse - - expectChar '\ESC' - expectChar '[' - ty <- readChar - case ty of - '<' -> classifySGRMouseEvent - 'M' -> classifyNormalMouseEvent - _ -> failParse - --- Given a modifer/button value, determine which button was indicated -getSGRButton :: Int -> Parser Button -getSGRButton mods = - let buttonMap = [ (leftButton, BLeft) - , (middleButton, BMiddle) - , (rightButton, BRight) - , (scrollUp, BScrollUp) - , (scrollDown, BScrollDown) - ] - in case lookup (mods .&. buttonMask) buttonMap of - Nothing -> failParse - Just b -> return b - -getModifiers :: Int -> [Modifier] -getModifiers mods = - catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing - , if mods `hasBitSet` metaBit then Just MMeta else Nothing - , if mods `hasBitSet` ctrlBit then Just MCtrl else Nothing - ] - --- Attempt to classify a control sequence as a "normal" mouse event. To --- get here we should have already read "\ESC[M" so that will not be --- included in the string to be parsed. -classifyNormalMouseEvent :: Parser Event -classifyNormalMouseEvent = do - statusChar <- readChar - xCoordChar <- readChar - yCoordChar <- readChar - - let xCoord = fromEnum xCoordChar - 32 - yCoord = fromEnum yCoordChar - 32 - status = fromEnum statusChar - modifiers = getModifiers status - - let press = status .&. buttonMask /= 3 - case press of - True -> do - button <- getSGRButton status - return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers - False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing - --- Attempt to classify a control sequence as an SGR mouse event. To --- get here we should have already read "\ESC[<" so that will not be --- included in the string to be parsed. -classifySGRMouseEvent :: Parser Event -classifySGRMouseEvent = do - mods <- readInt - expectChar ';' - xCoord <- readInt - expectChar ';' - yCoord <- readInt - final <- readChar - - let modifiers = getModifiers mods - button <- getSGRButton mods - case final of - 'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers - 'm' -> return $ EvMouseUp (xCoord-1) (yCoord-1) (Just button) - _ -> failParse diff --git a/src/Graphics/Vty/Input/Paste.hs b/src/Graphics/Vty/Input/Paste.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Paste.hs +++ /dev/null @@ -1,49 +0,0 @@ --- | This module provides bracketed paste support as described at --- --- http://cirw.in/blog/bracketed-paste -module Graphics.Vty.Input.Paste - ( parseBracketedPaste - , bracketedPasteStarted - , bracketedPasteFinished - ) -where - -import qualified Data.ByteString.Char8 as BS8 - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types - -import Data.List (isPrefixOf, isInfixOf) - -bracketedPasteStart :: String -bracketedPasteStart = "\ESC[200~" - -bracketedPasteEnd :: String -bracketedPasteEnd = "\ESC[201~" - --- | Does the input start a bracketed paste? -bracketedPasteStarted :: String -> Bool -bracketedPasteStarted = isPrefixOf bracketedPasteStart - --- | Does the input contain a complete bracketed paste? -bracketedPasteFinished :: String -> Bool -bracketedPasteFinished = isInfixOf bracketedPasteEnd - --- | Parse a bracketed paste. This should only be called on a string if --- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return --- 'True'. -parseBracketedPaste :: String -> KClass -parseBracketedPaste s = - let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd - rest' = if bracketedPasteEnd `isPrefixOf` rest - then drop (length bracketedPasteEnd) rest - else rest - in Valid (EvPaste $ BS8.pack p) rest' - -takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a]) -takeUntil [] _ = ([], []) -takeUntil cs sub - | length cs < length sub = (cs, []) - | take (length sub) cs == sub = ([], drop (length sub) cs) - | otherwise = let (pre, suf) = takeUntil (tail cs) sub - in (head cs:pre, suf) 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,184 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Graphics.Vty.Input.Terminfo where - -import Graphics.Vty.Input.Events -import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT - -import Control.Arrow -import System.Console.Terminfo - --- | Queries the terminal for all capability-based input sequences and --- then adds on a terminal-dependent input sequence mapping. --- --- For reference see: --- --- * http://vimdoc.sourceforge.net/htmldoc/term.html --- --- * vim74/src/term.c --- --- * http://invisible-island.net/vttest/ --- --- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html --- --- Terminfo is incomplete. The vim source implies that terminfo is also --- incorrect. Vty assumes that the internal terminfo table added to the --- system-provided terminfo table is correct. --- --- The procedure used here is: --- --- 1. Build terminfo table for all caps. Missing caps are not added. --- --- 2. Add tables for visible chars, esc, del, ctrl, and meta. --- --- 3. Add internally-defined table for given terminal type. --- --- Precedence is currently implicit in the 'compile' algorithm. -classifyMapForTerm :: String -> Terminal -> ClassifyMap -classifyMapForTerm termName term = - concat $ capsClassifyMap term keysFromCapsTable - : universalTable - : termSpecificTables termName - --- | The key table applicable to all terminals. --- --- Note that some of these entries are probably only applicable to --- ANSI/VT100 terminals. -universalTable :: ClassifyMap -universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys] - -capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap -capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table] - where extractCap = first (getCapability terminal . tiGetStr) - --- | Tables specific to a given terminal that are not derivable from --- terminfo. --- --- Note that this adds the ANSI/VT100/VT50 tables regardless of term --- identifier. -termSpecificTables :: String -> [ClassifyMap] -termSpecificTables _termName = ANSIVT.classifyTable - --- | Visible characters in the ISO-8859-1 and UTF-8 common set. --- --- We limit to < 0xC1. The UTF8 sequence detector will catch all values --- 0xC2 and above before this classify table is reached. -visibleChars :: ClassifyMap -visibleChars = [ ([x], EvKey (KChar x) []) - | x <- [' ' .. toEnum 0xC1] - ] - --- | Non-printable characters in the ISO-8859-1 and UTF-8 common set --- translated to ctrl + char. --- --- This treats CTRL-i the same as tab. -ctrlChars :: ClassifyMap -ctrlChars = - [ ([toEnum x],EvKey (KChar y) [MCtrl]) - | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']) - , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. - , y /= 'h' -- CTRL-h should not hide BS - ] - --- | Ctrl+Meta+Char -ctrlMetaChars :: ClassifyMap -ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars - --- | Esc, meta-esc, delete, meta-delete, enter, meta-enter. -specialSupportKeys :: ClassifyMap -specialSupportKeys = - [ -- special support for ESC - ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta]) - -- Special support for backspace - , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]) - -- Special support for Enter - , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter []) - -- explicit support for tab - , ("\t", EvKey (KChar '\t') []) - ] - --- | A classification table directly generated from terminfo cap --- strings. These are: --- --- * ka1 - keypad up-left --- --- * ka3 - keypad up-right --- --- * kb2 - keypad center --- --- * kbs - keypad backspace --- --- * kbeg - begin --- --- * kcbt - back tab --- --- * kc1 - keypad left-down --- --- * kc3 - keypad right-down --- --- * kdch1 - delete --- --- * kcud1 - down --- --- * kend - end --- --- * kent - enter --- --- * kf0 - kf63 - function keys --- --- * khome - KHome --- --- * kich1 - insert --- --- * kcub1 - left --- --- * knp - next page (page down) --- --- * kpp - previous page (page up) --- --- * kcuf1 - right --- --- * kDC - shift delete --- --- * kEND - shift end --- --- * kHOM - shift home --- --- * kIC - shift insert --- --- * kLFT - shift left --- --- * kRIT - shift right --- --- * kcuu1 - up -keysFromCapsTable :: ClassifyMap -keysFromCapsTable = - [ ("ka1", EvKey KUpLeft []) - , ("ka3", EvKey KUpRight []) - , ("kb2", EvKey KCenter []) - , ("kbs", EvKey KBS []) - , ("kbeg", EvKey KBegin []) - , ("kcbt", EvKey KBackTab []) - , ("kc1", EvKey KDownLeft []) - , ("kc3", EvKey KDownRight []) - , ("kdch1", EvKey KDel []) - , ("kcud1", EvKey KDown []) - , ("kend", EvKey KEnd []) - , ("kent", EvKey KEnter []) - , ("khome", EvKey KHome []) - , ("kich1", EvKey KIns []) - , ("kcub1", EvKey KLeft []) - , ("knp", EvKey KPageDown []) - , ("kpp", EvKey KPageUp []) - , ("kcuf1", EvKey KRight []) - , ("kDC", EvKey KDel [MShift]) - , ("kEND", EvKey KEnd [MShift]) - , ("kHOM", EvKey KHome [MShift]) - , ("kIC", EvKey KIns [MShift]) - , ("kLFT", EvKey KLeft [MShift]) - , ("kRIT", EvKey KRight [MShift]) - , ("kcuu1", EvKey KUp []) - ] ++ functionKeyCapsTable - --- | Cap names for function keys. -functionKeyCapsTable :: ClassifyMap -functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) []) 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,88 +0,0 @@ --- | Input mappings for ANSI/VT100/VT50 terminals that is missing from --- terminfo. --- --- Or that are sent regardless of terminfo by terminal emulators. EG: --- Terminal emulators will often use VT50 input bytes regardless of --- declared terminal type. This provides compatibility with programs --- that don't follow terminfo. -module Graphics.Vty.Input.Terminfo.ANSIVT where - -import Graphics.Vty.Input.Events - --- | Encoding for navigation keys. -navKeys0 :: ClassifyMap -navKeys0 = - [ k "G" KCenter - , k "P" KPause - , k "A" KUp - , k "B" KDown - , k "C" KRight - , k "D" KLeft - , k "H" KHome - , k "F" KEnd - , k "E" KBegin - ] - where k c s = ("\ESC["++c,EvKey s []) - --- | encoding for shift, meta and ctrl plus arrows/home/end -navKeys1 :: ClassifyMap -navKeys1 = - [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m) - | charCnt <- ["1;", ""], -- we can have a count or not - (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), - -- modifiers and their codes - ([MShift, MCtrl],6), ([MShift, MMeta],4)], - -- directions and their codes - (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] - ] - --- | encoding for ins, del, pageup, pagedown, home, end -navKeys2 :: ClassifyMap -navKeys2 = - let k n s = ("\ESC["++show n++"~",EvKey s []) - in zipWith k [2::Int,3,5,6,1,4] - [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] - --- | encoding for ctrl + ins, del, pageup, pagedown, home, end -navKeys3 :: ClassifyMap -navKeys3 = - let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl]) - in zipWith k [2::Int,3,5,6,1,4] - [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] - --- | encoding for shift plus function keys --- --- According to --- --- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html --- --- This encoding depends on the terminal. -functionKeys1 :: ClassifyMap -functionKeys1 = - let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in - concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ] - --- | encoding for meta plus char --- --- 1. removed 'ESC' from second list due to duplication with --- "special_support_keys". --- 2. removed '[' from second list due to conflict with 7-bit encoding --- for ESC. Whether meta+[ is the same as ESC should examine km and --- current encoding. --- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped --- to KBS by special_support_keys. -functionKeys2 :: ClassifyMap -functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta]) - | x <- '\t':[' ' .. '~'] - , x /= '[' - ] - -classifyTable :: [ClassifyMap] -classifyTable = - [ navKeys0 - , navKeys1 - , navKeys2 - , navKeys3 - , functionKeys1 - , functionKeys2 - ] 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,106 +1,367 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} --- | This module provides functions for accessing the current terminal --- or a specific terminal device. --- --- See also: --- --- 1. "Graphics.Vty.Output": This instantiates an abtract interface --- to the terminal based on the @TERM@ and @COLORTERM@ environment --- variables. --- --- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all --- terminal modules need to implement. --- --- 3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance --- that uses terminfo for all control strings. No attempt is made to --- change the character set to UTF-8 for these terminals. --- --- 4. "Graphics.Vty.Output.XTermColor": This module contains an --- interface suitable for xterm-like terminals. These are the terminals --- where @TERM@ begins with @xterm@. This does use terminfo for as many --- control codes as possible. +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards, CPP #-} +-- | This module provides an abstract interface for performing terminal +-- output and functions for accessing the current terminal or a specific +-- terminal device. module Graphics.Vty.Output - ( outputForConfig + ( Output(..) + , AssumedState(..) + , DisplayContext(..) + , Mode(..) + , displayContext + , outputPicture + , initialAssumedState + , limitAttrForDisplay , setCursorPos , hideCursor , showCursor ) where +import Blaze.ByteString.Builder (Write, writeToByteString) +import Blaze.ByteString.Builder.ByteString (writeByteString) import Control.Monad (when) - -import Graphics.Vty.Config -import Graphics.Vty.Image (regionWidth, regionHeight) -import Graphics.Vty.Output.Interface -import Graphics.Vty.Output.XTermColor as XTermColor -import Graphics.Vty.Output.TerminfoBased as TerminfoBased - -import Blaze.ByteString.Builder (writeToByteString) - -import Control.Monad.Trans - -import Data.List (isPrefixOf) +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Vector as Vector +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) - --- | Returns an `Output` for the terminal specified in `Config`. --- --- The specific Output implementation used is hidden from the API user. --- All terminal implementations are assumed to perform more, or less, --- the same. Currently, all implementations use terminfo for at least --- some terminal specific information. --- --- If a terminal implementation is developed for a terminal without --- terminfo support then Vty should work as expected on that terminal. --- --- Selection of a terminal is done as follows: --- --- * If TERM contains "xterm" or "screen", use XTermColor. --- * otherwise use the TerminfoBased driver. -outputForConfig :: Config -> IO Output -outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do - t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName - then XTermColor.reserveTerminal termName fd - -- Not an xterm-like terminal. try for generic terminfo. - else TerminfoBased.reserveTerminal termName fd +#endif +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL - case mouseMode of - Just s -> setMode t Mouse s - Nothing -> return () +import Graphics.Vty.Attributes +import Graphics.Vty.DisplayAttributes +import Graphics.Vty.Image (DisplayRegion, regionWidth, regionHeight) +import Graphics.Vty.Picture +import Graphics.Vty.PictureToSpans +import Graphics.Vty.Span - case bracketedPasteMode of - Just s -> setMode t BracketedPaste s - Nothing -> return () +-- | Modal terminal features that can be enabled and disabled. +data Mode = Mouse + -- ^ Mouse mode (whether the terminal is configured to provide + -- mouse input events) + | BracketedPaste + -- ^ Paste mode (whether the terminal is configured to provide + -- events on OS pastes) + | Focus + -- ^ Focus-in/focus-out events (whether the terminal is + -- configured to provide events on focus change) + | Hyperlink + -- ^ Hyperlink mode via the 'withURL' attribute modifier (see + -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). + -- Note that this may not work gracefully in all terminal + -- emulators so be sure to test this mode with the terminals + -- you intend to support. It is off by default. + deriving (Eq, Read, Show) - return t -outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig +-- | The library's device output abstraction. Platform-specific +-- implementations must implement an 'Output' and provide it to +-- 'Graphics.Vty.mkVtyFromPair'. +data Output = Output + { -- | Text identifier for the output device. Used for debugging. + terminalID :: String + -- | Release the terminal just prior to application exit and reset + -- it to its state prior to application startup. + , releaseTerminal :: IO () + -- | Clear the display and initialize the terminal to some initial + -- display state. + -- + -- The expectation of a program is that the display starts in some + -- The initial state. initial state would consist of fixed values: + -- + -- - cursor at top left + -- - UTF-8 character encoding + -- - drawing characteristics are the default + , reserveDisplay :: IO () + -- | Return the display to the state before `reserveDisplay` If no + -- previous state then set the display state to the initial state. + , releaseDisplay :: IO () + -- | Sets the current display bounds (width, height). + , setDisplayBounds :: (Int, Int) -> IO () + -- | Returns the current display bounds. + , displayBounds :: IO DisplayRegion + -- | Output the bytestring to the terminal device. + , outputByteBuffer :: BS.ByteString -> IO () + -- | Specifies whether the cursor can be shown / hidden. + , supportsCursorVisibility :: Bool + -- | Indicates support for terminal modes for this output device. + , supportsMode :: Mode -> Bool + -- | Enables or disables a mode (does nothing if the mode is + -- unsupported). + , setMode :: Mode -> Bool -> IO () + -- | Returns whether a mode is enabled. + , getModeStatus :: Mode -> IO Bool + , assumedStateRef :: IORef AssumedState + -- | Acquire display access to the given region of the display. + -- Currently all regions have the upper left corner of (0,0) and + -- the lower right corner at (max displayWidth providedWidth, max + -- displayHeight providedHeight) + , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext + -- | Ring the terminal bell if supported. + , ringTerminalBell :: IO () + -- | Returns whether the terminal has an audio bell feature. + , supportsBell :: IO Bool + -- | Returns whether the terminal supports italicized text. + -- + -- This is terminal-dependent and should make a best effort to + -- determine whether this feature is supported, but even if the + -- terminal advertises support (e.g. via terminfo) that might not + -- be a reliable indicator of whether the feature will work as + -- desired. + , supportsItalics :: IO Bool + -- | Returns whether the terminal supports strikethrough text. + -- + -- This is terminal-dependent and should make a best effort to + -- determine whether this feature is supported, but even if the + -- terminal advertises support (e.g. via terminfo) that might not + -- be a reliable indicator of whether the feature will work as + -- desired. + , supportsStrikethrough :: IO Bool + -- | Returns how many colors the terminal supports. + , outputColorMode :: ColorMode + -- | Set the output's window title, if any. + , setOutputWindowTitle :: String -> IO () + } -- | Sets the cursor position to the given output column and row. -- --- This is not necessarially the same as the character position with the +-- This is not necessarily the same as the character position with the -- same coordinates. Characters can be a variable number of columns in -- width. -- -- 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 () +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 () +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 () +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,305 +0,0 @@ --- Copyright Corey O'Connor -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} --- | This module provides an abstract interface for performing terminal --- output. The only user-facing part of this API is 'Output'. -module Graphics.Vty.Output.Interface - ( Output(..) - , AssumedState(..) - , DisplayContext(..) - , Mode(..) - , displayContext - , outputPicture - , initialAssumedState - , limitAttrForDisplay - ) -where - -import Graphics.Vty.Attributes -import Graphics.Vty.Image (DisplayRegion, regionHeight) -import Graphics.Vty.Picture -import Graphics.Vty.PictureToSpans -import Graphics.Vty.Span - -import Graphics.Vty.DisplayAttributes - -import Blaze.ByteString.Builder (Write, writeToByteString) -import Blaze.ByteString.Builder.ByteString (writeByteString) - -import 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 - --- | Modal terminal features that can be enabled and disabled. -data Mode = Mouse - -- ^ Mouse mode (whether the terminal is configured to provide - -- mouse input events) - | BracketedPaste - -- ^ Paste mode (whether the terminal is configured to provide - -- events on OS pastes) - | Focus - -- ^ Focus-in/focus-out events (whether the terminal is - -- configured to provide events on focus change) - | Hyperlink - -- ^ Hyperlink mode via the 'withURL' attribute modifier (see - -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). - -- Note that this may not work gracefully in all terminal - -- emulators so be sure to test this mode with the terminals - -- you intend to support. It is off by default. - deriving (Eq, Read, Show) - --- | The Vty terminal output interface. -data Output = Output - { -- | Text identifier for the output device. Used for debugging. - terminalID :: String - -- | Release the terminal just prior to application exit and reset - -- it to its state prior to application startup. - , releaseTerminal :: 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 - -- The initial state. initial state would consist of fixed values: - -- - -- - cursor at top left - -- - UTF-8 character encoding - -- - drawing characteristics are the default - , 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 bytestring to the terminal device. - , outputByteBuffer :: BS.ByteString -> IO () - -- | Specifies the maximum number of colors supported by the - -- context. - , contextColorCount :: Int - -- | Specifies whether the cursor can be shown / hidden. - , supportsCursorVisibility :: Bool - -- | Indicates support for terminal modes for this output device. - , supportsMode :: Mode -> Bool - -- | Enables or disables a mode (does nothing if the mode is - -- unsupported). - , setMode :: forall m. MonadIO m => Mode -> Bool -> m () - -- | Returns whether a mode is enabled. - , getModeStatus :: forall m. MonadIO m => Mode -> m 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 - -- | Ring the terminal bell if supported. - , ringTerminalBell :: forall m. MonadIO m => m () - -- | Returns whether the terminal has an audio bell feature. - , supportsBell :: forall m. MonadIO m => m Bool - } - -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 - -- 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 :: MonadIO m => DisplayContext -> Picture -> m () -outputPicture dc pic = liftIO $ 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 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 urlsEnabled dc initialAttr diffs ops - `mappend` - (let (w,h) = contextRegion dc - clampX = max 0 . min (w-1) - clampY = max 0 . min (h-1) in - case picCursor pic of - _ | not manipCursor -> mempty - NoCursor -> mempty - AbsoluteCursor x y -> - writeShowCursor dc `mappend` - writeMoveCursor dc (clampX x) (clampY y) - Cursor x y -> - let m = cursorOutputMap ops $ picCursor pic - (ox, oy) = charToOutputPos m (clampX x, clampY y) - in writeShowCursor dc `mappend` - writeMoveCursor dc (clampX ox) (clampY oy) - ) - -- ... then serialize - outputByteBuffer (contextDevice dc) (writeToByteString out) - -- Cache the output spans. - let as' = as { prevOutputOps = Just ops } - writeIORef (assumedStateRef $ contextDevice dc) as' - -writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write -writeOutputOps urlsEnabled dc initialAttr diffs ops = - let (_, out, _) = Vector.foldl' writeOutputOps' - (0, mempty, diffs) - ops - in out - where - writeOutputOps' (y, out, True : diffs') spanOps - = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps - out' = out `mappend` spanOut - in (y+1, out', diffs') - writeOutputOps' (y, out, False : diffs') _spanOps - = (y + 1, out, diffs') - writeOutputOps' (_y, _out, []) _spanOps - = error "vty - output spans without a corresponding diff." - -writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write -writeSpanOps urlsEnabled dc y initialAttr spanOps = - -- The first operation is to set the cursor to the start of the row - let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled - -- then the span ops are serialized in the order specified - in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of - (opOut, fattr') -> (out `mappend` opOut, fattr') - ) - (start, initialAttr) - spanOps - -writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr) -writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr = - let attr' = limitAttrForDisplay (contextDevice dc) attr - fattr' = fixDisplayAttr fattr attr' - diffs = displayAttrDiffs fattr fattr' - out = writeSetAttr dc urlsEnabled fattr attr' diffs - `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str) - in (out, fattr') -writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip" -writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr) - --- | The cursor position is given in X,Y character offsets. Due to --- multi-column characters this needs to be translated to column, row --- positions. -data CursorOutputMap = CursorOutputMap - { charToOutputPos :: (Int, Int) -> (Int, Int) - } - -cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap -cursorOutputMap spanOps _cursor = CursorOutputMap - { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy) - } - -cursorColumnOffset :: DisplayOps -> Int -> Int -> Int -cursorColumnOffset ops cx cy = - let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy) - (outOffset, _, _) - = Vector.foldl' ( \(d, currentCx, done) op -> - if done then (d, currentCx, done) else case spanOpHasWidth op of - Nothing -> (d, currentCx, False) - Just (cw, ow) -> case compare cx (currentCx + cw) of - GT -> ( d + ow - , currentCx + cw - , False - ) - EQ -> ( d + ow - , currentCx + cw - , True - ) - LT -> ( d + columnsToCharOffset (cx - currentCx) op - , currentCx + cw - , True - ) - ) - (0, 0, False) - cursorRowOps - in outOffset - --- | Not all terminals support all display attributes. This filters a --- display attribute to what the given terminal can display. -limitAttrForDisplay :: Output -> Attr -> Attr -limitAttrForDisplay t attr - = attr { attrForeColor = clampColor $ attrForeColor attr - , attrBackColor = clampColor $ attrBackColor attr - } - where - clampColor Default = Default - clampColor KeepCurrent = KeepCurrent - clampColor (SetTo c) = clampColor' c - clampColor' (ISOColor v) - | contextColorCount t < 8 = Default - | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8) - | otherwise = SetTo $ ISOColor v - clampColor' (Color240 v) - -- Should we choose closest ISO color? - | contextColorCount t < 8 = Default - | contextColorCount t < 16 = Default - | contextColorCount t <= 256 = SetTo $ Color240 v - | otherwise - = let p :: Double = fromIntegral v / 240.0 - v' = floor $ p * (fromIntegral $ contextColorCount t) - in SetTo $ Color240 v' 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 @@ -11,7 +11,8 @@ where import Graphics.Vty.Image (DisplayRegion) -import Graphics.Vty.Output.Interface +import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16)) +import Graphics.Vty.Output import Blaze.ByteString.Builder.Word (writeWord8) @@ -30,7 +31,7 @@ -- without considering terminal specific issues. -- -- The mock implementation is useful in manually determining if the --- sequence of terminal operations matche the expected sequence. The +-- sequence of terminal operations matches the expected sequence. The -- requirement of the produced representation is simplicity in parsing -- the text representation and determining how the picture was mapped to -- terminal operations. @@ -48,16 +49,20 @@ , releaseDisplay = return () , ringTerminalBell = return () , supportsBell = return False + , supportsItalics = return False + , supportsStrikethrough = return False + , setDisplayBounds = const $ return () , displayBounds = return r , outputByteBuffer = \bytes -> do putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes" writeIORef outRef $ UTF8.fromRep bytes - , contextColorCount = 16 , supportsCursorVisibility = True , supportsMode = const False , setMode = const $ const $ return () , getModeStatus = const $ return False , assumedStateRef = newAssumedStateRef + , outputColorMode = ColorMode16 + , setOutputWindowTitle = const $ return () , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual @@ -83,4 +88,3 @@ } } return (outRef, t) - 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,530 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} -{-# CFILES gwinsz.c #-} - --- | Terminfo-based terminal output driver. --- --- Copyright Corey O'Connor (coreyoconnor@gmail.com) -module Graphics.Vty.Output.TerminfoBased - ( reserveTerminal - ) -where - -import Control.Monad (when) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (toForeignPtr) -import Data.Terminfo.Parse -import Data.Terminfo.Eval - -import Graphics.Vty.Attributes -import Graphics.Vty.Image (DisplayRegion) -import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Output.Interface - -import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable) - -import Control.Monad.Trans - -import Data.Bits ((.&.)) -import Data.Foldable (foldMap) -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(..)) - -data TerminfoCaps = TerminfoCaps - { smcup :: Maybe CapExpression - , rmcup :: Maybe CapExpression - , cup :: CapExpression - , cnorm :: Maybe CapExpression - , civis :: Maybe CapExpression - , supportsNoColors :: Bool - , useAltColorMap :: Bool - , setForeColor :: CapExpression - , setBackColor :: CapExpression - , setDefaultAttr :: CapExpression - , clearScreen :: CapExpression - , clearEol :: CapExpression - , displayAttrCaps :: DisplayAttrCaps - , ringBellAudio :: Maybe CapExpression - } - -data DisplayAttrCaps = DisplayAttrCaps - { setAttrStates :: Maybe CapExpression - , enterStandout :: Maybe CapExpression - , exitStandout :: Maybe CapExpression - , enterItalic :: Maybe CapExpression - , exitItalic :: Maybe CapExpression - , enterUnderline :: Maybe CapExpression - , exitUnderline :: Maybe CapExpression - , enterReverseVideo :: Maybe CapExpression - , enterDimMode :: Maybe CapExpression - , enterBoldMode :: Maybe CapExpression - } - --- kinda like: --- https://code.google.com/p/vim/source/browse/src/fileio.c#10422 --- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR --- the write will be retried. -fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int -fdWriteAll outFd ptr len count - | len < 0 = fail "fdWriteAll: len is less than 0" - | len == 0 = return count - | otherwise = do - writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len) - let len' = len - writeCount - ptr' = ptr `plusPtr` writeCount - count' = count + writeCount - fdWriteAll outFd ptr' len' count' - -sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO () -sendCapToTerminal t cap capParams = do - outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams - --- | Constructs an output driver that uses terminfo for all control --- codes. While this should provide the most compatible terminal, --- terminfo does not support some features that would increase --- efficiency and improve compatibility: --- --- * determining the character encoding supported by the terminal. --- Should this be taken from the LANG environment variable? --- --- * Providing independent string capabilities for all display --- attributes. -reserveTerminal :: ( 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 - - hyperlinkModeStatus <- newIORef False - newAssumedStateRef <- newIORef initialAssumedState - - let terminfoSetMode m newStatus = do - curStatus <- terminfoModeStatus m - when (newStatus /= curStatus) $ - case m of - Hyperlink -> liftIO $ do - writeIORef hyperlinkModeStatus newStatus - writeIORef newAssumedStateRef initialAssumedState - _ -> return () - terminfoModeStatus m = - case m of - Hyperlink -> liftIO $ readIORef hyperlinkModeStatus - _ -> return False - terminfoModeSupported Hyperlink = True - terminfoModeSupported _ = False - - terminfoCaps <- pure TerminfoCaps - <*> probeCap ti "smcup" - <*> probeCap ti "rmcup" - <*> requireCap ti "cup" - <*> probeCap ti "cnorm" - <*> probeCap ti "civis" - <*> pure noColors - <*> pure useAlt - <*> pure setForeCap - <*> pure set_back_cap - <*> requireCap ti "sgr0" - <*> requireCap ti "clear" - <*> requireCap ti "el" - <*> currentDisplayAttrCaps ti - <*> probeCap ti "bel" - let t = Output - { terminalID = termName - , releaseTerminal = liftIO $ do - sendCap setDefaultAttr [] - maybeSendCap cnorm [] - , supportsBell = return $ isJust $ ringBellAudio terminfoCaps - , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio [] - , 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 - , supportsMode = terminfoModeSupported - , setMode = terminfoSetMode - , getModeStatus = terminfoModeStatus - , assumedStateRef = newAssumedStateRef - -- I think fix would help assure tActual is the only - -- reference. I was having issues tho. - , mkDisplayContext = \tActual -> 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 "sitm" - <*> probeCap ti "ritm" - <*> probeCap ti "smul" - <*> probeCap ti "rmul" - <*> probeCap ti "rev" - <*> probeCap ti "dim" - <*> probeCap ti "bold" - -foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong - -getWindowSize :: Fd -> IO (Int,Int) -getWindowSize fd = do - (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd - return (fromIntegral b, fromIntegral a) - -terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext -terminfoDisplayContext tActual terminfoCaps r = return dc - where dc = DisplayContext - { contextDevice = tActual - , contextRegion = r - , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x] - , writeShowCursor = case cnorm terminfoCaps of - Nothing -> error "this terminal does not support show cursor" - Just c -> writeCapExpr c [] - , writeHideCursor = case civis terminfoCaps of - Nothing -> error "this terminal does not support hide cursor" - Just c -> writeCapExpr c [] - , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps - , writeDefaultAttr = \urlsEnabled -> - writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend` - (if urlsEnabled then writeURLEscapes EndLink else mempty) - , writeRowEnd = writeCapExpr (clearEol terminfoCaps) [] - , inlineHack = return () - } - --- | Write the escape sequences that are used in some terminals to --- include embedded hyperlinks. As of yet, this information isn't --- included in termcap or terminfo, so this writes them directly --- instead of looking up the appropriate capabilities. -writeURLEscapes :: URLDiff -> Write -writeURLEscapes (LinkTo url) = - foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend` - foldMap writeStorable (BS.unpack url) `mappend` - writeStorable (0x07 :: Word8) -writeURLEscapes EndLink = - foldMap writeStorable (BS.unpack "\x1b]8;;\a") -writeURLEscapes NoLinkChange = - mempty - --- | Portably setting the display attributes is a giant pain in the ass. --- --- If the terminal supports the sgr capability (which sets the on/off --- state of each style directly ; and, for no good reason, resets the --- colors to the default) this procedure is used: --- --- 0. set the style attributes. This resets the fore and back color. --- --- 1, If a foreground color is to be set then set the foreground color --- --- 2. likewise with the background color --- --- If the terminal does not support the sgr cap then: if there is a --- change from an applied color to the default (in either the fore or --- back color) then: --- --- 0. reset all display attributes (sgr0) --- --- 1. enter required style modes --- --- 2. set the fore color if required --- --- 3. set the back color if required --- --- Entering the required style modes could require a reset of the --- display attributes. If this is the case then the back and fore colors --- always need to be set if not default. --- --- This equation implements the above logic. --- --- Note that this assumes the removal of color changes in the --- display attributes is done as expected with noColors == True. See --- `limitAttrForDisplay`. --- --- Note that this optimizes for fewer state changes followed by fewer --- bytes. -terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write -terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs = do - urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of - -- The only way to reset either color, portably, to the default - -- is to use either the set state capability or the set default - -- capability. - True -> do - case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) - (fixedStyle attr ) - (styleToApplySeq $ fixedStyle attr) of - -- only way to reset a color to the defaults - EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled - `mappend` - foldMap (\cap -> writeCapExpr cap []) caps - `mappend` - setColors - -- implicitly resets the colors to the defaults - SetState state -> writeCapExpr (fromJust $ setAttrStates - $ displayAttrCaps - $ terminfoCaps - ) - (sgrArgsForState state) - `mappend` - 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 - urlAttrs True = writeURLEscapes (urlDiff diffs) - urlAttrs False = mempty - 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 - , applyItalic :: Bool - , applyReverseVideo :: Bool - , applyBlink :: Bool - , applyDim :: Bool - , applyBold :: Bool - } - -sgrArgsForState :: DisplayAttrState -> [CapParam] -sgrArgsForState attrState = map (\b -> if b then 1 else 0) - [ applyStandout attrState - , applyUnderline attrState - , applyItalic attrState - , applyReverseVideo attrState - , applyBlink attrState - , applyDim attrState - , applyBold attrState - , False -- invis - , False -- protect - , False -- alt char set - ] - -reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq -reqDisplayCapSeqFor caps s diffs - -- if the state transition implied by any diff cannot be supported - -- with an enter/exit mode cap then either the state needs to be set - -- or the attribute change ignored. - = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of - -- If all the diffs have an enter-exit cap then just use those - ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs - -- If not all the diffs have an enter-exit cap and there is no - -- set state cap then filter out all unsupported diffs and just - -- apply the rest - ( True, False ) -> EnterExitSeq $ map enterExitCap - $ filter (not . noEnterExitCap) diffs - -- if not all the diffs have an enter-exit can and there is a - -- set state cap then just use the set state cap. - ( True, True ) -> SetState $ stateForStyle s - where - noEnterExitCap ApplyItalic = isNothing $ enterItalic caps - noEnterExitCap RemoveItalic = isNothing $ exitItalic caps - noEnterExitCap ApplyStandout = isNothing $ enterStandout caps - noEnterExitCap RemoveStandout = isNothing $ exitStandout caps - noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps - noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps - noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps - noEnterExitCap RemoveReverseVideo = True - noEnterExitCap ApplyBlink = True - noEnterExitCap RemoveBlink = True - noEnterExitCap ApplyDim = isNothing $ enterDimMode caps - noEnterExitCap RemoveDim = True - noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps - noEnterExitCap RemoveBold = True - enterExitCap ApplyItalic = fromJust $ enterItalic caps - enterExitCap RemoveItalic = fromJust $ exitItalic caps - enterExitCap ApplyStandout = fromJust $ enterStandout caps - enterExitCap RemoveStandout = fromJust $ exitStandout caps - enterExitCap ApplyUnderline = fromJust $ enterUnderline caps - enterExitCap RemoveUnderline = fromJust $ exitUnderline caps - enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps - enterExitCap ApplyDim = fromJust $ enterDimMode caps - enterExitCap ApplyBold = fromJust $ enterBoldMode caps - enterExitCap _ = error "enterExitCap applied to diff that was known not to have one." - -stateForStyle :: Style -> DisplayAttrState -stateForStyle s = DisplayAttrState - { applyStandout = isStyleSet standout - , applyUnderline = isStyleSet underline - , applyItalic = isStyleSet italic - , applyReverseVideo = isStyleSet reverseVideo - , applyBlink = isStyleSet blink - , applyDim = isStyleSet dim - , applyBold = isStyleSet bold - } - where isStyleSet = hasStyle s - -styleToApplySeq :: Style -> [StyleStateChange] -styleToApplySeq s = concat - [ applyIfRequired ApplyStandout standout - , applyIfRequired ApplyUnderline underline - , applyIfRequired ApplyItalic italic - , applyIfRequired ApplyReverseVideo reverseVideo - , applyIfRequired ApplyBlink blink - , applyIfRequired ApplyDim dim - , applyIfRequired 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,118 +0,0 @@ --- Copyright 2009-2010 Corey O'Connor --- | Xterm output driver. This uses the Terminfo driver with some --- extensions for Xterm. -module Graphics.Vty.Output.XTermColor - ( reserveTerminal - ) -where - -import Graphics.Vty.Output.Interface -import Graphics.Vty.Input.Mouse -import Graphics.Vty.Input.Focus -import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased - -import Blaze.ByteString.Builder (writeToByteString) -import Blaze.ByteString.Builder.Word (writeWord8) - -import Control.Monad (void, when) -import Control.Monad.Trans -import Data.IORef - -import System.Posix.IO (fdWrite) -import System.Posix.Types (Fd) -import System.Posix.Env (getEnv) - -import Data.List (isInfixOf) -import Data.Maybe (catMaybes) -import Data.Monoid ((<>)) - --- | Construct an Xterm output driver. Initialize the display to UTF-8. -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output -reserveTerminal variant outFd = liftIO $ do - let flushedPut = void . fdWrite outFd - -- If the terminal variant is xterm-color use xterm instead since, - -- more often than not, xterm-color is broken. - let variant' = if variant == "xterm-color" then "xterm" else variant - - utf8a <- utf8Active - when (not utf8a) $ flushedPut setUtf8CharSet - t <- TerminfoBased.reserveTerminal variant' outFd - - mouseModeStatus <- newIORef False - focusModeStatus <- newIORef False - pasteModeStatus <- newIORef False - - let xtermSetMode t' m newStatus = do - curStatus <- getModeStatus t' m - when (newStatus /= curStatus) $ - case m of - Focus -> liftIO $ do - case newStatus of - True -> flushedPut requestFocusEvents - False -> flushedPut disableFocusEvents - writeIORef focusModeStatus newStatus - Mouse -> liftIO $ do - case newStatus of - True -> flushedPut requestMouseEvents - False -> flushedPut disableMouseEvents - writeIORef mouseModeStatus newStatus - BracketedPaste -> liftIO $ do - case newStatus of - True -> flushedPut enableBracketedPastes - False -> flushedPut disableBracketedPastes - writeIORef pasteModeStatus newStatus - Hyperlink -> setMode t Hyperlink newStatus - - xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus - xtermGetMode Focus = liftIO $ readIORef focusModeStatus - xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus - xtermGetMode Hyperlink = getModeStatus t Hyperlink - - let t' = t - { terminalID = terminalID t ++ " (xterm-color)" - , releaseTerminal = do - when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet - setMode t' BracketedPaste False - setMode t' Mouse False - setMode t' Focus False - releaseTerminal t - , mkDisplayContext = \tActual r -> do - dc <- mkDisplayContext t tActual r - return $ dc { inlineHack = xtermInlineHack t' } - , supportsMode = const True - , getModeStatus = xtermGetMode - , setMode = xtermSetMode t' - } - return t' - -utf8Active :: IO Bool -utf8Active = do - let vars = ["LC_ALL", "LANG", "LC_CTYPE"] - results <- catMaybes <$> mapM getEnv vars - let matches = filter ("UTF8" `isInfixOf`) results <> - filter ("UTF-8" `isInfixOf`) results - return $ not $ null matches - --- | Enable bracketed paste mode: --- http://cirw.in/blog/bracketed-paste -enableBracketedPastes :: String -enableBracketedPastes = "\ESC[?2004h" - --- | Disable bracketed paste mode: -disableBracketedPastes :: String -disableBracketedPastes = "\ESC[?2004l" - --- | These sequences set xterm based terminals to UTF-8 output. --- --- There is no known terminfo capability equivalent to this. -setUtf8CharSet, setDefaultCharSet :: String -setUtf8CharSet = "\ESC%G" -setDefaultCharSet = "\ESC%@" - --- | I think xterm is broken: Reseting the background color as the first --- bytes serialized on a new line does not effect the background color --- xterm uses to clear the line. Which is used *after* the next newline. -xtermInlineHack :: Output -> IO () -xtermInlineHack t = do - let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K" - outputByteBuffer t $ writeToByteString writeReset 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,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -- A 'Picture' is a background paired with a set of 'Image' layers. The -- 'Picture' data structure is representative of the final terminal -- view. @@ -31,10 +30,7 @@ , picBackground :: Background -- ^ The picture's background to be displayed in locations with no -- Image data. - } deriving Eq - -instance Show Picture where - show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??" + } deriving (Eq, Show) instance NFData Picture where rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () @@ -80,12 +76,20 @@ data Cursor = -- | Hide the cursor NoCursor + -- | Set the terminal's cursor position without displaying a cursor + -- character. This is important for accessibility with screen + -- readers where a cursor position needs to be reported but we may + -- not want to show a block cursor in that location for cosmetic + -- reasons. The boolean argument indicates whether the positioning + -- should be absolute as with 'AbsoluteCursor' ('True') or logical + -- as with 'Cursor' ('False'). + | PositionOnly !Bool !Int !Int -- | Show the cursor at the given logical column accounting for -- character width in the presence of multi-column characters. | Cursor !Int !Int -- | Show the cursor at the given absolute terminal column and row | AbsoluteCursor !Int !Int - deriving Eq + deriving (Eq, Show) instance NFData Cursor where rnf c = c `seq` () @@ -109,7 +113,7 @@ -- -- * End of line if there are no remaining non-skip ops. | ClearBackground - deriving Eq + deriving (Eq, Show) instance NFData Background where rnf (Background c a) = c `seq` a `seq` () 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 @@ -3,10 +3,12 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -- | Transforms an image into rows of operations. -module Graphics.Vty.PictureToSpans where +module Graphics.Vty.PictureToSpans + ( displayOpsForPic + ) +where import Graphics.Vty.Attributes (Attr, currentAttr) import Graphics.Vty.Image @@ -16,7 +18,7 @@ import Lens.Micro import Lens.Micro.Mtl -import Lens.Micro.TH +import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) import Control.Monad.ST.Strict @@ -29,8 +31,6 @@ type MRowOps s = MVector s SpanOps -type MSpanOps s = MVector s SpanOp - -- transform plus clip. More or less. data BlitState = BlitState -- we always snoc to the operation vectors. Thus the columnOffset = @@ -53,15 +53,35 @@ , _remainingRows :: Int } -makeLenses ''BlitState +columnOffset :: Lens' BlitState Int +columnOffset = lens _columnOffset (\e v -> e { _columnOffset = v }) +rowOffset :: Lens' BlitState Int +rowOffset = lens _rowOffset (\e v -> e { _rowOffset = v }) + +skipColumns :: Lens' BlitState Int +skipColumns = lens _skipColumns (\e v -> e { _skipColumns = v }) + +skipRows :: Lens' BlitState Int +skipRows = lens _skipRows (\e v -> e { _skipRows = v }) + +remainingColumns :: Lens' BlitState Int +remainingColumns = lens _remainingColumns (\e v -> e { _remainingColumns = v }) + +remainingRows :: Lens' BlitState Int +remainingRows = lens _remainingRows (\e v -> e { _remainingRows = v }) + data BlitEnv s = BlitEnv { _region :: DisplayRegion , _mrowOps :: MRowOps s } -makeLenses ''BlitEnv +region :: Lens' (BlitEnv s) DisplayRegion +region = lens _region (\e r -> e { _region = r }) +mrowOps :: Lens' (BlitEnv s) (MRowOps s) +mrowOps = lens _mrowOps (\e r -> e { _mrowOps = r }) + type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a -- | Produces the span ops that will render the given picture, possibly @@ -69,21 +89,14 @@ displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r) --- | Returns the DisplayOps for an image rendered to a window the size --- of the image. --- --- largerly used only for debugging. -displayOpsForImage :: Image -> DisplayOps -displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i) - -- | Produces the span ops for each layer then combines them. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0 | otherwise = do - layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic) + layerOps <- mapM (`buildSpans` r) (picLayers pic) case layerOps of - [] -> fail "empty picture" + [] -> error "empty picture" [ops] -> substituteSkips (picBackground pic) ops -- instead of merging ops after generation the merging can -- be performed as part of snocOp. @@ -113,7 +126,7 @@ -- At this point we decide if the background character is single -- column or not. obviously, single column is easier. case safeWcwidth backgroundChar of - w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar + w | w == 0 -> error $ "invalid background character " ++ show backgroundChar | w == 1 -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row @@ -136,8 +149,8 @@ return upper mergeRowUnder :: SpanOps -> SpanOps -> SpanOps -mergeRowUnder upperRowOps lowerRowOps = - onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps +mergeRowUnder upperRowOps = + onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) where -- H: it will never be the case that we are out of upper ops -- before lower ops. @@ -159,7 +172,7 @@ swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f - where f (Skip ow) = let txt = TL.pack $ replicate ow c + where f (Skip ow) = let txt = TL.take (toEnum ow) $ TL.repeat c in TextSpan a ow ow txt f v = v @@ -220,18 +233,18 @@ isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s - | s ^. remainingColumns <= 0 = True - | s ^. remainingRows <= 0 = True + | s ^. remainingColumns <= 0 = True + | s ^. remainingRows <= 0 = True | s ^. skipColumns >= imageWidth i = True | s ^. skipRows >= imageHeight i = True | otherwise = False -- | This adds an image that might be partially clipped to the output -- ops. --- -- This is a very touchy algorithm. Too touchy. For instance, the --- CropRight and CropBottom implementations are odd. They pass the --- current tests but something seems terribly wrong about all this. +-- Crop implementations is odd. They pass the current tests but +-- something seems terribly wrong about all this. +-- addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do @@ -266,23 +279,13 @@ outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows) y <- use rowOffset forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth') -addMaybeClipped CropRight {croppedImage, outputWidth} = do - s <- use skipColumns - r <- use remainingColumns - let x = outputWidth - s - when (x < r) $ remainingColumns .= x - addMaybeClipped croppedImage -addMaybeClipped CropLeft {croppedImage, leftSkip} = do +addMaybeClipped Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight} = do + sx <- use skipColumns skipColumns += leftSkip - addMaybeClipped croppedImage -addMaybeClipped CropBottom {croppedImage, outputHeight} = do - s <- use skipRows - r <- use remainingRows - let x = outputHeight - s - when (x < r) $ remainingRows .= x - addMaybeClipped croppedImage -addMaybeClipped CropTop {croppedImage, topSkip} = do + modifying remainingColumns (min (outputWidth - sx)) + sy <- use skipRows skipRows += topSkip + modifying remainingRows (min (outputHeight - sy)) addMaybeClipped croppedImage addMaybeClippedJoin :: forall s . String @@ -296,13 +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 | s > size -> put $ state & skip -~ size + 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 -> @@ -311,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 @@ -343,12 +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' - -(-~) :: Num a => ASetter s t a a -> a -> s -> t -l -~ n = over l (subtract n) - -(+~) :: Num a => ASetter s t a a -> a -> s -> t -l +~ n = over l (n +) 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,6 +1,4 @@ -- Copyright Corey O'Connor -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} -- | A picture is translated into a sequences of state changes and -- character spans. The attribute is applied to all following spans, @@ -9,8 +7,23 @@ -- -- A span op sequence will be defined for all rows and columns (and no -- more) of the region provided with the picture to 'spansForPic'. -module Graphics.Vty.Span where +module Graphics.Vty.Span + ( SpanOp(..) + , columnsToCharOffset + , spanOpHasWidth + , SpanOps + , spanOpsAffectedColumns + , splitOpsAt + , dropOps + + , DisplayOps + , displayOpsRows + , displayOpsColumns + , affectedRegion + ) +where + import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) @@ -30,7 +43,7 @@ { textSpanAttr :: !Attr , textSpanOutputWidth :: !Int , textSpanCharWidth :: !Int - , textSpanText :: DisplayText + , textSpanText :: TL.Text } -- | Skips the given number of columns. | Skip !Int @@ -52,7 +65,7 @@ dropOps w = snd . splitOpsAt w splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps) -splitOpsAt inW inOps = splitOpsAt' inW inOps +splitOpsAt = splitOpsAt' where splitOpsAt' 0 ops = (Vector.empty, ops) splitOpsAt' remainingColumns ops = case Vector.head ops of @@ -103,18 +116,18 @@ -- | The number of rows the DisplayOps are defined for. displayOpsRows :: DisplayOps -> Int -displayOpsRows ops = Vector.length ops +displayOpsRows = Vector.length affectedRegion :: DisplayOps -> DisplayRegion affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) -- | The number of columns a SpanOps affects. -spanOpsEffectedColumns :: SpanOps -> Int -spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps +spanOpsAffectedColumns :: SpanOps -> Int +spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps where - spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w - spanOpsEffectedColumns' t (Skip w) = t + w - spanOpsEffectedColumns' t (RowEnd w) = t + w + spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w + spanOpsAffectedColumns' t (Skip w) = t + w + spanOpsAffectedColumns' t (RowEnd w) = t + w -- | The width of a single SpanOp in columns. spanOpHasWidth :: SpanOp -> Maybe (Int, Int) @@ -126,7 +139,6 @@ -- 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,89 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module Verify - ( module Verify - , module Control.Applicative - , module Control.DeepSeq - , module Control.Exception - , module Control.Monad - , module Test.QuickCheck - , module Test.QuickCheck.Modifiers - , module Text.Printf - , succeeded - , failed - , monadicIO - , liftIO - , liftBool - , Test(..) - , Prop.Result(..) - ) -where - -import Control.Exception ( bracket, try, SomeException(..) ) - -import Distribution.TestSuite hiding ( Result(..) ) -import qualified Distribution.TestSuite as TS - -import Test.QuickCheck hiding ( Result(..) ) -import qualified Test.QuickCheck as QC -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Property hiding ( Result(..) ) -import qualified Test.QuickCheck.Property as Prop -import Test.QuickCheck.Monadic ( monadicIO ) - -import Text.Printf - -import qualified Codec.Binary.UTF8.String as UTF8 - -import Control.Applicative hiding ( (<|>) ) -import Control.DeepSeq -import Control.Monad ( forM, mapM, mapM_, forM_ ) -import Control.Monad.State.Strict - -import Numeric ( showHex ) - -verify :: Testable t => String -> t -> Test -verify testName p = Test $ TestInstance - { name = testName - , run = do - qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p - case qcResult of - QC.Success {..} -> return $ Finished TS.Pass - QC.Failure {numShrinks,reason} -> return $ Finished - $ TS.Fail $ "After " - ++ show numShrinks ++ " shrinks determined failure to be: " - ++ show reason - _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message" - , tags = [] - , options = [] - , setOption = \_ _ -> Left "no options supported" - } - -data SingleColumnChar = SingleColumnChar Char - deriving (Show, Eq) - -instance Arbitrary SingleColumnChar where - arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E] - -data DoubleColumnChar = DoubleColumnChar Char - deriving (Eq) - -instance Show DoubleColumnChar where - show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c] - -instance Arbitrary DoubleColumnChar where - arbitrary = elements $ map DoubleColumnChar $ - [ toEnum 0x3040 .. toEnum 0x3098 ] - ++ [ toEnum 0x309B .. toEnum 0xA4CF ] - -liftIOResult :: Testable prop => IO prop -> Property -liftIOResult = ioProperty - -data Bench where - Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench 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,59 +0,0 @@ -module Verify.Graphics.Vty.Output where - -import Control.Applicative ((<$>)) - -import Graphics.Vty.Output.Mock - -import Data.IORef -import qualified Data.String.UTF8 as UTF8 - -import Test.QuickCheck.Property - --- A list of terminals that should be supported. This started with a --- list of terminals ubuntu supported. Then those terminals that really --- could not be supported were removed. Then a few more were pruned --- until a reasonable looking set was made. -terminalsOfInterest :: [String] -terminalsOfInterest = - [ "vt100" - , "vt220" - , "vt102" - , "xterm-r5" - , "xterm-xfree86" - , "xterm-r6" - , "xterm-256color" - , "xterm-vt220" - , "xterm-debian" - , "xterm-mono" - , "xterm-color" - , "xterm" - , "mach" - , "mach-bold" - , "mach-color" - , "linux" - , "ansi" - , "hurd" - , "Eterm" - , "pcansi" - , "screen-256color" - , "screen-bce" - , "screen-s" - , "screen-w" - , "screen" - , "screen-256color-bce" - , "sun" - , "rxvt" - , "rxvt-unicode" - , "rxvt-basic" - , "cygwin" - ] - -compareMockOutput :: MockData -> String -> IO Result -compareMockOutput mockData expectedStr = do - outStr <- UTF8.toString <$> readIORef mockData - if outStr /= expectedStr - then return $ failed { reason = "bytes\n" ++ outStr - ++ "\nare not the expected bytes\n" - ++ expectedStr - } - else return succeeded 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,24 +0,0 @@ -module Verify.Graphics.Vty.Prelude - ( module Verify.Graphics.Vty.Prelude - , MockWindow(..) - ) -where - -import Graphics.Vty.Debug - -import Verify - -data EmptyWindow = EmptyWindow MockWindow - -instance Arbitrary EmptyWindow where - arbitrary = return $ EmptyWindow (MockWindow (0 :: Int) (0 :: Int)) - -instance Show EmptyWindow where - show (EmptyWindow _) = "EmptyWindow" - -instance Arbitrary MockWindow where - arbitrary = do - w <- choose (1,1024) - h <- choose (1,1024) - return $ MockWindow w h - 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.String.QQ -import qualified Data.ByteString.Char8 as B - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -exampleConfig :: B.ByteString -exampleConfig = B.pack [s| --- comments should be ignored. -map _ "\ESC[B" KUp [] -askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored -map _ "\ESC[1;3B" KDown [MAlt] -map "xterm" "\ESC[1;3B" KDown [MAlt] -map "xterm-256-color" "\ESC[1;3B" KDown [MAlt] -debugLog "/tmp/vty-debug.txt" -|] - -exampleConfigConfig :: Config -exampleConfigConfig = defaultConfig - { debugLog = Just "/tmp/vty-debug.txt" - , inputMap = [ (Nothing, "\ESC[B", EvKey KUp []) - , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt]) - , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt]) - , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt]) - ] - } - -exampleConfigParses :: IO () -exampleConfigParses = - assertEqual "example config parses as expected" - exampleConfigConfig - (runParseConfig "exampleConfig" exampleConfig) - -main :: IO () -main = defaultMain - [ testCase "example config parses" $ exampleConfigParses - ] diff --git a/test/VerifyCropSpanGeneration.hs b/test/VerifyCropSpanGeneration.hs deleted file mode 100644 --- a/test/VerifyCropSpanGeneration.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyCropSpanGeneration where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Span - -import Graphics.Vty.Debug -import Graphics.Vty.PictureToSpans - -import Verify - -import qualified Data.Vector as Vector - -cropOpDisplayOps :: (Int -> Image -> Image) -> - Int -> Image -> (DisplayOps, Image) -cropOpDisplayOps cropOp v i = - let iOut = cropOp v i - p = picForImage iOut - w = MockWindow (imageWidth iOut) (imageHeight iOut) - in (displayOpsForPic p (regionForWindow w), iOut) - -widthCropOutputColumns :: (Int -> Image -> Image) -> - SingleAttrSingleSpanStack -> - NonNegative Int -> - Property -widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==> - let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s) - in verifyAllSpansHaveWidth iOut ops w - -heightCropOutputColumns :: (Int -> Image -> Image) -> - SingleAttrSingleSpanStack -> - NonNegative Int -> - Property -heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==> - let (ops, _) = cropOpDisplayOps cropOp h (stackImage s) - in displayOpsRows ops == h - -cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropRightOutputColumns = widthCropOutputColumns cropRight - -cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropLeftOutputColumns = widthCropOutputColumns cropLeft - -cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropTopOutputRows = heightCropOutputColumns cropTop - -cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property -cropBottomOutputRows = heightCropOutputColumns cropBottom - --- TODO: known benign failure. -cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property -cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==> - let i = stackImage stack - -- the right part is made by cropping the image from the left. - iR = cropLeft (imageWidth i `div` 2) i - -- the left part is made by cropping the image from the right - iL = cropRight (imageWidth i `div` 2) i - iAlt = iL <|> iR - iOps = displayOpsForImage i - iAltOps = displayOpsForImage iAlt - in verifyOpsEquality iOps iAltOps - -cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property -cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==> - let i = stackImage stack - -- the top part is made by cropping the image from the bottom. - iT = cropBottom (imageHeight i `div` 2) i - -- the bottom part is made by cropping the image from the top. - iB = cropTop (imageHeight i `div` 2) i - iAlt = iT <-> iB - in displayOpsForImage i == displayOpsForImage iAlt - -tests :: IO [Test] -tests = return - [ verify "cropping from the bottom produces display operations covering the expected rows" - cropBottomOutputRows - , verify "cropping from the top produces display operations covering the expected rows" - cropTopOutputRows - , verify "cropping from the left produces display operations covering the expected columns" - cropLeftOutputColumns - , verify "cropping from the right produces display operations covering the expected columns" - cropRightOutputColumns - -- TODO: known benign failure. - -- , verify "the output of a stack is the same as that stack cropped left & right and joined together" - -- cropRightAndLeftRejoinedEquivalence - , verify "the output of a stack is the same as that stack cropped top & bottom and joined together" - cropTopAndBottomRejoinedEquivalence - ] 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.Image ( 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,91 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyEvalTerminfoCaps where - -import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound) -import Data.Terminfo.Eval -import Data.Terminfo.Parse -import Control.DeepSeq - -import qualified System.Console.Terminfo as Terminfo - -import Verify -import Verify.Graphics.Vty.Output - -import Control.Applicative ( (<$>) ) -import Control.Exception ( try, SomeException(..) ) - -import Control.Monad ( mapM_, forM, forM_ ) - -import Data.Maybe ( fromJust ) -import Data.Word - -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, minusPtr) -import Numeric - --- If a terminal defines one of the caps then it's expected to be --- parsable. -capsOfInterest = - [ "cup" - , "sc" - , "rc" - , "setf" - , "setb" - , "setaf" - , "setab" - , "op" - , "cnorm" - , "civis" - , "smcup" - , "rmcup" - , "clear" - , "hpa" - , "vpa" - , "sgr" - , "sgr0" - ] - -fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) - -tests :: IO [Test] -tests = do - -- 1 MB should be big enough for any termcaps ;-) - evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) - fmap concat $ forM terminalsOfInterest $ \termName -> do - putStrLn $ "adding tests for terminal: " ++ termName - mti <- try $ Terminfo.setupTerm termName - case mti of - Left (_e :: SomeException) - -> return [] - Right ti -> do - fmap concat $ forM capsOfInterest $ \capName -> do - case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Just capDef -> do - putStrLn $ "\tadding test for cap: " ++ capName - let testName = termName ++ "(" ++ capName ++ ")" - case parseCapExpression capDef of - Left error -> return [verify testName (failed {reason = "parse error " ++ show error})] - Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)] - Nothing -> do - return [] - -{-# NOINLINE verifyEvalCap #-} -verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property -verifyEvalCap evalBuffer expr !junkInt = do - forAll (vector 9) $ \inputValues -> - let write = writeCapExpr expr inputValues - !byteCount = getBound write - in liftIOResult $ do - let startPtr :: Ptr Word8 = evalBuffer - forM_ [0..100] $ \i -> runWrite write startPtr - endPtr <- runWrite write startPtr - case endPtr `minusPtr` startPtr of - count | count < 0 -> - return $ failed { reason = "End pointer before start pointer." } - | toEnum count > byteCount -> - return $ failed { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byteCount) - } - | otherwise -> - return succeeded diff --git a/test/VerifyImageOps.hs b/test/VerifyImageOps.hs deleted file mode 100644 --- a/test/VerifyImageOps.hs +++ /dev/null @@ -1,173 +0,0 @@ -module VerifyImageOps where - -import Graphics.Vty.Attributes -import Graphics.Vty.Image.Internal -import Verify.Graphics.Vty.Image - -import Verify - -import Control.DeepSeq - -twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool -twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) = - imageWidth (char defAttr c1 <|> char defAttr c2) == 2 - -manySwHorizConcat :: [SingleColumnChar] -> Bool -manySwHorizConcat cs = - let chars = [ char | SingleColumnChar char <- cs ] - l = fromIntegral $ length cs - in imageWidth ( horizCat $ map (char defAttr) chars ) == l - -twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool -twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) = - imageHeight (char defAttr c1 <-> char defAttr c2) == 2 - -horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool -horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = - (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 - == - char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) - -twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool -twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = - imageWidth (char defAttr c1 <|> char defAttr c2) == 4 - -manyDwHorizConcat :: [DoubleColumnChar] -> Bool -manyDwHorizConcat cs = - let chars = [ char | DoubleColumnChar char <- cs ] - l = fromIntegral $ length cs - in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2 - -twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool -twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = - imageHeight (char defAttr c1 <-> char defAttr c2) == 2 - -horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool -horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = - (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 - == - char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) - -vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool -vertContatSingleRow (NonEmpty stack) = - let expectedHeight :: Int = length stack - stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ] - in imageHeight stackImage == expectedHeight - -disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) = - let expectedHeight :: Int = max (length stack0) (length stack1) - stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - in imageHeight (stackImage0 <|> stackImage1) == expectedHeight - - -disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = - let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - image = stackImage0 <|> stackImage1 - expectedHeight = imageHeight image - in case image of - HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) ) - && - ( expectedHeight == (imageHeight $ partRight image) ) - _ -> True - -disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) = - let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) - stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - stack0Image = vertCat stack0Images - stack1Image = vertCat stack1Images - image = stack0Image <-> stack1Image - in imageWidth image == expectedWidth - -disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage - -> NonEmptyList SingleRowSingleAttrImage - -> Bool -disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = - let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) - stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] - stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] - stack0Image = vertCat stack0Images - stack1Image = vertCat stack1Images - image = stack0Image <-> stack1Image - in case image of - VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) ) - && - ( expectedWidth == (imageWidth $ partBottom image) ) - _ -> True - -translationIsLinearOnOutSize :: Translation -> Bool -translationIsLinearOnOutSize (Translation i (x,y) i') = - imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y - -paddingIsLinearOnOutSize :: Image -> Gen Bool -paddingIsLinearOnOutSize i = do - l <- offset - t <- offset - r <- offset - b <- offset - let i' = pad l t r b i - return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b - where offset = choose (1,1024) - -cropLeftLimitsWidth :: Image -> Int -> Property -cropLeftLimitsWidth i v = v >= 0 ==> - v >= imageWidth (cropLeft v i) - -cropRightLimitsWidth :: Image -> Int -> Property -cropRightLimitsWidth i v = v >= 0 ==> - v >= imageWidth (cropRight v i) - -cropTopLimitsHeight :: Image -> Int -> Property -cropTopLimitsHeight i v = v >= 0 ==> - v >= imageHeight (cropTop v i) - -cropBottomLimitsHeight :: Image -> Int -> Property -cropBottomLimitsHeight i v = v >= 0 ==> - v >= imageHeight (cropBottom v i) - --- rediculous tests just to satisfy my desire for nice code coverage :-P -canShowImage :: Image -> Bool -canShowImage i = length (show i) > 0 - -canRnfImage :: Image -> Bool -canRnfImage i = rnf i == () - -canPpImage :: Image -> Bool -canPpImage i = length (ppImageStructure i) > 0 - -tests :: IO [Test] -tests = return - [ verify "twoSwHorizConcat" twoSwHorizConcat - , verify "manySwHorizConcat" manySwHorizConcat - , verify "twoSwVertConcat" twoSwVertConcat - , verify "horizConcatSwAssoc" horizConcatSwAssoc - , verify "manyDwHorizConcat" manyDwHorizConcat - , verify "twoDwHorizConcat" twoDwHorizConcat - , verify "twoDwVertConcat" twoDwVertConcat - , verify "horizConcatDwAssoc" horizConcatDwAssoc - , verify "single row vert concats to correct height" vertContatSingleRow - , verify "disjointHeightHorizJoin" disjointHeightHorizJoin - , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill - , verify "disjointWidthVertJoin" disjointWidthVertJoin - , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill - , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize - , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize - , verify "crop left limits width" cropLeftLimitsWidth - , verify "crop right limits width" cropRightLimitsWidth - , verify "crop top limits height" cropTopLimitsHeight - , verify "crop bottom limits height" cropBottomLimitsHeight - , verify "can show image" canShowImage - , verify "can rnf image" canRnfImage - , verify "can pp image" canPpImage - ] 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,130 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyLayersSpanGeneration where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Attributes -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Span - -import Graphics.Vty.Debug -import Graphics.Vty.PictureToSpans - -import Verify - -import qualified Data.Vector as Vector - -largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -largerHorizSpanOcclusion row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0) - expectedOps = displayOpsForImage iLarger - p = picForLayers [iLarger, iSmaller] - ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger) - in verifyOpsEquality expectedOps ops - --- | Two rows stacked vertical is equivalent to the first row rendered --- as the top layer and the second row rendered as a bottom layer with a --- background fill where the first row would be. -vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -vertStackLayerEquivalence0 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <-> i1 - p = picForImage i - iLower = backgroundFill (imageWidth i0) 1 <-> i1 - pLayered = picForLayers [i0, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - -vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -vertStackLayerEquivalence1 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <-> i1 - p = picForImage i - iLower = i0 <-> backgroundFill (imageWidth i1) 1 - iUpper = backgroundFill (imageWidth i0) 1 <-> i1 - pLayered = picForLayers [iUpper, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - --- | Two rows horiz joined is equivalent to the first row rendered as --- the top layer and the second row rendered as a bottom layer with a --- background fill where the first row would be. -horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -horizJoinLayerEquivalence0 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <|> i1 - p = picForImage i - iLower = backgroundFill (imageWidth i0) 1 <|> i1 - pLayered = picForLayers [i0, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - -horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result -horizJoinLayerEquivalence1 row0 row1 = - let i0 = rowImage row0 - i1 = rowImage row1 - i = i0 <|> i1 - p = picForImage i - iLower = i0 <|> backgroundFill (imageWidth i1) 1 - iUpper = backgroundFill (imageWidth i0) 1 <|> i1 - pLayered = picForLayers [iUpper, iLower] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) - in verifyOpsEquality expectedOps opsLayered - -horizJoinAlternate0 :: Result -horizJoinAlternate0 = - let size = 4 - str0 = replicate size 'a' - str1 = replicate size 'b' - i0 = string defAttr str0 - i1 = string defAttr str1 - i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1) - layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1 - layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1 - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic (picForLayers [layer0, layer1]) - (imageWidth i,imageHeight i) - in verifyOpsEquality expectedOps opsLayered - -horizJoinAlternate1 :: Result -horizJoinAlternate1 = - let size = 4 - str0 = replicate size 'a' - str1 = replicate size 'b' - i0 = string defAttr str0 - i1 = string defAttr str1 - i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1) - layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1] - expectedOps = displayOpsForImage i - opsLayered = displayOpsForPic (picForLayers layers) - (imageWidth i,imageHeight i) - in verifyOpsEquality expectedOps opsLayered - -tests :: IO [Test] -tests = return - [ verify "a larger horiz span occludes a smaller span on a lower layer" - largerHorizSpanOcclusion - , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)" - vertStackLayerEquivalence0 - , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)" - vertStackLayerEquivalence1 - -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)" - -- horizJoinLayerEquivalence0 - -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)" - -- horizJoinLayerEquivalence1 - -- , verify "alternating images using joins is the same as alternating images using layers (0)" - -- horizJoinAlternate0 - -- , verify "alternating images using joins is the same as alternating images using layers (1)" - -- horizJoinAlternate1 - ] diff --git a/test/VerifyOutput.hs b/test/VerifyOutput.hs deleted file mode 100644 --- a/test/VerifyOutput.hs +++ /dev/null @@ -1,54 +0,0 @@ --- We setup the environment to envoke certain terminals of interest. --- This assumes appropriate definitions exist in the current environment --- for the terminals of interest. -module VerifyOutput where - -import Verify - -import Graphics.Vty - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Output - -import Control.Monad - -import qualified System.Console.Terminfo as Terminfo -import System.Posix.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 $ defaultConfig { outputFd = Just nullOut, termName = Just termName } - -- putStrLn $ "context color count: " ++ show (contextColorCount t) - reserveDisplay t - dc <- displayContext t (100,100) - -- always show the cursor to produce tests for terminals with no - -- cursor support. - let pic = (picForImage i) { picCursor = Cursor 0 0 } - outputPicture dc pic - setCursorPos t 0 0 - when (supportsCursorVisibility t) $ do - hideCursor t - showCursor t - releaseDisplay t - releaseTerminal t - closeFd nullOut - return succeeded - diff --git a/test/VerifyParseTerminfoCaps.hs b/test/VerifyParseTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyParseTerminfoCaps.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module VerifyParseTerminfoCaps where - -import Prelude hiding ( catch ) - -import qualified System.Console.Terminfo as Terminfo - -import Verify.Data.Terminfo.Parse -import Verify.Graphics.Vty.Output -import Verify - -import Data.Maybe ( catMaybes, fromJust ) -import Data.Word - -import Numeric - --- If a terminal defines one of the caps then it's expected to be parsable. --- TODO: reduce duplication with terminfo terminal implementation. -capsOfInterest = - [ "cup" - , "sc" - , "rc" - , "setf" - , "setb" - , "setaf" - , "setab" - , "op" - , "cnorm" - , "civis" - , "smcup" - , "rmcup" - , "clear" - , "hpa" - , "vpa" - , "sgr" - , "sgr0" - ] - -fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) - -tests :: IO [Test] -tests = do - parseTests <- concat <$> forM terminalsOfInterest (\termName -> - liftIO (try $ Terminfo.setupTerm termName) - >>= either (\(_e :: SomeException) -> return []) - (\ti -> concat <$> forM capsOfInterest (\capName -> do - let caseName = "\tparsing cap: " ++ capName - liftIO $ putStrLn caseName - return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Just capDef -> [verify (caseName ++ " -> " ++ show capDef) - (verifyParseCap capDef $ const succeeded)] - Nothing -> [] - ) - ) - ) - return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps - , verify "parse cap string with literal %" literalPercentCaps - , verify "parse cap string with %i op" incFirstTwoCaps - , verify "parse cap string with %pN op" pushParamCaps - ] ++ parseTests - -verifyParseCap capString onParse = - case parseCapExpression capString of - Left error -> failed { reason = "parse error " ++ show error } - Right e -> onParse e - -nonParamaterizedCaps (NonParamCapString cap) = do - verifyParseCap cap $ \e -> - let expectedBytes = map (toEnum . fromEnum) cap - outBytes = bytesForRange e 0 (length cap) - in verifyBytesEqual outBytes expectedBytes - -literalPercentCaps (LiteralPercentCap capString expectedBytes) = do - verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes - -incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do - verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes - -pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do - verifyParseCap capString $ \e -> - let outBytes = collectBytes e - outParamCount = paramCount e - in if outParamCount == expectedParamCount - then verifyBytesEqual outBytes expectedBytes - else failed { reason = "out param count /= expected param count" } - -decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do - verifyParseCap capString $ \e -> - let outBytes = collectBytes e - outParamCount = paramCount e - in if outParamCount == expectedParamCount - then verifyBytesEqual outBytes expectedBytes - else failed { reason = "out param count /= expected param count" } - -printCap ti capName = do - putStrLn $ capName ++ ": " ++ show (fromCapname ti capName) - -printExpression ti capName = do - let parseResult = parseCapExpression $ fromCapname ti capName - putStrLn $ capName ++ ": " ++ show parseResult 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,220 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} --- Generate some input bytes and delays between blocks of input bytes. --- Verify the events produced are as expected. -module Main where - -import Verify.Graphics.Vty.Output - -import Graphics.Vty hiding (resize) -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Loop -import Graphics.Vty.Input.Terminfo - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Lens.Micro ((^.)) -import Control.Monad - -import Data.IORef -import Data.List (intersperse, reverse, nubBy) - -import System.Console.Terminfo -import System.Posix.IO -import System.Posix.Terminal (openPseudoTerminal) -import System.Posix.Types -import System.Timeout - -import Test.Framework.Providers.SmallCheck -import Test.Framework -import Test.SmallCheck -import Test.SmallCheck.Series - -import Text.Printf - --- processing a block of 16 chars is the largest I can do without taking --- too long to run the test. -maxBlockSize :: Int -maxBlockSize = 16 - -maxTableSize :: Int -maxTableSize = 28 - -forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m -forEachOf l = over (generate (\n -> take n l)) - -data InputEvent - = Bytes String - -- ^ Input sequence encoded as a string. Regardless, the input is - -- read a byte at a time. - | Delay Int - -- ^ Microsecond delay - deriving Show - -type InputSpec = [InputEvent] - -type ExpectedSpec = [Event] - -synthesizeInput :: InputSpec -> Fd -> IO () -synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD") - where - f (Bytes str) = void $ fdWrite outHandle str - f (Delay t) = threadDelay t - -minDetectableDelay :: Int -minDetectableDelay = 4000 - -minTimout :: Int -minTimout = 4000000 - -testKeyDelay :: Int -testKeyDelay = minDetectableDelay * 4 - -testEscSampleDelay :: Int -testEscSampleDelay = minDetectableDelay * 2 - -genEventsUsingIoActions :: Int -> IO () -> IO () -> IO () -genEventsUsingIoActions maxDuration inputAction outputAction = do - let maxDuration' = max minTimout maxDuration - readComplete <- newEmptyMVar - writeComplete <- newEmptyMVar - _ <- forkOS $ inputAction `finally` putMVar writeComplete () - _ <- forkOS $ outputAction `finally` putMVar readComplete () - Just () <- timeout maxDuration' $ takeMVar writeComplete - Just () <- timeout maxDuration' $ takeMVar readComplete - return () - -compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool -compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents - where - compareEvents' [] [] = return True - compareEvents' [] outEvents' = do - printf "extra events %s\n" (show outEvents') :: IO () - return False - compareEvents' expectedEvents' [] = do - printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO () - printf "expected events %s\n" (show expectedEvents) :: IO () - printf "received events %s\n" (show outEvents) :: IO () - return False - compareEvents' (e : expectedEvents') (o : outEvents') - | e == o = compareEvents' expectedEvents' outEvents' - | otherwise = do - printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO () - printf "expected events %s\n" (show expectedEvents) :: IO () - printf "received events %s\n" (show outEvents) :: IO () - return False - -assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool -assertEventsFromSynInput table inputSpec expectedEvents = do - let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay - eventCount = length expectedEvents - (writeFd, readFd) <- openPseudoTerminal - (setTermAttr,_) <- attributeControl readFd - setTermAttr - let testConfig = defaultConfig { inputFd = Just readFd - , termName = Just "dummy" - , vmin = Just 1 - , vtime = Just 100 - } - input <- initInput testConfig table - eventsRef <- newIORef [] - let writeWaitClose = do - synthesizeInput inputSpec writeFd - threadDelay minDetectableDelay - shutdownInput input - threadDelay minDetectableDelay - closeFd writeFd - closeFd readFd - -- drain output pipe - let readEvents = readLoop eventCount - readLoop 0 = return () - readLoop n = do - e <- atomically $ readTChan $ input^.eventChannel - modifyIORef eventsRef ((:) e) - readLoop (n - 1) - genEventsUsingIoActions maxDuration writeWaitClose readEvents - outEvents <- reverse <$> readIORef eventsRef - compareEvents inputSpec expectedEvents outEvents - -newtype InputBlocksUsingTable event - = InputBlocksUsingTable ([(String,event)] -> [(String, event)]) - -instance Show (InputBlocksUsingTable event) where - show (InputBlocksUsingTable _g) = "InputBlocksUsingTable" - -instance Monad m => Serial m (InputBlocksUsingTable event) where - series = do - n :: Int <- localDepth (const maxTableSize) series - return $ InputBlocksUsingTable $ \raw_table -> - let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table - in concat (take n (selections table)) - where - selections [] = [] - selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z) - -verifyVisibleSynInputToEvent :: Property IO -verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do - let table = visibleChars - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput universalTable input events - -verifyCapsSynInputToEvent :: Property IO -verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \terminalName -> monadic $ do - term <- setupTerm terminalName - let table = capsClassifyMap term keysFromCapsTable - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput table input events - -verifySpecialSynInputToEvent :: Property IO -verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do - let table = specialSupportKeys - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput universalTable input events - -verifyFullSynInputToEvent :: Property IO -verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \terminalName -> monadic $ do - term <- setupTerm terminalName - let table = classifyMapForTerm terminalName term - inputSeq = gen table - events = map snd inputSeq - keydowns = map (Bytes . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput table input events - -verifyFullSynInputToEvent_2x :: Property IO -verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) -> - forEachOf terminalsOfInterest $ \terminalName -> monadic $ do - term <- setupTerm terminalName - let table = classifyMapForTerm terminalName term - inputSeq = gen table - events = concatMap ((\s -> [s,s]) . snd) inputSeq - keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq - input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] - assertEventsFromSynInput table input events - -main :: IO () -main = defaultMain - [ testProperty "synthesized typing of single visible chars translates to expected events" - verifyVisibleSynInputToEvent - , testProperty "synthesized typing of keys from capabilities tables translates to expected events" - verifyCapsSynInputToEvent - , testProperty "synthesized typing of hard coded special keys translates to expected events" - verifySpecialSynInputToEvent - , testProperty "synthesized typing of any key in the table translates to its paired event" - verifyFullSynInputToEvent - , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event" - verifyFullSynInputToEvent_2x - ] - diff --git a/test/VerifyUsingMockTerminal.hs b/test/VerifyUsingMockTerminal.hs deleted file mode 100644 --- a/test/VerifyUsingMockTerminal.hs +++ /dev/null @@ -1,108 +0,0 @@ -module VerifyUsingMockTerminal where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Attributes -import Verify.Graphics.Vty.Span -import Verify.Graphics.Vty.Output -import Graphics.Vty.Output -import Graphics.Vty.Output.Interface -import Graphics.Vty.Output.Mock - -import Graphics.Vty.Debug - -import Verify - -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.String.UTF8 as UTF8 - -import System.IO - -unitImageUnitBounds :: UnitImage -> Property -unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do - (_,t) <- mockTerminal (1,1) - dc <- displayBounds t >>= displayContext t - let pic = picForImage i - outputPicture dc pic - return succeeded - -unitImageArbBounds :: UnitImage -> MockWindow -> Property -unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do - (_,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - let pic = picForImage i - outputPicture dc pic - return succeeded - -singleTRow :: MockWindow -> Property -singleTRow (MockWindow w h) = liftIOResult $ do - (mockData,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains just the character T repeated for a - -- single row - let i = horizCat $ replicate (fromEnum w) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The mock output string that represents the output bytes a single - -- line containing the T string: Followed by h - 1 lines of a change - -- to the background attribute and then the background character - let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T' - ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B') - compareMockOutput mockData expected - -manyTRows :: MockWindow -> Property -manyTRows (MockWindow w h) = liftIOResult $ do - (mockData, t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all - -- the rows - let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of - -- a move, 'M', followed by an attribute change. 'A', followed by w - -- 'T's - let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') - compareMockOutput mockData expected - -manyTRowsCroppedWidth :: MockWindow -> Property -manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do - (mockData,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all - -- the rows - let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of - -- a move, 'M', followed by an attribute change. 'A', followed by w - -- 'T's - let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') - compareMockOutput mockData expected - -manyTRowsCroppedHeight :: MockWindow -> Property -manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do - (mockData,t) <- mockTerminal (w,h) - dc <- displayBounds t >>= displayContext t - -- create an image that contains the character 'T' repeated for all - -- the rows - let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') - pic = (picForImage i) { picBackground = Background 'B' defAttr } - outputPicture dc pic - -- The UTF8 string that represents the output bytes is h repeats of - -- a move, 'M', followed by an attribute change. 'A', followed by w - -- count 'T's - let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') - compareMockOutput mockData expected - -tests :: IO [Test] -tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds - , verify "unitImageArbBounds" unitImageArbBounds - , verify "singleTRow" singleTRow - , verify "manyTRows" manyTRows - , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth - , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight - ] diff --git a/test/VerifyUtf8Width.hs b/test/VerifyUtf8Width.hs deleted file mode 100644 --- a/test/VerifyUtf8Width.hs +++ /dev/null @@ -1,30 +0,0 @@ -module VerifyUtf8Width where - -import Verify - -import Graphics.Text.Width -import Graphics.Vty.Attributes -import Graphics.Vty.Picture -import Graphics.Vty.Image - -swIs1Column :: SingleColumnChar -> Bool -swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1 - -dwIs2Column :: DoubleColumnChar -> Bool -dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2 - -dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool -dcStringIsEven (NonEmpty dw_list) = - even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ] - -safeWcwidthForControlChars :: Bool -safeWcwidthForControlChars = 0 == safeWcwidth '\NUL' - -tests :: IO [Test] -tests = return - [ verify "swIs1Column" swIs1Column - , verify "dwIs2Column" dwIs2Column - , verify "a string of double characters is an even width" dcStringIsEven - , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars - ] - diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,5 +1,5 @@ name: vty -version: 5.23 +version: 6.6 license: BSD3 license-file: LICENSE author: AUTHORS @@ -9,28 +9,25 @@ synopsis: A simple terminal UI library description: vty is terminal GUI library in the niche of ncurses. It is intended to - be easy to use, have no confusing corner cases, and good support for - common terminal types. - . - See the @vty-examples@ package as well as the program - @test/interactive_terminal_test.hs@ included in the @vty@ package for - examples on how to use the library. + be easy to use and to provide good support for common terminal types. . - Import the "Graphics.Vty" convenience module to get access to the core - parts of the library. + See the example programs in the @vty-crossplatform@ package examples + on how to use the library. . © 2006-2007 Stefan O'Rear; BSD3 license. . © Corey O'Connor; BSD3 license. . © Jonathan Daugherty; BSD3 license. -cabal-version: >= 1.18 +cabal-version: 1.18 build-type: Simple extra-doc-files: README.md, AUTHORS, 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 @@ -38,590 +35,52 @@ library default-language: Haskell2010 + include-dirs: cbits + hs-source-dirs: src + ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10 + ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 build-depends: base >= 4.8 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, - containers, - deepseq >= 1.1 && < 1.5, - directory, - filepath >= 1.0 && < 2.0, - microlens, + deepseq >= 1.1 && < 1.6, + microlens < 0.6, microlens-mtl, - microlens-th, - -- required for nice installation with yi - hashable >= 1.2, - mtl >= 1.1.1.0 && < 2.3, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, + mtl >= 1.1.1.0 && < 2.4, stm, - terminfo >= 0.3 && < 0.5, - transformers >= 0.3.0.0, text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 + utf8-string >= 0.3.1 && < 1.1, + vector >= 0.7, + binary, + parsec, + filepath, + directory if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.16 + build-depends: semigroups >= 0.16, + fail - exposed-modules: Graphics.Vty + exposed-modules: Graphics.Text.Width + Graphics.Vty Graphics.Vty.Attributes + Graphics.Vty.Attributes.Color + Graphics.Vty.Attributes.Color240 Graphics.Vty.Config + Graphics.Vty.Debug + Graphics.Vty.DisplayAttributes Graphics.Vty.Error Graphics.Vty.Image + Graphics.Vty.Image.Internal Graphics.Vty.Inline - Graphics.Vty.Inline.Unsafe Graphics.Vty.Input Graphics.Vty.Input.Events - Graphics.Vty.Picture Graphics.Vty.Output - Graphics.Text.Width - -- 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.Classify.Types - Graphics.Vty.Input.Classify.Parse - Graphics.Vty.Input.Loop - Graphics.Vty.Input.Mouse - Graphics.Vty.Input.Focus - Graphics.Vty.Input.Paste - Graphics.Vty.Input.Terminfo + Graphics.Vty.Output.Mock + Graphics.Vty.Picture Graphics.Vty.PictureToSpans Graphics.Vty.Span - Graphics.Vty.Output.Mock - Graphics.Vty.Output.Interface - Graphics.Vty.Output.XTermColor - Graphics.Vty.Output.TerminfoBased - - 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 -Wall -fspec-constr -fspec-constr-count=10 - - ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 - - cc-options: -O2 - -executable vty-mode-demo - main-is: ModeDemo.hs - hs-source-dirs: demos - - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - ghc-options: -threaded - - build-depends: vty, - base >= 4.8 && < 5, - containers, - microlens, - microlens-mtl, - mtl >= 1.1.1.0 && < 2.3 - -executable vty-demo - main-is: Demo.hs - hs-source-dirs: demos - - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - ghc-options: -threaded - - build-depends: vty, - base >= 4.8 && < 5, - containers, - microlens, - microlens-mtl, - mtl >= 1.1.1.0 && < 2.3 - -test-suite verify-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.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-using-mock-terminal - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyUsingMockTerminal - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - terminfo >= 0.3 && < 0.5, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-terminal - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyOutput - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-display-attributes - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyDisplayAttributes - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.DisplayAttributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-empty-image-props - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyEmptyImageProps - - other-modules: Verify - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-eval-terminfo-caps - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyEvalTerminfoCaps - - other-modules: Verify - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - blaze-builder >= 0.3.3.2 && < 0.5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-image-ops - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyImageOps - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Image - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-image-trans - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyImageTrans - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Image - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-inline - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyInline - - other-modules: Verify - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-parse-terminfo-caps - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyParseTerminfoCaps - - other-modules: Verify - Verify.Data.Terminfo.Parse - Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-simple-span-generation - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifySimpleSpanGeneration - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - -test-suite verify-crop-span-generation - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyCropSpanGeneration - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - -test-suite verify-layers-span-generation - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyLayersSpanGeneration - - other-modules: Verify - Verify.Graphics.Vty.Attributes - Verify.Graphics.Vty.Prelude - Verify.Graphics.Vty.Picture - Verify.Graphics.Vty.Image - Verify.Graphics.Vty.Span - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-utf8-width - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyUtf8Width - - other-modules: Verify - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - -test-suite verify-using-mock-input - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: exitcode-stdio-1.0 - - hs-source-dirs: test - - main-is: VerifyUsingMockInput.hs - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - smallcheck == 1.*, - quickcheck-assertions >= 0.1.1, - test-framework == 0.8.*, - test-framework-smallcheck == 0.2.*, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - microlens, - microlens-mtl, - mtl >= 1.1.1.0 && < 2.3, - stm, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - ghc-options: -threaded -Wall - -test-suite verify-config - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: exitcode-stdio-1.0 - - hs-source-dirs: test - - main-is: VerifyConfig.hs - - build-depends: vty, - Cabal >= 1.20, - HUnit, - QuickCheck >= 2.7, - smallcheck == 1.*, - quickcheck-assertions >= 0.1.1, - test-framework == 0.8.*, - test-framework-smallcheck == 0.2.*, - test-framework-hunit, - random >= 1.0 && < 1.2, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - microlens, - microlens-mtl, - mtl >= 1.1.1.0 && < 2.3, - string-qq, - terminfo >= 0.3 && < 0.5, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - ghc-options: -threaded -Wall + Graphics.Vty.UnicodeWidthTable.IO + Graphics.Vty.UnicodeWidthTable.Install + Graphics.Vty.UnicodeWidthTable.Main + Graphics.Vty.UnicodeWidthTable.Query + Graphics.Vty.UnicodeWidthTable.Types + c-sources: cbits/mk_wcwidth.c