vty-5.28.2/0000755000000000000000000000000007346545000010623 5ustar0000000000000000vty-5.28.2/AUTHORS0000644000000000000000000000075407346545000011701 0ustar0000000000000000The following people should be thanked for contributing to the vty library: * Andrea Vezzosi * Corey O'Connor * Emily Backes * Josef Svenningsson * Nicolas Pouillard * Roman Cheplyaka * Stefan O'Rear * Yusaku Hashimoto * allan.clark * gwern0 * jeanphilippe.bernardy * m.niloc * mikesteele81 * Mikolaj Konarski * Eyal Lotem * Yoshikuni Jujo * Dmitry Ivanov Plus others.. Check the git log and CHANGELOG.md for a full list. vty-5.28.2/CHANGELOG.md0000644000000000000000000005740307346545000012445 0ustar0000000000000000 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 vty-5.28.2/LICENSE0000644000000000000000000000303207346545000011626 0ustar0000000000000000Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Stefan O'Rear nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vty-5.28.2/README.md0000644000000000000000000001710207346545000012103 0ustar0000000000000000[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty) `vty` is a terminal interface library. It provides a high-level interface for doing terminal I/O. Vty is supported on GHC versions 7.10.1 and up. Install via `git` with: ``` git clone git://github.com/jtdaugherty/vty.git ``` Install via `cabal` with: ``` cabal install vty ``` # Features * Supports a large number of terminals, i.e., vt100, ansi, hurd, linux, `screen`, etc., or anything with a sufficient terminfo entry. * Automatically handles window resizes. * Supports Unicode output on terminals with UTF-8 support. * Provides an efficient output algorithm. Output buffering and terminal state changes are minimized. * Minimizes repaint area, which virtually eliminates the flicker problems that plague ncurses programs. * Provides a pure, compositional interface for efficiently constructing display images. * Automatically decodes keyboard keys into (key,[modifier]) tuples. * Automatically supports refresh on Ctrl-L. * Supports a keypress timeout after for lone ESC. The timeout is customizable. * Provides extensible input and output interfaces. * 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. * Properly handles cleanup (but not due to signals). * Provides a comprehensive test suite. * Supports "normal" and "extended" (SGR) mouse modes as described at http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking * Supports bracketed paste mode as described at http://cirw.in/blog/bracketed-paste * Supports multi-column Unicode characters such as emoji characters. In cases where Vty and your terminal emulator disagree on character widths, Vty provides a tool `vty-build-width-table` and library functionality to build a width table that will work for your terminal and load it on application startup. # Development Notes Vty uses threads internally, so programs made with Vty need to be compiled with the threaded runtime using the GHC `-threaded` option. # Platform Support ## Posix Terminals For the most part, Vty uses `terminfo` to determine terminal protocol with some special rules to handle some omissions from `terminfo`. ## Windows Windows is not supported. # Multi-Column Character Support Vty supports rendering of multi-column characters such as two-column Asian characters and Emoji characters. This section details how to take advantage of this feature, since its behavior will depend on the terminal emulator in use. Terminal emulators support Unicode to varying degrees, and each terminal emulator relies on a table of column widths for each supported Unicode character. Vty also needs to rely on such a table to compute the width of Vty images to do image layout. Since those tables can disagree if Vty and the terminal emulator support different versions of Unicode, and since different terminal emulators will support different versions of Unicode, it's likely that for some wide characters, Vty applications will exhibit rendering problems. Those rendering problems arise from Vty and the terminal emulator coming to different conclusions about how wide some characters are. To address this, Vty supports loading custom character width tables that are based on the terminal's behavior in order to eliminate these disagreements. By default, though, Vty will use its built-in Unicode character width table. Since the built-in table is likely to eventually disagree with your terminal, Vty provides an API and a command-line tool to generate and install custom tables. Custom Unicode width tables based on your terminal emulator can be built by running Vty's built-in tool, `vty-build-width-table`. The tool works by querying the current terminal emulator to obtain its width measurements for the entire supported Unicode range. The results are then saved to a disk file. These custom tables can also be generated programmatically by using the API in `Graphics.Vty.UnicodeWidthTable.Query`. 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. Without using a custom width table, users of Vty-based applications are likely to eventually experience rendering problems with with wide characters. We recommend that developers of Vty-based applications either: * Provide the `vty-build-width-table` tool and documentation for running it and updating the Vty configuration, or * Have the application invoke the Vty library's table-building functionality and load the table at startup without using the Vty configuration. The best option will depend on a number of factors: the user audience, the amount of risk posed by wide character rendering, the terminal emulators in use, etc. # Contributing If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: - 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. # Known Issues * Terminals have numerous quirks and bugs, so mileage may vary. Please report issues as you encounter them and provide details on your terminal emulator, operating system, etc. * STOP, TERM and INT signals are not handled. * 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. * Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which appears to be limited to Linux and BSD. # Further Reading Good sources of documentation for terminal programming are: * https://github.com/b4winckler/vim/blob/master/src/term.c * http://invisible-island.net/xterm/ctlseqs/ctlseqs.html * http://ulisse.elettra.trieste.it/services/doc/serial/config.html * http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html * http://www.unixwiz.net/techtips/termios-vmin-vtime.html * http://vt100.net/docs/vt100-ug/chapter3.html vty-5.28.2/Setup.lhs0000644000000000000000000000011307346545000012426 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMainvty-5.28.2/cbits/0000755000000000000000000000000007346545000011727 5ustar0000000000000000vty-5.28.2/cbits/get_tty_erase.c0000644000000000000000000000063407346545000014734 0ustar0000000000000000#include #include #include #include // Given a file descriptor for a terminal, get the ERASE character for // the terminal. If the terminal info cannot be obtained, this returns // zero. char vty_get_tty_erase(int fd) { struct termios trm; if (0 == tcgetattr(fd, &trm)) { return (char) trm.c_cc[VERASE]; } else { return (char) 0; } } vty-5.28.2/cbits/gwinsz.c0000644000000000000000000000030007346545000013405 0ustar0000000000000000#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; } vty-5.28.2/cbits/mk_wcwidth.c0000644000000000000000000003311407346545000014235 0ustar0000000000000000/* * This is an implementation of wcwidth() and wcswidth() (defined in * IEEE Std 1002.1-2001) for Unicode. * * http://www.opengroup.org/onlinepubs/007904975/functions/wcwidth.html * http://www.opengroup.org/onlinepubs/007904975/functions/wcswidth.html * * In fixed-width output devices, Latin characters all occupy a single * "cell" position of equal width, whereas ideographic CJK characters * occupy two such cells. Interoperability between terminal-line * applications and (teletype-style) character terminals using the * UTF-8 encoding requires agreement on which character should advance * the cursor by how many cell positions. No established formal * standards exist at present on which Unicode character shall occupy * how many cell positions on character terminals. These routines are * a first attempt of defining such behavior based on simple rules * applied to data provided by the Unicode Consortium. * * For some graphical characters, the Unicode standard explicitly * defines a character-cell width via the definition of the East Asian * FullWidth (F), Wide (W), Half-width (H), and Narrow (Na) classes. * In all these cases, there is no ambiguity about which width a * terminal shall use. For characters in the East Asian Ambiguous (A) * class, the width choice depends purely on a preference of backward * compatibility with either historic CJK or Western practice. * Choosing single-width for these characters is easy to justify as * the appropriate long-term solution, as the CJK practice of * displaying these characters as double-width comes from historic * implementation simplicity (8-bit encoded characters were displayed * single-width and 16-bit ones double-width, even for Greek, * Cyrillic, etc.) and not any typographic considerations. * * Much less clear is the choice of width for the Not East Asian * (Neutral) class. Existing practice does not dictate a width for any * of these characters. It would nevertheless make sense * typographically to allocate two character cells to characters such * as for instance EM SPACE or VOLUME INTEGRAL, which cannot be * represented adequately with a single-width glyph. The following * routines at present merely assign a single-cell width to all * neutral characters, in the interest of simplicity. This is not * entirely satisfactory and should be reconsidered before * establishing a formal standard in this area. At the moment, the * decision which Not East Asian (Neutral) characters should be * represented by double-width glyphs cannot yet be answered by * applying a simple rule from the Unicode database content. Setting * up a proper standard for the behavior of UTF-8 character terminals * will require a careful analysis not only of each Unicode character, * but also of each presentation form, something the author of these * routines has avoided to do so far. * * http://www.unicode.org/unicode/reports/tr11/ * * Markus Kuhn -- 2007-05-26 (Unicode 5.0) * * Permission to use, copy, modify, and distribute this software * for any purpose and without fee is hereby granted. The author * disclaims all warranties with regard to this software. * * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c */ #include #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; // The size of the custom table, in entries. This should only be set // if custom_table is not NULL. Its value should be the size of the // custom_table array. static uint32_t custom_table_size = 0; // A flag indicating whether the custom table is ready for // use. This should only be set once the table has been // allocated with vty_init_custom_table and initialized with // vty_set_custom_table_range. static uint8_t custom_table_ready = 0; struct interval { int first; int last; }; /* auxiliary function for binary search in interval table */ static int vty_bisearch(HsChar ucs, const struct interval *table, int max) { int min = 0; int mid; if (ucs < table[0].first || ucs > table[max].last) return 0; while (max >= min) { mid = (min + max) / 2; if (ucs > table[mid].last) min = mid + 1; else if (ucs < table[mid].first) max = mid - 1; else return 1; } return 0; } /* The following two functions define the column width of an ISO 10646 * character as follows: * * - The null character (U+0000) has a column width of 0. * * - Other C0/C1 control characters and DEL will lead to a return * value of -1. * * - Non-spacing and enclosing combining characters (general * category code Mn or Me in the Unicode database) have a * column width of 0. * * - SOFT HYPHEN (U+00AD) has a column width of 1. * * - Other format characters (general category code Cf in the Unicode * database) and ZERO WIDTH SPACE (U+200B) have a column width of 0. * * - Hangul Jamo medial vowels and final consonants (U+1160-U+11FF) * have a column width of 0. * * - Spacing characters in the East Asian Wide (W) or East Asian * Full-width (F) category as defined in Unicode Technical * Report #11 have a column width of 2. * * - All remaining characters (including all printable * ISO 8859-1 and WGL4 characters, Unicode control characters, * etc.) have a column width of 1. * * This implementation assumes that wchar_t characters are encoded * in ISO 10646. */ static HsInt builtin_wcwidth(HsChar ucs) { /* sorted list of non-overlapping intervals of non-spacing characters */ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */ static const struct interval combining[] = { { 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 }, { 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 }, { 0x05C4, 0x05C5 }, { 0x05C7, 0x05C7 }, { 0x0600, 0x0603 }, { 0x0610, 0x0615 }, { 0x064B, 0x065E }, { 0x0670, 0x0670 }, { 0x06D6, 0x06E4 }, { 0x06E7, 0x06E8 }, { 0x06EA, 0x06ED }, { 0x070F, 0x070F }, { 0x0711, 0x0711 }, { 0x0730, 0x074A }, { 0x07A6, 0x07B0 }, { 0x07EB, 0x07F3 }, { 0x0901, 0x0902 }, { 0x093C, 0x093C }, { 0x0941, 0x0948 }, { 0x094D, 0x094D }, { 0x0951, 0x0954 }, { 0x0962, 0x0963 }, { 0x0981, 0x0981 }, { 0x09BC, 0x09BC }, { 0x09C1, 0x09C4 }, { 0x09CD, 0x09CD }, { 0x09E2, 0x09E3 }, { 0x0A01, 0x0A02 }, { 0x0A3C, 0x0A3C }, { 0x0A41, 0x0A42 }, { 0x0A47, 0x0A48 }, { 0x0A4B, 0x0A4D }, { 0x0A70, 0x0A71 }, { 0x0A81, 0x0A82 }, { 0x0ABC, 0x0ABC }, { 0x0AC1, 0x0AC5 }, { 0x0AC7, 0x0AC8 }, { 0x0ACD, 0x0ACD }, { 0x0AE2, 0x0AE3 }, { 0x0B01, 0x0B01 }, { 0x0B3C, 0x0B3C }, { 0x0B3F, 0x0B3F }, { 0x0B41, 0x0B43 }, { 0x0B4D, 0x0B4D }, { 0x0B56, 0x0B56 }, { 0x0B82, 0x0B82 }, { 0x0BC0, 0x0BC0 }, { 0x0BCD, 0x0BCD }, { 0x0C3E, 0x0C40 }, { 0x0C46, 0x0C48 }, { 0x0C4A, 0x0C4D }, { 0x0C55, 0x0C56 }, { 0x0CBC, 0x0CBC }, { 0x0CBF, 0x0CBF }, { 0x0CC6, 0x0CC6 }, { 0x0CCC, 0x0CCD }, { 0x0CE2, 0x0CE3 }, { 0x0D41, 0x0D43 }, { 0x0D4D, 0x0D4D }, { 0x0DCA, 0x0DCA }, { 0x0DD2, 0x0DD4 }, { 0x0DD6, 0x0DD6 }, { 0x0E31, 0x0E31 }, { 0x0E34, 0x0E3A }, { 0x0E47, 0x0E4E }, { 0x0EB1, 0x0EB1 }, { 0x0EB4, 0x0EB9 }, { 0x0EBB, 0x0EBC }, { 0x0EC8, 0x0ECD }, { 0x0F18, 0x0F19 }, { 0x0F35, 0x0F35 }, { 0x0F37, 0x0F37 }, { 0x0F39, 0x0F39 }, { 0x0F71, 0x0F7E }, { 0x0F80, 0x0F84 }, { 0x0F86, 0x0F87 }, { 0x0F90, 0x0F97 }, { 0x0F99, 0x0FBC }, { 0x0FC6, 0x0FC6 }, { 0x102D, 0x1030 }, { 0x1032, 0x1032 }, { 0x1036, 0x1037 }, { 0x1039, 0x1039 }, { 0x1058, 0x1059 }, { 0x1160, 0x11FF }, { 0x135F, 0x135F }, { 0x1712, 0x1714 }, { 0x1732, 0x1734 }, { 0x1752, 0x1753 }, { 0x1772, 0x1773 }, { 0x17B4, 0x17B5 }, { 0x17B7, 0x17BD }, { 0x17C6, 0x17C6 }, { 0x17C9, 0x17D3 }, { 0x17DD, 0x17DD }, { 0x180B, 0x180D }, { 0x18A9, 0x18A9 }, { 0x1920, 0x1922 }, { 0x1927, 0x1928 }, { 0x1932, 0x1932 }, { 0x1939, 0x193B }, { 0x1A17, 0x1A18 }, { 0x1B00, 0x1B03 }, { 0x1B34, 0x1B34 }, { 0x1B36, 0x1B3A }, { 0x1B3C, 0x1B3C }, { 0x1B42, 0x1B42 }, { 0x1B6B, 0x1B73 }, { 0x1DC0, 0x1DCA }, { 0x1DFE, 0x1DFF }, { 0x200B, 0x200F }, { 0x202A, 0x202E }, { 0x2060, 0x2063 }, { 0x206A, 0x206F }, { 0x20D0, 0x20EF }, { 0x302A, 0x302F }, { 0x3099, 0x309A }, { 0xA806, 0xA806 }, { 0xA80B, 0xA80B }, { 0xA825, 0xA826 }, { 0xFB1E, 0xFB1E }, { 0xFE00, 0xFE0F }, { 0xFE20, 0xFE23 }, { 0xFEFF, 0xFEFF }, { 0xFFF9, 0xFFFB }, { 0x10A01, 0x10A03 }, { 0x10A05, 0x10A06 }, { 0x10A0C, 0x10A0F }, { 0x10A38, 0x10A3A }, { 0x10A3F, 0x10A3F }, { 0x1D167, 0x1D169 }, { 0x1D173, 0x1D182 }, { 0x1D185, 0x1D18B }, { 0x1D1AA, 0x1D1AD }, { 0x1D242, 0x1D244 }, { 0xE0001, 0xE0001 }, { 0xE0020, 0xE007F }, { 0xE0100, 0xE01EF } }; /* test for 8-bit control characters */ if (ucs == 0) return 0; if (ucs < 32 || (ucs >= 0x7f && ucs < 0xa0)) return -1; /* binary search in table of non-spacing characters */ if (vty_bisearch(ucs, combining, sizeof(combining) / sizeof(struct interval) - 1)) return 0; /* if we arrive here, ucs is not a combining or C0/C1 control character */ return 1 + (ucs >= 0x1100 && (ucs <= 0x115f || /* Hangul Jamo init. consonants */ ucs == 0x2329 || ucs == 0x232a || (ucs >= 0x2e80 && ucs <= 0xa4cf && ucs != 0x303f) || /* CJK ... Yi */ (ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */ (ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */ (ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */ (ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */ (ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */ (ucs >= 0xffe0 && ucs <= 0xffe6) || (ucs >= 0x20000 && ucs <= 0x2fffd) || (ucs >= 0x30000 && ucs <= 0x3fffd))); } // Return the width, in terminal cells, of the specified character. // // If the global custom width table is present, that table will be // consulted for the character's width. If the character is not in // the table, 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)) { return custom_table[ch]; } 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 1, 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, 1, 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; } } vty-5.28.2/cbits/set_term_timing.c0000644000000000000000000000042607346545000015266 0ustar0000000000000000#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); } vty-5.28.2/demos/0000755000000000000000000000000007346545000011732 5ustar0000000000000000vty-5.28.2/demos/Demo.hs0000644000000000000000000000626107346545000013157 0ustar0000000000000000{-# 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 [] vty-5.28.2/demos/ModeDemo.hs0000644000000000000000000000362507346545000013765 0ustar0000000000000000module Main where import Control.Applicative import Data.Monoid import Foreign.C.Types (CInt(..), CChar(..)) import System.Posix.Types (Fd(..)) 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 vty-5.28.2/src/Codec/Binary/UTF8/0000755000000000000000000000000007346545000014401 5ustar0000000000000000vty-5.28.2/src/Codec/Binary/UTF8/Debug.hs0000644000000000000000000000072307346545000015765 0ustar0000000000000000{-# 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 vty-5.28.2/src/Data/Terminfo/0000755000000000000000000000000007346545000014046 5ustar0000000000000000vty-5.28.2/src/Data/Terminfo/Eval.hs0000644000000000000000000000672207346545000015300 0ustar0000000000000000{-# 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 vty-5.28.2/src/Data/Terminfo/Parse.hs0000644000000000000000000002313507346545000015460 0ustar0000000000000000{-# 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 vty-5.28.2/src/Graphics/Text/0000755000000000000000000000000007346545000014076 5ustar0000000000000000vty-5.28.2/src/Graphics/Text/Width.hs0000644000000000000000000000376507346545000015524 0ustar0000000000000000-- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | This module provides functions to measure the terminal column width -- of characters and strings. -- -- The functions provided in this module all ultimately make calls to -- the C implementation in @cbits/mk_wcwidth.c@. That code manages some -- global state that carries a table of Unicode character widths. For -- more details, see 'Graphics.Vty.UnicodeWidthTable.Install', the C -- code, and the "Multi-Column Character Support" section of the project -- @README@. module Graphics.Text.Width ( wcwidth , wcswidth , wctwidth , wctlwidth , safeWcwidth , safeWcswidth , safeWctwidth , safeWctlwidth ) where import Data.List (foldl') import qualified Data.Text as T import qualified Data.Text.Lazy as TL foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int wcswidth :: String -> Int wcswidth = foldl' (\l c -> wcwidth c + l) 0 {-# INLINE [1] wcswidth #-} wctwidth :: T.Text -> Int wctwidth = T.foldl' (\l c -> wcwidth c + l) 0 wctlwidth :: TL.Text -> Int wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0 {-# RULES "wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x "wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x #-} -- | Returns the display width of a character. Assumes all characters -- with unknown widths are 0 width. safeWcwidth :: Char -> Int safeWcwidth = max 0 . wcwidth -- | Returns the display width of a string. Assumes all characters with -- unknown widths are 0 width. safeWcswidth :: String -> Int safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0 -- | Returns the display width of a text. Assumes all characters with -- unknown widths are 0 width. safeWctwidth :: T.Text -> Int safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0 -- | Returns the display width of a lazy text. Assumes all characters -- with unknown widths are 0 width. safeWctlwidth :: TL.Text -> Int safeWctlwidth = TL.foldl' (\l c -> safeWcwidth c + l) 0 vty-5.28.2/src/Graphics/0000755000000000000000000000000007346545000013152 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty.hs0000644000000000000000000002050307346545000014270 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Vty provides interfaces for both terminal input and terminal -- output. -- -- - 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 -- '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. -- -- @ -- import "Graphics.Vty" -- -- main = do -- cfg <- 'standardIOConfig' -- vty <- 'mkVty' cfg -- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\" -- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\" -- img = line0 '<->' line1 -- pic = 'picForImage' img -- 'update' vty pic -- e <- 'nextEvent' vty -- 'shutdown' vty -- 'print' (\"Last event was: \" '++' 'show' e) -- @ module Graphics.Vty ( Vty(..) , mkVty , Mode(..) , module Graphics.Vty.Config , module Graphics.Vty.Input , module Graphics.Vty.Output , module Graphics.Vty.Output.Interface , module Graphics.Vty.Picture , module Graphics.Vty.Image , module Graphics.Vty.Attributes ) where import Graphics.Vty.Config import Graphics.Vty.Input 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 #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup ((<>)) #endif -- | A Vty value represents a handle to the Vty library that the -- application must create in order to use Vty. -- -- The use of Vty typically follows this process: -- -- 1. Initialize vty with 'mkVty' (this takes control of the terminal). -- -- 2. Use 'update' to display a picture. -- -- 3. Use 'nextEvent' to get the next input event. -- -- 4. Depending on the event, go to 2 or 5. -- -- 5. Shutdown vty and restore the terminal state with 'shutdown'. At -- this point the 'Vty' handle cannot be used again. -- -- Operations on Vty handles are not thread-safe. data Vty = Vty { update :: Picture -> IO () -- ^ Outputs the given 'Picture'. , 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". -- -- For most applications @mkVty defaultConfig@ is sufficient. mkVty :: Config -> IO Vty mkVty appConfig = do config <- (<> appConfig) <$> userConfig when (allowCustomUnicodeWidthTables config /= Just False) $ installCustomWidthTable config input <- inputForConfig config out <- outputForConfig config internalMkVty input out installCustomWidthTable :: Config -> IO () installCustomWidthTable c = do let doLog s = case debugLog c of Nothing -> return () Just path -> appendFile path $ "installWidthTable: " <> s <> "\n" customInstalled <- isCustomTableReady when (not customInstalled) $ do mTerm <- currentTerminalName case mTerm of Nothing -> doLog "No current terminal name available" Just currentTerm -> case lookup currentTerm (termWidthMaps c) of Nothing -> doLog "Current terminal 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 internalMkVty :: Input -> Output -> IO Vty internalMkVty input out = do reserveDisplay out shutdownVar <- atomically $ newTVar False let shutdownIo = do alreadyShutdown <- atomically $ swapTVar shutdownVar True when (not alreadyShutdown) $ do shutdownInput input releaseDisplay out releaseTerminal out let shutdownStatus = atomically $ readTVar shutdownVar lastPicRef <- newIORef Nothing lastUpdateRef <- newIORef Nothing let innerUpdate inPic = do b <- displayBounds out mlastUpdate <- readIORef lastUpdateRef updateData <- case mlastUpdate of Nothing -> do dc <- displayContext out b outputPicture dc inPic return (b, dc) Just (lastBounds, lastContext) -> do if b /= lastBounds then do dc <- displayContext out b outputPicture dc inPic return (b, dc) else do outputPicture lastContext inPic return (b, lastContext) writeIORef lastUpdateRef $ Just updateData writeIORef lastPicRef $ Just inPic let innerRefresh = do writeIORef lastUpdateRef Nothing bounds <- displayBounds out dc <- displayContext out bounds writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState mPic <- readIORef lastPicRef maybe (return ()) innerUpdate mPic let mkResize = uncurry EvResize <$> displayBounds out gkey = do k <- atomically $ readTChan $ _eventChannel input case k of (EvResize _ _) -> mkResize _ -> return k gkey' = do k <- atomically $ tryReadTChan $ _eventChannel input case k of (Just (EvResize _ _)) -> Just <$> mkResize _ -> return k return $ Vty { update = innerUpdate , nextEvent = gkey , nextEventNonblocking = gkey' , inputIface = input , outputIface = out , refresh = innerRefresh , shutdown = shutdownIo , isShutdown = shutdownStatus } vty-5.28.2/src/Graphics/Vty/0000755000000000000000000000000007346545000013734 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Attributes.hs0000644000000000000000000001763707346545000016434 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} -- | Display attributes -- -- Attributes have three components: a foreground color, a background -- color, and a style mask. The simplest attribute is the default -- attribute, or 'defAttr'. Attributes can be modified with -- 'withForeColor', 'withBackColor', and 'withStyle', e.g., -- -- @ -- defAttr \`withForeColor\` red -- @ -- -- 'Image' constructors often require an 'Attr' to indicate the -- attributes used in the image, e.g., -- -- @ -- string (defAttr \`withForeColor\` red) "this text will be red" -- @ -- -- The appearance of 'Image's using 'defAttr' is determined by the The -- terminal, so this is not something VTY can control. The user is free -- to The define the color scheme of the terminal as they see fit. -- -- The value 'currentAttr' will keep the attributes of whatever was -- output previously. module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes.Color , Attr(..) , FixedAttr(..) , MaybeDefault(..) , defAttr , currentAttr -- * Styles , Style , withStyle , standout , italic , underline , reverseVideo , blink , dim , bold , defaultStyleMask , styleMask , hasStyle -- * Setting attribute colors , withForeColor , withBackColor -- * Setting hyperlinks , withURL ) 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 -- | A display attribute defines the Color and Style of all the -- characters rendered after the attribute is applied. -- -- At most 256 colors, picked from a 240 and 16 color palette, are -- possible for the background and foreground. The 240 colors and -- 16 colors are points in different palettes. See Color for more -- information. data Attr = Attr { attrStyle :: !(MaybeDefault Style) , attrForeColor :: !(MaybeDefault Color) , attrBackColor :: !(MaybeDefault Color) , attrURL :: !(MaybeDefault Text) } deriving ( Eq, Show, Read, Generic, NFData ) -- This could be encoded into a single 32 bit word. The 32 bit word is -- first divided into 4 groups of 8 bits where: The first group codes -- what action should be taken with regards to the other groups. -- XXYYZZ__ -- XX - style action -- 00 => reset to default -- 01 => unchanged -- 10 => set -- YY - foreground color action -- 00 => reset to default -- 01 => unchanged -- 10 => set -- ZZ - background color action -- 00 => reset to default -- 01 => unchanged -- 10 => set -- __ - unused -- -- Next is the style flags -- SURBDOI_ -- S - standout -- U - underline -- R - reverse video -- B - blink -- D - dim -- O - bold -- I - italic -- _ - unused -- -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits. 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 -- default colors (unfortunately). data FixedAttr = FixedAttr { fixedStyle :: !Style , fixedForeColor :: !(Maybe Color) , fixedBackColor :: !(Maybe Color) , fixedURL :: !(Maybe Text) } deriving ( Eq, Show ) -- | The style and color attributes can either be the terminal defaults. -- Or be equivalent to the previously applied style. Or be a specific -- value. data MaybeDefault v where Default :: MaybeDefault v KeepCurrent :: MaybeDefault v SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v instance (NFData v) => NFData (MaybeDefault v) where rnf Default = () rnf KeepCurrent = () rnf (SetTo v) = rnf 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 instance Eq v => Monoid ( MaybeDefault v ) where mempty = KeepCurrent #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | 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 7 possible style attributes: -- -- * standout -- -- * underline -- -- * reverseVideo -- -- * blink -- -- * dim -- -- * bold/bright -- -- * italic -- -- (The invisible, protect, and altcharset display attributes some -- terminals support are not supported via VTY.) standout, underline, reverseVideo, blink, dim, bold, italic :: Style standout = 0x01 underline = 0x02 reverseVideo = 0x04 blink = 0x08 dim = 0x10 bold = 0x20 italic = 0x40 defaultStyleMask :: Style defaultStyleMask = 0x00 styleMask :: Attr -> Word8 styleMask attr = case attrStyle attr of Default -> 0 KeepCurrent -> 0 SetTo v -> v -- | true if the given Style value has the specified Style set. hasStyle :: Style -> Style -> Bool hasStyle s bitMask = ( s .&. bitMask ) /= 0 -- | Set the foreground color of an `Attr'. withForeColor :: Attr -> Color -> Attr withForeColor attr c = attr { attrForeColor = SetTo c } -- | Set the background color of an `Attr'. withBackColor :: Attr -> Color -> Attr withBackColor attr c = attr { attrBackColor = SetTo c } -- | Add the given style attribute withStyle :: Attr -> Style -> Attr withStyle attr 0 = attr withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } -- | Add a hyperlinked URL using the proposed [escape sequences for -- hyperlinked -- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). -- These escape sequences are comparatively new and aren't widely -- supported in terminal emulators yet, but most terminal emulators -- that don't know about these sequences will ignore these sequences, -- and therefore this should fall back sensibly. In some cases they -- won't and this will result in garbage, so this is why hyperlinking is -- disabled by default, in which case this combinator has no observable -- effect. To enable it, enable 'Hyperlink' mode on your Vty output -- interface. withURL :: Attr -> Text -> Attr withURL attr url = attr { attrURL = SetTo url } -- | Sets the style, background color and foreground color to the -- default values for the terminal. There is no easy way to determine -- what the default background and foreground colors are. defAttr :: Attr defAttr = Attr Default Default Default Default -- | Keeps the style, background color and foreground color that was -- previously set. Used to override some part of the previous style. -- -- EG: current_style `withForeColor` brightMagenta -- -- Would be the currently applied style (be it underline, bold, etc) but -- with the foreground color set to brightMagenta. currentAttr :: Attr currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent vty-5.28.2/src/Graphics/Vty/Attributes/0000755000000000000000000000000007346545000016062 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Attributes/Color.hs0000644000000000000000000000717107346545000017502 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} module Graphics.Vty.Attributes.Color ( Color(..) -- ** Fixed Colors -- | Standard 8-color ANSI terminal color codes. -- -- Note that these map to colors in the terminal's custom palette. For -- instance, `white` maps to whatever the terminal color theme uses for -- white. -- -- Use these functions if you want to make apps that fit the terminal theme. -- If you want access to more/stronger colors use `rgbColor` , black , red , green , yellow , blue , magenta , cyan , white -- | Bright/Vivid variants of the standard 8-color ANSI , brightBlack , brightRed , brightGreen , brightYellow , brightBlue , brightMagenta , brightCyan , brightWhite -- ** Creating Colors From RGB , rgbColor , module Graphics.Vty.Attributes.Color240 ) where import Data.Word import GHC.Generics import Control.DeepSeq import Graphics.Vty.Attributes.Color240 -- | Abstract data type representing a color. -- -- Currently the foreground and background color are specified as points -- in either a: -- -- * 16 color palette. Where the first 8 colors are equal to the 8 -- colors of the ISO 6429 (ANSI) 8 color palette and the second 8 -- colors are bright/vivid versions of the first 8 colors. -- -- * 240 color palette. This palette is a regular sampling of the full -- RGB colorspace for the first 224 colors. The remaining 16 colors is -- a greyscale palette. -- -- The 8 ISO 6429 (ANSI) colors are as follows: -- -- 0. black -- -- 1. red -- -- 2. green -- -- 3. yellow -- -- 4. blue -- -- 5. magenta -- -- 6. cyan -- -- 7. white -- -- The mapping from points in the 240 color palette to colors actually -- displayable by the terminal depends on the number of colors the -- terminal claims to support. Which is usually determined by the -- terminfo "colors" property. If this property is not being accurately -- reported then the color reproduction will be incorrect. -- -- If the terminal reports <= 16 colors then the 240 color palette -- points are only mapped to the 8 color pallete. I'm not sure of -- the RGB points for the "bright" colors which is why they are not -- addressable via the 240 color palette. -- -- If the terminal reports > 16 colors then the 240 color palette -- points are mapped to the nearest points in a ("color count" - 16) -- subsampling of the 240 color palette. -- -- All of this assumes the terminals are behaving similarly to xterm and -- rxvt when handling colors. And that the individual colors have not -- been remapped by the user. There may be a way to verify this through -- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE. data Color = ISOColor !Word8 | Color240 !Word8 deriving ( Eq, Show, Read, Generic, NFData ) black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 red = ISOColor 1 green = ISOColor 2 yellow = ISOColor 3 blue = ISOColor 4 magenta= ISOColor 5 cyan = ISOColor 6 white = ISOColor 7 brightBlack, brightRed, brightGreen, brightYellow :: Color brightBlue, brightMagenta, brightCyan, brightWhite :: Color brightBlack = ISOColor 8 brightRed = ISOColor 9 brightGreen = ISOColor 10 brightYellow = ISOColor 11 brightBlue = ISOColor 12 brightMagenta= ISOColor 13 brightCyan = ISOColor 14 brightWhite = ISOColor 15 -- | Create a 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 = Color240 (rgbColorToColor240 r g b) vty-5.28.2/src/Graphics/Vty/Attributes/Color240.hs0000644000000000000000000004411707346545000017731 0ustar0000000000000000-- This header file was generated by ./256colres.pl module Graphics.Vty.Attributes.Color240 ( rgbColorToColor240 , color240CodeToRGB ) where import Data.Word (Word8) import Text.Printf -- Note: rgbColor's mapping from RGB to 240 colors was generated from -- 256colres.pl which is forked from xterm 256colres.pl. -- | Create a value in the Color240 set from an RGB triple rgbColorToColor240 :: Integral i => i -> i -> i -> Word8 rgbColorToColor240 r g b | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" | r == 8 && g == 8 && b == 8 = 216 | r == 18 && g == 18 && b == 18 = 217 | r == 28 && g == 28 && b == 28 = 218 | r == 38 && g == 38 && b == 38 = 219 | r == 48 && g == 48 && b == 48 = 220 | r == 58 && g == 58 && b == 58 = 221 | r == 68 && g == 68 && b == 68 = 222 | r == 78 && g == 78 && b == 78 = 223 | r == 88 && g == 88 && b == 88 = 224 | r == 98 && g == 98 && b == 98 = 225 | r == 108 && g == 108 && b == 108 = 226 | r == 118 && g == 118 && b == 118 = 227 | r == 128 && g == 128 && b == 128 = 228 | r == 138 && g == 138 && b == 138 = 229 | r == 148 && g == 148 && b == 148 = 230 | r == 158 && g == 158 && b == 158 = 231 | r == 168 && g == 168 && b == 168 = 232 | r == 178 && g == 178 && b == 178 = 233 | r == 188 && g == 188 && b == 188 = 234 | r == 198 && g == 198 && b == 198 = 235 | r == 208 && g == 208 && b == 208 = 236 | r == 218 && g == 218 && b == 218 = 237 | r == 228 && g == 228 && b == 228 = 238 | r == 238 && g == 238 && b == 238 = 239 | r <= 0 && g <= 0 && b <= 0 = 0 | r <= 0 && g <= 0 && b <= 95 = 1 | r <= 0 && g <= 0 && b <= 135 = 2 | r <= 0 && g <= 0 && b <= 175 = 3 | r <= 0 && g <= 0 && b <= 215 = 4 | r <= 0 && g <= 0 && b <= 255 = 5 | r <= 0 && g <= 95 && b <= 0 = 6 | r <= 0 && g <= 95 && b <= 95 = 7 | r <= 0 && g <= 95 && b <= 135 = 8 | r <= 0 && g <= 95 && b <= 175 = 9 | r <= 0 && g <= 95 && b <= 215 = 10 | r <= 0 && g <= 95 && b <= 255 = 11 | r <= 0 && g <= 135 && b <= 0 = 12 | r <= 0 && g <= 135 && b <= 95 = 13 | r <= 0 && g <= 135 && b <= 135 = 14 | r <= 0 && g <= 135 && b <= 175 = 15 | r <= 0 && g <= 135 && b <= 215 = 16 | r <= 0 && g <= 135 && b <= 255 = 17 | r <= 0 && g <= 175 && b <= 0 = 18 | r <= 0 && g <= 175 && b <= 95 = 19 | r <= 0 && g <= 175 && b <= 135 = 20 | r <= 0 && g <= 175 && b <= 175 = 21 | r <= 0 && g <= 175 && b <= 215 = 22 | r <= 0 && g <= 175 && b <= 255 = 23 | r <= 0 && g <= 215 && b <= 0 = 24 | r <= 0 && g <= 215 && b <= 95 = 25 | r <= 0 && g <= 215 && b <= 135 = 26 | r <= 0 && g <= 215 && b <= 175 = 27 | r <= 0 && g <= 215 && b <= 215 = 28 | r <= 0 && g <= 215 && b <= 255 = 29 | r <= 0 && g <= 255 && b <= 0 = 30 | r <= 0 && g <= 255 && b <= 95 = 31 | r <= 0 && g <= 255 && b <= 135 = 32 | r <= 0 && g <= 255 && b <= 175 = 33 | r <= 0 && g <= 255 && b <= 215 = 34 | r <= 0 && g <= 255 && b <= 255 = 35 | r <= 95 && g <= 0 && b <= 0 = 36 | r <= 95 && g <= 0 && b <= 95 = 37 | r <= 95 && g <= 0 && b <= 135 = 38 | r <= 95 && g <= 0 && b <= 175 = 39 | r <= 95 && g <= 0 && b <= 215 = 40 | r <= 95 && g <= 0 && b <= 255 = 41 | r <= 95 && g <= 95 && b <= 0 = 42 | r <= 95 && g <= 95 && b <= 95 = 43 | r <= 95 && g <= 95 && b <= 135 = 44 | r <= 95 && g <= 95 && b <= 175 = 45 | r <= 95 && g <= 95 && b <= 215 = 46 | r <= 95 && g <= 95 && b <= 255 = 47 | r <= 95 && g <= 135 && b <= 0 = 48 | r <= 95 && g <= 135 && b <= 95 = 49 | r <= 95 && g <= 135 && b <= 135 = 50 | r <= 95 && g <= 135 && b <= 175 = 51 | r <= 95 && g <= 135 && b <= 215 = 52 | r <= 95 && g <= 135 && b <= 255 = 53 | r <= 95 && g <= 175 && b <= 0 = 54 | r <= 95 && g <= 175 && b <= 95 = 55 | r <= 95 && g <= 175 && b <= 135 = 56 | r <= 95 && g <= 175 && b <= 175 = 57 | r <= 95 && g <= 175 && b <= 215 = 58 | r <= 95 && g <= 175 && b <= 255 = 59 | r <= 95 && g <= 215 && b <= 0 = 60 | r <= 95 && g <= 215 && b <= 95 = 61 | r <= 95 && g <= 215 && b <= 135 = 62 | r <= 95 && g <= 215 && b <= 175 = 63 | r <= 95 && g <= 215 && b <= 215 = 64 | r <= 95 && g <= 215 && b <= 255 = 65 | r <= 95 && g <= 255 && b <= 0 = 66 | r <= 95 && g <= 255 && b <= 95 = 67 | r <= 95 && g <= 255 && b <= 135 = 68 | r <= 95 && g <= 255 && b <= 175 = 69 | r <= 95 && g <= 255 && b <= 215 = 70 | r <= 95 && g <= 255 && b <= 255 = 71 | r <= 135 && g <= 0 && b <= 0 = 72 | r <= 135 && g <= 0 && b <= 95 = 73 | r <= 135 && g <= 0 && b <= 135 = 74 | r <= 135 && g <= 0 && b <= 175 = 75 | r <= 135 && g <= 0 && b <= 215 = 76 | r <= 135 && g <= 0 && b <= 255 = 77 | r <= 135 && g <= 95 && b <= 0 = 78 | r <= 135 && g <= 95 && b <= 95 = 79 | r <= 135 && g <= 95 && b <= 135 = 80 | r <= 135 && g <= 95 && b <= 175 = 81 | r <= 135 && g <= 95 && b <= 215 = 82 | r <= 135 && g <= 95 && b <= 255 = 83 | r <= 135 && g <= 135 && b <= 0 = 84 | r <= 135 && g <= 135 && b <= 95 = 85 | r <= 135 && g <= 135 && b <= 135 = 86 | r <= 135 && g <= 135 && b <= 175 = 87 | r <= 135 && g <= 135 && b <= 215 = 88 | r <= 135 && g <= 135 && b <= 255 = 89 | r <= 135 && g <= 175 && b <= 0 = 90 | r <= 135 && g <= 175 && b <= 95 = 91 | r <= 135 && g <= 175 && b <= 135 = 92 | r <= 135 && g <= 175 && b <= 175 = 93 | r <= 135 && g <= 175 && b <= 215 = 94 | r <= 135 && g <= 175 && b <= 255 = 95 | r <= 135 && g <= 215 && b <= 0 = 96 | r <= 135 && g <= 215 && b <= 95 = 97 | r <= 135 && g <= 215 && b <= 135 = 98 | r <= 135 && g <= 215 && b <= 175 = 99 | r <= 135 && g <= 215 && b <= 215 = 100 | r <= 135 && g <= 215 && b <= 255 = 101 | r <= 135 && g <= 255 && b <= 0 = 102 | r <= 135 && g <= 255 && b <= 95 = 103 | r <= 135 && g <= 255 && b <= 135 = 104 | r <= 135 && g <= 255 && b <= 175 = 105 | r <= 135 && g <= 255 && b <= 215 = 106 | r <= 135 && g <= 255 && b <= 255 = 107 | r <= 175 && g <= 0 && b <= 0 = 108 | r <= 175 && g <= 0 && b <= 95 = 109 | r <= 175 && g <= 0 && b <= 135 = 110 | r <= 175 && g <= 0 && b <= 175 = 111 | r <= 175 && g <= 0 && b <= 215 = 112 | r <= 175 && g <= 0 && b <= 255 = 113 | r <= 175 && g <= 95 && b <= 0 = 114 | r <= 175 && g <= 95 && b <= 95 = 115 | r <= 175 && g <= 95 && b <= 135 = 116 | r <= 175 && g <= 95 && b <= 175 = 117 | r <= 175 && g <= 95 && b <= 215 = 118 | r <= 175 && g <= 95 && b <= 255 = 119 | r <= 175 && g <= 135 && b <= 0 = 120 | r <= 175 && g <= 135 && b <= 95 = 121 | r <= 175 && g <= 135 && b <= 135 = 122 | r <= 175 && g <= 135 && b <= 175 = 123 | r <= 175 && g <= 135 && b <= 215 = 124 | r <= 175 && g <= 135 && b <= 255 = 125 | r <= 175 && g <= 175 && b <= 0 = 126 | r <= 175 && g <= 175 && b <= 95 = 127 | r <= 175 && g <= 175 && b <= 135 = 128 | r <= 175 && g <= 175 && b <= 175 = 129 | r <= 175 && g <= 175 && b <= 215 = 130 | r <= 175 && g <= 175 && b <= 255 = 131 | r <= 175 && g <= 215 && b <= 0 = 132 | r <= 175 && g <= 215 && b <= 95 = 133 | r <= 175 && g <= 215 && b <= 135 = 134 | r <= 175 && g <= 215 && b <= 175 = 135 | r <= 175 && g <= 215 && b <= 215 = 136 | r <= 175 && g <= 215 && b <= 255 = 137 | r <= 175 && g <= 255 && b <= 0 = 138 | r <= 175 && g <= 255 && b <= 95 = 139 | r <= 175 && g <= 255 && b <= 135 = 140 | r <= 175 && g <= 255 && b <= 175 = 141 | r <= 175 && g <= 255 && b <= 215 = 142 | r <= 175 && g <= 255 && b <= 255 = 143 | r <= 215 && g <= 0 && b <= 0 = 144 | r <= 215 && g <= 0 && b <= 95 = 145 | r <= 215 && g <= 0 && b <= 135 = 146 | r <= 215 && g <= 0 && b <= 175 = 147 | r <= 215 && g <= 0 && b <= 215 = 148 | r <= 215 && g <= 0 && b <= 255 = 149 | r <= 215 && g <= 95 && b <= 0 = 150 | r <= 215 && g <= 95 && b <= 95 = 151 | r <= 215 && g <= 95 && b <= 135 = 152 | r <= 215 && g <= 95 && b <= 175 = 153 | r <= 215 && g <= 95 && b <= 215 = 154 | r <= 215 && g <= 95 && b <= 255 = 155 | r <= 215 && g <= 135 && b <= 0 = 156 | r <= 215 && g <= 135 && b <= 95 = 157 | r <= 215 && g <= 135 && b <= 135 = 158 | r <= 215 && g <= 135 && b <= 175 = 159 | r <= 215 && g <= 135 && b <= 215 = 160 | r <= 215 && g <= 135 && b <= 255 = 161 | r <= 215 && g <= 175 && b <= 0 = 162 | r <= 215 && g <= 175 && b <= 95 = 163 | r <= 215 && g <= 175 && b <= 135 = 164 | r <= 215 && g <= 175 && b <= 175 = 165 | r <= 215 && g <= 175 && b <= 215 = 166 | r <= 215 && g <= 175 && b <= 255 = 167 | r <= 215 && g <= 215 && b <= 0 = 168 | r <= 215 && g <= 215 && b <= 95 = 169 | r <= 215 && g <= 215 && b <= 135 = 170 | r <= 215 && g <= 215 && b <= 175 = 171 | r <= 215 && g <= 215 && b <= 215 = 172 | r <= 215 && g <= 215 && b <= 255 = 173 | r <= 215 && g <= 255 && b <= 0 = 174 | r <= 215 && g <= 255 && b <= 95 = 175 | r <= 215 && g <= 255 && b <= 135 = 176 | r <= 215 && g <= 255 && b <= 175 = 177 | r <= 215 && g <= 255 && b <= 215 = 178 | r <= 215 && g <= 255 && b <= 255 = 179 | r <= 255 && g <= 0 && b <= 0 = 180 | r <= 255 && g <= 0 && b <= 95 = 181 | r <= 255 && g <= 0 && b <= 135 = 182 | r <= 255 && g <= 0 && b <= 175 = 183 | r <= 255 && g <= 0 && b <= 215 = 184 | r <= 255 && g <= 0 && b <= 255 = 185 | r <= 255 && g <= 95 && b <= 0 = 186 | r <= 255 && g <= 95 && b <= 95 = 187 | r <= 255 && g <= 95 && b <= 135 = 188 | r <= 255 && g <= 95 && b <= 175 = 189 | r <= 255 && g <= 95 && b <= 215 = 190 | r <= 255 && g <= 95 && b <= 255 = 191 | r <= 255 && g <= 135 && b <= 0 = 192 | r <= 255 && g <= 135 && b <= 95 = 193 | r <= 255 && g <= 135 && b <= 135 = 194 | r <= 255 && g <= 135 && b <= 175 = 195 | r <= 255 && g <= 135 && b <= 215 = 196 | r <= 255 && g <= 135 && b <= 255 = 197 | r <= 255 && g <= 175 && b <= 0 = 198 | r <= 255 && g <= 175 && b <= 95 = 199 | r <= 255 && g <= 175 && b <= 135 = 200 | r <= 255 && g <= 175 && b <= 175 = 201 | r <= 255 && g <= 175 && b <= 215 = 202 | r <= 255 && g <= 175 && b <= 255 = 203 | r <= 255 && g <= 215 && b <= 0 = 204 | r <= 255 && g <= 215 && b <= 95 = 205 | r <= 255 && g <= 215 && b <= 135 = 206 | r <= 255 && g <= 215 && b <= 175 = 207 | r <= 255 && g <= 215 && b <= 215 = 208 | r <= 255 && g <= 215 && b <= 255 = 209 | r <= 255 && g <= 255 && b <= 0 = 210 | r <= 255 && g <= 255 && b <= 95 = 211 | r <= 255 && g <= 255 && b <= 135 = 212 | r <= 255 && g <= 255 && b <= 175 = 213 | r <= 255 && g <= 255 && b <= 215 = 214 | r <= 255 && g <= 255 && b <= 255 = 215 | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." (fromIntegral r :: Int) (fromIntegral g :: Int) (fromIntegral b :: Int)) -- | Create a RGB triple from a value in the Color240 set. color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int) color240CodeToRGB n = case n of 0 -> Just (0, 0, 0) 1 -> Just (0, 0, 95) 2 -> Just (0, 0, 135) 3 -> Just (0, 0, 175) 4 -> Just (0, 0, 215) 5 -> Just (0, 0, 255) 6 -> Just (0, 95, 0) 7 -> Just (0, 95, 95) 8 -> Just (0, 95, 135) 9 -> Just (0, 95, 175) 10 -> Just (0, 95, 215) 11 -> Just (0, 95, 255) 12 -> Just (0, 135, 0) 13 -> Just (0, 135, 95) 14 -> Just (0, 135, 135) 15 -> Just (0, 135, 175) 16 -> Just (0, 135, 215) 17 -> Just (0, 135, 255) 18 -> Just (0, 175, 0) 19 -> Just (0, 175, 95) 20 -> Just (0, 175, 135) 21 -> Just (0, 175, 175) 22 -> Just (0, 175, 215) 23 -> Just (0, 175, 255) 24 -> Just (0, 215, 0) 25 -> Just (0, 215, 95) 26 -> Just (0, 215, 135) 27 -> Just (0, 215, 175) 28 -> Just (0, 215, 215) 29 -> Just (0, 215, 255) 30 -> Just (0, 255, 0) 31 -> Just (0, 255, 95) 32 -> Just (0, 255, 135) 33 -> Just (0, 255, 175) 34 -> Just (0, 255, 215) 35 -> Just (0, 255, 255) 36 -> Just (95, 0, 0) 37 -> Just (95, 0, 95) 38 -> Just (95, 0, 135) 39 -> Just (95, 0, 175) 40 -> Just (95, 0, 215) 41 -> Just (95, 0, 255) 42 -> Just (95, 95, 0) 43 -> Just (95, 95, 95) 44 -> Just (95, 95, 135) 45 -> Just (95, 95, 175) 46 -> Just (95, 95, 215) 47 -> Just (95, 95, 255) 48 -> Just (95, 135, 0) 49 -> Just (95, 135, 95) 50 -> Just (95, 135, 135) 51 -> Just (95, 135, 175) 52 -> Just (95, 135, 215) 53 -> Just (95, 135, 255) 54 -> Just (95, 175, 0) 55 -> Just (95, 175, 95) 56 -> Just (95, 175, 135) 57 -> Just (95, 175, 175) 58 -> Just (95, 175, 215) 59 -> Just (95, 175, 255) 60 -> Just (95, 215, 0) 61 -> Just (95, 215, 95) 62 -> Just (95, 215, 135) 63 -> Just (95, 215, 175) 64 -> Just (95, 215, 215) 65 -> Just (95, 215, 255) 66 -> Just (95, 255, 0) 67 -> Just (95, 255, 95) 68 -> Just (95, 255, 135) 69 -> Just (95, 255, 175) 70 -> Just (95, 255, 215) 71 -> Just (95, 255, 255) 72 -> Just (135, 0, 0) 73 -> Just (135, 0, 95) 74 -> Just (135, 0, 135) 75 -> Just (135, 0, 175) 76 -> Just (135, 0, 215) 77 -> Just (135, 0, 255) 78 -> Just (135, 95, 0) 79 -> Just (135, 95, 95) 80 -> Just (135, 95, 135) 81 -> Just (135, 95, 175) 82 -> Just (135, 95, 215) 83 -> Just (135, 95, 255) 84 -> Just (135, 135, 0) 85 -> Just (135, 135, 95) 86 -> Just (135, 135, 135) 87 -> Just (135, 135, 175) 88 -> Just (135, 135, 215) 89 -> Just (135, 135, 255) 90 -> Just (135, 175, 0) 91 -> Just (135, 175, 95) 92 -> Just (135, 175, 135) 93 -> Just (135, 175, 175) 94 -> Just (135, 175, 215) 95 -> Just (135, 175, 255) 96 -> Just (135, 215, 0) 97 -> Just (135, 215, 95) 98 -> Just (135, 215, 135) 99 -> Just (135, 215, 175) 100 -> Just (135, 215, 215) 101 -> Just (135, 215, 255) 102 -> Just (135, 255, 0) 103 -> Just (135, 255, 95) 104 -> Just (135, 255, 135) 105 -> Just (135, 255, 175) 106 -> Just (135, 255, 215) 107 -> Just (135, 255, 255) 108 -> Just (175, 0, 0) 109 -> Just (175, 0, 95) 110 -> Just (175, 0, 135) 111 -> Just (175, 0, 175) 112 -> Just (175, 0, 215) 113 -> Just (175, 0, 255) 114 -> Just (175, 95, 0) 115 -> Just (175, 95, 95) 116 -> Just (175, 95, 135) 117 -> Just (175, 95, 175) 118 -> Just (175, 95, 215) 119 -> Just (175, 95, 255) 120 -> Just (175, 135, 0) 121 -> Just (175, 135, 95) 122 -> Just (175, 135, 135) 123 -> Just (175, 135, 175) 124 -> Just (175, 135, 215) 125 -> Just (175, 135, 255) 126 -> Just (175, 175, 0) 127 -> Just (175, 175, 95) 128 -> Just (175, 175, 135) 129 -> Just (175, 175, 175) 130 -> Just (175, 175, 215) 131 -> Just (175, 175, 255) 132 -> Just (175, 215, 0) 133 -> Just (175, 215, 95) 134 -> Just (175, 215, 135) 135 -> Just (175, 215, 175) 136 -> Just (175, 215, 215) 137 -> Just (175, 215, 255) 138 -> Just (175, 255, 0) 139 -> Just (175, 255, 95) 140 -> Just (175, 255, 135) 141 -> Just (175, 255, 175) 142 -> Just (175, 255, 215) 143 -> Just (175, 255, 255) 144 -> Just (215, 0, 0) 145 -> Just (215, 0, 95) 146 -> Just (215, 0, 135) 147 -> Just (215, 0, 175) 148 -> Just (215, 0, 215) 149 -> Just (215, 0, 255) 150 -> Just (215, 95, 0) 151 -> Just (215, 95, 95) 152 -> Just (215, 95, 135) 153 -> Just (215, 95, 175) 154 -> Just (215, 95, 215) 155 -> Just (215, 95, 255) 156 -> Just (215, 135, 0) 157 -> Just (215, 135, 95) 158 -> Just (215, 135, 135) 159 -> Just (215, 135, 175) 160 -> Just (215, 135, 215) 161 -> Just (215, 135, 255) 162 -> Just (215, 175, 0) 163 -> Just (215, 175, 95) 164 -> Just (215, 175, 135) 165 -> Just (215, 175, 175) 166 -> Just (215, 175, 215) 167 -> Just (215, 175, 255) 168 -> Just (215, 215, 0) 169 -> Just (215, 215, 95) 170 -> Just (215, 215, 135) 171 -> Just (215, 215, 175) 172 -> Just (215, 215, 215) 173 -> Just (215, 215, 255) 174 -> Just (215, 255, 0) 175 -> Just (215, 255, 95) 176 -> Just (215, 255, 135) 177 -> Just (215, 255, 175) 178 -> Just (215, 255, 215) 179 -> Just (215, 255, 255) 180 -> Just (255, 0, 0) 181 -> Just (255, 0, 95) 182 -> Just (255, 0, 135) 183 -> Just (255, 0, 175) 184 -> Just (255, 0, 215) 185 -> Just (255, 0, 255) 186 -> Just (255, 95, 0) 187 -> Just (255, 95, 95) 188 -> Just (255, 95, 135) 189 -> Just (255, 95, 175) 190 -> Just (255, 95, 215) 191 -> Just (255, 95, 255) 192 -> Just (255, 135, 0) 193 -> Just (255, 135, 95) 194 -> Just (255, 135, 135) 195 -> Just (255, 135, 175) 196 -> Just (255, 135, 215) 197 -> Just (255, 135, 255) 198 -> Just (255, 175, 0) 199 -> Just (255, 175, 95) 200 -> Just (255, 175, 135) 201 -> Just (255, 175, 175) 202 -> Just (255, 175, 215) 203 -> Just (255, 175, 255) 204 -> Just (255, 215, 0) 205 -> Just (255, 215, 95) 206 -> Just (255, 215, 135) 207 -> Just (255, 215, 175) 208 -> Just (255, 215, 215) 209 -> Just (255, 215, 255) 210 -> Just (255, 255, 0) 211 -> Just (255, 255, 95) 212 -> Just (255, 255, 135) 213 -> Just (255, 255, 175) 214 -> Just (255, 255, 215) 215 -> Just (255, 255, 255) 216 -> Just (8, 8, 8) 217 -> Just (18, 18, 18) 218 -> Just (28, 28, 28) 219 -> Just (38, 38, 38) 220 -> Just (48, 48, 48) 221 -> Just (58, 58, 58) 222 -> Just (68, 68, 68) 223 -> Just (78, 78, 78) 224 -> Just (88, 88, 88) 225 -> Just (98, 98, 98) 226 -> Just (108, 108, 108) 227 -> Just (118, 118, 118) 228 -> Just (128, 128, 128) 229 -> Just (138, 138, 138) 230 -> Just (148, 148, 148) 231 -> Just (158, 158, 158) 232 -> Just (168, 168, 168) 233 -> Just (178, 178, 178) 234 -> Just (188, 188, 188) 235 -> Just (198, 198, 198) 236 -> Just (208, 208, 208) 237 -> Just (218, 218, 218) 238 -> Just (228, 228, 228) 239 -> Just (238, 238, 238) _ -> Nothing vty-5.28.2/src/Graphics/Vty/Config.hs0000644000000000000000000004040607346545000015501 0ustar0000000000000000{-# 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 -- application's use of Vty. -- -- Lines in config files that fail to parse are ignored. Later entries -- take precedence over earlier ones. -- -- = Debug -- -- == @debugLog@ -- -- Format: -- -- @ -- \"debugLog\" string -- @ -- -- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent -- to a debugLog entry at the end of the last config file. -- -- = Input Processing -- -- == @map@ -- -- Format: -- -- @ -- \"map\" term string key modifier_list -- where -- key := KEsc | KChar Char | KBS ... (same as 'Key') -- modifier_list := \"[\" modifier+ \"]\" -- modifier := MShift | MCtrl | MMeta | MAlt -- term := "_" | string -- @ -- -- E.g., if the contents are -- -- @ -- map _ \"\\ESC[B\" KUp [] -- map _ \"\\ESC[1;3B\" KDown [MAlt] -- map \"xterm\" \"\\ESC[D\" KLeft [] -- @ -- -- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all -- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown -- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will -- result in the KLeft event when @TERM@ is @xterm@. -- -- If a debug log is requested then vty will output the current input -- table to the log in the above format. A workflow for using this is -- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for -- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@. -- -- = Unicode Character Width Maps -- -- == @widthMap@ -- -- Format: -- -- @ -- \"widthMap\" string string -- @ -- -- E.g., -- -- @ -- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\" -- @ -- -- This directive specifies the path to a Unicode character width -- map (the second argument) that should be loaded and used when -- the value of TERM matches the first argument. Unicode character -- width maps can be produced either by running the provided binary -- @vty-build-width-table@ or by calling the library routine -- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The -- 'Graphics.Vty.mkVty' function will use these configuration settings -- to attempt to load and install the specified width map. See the -- documentation for 'Graphics.Vty.mkVty' for details. module Graphics.Vty.Config ( InputMap , Config(..) , VtyConfigurationError(..) , userConfig , overrideEnvConfig , standardIOConfig , runParseConfig , parseConfigFile , defaultConfig , getTtyEraseChar , currentTerminalName , vtyConfigPath , widthTableFilename , vtyDataDirectory , terminalWidthTablePath , vtyConfigFileEnvName , ConfigUpdateResult(..) , addConfigWidthMap ) where import Prelude import Control.Applicative hiding (many) import Control.Exception (catch, IOException, Exception(..), throwIO) 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 Graphics.Vty.Input.Events import GHC.Generics import System.Directory ( getAppUserDataDirectory, doesFileExist , createDirectoryIfMissing ) import System.Environment (lookupEnv) import System.FilePath ((), takeDirectory) import System.Posix.IO (stdInput, stdOutput) import System.Posix.Types (Fd(..)) import Foreign.C.Types (CInt(..), CChar(..)) 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 { vmin :: Maybe Int -- ^ The default is 1 character. , vtime :: Maybe Int -- ^ The default is 100 milliseconds, 0.1 seconds. , mouseMode :: Maybe Bool -- ^ The default is False. , bracketedPasteMode :: Maybe Bool -- ^ The default is False. , debugLog :: Maybe FilePath -- ^ Debug information is appended to this file if not -- Nothing. , inputMap :: 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. , inputFd :: Maybe Fd -- ^ The input file descriptor to use. The default is -- 'System.Posix.IO.stdInput' , outputFd :: Maybe Fd -- ^ The output file descriptor to use. The default is -- 'System.Posix.IO.stdOutput' , termName :: Maybe String -- ^ The terminal name used to look up terminfo capabilities. -- The default is the value of the TERM environment variable. , termWidthMaps :: [(String, FilePath)] -- ^ Terminal width map files. , allowCustomUnicodeWidthTables :: 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. } deriving (Show, Eq) defaultConfig :: Config defaultConfig = mempty instance Semigroup Config where c0 <> c1 = -- latter config takes priority for everything but inputMap Config { 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 , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0 , allowCustomUnicodeWidthTables = allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables 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 , termWidthMaps = [] , allowCustomUnicodeWidthTables = Nothing } #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif vtyDataDirectory :: IO FilePath vtyDataDirectory = getAppUserDataDirectory "vty" vtyConfigPath :: IO FilePath vtyConfigPath = do dir <- vtyDataDirectory return $ dir "config" vtyConfigFileEnvName :: String vtyConfigFileEnvName = "VTY_CONFIG_FILE" -- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@. userConfig :: IO Config userConfig = do configFile <- vtyConfigPath >>= parseConfigFile overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< lookupEnv vtyConfigFileEnvName let base = configFile <> overrideConfig mappend base <$> overrideEnvConfig widthTableFilename :: String -> String widthTableFilename term = "width_table_" <> term <> ".dat" termVariable :: String termVariable = "TERM" currentTerminalName :: IO (Maybe String) currentTerminalName = lookupEnv termVariable terminalWidthTablePath :: IO (Maybe FilePath) terminalWidthTablePath = do dataDir <- vtyDataDirectory result <- lookupEnv termVariable case result of Nothing -> return Nothing Just term -> do return $ Just $ dataDir widthTableFilename term overrideEnvConfig :: IO Config overrideEnvConfig = do d <- lookupEnv "VTY_DEBUG_LOG" return $ defaultConfig { debugLog = d } -- | Configures VTY using defaults suitable for terminals. This function -- can raise 'VtyConfigurationError'. standardIOConfig :: IO Config standardIOConfig = do mb <- lookupEnv termVariable 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 } parseConfigFile :: FilePath -> IO Config parseConfigFile path = do catch (runParseConfig path <$> BS.readFile path) (\(_ :: IOException) -> return defaultConfig) runParseConfig :: String -> BS.ByteString -> Config runParseConfig name cfgTxt = case runParser parseConfig () name cfgTxt of Right cfg -> cfg Left{} -> defaultConfig ------------------------------------------------------------------------ type Parser = Parsec BS.ByteString () configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m configLanguage = LanguageDef { commentStart = "{-" , commentEnd = "-}" , commentLine = "--" , nestedComments = True , identStart = letter <|> char '_' , identLetter = alphaNum <|> oneOf "_'" , opStart = opLetter configLanguage , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" , reservedOpNames = [] , reservedNames = [] , caseSensitive = True } configLexer :: Monad m => P.GenTokenParser BS.ByteString () m configLexer = P.makeTokenParser configLanguage mapDecl :: Parser Config mapDecl = do "map" <- P.identifier configLexer termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing) <|> (Just <$> P.stringLiteral configLexer) bytes <- P.stringLiteral configLexer key <- parseValue modifiers <- parseValue return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] } debugLogDecl :: Parser Config debugLogDecl = do "debugLog" <- P.identifier configLexer path <- P.stringLiteral configLexer return defaultConfig { debugLog = Just path } widthMapDecl :: Parser Config widthMapDecl = do "widthMap" <- P.identifier configLexer tName <- P.stringLiteral configLexer path <- P.stringLiteral configLexer return defaultConfig { termWidthMaps = [(tName, path)] } ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline parseConfig :: Parser Config parseConfig = liftM mconcat $ many $ do P.whiteSpace configLexer let directives = [try mapDecl, try debugLogDecl, try widthMapDecl] choice directives <|> (ignoreLine >> return defaultConfig) class Parse a where parseValue :: Parser a instance Parse Char where parseValue = P.charLiteral configLexer instance Parse Int where parseValue = fromInteger <$> P.natural configLexer instance Parse Key where parseValue = genericParse instance Parse Modifier where parseValue = genericParse instance Parse a => Parse [a] where parseValue = P.brackets configLexer (parseValue `sepBy` P.symbol configLexer ",") ------------------------------------------------------------------------ -- Derived parser for ADTs via generics ------------------------------------------------------------------------ genericParse :: (Generic a, GParse (Rep a)) => Parser a genericParse = to <$> gparse class GParse f where gparse :: Parser (f a) instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse instance GParse U1 where gparse = return U1 instance Parse a => GParse (K1 i a) where gparse = K1 <$> parseValue instance (GParse f, GParse g) => GParse (f :*: g) where gparse = (:*:) <$> gparse <*> gparse instance GParseAlts f => GParse (M1 D i f) where gparse = do con <- P.identifier configLexer M1 <$> gparseAlts con ------------------------------------------------------------------------ class GParseAlts f where gparseAlts :: String -> Parser (f a) instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where gparseAlts con = do guard (con == conName (M1 Nothing :: C1 i Maybe a)) M1 <$> gparse instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1" foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar -- | Get the "erase" character for the terminal attached to the -- specified file descriptor. This is the character configured by 'stty -- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'. -- Otherwise it will return the character that has been configured to -- indicate the canonical mode ERASE behavior. That character can then -- be added to the table of strings that we interpret to mean Backspace. -- -- For more details, see: -- -- * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html -- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty -- * https://github.com/matterhorn-chat/matterhorn/issues/565 getTtyEraseChar :: Fd -> IO (Maybe Char) getTtyEraseChar fd = do c <- cGetTtyErase fd if c /= 0 then return $ Just $ toEnum $ fromEnum c else return Nothing data ConfigUpdateResult = ConfigurationCreated | ConfigurationModified | ConfigurationConflict String | ConfigurationRedundant 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 @True@ if the configuration was created or modified and -- @False@ otherwise. 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` termWidthMaps config then return ConfigurationRedundant else case lookup term (termWidthMaps config) of Just other -> return $ ConfigurationConflict other Nothing -> do appendFile configPath directive return ConfigurationModified vty-5.28.2/src/Graphics/Vty/Debug.hs0000644000000000000000000000217407346545000015322 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug ( module Graphics.Vty.Debug , module Graphics.Vty.Debug.Image ) 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 rowOpsAffectedColumns :: DisplayOps -> [Int] rowOpsAffectedColumns ops = Vector.toList $ Vector.map spanOpsAffectedColumns ops allSpansHaveWidth :: DisplayOps -> Int -> Bool allSpansHaveWidth ops expected = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops spanOpsAffectedRows :: DisplayOps -> Int spanOpsAffectedRows ops = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops)) type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr isSetAttr :: Attr -> SpanConstructEvent -> Bool isSetAttr expectedAttr (SpanSetAttr inAttr) | inAttr == expectedAttr = True isSetAttr _attr _event = False data MockWindow = MockWindow Int Int deriving (Show, Eq) regionForWindow :: MockWindow -> DisplayRegion regionForWindow (MockWindow w h) = (w,h) vty-5.28.2/src/Graphics/Vty/Debug/0000755000000000000000000000000007346545000014762 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Debug/Image.hs0000644000000000000000000000137107346545000016342 0ustar0000000000000000{-# 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 vty-5.28.2/src/Graphics/Vty/DisplayAttributes.hs0000644000000000000000000001360307346545000017747 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Graphics.Vty.DisplayAttributes where import Graphics.Vty.Attributes import Data.Bits ((.&.)) import Data.ByteString (ByteString) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -- | Given the previously applied display attributes as a FixedAttr and -- the current display attributes as an Attr produces a FixedAttr that -- represents the current display attributes. This is done by using the -- previously applied display attributes to remove the "KeepCurrent" -- abstraction. fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr fixDisplayAttr fattr attr = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr)) (fixColor (fixedForeColor fattr) (attrForeColor attr)) (fixColor (fixedBackColor fattr) (attrBackColor attr)) (fixURL (fixedURL fattr) (attrURL attr)) where fixStyle _s Default = defaultStyleMask fixStyle s KeepCurrent = s fixStyle _s (SetTo newStyle) = newStyle fixColor _c Default = Nothing fixColor c KeepCurrent = c fixColor _c (SetTo c) = Just c fixURL c KeepCurrent = c fixURL _c (SetTo n) = Just n fixURL _c Default = Nothing -- | difference between two display attributes. Used in the calculation -- of the operations required to go from one display attribute to the -- next. -- -- Previously, vty would reset display attributes to default then apply -- the new display attributes. This turned out to be very expensive: A -- *lot* more data would be sent to the terminal than required. data DisplayAttrDiff = DisplayAttrDiff { styleDiffs :: [StyleStateChange] , foreColorDiff :: DisplayColorDiff , backColorDiff :: DisplayColorDiff , urlDiff :: URLDiff } deriving (Show) instance Semigroup DisplayAttrDiff where d0 <> d1 = let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1) fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1) bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1) ud = simplifyUrlDiffs (urlDiff d0) (urlDiff d1) in DisplayAttrDiff ds fcd bcd ud instance Monoid DisplayAttrDiff where mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | Used in the computation of a final style attribute change. simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange] simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1 -- | Consider two display color attributes diffs. What display color -- attribute diff are these equivalent to? simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplifyColorDiffs _cd ColorToDefault = ColorToDefault simplifyColorDiffs cd NoColorChange = cd simplifyColorDiffs _cd (SetColor !c) = SetColor c -- | Consider two URL changes, which are mostly going to be the latter -- unless the latter specifies no change. simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff simplifyUrlDiffs ud NoLinkChange = ud simplifyUrlDiffs _ ud = ud -- | Difference between two display color attribute changes. data DisplayColorDiff = ColorToDefault | NoColorChange | SetColor !Color deriving (Show, Eq) -- | Style attribute changes are transformed into a sequence of -- apply/removes of the individual attributes. data StyleStateChange = ApplyStandout | RemoveStandout | ApplyItalic | RemoveItalic | ApplyUnderline | RemoveUnderline | ApplyReverseVideo | RemoveReverseVideo | ApplyBlink | RemoveBlink | ApplyDim | RemoveDim | ApplyBold | RemoveBold deriving (Show, Eq) -- Setting and unsetting hyperlinks data URLDiff = LinkTo !ByteString | NoLinkChange | EndLink deriving (Show, Eq) -- | Determines the diff between two display&color attributes. This diff -- determines the operations that actually get output to the terminal. displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff displayAttrDiffs attr attr' = DisplayAttrDiff { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr') , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr') , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr') , urlDiff = diffURL (fixedURL attr) (fixedURL attr') } diffURL :: Maybe Text -> Maybe Text -> URLDiff diffURL Nothing Nothing = NoLinkChange diffURL (Just _) Nothing = EndLink diffURL _ (Just url) = LinkTo (encodeUtf8 url) diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff diffColor Nothing (Just c') = SetColor c' diffColor (Just c) (Just c') | c == c' = NoColorChange | otherwise = SetColor c' diffColor Nothing Nothing = NoColorChange diffColor (Just _) Nothing = ColorToDefault diffStyles :: Style -> Style -> [StyleStateChange] diffStyles prev cur = mconcat [ styleDiff standout ApplyStandout RemoveStandout , styleDiff underline ApplyUnderline RemoveUnderline , styleDiff italic ApplyItalic RemoveItalic , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo , styleDiff blink ApplyBlink RemoveBlink , styleDiff dim ApplyDim RemoveDim , styleDiff bold ApplyBold RemoveBold ] where styleDiff s sm rm = case (0 == prev .&. s, 0 == cur .&. s) of -- not set in either (True, True) -> [] -- set in both (False, False) -> [] -- now set (True, False) -> [sm] -- now unset (False, True) -> [rm] vty-5.28.2/src/Graphics/Vty/Error.hs0000644000000000000000000000041007346545000015354 0ustar0000000000000000module Graphics.Vty.Error where -- | The type of exceptions specific to vty. -- -- These have fully qualified names by default since, IMO, exception -- handling requires this. data VtyException = VtyFailure String -- ^ Uncategorized failure specific to vty. vty-5.28.2/src/Graphics/Vty/Image.hs0000644000000000000000000003150607346545000015317 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -- | A Vty program makes 'Picture's from 'Image's. This module provides -- the core constructors for creating, combining, and modifying -- 'Image's. module Graphics.Vty.Image ( -- * Images Image , imageWidth , imageHeight -- * Image constructors , emptyImage , char , string , iso10646String , utf8String , text , text' , backgroundFill , utf8Bytestring , utf8Bytestring' , charFill -- * Combinators , horizJoin , (<|>) , vertJoin , (<->) , horizCat , vertCat -- * Image modifications , crop , cropRight , cropLeft , cropBottom , cropTop , pad , resize , resizeWidth , resizeHeight , translate , translateX , translateY -- * Character width functions , safeWcwidth , safeWcswidth , safeWctwidth , safeWctlwidth , wcwidth , wcswidth , wctwidth , wctlwidth -- * Display Regions , DisplayText , DisplayRegion , regionWidth , regionHeight ) where import Graphics.Vty.Attributes import Graphics.Vty.Image.Internal import Graphics.Text.Width import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Word -- | A region of the display (first width, then height) type DisplayRegion = (Int,Int) regionWidth :: DisplayRegion -> Int regionWidth = fst regionHeight :: DisplayRegion -> Int regionHeight = snd infixr 5 <|> infixr 4 <-> -- | An area of the picture's background (See 'Background'). backgroundFill :: Int -- ^ Fill width in columns -> Int -- ^ Fill height in rows -> Image backgroundFill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h -- | Combines two images horizontally. This is an alias for 'horizJoin'. -- -- infixr 5 (<|>) :: Image -> Image -> Image (<|>) = horizJoin -- | Combines two images vertically. This is an alias for 'vertJoin'. -- -- infixr 4 (<->) :: Image -> Image -> Image (<->) = vertJoin -- | Compose any number of images together horizontally, with the first -- in the list being leftmost. horizCat :: [Image] -> Image horizCat = foldr horizJoin EmptyImage -- | Compose any number of images vertically, with the first in the list -- being topmost. vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage -- | Make an 'Image' from a lazy text value. This function should not be -- given a text value containing escapes. text :: Attr -> TL.Text -> Image text a txt = let displayWidth = safeWctlwidth txt in HorizText a txt displayWidth (fromIntegral $! TL.length txt) -- | Make an 'Image' from a text value. This function should not be -- given a text value containing escapes. text' :: Attr -> T.Text -> Image text' a txt = let displayWidth = safeWctwidth txt in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) -- | Make an image from a single character. This is a standard Haskell -- 31-bit character assumed to be in the ISO-10646 encoding. char :: Attr -> Char -> Image char a c = let displayWidth = safeWcwidth c in HorizText a (TL.singleton c) displayWidth 1 -- | Make an image from a string of characters layed 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. -- -- Note: depending on how the Haskell compiler represents string -- literals, a string literal in a UTF-8 encoded source file, for -- example, may be represented as a ISO-10646 string. That is, I think, -- the case with GHC 6.10. This means, for the most part, you don't need -- to worry about the encoding format when outputting string literals. -- Just provide the string literal directly to iso10646String or string. iso10646String :: Attr -> String -> Image iso10646String a str = let displayWidth = safeWcswidth str in HorizText a (TL.pack str) displayWidth (length str) -- | Make an 'Image' from a 'String'. -- -- This is an alias for iso10646String since the usual case is that a -- literal string like "foo" is represented internally as a list of ISO -- 10646 31 bit characters. This function should not be given a string -- containing escapes. -- -- Note: Keep in mind that GHC will compile source encoded as UTF-8 -- but the literal strings, while UTF-8 encoded in the source, will be -- transcoded to a ISO 10646 31 bit characters runtime representation. string :: Attr -> String -> Image string = iso10646String -- | Make an 'Image' from a string of characters layed out on a single -- row. The input is assumed to be the bytes for UTF-8 encoded text. utf8String :: Attr -> [Word8] -> Image utf8String a bytes = utf8Bytestring a (BL.pack bytes) -- | Make an 'Image' from a UTF-8 encoded lazy bytestring. utf8Bytestring :: Attr -> BL.ByteString -> Image utf8Bytestring a bs = text a (TL.decodeUtf8 bs) -- | Make an 'Image' from a UTF-8 encoded strict bytestring. utf8Bytestring' :: Attr -> B.ByteString -> Image utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) -- | Make an image filling a region with the specified character. -- -- If either the width or height are less than or equal to 0, then -- the result is the empty image. charFill :: Integral d => Attr -- ^ The attribute to use. -> Char -- ^ The character to use in filling the region. -> d -- ^ The region width. -> d -- ^ The region height. -> Image charFill a c w h | w <= 0 || h <= 0 = EmptyImage | otherwise = vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth where txt = TL.replicate charWidth (TL.singleton c) displayWidth = safeWcwidth c * charWidth charWidth :: Num a => a charWidth = fromIntegral w -- | The empty image. Useful for fold combinators. These occupy no space -- and do not affect display attributes. emptyImage :: Image emptyImage = EmptyImage -- | Pad the given image. This adds background character fills to the -- left, top, right, bottom. pad :: Int -- ^ How much padding to add to the left side of the image. -> Int -- ^ How much padding to add to the top of the image. -> Int -- ^ How much padding to add to the right side of the image. -> Int -- ^ How much padding to add to the bottom of the image. -> Image -- ^ The image to pad. -> Image pad 0 0 0 0 i = i pad inL inT inR inB inImage | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount" | otherwise = go inL inT inR inB inImage where go 0 0 0 0 i = i go 0 0 0 b i = VertJoin i (BGFill w b) w h where w = imageWidth i h = imageHeight i + b go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h where w = imageWidth i + r h = imageHeight i go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h where w = imageWidth i h = imageHeight i + t go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h where w = imageWidth i + l h = imageHeight i -- | Translates an image by padding or cropping the left and top. -- -- If translation offsets are negative then the image is cropped. translate :: Int -- ^ The horizontal translation offset (can be negative) -> Int -- ^ The vertical translation offset (can be negative) -> Image -- ^ The image to translate. -> Image translate x y i = translateX x (translateY y i) -- | Translates an image by padding or cropping its left side. translateX :: Int -> Image -> Image translateX x i | x < 0 && (abs x > imageWidth i) = emptyImage | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i) | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h -- | Translates an image by padding or cropping its top. translateY :: Int -> Image -> Image translateY y i | y < 0 && (abs y > imageHeight i) = emptyImage | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s) | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) -- | Ensure an image is no larger than the provided size. If the image -- is larger then crop the right or bottom. -- -- This is equivalent to a vertical crop from the bottom followed by -- horizontal crop from the right. crop :: Int -- ^ Cropping width -> Int -- ^ Cropping height -> Image -- ^ The image to crop -> Image crop 0 _ _ = EmptyImage crop _ 0 _ = EmptyImage crop w h i = cropBottom h (cropRight w i) -- | Crop an image's height. If the image's height is less than or equal -- to the specified height then this operation has no effect. Otherwise -- the image is cropped from the bottom. cropBottom :: Int -> Image -> Image cropBottom 0 _ = EmptyImage cropBottom h inI | h < 0 = error "cannot crop height to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropBottom {croppedImage, outputWidth, outputHeight}) | outputHeight <= h = i | otherwise = CropBottom croppedImage outputWidth h go i | h >= imageHeight i = i | otherwise = CropBottom i (imageWidth i) h -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise -- the image is cropped from the right. cropRight :: Int -> Image -> Image cropRight 0 _ = EmptyImage cropRight w inI | w < 0 = error "cannot crop width to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropRight {croppedImage, outputWidth, outputHeight}) | outputWidth <= w = i | otherwise = CropRight croppedImage w outputHeight go i | w >= imageWidth i = i | otherwise = CropRight i w (imageHeight i) -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise -- the image is cropped from the left. cropLeft :: Int -> Image -> Image cropLeft 0 _ = EmptyImage cropLeft w inI | w < 0 = error "cannot crop the width to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) | outputWidth <= w = i | otherwise = let leftSkip' = leftSkip + outputWidth - w in CropLeft croppedImage leftSkip' w outputHeight go i | imageWidth i <= w = i | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i) -- | Crop an image's height. If the image's height is less than or equal -- to the specified height then this operation has no effect. Otherwise -- the image is cropped from the top. cropTop :: Int -> Image -> Image cropTop 0 _ = EmptyImage cropTop h inI | h < 0 = error "cannot crop the height to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight}) | outputHeight <= h = i | otherwise = let topSkip' = topSkip + outputHeight - h in CropTop croppedImage topSkip' outputWidth h go i | imageHeight i <= h = i | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h -- | Generic resize. Pads and crops are added to ensure that the -- resulting image matches the specified dimensions. This is biased to -- pad/crop the right and bottom. resize :: Int -> Int -> Image -> Image resize w h i = resizeHeight h (resizeWidth w i) -- | Resize the width. Pads and crops as required to assure the given -- display width. This is biased to pad/crop on the right. resizeWidth :: Int -> Image -> Image resizeWidth w i = case w `compare` imageWidth i of LT -> cropRight w i EQ -> i GT -> i <|> BGFill (w - imageWidth i) (imageHeight i) -- | Resize the height. Pads and crops as required to assure the given -- display height. This is biased to pad/crop on the bottom. resizeHeight :: Int -> Image -> Image resizeHeight h i = case h `compare` imageHeight i of LT -> cropBottom h i EQ -> i GT -> i <-> BGFill (imageWidth i) (h - imageHeight i) vty-5.28.2/src/Graphics/Vty/Image/0000755000000000000000000000000007346545000014756 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Image/Internal.hs0000644000000000000000000002542307346545000017074 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} module Graphics.Vty.Image.Internal where import Graphics.Vty.Attributes import Graphics.Text.Width import GHC.Generics import Control.DeepSeq #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import qualified Data.Text.Lazy as TL -- | A display text is a Data.Text.Lazy type DisplayText = TL.Text clipText :: DisplayText -> Int -> Int -> DisplayText clipText txt leftSkip rightClip = -- CPS would clarify this I think let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0 txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt (toTake,padSuffix) = clipForCharWidth rightClip txt' 0 txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty) -- Note: some characters and zero-width and combining characters -- combine to the left, so keep taking characters even if the -- width is zero. clipForCharWidth w t n | TL.null t = (n, False) | w < cw = (n, w /= 0) | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1) where cw = safeWcwidth (TL.head t) in txt'' -- | This is the internal representation of Images. Use the constructors -- in "Graphics.Vty.Image" to create instances. -- -- Images are: -- -- * a horizontal span of text -- -- * a horizontal or vertical join of two images -- -- * a two dimensional fill of the 'Picture's background character -- -- * a cropped image -- -- * an empty image of no size or content. data Image = -- | A horizontal text span has a row height of 1. HorizText { attr :: Attr -- | The text to display. The display width of the text is always -- outputWidth. , displayText :: DisplayText -- | The number of display columns for the text. , outputWidth :: Int -- | the number of characters in the text. , charWidth :: Int } -- | A horizontal join can be constructed between any two images. -- However a HorizJoin instance is required to be between two images -- of equal height. The horizJoin constructor adds background fills -- to the provided images that assure this is true for the HorizJoin -- value produced. | HorizJoin { partLeft :: Image , partRight :: Image , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 0 , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0 } -- | A veritical join can be constructed between any two images. -- However a VertJoin instance is required to be between two images -- of equal width. The vertJoin constructor adds background fills -- to the provides images that assure this is true for the VertJoin -- value produced. | VertJoin { partTop :: Image , partBottom :: Image , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0 , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1 } -- | A background fill will be filled with the background char. The -- background char is defined as a property of the Picture this -- Image is used to form. | BGFill { outputWidth :: Int -- ^ always > 0 , outputHeight :: Int -- ^ always > 0 } -- | Crop an image 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 { croppedImage :: Image -- | Always < imageWidth croppedImage > 0 , leftSkip :: Int -- | Always < imageWidth croppedImage > 0 , outputWidth :: Int , outputHeight :: Int } -- | Crop an image vertically to a size by reducing the size from -- the bottom | CropBottom { croppedImage :: Image -- | imageWidth croppedImage , outputWidth :: Int -- | height image is cropped to. Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | Crop an image vertically to a size by reducing the size from -- the top | CropTop { croppedImage :: Image -- | Always < imageHeight croppedImage > 0 , topSkip :: Int -- | imageWidth croppedImage , outputWidth :: Int -- | Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | The empty image -- -- The combining operators identity constant. -- EmptyImage <|> a = a -- EmptyImage <-> a = a -- -- Any image of zero size equals the empty image. | EmptyImage deriving (Eq, Generic, Show, Read) -- | pretty print just the structure of an image. ppImageStructure :: Image -> String ppImageStructure inImg = go 0 inImg where go indent img = tab indent ++ pp indent img tab indent = concat $ replicate indent " " pp _ (HorizText {outputWidth}) = "HorizText(" ++ show outputWidth ++ ")" pp _ (BGFill {outputWidth, outputHeight}) = "BGFill(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")" pp i (HorizJoin {partLeft = l, partRight = r, outputWidth = c}) = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r pp i (VertJoin {partTop = t, partBottom = b, outputWidth = c, outputHeight = r}) = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n" ++ go (i+1) t ++ "\n" ++ go (i+1) b pp i (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" ++ 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 (BGFill w h) = w `seq` h `seq` () rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` () rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` () rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` () -- | The width of an Image. This is the number display columns the image -- will occupy. imageWidth :: Image -> Int imageWidth HorizText { outputWidth = w } = w imageWidth HorizJoin { outputWidth = w } = w imageWidth VertJoin { outputWidth = w } = w imageWidth BGFill { outputWidth = w } = w imageWidth CropRight { outputWidth = w } = w imageWidth CropLeft { outputWidth = w } = w imageWidth CropBottom { outputWidth = w } = w imageWidth CropTop { outputWidth = w } = w imageWidth EmptyImage = 0 -- | The height of an Image. This is the number of display rows the -- image will occupy. imageHeight :: Image -> Int imageHeight HorizText {} = 1 imageHeight HorizJoin { outputHeight = h } = h imageHeight VertJoin { outputHeight = h } = h imageHeight BGFill { outputHeight = h } = h imageHeight CropRight { outputHeight = h } = h imageHeight CropLeft { outputHeight = h } = h imageHeight CropBottom { outputHeight = h } = h imageHeight CropTop { outputHeight = h } = h imageHeight EmptyImage = 0 -- | Append in the 'Semigroup' instance is equivalent to '<->'. instance Semigroup Image where (<>) = vertJoin -- | Append in the 'Monoid' instance is equivalent to '<->'. instance Monoid Image where mempty = EmptyImage #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | combines two images side by side -- -- Combines text chunks where possible. Assures outputWidth and -- outputHeight properties are not violated. -- -- The result image will have a width equal to the sum of the two images -- width. And the height will equal the largest height of the two -- images. The area not defined in one image due to a height missmatch -- will be filled with the background pattern. horizJoin :: Image -> Image -> Image horizJoin EmptyImage i = i horizJoin i EmptyImage = i horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1) | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1) -- assumes horiz text height is always 1 | otherwise = HorizJoin i0 i1 (w0 + w1) 1 horizJoin i0 i1 -- If the images are of the same height then no padding is required | h0 == h1 = HorizJoin i0 i1 w h0 -- otherwise one of the images needs to be padded to the right size. | h0 < h1 -- Pad i0 = let padAmount = h1 - h0 in HorizJoin (VertJoin i0 (BGFill w0 padAmount) w0 h1) i1 w h1 | h0 > h1 -- Pad i1 = let padAmount = h0 - h1 in HorizJoin i0 (VertJoin i1 (BGFill w1 padAmount) w1 h0) w h0 where w0 = imageWidth i0 w1 = imageWidth i1 w = w0 + w1 h0 = imageHeight i0 h1 = imageHeight i1 horizJoin _ _ = error "horizJoin applied to undefined values." -- | combines two images vertically -- -- The result image will have a height equal to the sum of the heights -- of both images. The width will equal the largest width of the two -- images. The area not defined in one image due to a width missmatch -- will be filled with the background pattern. vertJoin :: Image -> Image -> Image vertJoin EmptyImage i = i vertJoin i EmptyImage = i vertJoin i0 i1 -- If the images are of the same width then no background padding is -- required | w0 == w1 = VertJoin i0 i1 w0 h -- Otherwise one of the images needs to be padded to the size of the -- other image. | w0 < w1 = let padAmount = w1 - w0 in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h | w0 > w1 = let padAmount = w0 - w1 in VertJoin i0 (HorizJoin i1 (BGFill padAmount h1) w0 h1) w0 h where w0 = imageWidth i0 w1 = imageWidth i1 h0 = imageHeight i0 h1 = imageHeight i1 h = h0 + h1 vertJoin _ _ = error "vertJoin applied to undefined values." vty-5.28.2/src/Graphics/Vty/Inline.hs0000644000000000000000000001070207346545000015506 0ustar0000000000000000{-# 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. -- -- The changes specified by the InlineM monad are applied to the -- terminal's display attributes. These display attributes affect the -- display of all following text output to the terminal file descriptor. -- -- For example, in an IO monad the following code will print the text -- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red -- background and underlined. -- -- @ -- putStr \"Not styled. \" -- putAttrChange_ $ do -- backColor red -- applyStyle underline -- putStr \" Styled! \" -- putAttrChange_ $ defaultAll -- putStrLn \"Not styled.\" -- @ -- -- 'putAttrChange' emits the control codes to the terminal device -- attached to 'Handle'. This is a duplicate of the 'stdout' handle when -- the 'terminalHandle' was (first) acquired. If 'stdout' has since been -- changed then 'putStr', 'putStrLn', 'print' etc. will output to a -- different 'Handle' than 'putAttrChange'. -- -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Inline ( module Graphics.Vty.Inline , withVty ) where import Graphics.Vty import Graphics.Vty.DisplayAttributes import Graphics.Vty.Inline.Unsafe import Blaze.ByteString.Builder (writeToByteString) import Control.Monad.State.Strict import Data.Bits ( (.&.), complement ) import Data.IORef import System.IO type InlineM v = State InlineState v data InlineState = InlineState { inlineAttr :: Attr , inlineUrlsEnabled :: Bool } -- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM () backColor c = modify $ \s -> s { inlineAttr = inlineAttr s `mappend` (currentAttr `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) } -- | Attempt to change the 'Style' of the following text.. -- -- If the terminal does not support the style change then no error is -- produced. The style can still be removed. applyStyle :: Style -> InlineM () applyStyle st = modify $ \s -> s { inlineAttr = inlineAttr s `mappend` (currentAttr `withStyle` st) } -- | Attempt to remove the specified 'Style' from the display of the -- following text. -- -- This will fail if 'applyStyle' for the given style has not been -- previously called. removeStyle :: Style -> InlineM () removeStyle sMask = modify $ \s -> s { inlineAttr = let style' = case attrStyle (inlineAttr s) of Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." SetTo st -> st .&. complement sMask in (inlineAttr s) { attrStyle = SetTo style' } } -- | Reset the display attributes. defaultAll :: InlineM () defaultAll = modify $ \s -> s { inlineAttr = defAttr } -- | Apply the provided display attribute changes to the given terminal -- output device. -- -- This does not flush the terminal. putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () putAttrChange out c = liftIO $ do bounds <- displayBounds out dc <- displayContext out bounds mfattr <- prevFattr <$> readIORef (assumedStateRef out) fattr <- case mfattr of Nothing -> do liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False return $ FixedAttr defaultStyleMask Nothing Nothing Nothing Just v -> return v let InlineState attr urlsEnabled = execState c (InlineState currentAttr False) attr' = limitAttrForDisplay out attr fattr' = fixDisplayAttr fattr attr' diffs = displayAttrDiffs fattr fattr' outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' } inlineHack dc -- | Apply the provided display attributes changes to the terminal -- output device. -- -- This will flush the terminal output. putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m () putAttrChange_ c = liftIO $ withOutput $ \out -> do hFlush stdout putAttrChange out c hFlush stdout vty-5.28.2/src/Graphics/Vty/Inline/0000755000000000000000000000000007346545000015152 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Inline/Unsafe.hs0000644000000000000000000000323407346545000016731 0ustar0000000000000000{-# 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 vty-5.28.2/src/Graphics/Vty/Input.hs0000644000000000000000000001572607346545000015402 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} -- | 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/ module Graphics.Vty.Input ( Key(..) , Modifier(..) , Button(..) , Event(..) , Input(..) , inputForConfig ) 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 #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -- | 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 vty-5.28.2/src/Graphics/Vty/Input/0000755000000000000000000000000007346545000015033 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Input/Classify.hs0000644000000000000000000000624207346545000017150 0ustar0000000000000000{-# 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 vty-5.28.2/src/Graphics/Vty/Input/Classify/0000755000000000000000000000000007346545000016610 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Input/Classify/Parse.hs0000644000000000000000000000316207346545000020220 0ustar0000000000000000-- | 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 vty-5.28.2/src/Graphics/Vty/Input/Classify/Types.hs0000644000000000000000000000106507346545000020252 0ustar0000000000000000-- | 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) vty-5.28.2/src/Graphics/Vty/Input/Events.hs0000644000000000000000000000546407346545000016644 0ustar0000000000000000{-# Language DeriveGeneric #-} module Graphics.Vty.Input.Events where import Data.ByteString import GHC.Generics -- | Representations of non-modifier keys. -- -- * KFun is indexed from 0 to 63. Range of supported FKeys varies by -- terminal and keyboard. -- -- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by -- terminal and keyboard. -- -- * Actually, support for most of these but KEsc, KChar, KBS, and -- KEnter vary by terminal and keyboard. data Key = KEsc | KChar Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter | KFun Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu deriving (Eq,Show,Read,Ord,Generic) -- | Modifier keys. Key codes are interpreted such that users are more -- likely to have Meta than Alt; for instance on the PC Linux console, -- 'MMeta' will generally correspond to the physical Alt key. data Modifier = MShift | MCtrl | MMeta | MAlt deriving (Eq,Show,Read,Ord,Generic) -- | Mouse buttons. data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown deriving (Eq,Show,Read,Ord,Generic) -- | Events. data Event = EvKey Key [Modifier] -- ^ A keyboard key was pressed with the specified modifiers. | EvMouseDown Int Int Button [Modifier] -- ^ A mouse button was pressed at the specified column and row. Any -- modifiers available in the event are also provided. | EvMouseUp Int Int (Maybe Button) -- ^ A mouse button was released at the specified column and -- row. Some terminals report only that a button was released -- without specifying which one; in that case, Nothing is provided. -- Otherwise Just the button released is included in the event. | EvResize Int Int -- ^ 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. | EvPaste ByteString -- ^ A paste event occurs when a bracketed paste input sequence is -- received. For terminals that support bracketed paste mode, these -- events will be triggered on a paste event. Terminals that do not -- support bracketed pastes will send the paste contents as ordinary -- input (which is probably bad, so beware!) Note that the data is -- provided in raw form and you'll have to decode (e.g. as UTF-8) if -- that's what your application expects. | EvLostFocus -- ^ The terminal running the application lost input focus. | EvGainedFocus -- ^ The terminal running the application gained input focus. deriving (Eq,Show,Read,Ord,Generic) type ClassifyMap = [(String,Event)] vty-5.28.2/src/Graphics/Vty/Input/Focus.hs0000644000000000000000000000220307346545000016443 0ustar0000000000000000module 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 vty-5.28.2/src/Graphics/Vty/Input/Loop.hs0000644000000000000000000002035507346545000016305 0ustar0000000000000000{-# 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) vty-5.28.2/src/Graphics/Vty/Input/Mouse.hs0000644000000000000000000001067007346545000016463 0ustar0000000000000000-- | 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 vty-5.28.2/src/Graphics/Vty/Input/Paste.hs0000644000000000000000000000312207346545000016441 0ustar0000000000000000-- | 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) vty-5.28.2/src/Graphics/Vty/Input/Terminfo.hs0000644000000000000000000001233507346545000017156 0ustar0000000000000000{-# 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) []) vty-5.28.2/src/Graphics/Vty/Input/Terminfo/0000755000000000000000000000000007346545000016616 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs0000644000000000000000000000536207346545000020164 0ustar0000000000000000-- | 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 ] vty-5.28.2/src/Graphics/Vty/Output.hs0000644000000000000000000000731207346545000015573 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NamedFieldPuns, CPP #-} -- | 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. module Graphics.Vty.Output ( outputForConfig , setCursorPos , hideCursor , showCursor ) where 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 Data.List (isPrefixOf) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -- | 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 case mouseMode of Just s -> setMode t Mouse s Nothing -> return () case bracketedPasteMode of Just s -> setMode t BracketedPaste s Nothing -> return () return t outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig -- | Sets the cursor position to the given output column and row. -- -- This is not necessarially the same as the character position with the -- same coordinates. Characters can be a variable number of columns in -- width. -- -- Currently, the only way to set the cursor position to a given -- character coordinate is to specify the coordinate in the Picture -- instance provided to 'outputPicture' or 'refresh'. setCursorPos :: Output -> Int -> Int -> IO () setCursorPos t x y = do bounds <- displayBounds t when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do dc <- displayContext t bounds outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y -- | Hides the cursor. hideCursor :: Output -> IO () hideCursor t = do bounds <- displayBounds t dc <- displayContext t bounds outputByteBuffer t $ writeToByteString $ writeHideCursor dc -- | Shows the cursor. showCursor :: Output -> IO () showCursor t = do bounds <- displayBounds t dc <- displayContext t bounds outputByteBuffer t $ writeToByteString $ writeShowCursor dc vty-5.28.2/src/Graphics/Vty/Output/0000755000000000000000000000000007346545000015234 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/Output/Interface.hs0000644000000000000000000003235007346545000017473 0ustar0000000000000000-- 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 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 :: 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 () -- | Returns the current display bounds. , displayBounds :: IO 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 :: 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 } 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) 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' vty-5.28.2/src/Graphics/Vty/Output/Mock.hs0000644000000000000000000000717607346545000016474 0ustar0000000000000000-- Copyright Corey O'Connor {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -- | This provides a mock terminal implementation that is nice for -- testing. This transforms the output operations to visible characters -- which is useful for testing. module Graphics.Vty.Output.Mock ( MockData , mockTerminal ) where import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder.Word (writeWord8) import Control.Monad.Trans import qualified Data.ByteString as BS import Data.IORef import qualified Data.String.UTF8 as UTF8 type MockData = IORef (UTF8.UTF8 BS.ByteString) -- | The mock display terminal produces a string representation of -- the requested picture. There is *not* an isomorphism between the -- string representation and the picture. The string representation is -- a simplification of the picture that is only useful in debugging VTY -- without considering terminal specific issues. -- -- The mock implementation is useful in manually determining if the -- sequence of terminal operations matche the expected sequence. The -- requirement of the produced representation is simplicity in parsing -- the text representation and determining how the picture was mapped to -- terminal operations. -- -- The string representation is a sequence of identifiers where each -- identifier is the name of an operation in the algebra. mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output) mockTerminal r = liftIO $ do outRef <- newIORef undefined newAssumedStateRef <- newIORef initialAssumedState let t = Output { terminalID = "mock terminal" , releaseTerminal = return () , reserveDisplay = return () , releaseDisplay = return () , ringTerminalBell = return () , supportsBell = return False , 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 , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual -- A cursor move is always visualized as the single -- character 'M' , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M' -- Show cursor is always visualized as the single -- character 'S' , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S' -- Hide cursor is always visualized as the single -- character 'H' , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H' -- An attr change is always visualized as the single -- character 'A' , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A' -- default attr is always visualized as the single -- character 'D' , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D' -- row end is always visualized as the single character -- 'E' , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E' , inlineHack = return () } } return (outRef, t) vty-5.28.2/src/Graphics/Vty/Output/TerminfoBased.hs0000644000000000000000000005413707346545000020324 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# 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 Data.Bits ((.&.)) import Data.IORef import Data.Maybe (isJust, isNothing, fromJust) import Data.Word #if !MIN_VERSION_base(4,8,0) import Data.Foldable (foldMap) #endif 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 :: String -> Fd -> IO Output reserveTerminal termName outFd = 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 -> do writeIORef hyperlinkModeStatus newStatus writeIORef newAssumedStateRef initialAssumedState _ -> return () terminfoModeStatus m = case m of Hyperlink -> 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 = do sendCap setDefaultAttr [] maybeSendCap cnorm [] , supportsBell = return $ isJust $ ringBellAudio terminfoCaps , ringTerminalBell = maybeSendCap ringBellAudio [] , reserveDisplay = 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 = do maybeSendCap rmcup [] maybeSendCap cnorm [] , displayBounds = do rawSize <- 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 -> terminfoDisplayContext tActual terminfoCaps } sendCap s = sendCapToTerminal t (s terminfoCaps) maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) return t requireCap :: Terminfo.Terminal -> String -> IO 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 :: Terminfo.Terminal -> String -> IO (Maybe CapExpression) probeCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> return Nothing Just capStr -> Just <$> parseCap capStr parseCap :: String -> IO CapExpression parseCap capStr = do case parseCapExpression capStr of Left e -> fail $ show e Right cap -> return cap currentDisplayAttrCaps :: Terminfo.Terminal -> IO 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 = 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` setItalics `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` setItalics `mappend` setColors where urlAttrs True = writeURLEscapes (urlDiff diffs) urlAttrs False = mempty colorMap = case useAltColorMap terminfoCaps of False -> ansiColorIndex True -> altColorIndex attr = fixDisplayAttr prevAttr reqAttr -- italics can't be set via SGR, so here we manually -- apply the enter and exit sequences as needed after -- changing the SGR setItalics | hasStyle (fixedStyle attr) italic , Just sitm <- enterItalic (displayAttrCaps terminfoCaps) = writeCapExpr sitm [] | otherwise = mempty 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 , 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 ApplyBold bold ] where applyIfRequired op flag = if 0 == (flag .&. s) then [] else [op] vty-5.28.2/src/Graphics/Vty/Output/XTermColor.hs0000644000000000000000000001074307346545000017633 0ustar0000000000000000{-# Language CPP #-} -- 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) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -- | 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 vty-5.28.2/src/Graphics/Vty/Picture.hs0000644000000000000000000000726607346545000015716 0ustar0000000000000000{-# 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. module Graphics.Vty.Picture ( Picture(..) , Cursor(..) , Background(..) , emptyPicture , addToTop , addToBottom , picForImage , picForLayers , picImage ) where import Graphics.Vty.Image import Graphics.Vty.Attributes import Control.DeepSeq -- | A Vty picture. -- -- These can be constructed directly or using `picForImage`. data Picture = Picture { picCursor :: Cursor -- ^ The picture's cursor. , picLayers :: [Image] -- ^ The picture's image layers (top-most first). , picBackground :: Background -- ^ The picture's background to be displayed in locations with no -- Image data. } deriving Eq instance Show Picture where show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??" instance NFData Picture where rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () -- | A picture with no cursor, background or image layers. emptyPicture :: Picture emptyPicture = Picture NoCursor [] ClearBackground -- | Add an 'Image' as the top-most layer of a 'Picture'. addToTop :: Picture -> Image -> Picture addToTop p i = p {picLayers = i : picLayers p} -- | Add an 'Image' as the bottom-most layer of a 'Picture'. addToBottom :: Picture -> Image -> Picture addToBottom p i = p {picLayers = picLayers p ++ [i]} -- | Create a picture from the given image. The picture will not have a -- displayed cursor and no background pattern (ClearBackground) will be -- used. picForImage :: Image -> Picture picForImage i = Picture { picCursor = NoCursor , picLayers = [i] , picBackground = ClearBackground } -- | Create a picture with the given layers, top-most first. -- -- The picture will not have a displayed cursor and no background -- pattern (ClearBackgroun) will be used. picForLayers :: [Image] -> Picture picForLayers is = Picture { picCursor = NoCursor , picLayers = is , picBackground = ClearBackground } -- | A picture can be configured to hide the cursor or to show the -- cursor at the specified character position. -- -- There is not a 1:1 map from character positions to a row and column -- on the screen due to characters that take more than 1 column. data Cursor = -- | Hide the cursor NoCursor -- | 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 instance NFData Cursor where rnf c = c `seq` () -- | A 'Picture' has a background pattern. The background is either: -- -- * ClearBackground, which shows the layer below or is blank if the -- bottom layer -- * A character and a display attribute -- -- If the display attribute used previously should be used for a -- background fill then use `currentAttr` for the background attribute. data Background = Background { backgroundChar :: Char , backgroundAttr :: Attr } -- | A ClearBackground is: -- -- * the space character if there are remaining non-skip ops -- -- * End of line if there are no remaining non-skip ops. | ClearBackground deriving Eq instance NFData Background where rnf (Background c a) = c `seq` a `seq` () rnf ClearBackground = () -- | Return the top-most 'Image' layer for a picture. This is unsafe for -- 'Picture's without at least one layer. -- -- This is provided for compatibility with applications that do not use -- more than a single layer. picImage :: Picture -> Image picImage = head . picLayers vty-5.28.2/src/Graphics/Vty/PictureToSpans.hs0000644000000000000000000003503607346545000017222 0ustar0000000000000000-- Copyright Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -- | Transforms an image into rows of operations. module Graphics.Vty.PictureToSpans where import Graphics.Vty.Attributes (Attr, currentAttr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal import Graphics.Vty.Picture import Graphics.Vty.Span import Lens.Micro import Lens.Micro.Mtl import Lens.Micro.TH import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) import Control.Monad.ST.Strict import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..)) import qualified Data.Vector.Mutable as MVector import qualified Data.Text.Lazy as TL type MRowOps s = MVector s SpanOps type MSpanOps s = MVector s SpanOp -- transform plus clip. More or less. data BlitState = BlitState -- we always snoc to the operation vectors. Thus the columnOffset = -- length of row at rowOffset although, one possibility is to merge -- layers right in snocOp (naming it something else, of course). In -- which case columnnOffset would be applicable. Right now we need -- it to exist. { _columnOffset :: Int , _rowOffset :: Int -- clip coordinate space is in image space. Which means it's >= 0 -- and < imageWidth. , _skipColumns :: Int -- >= 0 and < imageHeight , _skipRows :: Int -- includes consideration of skipColumns. In display space. The -- number of columns from the next column to be defined to the end -- of the display for the row. , _remainingColumns :: Int -- includes consideration of skipRows. In display space. , _remainingRows :: Int } makeLenses ''BlitState data BlitEnv s = BlitEnv { _region :: DisplayRegion , _mrowOps :: MRowOps s } makeLenses ''BlitEnv type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a -- | Produces the span ops that will render the given picture, possibly -- cropped or padded, into the specified region. displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r) -- | 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) case layerOps of [] -> fail "empty picture" [ops] -> substituteSkips (picBackground pic) ops -- instead of merging ops after generation the merging can -- be performed as part of snocOp. topOps : lowerOps -> do ops <- foldM mergeUnder topOps lowerOps substituteSkips (picBackground pic) ops substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s) substituteSkips ClearBackground ops = do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row -- the image operations assure that background fills are -- combined. clipping a background fill does not split the -- background fill. merging of image layers can split a skip, -- but only by the insertion of a non skip. all this combines to -- mean we can check the last operation and remove it if it's a -- skip let rowOps' = case Vector.last rowOps of Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w _ -> rowOps -- now all the skips can be replaced by replications of ' ' of -- the required width. let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps' MVector.write ops row rowOps'' return ops substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do -- At this point we decide if the background character is single -- column or not. obviously, single column is easier. case safeWcwidth backgroundChar of w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar | w == 1 -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row let rowOps' = swapSkipsForSingleColumnCharSpan backgroundChar backgroundAttr rowOps MVector.write ops row rowOps' | otherwise -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row let rowOps' = swapSkipsForCharSpan w backgroundChar backgroundAttr rowOps MVector.write ops row rowOps' return ops mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s) mergeUnder upper lower = do forM_ [0 .. MVector.length upper - 1] $ \row -> do upperRowOps <- MVector.read upper row lowerRowOps <- MVector.read lower row let rowOps = mergeRowUnder upperRowOps lowerRowOps MVector.write upper row rowOps return upper mergeRowUnder :: SpanOps -> SpanOps -> SpanOps mergeRowUnder upperRowOps lowerRowOps = onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps where -- H: it will never be the case that we are out of upper ops -- before lower ops. onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps = let lowerOps' = dropOps w lowerOps outOps' = Vector.snoc outOps op in if Vector.null lowerOps' then outOps' else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps' onUpperOp outOps (Skip w) upperOps lowerOps = let (ops', lowerOps') = splitOpsAt w lowerOps outOps' = outOps `mappend` ops' in if Vector.null lowerOps' then outOps' else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps' onUpperOp _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops" swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f where f (Skip ow) = let txt = TL.pack $ replicate ow c in TextSpan a ow ow txt f v = v swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps swapSkipsForCharSpan w c a = Vector.map f where f (Skip ow) = let txt0Cw = ow `div` w txt0 = TL.pack $ replicate txt0Cw c txt1Cw = ow `mod` w txt1 = TL.pack $ replicate txt1Cw '…' cw = txt0Cw + txt1Cw txt = txt0 `TL.append` txt1 in TextSpan a ow cw txt f v = v -- | Builds a vector of row operations that will output the given -- picture to the terminal. -- -- Crops to the given display region. buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s) buildSpans image outRegion = do -- First we create a mutable vector for each rows output operations. outOps <- MVector.replicate (regionHeight outRegion) Vector.empty -- It's possible that building the span operations in display order -- would provide better performance. -- -- A depth first traversal of the image is performed. ordered -- according to the column range defined by the image from least -- to greatest. The output row ops will at least have the region -- of the image specified. Iterate over all output rows and output -- background fills for all unspecified columns. -- -- The images are made into span operations from left to right. It's -- possible that this could easily be made to assure top to bottom -- output as well. when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do -- The ops builder recursively descends the image and outputs -- span ops that would display that image. The number of columns -- remaining in this row before exceeding the bounds is also -- provided. This is used to clip the span ops produced to the -- display. let fullBuild = do startImageBuild image -- Fill in any unspecified columns with a skip. forM_ [0 .. (regionHeight outRegion - 1)] (addRowCompletion outRegion) initEnv = BlitEnv outRegion outOps initState = BlitState 0 0 0 0 (regionWidth outRegion) (regionHeight outRegion) _ <- runStateT (runReaderT fullBuild initEnv) initState return () return outOps -- | Add the operations required to build a given image to the current -- set of row operations. startImageBuild :: Image -> BlitM s () startImageBuild image = do outOfBounds <- isOutOfBounds image <$> get when (not outOfBounds) $ addMaybeClipped image isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s | s ^. remainingColumns <= 0 = True | s ^. remainingRows <= 0 = True | s ^. skipColumns >= imageWidth i = True | s ^. skipRows >= imageHeight i = True | otherwise = False -- | This adds an image that might be partially clipped to the output -- ops. -- -- This is a very touchy algorithm. Too touchy. For instance, the -- CropRight and CropBottom implementations are odd. They pass the -- current tests but something seems terribly wrong about all this. addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do -- This assumes that text spans are only 1 row high. s <- use skipRows when (s < 1) $ do leftClip <- use skipColumns rightClip <- use remainingColumns let leftClipped = leftClip > 0 rightClipped = (ow - leftClip) > rightClip if leftClipped || rightClipped then let textStr' = clipText textStr leftClip rightClip in addUnclippedText a textStr' else addUnclippedText a textStr addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do when (imageHeight topImage + imageHeight bottomImage > 0) $ addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset (imageHeight topImage) topImage bottomImage oh addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do when (imageWidth leftImage + imageWidth rightImage > 0) $ addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset (imageWidth leftImage) leftImage rightImage ow addMaybeClipped BGFill {outputWidth, outputHeight} = do s <- get let outputWidth' = min (outputWidth - s^.skipColumns) (s^.remainingColumns) outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows) y <- use rowOffset forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth') addMaybeClipped 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 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 skipRows += topSkip addMaybeClipped croppedImage addMaybeClippedJoin :: forall s . String -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int -> Int -> Image -> Image -> Int -> BlitM s () addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do state <- get when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0" case state^.skip of s | s > size -> put $ state & skip %~ subtract size | s == 0 -> if state^.remaining > i0Dim then do addMaybeClipped i0 put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim addMaybeClipped i1 else addMaybeClipped i0 | s < i0Dim -> let i0Dim' = i0Dim - s in if state^.remaining <= i0Dim' then addMaybeClipped i0 else do addMaybeClipped i0 put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0 addMaybeClipped i1 | s >= i0Dim -> do put $ state & skip %~ subtract i0Dim addMaybeClipped i1 _ -> fail $ name ++ " has unhandled skip class" addUnclippedText :: Attr -> DisplayText -> BlitM s () addUnclippedText a txt = do let op = TextSpan a usedDisplayColumns (fromIntegral $ TL.length txt) txt usedDisplayColumns = wctlwidth txt use rowOffset >>= snocOp op addRowCompletion :: DisplayRegion -> Int -> BlitM s () addRowCompletion displayRegion row = do allRowOps <- view mrowOps rowOps <- lift $ lift $ MVector.read allRowOps row let endX = spanOpsAffectedColumns rowOps when (endX < regionWidth displayRegion) $ do let ow = regionWidth displayRegion - endX snocOp (Skip ow) row -- | snocs the operation to the operations for the given row. snocOp :: SpanOp -> Int -> BlitM s () snocOp !op !row = do theMrowOps <- view mrowOps theRegion <- view region lift $ lift $ do ops <- MVector.read theMrowOps row let ops' = Vector.snoc ops op when (spanOpsAffectedColumns ops' > regionWidth theRegion) $ fail $ "row " ++ show row ++ " now exceeds region width" MVector.write theMrowOps row ops' vty-5.28.2/src/Graphics/Vty/Span.hs0000644000000000000000000001340607346545000015175 0ustar0000000000000000-- 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, -- including spans of the next row. The nth element of the sequence -- represents the nth row (from top to bottom) of the picture to render. -- -- A span op sequence will be defined for all rows and columns (and no -- more) of the region provided with the picture to 'spansForPic'. module Graphics.Vty.Span where import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) import qualified Data.Text.Lazy as TL import Data.Vector (Vector) import qualified Data.Vector as Vector -- | This represents an operation on the terminal: either an attribute -- change or the output of a text string. data SpanOp = -- | A span of UTF-8 text occupies a specific number of screen space -- columns. A single UTF character does not necessarily represent 1 -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width -- in columns] [number of characters] [data] TextSpan { textSpanAttr :: !Attr , textSpanOutputWidth :: !Int , textSpanCharWidth :: !Int , textSpanText :: DisplayText } -- | Skips the given number of columns. | Skip !Int -- | Marks the end of a row. Specifies how many columns are -- remaining. These columns will not be explicitly overwritten with -- the span ops. The terminal is require to assure the remaining -- columns are clear. | RowEnd !Int deriving Eq -- | A vector of span operations executed in succession. This represents -- the operations required to render a row of the terminal. The -- operations in one row may affect subsequent rows. For example, -- setting the foreground color in one row will affect all subsequent -- rows until the foreground color is changed. type SpanOps = Vector SpanOp dropOps :: Int -> SpanOps -> SpanOps dropOps w = snd . splitOpsAt w splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps) splitOpsAt inW inOps = splitOpsAt' inW inOps where splitOpsAt' 0 ops = (Vector.empty, ops) splitOpsAt' remainingColumns ops = case Vector.head ops of t@(TextSpan {}) -> if remainingColumns >= textSpanOutputWidth t then let (pre,post) = splitOpsAt' (remainingColumns - textSpanOutputWidth t) (Vector.tail ops) in (Vector.cons t pre, post) else let preTxt = clipText (textSpanText t) 0 remainingColumns preOp = TextSpan { textSpanAttr = textSpanAttr t , textSpanOutputWidth = remainingColumns , textSpanCharWidth = fromIntegral $! TL.length preTxt , textSpanText = preTxt } postWidth = textSpanOutputWidth t - remainingColumns postTxt = clipText (textSpanText t) remainingColumns postWidth postOp = TextSpan { textSpanAttr = textSpanAttr t , textSpanOutputWidth = postWidth , textSpanCharWidth = fromIntegral $! TL.length postTxt , textSpanText = postTxt } in ( Vector.singleton preOp , Vector.cons postOp (Vector.tail ops) ) Skip w -> if remainingColumns >= w then let (pre,post) = splitOpsAt' (remainingColumns - w) (Vector.tail ops) in (Vector.cons (Skip w) pre, post) else ( Vector.singleton $ Skip remainingColumns , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops) ) RowEnd _ -> error "cannot split ops containing a row end" -- | A vector of span operation vectors for display, one per row of the -- output region. type DisplayOps = Vector SpanOps instance Show SpanOp where show (TextSpan attr ow cw _) = "TextSpan(" ++ show attr ++ ")(" ++ show ow ++ ", " ++ show cw ++ ")" show (Skip ow) = "Skip(" ++ show ow ++ ")" show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" -- | The number of columns the DisplayOps are defined for. -- -- All spans are verified to define same number of columns. displayOpsColumns :: DisplayOps -> Int displayOpsColumns ops | Vector.length ops == 0 = 0 | otherwise = Vector.length $ Vector.head ops -- | The number of rows the DisplayOps are defined for. displayOpsRows :: DisplayOps -> Int displayOpsRows ops = Vector.length ops affectedRegion :: DisplayOps -> DisplayRegion affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) -- | The number of columns a SpanOps affects. spanOpsAffectedColumns :: SpanOps -> Int spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps where spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w spanOpsAffectedColumns' t (Skip w) = t + w spanOpsAffectedColumns' t (RowEnd w) = t + w -- | The width of a single SpanOp in columns. spanOpHasWidth :: SpanOp -> Maybe (Int, Int) spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow) spanOpHasWidth (Skip ow) = Just (ow,ow) spanOpHasWidth (RowEnd ow) = Just (ow,ow) -- | The number of columns to the character at the given position in the -- span op. columnsToCharOffset :: Int -> SpanOp -> Int columnsToCharOffset cx (TextSpan _ _ _ utf8Str) = wctlwidth (TL.take (fromIntegral cx) utf8Str) columnsToCharOffset cx (Skip _) = cx columnsToCharOffset cx (RowEnd _) = cx vty-5.28.2/src/Graphics/Vty/UnicodeWidthTable/0000755000000000000000000000000007346545000017272 5ustar0000000000000000vty-5.28.2/src/Graphics/Vty/UnicodeWidthTable/IO.hs0000644000000000000000000000573407346545000020146 0ustar0000000000000000{-# 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 vty-5.28.2/src/Graphics/Vty/UnicodeWidthTable/Install.hs0000644000000000000000000001147007346545000021237 0ustar0000000000000000{-# 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 () vty-5.28.2/src/Graphics/Vty/UnicodeWidthTable/Query.hs0000644000000000000000000000562107346545000020737 0ustar0000000000000000{-# LANGUAGE TupleSections #-} module Graphics.Vty.UnicodeWidthTable.Query ( buildUnicodeWidthTable , defaultUnicodeTableUpperBound ) where import Control.Monad (forM) import Data.Char (generalCategory, GeneralCategory(..)) import System.Console.ANSI (getCursorPosition) import Text.Printf (printf) import Graphics.Vty.UnicodeWidthTable.Types shouldConsider :: Char -> Bool shouldConsider c = case generalCategory c of Control -> False NotAssigned -> False Surrogate -> False _ -> True charWidth :: Char -> IO Int charWidth c = do printf "\r" putChar c Just (_, col) <- getCursorPosition return col -- | 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 by querying the terminal -- connected to stdout. This works by emitting characters to stdout -- and then querying the terminal to determine the resulting cursor -- position in order to measure character widths. Consequently this will -- generate a lot of output and may take a while, depending on your -- system performance. This should not be run in a terminal while it is -- controlled by Vty. -- -- The 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 UnicodeWidthTable buildUnicodeWidthTable tableUpperBound = do pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i -> (i,) <$> charWidth i return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs } vty-5.28.2/src/Graphics/Vty/UnicodeWidthTable/Types.hs0000644000000000000000000000202607346545000020732 0ustar0000000000000000module 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) vty-5.28.2/test/0000755000000000000000000000000007346545000011602 5ustar0000000000000000vty-5.28.2/test/Verify.hs0000644000000000000000000000514307346545000013405 0ustar0000000000000000{-# 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 vty-5.28.2/test/Verify/Data/Terminfo/0000755000000000000000000000000007346545000015502 5ustar0000000000000000vty-5.28.2/test/Verify/Data/Terminfo/Parse.hs0000644000000000000000000000710507346545000017113 0ustar0000000000000000module 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 ++ "]" } vty-5.28.2/test/Verify/Graphics/Vty/0000755000000000000000000000000007346545000015370 5ustar0000000000000000vty-5.28.2/test/Verify/Graphics/Vty/Attributes.hs0000644000000000000000000000317107346545000020054 0ustar0000000000000000module 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 vty-5.28.2/test/Verify/Graphics/Vty/DisplayAttributes.hs0000644000000000000000000000030707346545000021400 0ustar0000000000000000module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes , module Graphics.Vty.DisplayAttributes ) where import Graphics.Vty.DisplayAttributes import Verify vty-5.28.2/test/Verify/Graphics/Vty/Image.hs0000644000000000000000000001720707346545000016755 0ustar0000000000000000{-# 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' vty-5.28.2/test/Verify/Graphics/Vty/Output.hs0000644000000000000000000000270607346545000017231 0ustar0000000000000000module 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 vty-5.28.2/test/Verify/Graphics/Vty/Picture.hs0000644000000000000000000000262207346545000017341 0ustar0000000000000000{-# 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 vty-5.28.2/test/Verify/Graphics/Vty/Prelude.hs0000644000000000000000000000100707346545000017322 0ustar0000000000000000module 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 vty-5.28.2/test/Verify/Graphics/Vty/Span.hs0000644000000000000000000000215307346545000016626 0ustar0000000000000000{-# 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 -> (spanOpsAffectedColumns 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 } vty-5.28.2/test/VerifyConfig.hs0000644000000000000000000000237107346545000014533 0ustar0000000000000000{-# 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 ] vty-5.28.2/test/VerifyCropSpanGeneration.hs0000644000000000000000000000754507346545000017077 0ustar0000000000000000{-# 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 ] vty-5.28.2/test/VerifyDisplayAttributes.hs0000644000000000000000000000025607346545000017002 0ustar0000000000000000module VerifyDisplayAttributes where import Verify.Graphics.Vty.DisplayAttributes import Verify.Graphics.Vty.Attributes import Verify tests :: IO [Test] tests = return [] vty-5.28.2/test/VerifyEmptyImageProps.hs0000644000000000000000000000040407346545000016406 0ustar0000000000000000module 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 [] vty-5.28.2/test/VerifyEvalTerminfoCaps.hs0000644000000000000000000000616007346545000016530 0ustar0000000000000000{-# 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 vty-5.28.2/test/VerifyImageOps.hs0000644000000000000000000001671007346545000015034 0ustar0000000000000000module 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 ] vty-5.28.2/test/VerifyImageTrans.hs0000644000000000000000000000266707346545000015370 0ustar0000000000000000{-# 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 ] vty-5.28.2/test/VerifyInline.hs0000644000000000000000000000152507346545000014544 0ustar0000000000000000module 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" } ]) vty-5.28.2/test/VerifyLayersSpanGeneration.hs0000644000000000000000000001304707346545000017425 0ustar0000000000000000{-# 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 ] vty-5.28.2/test/VerifyOutput.hs0000644000000000000000000000333307346545000014625 0ustar0000000000000000-- 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.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 vty-5.28.2/test/VerifyParseTerminfoCaps.hs0000644000000000000000000000702007346545000016707 0ustar0000000000000000{-# 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 vty-5.28.2/test/VerifySimpleSpanGeneration.hs0000644000000000000000000002214307346545000017414 0ustar0000000000000000{-# 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 ( spanOpsAffectedRows 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 ( spanOpsAffectedRows 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 spanOpsAffectedRows 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 = spanOpsAffectedRows 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 = spanOpsAffectedRows 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 = spanOpsAffectedRows 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 ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w ) spanOpsActuallyFillRows :: DefaultPic -> Bool spanOpsActuallyFillRows (DefaultPic pic win) = let ops = displayOpsForPic pic (regionForWindow win) expectedRowCount = regionHeight (regionForWindow win) actualRowCount = spanOpsAffectedRows 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 ] vty-5.28.2/test/VerifyUsingMockInput.hs0000644000000000000000000002125607346545000016250 0ustar0000000000000000{-# 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 ] vty-5.28.2/test/VerifyUsingMockTerminal.hs0000644000000000000000000001075507346545000016726 0ustar0000000000000000module 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 ] vty-5.28.2/test/VerifyUtf8Width.hs0000644000000000000000000000161307346545000015152 0ustar0000000000000000module 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 ] vty-5.28.2/tools/0000755000000000000000000000000007346545000011763 5ustar0000000000000000vty-5.28.2/tools/BuildWidthTable.hs0000644000000000000000000001174607346545000015337 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Main 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 } main :: IO () main = 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 $ 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 vty-5.28.2/vty.cabal0000644000000000000000000005057307346545000012443 0ustar0000000000000000name: vty version: 5.28.2 license: BSD3 license-file: LICENSE author: AUTHORS maintainer: Jonathan Daugherty (cygnus@foobox.com) homepage: https://github.com/jtdaugherty/vty category: User Interfaces synopsis: A simple terminal UI library description: vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, 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. . Import the "Graphics.Vty" convenience module to get access to the core parts of the library. . © 2006-2007 Stefan O'Rear; BSD3 license. . © Corey O'Connor; BSD3 license. . © Jonathan Daugherty; BSD3 license. cabal-version: 1.18 build-type: Simple extra-doc-files: README.md, AUTHORS, CHANGELOG.md, LICENSE tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5 source-repository head type: git location: https://github.com/jtdaugherty/vty.git library default-language: Haskell2010 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 < 0.4.12, microlens-mtl, microlens-th, hashable >= 1.2, mtl >= 1.1.1.0 && < 2.3, parallel >= 2.2 && < 3.3, parsec >= 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, binary, ansi-terminal >= 0.10.3 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16, fail exposed-modules: Graphics.Vty Graphics.Vty.Attributes Graphics.Vty.Attributes.Color Graphics.Vty.Config Graphics.Vty.Error Graphics.Vty.Image Graphics.Vty.Inline Graphics.Vty.Inline.Unsafe Graphics.Vty.Input Graphics.Vty.Input.Events Graphics.Vty.Picture Graphics.Vty.Output Graphics.Text.Width 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.PictureToSpans Graphics.Vty.Span Graphics.Vty.Output.Mock Graphics.Vty.Output.Interface Graphics.Vty.Output.XTermColor Graphics.Vty.Output.TerminfoBased Graphics.Vty.UnicodeWidthTable.Types Graphics.Vty.UnicodeWidthTable.IO Graphics.Vty.UnicodeWidthTable.Query Graphics.Vty.UnicodeWidthTable.Install other-modules: Graphics.Vty.Attributes.Color240 Graphics.Vty.Debug.Image Graphics.Vty.Input.Terminfo.ANSIVT c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/get_tty_erase.c cbits/mk_wcwidth.c include-dirs: cbits hs-source-dirs: src default-extensions: ScopedTypeVariables 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 executable vty-build-width-table main-is: BuildWidthTable.hs hs-source-dirs: tools default-language: Haskell2010 ghc-options: -threaded -Wall if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 build-depends: vty, directory, filepath, base >= 4.8 && < 5 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-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