packages feed

vty 5.5.0 → 6.6

raw patch · 73 files changed

Files

AUTHORS view
@@ -1,4 +1,6 @@-The following people should be thanked for contributing to the vty library:+The following people should be thanked for contributing to the vty+library:+     * Andrea Vezzosi     * Corey O'Connor     * Emily Backes@@ -17,4 +19,4 @@     * Yoshikuni Jujo     * Dmitry Ivanov -Plus others.. Check the git log for a full list.+Plus others.. Check the git log and CHANGELOG.md for a full list.
− CHANGELOG 
@@ -1,265 +0,0 @@-5.5.0-  - Replaced lens dependency with microlens, microlens-mtl, microlens-th dependencies. Issue #90-    - Thanks Jonathan Daugherty-  - Cabal corrections.-    - Thanks Lennart Spitzner--5.4.0-  - Changed eventChannel of Graphics.Vty.Input from Chan to TChan. This enables clients to query if-    there are no pending events. The Graphics.Vty interface nextEvent is unchanged. Clients that use-    eventChannel directly will require updating.-    https://github.com/coreyoconnor/vty/issues/60-5.3.1-  - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due-    to possibly breaking this on reasonable GHC versions--5.3-  - Upgraded QuickCheck dependency to 2.7-  - The standard IO Config (standardIOConfig) was overriding any provided application config.-    In addition, the inputFd and outputFd could not be changed if mkVty was used.-    Fixed.-  - Correct handling of display attributes at end of line. The output attributes are set to default-    at the end of content for the line and at the start of a new line.  Previously the current-    attribute would extend to the next start of content. This was odd to reason about and was the-    cause of https://github.com/coreyoconnor/vty/issues/76-    IIRC Yi requires the old behavior to display the selection region correctly.-  - shutdown of the input thread is now performed using killThread and synchronization on an MVar.-    For correct handling of the terminal read vmin and vtime the read must be a blocking read on an-    OS thread. This places a threadWaitRead, which will be interrupted by the killThread, prior to-    the uninterruptable read. An alternative would be to re-import the read foreign call as-    interruptable.--5.2.11-  - deepseq bounds increased for tests.-  - Clean up warnings when compiling on 7.10-    - Thanks Eric Mertens-  - Avoid discarding input bytes after multi-byte encoded codepoint-    - Thanks Eric Mertens--5.2.10-  - "str" now returns EmptyImage for empty strings to match behavior of other string-like Image constructors (fixes #74)-    - Thanks Jonathan Daugherty--5.2.9-  - dependency version bumps-    - https://github.com/coreyoconnor/vty/pull/71-    - https://github.com/coreyoconnor/vty/pull/70-  - Correct/Simplify the example code-    - Thanks glguy-    - https://github.com/coreyoconnor/vty/pull/69--5.2.8-  - blaze-builder, lens, utf8-string version constraint bump-      - Thanks glguy-      - https://github.com/coreyoconnor/vty/pull/67-  - Do not differentiate based on TERM_PROGRAM-      - https://github.com/coreyoconnor/vty/issues/68--5.2.7-  - lens and deepseq constraint bump + misc-      - Thanks ethercrow-      - https://github.com/coreyoconnor/vty/pull/66--5.2.6-  - lens constraint bump-      - Thanks alexander-b!-      - https://github.com/coreyoconnor/vty/pull/64--5.2.5-  - lens and random version constraint bump.-      - Thanks RyanGlScott!-      - https://github.com/coreyoconnor/vty/pull/62--5.2.4-  - removed -fpic from cc-options. No longer required.-      - https://github.com/coreyoconnor/vty/issues/61-      - https://ghc.haskell.org/trac/ghc/ticket/9657-      - Thanks Fuuzetsu!--5.2.3-  - evaluate/compile the input parsing table once instead of each keystroke.-      - https://github.com/coreyoconnor/vty/pull/59-      - Thanks ethercrow!--5.2.2-  - When looking at input for an event, don't look too deep.-      - https://github.com/coreyoconnor/vty/pull/57-      - Thanks ethercrow!--5.2.1-  - Bump upper version bound for lens to 4.5. Thanks markus1189!--5.2.0-  - Config structure now specifies file descriptor to use. The default is stdInput and stdOutput-    file descriptors. Previously Vty used stdInput for input and the follow code for output:-      - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` NoBuffering)-      - the difference was required by Vty.Inline. Now, Vty.Inline uses the Config structure options-        to acheive the same effect.-  - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, inputForNameAndIO,-    outputForCurrentTerminal, outputForNameAndIO-  - added: inputForConfig, outputForConfig-  - updates to vty-rogue from jtdaugherty. Thanks!-  - the oldest version of GHC tested to support vty is 7.6.2.-  - the oldest version of GHC that vty compiles under is 7.4.2--5.1.4-  - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!--5.1.1-  - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!-  - jtdaugherty resolved a number of compiler warnings. Thanks!--5.1.0-  - vmin and vtime can be specified however the application requires. See Graphics.Vty.Config.-  - fixed the processing of input when vmin is set > 1.--5.0.0-  - The naming convention now matches:-    - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions-  - all projects using vty for input must be compiled with -threaded. Please notify vty author if-    this is not acceptable.-  - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default-    configuration.-  - input handling changes-    - KASCII is now KChar-    - KPN5 is now KCenter-    - tests exist.-    - Applications can add to the input tables by setting inputMap of the Config.-      See Graphics.Vty.Config-    - Users can define input table extensions that will apply to all vty applications.-      See Graphics.Vty.Config-    - terminal timing is now handled by selecting an appropriate VTIME. Previously this was-      implemented within Vty itself. This reduced complexity in vty but provides a different meta-      key behavior and implies a requirement on -threaded.-    - The time vty will wait to verify an ESC byte means a single ESC key is the-      singleEscPeriod of the Input Config structure.-  - removed the typeclass based terminal and display context interface in favor of a data-    structure of properties interface.-  - renamed the Terminal interface to Output-  - The default picture for an image now uses the "clear" background. This background fills-    background spans with spaces or just ends the line.-    - Previously the background defaulted to the space character. This causes issues copying-      text from a text editor. The text would end up with extra spaces at the end of the line.-  - Layer support-    - Each layer is an image.-    - The layers for a picture are a list of images.-    - The first image is the top-most layer. The images are ordered from top to bottom.-    - The transparent areas for a layer are the backgroundFill areas. backgroundFill is-      added to pad images when images of different sizes are joined.-    - If the background is clear there is no background layer.-    - If there is a background character then the bottom layer is the background layer.-    - emptyPicture is a Picture with no layers and no cursor-    - addToTop and addToBottom add a layer to the top and bottom of the given Picture.-  - compatibility improvements:-    - terminfo based terminals with no cursor support are silently accepted. The cursor-      visibility changes in the Picture will have no effect.-    - alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a-      guess.-    - added "rgbColor" for easy support of RGB specified colors.-    - Both applications and users can add to the mapping used to translate from input bytes to-      events.-  - Additional information about input and output process can be appended to a debug log-    - Set environment variable VTY_DEBUG_LOG to path of debug log-    - Or use "debugLog <path>" config directive-    - Or set 'debugLog' property of the Config provided to mkVty.-  - examples moved to vty-examples package. See test directory for cabal file.-    - vty-interactive-terminal-test-      - interactive test. Useful for building a bug report for vty's author.-      - test/interactive_terminal_test.hs-    - vty-event-echo-      - view a input event log for vty. Example of interacting with user.-      - test/EventEcho.hs-    - vty-rogue-      - The start of a rogue-like game. Example of layers and image build operations.-      - test/Rogue.hs-    - vty-benchmark-      - benchmarks vty. A series of tests that push random pictures to the terminal. The-        random pictures are generated using QuickCheck. The same generators used in the-        automated tests.-      - test/benchmark.hs--4.7.0.0-    - API changes:-       - Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size.-       - Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size.-       - Added Graphics.Vty.Image.translate: Offset an image.-    - Thanks Ben Boeckel <MathStuf@gmail.com> for these features.--4.3.0.0--4.2.1.0-    - API changes:-        - Attr record accessor fore_color changed to attr_fore_color-        - Attr record accessor back_color changed to attr_back_color-        - Attr record accessor style changed to attr_style-        - Added an "inline" display attribute changing DSL:-            - put_attr_change applies a display attribute change immediately to a terminal-            - For instance, can be used to change the display attrbiutes of text output via putStrLn-              and putStr. EX: "put_attr_change $ back_color red" will set the-              background color to red.-            - Changes do not apply to a Picture output via output_picture.-            - See Graphics.Vty.Inline-        - Moved all IO actions into any monad an instance of MonadIO--4.0.0.1-    - binding for mk_wcswidth was incorrect. Most platforms just magically worked due to-      coincidence.--4.0.0-    - API changes:-        - "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an-          instance of the Vty data structure.-        - added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated-          with the Vty instance.-        - Graphics.Vty.Types has undergone a number of changes. Summary:-          - Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for-            image combinators. Graphics.Vty.Picture for final picture construction.-        - Graphics.Vty.Attributes:-          - "setFG" and "setBG" are now "with_fore_color" and "with_back_color"-          - All other "set.." equations similarly replaced.-          - "attr" is now "def_attr", short for "default display attributes" Also added a-            "current_attr" for "currently applied display attributes"-        - Graphics.Vty.Image:-          - "horzcat" is now "horiz_cat"-          - "vertcat" is now "vert_cat"-          - "renderBS" is now "utf8_bytestring"-          - "renderChar" is now "char"-          - "renderFill" is now "char_fill"-          - added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings-            and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime-            representation.-        - Graphics.Vty.Picture:-          - exports Graphics.Vty.Image-          - "pic" is now "pic_for_image"-          - added API for setting background fill pattern.-    - Completely rewritten output backend.-        - Efficient, scanline style output span generator. Has not been fully optimized, but good-          enough.-        - The details required to display the desired picture on a terminal are well encapsulated.-        - Terminfo based display terminal implementation. With specialized derivitives for xterm,-          Terminal.app, and iTerm.app.-            - Attempts to robustly handle even terminals that don't support all display attributes.-            - I've tested the following terminals with success: iTerm.app, Terminal.app, xterm,-              rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be-              as successfull.-        - Improved unicode support. Double wide characters will display as expected.-    - 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted-      according to the number of colors the terminal supports.-    - The Graphics.Vty.Image combinators no longer require matching dimensions to arguments.-      Unspecified areas are filled in with a user-customizable background pattern. See-      Graphics.Vty.Picture.-    - output images are always cropped to display size.-    - Significant code coverage by QuickCheck tests. An interactive test for those final properties-      that couldn't be automatically verified.--    issues resolved:-        - "gnome terminal displays non-basic attributes as strikethrough"-            - http://trac.haskell.org/vty/ticket/14-        - "Multi-byte characters are not displayed correctly on update"-            - http://trac.haskell.org/vty/ticket/10-        - "Redraw does not handle rendering a line that extends beyond screen width characters"-            - http://trac.haskell.org/vty/ticket/13-        - "The <|> and <-> combinators should be more forgiving of mismatched dimensions"-            - http://trac.haskell.org/vty/ticket/9-        - "256-color support"-            - http://trac.haskell.org/vty/ticket/19
+ CHANGELOG.md view
@@ -0,0 +1,1113 @@++6.6+---++* Added support for horizontal scrolling inputs. The `Button` type in+  `Graphics.Vty.Input.Events` got new constructors `BScrollLeft` and+  `BScrollRight` for Vty backend implementations that support horizontal+  scrolling inputs.++6.5+---++* Raised upper bound on `microlens` dependency to permit builds against+  0.5.+* Fixed the `utf8-string` dependency lower bound to account for an added+  module in 0.3.1. (#279)+* Improved the allocation behavior of `swapSkipsForSingleColumnCharSpan`.++6.4+---++* Updated the behavior of character width computations when a custom+  character width table has been installed. Now when a custom character+  width table doesn't provide a width for a character, rather than+  defaulting to 1 column, the built-in table is consulted. This change+  shouldn't affect users using width tables generated by `vty-unix`'s+  table-building tool since that tool generates tables that will provide+  widths for all supported characters.++6.3+---++* Raise microlens upper bound to build with 0.4.14 (#278)+* Updated other bounds to permit building with GHC 9.12 (thanks Erik de+  Catro Lopo)+* Removed defunct examples from project++6.2+---++Package changes:+* Update version bounds to support building with GHC 9.8++Bug fixes:+* Updated `PictureToSpans` module to implement its lenses manually to+  avoid template haskell which has trouble on Windows and GHC 9.2 (#271)++6.1+---++API changes:+* `ColorMode` got a `Read` instance.+* The `Config` type got a new `configPreferredColorMode` field for+  specifying a preferred `ColorMode`. Backend packages should respect+  this field, but note that `vty` itself does not (and cannot) enact+  this preference since it's up to the backend driver to configure the+  color mode.+* The Vty configuration file got a new `colorMode` field whose value is+  a string literal compatible with the `ColorMode` `Read` instance.++6.0+---++This release marks the beginning of multi-platform support in Vty.+Getting to this point involved removing Unix-specific functionality+from Vty and moving it to a new package, `vty-unix`. Windows support+is now provided via a `vty-windows` package. Another new package,+`vty-crossplatform`, is provided as a convenience for applications that+want to support both Unix and Windows platforms automatically at build+time. See the migration guide below for details on how to upgrade.++**Migration guide for 6.0**++To upgrade to this version of Vty, most people will only need to take a+few steps:++1. Add a package dependency on `vty-unix`, `vty-windows,` or+   `vty-crossplatform`, depending on the desired level of platform+   support. For example, if an application only supports Unix systems,+   it should depend on `vty-unix`. But if an application is intended to+   work anywhere Vty works, then `vty-crossplatform` is the best choice.+2. Import `mkVty` from the platform package in step (1). (`mkVty` was+   removed from the `vty` package and is now the responsibility of each+   platform package.) Imports are as follows:+   * `vty-unix`: `Graphics.Vty.Platform.Unix`+   * `vty-windows`: `Graphics.Vty.Platform.Windows`+   * `vty-crossplatform`: `Graphics.Vty.CrossPlatform`+3. Maintain any existing package dependency on `vty`; the core library+   abstractions, types, and functions are still obtained from `vty`+   itself. The platform packages do not re-export the core library's+   modules.+4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty+   user configuration since this step is no longer automatic.+5. Some configurations have been moved to `Graphics.Vty.Output`. For +   example, `mouseMode` is no longer a field in `VtyUserConfig`. +   Instead, use `setMode` to enable it.++For applications using more of Vty's API than just the basic+initialization and rendering API, the full change list is provided+below. For people who want to write their own Vty platform package like+`vty-unix`, see `PLATFORM-HOWTO.md`.++**Detailed change list for 6.0**++* Package changes:+  * The following modules got added to the `vty` library:+    * `Graphics.Vty.UnicodeWidthTable.Main`+  * The following modules got moved to `vty-unix`:+    * `Data.Terminfo.Eval`+    * `Data.Terminfo.Parse`+  * The following modules got moved to `vty-unix` into the+    `Graphics.Vty.Platform.Unix` module namespace (previously+    `Graphics.Vty`):+    * `Graphics.Vty.Input.Classify`+    * `Graphics.Vty.Input.Classify.Parse`+    * `Graphics.Vty.Input.Classify.Types`+    * `Graphics.Vty.Input.Focus`+    * `Graphics.Vty.Input.Loop`+    * `Graphics.Vty.Input.Mouse`+    * `Graphics.Vty.Input.Paste`+    * `Graphics.Vty.Input.Terminfo`+    * `Graphics.Vty.Output.TerminfoBased`+    * `Graphics.Vty.Output.XTermColor`+  * The following modules were removed entirely (with contents migrated+    elsewhere as needed):+    * `Graphics.Vty.Inline.Unsafe`+    * `Graphics.Vty.Output.Interface` (migrated to+      `Graphics.Vty.Output`)+  * Removed library dependencies on the following packages:+    * `ansi-terminal`+    * `containers`+    * `terminfo`+    * `transformers`+    * `unix`+  * The following executables were moved to other packages:+    * `vty-build-width-table` (moved to `vty-unix` as+      `vty-unix-build-width-table`)+    * `vty-mode-demo` (moved to `vty-crossplatform`)+* API changes:+  * `Graphics.Vty.mkVty` moved to the `vty-unix` package's+    `Graphics.Vty.Platform.Unix` module.+  * Added `Graphics.Vty.mkVtyFromPair` for platform packages to+    construct `Vty` handles.+  * The contents of the `Graphics.Vty.Output.Interface` module were+    merged into `Graphics.Vty.Output`.+  * The `vty-build-width-table` tool was removed from the `vty` package,+    but its core functionality is now exposed as a library for+    platform packages to use to provide platform-specific tools using+    `Graphics.Vty.UnicodeWidthTable.Main` and a new tool by the same+    name was added to the `vty-unix` package.+  * `Graphics.Vty.Events`: the `InternalEvent` type's+    `ResumeAfterSignal` constructor was renamed to+    `ResumeAfterInterrupt` to be a bit more abstract and+    platform-agnostic.+  * Removed the following lenses for fields of the `Input` type:+    * `eventChannel` (was for `_eventChannel` which was then renamed to+      `eventChannel`)+    * `configRef` (was for `_configRef` which was then renamed to+      `configRef`)+  * The `Output` record type got a new field, `setOutputWindowTitle`.+  * The `Input` record type got a new field, `inputLogMsg :: String ->+    IO ()`, for logging to the Vty log.+  * `Graphics.Vty.Config` now exposes `VtyUserConfig` instead of+    `Config`. Many of its fields were Unix-specific and were+    consequently moved to the `UnixSettings` type in `vty-unix` and+    given a `settings` prefix. This includes `outputFd`, `inputFd`,+    `vmin`, `vtime`, and `termName`.+  * The `VtyUserConfig` type's fields got a `config` field name prefix.+  * `inputForConfig` was moved to `vty-unix` as `buildInput` but+    generally should not be needed and is exposed only for testing.+  * `outputForConfig` was moved to `vty-unix` as `buildOutput` but+    generally should not be needed and is exposed only for testing.+* Behavior changes:+  * Since `vty` no longer implements `mkVty`, the Vty user configuration+    is no longer implicitly loaded by Vty-based applications.+    Instead, it is now up to the applications to call+    `Graphics.Vty.Config.userConfig` to load any user-provided+    configuration.+  * Vty no longer implicitly attempts to load configured Unicode+    width tables. It is now the responsibility of the platform packages+    (such as `vty-unix`) and/or applications to load tables via+    `Graphics.Vty.UnicodeWidthTable.IO` and install them via+    `Graphics.Vty.UnicodeWidthTable.Install`.+* Changes to demonstration programs:+  * `EventEcho`, `ModeDemo`, and `Rogue` demo programs moved to the+    `vty-crossplatform` package.+* Changes to tests:+  * Where appropriate, some test programs and test cases were moved to+    `vty-unix` or `vty-crossplatform`.++5.39+----++Package changes:+* Now builds with `mtl-2.3.*`.++Bug fixes:+* Fixed a long-standing issue where unused input on stdin could cause a+  memory error and a crash when Vty was being initialized. (#266)++5.38+----++This release includes numerous API changes, although none of them should+break your programs. If so, please open a ticket on the Vty issue+tracker.++Package changes:+* Support mtl 2.3 (thanks Daniel Firth)+* The test and example collections got completely overhauled to clean up+  bit rot.+  * Moved example programs into examples/ under a new vty-examples+    package.+  * Moved test suite programs out of vty.cabal and into tests/ under a+    new vty-tests package.+  * Cleaned up all build-depends lists in all three packages to remove+    unused deps.+  * Consolidated the test suite library modules into the vty-tests+    library to avoid redundant compilation.+  * Added build.sh to build everything in the development process to+    help ensure that examples and tests don't get forgotten.+  * Removeed lots of stale/unused modules in old test/ directory.+* Got vty-examples building again and resolved various warnings and+  issues.++API changes:+* All modules got explicit export lists. Prior to this release, many+  modules exported everything they contained, making it difficult to+  know what was really intended to be part of the public API. The new+  export lists should contain everything that applications need; the+  risk of breakage exists but should be minor. Please open a ticket if+  you were using something that is no longer exported. It might be that+  it was never supposed to be exported to begin with, or it might be+  just something we need to export once again.+* Moved the `attributeControl` function from `Graphics.Vty.Input.Loop`+  to `Graphics.Vty.Input`.+* Removed the `Graphics.Vty.Image.DisplayText` alias for `Text`.+* Unified the `Image` cropping constructors (thanks Fraser Tweedale)++5.37+----++* The Xterm backend is now used when `TERM` matches `rxvt` or `tmux`.+* PictureToSpans now uses `error`, not `fail`, to avoid dependence on+  soon-to-be-removed `MonadFail` instance for `ST` (#248)++5.36+----++ * Raised `microlens` upper bound to allow building with 0.4.13.+ * Replaced incomplete `Show` output for `Picture` with a derived+   instance; derived `Show` for `Cursor` and `Background`, too.++5.35.1+------++Bug fixes:+ * Fixed a build issue with a test program.++5.35+----++New features:+ * Add support for 24-bit color (thanks @u-quark). This change+   updates Vty to look at the `COLORTERM` environment variable that is+   conventionally used to advertise support for truecolor escape+   sequences. The change also updates the Vty demo to demonstrate+   24-bit colors. This change also adds a new data type, `ColorMode`,+   to represent the color mode in use, as well as an `Output` interface+   field, `outputColorMode`, to track the active color mode and use it+   to clamp emitted color escape sequences to the active color range.++API changes:+ * All types in `Graphics.Vty.Input.Events` now have strict constructor+   fields.+ * Internal events are now wrapped in a new `InternalEvent` type to+   improve how signal handling is done. This change modifies the `Input`+   type's event channel API to produce `InternalEvents`, not `Events`.+   The new `InternalEvent` either wraps `Event` with the `InputEvent`+   constructor (the previous behavior) or indicates that Vty resumed+   after handling a signal using the `ResumeAfterSignal` constructor.+   This change avoids the previous use of `EvResize` with lazy exception+   arguments as a sentinel value for `ResumeAfterSignal`.++Other enhancements:+ * Bracketed paste parsing performance has been greatly improved thanks+   to benchmarking and optimization work by @iphydf. As part of that+   work, Vty now uses bytestrings rather than Strings internally when+   parsing input to look for events.+ * The `\b` value is now interpreted as `KBS` (thanks @vglfr)++5.34+----++API changes:+ * Added an `NFData` instance for `Event` (thanks Mario Lang)+ * Removed `Monoid` and `Semigroup` instances for `Attr` and+   `MaybeDefault`. This change removed the instances because they were+   misbehaved; merging `Attr` and `MaybeDefault` values with these+   instances resulted in field value losses. For example, before this+   change,+```+(defAttr `withForeColor` blue) <> (defAttr `withBackColor` green)+```+   would result in just+```+   (defAttr `withBackColor` green)+```+   because the instances were designed to favor the right-hand+   arguments' fields even if they had not been explicitly set+   (a consequence of the `MaybeDefault` `Semigroup` instance).+   While that behavior was sensible specifically in the context of+   `Graphics.Vty.Inline`, it wasn't a useful user-facing API and it made+   for surprising instance behavior. Since there is actually no good way+   to handle this in a `Semigroup` instance for `Attr` -- some choices+   have to be made about how to merge two attributes' foreground colors,+   and that won't be much better than what we had -- the instance was+   just removed.+++5.33+----++API changes:+* The `Cursor` type got a new `PositionOnly` constructor for cursor+  placement without visibility.++Package changes:+* Relaxed upper bound for `random`+* Updated `microlens` bounds to allow 0.4.12++Other improvements:+* Various hlint-driven improvements (thanks Willem Van Onsem)+* The implementation of `color240` was improved (thanks (Willem Van+  Onsem)++5.32+----++New features:+ * Meta-PageUp and Meta-PageDown are now supported (#193)+ * Added `supportsItalics` and `supportsStrikethrough` functions to+   check for feature support in terminfo++Bug fixes:+ * Detect utf-8 mode in `LANG` regardless of case (thanks Emeka+   Nkurumeh)++5.31+----++New features and API changes:+ * Added support for strikethrough mode. This change adds a new+   `strikethrough` `Style` value and uses the `smxx` and `rmxx`+   Terminfo capabilities to activate and deactivate strikethrough mode,+   respectively. If the terminfo does not report those capabilities,+   this style is ignored.+ * `Output`: added the `setDisplayBounds` field to set the output+   dimensions of the output handle; added an implementation of this for+   the `TerminfoBased` backend.++Other changes:+ * The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.++5.30+----++New features:+ * Added `Graphics.Vty.setWindowTitle` to emit an escape+   sequence to set the window title, provide the terminal emulator+   accepts Xterm-style title sequences. For details, see:+   https://tldp.org/HOWTO/Xterm-Title-3.html++5.29+----++API changes:+ * The Input type got a new field, 'restoreInputState'. This field+   allows the end user to have direct access to the logic needed to+   restore the terminal's input state flags. Prior to having this field,+   this state restoration logic could only be invoked as part of calling+   'shutdownInput', but since that function does other things (like+   killing threads) it is not advisable to call it repeatedly (which is+   necessary in the use case this change is intended to support). This+   can be called directly to restore the input state flags as needed,+   although this is not required if 'shutdown' (or 'shutdownInput') is+   called.++Other changes:+ * attributeControl: explicitly enable the ICRNL terminal mode flag (see+   #187 and c572ad).++5.28.2+------++Bug fixes:+ * Added a package dependency on `semigroups` for the+   `vty-build-width-table` tool on older GHCs (#185)++5.28.1+------++Bug fixes:+ * `installUnicodeWidthTable`: use `throwIO`, not `throw`++5.28+----++This release improves Vty's support for multi-column Unicode characters+and provides greater compatibility with a wider array of terminal+emulators. The following sections summarize the relevant changes, but an+overview of the new functionality is motivated and detailed in the new+"Multi-Column Character Support" README section. For+historical context, please also consider reading over+[#175](https://github.com/jtdaugherty/vty/issues/175).++API changes:+ * New modules were added:+   * `Graphics.Vty.UnicodeWidthTable.Types`+   * `Graphics.Vty.UnicodeWidthTable.IO`+   * `Graphics.Vty.UnicodeWidthTable.Query`+   * `Graphics.Vty.UnicodeWidthTable.Install`+ * The `Config` type got a new field, `allowCustomUnicodeWidthTables`,+   that controls whether `mkVty` will attempt to load a Unicode width+   table if specified in the configuration.++Configuration file changes:+ * A new syntax was added to support specifying Unicode width tables on+   a per-`TERM` basis. The syntax is `widthMap <TERM> <PATH>`. See the+   documentation for `Graphics.Vty.Config` for details. Since prior+   versions of this library will silently ignore any configuration file+   lines they cannot parse, this change to user configuration files is+   at least non-breaking for older versions of Vty.++Other changes:+ * The `mkVty` function now automatically attempts to load a custom+   Unicode width table if one is specified in the configuration,+   provided `allowCustomUnicodeWidthTables` is not set to `Just False`.+   See the documentation for `Graphics.Vty.mkVty` for details.+ * Vty now includes a command line tool, `vty-build-width-table`, that+   queries the terminal emulator to construct a custom Unicode width+   table and optionally update the Vty configuration file to use it.+   Programs that want to use that tool's functionality may also do so+   via the API exposed in the various modules listed above.++5.27+----++* Added `Graphics.Vty.Config.getTtyEraseChar` to support querying the+  kernel for the current terminal's settings to obtain the character+  assigned by the `stty erase` command. That can then be added to the+  Vty configuration's input map to map to `KBS` (backspace) if desired.++5.26+----++* Resolved various import warnings (thanks @glguy)+* Removed the `MonadIO` constraint from the Output type's fields and+  removed `MonadFail` uses (PR #177, thanks @glguy)+* Clarified documentation for ANSI colors (thanks Colby Jenn)+* `Graphics.Vty.Attributes` no longer re-exports+  `Graphics.Vty.Attributes.Color`+* The `Graphics.Vty.Attributes.Color` module is now exposed (thanks+  Colby Jenn)+* Raised upper bound for `microlens` to 0.4.12 (thanks Artyom Kazak)+* Changed from using `System.Posix.Env.getEnv` to+  `System.Environment.lookupEnv` (thanks Jonathan Osser)+* Added `Graphics.Vty.Image` functions for dealing with character width+  computations on `Text` values instead of `Strings`:+  * `safeWctwidth`+  * `safeWctlwidth`+  * `wctwidth`+  * `wctlwidth`++5.25.1+------++* Avoided a conflict with a Microlens 0.4.10 operator and added an+  upper bound on Microlens of 0.4.11.++5.25+----++* The Vty type got a new field, isShutdown, that returns whether the+  Vty handle has had its 'shutdown' function called (thanks Ian+  Jeffries)+* Vty's shutdown function is now thread-safe.++5.24.1+------++* The "shutdown" method of Vty handles is now idempotent (#159)++5.24+----++* Add Generic and NFData instances for some types+* Image: remove custom Show instance, add derived Show and Read+  instances+* Updated Travis build settings (thanks Eric Mertens)++5.23.1+------++* Fixed a bug where italics did not combine properly with other display+  modes (#155, thanks Eric Mertens)++5.23+----++* Added support for italicized output when terminfo supports it. This+  takes the form of a new Style, "italic". Note that most terminfo+  descriptors do not report capabilities for italics, so support for+  this will be very spotty.+* Updateed text/string function documentation to indicate that escapes+  are not permitted in their inputs.++5.22+----++* Added Graphics.Vty.Attributes.Color240.color240CodeToRGB function+  (thanks Brent Carmer)+* Added nextEventNonblocking function (field) to Vty type (#87)++5.21+----++* Picture and Background now provide Eq instances (thanks Jaro Reinders)+* #145: vty builds with microlens 0.4.9 (thanks Daniel Wagner)+* #142: note requirement of threaded RTS++5.20+----++API changes:+* Split up Monoid instances into Monoid and Semigroup for newer GHCs+  (thanks Ryan Scott)++5.19.1+------++API changes:+* Cursor now provides an Eq instance (thanks Jaro Reinders)++5.19+----++API changes:+* URL hyperlinking (via 'withURL') is now optional and disabled by+  default due to poor support on some common terminals. A new 'Mode'+  constructor, 'Hyperlink', has been added to enable this feature. To+  change the hyperlinking mode, use 'setMode' on the 'outputIface' of a+  Vty handle.++5.18.1+------++Bug fixes:+* Reset the hyperlink state on line endings to avoid run-on hyperlinks++5.18+----++API changes:+* Added support for hyperlinking attributes (thanks Getty Ritter). This+  change adds a new Attr field for containing the hyperlink to apply,+  as per https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda++5.17.1+------++* withStyle now ignores zero arguments, leaving attribute styles+  untouched if the input style is the null style++5.17+----++API changes:+* Add support for terminal focus events. This change adds a new mode+  usable with setMode, Focus, that requests that the terminal send+  events on focus lose/gain. This change also adds two new Event+  constructors, EvLostFocus and EvGainedFocus.+* No longer enable UTF8 mouse event encoding. This encoding was not+  working properly with Terminal.app, and using the other modes (SGR,+  etc.) work.+* Graphics.Vty.Attributes: escape backticks in Haddock comment (fixes+  #131)++5.16+----++API changes:+* Added support for mouse wheel events while in mouse mode. The Button+  type got two new constructors as a result: BScrollUp and BScrollDown.+  Thanks to doublescale@tutanota.com for this contribution!++Bug fixes:+* charFill now clamps negative arguments to zero (thanks Eric Mertens!)++5.15.1+------++Package changes:+* Documentation files are now marked accordingly (thanks Michal+  Suchánek)++Bug fixes:+* translateX/Y: fix negative translations++5.15+----++Package changes:+* Discontinued support for GHC versions prior to 7.10.1.+* Removed instructions and configuration for Stack builds since they+  are no longer supported.+* Clarified README mention of (lack of) Windows support (contributors+  wanted, though!)+* Removed dependency on data-default (see below).++API changes:+* Moved color definitions from Attributes to Color module.+* In lieu of data-default (Default) instances for Attr and Config, use+  'defAttr' and the new 'defaultConfig' (or 'mempty') instead of 'def'.+* Graphics.Vty.Output no longer re-exports+  Graphics.Vty.Output.Interface.+* Removed Graphics.Vty.Prelude module and moved DisplayRegion and its+  accessors to Graphics.Vty.Image.+* Graphics.Vty.Image no longer re-exports Graphics.Vty.Attributes.+* Graphics.Vty.Picture no longer re-exports Graphics.Vty.Image.++5.14+----++* addMaybeClippedJoin: instead of raising an exception when the join+  is totally clipped, just reduce the clip amount and continue+* addMaybeClipped: skip blit of joins when their primary dimension is+  zero+* 'string' and related text functions no longer treat an empty string+  as an empty image (thanks Chris Penner). This means that now it is+  possible to use 'str ""' as a non-empty image with height 1.++5.13+----++* Reverted changes in 5.12 due to disagreements between terminal+  emulators and utf8proc; for more details, please see the ticket+  discussion at+  https://github.com/coreyoconnor/vty/issues/115++5.12+----++* Replaced 'wcwidth' with a call to the utf8proc library's character+  width function, which is much more up to date (by several Unicode+  versions) and returns the right width for a much larger set of+  characters.+* Added a bundled version of the utf8proc C library.++5.11.3+------++* Fix mouse event offsets in mouse-up events++5.11.2+------++* Mouse events were modified so that the upper-left corner of the window+  is (0,0) rather than (1,1).++5.11.1+------++* Add Generic instance for Image+* nextEvent: stop trying to refresh on a resize event (fixes segfault+  on refresh with normal cursor positioning mode)+* Remove redundant clause from clipForCharWidth (thanks Eric Mertens)+* Update maintainer++5.11+----++* Vty now raises a VtyConfigurationError exception when the TERM+  evironment variable is missing (thanks Eric Mertens)+* Graphics.Vty.Config got an explicit export list to avoid accidentally+  exporting internal types (thanks Eric Mertens)++5.10+----++* Add absolute cursor positioning mode AbsoluteCursor to Cursor. This+  mode provides greater control over cursor positioning by bypassing+  the logical positioning provided by default. Rather than positioning+  the cursor by looking at the widths of characters involved, this+  constructor lets you provide a physical row and column instead. This+  is useful in more sophisticated programs. (thanks Eric Mertens)+* Added a new Generic-derived config parser (thanks Eric Mertens)+* Fixed the MShift case in the configuration file parser (thanks Eric+  Mertens)+* Fixed wcwidth import and matched safeWcswidth to its documented+  behavior. Previously vty_mk_wcwidth was being imported with the+  wrong type causing the -1 return value to be mapped to the wrong Int+  value. Additionally safeWcswidth was using the unsafe character width+  function and only ensuring that the final result was non-negative.+  (thanks Eric Mertens)++5.9.1+-----++* Vty now only emits UTF8 charset sequences in terminals without a+  preexisting UTF8 declaration to avoid emitting garbage sequences+  (fixes #89)++5.9+---++* Added new Output methods supportsBell and ringTerminalBell to find out+  whether the output device has an audio bell and to ring it (see #102)++5.8.1+-----++* Fixed "refresh" to work as advertised (see #104)++5.8+---++* API change: EvPaste input event now provides paste data as a raw+  ByteString rather than a String to allow the application to decode how+  best to decode it++5.7.1+-----++* ModeDemo: added an explicit Control.Applicative import for older GHCs++5.7+---++* Mouse and paste modes are now off by default.+* The Config type got new fields: mouseMode and bracketedPasteMode.+  These determine whether these modes are enabled initially (for+  terminals that support them).+* Added a Mode type for modal terminal features (mouse events,+  bracketed paste mode) that is used with new Output interface+  functions:+  * supportsMode :: Mode -> Bool tells whether the device supports a+    mode+  * setMode :: Mode -> Bool -> IO () turns a mode on or off+  * getModeStatus :: Mode -> IO Bool tells you whether a mode is on or+    off+* Added a new demo program, ModeDemo.hs, to demonstrate usage of modes++5.6+---++* Added support for normal and extended mouse modes in Xterm-like+  terminals via the MouseDown and MouseUp Event constructors+* Added support for bracketed paste mode in Xterm-like terminals via+  the EvPaste event constructor+* Added derived Show instances for Event and Button (thanks Felix+  Hirn)+* Now TERM values containing "screen" will automatically use the+  XtermColor driver rather than just TerminfoBased++5.5.0+-----++* Replaced lens dependency with microlens, microlens-mtl, microlens-th+  dependencies. Issue #90+  * Thanks Jonathan Daugherty+* Cabal corrections.+  * Thanks Lennart Spitzner++5.4.0+-----++* Changed eventChannel of Graphics.Vty.Input from Chan to+  TChan. This enables clients to query if there are no pending+  events. The Graphics.Vty interface nextEvent is unchanged.+  Clients that use eventChannel directly will require updating.+  https://github.com/coreyoconnor/vty/issues/60++5.3.1+-----++* Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to+  possibly breaking this on reasonable GHC versions++5.3+---++* Upgraded QuickCheck dependency to 2.7+* The standard IO Config (standardIOConfig) was overriding any provided+  application config. In addition, the inputFd and outputFd could not be+  changed if mkVty was used. Fixed.+* Correct handling of display attributes at end of line. The output+  attributes are set to default at the end of content for the line and+  at the start of a new line. Previously the current attribute would+  extend to the next start of content. This was odd to reason about and+  was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi+  requires the old behavior to display the selection region correctly.+* shutdown of the input thread is now performed using killThread and+  synchronization on an MVar. For correct handling of the terminal read+  vmin and vtime the read must be a blocking read on an OS thread.+  This places a threadWaitRead, which will be interrupted by the+  killThread, prior to the uninterruptable read. An alternative would be+  to re-import the read foreign call as interruptable.++5.2.11+------++* deepseq bounds increased for tests.+* Clean up warnings when compiling on 7.10+  * Thanks Eric Mertens+* Avoid discarding input bytes after multi-byte encoded codepoint+  * Thanks Eric Mertens++5.2.10+------++* "str" now returns EmptyImage for empty strings to match behavior of+  other string-like Image constructors (fixes #74)+  * Thanks Jonathan Daugherty++5.2.9+-----++* dependency version bumps+  * https://github.com/coreyoconnor/vty/pull/71+  * https://github.com/coreyoconnor/vty/pull/70+* Correct/Simplify the example code+  * Thanks glguy+  * https://github.com/coreyoconnor/vty/pull/69++5.2.8+-----++* blaze-builder, lens, utf8-string version constraint bump+    * Thanks glguy+    * https://github.com/coreyoconnor/vty/pull/67+* Do not differentiate based on TERM_PROGRAM+    * https://github.com/coreyoconnor/vty/issues/68++5.2.7+-----++* lens and deepseq constraint bump + misc+    * Thanks ethercrow+    * https://github.com/coreyoconnor/vty/pull/66++5.2.6+-----++* lens constraint bump+    * Thanks alexander-b!+    * https://github.com/coreyoconnor/vty/pull/64++5.2.5+-----++* lens and random version constraint bump.+    * Thanks RyanGlScott!+    * https://github.com/coreyoconnor/vty/pull/62++5.2.4+-----++* removed -fpic from cc-options. No longer required.+    * https://github.com/coreyoconnor/vty/issues/61+    * https://ghc.haskell.org/trac/ghc/ticket/9657+    * Thanks Fuuzetsu!++5.2.3+-----++* evaluate/compile the input parsing table once instead of each+  keystroke.+    * https://github.com/coreyoconnor/vty/pull/59+    * Thanks ethercrow!++5.2.2+-----++* When looking at input for an event, don't look too deep.+    * https://github.com/coreyoconnor/vty/pull/57+    * Thanks ethercrow!++5.2.1+-----++* Bump upper version bound for lens to 4.5. Thanks markus1189!++5.2.0+-----++* Config structure now specifies file descriptor to use. The default+  is stdInput and stdOutput file descriptors. Previously Vty used+  stdInput for input and the follow code for output:+    * hDuplicate stdout >>= handleToFd >>= (`hSetBuffering`+      NoBuffering)+    * the difference was required by Vty.Inline. Now, Vty.Inline uses+      the Config structure options to acheive the same effect.+* removed: derivedVtime, derivedVmin, inputForCurrentTerminal,+  inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO+* added: inputForConfig, outputForConfig+* updates to vty-rogue from jtdaugherty. Thanks!+* the oldest version of GHC tested to support vty is 7.6.2.+* the oldest version of GHC that vty compiles under is 7.4.2++5.1.4+-----++* merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!++5.1.1+-----++* merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke!+* jtdaugherty resolved a number of compiler warnings. Thanks!++5.1.0+-----++* vmin and vtime can be specified however the application requires.+  See Graphics.Vty.Config.+* fixed the processing of input when vmin is set > 1.++5.0.0+-----++* The naming convention now matches:+  * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions+* all projects using vty for input must be compiled with -threaded.+  Please notify vty author if this is not acceptable.+* mkVtyEscDelay has been removed. Use "mkVty def". Which initialized+  vty with the default configuration.+* input handling changes+  * KASCII is now KChar+  * KPN5 is now KCenter+  * tests exist.+  * Applications can add to the input tables by setting inputMap of+    the Config. See Graphics.Vty.Config+  * Users can define input table extensions that will apply to all vty+    applications. See Graphics.Vty.Config+  * terminal timing is now handled by selecting an appropriate VTIME.+    Previously this was implemented within Vty itself. This reduced+    complexity in vty but provides a different meta key behavior and+    implies a requirement on -threaded.+  * The time vty will wait to verify an ESC byte means a single ESC+    key is the singleEscPeriod of the Input Config structure.+* removed the typeclass based terminal and display context interface+  in favor of a data structure of properties interface.+* renamed the Terminal interface to Output+* The default picture for an image now uses the "clear" background.+  This background fills background spans with spaces or just ends the+  line.+  * Previously the background defaulted to the space character. This+    causes issues copying text from a text editor. The text would end+    up with extra spaces at the end of the line.+* Layer support+  * Each layer is an image.+  * The layers for a picture are a list of images.+  * The first image is the top-most layer. The images are ordered from+    top to bottom.+  * The transparent areas for a layer are the backgroundFill areas.+    backgroundFill is added to pad images when images of different+    sizes are joined.+  * If the background is clear there is no background layer.+  * If there is a background character then the bottom layer is the+    background layer.+  * emptyPicture is a Picture with no layers and no cursor+  * addToTop and addToBottom add a layer to the top and bottom of the+    given Picture.+* compatibility improvements:+  * terminfo based terminals with no cursor support are silently+    accepted. The cursor visibility changes in the Picture will have+    no effect.+  * alternate (setf/setb) color maps supported. Though colors beyond+    the first 8 are just a guess.+  * added "rgbColor" for easy support of RGB specified colors.+  * Both applications and users can add to the mapping used to+    translate from input bytes to events.+* Additional information about input and output process can be+  appended to a debug log+  * Set environment variable VTY_DEBUG_LOG to path of debug log+  * Or use "debugLog <path>" config directive+  * Or set 'debugLog' property of the Config provided to mkVty.+* examples moved to vty-examples package. See test directory for cabal+  file.+  * vty-interactive-terminal-test+    * interactive test. Useful for building a bug report for vty's+      author.+    * test/interactive_terminal_test.hs+  * vty-event-echo+    * view a input event log for vty. Example of interacting with+      user.+    * test/EventEcho.hs+  * vty-rogue+    * The start of a rogue-like game. Example of layers and image+      build operations.+    * test/Rogue.hs+  * vty-benchmark+    * benchmarks vty. A series of tests that push random pictures to+      the terminal. The random pictures are generated using+      QuickCheck. The same generators used in the automated tests.+    * test/benchmark.hs++4.7.0.0+-------++API changes:+* Added Graphics.Vty.Image.crop: Ensure an image is no larger+  than the specified size.+* Added Graphics.Vty.Image.pad: Ensure an image is no smaller+  than the specified size.+* Added Graphics.Vty.Image.translate: Offset an image.+* Thanks Ben Boeckel <MathStuf@gmail.com> for these features.++4.2.1.0+-------++API changes:+* Attr record accessor fore_color changed to attr_fore_color+* Attr record accessor back_color changed to attr_back_color+* Attr record accessor style changed to attr_style+* Added an "inline" display attribute changing DSL:+  * put_attr_change applies a display attribute change+    immediately to a terminal+  * For instance, can be used to change the display attrbiutes+    of text output via putStrLn and putStr. EX:+    "put_attr_change $ back_color red" will set the background+    color to red.+  * Changes do not apply to a Picture output via output_picture.+  * See Graphics.Vty.Inline+* Moved all IO actions into any monad an instance of MonadIO++4.0.0.1+-------++* binding for mk_wcswidth was incorrect. Most platforms just+  magically worked due to coincidence.++4.0.0+-----++API changes:+* "getSize" has been removed. Use "terminal vty >>= display_bounds"+  where "vty" is an instance of the Vty data structure.+* added a "terminal" field to the Vty data structure. Accesses the+  TerminalHandle associated with the Vty instance.+* Graphics.Vty.Types has undergone a number of changes. Summary:+  * Partitioned into Graphics.Vty.Attributes for display attributes.+    Graphics.Vty.Image for image combinators. Graphics.Vty.Picture+    for final picture construction.+* Graphics.Vty.Attributes:+  * "setFG" and "setBG" are now "with_fore_color" and+    "with_back_color"+  * All other "set.." equations similarly replaced.+  * "attr" is now "def_attr", short for "default display attributes"+    Also added a "current_attr" for "currently applied display+    attributes"+* Graphics.Vty.Image:+  * "horzcat" is now "horiz_cat"+  * "vertcat" is now "vert_cat"+  * "renderBS" is now "utf8_bytestring"+  * "renderChar" is now "char"+  * "renderFill" is now "char_fill"+  * added a "utf8_string" and "string" (AKA "iso_10464_string") for+    UTF-8 encoded Strings and ISO-10464 encoded Strings. String+    literals in GHC have an ISO-10464 runtime representation.+* Graphics.Vty.Picture:+  * exports Graphics.Vty.Image+  * "pic" is now "pic_for_image"+  * added API for setting background fill pattern.+* Completely rewritten output backend.+  * Efficient, scanline style output span generator. Has not been+    fully optimized, but good enough.+  * The details required to display the desired picture on a+    terminal are well encapsulated.+  * Terminfo based display terminal implementation. With specialized+    derivitives for xterm, Terminal.app, and iTerm.app.+      * Attempts to robustly handle even terminals that don't+        support all display attributes.+      * I've tested the following terminals with success: iTerm.app,+        Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal,+        konsole, screen, linux vty. Hopefully you will be as+        successfull.+  * Improved unicode support. Double wide characters will display as+    expected.+* 256 color support. See Graphics.Vty.Attributes.Color240. The actual+  output color is adjusted according to the number of colors the+  terminal supports.+* The Graphics.Vty.Image combinators no longer require matching+  dimensions to arguments. Unspecified areas are filled in with a+  user-customizable background pattern. See Graphics.Vty.Picture.+* output images are always cropped to display size.+* Significant code coverage by QuickCheck tests. An interactive test+  for those final properties that couldn't be automatically verified.++Issues resolved:+* "gnome terminal displays non-basic attributes as strikethrough"+  * http://trac.haskell.org/vty/ticket/14+* "Multi-byte characters are not displayed correctly on update"+  * http://trac.haskell.org/vty/ticket/10+* "Redraw does not handle rendering a line that extends beyond screen+  width characters"+  * http://trac.haskell.org/vty/ticket/13+* "The <|> and <-> combinators should be more forgiving of mismatched+  dimensions"+  * http://trac.haskell.org/vty/ticket/9+* "256-color support"+  * http://trac.haskell.org/vty/ticket/19
− Demo.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Main where--import Graphics.Vty--import Control.Applicative hiding ((<|>))-import Control.Arrow-import Control.Monad.RWS--import Data.Default (def)-import Data.Sequence (Seq, (<|) )-import qualified Data.Sequence as Seq-import Data.Foldable--eventBufferSize = 1000--type App = RWST Vty () (Seq String) IO--main = do-    vty <- if True -- change to false for emacs-like input processing-            then mkVty def-            else mkVty (def { vmin = Just 2, vtime = Just 300 } )-    _ <- execRWST (vtyInteract False) vty Seq.empty-    shutdown vty--vtyInteract :: Bool -> App ()-vtyInteract shouldExit = do-    updateDisplay-    unless shouldExit $ handleNextEvent >>= vtyInteract--introText = vertCat $ map (string defAttr)-    [ "this line is hidden by the top layer"-    , "The vty demo program will echo the events generated by the pressed keys."-    , "Below there is a 240 color box."-    , "Followed by a description of the 16 color pallete."-    , "If the 240 color box is not visible then the terminal"-    , "claims 240 colors are not supported."-    , "Try setting TERM to xterm-256color"-    , "This text is on a lower layer than the event list."-    , "Which means it'll be hidden soon."-    , "Bye!"-    , "Great Faith in the ¯\\_(ツ)_/¯"-    , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯"-    ]--colorbox_240 :: Image-colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages-    where-        colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]-        splitColorImages [] = []-        splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))--colorbox_16 :: Image-colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border-    where-        column0 = vertCat $ map lineWithColor normal-        column1 = vertCat $ map lineWithColor bright-        border = vertCat $ replicate (length normal) $ string defAttr " | "-        column2 = vertCat $ map (string defAttr . snd) normal-        lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName-        normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ]-                     [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]-        bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue-                     , brightMagenta, brightCyan, brightWhite ]-                     [ "bright black", "bright red", "bright green", "bright yellow"-                     , "bright blue", "bright magenta", "bright cyan", "bright white" ]--updateDisplay :: App ()-updateDisplay = do-    let info = string (defAttr `withForeColor` black `withBackColor` green)-                      "Press ESC to exit. Events for keys below."-    eventLog <- foldMap (string defAttr) <$> get-    let pic = picForImage (info <-> eventLog)-              `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)-    vty <- ask-    liftIO $ update vty pic--handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent-    where-        handleEvent e               = do-            modify $ (<|) (show e) >>> Seq.take eventBufferSize-            return $ e == EvKey KEsc []-
LICENSE view
@@ -1,3 +1,5 @@+BSD 3-Clause License+ Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009  All rights reserved.
README.md view
@@ -1,122 +1,173 @@-[![Build Status](https://travis-ci.org/coreyoconnor/vty.png)](https://travis-ci.org/coreyoconnor/vty)--`vty` is a terminal interface library.--This project is hosted on github.com: https://github.com/coreyoconnor/vty+[![Build Status](https://travis-ci.org/jtdaugherty/vty.png)](https://travis-ci.org/jtdaugherty/vty) -Install via `git` with:+`vty` is a terminal interface library. It provides a high-level+interface for doing terminal I/O. Vty is supported on GHC versions+7.10.1 and up. -```-git clone git://github.com/coreyoconnor/vty.git-```+`vty` and its partner packages are published on+[Hackage](https://hackage.haskell.org/). The `vty` package works in+concert with one or more *platform packages* to do terminal I/O. Each+platform package provides support for terminal I/O on a specific+platform. Known platform packages are: -Install via `cabal` with:+* [vty-unix](https://github.com/jtdaugherty/vty-unix) - the Unix+  terminal backend for Vty+* [vty-windows](https://github.com/chhackett/vty-windows) - the Windows+  terminal backend for Vty+* [vty-crossplatform](https://github.com/jtdaugherty/vty-crossplatform) -+  a package that builds `vty-unix` or `vty-windows` based on the build+  environment -```-cabal install vty-```+# How to use Vty -# Features+1. Add a package dependency on `vty-unix`, `vty-windows,` or+   `vty-crossplatform`, depending on the desired level of platform+   support. For example, if an application only supports Unix systems,+   it should depend on `vty-unix`. But if an application is intended to+   work anywhere Vty works, then `vty-crossplatform` is the best choice.+2. Add a package dependency on `vty`; the core library abstractions,+   types, and functions are obtained from `vty` itself. The platform+   packages do not re-export the core library's modules.+3. Import `mkVty` from the platform package in step (1) and use that to+   construct a `Vty` handle and initialize the terminal.+4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty+   user configuration since this step is not automatic. -* Support for a large number of terminals. vt100, ansi, hurd, linux, screen etc-  etc. Anything with a sufficient terminfo entry.+Once you've initialized the terminal and have a `Vty` value, all of the+`vty` package's API is now ready to use to do terminal I/O. -* Automatic handling of window resizes.+# Implementing support for a new platform -* If the terminal support UTF-8 then vty supports Unicode output.+Although this shouldn't be necessary to do very often (if ever!), if+you would like to implement support for a new platform for Vty, see+`PLATFORM-HOWTO.md`. -* Handles multi-column glyphs. (Requires user to properly configure terminal.)+# Features -* Efficient output. Output buffering and terminal state changes are minimized.+* Provides an efficient output algorithm. Output buffering and terminal+  state changes are minimized. -* Minimizes repaint area. Virtually eliminating the flicker problems that-  plagues ncurses programs.+* Automatically handles window resizes. -* A pure, compositional interface for efficiently constructing display images.+* Minimizes repaint area, which virtually eliminates the flicker+  problems that plague ncurses programs. -* Automatically decodes keyboard keys into (key,[modifier]) tuples.+* Provides a pure, compositional interface for efficiently constructing+  display images.  * Automatically supports refresh on Ctrl-L. -* Automatically supports timeout after for lone ESC. The timeout is-  customizable.--* Interface is designed for easy compatible extension.--* Supports ANSI graphics modes (SGR as defined in console_codes(4)) with a-  type-safe interface. Gracefull fallback for terminals that do not support, or-  partially support the standard ANSI graphics modes.--* Properly handles cleanup, but not due to signals.+* Provides extensible input and output interfaces. -* Comprehensive test suite.+* Properly handles cleanup (but not due to signals). -# Known Issues+* Provides a comprehensive test suite. -* Terminals have numerous quirks and bugs. vty picks what works best for the-  author in ambigious, or buggy situations.+* Supports "normal" and "extended" (SGR) mouse modes as described at+  http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking -* Signal handling of STOP, TERM and INT are non existent.+* Supports bracketed paste mode as described at+  http://cirw.in/blog/bracketed-paste -* The character encoding of the terminal is assumed to be UTF-8 if-  unicode is used.+* 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. -* 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.+# Development Notes -* Uses the TIOCGWINSZ ioctl to find the current window size, which appears to be-  limited to Linux and BSD.+Vty uses threads internally, so programs made with Vty need to be+compiled with the threaded runtime using the GHC `-threaded` option. -# Platform Support+# Multi-Column Character Support -## Posix Terminals+Vty supports rendering of multi-column characters such as two-column+Asian characters and Emoji characters. This section details how to+take advantage of this feature, since its behavior will depend on the+terminal emulator in use. -Uses terminfo to determine terminal protocol. With some special rules to handle-some omissions from terminfo.+Terminal emulators support Unicode to varying degrees, and each terminal+emulator relies on a table of column widths for each supported Unicode+character. Vty also needs to rely on such a table to compute the width+of Vty images to do image layout. Since those tables can disagree if+Vty and the terminal emulator support different versions of Unicode,+and since different terminal emulators will support different versions+of Unicode, it's likely that for some wide characters, Vty applications+will exhibit rendering problems. Those rendering problems arise from Vty+and the terminal emulator coming to different conclusions about how wide+some characters are. -## Windows+To address this, Vty supports loading custom character width tables+that are based on the terminal's behavior in order to eliminate these+disagreements. By default, though, Vty will use its built-in Unicode+character width table. Since the built-in table is likely to eventually+disagree with your terminal, Vty provides an API and a command-line tool+to generate and install custom tables. -cygwin only.+Custom Unicode width tables based on your terminal emulator can+be built by using the API in `Graphics.Vty.UnicodeWidthTable`.+The process works by querying the current terminal environment to+obtain its width measurements for the entire supported Unicode+range. The results are then saved to a disk file. -# Development Notes+Saved width tables can then be loaded in one of two ways: -## Under NixOS+* 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 -### Using cabal+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., -After installing ncurses to user env.+```+widthMap "xterm" "/path/to/map.dat"+``` -~~~-LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib-LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build-LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test-~~~+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. -### Using stack+The tables declared in the configuration file are only ever+automatically loaded when applications set up Vty by calling+`Graphics.Vty.mkVty`. -~~~-stack build-stack test-stack install-~~~+Before a custom table has been loaded, calls to the library's character+width functions (e.g. `wcwidth`) will use the default built-in table.+Once a custom table has been loaded, the functions will use the new+custom table. Only one custom table load can be performed in a Vty+program. Once a custom table has been loaded, it cannot be replaced or+removed. -## Coverage+# Contributing -As of last testing, profiling causes issues with coverage when enabled. To-evaluate coverage configure as follows:+If you decide to contribute, that's great! Here are some guidelines you+should consider to make submitting patches easier for all concerned: -~~~-rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \-  --disable-library-profiling \-  --disable-executable-profiling-~~~+ - Patches written completely or partially by AI are unlikely to be+   accepted. Please disclose any AI use.+ - If you want to take on big things, talk to me first; let's have a+   design/vision discussion before you start coding. Create a GitHub+   issue and we can use that as the place to hash things out.+ - If you make changes, make them consistent with the syntactic+   conventions already used in the codebase.+ - Please provide Haddock documentation for any changes you make.+ - Please do NOT include package version changes in your patches.+   Package version changes are only done at release time when the full+   scope of a release's changes can be evaluated to determine the+   appropriate version change. -## Profiling+# Further Reading +Good sources of documentation for terminal programming are: -~~~-rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \-  --enable-library-profiling \-  --enable-executable-profiling-~~~+* https://github.com/b4winckler/vim/blob/master/src/term.c+* http://invisible-island.net/xterm/ctlseqs/ctlseqs.html+* http://ulisse.elettra.trieste.it/services/doc/serial/config.html+* http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html+* http://www.unixwiz.net/techtips/termios-vmin-vtime.html+* http://vt100.net/docs/vt100-ug/chapter3.html
− TODO 
@@ -1,15 +0,0 @@-- Improve input handling-  - base off of haskeline input system. The haskeline input system appears to be excellent and-    satisfy all of Vty's input requirements. The current haskeline distribution does not appear to-    export the required modules. Either:-        0. Add the required exports to the haskeline distribution. -            - fine for development but complicates the UI for production clients. Though, exposing-              the modules would only complicate the appearance of haskeline's interface. -        1. Partition the backend of haskeline into a separate package usable by both vty and-        haskeline.-- use compact-string for character encoding handling-- Custom cursor appearance handling?-    - specific color?-    - reverse video?-    - auto?-
− cbits/gwinsz.c 
@@ -1,9 +0,0 @@-#include <sys/ioctl.h>--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;-}
cbits/mk_wcwidth.c view
@@ -59,15 +59,40 @@  * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c  */ -#include <wchar.h>+#include <HsFFI.h>+#include <stdlib.h>+#include <string.h> +// The maximum size for a custom character width table is the total+// number of possible characters as dictated by the compiler.+#define MAX_CUSTOM_TABLE_SIZE (HS_CHAR_MAX + 1)++// The pointer to the start of the custom character width table, if+// any. If this is NULL or this is set but the ready flag is false, the+// built-in tree search logic is used.+static uint8_t* custom_table = NULL;++// Unused table cell value.+static uint8_t UNUSED_CELL = 0xff;++// The size of the custom table, in entries. This should only be set+// if custom_table is not NULL. Its value should be the size of the+// custom_table array.+static uint32_t custom_table_size = 0;++// A flag indicating whether the custom table is ready for+// use. This should only be set once the table has been+// allocated with vty_init_custom_table and initialized with+// vty_set_custom_table_range.+static uint8_t custom_table_ready = 0;+ struct interval {   int first;   int last; };  /* auxiliary function for binary search in interval table */-static int vty_bisearch(wchar_t ucs, const struct interval *table, int max) {+static int vty_bisearch(HsChar ucs, const struct interval *table, int max) {   int min = 0;   int mid; @@ -119,7 +144,7 @@  * in ISO 10646.  */ -int vty_mk_wcwidth(wchar_t ucs)+static HsInt builtin_wcwidth(HsChar ucs) {   /* sorted list of non-overlapping intervals of non-spacing characters */   /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */@@ -182,7 +207,7 @@    /* binary search in table of non-spacing characters */   if (vty_bisearch(ucs, combining,-	       sizeof(combining) / sizeof(struct interval) - 1))+              sizeof(combining) / sizeof(struct interval) - 1))     return 0;    /* if we arrive here, ucs is not a combining or C0/C1 control character */@@ -203,107 +228,124 @@       (ucs >= 0x30000 && ucs <= 0x3fffd))); } --int vty_mk_wcswidth(const wchar_t *pwcs, size_t n)+// Return the width, in terminal cells, of the specified character.+//+// If the global custom width table is present, that table will be+// consulted for the character's width. If the character is not in the+// table, this will fall back to the built-in table. If the character is+// in neither table, zero will be returned. If the custom width table is+// not present, the built-in width table will be used.+HsInt vty_mk_wcwidth(HsChar ch) {-  int w, width = 0;--  for (;n-- > 0; pwcs++)-    if ((w = vty_mk_wcwidth(*pwcs)) < 0)-      return -1;-    else-      width += w;+    if (custom_table_ready) {+        if ((ch >= 0) && (ch < custom_table_size)) {+            uint8_t result = custom_table[ch]; -  return width;+            // The table is filled with UNUSED_CELL values for+            // uninitialized ranges so we can defer to the built-in+            // table in those cases.+            if (result == UNUSED_CELL) {+                return builtin_wcwidth(ch);+            } else {+                return result;+            }+        } else {+            return -1;+        }+    } else {+        return builtin_wcwidth(ch);+    } } --/*- * The following functions are the same as mk_wcwidth() and- * mk_wcswidth(), except that spacing characters in the East Asian- * Ambiguous (A) category as defined in Unicode Technical Report #11- * have a column width of 2. This variant might be useful for users of- * CJK legacy encodings who want to migrate to UCS without changing- * the traditional terminal character-width behaviour. It is not- * otherwise recommended for general use.- */-int vty_mk_wcwidth_cjk(wchar_t ucs)+// Initialize a custom character width table.+//+// This allocates a new character width table of the specified size+// (in characters). If a custom table has already been allocated, this+// returns 1. Otherwise it allocates a new table, initializes all of its+// entries to UNUSED_CELL, and returns zero.+//+// Note that this does *not* mark the table as ready for use. Until the+// table is marked ready, it will not be used by vty_mk_wcwidth. To mark+// the table as ready, call vty_activate_custom_table() after the table+// has been set up with calls to vty_set_custom_table_range.+int vty_init_custom_table(int size) {-  /* sorted list of non-overlapping intervals of East Asian Ambiguous-   * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */-  static const struct interval ambiguous[] = {-    { 0x00A1, 0x00A1 }, { 0x00A4, 0x00A4 }, { 0x00A7, 0x00A8 },-    { 0x00AA, 0x00AA }, { 0x00AE, 0x00AE }, { 0x00B0, 0x00B4 },-    { 0x00B6, 0x00BA }, { 0x00BC, 0x00BF }, { 0x00C6, 0x00C6 },-    { 0x00D0, 0x00D0 }, { 0x00D7, 0x00D8 }, { 0x00DE, 0x00E1 },-    { 0x00E6, 0x00E6 }, { 0x00E8, 0x00EA }, { 0x00EC, 0x00ED },-    { 0x00F0, 0x00F0 }, { 0x00F2, 0x00F3 }, { 0x00F7, 0x00FA },-    { 0x00FC, 0x00FC }, { 0x00FE, 0x00FE }, { 0x0101, 0x0101 },-    { 0x0111, 0x0111 }, { 0x0113, 0x0113 }, { 0x011B, 0x011B },-    { 0x0126, 0x0127 }, { 0x012B, 0x012B }, { 0x0131, 0x0133 },-    { 0x0138, 0x0138 }, { 0x013F, 0x0142 }, { 0x0144, 0x0144 },-    { 0x0148, 0x014B }, { 0x014D, 0x014D }, { 0x0152, 0x0153 },-    { 0x0166, 0x0167 }, { 0x016B, 0x016B }, { 0x01CE, 0x01CE },-    { 0x01D0, 0x01D0 }, { 0x01D2, 0x01D2 }, { 0x01D4, 0x01D4 },-    { 0x01D6, 0x01D6 }, { 0x01D8, 0x01D8 }, { 0x01DA, 0x01DA },-    { 0x01DC, 0x01DC }, { 0x0251, 0x0251 }, { 0x0261, 0x0261 },-    { 0x02C4, 0x02C4 }, { 0x02C7, 0x02C7 }, { 0x02C9, 0x02CB },-    { 0x02CD, 0x02CD }, { 0x02D0, 0x02D0 }, { 0x02D8, 0x02DB },-    { 0x02DD, 0x02DD }, { 0x02DF, 0x02DF }, { 0x0391, 0x03A1 },-    { 0x03A3, 0x03A9 }, { 0x03B1, 0x03C1 }, { 0x03C3, 0x03C9 },-    { 0x0401, 0x0401 }, { 0x0410, 0x044F }, { 0x0451, 0x0451 },-    { 0x2010, 0x2010 }, { 0x2013, 0x2016 }, { 0x2018, 0x2019 },-    { 0x201C, 0x201D }, { 0x2020, 0x2022 }, { 0x2024, 0x2027 },-    { 0x2030, 0x2030 }, { 0x2032, 0x2033 }, { 0x2035, 0x2035 },-    { 0x203B, 0x203B }, { 0x203E, 0x203E }, { 0x2074, 0x2074 },-    { 0x207F, 0x207F }, { 0x2081, 0x2084 }, { 0x20AC, 0x20AC },-    { 0x2103, 0x2103 }, { 0x2105, 0x2105 }, { 0x2109, 0x2109 },-    { 0x2113, 0x2113 }, { 0x2116, 0x2116 }, { 0x2121, 0x2122 },-    { 0x2126, 0x2126 }, { 0x212B, 0x212B }, { 0x2153, 0x2154 },-    { 0x215B, 0x215E }, { 0x2160, 0x216B }, { 0x2170, 0x2179 },-    { 0x2190, 0x2199 }, { 0x21B8, 0x21B9 }, { 0x21D2, 0x21D2 },-    { 0x21D4, 0x21D4 }, { 0x21E7, 0x21E7 }, { 0x2200, 0x2200 },-    { 0x2202, 0x2203 }, { 0x2207, 0x2208 }, { 0x220B, 0x220B },-    { 0x220F, 0x220F }, { 0x2211, 0x2211 }, { 0x2215, 0x2215 },-    { 0x221A, 0x221A }, { 0x221D, 0x2220 }, { 0x2223, 0x2223 },-    { 0x2225, 0x2225 }, { 0x2227, 0x222C }, { 0x222E, 0x222E },-    { 0x2234, 0x2237 }, { 0x223C, 0x223D }, { 0x2248, 0x2248 },-    { 0x224C, 0x224C }, { 0x2252, 0x2252 }, { 0x2260, 0x2261 },-    { 0x2264, 0x2267 }, { 0x226A, 0x226B }, { 0x226E, 0x226F },-    { 0x2282, 0x2283 }, { 0x2286, 0x2287 }, { 0x2295, 0x2295 },-    { 0x2299, 0x2299 }, { 0x22A5, 0x22A5 }, { 0x22BF, 0x22BF },-    { 0x2312, 0x2312 }, { 0x2460, 0x24E9 }, { 0x24EB, 0x254B },-    { 0x2550, 0x2573 }, { 0x2580, 0x258F }, { 0x2592, 0x2595 },-    { 0x25A0, 0x25A1 }, { 0x25A3, 0x25A9 }, { 0x25B2, 0x25B3 },-    { 0x25B6, 0x25B7 }, { 0x25BC, 0x25BD }, { 0x25C0, 0x25C1 },-    { 0x25C6, 0x25C8 }, { 0x25CB, 0x25CB }, { 0x25CE, 0x25D1 },-    { 0x25E2, 0x25E5 }, { 0x25EF, 0x25EF }, { 0x2605, 0x2606 },-    { 0x2609, 0x2609 }, { 0x260E, 0x260F }, { 0x2614, 0x2615 },-    { 0x261C, 0x261C }, { 0x261E, 0x261E }, { 0x2640, 0x2640 },-    { 0x2642, 0x2642 }, { 0x2660, 0x2661 }, { 0x2663, 0x2665 },-    { 0x2667, 0x266A }, { 0x266C, 0x266D }, { 0x266F, 0x266F },-    { 0x273D, 0x273D }, { 0x2776, 0x277F }, { 0xE000, 0xF8FF },-    { 0xFFFD, 0xFFFD }, { 0xF0000, 0xFFFFD }, { 0x100000, 0x10FFFD }-  };--  /* binary search in table of non-spacing characters */-  if (vty_bisearch(ucs, ambiguous,-	       sizeof(ambiguous) / sizeof(struct interval) - 1))-    return 2;--  return vty_mk_wcwidth(ucs);+    if (custom_table == NULL) {+        if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) {+            custom_table_ready = 0;+            custom_table = malloc(size);+            memset(custom_table, UNUSED_CELL, size);+            custom_table_size = size;+            return 0;+        } else {+            return 1;+        }+    } else {+        return 1;+    } } +// Set the specified character range in the custom width table to the+// specified width.+//+// This function sets 'width' as the character width for all entries+// in the custom character table starting at the 'start' entry and+// including all entries up to and including 'start + size - 1'.+//+// If this succeeds, it returns zero. If it fails, it returns 1. It+// fails if the table is not allocated, marked as ready (i.e. it is in+// use and has already been populated), or if the start or size values+// are not in bounds for the table.+int vty_set_custom_table_range(uint32_t start, uint32_t size, uint8_t width)+{+    if ((custom_table == NULL) ||+        (size >= custom_table_size) ||+        (start >= custom_table_size) ||+        ((start + 1) >= (custom_table_size - size)) ||+        custom_table_ready) {+        return 1;+    } else {+        memset(custom_table + start, width, size);+        return 0;+    }+} -int vty_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n)+// Mark the allocated custom character width table as ready for use.+//+// After this call, further calls to vty_set_custom_table_range will+// fail.+//+// This function returns 0 if it succeeds. If it fails, it returns 1.+// It fails if the custom table is already ready or if it has not been+// allocated.+int vty_activate_custom_table() {-  int w, width = 0;+    if (custom_table_ready || (custom_table == NULL)) {+        return 1;+    } else {+        custom_table_ready = 1;+        return 0;+    }+} -  for (;n-- > 0; pwcs++)-    if ((w = vty_mk_wcwidth_cjk(*pwcs)) < 0)-      return -1;-    else-      width += w;+// Returns whether a custom character width table has been marked ready.+int vty_custom_table_ready()+{+    return custom_table_ready;+} -  return width;+// Deallocate the custom width table.+//+// This does nothing if there is no allocated custom width table, or if+// there is one but it is in use (marked ready). This is only useful if+// an initial allocation succeeds, but range population fails, after+// which point the application may want to deallocate the table to avoid+// leaving it in an intermediate state.+void vty_deallocate_custom_table()+{+    if ((custom_table != NULL) && (!custom_table_ready)) {+        free(custom_table);+        custom_table = NULL;+        custom_table_size = 0;+    } }
− cbits/set_term_timing.c 
@@ -1,13 +0,0 @@-#include <termios.h>-#include <stdio.h>-#include <unistd.h>-#include <stdlib.h>--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);-}
− src/Codec/Binary/UTF8/Debug.hs 
@@ -1,19 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- Copyright 2009 Corey O'Connor-module Codec.Binary.UTF8.Debug -    where--import Codec.Binary.UTF8.String ( encode )--import Data.Word--import Numeric---- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the--- corresponding UTF8 byte sequence-utf8FromIso :: [Int] -> [Word8]-utf8FromIso = encode . map toEnum--ppUtf8 :: [Int] -> IO ()-ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso-
− src/Data/Terminfo/Eval.hs 
@@ -1,140 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK hide #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif--{- Evaluates the paramaterized terminfo string capability with the given parameters.- -- -}-module Data.Terminfo.Eval (writeCapExpr)-    where--import Blaze.ByteString.Builder.Word-import Blaze.ByteString.Builder-import Data.Terminfo.Parse--import Control.Monad.Identity-import Control.Monad.State.Strict-import Control.Monad.Writer--import Data.Bits ((.|.), (.&.), xor)-import Data.List--import qualified Data.Vector.Unboxed as Vector--#if !(MIN_VERSION_base(4,8,0))-import Data.Word-#endif---- | capability evaluator state-data EvalState = EvalState-    { evalStack :: ![CapParam]-    , evalExpression :: !CapExpression-    , evalParams :: ![CapParam]-    }--type Eval a = StateT EvalState (Writer Write) a--pop :: Eval CapParam-pop = do-    s <- get-    let v : stack' = evalStack s-        s' = s { evalStack = stack' }-    put s'-    return v--readParam :: Word -> Eval CapParam-readParam pn = do-    !params <- get >>= return . evalParams-    return $! genericIndex params pn--push :: CapParam -> Eval ()-push !v = do-    s <- get-    let s' = s { evalStack = v : evalStack s }-    put s'--applyParamOps :: CapExpression -> [CapParam] -> [CapParam]-applyParamOps cap params = foldl applyParamOp params (paramOps cap)--applyParamOp :: [CapParam] -> ParamOp -> [CapParam]-applyParamOp params IncFirstTwo = map (+ 1) params--writeCapExpr :: CapExpression -> [CapParam] -> Write-writeCapExpr cap params =-    let params' = applyParamOps cap params-        s0 = EvalState [] cap params'-    in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)--writeCapOps :: CapOps -> Eval ()-writeCapOps ops = mapM_ writeCapOp ops--writeCapOp :: CapOp -> Eval ()-writeCapOp (Bytes !offset !count) = do-    !cap <- get >>= return . evalExpression-    let bytes = Vector.take count $ Vector.drop offset (capBytes cap)-    Vector.forM_ bytes $ tell.writeWord8-writeCapOp DecOut = do-    p <- pop-    forM_ (show p) $ tell.writeWord8.toEnum.fromEnum-writeCapOp CharOut = do-    pop >>= tell.writeWord8.toEnum.fromEnum -writeCapOp (PushParam pn) = do-    readParam pn >>= push-writeCapOp (PushValue v) = do-    push v-writeCapOp (Conditional expr parts) = do-    writeCapOps expr-    writeContitionalParts parts-    where -        writeContitionalParts [] = return ()-        writeContitionalParts ((trueOps, falseOps) : falseParts) = do-            -- (man 5 terminfo)-            -- Usually the %? expr part pushes a value onto the stack, and %t pops  it  from  the-            -- stack, testing if it is nonzero (true).  If it is zero (false), control-            -- passes to the %e (else) part.-            v <- pop-            if v /= 0-                then writeCapOps trueOps-                else do-                    writeCapOps falseOps-                    writeContitionalParts falseParts--writeCapOp BitwiseOr = do-    v0 <- pop-    v1 <- pop-    push $ v0 .|. v1-writeCapOp BitwiseAnd = do-    v0 <- pop-    v1 <- pop-    push $ v0 .&. v1-writeCapOp BitwiseXOr = do-    v1 <- pop-    v0 <- pop-    push $ v0 `xor` v1-writeCapOp ArithPlus = do-    v1 <- pop-    v0 <- pop-    push $ v0 + v1-writeCapOp ArithMinus = do-    v1 <- pop-    v0 <- pop-    push $ v0 - v1-writeCapOp CompareEq = do-    v1 <- pop-    v0 <- pop-    push $ if v0 == v1 then 1 else 0-writeCapOp CompareLt = do-    v1 <- pop-    v0 <- pop-    push $ if v0 < v1 then 1 else 0-writeCapOp CompareGt = do-    v1 <- pop-    v0 <- pop-    push $ if v0 > v1 then 1 else 0-
− src/Data/Terminfo/Parse.hs 
@@ -1,348 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS_GHC -funbox-strict-fields -O #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif--module Data.Terminfo.Parse ( module Data.Terminfo.Parse-                           , Text.Parsec.ParseError-                           )-    where--import Control.Monad ( liftM )-import Control.DeepSeq--import Data.Word-import qualified Data.Vector.Unboxed as Vector--import Numeric (showHex)--import Text.Parsec--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif--data CapExpression = CapExpression-    { capOps :: !CapOps-    , capBytes :: !(Vector.Vector Word8)-    , sourceString :: !String-    , paramCount :: !Int-    , paramOps :: !ParamOps-    } deriving (Eq)--instance Show CapExpression where-    show c-        = "CapExpression { " ++ show (capOps c) ++ " }"-        ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]"-        ++ " <= " ++ show (sourceString c)-        where-            hexDump :: [Word8] -> String-            hexDump = foldr (\b s -> showHex b s) ""--instance NFData CapExpression where-    rnf (CapExpression ops !_bytes !str !c !pOps) -        = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps--type CapParam = Word--type CapOps = [CapOp]-data CapOp = -      Bytes !Int !Int -- offset count-    | DecOut | CharOut-    -- This stores a 0-based index to the parameter. However the operation that implies this op is-    -- 1-based-    | PushParam !Word | PushValue !Word-    -- The conditional parts are the sequence of (%t expression, %e expression) pairs.-    -- The %e expression may be NOP-    | Conditional -      { conditionalExpr :: !CapOps-      , conditionalParts :: ![(CapOps, CapOps)]-      }-    | BitwiseOr | BitwiseXOr | BitwiseAnd-    | ArithPlus | ArithMinus-    | CompareEq | CompareLt | CompareGt-    deriving (Show, Eq)--instance NFData CapOp where-    rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount-    rnf (PushParam pn) = rnf pn-    rnf (PushValue v) = rnf v -    rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts -    rnf BitwiseOr = ()-    rnf BitwiseXOr = ()-    rnf BitwiseAnd = ()-    rnf ArithPlus = ()-    rnf ArithMinus = ()-    rnf CompareEq = ()-    rnf CompareLt = ()-    rnf CompareGt = ()-    rnf DecOut = ()-    rnf CharOut = ()--type ParamOps = [ParamOp]-data ParamOp =-      IncFirstTwo-    deriving (Show, Eq)--instance NFData ParamOp where-    rnf IncFirstTwo = ()--parseCapExpression :: String -> Either ParseError CapExpression-parseCapExpression capString = -    let v = runParser capExpressionParser-                      initialBuildState-                      "terminfo cap" -                      capString -    in case v of-        Left e -> Left e-        Right buildResults -> Right $ constructCapExpression capString buildResults--constructCapExpression :: [Char] -> BuildResults -> CapExpression-constructCapExpression capString buildResults =-    let expr = CapExpression-                { capOps = outCapOps buildResults-                -- The cap bytes are the lower 8 bits of the input string's characters.-                -- \todo Verify the input string actually contains an 8bit byte per character.-                , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString-                , sourceString = capString-                , paramCount = outParamCount buildResults-                , paramOps = outParamOps buildResults-                } -    in rnf expr `seq` expr--type CapParser a = Parsec String BuildState a --capExpressionParser :: CapParser BuildResults-capExpressionParser = do-    rs <- many $ paramEscapeParser <|> bytesOpParser -    return $ mconcat rs--paramEscapeParser :: CapParser BuildResults-paramEscapeParser = do-    _ <- char '%'-    incOffset 1-    literalPercentParser <|> paramOpParser --literalPercentParser :: CapParser BuildResults-literalPercentParser = do-    _ <- char '%'-    startOffset <- getState >>= return . nextOffset-    incOffset 1-    return $ BuildResults 0 [Bytes startOffset 1] []--paramOpParser :: CapParser BuildResults-paramOpParser-    = incrementOpParser -    <|> pushOpParser-    <|> decOutParser-    <|> charOutParser-    <|> conditionalOpParser-    <|> bitwiseOpParser-    <|> arithOpParser-    <|> literalIntOpParser-    <|> compareOpParser-    <|> charConstParser--incrementOpParser :: CapParser BuildResults-incrementOpParser = do-    _ <- char 'i'-    incOffset 1-    return $ BuildResults 0 [] [ IncFirstTwo ]--pushOpParser :: CapParser BuildResults-pushOpParser = do-    _ <- char 'p'-    paramN <- digit >>= return . (\d -> read [d])-    incOffset 2-    return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []--decOutParser :: CapParser BuildResults-decOutParser = do-    _ <- char 'd'-    incOffset 1-    return $ BuildResults 0 [ DecOut ] []--charOutParser :: CapParser BuildResults-charOutParser = do-    _ <- char 'c'-    incOffset 1-    return $ BuildResults 0 [ CharOut ] []--conditionalOpParser :: CapParser BuildResults-conditionalOpParser = do-    _ <- char '?'-    incOffset 1-    condPart <- manyExpr conditionalTrueParser-    parts <- manyP -             ( do-                truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser-                                              , conditionalFalseParser -                                              ]-                falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser-                                               , conditionalTrueParser-                                               ]-                return ( truePart, falsePart )-             ) -             conditionalEndParser--    let trueParts = map fst parts-        falseParts = map snd parts-        BuildResults n cond condParamOps = condPart--    let n' = maximum $ n : map outParamCount trueParts-        n'' = maximum $ n' : map outParamCount falseParts--    let trueOps = map outCapOps trueParts-        falseOps = map outCapOps falseParts-        condParts = zip trueOps falseOps--    let trueParamOps = mconcat $ map outParamOps trueParts-        falseParamOps = mconcat $ map outParamOps falseParts-        pOps = mconcat [condParamOps, trueParamOps, falseParamOps]--    return $ BuildResults n'' [ Conditional cond condParts ] pOps--    where -        manyP !p !end = choice -            [ try end >> return []-            , do !v <- p -                 !vs <- manyP p end-                 return $! v : vs-            ]-        manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end--conditionalTrueParser :: CapParser ()-conditionalTrueParser = do-    _ <- string "%t"-    incOffset 2--conditionalFalseParser :: CapParser ()-conditionalFalseParser = do-    _ <- string "%e"-    incOffset 2--conditionalEndParser :: CapParser ()-conditionalEndParser = do-    _ <- string "%;"-    incOffset 2--bitwiseOpParser :: CapParser BuildResults-bitwiseOpParser -    =   bitwiseOrParser-    <|> bitwiseAndParser-    <|> bitwiseXorParser--bitwiseOrParser :: CapParser BuildResults-bitwiseOrParser = do-    _ <- char '|'-    incOffset 1-    return $ BuildResults 0 [ BitwiseOr ] [ ]--bitwiseAndParser :: CapParser BuildResults-bitwiseAndParser = do-    _ <- char '&'-    incOffset 1-    return $ BuildResults 0 [ BitwiseAnd ] [ ]--bitwiseXorParser :: CapParser BuildResults-bitwiseXorParser = do-    _ <- char '^'-    incOffset 1-    return $ BuildResults 0 [ BitwiseXOr ] [ ]--arithOpParser :: CapParser BuildResults-arithOpParser -    =   plusOp -    <|> minusOp -    where-        plusOp = do-            _ <- char '+'-            incOffset 1-            return $ BuildResults 0 [ ArithPlus ] [ ]-        minusOp = do-            _ <- char '-'-            incOffset 1-            return $ BuildResults 0 [ ArithMinus ] [ ]--literalIntOpParser :: CapParser BuildResults-literalIntOpParser = do-    _ <- char '{'-    incOffset 1-    nStr <- many1 digit-    incOffset $ toEnum $ length nStr-    let n :: Word = read nStr-    _ <- char '}'-    incOffset 1-    return $ BuildResults 0 [ PushValue n ] [ ]--compareOpParser :: CapParser BuildResults-compareOpParser -    =   compareEqOp-    <|> compareLtOp -    <|> compareGtOp -    where-        compareEqOp = do-            _ <- char '='-            incOffset 1-            return $ BuildResults 0 [ CompareEq ] [ ]-        compareLtOp = do-            _ <- char '<'-            incOffset 1-            return $ BuildResults 0 [ CompareLt ] [ ]-        compareGtOp = do-            _ <- char '>'-            incOffset 1-            return $ BuildResults 0 [ CompareGt ] [ ]--bytesOpParser :: CapParser BuildResults-bytesOpParser = do-    bytes <- many1 $ satisfy (/= '%')-    startOffset <- getState >>= return . nextOffset-    let !c = length bytes-    !s <- getState-    let s' = s { nextOffset = startOffset + c }-    setState s'-    return $ BuildResults 0 [Bytes startOffset c] []--charConstParser :: CapParser BuildResults-charConstParser = do-    _ <- char '\''-    charValue <- liftM (toEnum . fromEnum) anyChar -    _ <- char '\''-    incOffset 3-    return $ BuildResults 0 [ PushValue charValue ] [ ]--data BuildState = BuildState -    { nextOffset :: Int-    } --incOffset :: Int -> CapParser ()-incOffset n = do-    s <- getState-    let s' = s { nextOffset = nextOffset s + n }-    setState s'--initialBuildState :: BuildState-initialBuildState = BuildState 0--data BuildResults = BuildResults-    { outParamCount :: !Int-    , outCapOps :: !CapOps-    , outParamOps :: !ParamOps-    }--instance Monoid BuildResults where-    mempty = BuildResults 0 [] []-    v0 `mappend` v1 -        = BuildResults-        { outParamCount = (outParamCount v0) `max` (outParamCount v1)-        , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)-        , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)-        }-
src/Graphics/Text/Width.hs view
@@ -1,34 +1,64 @@ -- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE #-} {-# LANGUAGE ForeignFunctionInterface #-}-module Graphics.Text.Width ( wcwidth-                           , wcswidth-                           , safeWcwidth-                           , safeWcswidth-                           )-    where+-- | This module provides functions to measure the terminal column width+-- of characters and strings.+--+-- The functions provided in this module all ultimately make calls to+-- the C implementation in @cbits/mk_wcwidth.c@. That code manages some+-- global state that carries a table of Unicode character widths. For+-- more details, see 'Graphics.Vty.UnicodeWidthTable.Install', the C+-- code, and the "Multi-Column Character Support" section of the project+-- @README@.+module Graphics.Text.Width+  ( wcwidth+  , wcswidth+  , wctwidth+  , wctlwidth+  , safeWcwidth+  , safeWcswidth+  , safeWctwidth+  , safeWctlwidth+  )+where +import Data.List (foldl')+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+ foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int  wcswidth :: String -> Int-wcswidth = sum . map wcwidth+wcswidth = foldl' (\l c -> wcwidth c + l) 0+{-# INLINE [1] wcswidth #-} --- XXX: Characters with unknown widths occupy 1 column?--- --- Not sure if this is actually correct.  I presume there is a replacement character that is output--- by the terminal instead of the character and this replacement character is 1 column wide. If this--- is not true for all terminals then a per-terminal replacement character width needs to be--- implemented.+wctwidth :: T.Text -> Int+wctwidth = T.foldl' (\l c -> wcwidth c + l) 0 --- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width+wctlwidth :: TL.Text -> Int+wctlwidth = TL.foldl' (\l c -> wcwidth c + l) 0++{-# RULES+"wcswidth/unpack" forall x. wcswidth (T.unpack x) = wctwidth x+"wcswidth/lazy-unpack" forall x. wcswidth (TL.unpack x) = wctlwidth x+  #-}++-- | Returns the display width of a character. Assumes all characters+-- with unknown widths are 0 width. safeWcwidth :: Char -> Int-safeWcwidth c = case wcwidth c of-    i   | i < 0 -> 0-        | otherwise -> i+safeWcwidth = max 0 . wcwidth --- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width+-- | Returns the display width of a string. Assumes all characters with+-- unknown widths are 0 width. safeWcswidth :: String -> Int-safeWcswidth str = case wcswidth str of-    i   | i < 0 -> 0-        | otherwise -> i+safeWcswidth = foldl' (\l c -> safeWcwidth c + l) 0 +-- | Returns the display width of a text. Assumes all characters with+-- unknown widths are 0 width.+safeWctwidth :: T.Text -> Int+safeWctwidth = T.foldl' (\l c -> safeWcwidth c + l) 0++-- | Returns the display width of a lazy text. Assumes all characters+-- with unknown widths are 0 width.+safeWctlwidth :: TL.Text -> Int+safeWctlwidth = TL.foldl' (\l c -> safeWcwidth c + l) 0
src/Graphics/Vty.hs view
@@ -1,182 +1,249 @@--- | Vty supports input and output to terminal devices.------  - Input to the terminal is provided to the app as a sequence of 'Event's.------  - The output is defined by a 'Picture'. Which is one or more layers of 'Image's.------      - The module "Graphics.Vty.Image" provides a number of constructor equations that will build---      correct 'Image' values. See 'string', '<|>', and '<->' for starters.------      - The constructors in "Graphics.Vty.Image.Internal" should not be used.------  - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".--- --- See the vty-examples package for a number of examples.------ @---  import "Graphics.Vty"------  main = do---      cfg <- 'standardIOConfig'---      vty <- 'mkVty' cfg---      let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\"---          line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\"---          img = line0 '<->' line1---          pic = 'picForImage' img---      'update' vty pic---      e <- 'nextEvent' vty---      'shutdown' vty---      'print' (\"Last event was: \" '++' 'show' e)--- @--- --- Good sources of documentation for terminal programming are:+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Vty provides interfaces for both terminal input and terminal+-- output. -----  - <https://github.com/b4winckler/vim/blob/master/src/term.c>+-- - User input to the terminal is provided to the Vty application as a+--   sequence of 'Event's. -----  - <http://invisible-island.net/xterm/ctlseqs/ctlseqs.html>+-- - Output is provided to by the application to Vty in the form of a+--   'Picture'. A 'Picture' is one or more layers of 'Image's.+--   'Image' values can be built by the various constructors in+--   "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)+--   values in the "Graphics.Vty.Attributes" module. -----  - <http://ulisse.elettra.trieste.it/services/doc/serial/config.html>+-- - Each platform on which Vty is supported provides a package that+--   provides Vty with access to the platform-specific terminal+--   interface. For example, on Unix systems, the @vty-unix@ package+--   must be used to initialize Vty with access to a Unix terminal. -----  - <http://www.leonerd.org.uk/hacks/hints/xterm-8bit.html>+-- As a small example, the following program demonstrates the use of Vty+-- on a Unix system using the @vty-unix@ package: -----  - <http://www.unixwiz.net/techtips/termios-vmin-vtime.html>+-- > import Graphics.Vty+-- > import Graphics.Vty.Platform.Unix (mkVty)+-- >+-- > main = do+-- >     vty <- mkVty defaultConfig+-- >     let line0 = string (defAttr `withForeColor` green) "first line"+-- >         line1 = string (defAttr `withBackColor` blue) "second line"+-- >         img = line0 <-> line1+-- >         pic = picForImage img+-- >     update vty pic+-- >     e <- nextEvent vty+-- >     shutdown vty+-- >     print ("Last event was: " ++ show e) -----  - <http://vt100.net/docs/vt100-ug/chapter3.html vt100 control sequences>-module Graphics.Vty ( Vty(..)-                    , mkVty-                    , module Graphics.Vty.Config-                    , module Graphics.Vty.Input-                    , module Graphics.Vty.Output-                    , module Graphics.Vty.Picture-                    , DisplayRegion-                    ) -    where--import Graphics.Vty.Prelude+-- Vty uses threads internally, so programs made with Vty must be+-- compiled with the threaded runtime using the GHC @-threaded@ option.+module Graphics.Vty+  ( Vty(..)+  , setWindowTitle+  , installCustomWidthTable+  , mkVtyFromPair+  , module Graphics.Vty.Config+  , module Graphics.Vty.Input+  , module Graphics.Vty.Input.Events+  , module Graphics.Vty.Output+  , module Graphics.Vty.Picture+  , module Graphics.Vty.Image+  , module Graphics.Vty.Attributes+  )+where  import Graphics.Vty.Config import Graphics.Vty.Input+import Graphics.Vty.Input.Events import Graphics.Vty.Output import Graphics.Vty.Picture+import Graphics.Vty.Image+import Graphics.Vty.Attributes+import Graphics.Vty.UnicodeWidthTable.IO+import Graphics.Vty.UnicodeWidthTable.Install +import qualified Control.Exception as E+import Control.Monad (when) import Control.Concurrent.STM  import Data.IORef-import Data.Monoid+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif --- | The main object.  At most one should be created.------ The use of Vty typically follows this process:+-- | A 'Vty' value represents a handle to the Vty library that the+-- application must create in order to use Vty. -----    0. initialize vty+-- The use of this library typically follows this process: -----    1. use the update equation of Vty to display a picture+-- 1. Initialize Vty with the 'mkVty' implementation for your+-- platform's Vty package (e.g. @vty-unix@), or, more generically, with+-- 'mkVtyFromPair'. This takes control of (and sets up) the terminal. -----    2. repeat+-- 2. Use 'update' to display a picture. -----    3. shutdown vty.+-- 3. Use 'nextEvent' to get the next input event. ----- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe".+-- 4. Depending on the event, go to 2 or 5. ----- This does not assure any thread safety. In theory, as long as an update action is not executed--- when another update action is already then it's safe to call this on multiple threads.+-- 5. Shutdown Vty and restore the terminal state with 'shutdown'. At+-- this point the 'Vty' handle cannot be used again. ----- \todo Remove explicit `shutdown` requirement.-data Vty = Vty -    { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context-      -- implicitly managed by Vty. The managed display context is reset on resize.-      update :: Picture -> IO ()-      -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event-      -- is a 'EvResize'.-    , nextEvent :: IO Event-      -- | The input interface. See 'Input'-    , inputIface :: Input-      -- | The output interface. See 'Output'-    , outputIface :: Output-      -- | Refresh the display. 'nextEvent' will refresh the display if a resize occurs.-      -- If other programs output to the terminal and mess up the display then the application might-      -- want to force a refresh.-    , refresh :: IO ()-      -- | Clean up after vty.-      -- The above methods will throw an exception if executed after this is executed.-    , shutdown :: IO () -    }+-- Operations on Vty handles are not thread-safe.+data Vty =+    Vty { update :: Picture -> IO ()+        -- ^ Output the given 'Picture' to the terminal.+        , nextEvent :: IO Event+        -- ^ Return the next 'Event' or block until one becomes+        -- available.+        , nextEventNonblocking :: IO (Maybe Event)+        -- ^ Non-blocking version of 'nextEvent'.+        , inputIface :: Input+        -- ^ The input interface. See 'Input'.+        , outputIface :: Output+        -- ^ The output interface. See 'Output'.+        , refresh :: IO ()+        -- ^ Refresh the display. If other programs output to the+        -- terminal and mess up the display then the application might+        -- want to force a refresh using this function.+        , shutdown :: IO ()+        -- ^ Clean up after vty. A call to this function is necessary to+        -- cleanly restore the terminal state before application exit.+        -- The above methods will throw an exception if executed after+        -- this is executed. Idempotent.+        , isShutdown :: IO Bool+        } --- | Set up the state object for using vty.  At most one state object should be--- created at a time for a given terminal device.------ The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence.--- See "Graphics.Vty.Config"+-- | Attempt to load and install a custom character width table into+-- this process. ----- For most applications @mkVty def@ is sufficient.-mkVty :: Config -> IO Vty-mkVty appConfig = do-    config <- (<> appConfig) <$> userConfig-    input  <- inputForConfig config-    out    <- outputForConfig config-    intMkVty input out+-- This looks up the specified terminal name in the specified width+-- table map and, if a map file path is found, the map is loaded and+-- installed. This is exposed for Vty platform package implementors;+-- application developers should never need to call this.+installCustomWidthTable :: Maybe FilePath+                        -- ^ Optional path to a log file where log+                        -- messages should be written when attempting to+                        -- load a width table.+                        -> Maybe String+                        -- ^ Optional width table entry name (usually+                        -- the terminal name, e.g. value of @TERM@ on+                        -- Unix systems). If omitted, this function does+                        -- not attempt to load a table.+                        -> [(String, FilePath)]+                        -- ^ Mapping from width table entry names to+                        -- width table file paths. This is usually+                        -- obtained from 'configTermWidthMaps' of+                        -- 'VtyUserConfig'.+                        -> IO ()+installCustomWidthTable logPath tblName widthMaps = do+    let doLog s = case logPath of+                      Nothing -> return ()+                      Just path -> appendFile path $ "installWidthTable: " <> s <> "\n" -intMkVty :: Input -> Output -> IO Vty-intMkVty input out = do+    customInstalled <- isCustomTableReady+    when (not customInstalled) $ do+        case tblName of+            Nothing ->+                doLog "No terminal name given in the configuration, skipping load"+            Just name ->+                case lookup name widthMaps of+                    Nothing ->+                        doLog $ "Width table " <> show name <> " not found in custom character width mapping list"+                    Just path -> do+                        tableResult <- E.try $ readUnicodeWidthTable path+                        case tableResult of+                            Left (e::E.SomeException) ->+                                doLog $ "Error reading custom character width table " <>+                                        "at " <> show path <> ": " <> show e+                            Right (Left msg) ->+                                doLog $ "Error reading custom character width table " <>+                                        "at " <> show path <> ": " <> msg+                            Right (Right table) -> do+                                installResult <- E.try $ installUnicodeWidthTable table+                                case installResult of+                                    Left (e::E.SomeException) ->+                                        doLog $ "Error installing unicode table (" <>+                                                show path <> ": " <> show e+                                    Right () ->+                                        doLog $ "Successfully installed Unicode width table " <>+                                                " from " <> show path++-- | Build a 'Vty' handle from an input/output pair.+--+-- This is exposed for Vty platform package implementors; application+-- developers should never need to call this, and should instead call+-- @mkVty@ or equivalent from their platform package of choice.+mkVtyFromPair :: Input -> Output -> IO Vty+mkVtyFromPair input out = do     reserveDisplay out++    shutdownVar <- newTVarIO False     let shutdownIo = do-            shutdownInput input-            releaseDisplay out-            releaseTerminal out+            alreadyShutdown <- atomically $ swapTVar shutdownVar True+            when (not alreadyShutdown) $ do+                shutdownInput input+                releaseDisplay out+                releaseTerminal out++        shutdownStatus = readTVarIO shutdownVar+     lastPicRef <- newIORef Nothing     lastUpdateRef <- newIORef Nothing      let innerUpdate inPic = do-            b@(w,h) <- displayBounds out-            let cursor  = picCursor inPic-                inPic' = case cursor of-                  Cursor x y ->-                    let-                       x'      = case x of-                                   _ | x < 0     -> 0-                                     | x >= w    -> w - 1-                                     | otherwise -> x-                       y'      = case y of-                                   _ | y < 0     -> 0-                                     | y >= h    -> h - 1-                                     | otherwise -> y-                     in inPic { picCursor = Cursor x' y' }-                  _ -> inPic+            b <- displayBounds out             mlastUpdate <- readIORef lastUpdateRef             updateData <- case mlastUpdate of                 Nothing -> do                     dc <- displayContext out b-                    outputPicture dc inPic'+                    outputPicture dc inPic                     return (b, dc)                 Just (lastBounds, lastContext) -> do                     if b /= lastBounds                         then do                             dc <- displayContext out b-                            outputPicture dc inPic'+                            outputPicture dc inPic                             return (b, dc)                         else do-                            outputPicture lastContext inPic'+                            outputPicture lastContext inPic                             return (b, lastContext)             writeIORef lastUpdateRef $ Just updateData-            writeIORef lastPicRef $ Just inPic'+            writeIORef lastPicRef $ Just inPic -    let innerRefresh -            =   writeIORef lastUpdateRef Nothing-            >>  readIORef lastPicRef -            >>= maybe ( return () ) ( \pic -> innerUpdate pic ) +        innerRefresh = do+            writeIORef lastUpdateRef Nothing+            bounds <- displayBounds out+            dc <- displayContext out bounds+            writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState+            mPic <- readIORef lastPicRef+            maybe (return ()) innerUpdate mPic -    let gkey = do k <- atomically $ readTChan $ _eventChannel input-                  case k of -                    (EvResize _ _)  -> innerRefresh-                                       >> displayBounds out-                                       >>= return . (\(w,h)-> EvResize w h)-                    _               -> return k+        mkResize = uncurry EvResize <$> displayBounds out +        translateInternalEvent ResumeAfterInterrupt = mkResize+        translateInternalEvent (InputEvent e) = return e++        gkey = do+            e <- atomically $ readTChan $ eventChannel input+            translateInternalEvent e+        gkey' = do+            mEv <- atomically $ tryReadTChan $ eventChannel input+            case mEv of+                Just e  -> Just <$> translateInternalEvent e+                Nothing -> return Nothing+     return $ Vty { update = innerUpdate                  , nextEvent = gkey+                 , nextEventNonblocking = gkey'                  , inputIface = input                  , outputIface = out                  , refresh = innerRefresh                  , shutdown = shutdownIo+                 , isShutdown = shutdownStatus                  } +-- | Set the terminal window title string.+setWindowTitle :: Vty -> String -> IO ()+setWindowTitle vty title =+    setOutputWindowTitle (outputIface vty) title
src/Graphics/Vty/Attributes.hs view
@@ -1,68 +1,89 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}  -- | Display attributes ----- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes:+-- Attributes have three components: a foreground color, a background+-- color, and a style mask. The simplest attribute is the default+-- attribute, or 'defAttr'. Attributes can be modified with+-- 'withForeColor', 'withBackColor', and 'withStyle', e.g., -- -- @---     defAttr `withForeColor` red+--     defAttr \`withForeColor\` red -- @ ----- Is the attribute that will set the foreground color to red and the background color to the--- default.------ This can then be used to build an image wiht a red foreground like so:+-- 'Image' constructors often require an 'Attr' to indicate the+-- attributes used in the image, e.g., -- -- @---      string (defAttr `withForeColor` red) "this text will be red"+--     string (defAttr \`withForeColor\` red) "this text will be red" -- @ ----- The default attributes set by 'defAttr' have a presentation determined by the terminal.  This is--- not something VTY can control. The user is free to define the color scheme of the terminal as--- they see fit. Up to the limits of the terminal anyways.------ The value 'currentAttr' will keep the attributes of whatever was output previously.+-- The appearance of 'Image's using 'defAttr' is determined by the The+-- terminal, so this is not something VTY can control. The user is free+-- to The define the color scheme of the terminal as they see fit. ----- \todo This API is very verbose IMO. I'd like something more succinct.-module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes-                               , module Graphics.Vty.Attributes.Color-                               , module Graphics.Vty.Attributes.Color240-                               )-    where+-- The value 'currentAttr' will keep the attributes of whatever was+-- output previously.+module Graphics.Vty.Attributes+  ( module Graphics.Vty.Attributes.Color +  , Attr(..)+  , FixedAttr(..)+  , MaybeDefault(..)+  , defAttr+  , currentAttr++  -- * Styles+  , Style+  , withStyle+  , standout+  , italic+  , strikethrough+  , underline+  , reverseVideo+  , blink+  , dim+  , bold+  , defaultStyleMask+  , styleMask+  , hasStyle++  -- * Setting attribute colors+  , withForeColor+  , withBackColor++  -- * Setting hyperlinks+  , withURL+  )+where++import Control.DeepSeq import Data.Bits-import Data.Default+import Data.Text (Text) import Data.Word+import GHC.Generics  import Graphics.Vty.Attributes.Color-import Graphics.Vty.Attributes.Color240 -#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif---- | A display attribute defines the Color and Style of all the characters rendered after the--- attribute is applied.+-- | A display attribute defines the Color and Style of all the+-- characters rendered after the attribute is applied. -----  At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and---  foreground. The 240 colors and 16 colors are points in different palettes. See Color for more---  information.+-- At most 256 colors, picked from a 240 and 16 color palette, are+-- possible for the background and foreground. The 240 colors and+-- 16 colors are points in different palettes. See Color for more+-- information. data Attr = Attr     { attrStyle :: !(MaybeDefault Style)     , attrForeColor :: !(MaybeDefault Color)     , attrBackColor :: !(MaybeDefault Color)-    } deriving ( Eq, Show, Read )+    , attrURL :: !(MaybeDefault Text)+    } deriving ( Eq, Show, Read, Generic, NFData ) --- This could be encoded into a single 32 bit word. The 32 bit word is first divided--- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to--- the other groups.+-- This could be encoded into a single 32 bit word. The 32 bit word is+-- first divided into 4 groups of 8 bits where: The first group codes+-- what action should be taken with regards to the other groups. --      XXYYZZ__ --      XX - style action --          00 => reset to default@@ -79,85 +100,47 @@ --      __ - unused -- --  Next is the style flags---      SURBDO__+--      SURBDOI_ --      S - standout --      U - underline --      R - reverse video --      B - blink --      D - dim --      O - bold---      __ - unused+--      I - italic+--      _ - unused -- --  Then the foreground color encoded into 8 bits. --  Then the background color encoded into 8 bits. -instance Monoid Attr where-    mempty = Attr mempty mempty mempty-    mappend attr0 attr1 = -        Attr ( attrStyle attr0     `mappend` attrStyle attr1 )-             ( attrForeColor attr0 `mappend` attrForeColor attr1 )-             ( attrBackColor attr0 `mappend` attrBackColor attr1 )---- | Specifies the display attributes such that the final style and color values do not depend on--- the previously applied display attribute. The display attributes can still depend on the--- terminal's default colors (unfortunately).+-- | Specifies the display attributes such that the final style and+-- color values do not depend on the previously applied display+-- attribute. The display attributes can still depend on the terminal's+-- default colors (unfortunately). data FixedAttr = FixedAttr     { fixedStyle :: !Style     , fixedForeColor :: !(Maybe Color)     , fixedBackColor :: !(Maybe Color)+    , fixedURL       :: !(Maybe Text)     } deriving ( Eq, Show ) --- | The style and color attributes can either be the terminal defaults. Or be equivalent to the--- previously applied style. Or be a specific value.-data MaybeDefault v where-    Default :: MaybeDefault v-    KeepCurrent :: MaybeDefault v-    SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v--deriving instance Eq v => Eq (MaybeDefault v)-deriving instance Eq v => Show (MaybeDefault v)-deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)--instance Eq v => Monoid ( MaybeDefault v ) where-    mempty = KeepCurrent-    mappend Default Default = Default-    mappend Default KeepCurrent = Default-    mappend Default ( SetTo v ) = SetTo v-    mappend KeepCurrent Default = Default-    mappend KeepCurrent KeepCurrent = KeepCurrent-    mappend KeepCurrent ( SetTo v ) = SetTo v-    mappend ( SetTo _v ) Default = Default-    mappend ( SetTo v ) KeepCurrent = SetTo v-    mappend ( SetTo _ ) ( SetTo v ) = SetTo v---- | Standard 8-color ANSI terminal color codes.-black, red, green, yellow, blue, magenta, cyan, white :: Color-black  = ISOColor 0-red    = ISOColor 1-green  = ISOColor 2-yellow = ISOColor 3-blue   = ISOColor 4-magenta= ISOColor 5-cyan   = ISOColor 6-white  = ISOColor 7+-- | The style and color attributes can either be the terminal defaults.+-- Or be equivalent to the previously applied style. Or be a specific+-- value.+data MaybeDefault v = Default | KeepCurrent | SetTo !v+  deriving (Eq, Read, Show) --- | Bright/Vivid variants of the standard 8-color ANSI -brightBlack, brightRed, brightGreen, brightYellow :: Color-brightBlue, brightMagenta, brightCyan, brightWhite :: Color-brightBlack  = ISOColor 8-brightRed    = ISOColor 9-brightGreen  = ISOColor 10-brightYellow = ISOColor 11-brightBlue   = ISOColor 12-brightMagenta= ISOColor 13-brightCyan   = ISOColor 14-brightWhite  = ISOColor 15+instance (NFData v) => NFData (MaybeDefault v) where+    rnf Default = ()+    rnf KeepCurrent = ()+    rnf (SetTo v) = rnf v --- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute--- assigned to that bit should be applied and 0 if the style attribute should not be applied.+-- | Styles are represented as an 8 bit word. Each bit in the word is 1+-- if the style attribute assigned to that bit should be applied and 0+-- if the style attribute should not be applied. type Style = Word8 --- | The 6 possible style attributes:+-- | Valid style attributes include: -- --      * standout --@@ -171,21 +154,27 @@ -- --      * bold/bright -----  ( The invisible, protect, and altcharset display attributes some terminals support are not---  supported via VTY.)-standout, underline, reverseVideo, blink, dim, bold :: Style+--      * italic+--+--      * strikethrough (via the smxx/rmxx terminfo capabilities)+--+--  (The invisible, protect, and altcharset display attributes some+--  terminals support are not supported via VTY.)+standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style standout        = 0x01 underline       = 0x02-reverseVideo   = 0x04+reverseVideo    = 0x04 blink           = 0x08 dim             = 0x10 bold            = 0x20+italic          = 0x40+strikethrough   = 0x80  defaultStyleMask :: Style defaultStyleMask = 0x00  styleMask :: Attr -> Word8-styleMask attr +styleMask attr     = case attrStyle attr of         Default  -> 0         KeepCurrent -> 0@@ -205,23 +194,35 @@  -- | Add the given style attribute withStyle :: Attr -> Style -> Attr+withStyle attr 0 = attr withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } --- | Sets the style, background color and foreground color to the default values for the terminal.--- There is no easy way to determine what the default background and foreground colors are.-defAttr :: Attr-defAttr = Attr Default Default Default+-- | Add a hyperlinked URL using the proposed [escape sequences for+-- hyperlinked+-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).+-- These escape sequences are comparatively new and aren't widely+-- supported in terminal emulators yet, but most terminal emulators+-- that don't know about these sequences will ignore these sequences,+-- and therefore this should fall back sensibly. In some cases they+-- won't and this will result in garbage, so this is why hyperlinking is+-- disabled by default, in which case this combinator has no observable+-- effect. To enable it, enable 'Hyperlink' mode on your Vty output+-- interface.+withURL :: Attr -> Text -> Attr+withURL attr url = attr { attrURL = SetTo url } -instance Default Attr where-    def = defAttr+-- | Sets the style, background color and foreground color to the+-- default values for the terminal. There is no easy way to determine+-- what the default background and foreground colors are.+defAttr :: Attr+defAttr = Attr Default Default Default Default --- | Keeps the style, background color and foreground color that was previously set. Used to--- override some part of the previous style.+-- | Keeps the style, background color and foreground color that was+-- previously set. Used to override some part of the previous style. -- -- EG: current_style `withForeColor` brightMagenta ----- Would be the currently applied style (be it underline, bold, etc) but with the foreground color--- set to brightMagenta.+-- Would be the currently applied style (be it underline, bold, etc) but+-- with the foreground color set to brightMagenta. currentAttr :: Attr-currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent-+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent KeepCurrent
src/Graphics/Vty/Attributes/Color.hs view
@@ -1,51 +1,173 @@-module Graphics.Vty.Attributes.Color where+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Graphics.Vty.Attributes.Color+  ( Color(..)+  , ColorMode(..)++  -- ** Fixed Colors+  -- | Standard 8-color ANSI terminal color codes.+  --+  -- Note that these map to colors in the terminal's custom palette. For+  -- instance, `white` maps to whatever the terminal color theme uses for+  -- white.+  --+  -- Use these functions if you want to make apps that fit the terminal theme.+  -- If you want access to more/stronger colors use `rgbColor`+  , black+  , red+  , green+  , yellow+  , blue+  , magenta+  , cyan+  , white++  -- | Bright/Vivid variants of the standard 8-color ANSI+  , brightBlack+  , brightRed+  , brightGreen+  , brightYellow+  , brightBlue+  , brightMagenta+  , brightCyan+  , brightWhite+  -- ** Creating Colors From RGB+  , linearColor+  , srgbColor+  , rgbColor+  , color240+  , module Graphics.Vty.Attributes.Color240+  )+where+ import Data.Word+import GHC.Generics+import Control.DeepSeq +import Graphics.Vty.Attributes.Color240+ -- | Abstract data type representing a color.---  --- Currently the foreground and background color are specified as points in either a: -----  * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8---  color palette and the second 8 colors are bright/vivid versions of the first 8 colors.+-- Currently the foreground and background color are specified as points+-- in either a: -----  * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first---  224 colors. The remaining 16 colors is a greyscale palette.--- +--  * 16 color palette. Where the first 8 colors are equal to the 8+--  colors of the ISO 6429 (ANSI) 8 color palette and the second 8+--  colors are bright/vivid versions of the first 8 colors.+--+--  * 240 color palette. This palette is a regular sampling of the full+--  RGB colorspace for the first 224 colors. The remaining 16 colors is+--  a greyscale palette.+-- -- The 8 ISO 6429 (ANSI) colors are as follows: -----      0. black+--      * black (0) -----      1. red+--      * red (1) -----      2. green+--      * green (2) -----      3. yellow+--      * yellow (3) -----      4. blue+--      * blue (4) -----      5. magenta+--      * magenta (5) -----      6. cyan+--      * cyan (6) -----      7. white+--      * white (7) ----- The mapping from points in the 240 color palette to colors actually displayable by the terminal--- depends on the number of colors the terminal claims to support. Which is usually determined by--- the terminfo "colors" property. If this property is not being accurately reported then the color--- reproduction will be incorrect.+-- The mapping from points in the 240 color palette to colors actually+-- displayable by the terminal depends on the number of colors the+-- terminal claims to support. Which is usually determined by the+-- terminfo "colors" property. If this property is not being accurately+-- reported then the color reproduction will be incorrect. ----- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8--- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not--- addressable via the 240 color palette. +-- If the terminal reports <= 16 colors then the 240 color palette+-- points are only mapped to the 8 color palette. I'm not sure of+-- the RGB points for the "bright" colors which is why they are not+-- addressable via the 240 color palette. ----- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest--- points in a ("color count" - 16) subsampling of the 240 color palette.+-- If the terminal reports > 16 colors then the 240 color palette+-- points are mapped to the nearest points in a ("color count" - 16)+-- subsampling of the 240 color palette. ----- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors.--- And that the individual colors have not been remapped by the user. There may be a way to verify--- this through terminfo but I don't know it.+-- All of this assumes the terminals are behaving similarly to xterm and+-- rxvt when handling colors. And that the individual colors have not+-- been remapped by the user. There may be a way to verify this through+-- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE.-data Color = ISOColor !Word8 | Color240 !Word8+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8+    deriving ( Eq, Show, Read, Generic, NFData )++data ColorMode+    = NoColor+    | ColorMode8+    | ColorMode16+    | ColorMode240 !Word8+    | FullColor     deriving ( Eq, Show, Read ) +black, red, green, yellow, blue, magenta, cyan, white :: Color+black  = ISOColor 0+red    = ISOColor 1+green  = ISOColor 2+yellow = ISOColor 3+blue   = ISOColor 4+magenta= ISOColor 5+cyan   = ISOColor 6+white  = ISOColor 7++brightBlack, brightRed, brightGreen, brightYellow :: Color+brightBlue, brightMagenta, brightCyan, brightWhite :: Color+brightBlack  = ISOColor 8+brightRed    = ISOColor 9+brightGreen  = ISOColor 10+brightYellow = ISOColor 11+brightBlue   = ISOColor 12+brightMagenta= ISOColor 13+brightCyan   = ISOColor 14+brightWhite  = ISOColor 15++-- | Create a color value from RGB values in the 0..255 range inclusive.+-- No transformation of the input values is done; a color is created+-- directly from the RGB values specified, unlike the 'srgbColor' and+-- 'color240' functions.+linearColor :: Integral i => i -> i -> i -> Color+linearColor r g b = RGBColor r' g' b'+    where+        r' = fromIntegral (clamp r) :: Word8+        g' = fromIntegral (clamp g) :: Word8+        b' = fromIntegral (clamp b) :: Word8+        clamp = min 255 . max 0++-- | Given RGB values in the range 0..255 inclusive, create a color+-- using the sRGB transformation described at+--+-- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation+srgbColor :: Integral i => i -> i -> i -> Color+srgbColor r g b =+    -- TODO: it may be worth translating this to a lookup table, as with color240+    let shrink n = fromIntegral n / 255 :: Double+        -- called gamma^-1 in wiki+        gamma u+            | u <= 0.04045 = u/12.92+            | otherwise    = ((u + 0.055) / 1.055) ** 2.4+        -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?+        expand n = round (255 * n)+        convert = expand . gamma . shrink+     in RGBColor (convert r) (convert g) (convert b)++color240 :: Integral i => i -> i -> i -> Color+color240 r g b = Color240 (rgbColorToColor240 r g b)++-- | Create a Vty 'Color' (in the 240 color set) from an RGB triple.+-- This is a synonym for 'color240'. This function is lossy in the sense+-- that we only internally support 240 colors but the #RRGGBB format+-- supports 256^3 colors.+rgbColor :: Integral i => i -> i -> i -> Color+rgbColor = color240
src/Graphics/Vty/Attributes/Color240.hs view
@@ -1,261 +1,301 @@-{-- - This header file was generated by ./256colres.pl- -}-module Graphics.Vty.Attributes.Color240 where--import Graphics.Vty.Attributes.Color+-- This header file was generated by ./256colres.pl+module Graphics.Vty.Attributes.Color240+  ( rgbColorToColor240+  , color240CodeToRGB+  )+where +import Data.Word (Word8) import Text.Printf --- | RGB color to 240 color palette.+-- Note: rgbColor's mapping from RGB to 240 colors was generated from+-- 256colres.pl which is forked from xterm 256colres.pl.++-- | Create a value in the Color240 set from an RGB triple. This maps+-- the input arguments to an entry in the 240-color palette depicted at: ----- generated from 256colres.pl which is forked from xterm 256colres.pl--- todo: all values get clamped high.-rgbColor :: Integral i => i -> i -> i -> Color-rgbColor r g b+-- https://rich.readthedocs.io/en/stable/appendix/colors.html+rgbColorToColor240 :: Integral i => i -> i -> i -> Word8+rgbColorToColor240 r g b     | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"-    | r == 8 && g == 8 && b == 8 = Color240 216-    | r == 18 && g == 18 && b == 18 = Color240 217-    | r == 28 && g == 28 && b == 28 = Color240 218-    | r == 38 && g == 38 && b == 38 = Color240 219-    | r == 48 && g == 48 && b == 48 = Color240 220-    | r == 58 && g == 58 && b == 58 = Color240 221-    | r == 68 && g == 68 && b == 68 = Color240 222-    | r == 78 && g == 78 && b == 78 = Color240 223-    | r == 88 && g == 88 && b == 88 = Color240 224-    | r == 98 && g == 98 && b == 98 = Color240 225-    | r == 108 && g == 108 && b == 108 = Color240 226-    | r == 118 && g == 118 && b == 118 = Color240 227-    | r == 128 && g == 128 && b == 128 = Color240 228-    | r == 138 && g == 138 && b == 138 = Color240 229-    | r == 148 && g == 148 && b == 148 = Color240 230-    | r == 158 && g == 158 && b == 158 = Color240 231-    | r == 168 && g == 168 && b == 168 = Color240 232-    | r == 178 && g == 178 && b == 178 = Color240 233-    | r == 188 && g == 188 && b == 188 = Color240 234-    | r == 198 && g == 198 && b == 198 = Color240 235-    | r == 208 && g == 208 && b == 208 = Color240 236-    | r == 218 && g == 218 && b == 218 = Color240 237-    | r == 228 && g == 228 && b == 228 = Color240 238-    | r == 238 && g == 238 && b == 238 = Color240 239-    | r <= 0 && g <= 0 && b <= 0 = Color240 0-    | r <= 0 && g <= 0 && b <= 95 = Color240 1-    | r <= 0 && g <= 0 && b <= 135 = Color240 2-    | r <= 0 && g <= 0 && b <= 175 = Color240 3-    | r <= 0 && g <= 0 && b <= 215 = Color240 4-    | r <= 0 && g <= 0 && b <= 255 = Color240 5-    | r <= 0 && g <= 95 && b <= 0 = Color240 6-    | r <= 0 && g <= 95 && b <= 95 = Color240 7-    | r <= 0 && g <= 95 && b <= 135 = Color240 8-    | r <= 0 && g <= 95 && b <= 175 = Color240 9-    | r <= 0 && g <= 95 && b <= 215 = Color240 10-    | r <= 0 && g <= 95 && b <= 255 = Color240 11-    | r <= 0 && g <= 135 && b <= 0 = Color240 12-    | r <= 0 && g <= 135 && b <= 95 = Color240 13-    | r <= 0 && g <= 135 && b <= 135 = Color240 14-    | r <= 0 && g <= 135 && b <= 175 = Color240 15-    | r <= 0 && g <= 135 && b <= 215 = Color240 16-    | r <= 0 && g <= 135 && b <= 255 = Color240 17-    | r <= 0 && g <= 175 && b <= 0 = Color240 18-    | r <= 0 && g <= 175 && b <= 95 = Color240 19-    | r <= 0 && g <= 175 && b <= 135 = Color240 20-    | r <= 0 && g <= 175 && b <= 175 = Color240 21-    | r <= 0 && g <= 175 && b <= 215 = Color240 22-    | r <= 0 && g <= 175 && b <= 255 = Color240 23-    | r <= 0 && g <= 215 && b <= 0 = Color240 24-    | r <= 0 && g <= 215 && b <= 95 = Color240 25-    | r <= 0 && g <= 215 && b <= 135 = Color240 26-    | r <= 0 && g <= 215 && b <= 175 = Color240 27-    | r <= 0 && g <= 215 && b <= 215 = Color240 28-    | r <= 0 && g <= 215 && b <= 255 = Color240 29-    | r <= 0 && g <= 255 && b <= 0 = Color240 30-    | r <= 0 && g <= 255 && b <= 95 = Color240 31-    | r <= 0 && g <= 255 && b <= 135 = Color240 32-    | r <= 0 && g <= 255 && b <= 175 = Color240 33-    | r <= 0 && g <= 255 && b <= 215 = Color240 34-    | r <= 0 && g <= 255 && b <= 255 = Color240 35-    | r <= 95 && g <= 0 && b <= 0 = Color240 36-    | r <= 95 && g <= 0 && b <= 95 = Color240 37-    | r <= 95 && g <= 0 && b <= 135 = Color240 38-    | r <= 95 && g <= 0 && b <= 175 = Color240 39-    | r <= 95 && g <= 0 && b <= 215 = Color240 40-    | r <= 95 && g <= 0 && b <= 255 = Color240 41-    | r <= 95 && g <= 95 && b <= 0 = Color240 42-    | r <= 95 && g <= 95 && b <= 95 = Color240 43-    | r <= 95 && g <= 95 && b <= 135 = Color240 44-    | r <= 95 && g <= 95 && b <= 175 = Color240 45-    | r <= 95 && g <= 95 && b <= 215 = Color240 46-    | r <= 95 && g <= 95 && b <= 255 = Color240 47-    | r <= 95 && g <= 135 && b <= 0 = Color240 48-    | r <= 95 && g <= 135 && b <= 95 = Color240 49-    | r <= 95 && g <= 135 && b <= 135 = Color240 50-    | r <= 95 && g <= 135 && b <= 175 = Color240 51-    | r <= 95 && g <= 135 && b <= 215 = Color240 52-    | r <= 95 && g <= 135 && b <= 255 = Color240 53-    | r <= 95 && g <= 175 && b <= 0 = Color240 54-    | r <= 95 && g <= 175 && b <= 95 = Color240 55-    | r <= 95 && g <= 175 && b <= 135 = Color240 56-    | r <= 95 && g <= 175 && b <= 175 = Color240 57-    | r <= 95 && g <= 175 && b <= 215 = Color240 58-    | r <= 95 && g <= 175 && b <= 255 = Color240 59-    | r <= 95 && g <= 215 && b <= 0 = Color240 60-    | r <= 95 && g <= 215 && b <= 95 = Color240 61-    | r <= 95 && g <= 215 && b <= 135 = Color240 62-    | r <= 95 && g <= 215 && b <= 175 = Color240 63-    | r <= 95 && g <= 215 && b <= 215 = Color240 64-    | r <= 95 && g <= 215 && b <= 255 = Color240 65-    | r <= 95 && g <= 255 && b <= 0 = Color240 66-    | r <= 95 && g <= 255 && b <= 95 = Color240 67-    | r <= 95 && g <= 255 && b <= 135 = Color240 68-    | r <= 95 && g <= 255 && b <= 175 = Color240 69-    | r <= 95 && g <= 255 && b <= 215 = Color240 70-    | r <= 95 && g <= 255 && b <= 255 = Color240 71-    | r <= 135 && g <= 0 && b <= 0 = Color240 72-    | r <= 135 && g <= 0 && b <= 95 = Color240 73-    | r <= 135 && g <= 0 && b <= 135 = Color240 74-    | r <= 135 && g <= 0 && b <= 175 = Color240 75-    | r <= 135 && g <= 0 && b <= 215 = Color240 76-    | r <= 135 && g <= 0 && b <= 255 = Color240 77-    | r <= 135 && g <= 95 && b <= 0 = Color240 78-    | r <= 135 && g <= 95 && b <= 95 = Color240 79-    | r <= 135 && g <= 95 && b <= 135 = Color240 80-    | r <= 135 && g <= 95 && b <= 175 = Color240 81-    | r <= 135 && g <= 95 && b <= 215 = Color240 82-    | r <= 135 && g <= 95 && b <= 255 = Color240 83-    | r <= 135 && g <= 135 && b <= 0 = Color240 84-    | r <= 135 && g <= 135 && b <= 95 = Color240 85-    | r <= 135 && g <= 135 && b <= 135 = Color240 86-    | r <= 135 && g <= 135 && b <= 175 = Color240 87-    | r <= 135 && g <= 135 && b <= 215 = Color240 88-    | r <= 135 && g <= 135 && b <= 255 = Color240 89-    | r <= 135 && g <= 175 && b <= 0 = Color240 90-    | r <= 135 && g <= 175 && b <= 95 = Color240 91-    | r <= 135 && g <= 175 && b <= 135 = Color240 92-    | r <= 135 && g <= 175 && b <= 175 = Color240 93-    | r <= 135 && g <= 175 && b <= 215 = Color240 94-    | r <= 135 && g <= 175 && b <= 255 = Color240 95-    | r <= 135 && g <= 215 && b <= 0 = Color240 96-    | r <= 135 && g <= 215 && b <= 95 = Color240 97-    | r <= 135 && g <= 215 && b <= 135 = Color240 98-    | r <= 135 && g <= 215 && b <= 175 = Color240 99-    | r <= 135 && g <= 215 && b <= 215 = Color240 100-    | r <= 135 && g <= 215 && b <= 255 = Color240 101-    | r <= 135 && g <= 255 && b <= 0 = Color240 102-    | r <= 135 && g <= 255 && b <= 95 = Color240 103-    | r <= 135 && g <= 255 && b <= 135 = Color240 104-    | r <= 135 && g <= 255 && b <= 175 = Color240 105-    | r <= 135 && g <= 255 && b <= 215 = Color240 106-    | r <= 135 && g <= 255 && b <= 255 = Color240 107-    | r <= 175 && g <= 0 && b <= 0 = Color240 108-    | r <= 175 && g <= 0 && b <= 95 = Color240 109-    | r <= 175 && g <= 0 && b <= 135 = Color240 110-    | r <= 175 && g <= 0 && b <= 175 = Color240 111-    | r <= 175 && g <= 0 && b <= 215 = Color240 112-    | r <= 175 && g <= 0 && b <= 255 = Color240 113-    | r <= 175 && g <= 95 && b <= 0 = Color240 114-    | r <= 175 && g <= 95 && b <= 95 = Color240 115-    | r <= 175 && g <= 95 && b <= 135 = Color240 116-    | r <= 175 && g <= 95 && b <= 175 = Color240 117-    | r <= 175 && g <= 95 && b <= 215 = Color240 118-    | r <= 175 && g <= 95 && b <= 255 = Color240 119-    | r <= 175 && g <= 135 && b <= 0 = Color240 120-    | r <= 175 && g <= 135 && b <= 95 = Color240 121-    | r <= 175 && g <= 135 && b <= 135 = Color240 122-    | r <= 175 && g <= 135 && b <= 175 = Color240 123-    | r <= 175 && g <= 135 && b <= 215 = Color240 124-    | r <= 175 && g <= 135 && b <= 255 = Color240 125-    | r <= 175 && g <= 175 && b <= 0 = Color240 126-    | r <= 175 && g <= 175 && b <= 95 = Color240 127-    | r <= 175 && g <= 175 && b <= 135 = Color240 128-    | r <= 175 && g <= 175 && b <= 175 = Color240 129-    | r <= 175 && g <= 175 && b <= 215 = Color240 130-    | r <= 175 && g <= 175 && b <= 255 = Color240 131-    | r <= 175 && g <= 215 && b <= 0 = Color240 132-    | r <= 175 && g <= 215 && b <= 95 = Color240 133-    | r <= 175 && g <= 215 && b <= 135 = Color240 134-    | r <= 175 && g <= 215 && b <= 175 = Color240 135-    | r <= 175 && g <= 215 && b <= 215 = Color240 136-    | r <= 175 && g <= 215 && b <= 255 = Color240 137-    | r <= 175 && g <= 255 && b <= 0 = Color240 138-    | r <= 175 && g <= 255 && b <= 95 = Color240 139-    | r <= 175 && g <= 255 && b <= 135 = Color240 140-    | r <= 175 && g <= 255 && b <= 175 = Color240 141-    | r <= 175 && g <= 255 && b <= 215 = Color240 142-    | r <= 175 && g <= 255 && b <= 255 = Color240 143-    | r <= 215 && g <= 0 && b <= 0 = Color240 144-    | r <= 215 && g <= 0 && b <= 95 = Color240 145-    | r <= 215 && g <= 0 && b <= 135 = Color240 146-    | r <= 215 && g <= 0 && b <= 175 = Color240 147-    | r <= 215 && g <= 0 && b <= 215 = Color240 148-    | r <= 215 && g <= 0 && b <= 255 = Color240 149-    | r <= 215 && g <= 95 && b <= 0 = Color240 150-    | r <= 215 && g <= 95 && b <= 95 = Color240 151-    | r <= 215 && g <= 95 && b <= 135 = Color240 152-    | r <= 215 && g <= 95 && b <= 175 = Color240 153-    | r <= 215 && g <= 95 && b <= 215 = Color240 154-    | r <= 215 && g <= 95 && b <= 255 = Color240 155-    | r <= 215 && g <= 135 && b <= 0 = Color240 156-    | r <= 215 && g <= 135 && b <= 95 = Color240 157-    | r <= 215 && g <= 135 && b <= 135 = Color240 158-    | r <= 215 && g <= 135 && b <= 175 = Color240 159-    | r <= 215 && g <= 135 && b <= 215 = Color240 160-    | r <= 215 && g <= 135 && b <= 255 = Color240 161-    | r <= 215 && g <= 175 && b <= 0 = Color240 162-    | r <= 215 && g <= 175 && b <= 95 = Color240 163-    | r <= 215 && g <= 175 && b <= 135 = Color240 164-    | r <= 215 && g <= 175 && b <= 175 = Color240 165-    | r <= 215 && g <= 175 && b <= 215 = Color240 166-    | r <= 215 && g <= 175 && b <= 255 = Color240 167-    | r <= 215 && g <= 215 && b <= 0 = Color240 168-    | r <= 215 && g <= 215 && b <= 95 = Color240 169-    | r <= 215 && g <= 215 && b <= 135 = Color240 170-    | r <= 215 && g <= 215 && b <= 175 = Color240 171-    | r <= 215 && g <= 215 && b <= 215 = Color240 172-    | r <= 215 && g <= 215 && b <= 255 = Color240 173-    | r <= 215 && g <= 255 && b <= 0 = Color240 174-    | r <= 215 && g <= 255 && b <= 95 = Color240 175-    | r <= 215 && g <= 255 && b <= 135 = Color240 176-    | r <= 215 && g <= 255 && b <= 175 = Color240 177-    | r <= 215 && g <= 255 && b <= 215 = Color240 178-    | r <= 215 && g <= 255 && b <= 255 = Color240 179-    | r <= 255 && g <= 0 && b <= 0 = Color240 180-    | r <= 255 && g <= 0 && b <= 95 = Color240 181-    | r <= 255 && g <= 0 && b <= 135 = Color240 182-    | r <= 255 && g <= 0 && b <= 175 = Color240 183-    | r <= 255 && g <= 0 && b <= 215 = Color240 184-    | r <= 255 && g <= 0 && b <= 255 = Color240 185-    | r <= 255 && g <= 95 && b <= 0 = Color240 186-    | r <= 255 && g <= 95 && b <= 95 = Color240 187-    | r <= 255 && g <= 95 && b <= 135 = Color240 188-    | r <= 255 && g <= 95 && b <= 175 = Color240 189-    | r <= 255 && g <= 95 && b <= 215 = Color240 190-    | r <= 255 && g <= 95 && b <= 255 = Color240 191-    | r <= 255 && g <= 135 && b <= 0 = Color240 192-    | r <= 255 && g <= 135 && b <= 95 = Color240 193-    | r <= 255 && g <= 135 && b <= 135 = Color240 194-    | r <= 255 && g <= 135 && b <= 175 = Color240 195-    | r <= 255 && g <= 135 && b <= 215 = Color240 196-    | r <= 255 && g <= 135 && b <= 255 = Color240 197-    | r <= 255 && g <= 175 && b <= 0 = Color240 198-    | r <= 255 && g <= 175 && b <= 95 = Color240 199-    | r <= 255 && g <= 175 && b <= 135 = Color240 200-    | r <= 255 && g <= 175 && b <= 175 = Color240 201-    | r <= 255 && g <= 175 && b <= 215 = Color240 202-    | r <= 255 && g <= 175 && b <= 255 = Color240 203-    | r <= 255 && g <= 215 && b <= 0 = Color240 204-    | r <= 255 && g <= 215 && b <= 95 = Color240 205-    | r <= 255 && g <= 215 && b <= 135 = Color240 206-    | r <= 255 && g <= 215 && b <= 175 = Color240 207-    | r <= 255 && g <= 215 && b <= 215 = Color240 208-    | r <= 255 && g <= 215 && b <= 255 = Color240 209-    | r <= 255 && g <= 255 && b <= 0 = Color240 210-    | r <= 255 && g <= 255 && b <= 95 = Color240 211-    | r <= 255 && g <= 255 && b <= 135 = Color240 212-    | r <= 255 && g <= 255 && b <= 175 = Color240 213-    | r <= 255 && g <= 255 && b <= 215 = Color240 214-    | r <= 255 && g <= 255 && b <= 255 = Color240 215-    | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." +    | r == 8 && g == 8 && b == 8 = 216+    | r == 18 && g == 18 && b == 18 = 217+    | r == 28 && g == 28 && b == 28 = 218+    | r == 38 && g == 38 && b == 38 = 219+    | r == 48 && g == 48 && b == 48 = 220+    | r == 58 && g == 58 && b == 58 = 221+    | r == 68 && g == 68 && b == 68 = 222+    | r == 78 && g == 78 && b == 78 = 223+    | r == 88 && g == 88 && b == 88 = 224+    | r == 98 && g == 98 && b == 98 = 225+    | r == 108 && g == 108 && b == 108 = 226+    | r == 118 && g == 118 && b == 118 = 227+    | r == 128 && g == 128 && b == 128 = 228+    | r == 138 && g == 138 && b == 138 = 229+    | r == 148 && g == 148 && b == 148 = 230+    | r == 158 && g == 158 && b == 158 = 231+    | r == 168 && g == 168 && b == 168 = 232+    | r == 178 && g == 178 && b == 178 = 233+    | r == 188 && g == 188 && b == 188 = 234+    | r == 198 && g == 198 && b == 198 = 235+    | r == 208 && g == 208 && b == 208 = 236+    | r == 218 && g == 218 && b == 218 = 237+    | r == 228 && g == 228 && b == 228 = 238+    | r == 238 && g == 238 && b == 238 = 239+    | otherwise = 36 * go r + 6 * go g + go b+    where go = simpleColor_ (error (printf "RGB color %d %d %d does not map to 240 palette."                                 (fromIntegral r :: Int)                                 (fromIntegral g :: Int)-                                (fromIntegral b :: Int))+                                (fromIntegral b :: Int))) +simpleColor_ :: Integral i => Word8 -> i -> Word8+simpleColor_ e c+    | c <= 0 = 0+    | c <= 95 = 1+    | c <= 255 = fromIntegral ((c-16) `div` 40)+    | otherwise = e++-- | Create a RGB triple from a value in the Color240 set.+color240CodeToRGB :: Word8 -> Maybe (Int, Int, Int)+color240CodeToRGB n = case n of+    0 -> Just (0, 0, 0)+    1 -> Just (0, 0, 95)+    2 -> Just (0, 0, 135)+    3 -> Just (0, 0, 175)+    4 -> Just (0, 0, 215)+    5 -> Just (0, 0, 255)+    6 -> Just (0, 95, 0)+    7 -> Just (0, 95, 95)+    8 -> Just (0, 95, 135)+    9 -> Just (0, 95, 175)+    10 -> Just (0, 95, 215)+    11 -> Just (0, 95, 255)+    12 -> Just (0, 135, 0)+    13 -> Just (0, 135, 95)+    14 -> Just (0, 135, 135)+    15 -> Just (0, 135, 175)+    16 -> Just (0, 135, 215)+    17 -> Just (0, 135, 255)+    18 -> Just (0, 175, 0)+    19 -> Just (0, 175, 95)+    20 -> Just (0, 175, 135)+    21 -> Just (0, 175, 175)+    22 -> Just (0, 175, 215)+    23 -> Just (0, 175, 255)+    24 -> Just (0, 215, 0)+    25 -> Just (0, 215, 95)+    26 -> Just (0, 215, 135)+    27 -> Just (0, 215, 175)+    28 -> Just (0, 215, 215)+    29 -> Just (0, 215, 255)+    30 -> Just (0, 255, 0)+    31 -> Just (0, 255, 95)+    32 -> Just (0, 255, 135)+    33 -> Just (0, 255, 175)+    34 -> Just (0, 255, 215)+    35 -> Just (0, 255, 255)+    36 -> Just (95, 0, 0)+    37 -> Just (95, 0, 95)+    38 -> Just (95, 0, 135)+    39 -> Just (95, 0, 175)+    40 -> Just (95, 0, 215)+    41 -> Just (95, 0, 255)+    42 -> Just (95, 95, 0)+    43 -> Just (95, 95, 95)+    44 -> Just (95, 95, 135)+    45 -> Just (95, 95, 175)+    46 -> Just (95, 95, 215)+    47 -> Just (95, 95, 255)+    48 -> Just (95, 135, 0)+    49 -> Just (95, 135, 95)+    50 -> Just (95, 135, 135)+    51 -> Just (95, 135, 175)+    52 -> Just (95, 135, 215)+    53 -> Just (95, 135, 255)+    54 -> Just (95, 175, 0)+    55 -> Just (95, 175, 95)+    56 -> Just (95, 175, 135)+    57 -> Just (95, 175, 175)+    58 -> Just (95, 175, 215)+    59 -> Just (95, 175, 255)+    60 -> Just (95, 215, 0)+    61 -> Just (95, 215, 95)+    62 -> Just (95, 215, 135)+    63 -> Just (95, 215, 175)+    64 -> Just (95, 215, 215)+    65 -> Just (95, 215, 255)+    66 -> Just (95, 255, 0)+    67 -> Just (95, 255, 95)+    68 -> Just (95, 255, 135)+    69 -> Just (95, 255, 175)+    70 -> Just (95, 255, 215)+    71 -> Just (95, 255, 255)+    72 -> Just (135, 0, 0)+    73 -> Just (135, 0, 95)+    74 -> Just (135, 0, 135)+    75 -> Just (135, 0, 175)+    76 -> Just (135, 0, 215)+    77 -> Just (135, 0, 255)+    78 -> Just (135, 95, 0)+    79 -> Just (135, 95, 95)+    80 -> Just (135, 95, 135)+    81 -> Just (135, 95, 175)+    82 -> Just (135, 95, 215)+    83 -> Just (135, 95, 255)+    84 -> Just (135, 135, 0)+    85 -> Just (135, 135, 95)+    86 -> Just (135, 135, 135)+    87 -> Just (135, 135, 175)+    88 -> Just (135, 135, 215)+    89 -> Just (135, 135, 255)+    90 -> Just (135, 175, 0)+    91 -> Just (135, 175, 95)+    92 -> Just (135, 175, 135)+    93 -> Just (135, 175, 175)+    94 -> Just (135, 175, 215)+    95 -> Just (135, 175, 255)+    96 -> Just (135, 215, 0)+    97 -> Just (135, 215, 95)+    98 -> Just (135, 215, 135)+    99 -> Just (135, 215, 175)+    100 -> Just (135, 215, 215)+    101 -> Just (135, 215, 255)+    102 -> Just (135, 255, 0)+    103 -> Just (135, 255, 95)+    104 -> Just (135, 255, 135)+    105 -> Just (135, 255, 175)+    106 -> Just (135, 255, 215)+    107 -> Just (135, 255, 255)+    108 -> Just (175, 0, 0)+    109 -> Just (175, 0, 95)+    110 -> Just (175, 0, 135)+    111 -> Just (175, 0, 175)+    112 -> Just (175, 0, 215)+    113 -> Just (175, 0, 255)+    114 -> Just (175, 95, 0)+    115 -> Just (175, 95, 95)+    116 -> Just (175, 95, 135)+    117 -> Just (175, 95, 175)+    118 -> Just (175, 95, 215)+    119 -> Just (175, 95, 255)+    120 -> Just (175, 135, 0)+    121 -> Just (175, 135, 95)+    122 -> Just (175, 135, 135)+    123 -> Just (175, 135, 175)+    124 -> Just (175, 135, 215)+    125 -> Just (175, 135, 255)+    126 -> Just (175, 175, 0)+    127 -> Just (175, 175, 95)+    128 -> Just (175, 175, 135)+    129 -> Just (175, 175, 175)+    130 -> Just (175, 175, 215)+    131 -> Just (175, 175, 255)+    132 -> Just (175, 215, 0)+    133 -> Just (175, 215, 95)+    134 -> Just (175, 215, 135)+    135 -> Just (175, 215, 175)+    136 -> Just (175, 215, 215)+    137 -> Just (175, 215, 255)+    138 -> Just (175, 255, 0)+    139 -> Just (175, 255, 95)+    140 -> Just (175, 255, 135)+    141 -> Just (175, 255, 175)+    142 -> Just (175, 255, 215)+    143 -> Just (175, 255, 255)+    144 -> Just (215, 0, 0)+    145 -> Just (215, 0, 95)+    146 -> Just (215, 0, 135)+    147 -> Just (215, 0, 175)+    148 -> Just (215, 0, 215)+    149 -> Just (215, 0, 255)+    150 -> Just (215, 95, 0)+    151 -> Just (215, 95, 95)+    152 -> Just (215, 95, 135)+    153 -> Just (215, 95, 175)+    154 -> Just (215, 95, 215)+    155 -> Just (215, 95, 255)+    156 -> Just (215, 135, 0)+    157 -> Just (215, 135, 95)+    158 -> Just (215, 135, 135)+    159 -> Just (215, 135, 175)+    160 -> Just (215, 135, 215)+    161 -> Just (215, 135, 255)+    162 -> Just (215, 175, 0)+    163 -> Just (215, 175, 95)+    164 -> Just (215, 175, 135)+    165 -> Just (215, 175, 175)+    166 -> Just (215, 175, 215)+    167 -> Just (215, 175, 255)+    168 -> Just (215, 215, 0)+    169 -> Just (215, 215, 95)+    170 -> Just (215, 215, 135)+    171 -> Just (215, 215, 175)+    172 -> Just (215, 215, 215)+    173 -> Just (215, 215, 255)+    174 -> Just (215, 255, 0)+    175 -> Just (215, 255, 95)+    176 -> Just (215, 255, 135)+    177 -> Just (215, 255, 175)+    178 -> Just (215, 255, 215)+    179 -> Just (215, 255, 255)+    180 -> Just (255, 0, 0)+    181 -> Just (255, 0, 95)+    182 -> Just (255, 0, 135)+    183 -> Just (255, 0, 175)+    184 -> Just (255, 0, 215)+    185 -> Just (255, 0, 255)+    186 -> Just (255, 95, 0)+    187 -> Just (255, 95, 95)+    188 -> Just (255, 95, 135)+    189 -> Just (255, 95, 175)+    190 -> Just (255, 95, 215)+    191 -> Just (255, 95, 255)+    192 -> Just (255, 135, 0)+    193 -> Just (255, 135, 95)+    194 -> Just (255, 135, 135)+    195 -> Just (255, 135, 175)+    196 -> Just (255, 135, 215)+    197 -> Just (255, 135, 255)+    198 -> Just (255, 175, 0)+    199 -> Just (255, 175, 95)+    200 -> Just (255, 175, 135)+    201 -> Just (255, 175, 175)+    202 -> Just (255, 175, 215)+    203 -> Just (255, 175, 255)+    204 -> Just (255, 215, 0)+    205 -> Just (255, 215, 95)+    206 -> Just (255, 215, 135)+    207 -> Just (255, 215, 175)+    208 -> Just (255, 215, 215)+    209 -> Just (255, 215, 255)+    210 -> Just (255, 255, 0)+    211 -> Just (255, 255, 95)+    212 -> Just (255, 255, 135)+    213 -> Just (255, 255, 175)+    214 -> Just (255, 255, 215)+    215 -> Just (255, 255, 255)+    216 -> Just (8, 8, 8)+    217 -> Just (18, 18, 18)+    218 -> Just (28, 28, 28)+    219 -> Just (38, 38, 38)+    220 -> Just (48, 48, 48)+    221 -> Just (58, 58, 58)+    222 -> Just (68, 68, 68)+    223 -> Just (78, 78, 78)+    224 -> Just (88, 88, 88)+    225 -> Just (98, 98, 98)+    226 -> Just (108, 108, 108)+    227 -> Just (118, 118, 118)+    228 -> Just (128, 128, 128)+    229 -> Just (138, 138, 138)+    230 -> Just (148, 148, 148)+    231 -> Just (158, 158, 158)+    232 -> Just (168, 168, 168)+    233 -> Just (178, 178, 178)+    234 -> Just (188, 188, 188)+    235 -> Just (198, 198, 198)+    236 -> Just (208, 208, 208)+    237 -> Just (218, 218, 218)+    238 -> Just (228, 228, 228)+    239 -> Just (238, 238, 238)+    _   -> Nothing
src/Graphics/Vty/Config.hs view
@@ -1,24 +1,28 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE KindSignatures #-}--- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can--- be used to customize vty for a user's system.+-- | Vty supports a configuration file format and provides a+-- corresponding 'VtyUserConfig' data type. The 'VtyUserConfig' can be+-- provided to platform packages' @mkVty@ functions to customize the+-- application's use of Vty. ----- The 'Config' provided is mappend'd to 'Config's loaded from @'getAppUserDataDirectory'/config@--- and @$VTY_CONFIG_FILE@. The @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the--- application provided 'Config'.+-- = Debug ----- Lines in config files that fail to parse are ignored.  Later entries take precedence over--- earlier.+-- == @colorMode@ ----- For all directives:--- +-- Format:+-- -- @---  string := \"\\\"\" chars+ \"\\\"\"+--  colorMode \"<ColorMode8|ColorMode16|ColorMode240 <int>|FullColor>\" -- @ ----- = Debug+-- The preferred color mode to use, chosen from the constructors of the+-- 'ColorMode' type. If absent, the backend driver may detect and choose+-- an appropriate color mode. Implementor's note: backend packages+-- should respect this setting when it is present even when their+-- detection indicates that a different color mode should be used. -- -- == @debugLog@ --@@ -28,8 +32,8 @@ --  \"debugLog\" string -- @ ----- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent to a debugLog entry at the--- end of the last config file.+-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent+-- to a debugLog entry at the end of the last config file. -- -- = Input Processing --@@ -39,14 +43,14 @@ -- -- @ --  \"map\" term string key modifier_list---  where +--  where --      key := KEsc | KChar Char | KBS ... (same as 'Key') --      modifier_list := \"[\" modifier+ \"]\" --      modifier := MShift | MCtrl | MMeta | MAlt --      term := "_" | string -- @ ----- EG: If the contents are+-- E.g., if the contents are -- -- @ --  map _       \"\\ESC[B\"    KUp   []@@ -54,231 +58,381 @@ --  map \"xterm\" \"\\ESC[D\"    KLeft [] -- @ ----- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all terminals. The bytes--- @\"\\ESC[1;3B\"@ will result in the event KDown with the MAlt modifier on all terminals.--- The bytes @\"\\ESC[D\"@ will result in the KLeft event when @TERM@ is @xterm@.+-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all+-- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown+-- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will+-- result in the KLeft event when @TERM@ is @xterm@. ----- If a debug log is requested then vty will output the current input table to the log in the above--- format.+-- If a debug log is requested then vty will output the current input+-- table to the log in the above format. A workflow for using this is+-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for+-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@. ----- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings. Add corrected mappings to--- .vty/config+-- = Unicode Character Width Maps ---module Graphics.Vty.Config where+-- == @widthMap@+--+-- Format:+--+-- @+--  \"widthMap\" string string+-- @+--+-- E.g.,+--+-- @+--   widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"+-- @+--+-- This directive specifies the path to a Unicode character+-- width map (the second argument) that should correspond to+-- the terminal named by first argument. Unicode character+-- width maps can be produced either by running platform+-- packages' width table tools or by calling the library routine+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. Vty+-- platform packages should use these configuration settings to attempt+-- to load and install the specified width map.+module Graphics.Vty.Config+  ( InputMap+  , VtyUserConfig(..)+  , userConfig+  , overrideEnvConfig+  , currentTerminalName+  , runParseConfig+  , parseConfigFile+  , defaultConfig -#if __GLASGOW_HASKELL__ > 704+  , vtyConfigPath+  , widthTableFilename+  , vtyDataDirectory+  , terminalWidthTablePath+  , vtyConfigFileEnvName++  , ConfigUpdateResult(..)+  , addConfigWidthMap+  )+where+ import Prelude-#else-import Prelude hiding (catch)-#endif  import Control.Applicative hiding (many)  import Control.Exception (catch, IOException)-import Control.Monad (void)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Writer+import Control.Monad (liftM, guard, void)  import qualified Data.ByteString as BS-import Data.Default-import Data.Monoid+#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Text.Read (readMaybe) +import Graphics.Vty.Attributes.Color (ColorMode(..)) import Graphics.Vty.Input.Events -import System.Directory (getAppUserDataDirectory)-import System.Posix.Env (getEnv)-import System.Posix.IO (stdInput, stdOutput)-import System.Posix.Types (Fd(..))+import GHC.Generics +import System.Directory ( getAppUserDataDirectory, doesFileExist+                        , createDirectoryIfMissing+                        )+import System.Environment (lookupEnv)+import System.FilePath ((</>), takeDirectory)+ import Text.Parsec hiding ((<|>)) import Text.Parsec.Token ( GenLanguageDef(..) ) import qualified Text.Parsec.Token as P --- | Mappings from input bytes to event in the order specified. Later entries take precedence over--- earlier in the case multiple entries have the same byte string.+-- | Mappings from input bytes to event in the order specified. Later+-- entries take precedence over earlier in the case multiple entries+-- have the same byte string. type InputMap = [(Maybe String, String, Event)] -data Config = Config-    {-    -- | The default is 1 character.-      vmin  :: Maybe Int-    -- | The default is 100 milliseconds, 0.1 seconds.-    , vtime :: Maybe Int-    -- | Debug information is appended to this file if not Nothing.-    , debugLog           :: Maybe FilePath-    -- | The (input byte, output event) pairs extend the internal input table of VTY and the table-    -- from terminfo.-    ---    -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive.-    , inputMap           :: InputMap-    -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput'-    , inputFd           :: Maybe Fd-    -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput'-    , outputFd          :: Maybe Fd-    -- | The terminal name used to look up terminfo capabilities.-    -- The default is the value of the TERM environment variable.-    , termName           :: Maybe String-    } deriving (Show, Eq)+-- | A Vty core library configuration. Platform-specific details are not+-- included in the VtyUserConfig.+data VtyUserConfig =+    VtyUserConfig { configDebugLog :: Maybe FilePath+                  -- ^ Debug information is appended to this file if not+                  -- Nothing.+                  , configInputMap :: InputMap+                  -- ^ The (input byte, output event) pairs extend the internal+                  -- input table of VTY and the table from terminfo.+                  --+                  -- See "Graphics.Vty.Config" module documentation for+                  -- documentation of the @map@ directive.+                  , configTermWidthMaps :: [(String, FilePath)]+                  -- ^ Terminal width map files.+                  , configAllowCustomUnicodeWidthTables :: Maybe Bool+                  -- ^ Whether to permit custom Unicode width table loading by+                  -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that+                  -- table loading should not be performed. Other values permit+                  -- table loading.+                  --+                  -- If a table load is attempted and fails, information+                  -- about the failure will be logged to the debug log if the+                  -- configuration specifies one. If no custom table is loaded+                  -- (or if a load fails), the built-in character width table+                  -- will be used.+                  , configPreferredColorMode :: Maybe ColorMode+                  -- ^ Preferred color mode. If set, this should+                  -- override platform color mode detection.+                  }+                  deriving (Show, Eq) -instance Default Config where-    def = mempty+defaultConfig :: VtyUserConfig+defaultConfig = mempty -instance Monoid Config where-    mempty = Config-        { vmin         = Nothing-        , vtime        = Nothing-        , debugLog     = mempty-        , inputMap     = mempty-        , inputFd     = Nothing-        , outputFd    = Nothing-        , termName     = Nothing-        }-    mappend c0 c1 = Config+instance Semigroup VtyUserConfig where+    c0 <> c1 =         -- latter config takes priority for everything but inputMap-        { vmin          = vmin c1     <|> vmin c0-        , vtime         = vtime c1    <|> vtime c0-        , debugLog      = debugLog c1 <|> debugLog c0-        , inputMap      = inputMap c0 <>  inputMap c1-        , inputFd      = inputFd c1 <|> inputFd c0-        , outputFd     = outputFd c1 <|> outputFd c0-        , termName      = termName c1 <|> termName c0-        }+        VtyUserConfig { configDebugLog =+                          configDebugLog c1 <|> configDebugLog c0+                      , configInputMap =+                          configInputMap c0 <> configInputMap c1+                      , configTermWidthMaps =+                          configTermWidthMaps c1 <|> configTermWidthMaps c0+                      , configAllowCustomUnicodeWidthTables =+                          configAllowCustomUnicodeWidthTables c1 <|> configAllowCustomUnicodeWidthTables c0+                      , configPreferredColorMode =+                          configPreferredColorMode c1 <|> configPreferredColorMode c0+                      } -type ConfigParser s a = ParsecT s () (Writer Config) a+instance Monoid VtyUserConfig where+    mempty =+        VtyUserConfig { configDebugLog = mempty+                      , configInputMap = mempty+                      , configTermWidthMaps = []+                      , configAllowCustomUnicodeWidthTables = Nothing+                      , configPreferredColorMode = Nothing+                      }+#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif --- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@-userConfig :: IO Config+vtyDataDirectory :: IO FilePath+vtyDataDirectory = getAppUserDataDirectory "vty"++vtyConfigPath :: IO FilePath+vtyConfigPath = do+    dir <- vtyDataDirectory+    return $ dir </> "config"++vtyConfigFileEnvName :: String+vtyConfigFileEnvName = "VTY_CONFIG_FILE"++-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.+-- If none is found, build a default configuration.+userConfig :: IO VtyUserConfig userConfig = do-    configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile-    overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"+    configFile <- vtyConfigPath >>= parseConfigFile+    overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<+        lookupEnv vtyConfigFileEnvName     let base = configFile <> overrideConfig     mappend base <$> overrideEnvConfig -overrideEnvConfig :: IO Config-overrideEnvConfig = do-    d <- getEnv "VTY_DEBUG_LOG"-    return $ def { debugLog = d }+widthTableFilename :: String -> String+widthTableFilename term = "width_table_" <> term <> ".dat" -standardIOConfig :: IO Config-standardIOConfig = do-    Just t <- getEnv "TERM"-    return $ def { vmin = Just 1-                 , vtime = Just 100-                 , inputFd = Just stdInput-                 , outputFd = Just stdOutput-                 , termName = Just t-                 }+termVariable :: String+termVariable = "TERM" -parseConfigFile :: FilePath -> IO Config+currentTerminalName :: IO (Maybe String)+currentTerminalName = lookupEnv termVariable++terminalWidthTablePath :: IO (Maybe FilePath)+terminalWidthTablePath = do+    dataDir <- vtyDataDirectory+    result <- lookupEnv termVariable+    case result of+        Nothing -> return Nothing+        Just term -> do+            return $ Just $ dataDir </> widthTableFilename term++overrideEnvConfig :: IO VtyUserConfig+overrideEnvConfig = do+    d <- lookupEnv "VTY_DEBUG_LOG"+    return $ defaultConfig { configDebugLog = d }++-- | Parse a Vty configuration file.+--+-- Lines in config files that fail to parse are ignored. Later entries+-- take precedence over earlier ones.+parseConfigFile :: FilePath -> IO VtyUserConfig parseConfigFile path = do     catch (runParseConfig path <$> BS.readFile path)-          (\(_ :: IOException) -> return def)+          (\(_ :: IOException) -> return defaultConfig) -runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config-runParseConfig name = execWriter . runParserT parseConfig () name+runParseConfig :: String -> BS.ByteString -> VtyUserConfig+runParseConfig name cfgTxt =+  case runParser parseConfig () name cfgTxt of+    Right cfg -> cfg+    Left{}    -> defaultConfig --- I tried to use the haskellStyle here but that was specialized (without requirement?) to the--- String stream type.-configLanguage :: Stream s m Char => P.GenLanguageDef s u m+------------------------------------------------------------------------++type Parser = Parsec BS.ByteString ()++configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m configLanguage = LanguageDef-    { commentStart = "{-"-    , commentEnd = "-}"-    , commentLine = "--"-    , nestedComments = True-    , identStart = letter <|> char '_'-    , identLetter = alphaNum <|> oneOf "_'"-    , opStart = opLetter configLanguage-    , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+    { commentStart    = "{-"+    , commentEnd      = "-}"+    , commentLine     = "--"+    , nestedComments  = True+    , identStart      = letter <|> char '_'+    , identLetter     = alphaNum <|> oneOf "_'"+    , opStart         = opLetter configLanguage+    , opLetter        = oneOf ":!#$%&*+./<=>?@\\^|-~"     , reservedOpNames = []-    , reservedNames = []-    , caseSensitive = True+    , reservedNames   = []+    , caseSensitive   = True     } -configLexer :: Stream s m Char => P.GenTokenParser s u m+configLexer :: Monad m => P.GenTokenParser BS.ByteString () m configLexer = P.makeTokenParser configLanguage -mapDecl :: forall s u (m :: * -> *).-           (Monad m, Stream s (WriterT Config m) Char) =>-           ParsecT s u (WriterT Config m) ()+mapDecl :: Parser VtyUserConfig mapDecl = do-    void $ string "map"-    P.whiteSpace configLexer+    "map" <- P.identifier configLexer     termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)              <|> (Just <$> P.stringLiteral configLexer)-    bytes <- P.stringLiteral configLexer-    key <- parseKey-    modifiers <- parseModifiers-    lift $ tell $ def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }---- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read--- instance? Generics?-parseKey :: forall s u (m :: * -> *).-            Stream s m Char =>-            ParsecT s u m Key-parseKey = do-    key <- P.identifier configLexer-    case key of-     "KChar" -> KChar <$> P.charLiteral configLexer-     "KFun" -> KFun . fromInteger <$> P.natural configLexer-     "KEsc" -> return KEsc-     "KBS" -> return KBS-     "KEnter" -> return KEnter-     "KLeft" -> return KLeft-     "KRight" -> return KRight-     "KUp" -> return KUp-     "KDown" -> return KDown-     "KUpLeft" -> return KUpLeft-     "KUpRight" -> return KUpRight-     "KDownLeft" -> return KDownLeft-     "KDownRight" -> return KDownRight-     "KCenter" -> return KCenter-     "KBackTab" -> return KBackTab-     "KPrtScr" -> return KPrtScr-     "KPause" -> return KPause-     "KIns" -> return KIns-     "KHome" -> return KHome-     "KPageUp" -> return KPageUp-     "KDel" -> return KDel-     "KEnd" -> return KEnd-     "KPageDown" -> return KPageDown-     "KBegin" -> return KBegin-     "KMenu" -> return KMenu-     _ -> fail $ key ++ " is not a valid key identifier"+    bytes     <- P.stringLiteral configLexer+    key       <- parseValue+    modifiers <- parseValue+    return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] } -parseModifiers :: forall s u (m :: * -> *).-                  Stream s m Char =>-                  ParsecT s u m [Modifier]-parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",")+debugLogDecl :: Parser VtyUserConfig+debugLogDecl = do+    "debugLog" <- P.identifier configLexer+    path       <- P.stringLiteral configLexer+    return defaultConfig { configDebugLog = Just path } -parseModifier :: forall s u (m :: * -> *).-                 Stream s m Char =>-                 ParsecT s u m Modifier-parseModifier = do-    m <- P.identifier configLexer-    case m of-        "KMenu" -> return MShift-        "MCtrl" -> return MCtrl-        "MMeta" -> return MMeta-        "MAlt" -> return MAlt-        _ -> fail $ m ++ " is not a valid modifier identifier"+colorModeDecl :: Parser VtyUserConfig+colorModeDecl = do+    "colorMode" <- P.identifier configLexer+    mode <- P.stringLiteral configLexer+    return defaultConfig { configPreferredColorMode = readMaybe mode } -debugLogDecl :: forall s u (m :: * -> *).-                (Monad m, Stream s (WriterT Config m) Char) =>-                ParsecT s u (WriterT Config m) ()-debugLogDecl = do-    void $ string "debugLog"-    P.whiteSpace configLexer+widthMapDecl :: Parser VtyUserConfig+widthMapDecl = do+    "widthMap" <- P.identifier configLexer+    tName <- P.stringLiteral configLexer     path <- P.stringLiteral configLexer-    lift $ tell $ def { debugLog = Just path }+    return defaultConfig { configTermWidthMaps = [(tName, path)] } -ignoreLine :: forall s u (m :: * -> *).-              Stream s m Char => ParsecT s u m ()+ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline -parseConfig :: forall s u (m :: * -> *).-               (Monad m, Stream s (WriterT Config m) Char) =>-               ParsecT s u (WriterT Config m) ()-parseConfig = void $ many $ do+parseConfig :: Parser VtyUserConfig+parseConfig = liftM mconcat $ many $ do     P.whiteSpace configLexer-    let directives = [mapDecl, debugLogDecl]-    try (choice directives) <|> ignoreLine+    let directives = [try mapDecl, try debugLogDecl, try widthMapDecl, try colorModeDecl]+    choice directives <|> (ignoreLine >> return defaultConfig)++class    Parse a        where parseValue :: Parser a+instance Parse Char     where parseValue = P.charLiteral configLexer+instance Parse Int      where parseValue = fromInteger <$> P.natural configLexer+instance Parse Key      where parseValue = genericParse+instance Parse Modifier where parseValue = genericParse+instance Parse a => Parse [a] where+  parseValue = P.brackets configLexer+                 (parseValue `sepBy` P.symbol configLexer ",")++------------------------------------------------------------------------+-- Derived parser for ADTs via generics+------------------------------------------------------------------------++genericParse :: (Generic a, GParse (Rep a)) => Parser a+genericParse = to <$> gparse++class    GParse f                      where gparse :: Parser (f a)+instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse+instance GParse U1                     where gparse = return U1+instance Parse a => GParse (K1 i a)    where gparse = K1 <$> parseValue++instance (GParse f, GParse g) => GParse (f :*: g) where+  gparse = (:*:) <$> gparse <*> gparse++instance GParseAlts f => GParse (M1 D i f) where+  gparse =+    do con <- P.identifier configLexer+       M1 <$> gparseAlts con++------------------------------------------------------------------------++class GParseAlts f where+  gparseAlts :: String -> Parser (f a)++instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where+  gparseAlts con =+    do guard (con == conName (M1 Nothing :: C1 i Maybe a))+       M1 <$> gparse++instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where+  gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con++instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"++-- | The result of a configuration change attempt made by+-- 'addConfigWidthMap'.+data ConfigUpdateResult =+    ConfigurationCreated+    -- ^ A new configuration file file was written with the new width+    -- table entry.+    | ConfigurationModified+    -- ^ An existing configuration file was modified with the new width+    -- table entry.+    | ConfigurationConflict String+    -- ^ The attempted width table entry could not be written to the+    -- configuration due to a conflict; the argument here is the width+    -- table file path for the conflicting entry.+    | ConfigurationRedundant+    -- ^ No change was made because the existing configuration already+    -- contains the specified mapping.+    deriving (Eq, Show)++-- | Add a @widthMap@ directive to the Vty configuration file at the+-- specified path.+--+-- If the configuration path refers to a configuration that already+-- contains the directive for the specified map and terminal type, the+-- configuration file will not be modified. If the file does not contain+-- the directive, it will be appended to the file.+--+-- If the configuration path does not exist, a new configuration file+-- will be created and any directories in the path will also be created.+--+-- This returns a 'ConfigUpdateResult' indicating the change to the+-- configuration. This does not handle exceptions raised by file or+-- directory permissions issues.+addConfigWidthMap :: FilePath+                  -- ^ The configuration file path of the configuration+                  -- to modify or create.+                  -> String+                  -- ^ The @TERM@ value for the @widthMap@ directive.+                  -> FilePath+                  -- ^ The width table file path for the directive.+                  -> IO ConfigUpdateResult+addConfigWidthMap configPath term tablePath = do+    configEx <- doesFileExist configPath+    if configEx+       then updateConfig+       else createConfig >> return ConfigurationCreated++    where+        directive = "widthMap " <> show term <> " " <> show tablePath <> "\n"++        createConfig = do+            let dir = takeDirectory configPath+            createDirectoryIfMissing True dir+            writeFile configPath directive++        updateConfig = do+            config <- parseConfigFile configPath+            if (term, tablePath) `elem` configTermWidthMaps config+               then return ConfigurationRedundant+               else case lookup term (configTermWidthMaps config) of+                   Just other -> return $ ConfigurationConflict other+                   Nothing -> do+                       appendFile configPath directive+                       return ConfigurationModified
src/Graphics/Vty/Debug.hs view
@@ -1,29 +1,34 @@ -- Copyright 2009-2010 Corey O'Connor-module Graphics.Vty.Debug ( module Graphics.Vty.Debug-                          , module Graphics.Vty.Debug.Image-                          )+module Graphics.Vty.Debug+  ( MockWindow(..)+  , SpanConstructLog+  , regionForWindow+  , allSpansHaveWidth+  , spanOpsAffectedColumns+  , spanOpsAffectedRows+  , rowOpsAffectedColumns+  , isSetAttr+  ) where -import Graphics.Vty.Prelude- import Graphics.Vty.Attributes-import Graphics.Vty.Debug.Image+import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Span -import qualified Data.Vector as Vector +import qualified Data.Vector as Vector -rowOpsEffectedColumns :: DisplayOps -> [Int]-rowOpsEffectedColumns ops -    = Vector.toList $ Vector.map spanOpsEffectedColumns ops+rowOpsAffectedColumns :: DisplayOps -> [Int]+rowOpsAffectedColumns ops+    = Vector.toList $ Vector.map spanOpsAffectedColumns ops  allSpansHaveWidth :: DisplayOps -> Int -> Bool allSpansHaveWidth ops expected-    = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops+    = all (== expected) $ Vector.toList $ Vector.map spanOpsAffectedColumns ops -spanOpsEffectedRows :: DisplayOps -> Int-spanOpsEffectedRows ops+spanOpsAffectedRows :: DisplayOps -> Int+spanOpsAffectedRows ops     = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))-        + type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr @@ -37,4 +42,3 @@  regionForWindow :: MockWindow -> DisplayRegion regionForWindow (MockWindow w h) = (w,h)-
− src/Graphics/Vty/Debug/Image.hs 
@@ -1,32 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-module Graphics.Vty.Debug.Image where--import Graphics.Vty.Image--type ImageConstructLog = [ImageConstructEvent]-data ImageConstructEvent = ImageConstructEvent-    deriving ( Show, Eq )--forwardImageOps :: [Image -> Image]-forwardImageOps = map forwardTransform debugImageOps--forwardTransform, reverseTransform :: ImageOp -> (Image -> Image)--forwardTransform (ImageOp f _) = f-reverseTransform (ImageOp _ r) = r--data ImageOp = ImageOp ImageEndo ImageEndo-type ImageEndo = Image -> Image--debugImageOps :: [ImageOp]-debugImageOps = -    [ idImageOp-    -- , renderSingleColumnCharOp-    -- , renderDoubleColumnCharOp-    ]--idImageOp :: ImageOp-idImageOp = ImageOp id id---- renderCharOp :: ImageOp--- renderCharOp = ImageOp id id
src/Graphics/Vty/DisplayAttributes.hs view
@@ -1,31 +1,38 @@ -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif+{-# LANGUAGE CPP #-}  module Graphics.Vty.DisplayAttributes-    where+  ( DisplayAttrDiff(..)+  , StyleStateChange(..)+  , DisplayColorDiff(..)+  , URLDiff(..)+  , fixDisplayAttr+  , displayAttrDiffs+  )+where  import Graphics.Vty.Attributes  import Data.Bits ((.&.))--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (Monoid(..), mconcat)+import Data.ByteString (ByteString)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..)) #endif+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8) --- | Given the previously applied display attributes as a FixedAttr and the current display--- attributes as an Attr produces a FixedAttr that represents the current display attributes. This--- is done by using the previously applied display attributes to remove the "KeepCurrent"+-- | Given the previously applied display attributes as a FixedAttr and+-- the current display attributes as an Attr produces a FixedAttr that+-- represents the current display attributes. This is done by using the+-- previously applied display attributes to remove the "KeepCurrent" -- abstraction. fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr fixDisplayAttr fattr attr     = FixedAttr (fixStyle (fixedStyle fattr)     (attrStyle attr))                 (fixColor (fixedForeColor fattr) (attrForeColor attr))                 (fixColor (fixedBackColor fattr) (attrBackColor attr))+                (fixURL   (fixedURL fattr)       (attrURL attr))     where         fixStyle _s Default           = defaultStyleMask         fixStyle s KeepCurrent        = s@@ -33,43 +40,56 @@         fixColor _c Default           = Nothing         fixColor c KeepCurrent        = c         fixColor _c (SetTo c)         = Just c+        fixURL c KeepCurrent          = c+        fixURL _c (SetTo n)           = Just n+        fixURL _c Default             = Nothing --- | difference between two display attributes. Used in the calculation of the operations required--- to go from one display attribute to the next.+-- | difference between two display attributes. Used in the calculation+-- of the operations required to go from one display attribute to the+-- next. ----- Previously, vty would reset display attributes to default then apply the new display attributes.--- This turned out to be very expensive: A *lot* more data would be sent to the terminal than--- required.+-- Previously, vty would reset display attributes to default then apply+-- the new display attributes. This turned out to be very expensive: A+-- *lot* more data would be sent to the terminal than required. data DisplayAttrDiff = DisplayAttrDiff     { styleDiffs    :: [StyleStateChange]     , foreColorDiff :: DisplayColorDiff     , backColorDiff :: DisplayColorDiff+    , urlDiff       :: URLDiff     }     deriving (Show) -instance Monoid DisplayAttrDiff where-    mempty = DisplayAttrDiff [] NoColorChange NoColorChange-    mappend d0 d1 =+instance Semigroup DisplayAttrDiff where+    d0 <> d1 =         let ds  = simplifyStyleDiffs (styleDiffs d0)    (styleDiffs d1)             fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)             bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)-        in DisplayAttrDiff ds fcd bcd+            ud  = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)+        in DisplayAttrDiff ds fcd bcd ud +instance Monoid DisplayAttrDiff where+    mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange+#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif+ -- | Used in the computation of a final style attribute change.------ TODO(corey): not really a simplify but a monoid instance. simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange] simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1 --- | Consider two display color attributes diffs. What display color attribute diff are these--- equivalent to?------ TODO(corey): not really a simplify but a monoid instance.+-- | Consider two display color attributes diffs. What display color+-- attribute diff are these equivalent to? simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplifyColorDiffs _cd             ColorToDefault = ColorToDefault simplifyColorDiffs cd              NoColorChange  = cd simplifyColorDiffs _cd             (SetColor !c)  = SetColor c +-- | Consider two URL changes, which are mostly going to be the latter+-- unless the latter specifies no change.+simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff+simplifyUrlDiffs ud NoLinkChange = ud+simplifyUrlDiffs _ ud = ud+ -- | Difference between two display color attribute changes. data DisplayColorDiff     = ColorToDefault@@ -77,11 +97,15 @@     | SetColor !Color     deriving (Show, Eq) --- | Style attribute changes are transformed into a sequence of apply/removes of the individual--- attributes.-data StyleStateChange +-- | Style attribute changes are transformed into a sequence of+-- apply/removes of the individual attributes.+data StyleStateChange     = ApplyStandout     | RemoveStandout+    | ApplyItalic+    | RemoveItalic+    | ApplyStrikethrough+    | RemoveStrikethrough     | ApplyUnderline     | RemoveUnderline     | ApplyReverseVideo@@ -94,15 +118,28 @@     | RemoveBold     deriving (Show, Eq) --- | Determines the diff between two display&color attributes. This diff determines the operations--- that actually get output to the terminal.+-- Setting and unsetting hyperlinks+data URLDiff+    = LinkTo !ByteString+    | NoLinkChange+    | EndLink+    deriving (Show, Eq)++-- | Determines the diff between two display&color attributes. This diff+-- determines the operations that actually get output to the terminal. displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff displayAttrDiffs attr attr' = DisplayAttrDiff     { styleDiffs    = diffStyles (fixedStyle attr)      (fixedStyle attr')     , foreColorDiff = diffColor  (fixedForeColor attr) (fixedForeColor attr')     , backColorDiff = diffColor  (fixedBackColor attr) (fixedBackColor attr')+    , urlDiff       = diffURL    (fixedURL attr)       (fixedURL attr')     } +diffURL :: Maybe Text -> Maybe Text -> URLDiff+diffURL Nothing Nothing = NoLinkChange+diffURL (Just _) Nothing = EndLink+diffURL _ (Just url) = LinkTo (encodeUtf8 url)+ diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff diffColor Nothing  (Just c') = SetColor c' diffColor (Just c) (Just c')@@ -116,6 +153,8 @@     = mconcat     [ styleDiff standout      ApplyStandout     RemoveStandout     , styleDiff underline     ApplyUnderline    RemoveUnderline+    , styleDiff italic        ApplyItalic       RemoveItalic+    , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough     , styleDiff reverseVideo  ApplyReverseVideo RemoveReverseVideo     , styleDiff blink         ApplyBlink        RemoveBlink     , styleDiff dim           ApplyDim          RemoveDim
src/Graphics/Vty/Error.hs view
@@ -1,8 +1,11 @@ module Graphics.Vty.Error-    where+  ( VtyException(..)+  )+where  -- | The type of exceptions specific to vty. ----- These have fully qualified names by default since, IMO, exception handling requires this.+-- These have fully qualified names by default since, IMO, exception+-- handling requires this. data VtyException     =  VtyFailure String -- ^ Uncategorized failure specific to vty.
src/Graphics/Vty/Image.hs view
@@ -1,48 +1,62 @@ -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-}-module Graphics.Vty.Image ( DisplayText-                          , Image-                          , imageWidth-                          , imageHeight-                          , horizJoin-                          , (<|>)-                          , vertJoin-                          , (<->)-                          , horizCat-                          , vertCat-                          , backgroundFill-                          , text-                          , text'-                          , char-                          , string-                          , iso10646String-                          , utf8String-                          , utf8Bytestring-                          , utf8Bytestring'-                          , charFill-                          , emptyImage-                          , safeWcwidth-                          , safeWcswidth-                          , wcwidth-                          , wcswidth-                          , crop-                          , cropRight-                          , cropLeft-                          , cropBottom-                          , cropTop-                          , pad-                          , resize-                          , resizeWidth-                          , resizeHeight-                          , translate-                          , translateX-                          , translateY-                          -- | The possible display attributes used in constructing an `Image`.-                          , module Graphics.Vty.Attributes-                          )-    where+-- | A Vty program makes 'Picture's from 'Image's. This module provides+-- the core constructors for creating, combining, and modifying+-- 'Image's.+module Graphics.Vty.Image+  (+  -- * Images+    Image+  , imageWidth+  , imageHeight+  -- * Image constructors+  , emptyImage+  , char+  , string+  , iso10646String+  , utf8String+  , text+  , text'+  , backgroundFill+  , utf8Bytestring+  , utf8Bytestring'+  , charFill+  -- * Combinators+  , horizJoin+  , (<|>)+  , vertJoin+  , (<->)+  , horizCat+  , vertCat+  -- * Image modifications+  , crop+  , cropRight+  , cropLeft+  , cropBottom+  , cropTop+  , pad+  , resize+  , resizeWidth+  , resizeHeight+  , translate+  , translateX+  , translateY+  -- * Character width functions+  , safeWcwidth+  , safeWcswidth+  , safeWctwidth+  , safeWctlwidth+  , wcwidth+  , wcswidth+  , wctwidth+  , wctlwidth+  -- * Display Regions+  , DisplayRegion+  , regionWidth+  , regionHeight+  )+where  import Graphics.Vty.Attributes import Graphics.Vty.Image.Internal@@ -56,120 +70,163 @@ import qualified Data.Text.Lazy.Encoding as TL import Data.Word +-- | A region of the display (first width, then height)+type DisplayRegion = (Int,Int)++regionWidth :: DisplayRegion -> Int+regionWidth = fst++regionHeight :: DisplayRegion -> Int+regionHeight = snd+ infixr 5 <|> infixr 4 <-> --- | An area of the picture's bacground (See Background) of w columns and h rows.-backgroundFill :: Int -> Int -> Image-backgroundFill w h +-- | An area of the picture's background (See 'Background').+backgroundFill :: Int+               -- ^ Fill width in columns+               -> Int+               -- ^ Fill height in rows+               -> Image+backgroundFill w h     | w == 0    = EmptyImage     | h == 0    = EmptyImage     | otherwise = BGFill w h --- | Combines two images horizontally. Alias for horizJoin+-- | Combines two images horizontally. This is an alias for 'horizJoin'. -- -- infixr 5 (<|>) :: Image -> Image -> Image (<|>) = horizJoin --- | Combines two images vertically. Alias for vertJoin+-- | Combines two images vertically. This is an alias for 'vertJoin'. -- -- infixr 4 (<->) :: Image -> Image -> Image (<->) = vertJoin --- | Compose any number of images horizontally.+-- | Compose any number of images together horizontally, with the first+-- in the list being leftmost. horizCat :: [Image] -> Image horizCat = foldr horizJoin EmptyImage --- | Compose any number of images vertically.+-- | Compose any number of images vertically, with the first in the list+-- being topmost. vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage --- | A Data.Text.Lazy value+-- | Make an 'Image' from a lazy text value. The text value should be+-- sanitized of escape sequences (ASCII 27) and carriage returns;+-- otherwise layout and attribute problems may result. text :: Attr -> TL.Text -> Image-text a txt-    | TL.length txt == 0 = EmptyImage-    | otherwise          = let displayWidth = safeWcswidth (TL.unpack txt)-                           in HorizText a txt displayWidth (fromIntegral $! TL.length txt)+text a txt = let displayWidth = safeWctlwidth txt+             in HorizText a txt displayWidth (fromIntegral $! TL.length txt) --- | A Data.Text value+-- | Make an 'Image' from a text value. The text value should be+-- sanitized of escape sequences (ASCII 27) and carriage returns;+-- otherwise layout and attribute problems may result. text' :: Attr -> T.Text -> Image-text' a txt-    | T.length txt == 0 = EmptyImage-    | otherwise         = let displayWidth = safeWcswidth (T.unpack txt)-                          in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)+text' a txt = let displayWidth = safeWctwidth txt+              in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) --- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in--- the ISO-10646 encoding.+-- | Make an image from a single character. This is a standard Haskell+-- 31-bit character assumed to be in the ISO-10646 encoding. char :: Attr -> Char -> Image char a c =     let displayWidth = safeWcwidth c     in HorizText a (TL.singleton c) displayWidth 1 --- | A string of characters layed out on a single row with the same display attribute. The string is--- assumed to be a sequence of ISO-10646 characters. +-- | Make an image from a string of characters laid out on a single+-- row with the same display attribute. The string is assumed to be a+-- sequence of ISO-10646 characters. The input string should be+-- sanitized of escape sequences (ASCII 27) and carriage returns;+-- otherwise layout and attribute problems may result. ----- Note: depending on how the Haskell compiler represents string literals a string literal in a--- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string. --- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry--- about the encoding format when outputting string literals. Just provide the string literal--- directly to iso10646String or string.--- +-- Note: depending on how the Haskell compiler represents string+-- literals, a string literal in a UTF-8 encoded source file, for+-- example, may be represented as a ISO-10646 string. That is, I think,+-- the case with GHC 6.10. This means, for the most part, you don't need+-- to worry about the encoding format when outputting string literals.+-- Just provide the string literal directly to iso10646String or string. iso10646String :: Attr -> String -> Image-iso10646String _ [] = EmptyImage iso10646String a str =     let displayWidth = safeWcswidth str     in HorizText a (TL.pack str) displayWidth (length str) --- | Alias for iso10646String. Since the usual case is that a literal string like "foo" is--- represented internally as a list of ISO 10646 31 bit characters.  +-- | Make an 'Image' from a 'String'. ----- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while--- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime--- representation.+-- This is an alias for iso10646String since the usual case is that a+-- literal string like "foo" is represented internally as a list of ISO+-- 10646 31 bit characters.+--+-- Note: Keep in mind that GHC will compile source encoded as UTF-8+-- but the literal strings, while UTF-8 encoded in the source, will be+-- transcoded to a ISO 10646 31 bit characters runtime representation. string :: Attr -> String -> Image string = iso10646String --- | A string of characters layed out on a single row. The input is assumed to be the bytes for--- UTF-8 encoded text.+-- | Make an 'Image' from a string of characters layed out on a single+-- row. The input is assumed to be the bytes for UTF-8 encoded text. utf8String :: Attr -> [Word8] -> Image utf8String a bytes = utf8Bytestring a (BL.pack bytes) --- | Renders a UTF-8 encoded lazy bytestring. +-- | Make an 'Image' from a UTF-8 encoded lazy bytestring. utf8Bytestring :: Attr -> BL.ByteString -> Image utf8Bytestring a bs = text a (TL.decodeUtf8 bs) --- | Renders a UTF-8 encoded strict bytestring. +-- | Make an 'Image' from a UTF-8 encoded strict bytestring. utf8Bytestring' :: Attr -> B.ByteString -> Image utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) --- | creates a fill of the specified character. The dimensions are in number of characters wide and--- number of rows high.-charFill :: Integral d => Attr -> Char -> d -> d -> Image-charFill _a _c 0  _h = EmptyImage-charFill _a _c _w 0  = EmptyImage-charFill a c w h =-    vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth-    where -        txt = TL.replicate (fromIntegral w) (TL.singleton c)-        displayWidth = safeWcwidth c * (fromIntegral w)-        charWidth = fromIntegral w+-- | Make an image filling a region with the specified character.+--+-- If either the width or height are less than or equal to 0, then+-- the result is the empty image.+charFill :: Integral d+         => Attr+         -- ^ The attribute to use.+         -> Char+         -- ^ The character to use in filling the region.+         -> d+         -- ^ The region width.+         -> d+         -- ^ The region height.+         -> Image+charFill a c w h+  | w <= 0 || h <= 0 = EmptyImage+  | otherwise        = vertCat+                     $ replicate (fromIntegral h)+                     $ HorizText a txt displayWidth charWidth+  where+    txt          = TL.replicate charWidth (TL.singleton c)+    displayWidth = safeWcwidth c * charWidth --- | The empty image. Useful for fold combinators. These occupy no space nor define any display--- attributes.-emptyImage :: Image +    charWidth   :: Num a => a+    charWidth    = fromIntegral w++-- | The empty image. Useful for fold combinators. These occupy no space+-- and do not affect display attributes.+emptyImage :: Image emptyImage = EmptyImage --- | pad the given image. This adds background character fills to the left, top, right, bottom.--- The pad values are how many display columns or rows to add.-pad :: Int -> Int -> Int -> Int -> Image -> Image+-- | Pad the given image. This adds background character fills to the+-- left, top, right, bottom.+pad :: Int+    -- ^ How much padding to add to the left side of the image.+    -> Int+    -- ^ How much padding to add to the top of the image.+    -> Int+    -- ^ How much padding to add to the right side of the image.+    -> Int+    -- ^ How much padding to add to the bottom of the image.+    -> Image+    -- ^ The image to pad.+    -> Image pad 0 0 0 0 i = i pad inL inT inR inB inImage     | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"     | otherwise = go inL inT inR inB inImage-        where -            -- TODO: uh.+        where             go 0 0 0 0 i = i             go 0 0 0 b i = VertJoin i (BGFill w b) w h                 where w = imageWidth  i@@ -184,40 +241,53 @@                 where w = imageWidth  i + l                       h = imageHeight i --- | translates an image by padding or cropping the left and top. First param is amount to translate--- left. Second param is amount to translate top.+-- | Translates an image by padding or cropping the left and top. ----- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than--- (0,0) will crop the image.-translate :: Int -> Int -> Image -> Image+-- If translation offsets are negative then the image is cropped.+translate :: Int+          -- ^ The horizontal translation offset (can be negative)+          -> Int+          -- ^ The vertical translation offset (can be negative)+          -> Image+          -- ^ The image to translate.+          -> Image translate x y i = translateX x (translateY y i) --- | translates an image by padding or cropping the left+-- | Translates an image by padding or cropping its left side. translateX :: Int -> Image -> Image translateX x i-    | x < 0     = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)+    | x < 0 && (abs x > imageWidth i) = emptyImage+    | x < 0     = cropLeft (imageWidth i + x) i     | x == 0    = i     | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h --- | translates an image by padding or cropping the top+-- | Translates an image by padding or cropping its top. translateY :: Int -> Image -> Image translateY y i-    | y < 0     = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)+    | y < 0 && (abs y > imageHeight i) = emptyImage+    | y < 0     = cropTop (imageHeight i + y) i     | y == 0    = i     | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) --- | Ensure an image is no larger than the provided size. If the image is larger then crop the right--- or bottom.+-- | Ensure an image is no larger than the provided size. If the image+-- is larger then crop the right or bottom. ----- This is transformed to a vertical crop from the bottom followed by horizontal crop from the--- right.-crop :: Int -> Int -> Image -> Image+-- This is equivalent to a vertical crop from the bottom followed by+-- horizontal crop from the right.+crop :: Int+     -- ^ Cropping width+     -> Int+     -- ^ Cropping height+     -> Image+     -- ^ The image to crop+     -> Image crop 0 _ _ = EmptyImage crop _ 0 _ = EmptyImage crop w h i = cropBottom h (cropRight w i) --- | crop the display height. If the image is less than or equal in height then this operation has--- no effect. Otherwise the image is cropped from the bottom.+-- | Crop an image's height. If the image's height is less than or equal+-- to the specified height then this operation has no effect. Otherwise+-- the image is cropped from the bottom. cropBottom :: Int -> Image -> Image cropBottom 0 _ = EmptyImage cropBottom h inI@@ -225,15 +295,15 @@     | otherwise = go inI         where             go EmptyImage = EmptyImage-            go i@(CropBottom {croppedImage, outputWidth, outputHeight})-                | outputHeight <= h = i-                | otherwise          = CropBottom croppedImage outputWidth h+            go i@(Crop {outputHeight})+                = i {outputHeight = min h outputHeight}             go i                 | h >= imageHeight i = i-                | otherwise           = CropBottom i (imageWidth i) h+                | otherwise = Crop i 0 0 (imageWidth i) h --- | ensure the image is no wider than the given width. If the image is wider then crop the right--- side.+-- | Crop an image's width. If the image's width is less than or equal+-- to the specified width then this operation has no effect. Otherwise+-- the image is cropped from the right. cropRight :: Int -> Image -> Image cropRight 0 _ = EmptyImage cropRight w inI@@ -241,15 +311,15 @@     | otherwise = go inI         where             go EmptyImage = EmptyImage-            go i@(CropRight {croppedImage, outputWidth, outputHeight})-                | outputWidth <= w = i-                | otherwise         = CropRight croppedImage w outputHeight+            go i@(Crop {outputWidth})+                = i {outputWidth = min w outputWidth}             go i                 | w >= imageWidth i = i-                | otherwise          = CropRight i w (imageHeight i)+                | otherwise = Crop i 0 0 w (imageHeight i) --- | ensure the image is no wider than the given width. If the image is wider then crop the left--- side.+-- | Crop an image's width. If the image's width is less than or equal+-- to the specified width then this operation has no effect. Otherwise+-- the image is cropped from the left. cropLeft :: Int -> Image -> Image cropLeft 0 _ = EmptyImage cropLeft w inI@@ -257,17 +327,17 @@     | otherwise = go inI         where             go EmptyImage = EmptyImage-            go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})-                | outputWidth <= w = i-                | otherwise         =-                    let leftSkip' = leftSkip + outputWidth - w-                    in CropLeft croppedImage leftSkip' w outputHeight+            go i@(Crop {leftSkip, outputWidth}) =+                let delta = max 0 (outputWidth - w)+                in i { leftSkip = leftSkip + delta+                     , outputWidth = outputWidth - delta }             go i                 | imageWidth i <= w = i-                | otherwise          = CropLeft i (imageWidth i - w) w (imageHeight i)+                | otherwise = Crop i (imageWidth i - w) 0 w (imageHeight i) --- | crop the display height. If the image is less than or equal in height then this operation has--- no effect. Otherwise the image is cropped from the top.+-- | Crop an image's height. If the image's height is less than or equal+-- to the specified height then this operation has no effect. Otherwise+-- the image is cropped from the top. cropTop :: Int -> Image -> Image cropTop 0 _ = EmptyImage cropTop h inI@@ -275,33 +345,32 @@     | otherwise = go inI         where             go EmptyImage = EmptyImage-            go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight})-                | outputHeight <= h = i-                | otherwise         =-                    let topSkip' = topSkip + outputHeight - h-                    in CropTop croppedImage topSkip' outputWidth h+            go i@(Crop {topSkip, outputHeight}) =+                let delta = max 0 (outputHeight - h)+                in i { topSkip = topSkip + delta+                     , outputHeight = outputHeight - delta }             go i                 | imageHeight i <= h = i-                | otherwise          = CropTop i (imageHeight i - h) (imageWidth i) h+                | otherwise = Crop i 0 (imageHeight i - h) (imageWidth i) h --- | Generic resize. Pads and crops as required to assure the given display width and height.--- This is biased to pad/crop the right and bottom.+-- | Generic resize. Pads and crops are added to ensure that the+-- resulting image matches the specified dimensions. This is biased to+-- pad/crop the right and bottom. resize :: Int -> Int -> Image -> Image resize w h i = resizeHeight h (resizeWidth w i) --- | Resize the width. Pads and crops as required to assure the given display width.--- This is biased to pad/crop the right.+-- | Resize the width. Pads and crops as required to assure the given+-- display width. This is biased to pad/crop on the right. resizeWidth :: Int -> Image -> Image resizeWidth w i = case w `compare` imageWidth i of     LT -> cropRight w i     EQ -> i     GT -> i <|> BGFill (w - imageWidth i) (imageHeight i) --- | Resize the height. Pads and crops as required to assure the given display height.--- This is biased to pad/crop the bottom.+-- | Resize the height. Pads and crops as required to assure the given+-- display height. This is biased to pad/crop on the bottom. resizeHeight :: Int -> Image -> Image resizeHeight h i = case h `compare` imageHeight i of     LT -> cropBottom h i     EQ -> i     GT -> i <-> BGFill (imageWidth i) (h - imageHeight i)-
src/Graphics/Vty/Image/Internal.hs view
@@ -1,55 +1,51 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} -#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif+module Graphics.Vty.Image.Internal+  ( Image(..)+  , imageHeight+  , imageWidth+  , horizJoin+  , vertJoin -module Graphics.Vty.Image.Internal where+  , ppImageStructure+  , clipText+  )+where  import Graphics.Vty.Attributes import Graphics.Text.Width -import Control.DeepSeq+import GHC.Generics -import qualified Data.Text.Lazy as TL+import Control.DeepSeq -#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..)) #endif---- | A display text is a Data.Text.Lazy------ TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each--- application probably uses a single type. Perhaps parameterize the entire vty interface by the--- input text type?--- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance--- for the usual case of appending a bunch of characters with the same attribute together.-type DisplayText = TL.Text+import qualified Data.Text.Lazy as TL --- TODO: store a skip list in HorizText(?)--- TODO: represent display strings containing chars that are not 1 column chars as a separate--- display string value?-clipText :: DisplayText -> Int -> Int -> DisplayText+clipText :: TL.Text -> Int -> Int -> TL.Text clipText txt leftSkip rightClip =     -- CPS would clarify this I think     let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0         txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt         (toTake,padSuffix) = clipForCharWidth rightClip txt' 0         txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)-        clipForCharWidth 0 _ n = (n, False)+        -- Note: some characters and zero-width and combining characters+        -- combine to the left, so keep taking characters even if the+        -- width is zero.         clipForCharWidth w t n             | TL.null t = (n, False)-            | w <  cw = (n, True)-            | w == cw = (n+1, False)-            | w >  cw = clipForCharWidth (w - cw) (TL.tail t) (n + 1)+            | w < cw    = (n, w /= 0)+            | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1)             where cw = safeWcwidth (TL.head t)-        clipForCharWidth _ _ _ = error "clipForCharWidth applied to undefined"     in txt'' --- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to--- create instances.+-- | This is the internal representation of Images. Use the constructors+-- in "Graphics.Vty.Image" to create instances. -- -- Images are: --@@ -62,114 +58,72 @@ -- * a cropped image -- -- * an empty image of no size or content.-data Image = -    -- | A horizontal text span is always >= 1 column and has a row height of 1.+data Image =+    -- | A horizontal text span has a row height of 1.       HorizText       { attr :: Attr-      -- | The text to display. The display width of the text is always outputWidth.-      , displayText :: DisplayText-      -- | The number of display columns for the text. Always > 0.+      -- | The text to display. The display width of the text is always+      -- outputWidth.+      , displayText :: TL.Text+      -- | The number of display columns for the text.       , outputWidth :: Int-      -- | the number of characters in the text. Always > 0.+      -- | the number of characters in the text.       , charWidth :: Int       }-    -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is-    -- required to be between two images of equal height. The horizJoin constructor adds background-    -- fills to the provided images that assure this is true for the HorizJoin value produced.+    -- | A horizontal join can be constructed between any two images.+    -- However a HorizJoin instance is required to be between two images+    -- of equal height. The horizJoin constructor adds background fills+    -- to the provided images that assure this is true for the HorizJoin+    -- value produced.     | HorizJoin-      { partLeft :: Image +      { partLeft :: Image       , partRight :: Image-      , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 1-      , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0+      , outputWidth :: Int+      -- ^ imageWidth partLeft == imageWidth partRight. Always > 0+      , outputHeight :: Int+      -- ^ imageHeight partLeft == imageHeight partRight. Always > 0       }-    -- | A veritical join can be constructed between any two images. However a VertJoin instance is-    -- required to be between two images of equal width. The vertJoin constructor adds background-    -- fills to the provides images that assure this is true for the VertJoin value produced.+    -- | A veritical join can be constructed between any two images.+    -- However a VertJoin instance is required to be between two images+    -- of equal width. The vertJoin constructor adds background fills+    -- to the provides images that assure this is true for the VertJoin+    -- value produced.     | VertJoin       { partTop :: Image       , partBottom :: Image-      , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0-      , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1+      , outputWidth :: Int+      -- ^ imageWidth partTop == imageWidth partBottom. always > 0+      , outputHeight :: Int+      -- ^ imageHeight partTop == imageHeight partBottom. always > 1       }-    -- | A background fill will be filled with the background char. The background char is-    -- defined as a property of the Picture this Image is used to form.+    -- | A background fill will be filled with the background char. The+    -- background char is defined as a property of the Picture this+    -- Image is used to form.     | BGFill       { outputWidth :: Int -- ^ always > 0       , outputHeight :: Int -- ^ always > 0       }-    -- | Crop an image horizontally to a size by reducing the size from the right.-    | CropRight-      { croppedImage :: Image-      -- | Always < imageWidth croppedImage > 0-      , outputWidth :: Int-      , outputHeight :: Int -- ^ imageHeight croppedImage-      }-    -- | Crop an image horizontally to a size by reducing the size from the left.-    | CropLeft+    -- | Crop an image+    | Crop       { croppedImage :: Image-      -- | Always < imageWidth croppedImage > 0       , leftSkip :: Int-      -- | Always < imageWidth croppedImage > 0-      , outputWidth :: Int-      , outputHeight :: Int-      }-    -- | Crop an image vertically to a size by reducing the size from the bottom-    | CropBottom-      { croppedImage :: Image-      -- | imageWidth croppedImage-      , outputWidth :: Int-      -- | height image is cropped to. Always < imageHeight croppedImage > 0-      , outputHeight :: Int-      }-    -- | Crop an image vertically to a size by reducing the size from the top-    | CropTop-      { croppedImage :: Image-      -- | Always < imageHeight croppedImage > 0       , topSkip :: Int-      -- | imageWidth croppedImage       , outputWidth :: Int-      -- | Always < imageHeight croppedImage > 0       , outputHeight :: Int       }     -- | The empty image     ---    -- The combining operators identity constant. +    -- The combining operators identity constant.     -- EmptyImage <|> a = a     -- EmptyImage <-> a = a-    -- +    --     -- Any image of zero size equals the empty image.     | EmptyImage-    deriving Eq--instance Show Image where-    show ( HorizText { attr, displayText, outputWidth, charWidth } )-        = "HorizText " ++ show displayText-                       ++ "@(" ++ show attr ++ ","-                               ++ show outputWidth ++ ","-                               ++ show charWidth ++ ")"-    show ( BGFill { outputWidth, outputHeight } )-        = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"-    show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )-        = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"-    show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )-        = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"-    show ( CropRight { croppedImage, outputWidth, outputHeight } )-        = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"-                     ++ " (" ++ show croppedImage ++ ")"-    show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )-        = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"-                    ++ " (" ++ show croppedImage ++ ")"-    show ( CropBottom { croppedImage, outputWidth, outputHeight } )-        = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"-                      ++ " (" ++ show croppedImage ++ ")"-    show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )-        = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"-                   ++ " (" ++ show croppedImage ++ ")"-    show ( EmptyImage ) = "EmptyImage"+    deriving (Eq, Generic, Show, Read)  -- | pretty print just the structure of an image. ppImageStructure :: Image -> String-ppImageStructure inImg = go 0 inImg+ppImageStructure = go 0     where         go indent img = tab indent ++ pp indent img         tab indent = concat $ replicate indent "  "@@ -182,76 +136,65 @@             = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n"               ++ go (i+1) t ++ "\n"               ++ go (i+1) b-        pp i (CropRight {croppedImage, outputWidth, outputHeight})-            = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"-              ++ go (i+1) croppedImage-        pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})-            = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"-              ++ go (i+1) croppedImage-        pp i (CropBottom {croppedImage, outputWidth, outputHeight})-            = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"-              ++ go (i+1) croppedImage-        pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight})-            = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n"+        pp i (Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight})+            = "Crop(" ++ show leftSkip ++ "," ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"               ++ go (i+1) croppedImage         pp _ EmptyImage = "EmptyImage"-        + instance NFData Image where     rnf EmptyImage = ()-    rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()-    rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` ()-    rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` ()-    rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` ()+    rnf (Crop i x y w h) = i `deepseq` x `seq` y `seq` w `seq` h `seq` ()     rnf (BGFill w h) = w `seq` h `seq` ()     rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` ()     rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()     rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` () --- | The width of an Image. This is the number display columns the image will occupy.+-- | The width of an Image. This is the number display columns the image+-- will occupy. imageWidth :: Image -> Int imageWidth HorizText { outputWidth = w } = w imageWidth HorizJoin { outputWidth = w } = w imageWidth VertJoin { outputWidth = w } = w imageWidth BGFill { outputWidth = w } = w-imageWidth CropRight { outputWidth  = w } = w-imageWidth CropLeft { outputWidth  = w } = w-imageWidth CropBottom { outputWidth = w } = w-imageWidth CropTop { outputWidth = w } = w+imageWidth Crop { outputWidth = w } = w imageWidth EmptyImage = 0 --- | The height of an Image. This is the number of display rows the image will occupy.+-- | The height of an Image. This is the number of display rows the+-- image will occupy. imageHeight :: Image -> Int imageHeight HorizText {} = 1 imageHeight HorizJoin { outputHeight = h } = h imageHeight VertJoin { outputHeight = h } = h imageHeight BGFill { outputHeight = h } = h-imageHeight CropRight { outputHeight  = h } = h-imageHeight CropLeft { outputHeight  = h } = h-imageHeight CropBottom { outputHeight = h } = h-imageHeight CropTop { outputHeight = h } = h+imageHeight Crop { outputHeight = h } = h imageHeight EmptyImage = 0 --- | Append in the Monoid instance is equivalent to <->. +-- | Append in the 'Semigroup' instance is equivalent to '<->'.+instance Semigroup Image where+    (<>) = vertJoin++-- | Append in the 'Monoid' instance is equivalent to '<->'. instance Monoid Image where     mempty = EmptyImage-    mappend = vertJoin+#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif  -- | combines two images side by side ----- Combines text chunks where possible. Assures outputWidth and outputHeight properties are not--- violated.------ The result image will have a width equal to the sum of the two images width.  And the height will--- equal the largest height of the two images.  The area not defined in one image due to a height--- missmatch will be filled with the background pattern.+-- Combines text chunks where possible. Assures outputWidth and+-- outputHeight properties are not violated. ----- TODO: the bg fill is biased towards top to bottom languages(?)+-- The result image will have a width equal to the sum of the two images+-- width. And the height will equal the largest height of the two+-- images. The area not defined in one image due to a height mismatch+-- will be filled with the background pattern. horizJoin :: Image -> Image -> Image horizJoin EmptyImage i          = i horizJoin i          EmptyImage = i horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1)     | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1)-    -- TODO: assumes horiz text height is always 1+    -- assumes horiz text height is always 1     | otherwise  = HorizJoin i0 i1 (w0 + w1) 1 horizJoin i0 i1     -- If the images are of the same height then no padding is required@@ -273,19 +216,19 @@  -- | combines two images vertically ----- The result image will have a height equal to the sum of the heights of both images.--- The width will equal the largest width of the two images.--- The area not defined in one image due to a width missmatch will be filled with the background--- pattern.------ TODO: the bg fill is biased towards right to left languages(?)+-- The result image will have a height equal to the sum of the heights+-- of both images. The width will equal the largest width of the two+-- images. The area not defined in one image due to a width mismatch+-- will be filled with the background pattern. vertJoin :: Image -> Image -> Image vertJoin EmptyImage i          = i vertJoin i          EmptyImage = i vertJoin i0 i1-    -- If the images are of the same width then no background padding is required+    -- If the images are of the same width then no background padding is+    -- required     | w0 == w1 = VertJoin i0 i1 w0 h-    -- Otherwise one of the images needs to be padded to the size of the other image.+    -- Otherwise one of the images needs to be padded to the size of the+    -- other image.     | w0 < w1         = let padAmount = w1 - w0           in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h@@ -299,4 +242,3 @@         h1 = imageHeight i1         h   = h0 + h1 vertJoin _ _ = error "vertJoin applied to undefined values."-
src/Graphics/Vty/Inline.hs view
@@ -1,45 +1,39 @@--- | The inline module provides a limited interface to changing the style of terminal output. The--- intention is for this interface to be used inline with other output systems. +-- | The inline module provides a limited interface to changing the+-- style of terminal output. The intention is for this interface to be+-- used inline with other output systems. ----- The changes specified by the InlineM monad are applied to the terminals display attributes. These--- display attributes effect the display of all following text output to the terminal file--- descriptor.+-- The changes specified by the InlineM monad are applied to the+-- terminal's display attributes. These display attributes affect the+-- display of all following text output to the terminal file descriptor. ----- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the--- text \" Styled! \" drawn over a red background and underlined.+-- For example, in an IO monad the following code will print the text+-- \"Not styled. \" Followed by the text \" Styled! \" drawn over a red+-- background and underlined. -- -- @ --      putStr \"Not styled. \" --      putAttrChange_ $ do---          backColor red +--          backColor red --          applyStyle underline --      putStr \" Styled! \" --      putAttrChange_ $ defaultAll --      putStrLn \"Not styled.\" -- @ ----- 'putAttrChange' outputs the control codes to the terminal device 'Handle'. This is a duplicate--- of the 'stdout' handle when the 'terminalHandle' was (first) acquired. If 'stdout' has since been--- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than--- 'putAttrChange'+-- 'putAttrChange' emits the control codes to the terminal device+-- attached to 'Handle'. This is a duplicate of the 'stdout' handle when+-- the 'terminalHandle' was (first) acquired. If 'stdout' has since been+-- changed then 'putStr', 'putStrLn', 'print' etc. will output to a+-- different 'Handle' than 'putAttrChange'. -- -- Copyright 2009-2010 Corey O'Connor-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif--module Graphics.Vty.Inline ( module Graphics.Vty.Inline-                           , withVty-                           )-    where+module Graphics.Vty.Inline+  ( module Graphics.Vty.Inline+  )+where  import Graphics.Vty import Graphics.Vty.DisplayAttributes-import Graphics.Vty.Inline.Unsafe-import Graphics.Vty.Output.Interface  import Blaze.ByteString.Builder (writeToByteString) @@ -50,44 +44,55 @@  import System.IO -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-import Data.Monoid ( mappend )-#endif+type InlineM v = State InlineState v -type InlineM v = State Attr v+data InlineState =+    InlineState { inlineAttr :: Attr+                , inlineUrlsEnabled :: Bool+                } --- | Set the background color to the provided 'Color'+-- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM ()-backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )+backColor c = modify $ \s ->+    s { inlineAttr = inlineAttr s `withBackColor` c+      } --- | Set the foreground color to the provided 'Color'+-- | Set the foreground color to the provided 'Color'. foreColor :: Color -> InlineM ()-foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )+foreColor c = modify $ \s ->+    s { inlineAttr = inlineAttr s `withForeColor` c+      } --- | Attempt to change the 'Style' of the following text.+-- | Attempt to change the 'Style' of the following text.. ----- If the terminal does not support the style change no error is produced. The style can still be--- removed.+-- If the terminal does not support the style change then no error is+-- produced. The style can still be removed. applyStyle :: Style -> InlineM ()-applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )+applyStyle st = modify $ \s ->+    s { inlineAttr = inlineAttr s `withStyle` st+      } --- | Attempt to remove the specified 'Style' from the display of the following text.+-- | Attempt to remove the specified 'Style' from the display of the+-- following text. ----- This will fail if applyStyle for the given style has not been previously called. +-- This will fail if 'applyStyle' for the given style has not been+-- previously called. removeStyle :: Style -> InlineM ()-removeStyle sMask = modify $ \attr -> -    let style' = case attrStyle attr of-                    Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."-                    KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."-                    SetTo s -> s .&. complement sMask-    in attr { attrStyle = SetTo style' } +removeStyle sMask = modify $ \s ->+    s { inlineAttr =+          let style' = case attrStyle (inlineAttr s) of+                Default -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."+                KeepCurrent -> error "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."+                SetTo st -> st .&. complement sMask+          in (inlineAttr s) { attrStyle = SetTo style' }+      } --- | Reset the display attributes+-- | Reset the display attributes. defaultAll :: InlineM ()-defaultAll = put defAttr+defaultAll = modify $ \s -> s { inlineAttr = defAttr } --- | Apply the provided display attribute changes to the given terminal output device.+-- | Apply the provided display attribute changes to the given terminal+-- output device. -- -- This does not flush the terminal. putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()@@ -97,23 +102,23 @@     mfattr <- prevFattr <$> readIORef (assumedStateRef out)     fattr <- case mfattr of                 Nothing -> do-                    liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc-                    return $ FixedAttr defaultStyleMask Nothing Nothing+                    liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc False+                    return $ FixedAttr defaultStyleMask Nothing Nothing Nothing                 Just v -> return v-    let attr = execState c currentAttr+    let InlineState attr urlsEnabled = execState c (InlineState currentAttr False)         attr' = limitAttrForDisplay out attr         fattr' = fixDisplayAttr fattr attr'         diffs = displayAttrDiffs fattr fattr'-    outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs+    outputByteBuffer out $ writeToByteString $ writeSetAttr dc urlsEnabled fattr attr' diffs     modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }     inlineHack dc --- | Apply the provided display attributes changes to the terminal output device that was current at--- the time this was first used. Which, for most use cases, is the current terminal.+-- | Apply the provided display attributes changes to the terminal+-- output device. -- -- This will flush the terminal output.-putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()-putAttrChange_ c = liftIO $ withOutput $ \out -> do+putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()+putAttrChange_ out c = liftIO $ do     hFlush stdout     putAttrChange out c     hFlush stdout
− src/Graphics/Vty/Inline/Unsafe.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif--module Graphics.Vty.Inline.Unsafe where--import Graphics.Vty--import Data.Default-import Data.Monoid-import Data.IORef--import GHC.IO.Handle (hDuplicate)--import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering))--import System.IO.Unsafe--import System.Posix.IO (handleToFd)--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif--globalVty :: IORef (Maybe Vty)-{-# NOINLINE globalVty #-}-globalVty = unsafePerformIO $ newIORef Nothing--globalOutput :: IORef (Maybe Output)-{-# NOINLINE globalOutput #-}-globalOutput = unsafePerformIO $ newIORef Nothing--mkDupeConfig :: IO Config-mkDupeConfig = do-    hSetBuffering stdout NoBuffering-    hSetBuffering stdin NoBuffering-    stdinDupe <- hDuplicate stdin >>= handleToFd-    stdoutDupe <- hDuplicate stdout >>= handleToFd-    return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }---- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.--- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'.------ This instance will use duplicates of the stdin and stdout Handles.-withVty :: (Vty -> IO b) -> IO b-withVty f = do-    mvty <- readIORef globalVty-    vty <- case mvty of-        Nothing -> do-            vty <- mkDupeConfig >>= mkVty-            writeIORef globalVty (Just vty)-            return vty-        Just vty -> return vty-    f vty--withOutput :: (Output -> IO b) -> IO b-withOutput f = do-    mout <- readIORef globalOutput-    out <- case mout of-        Nothing -> do-            config <- mappend <$> userConfig <*> mkDupeConfig-            out <- outputForConfig config-            writeIORef globalOutput (Just out)-            return out-        Just out -> return out-    f out
src/Graphics/Vty/Input.hs view
@@ -1,206 +1,32 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif---- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can--- then be used to read 'Event's from the terminal.------ The history of terminals has resulted in a broken input process. Some keys and combinations will--- not reliably map to the expected events by any terminal program. Even those not using vty. There--- is no 1:1 mapping from key events to bytes read from the terminal input device. In very limited--- cases the terminal and vty's input process can be customized to resolve these issues.------ See "Graphics.Vty.Config" for how to configure vty's input processing. Customizing terminfo and--- the terminal is beyond the scope of this documentation.------ = VTY's Implementation------ One can get the brain rot trying to understand all this. So, as far as I can care...------ There are two input modes:------  1. 7 bit------  2. 8 bit------ 7 bit input is the default and the expected in most use cases. This is what vty uses.------ == 7 bit input encoding------ Control key combinations are represented by masking the two high bits of the 7bit input.  Back in--- the day the control key actually grounded the two high bit wires: 6 and 7. This is why--- control key combos map to single character events: The input bytes are identical. The input byte--- is the bit encoding of the character with bits 6 and 7 masked.  Bit 6 is set by shift. Bit 6 and--- 7 are masked by control. EG:------ * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become `00001001`. Which is the ASCII--- and UTF-8 encoding of the tab key.------ * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero which makes `0000011` and--- is the "End of Text" code.------ * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This is the value 1 with bit 7--- set and 6 unset.------ * Hypothesis: Bit 6 is unset by upper case letters because, initially, there were only upper case--- letters used and a 5 bit encoding.------ == 8 bit encoding------ The 8th bit was originally used for parity checking. Useless for emulators. Some terminal--- emulators support a 8 bit input encoding. While this provides some advantages the actual usage is--- low. Most systems use 7bit mode but recognize 8bit control characters when escaped. This is what--- vty does.------ == Escaped Control Keys------ Using 7 bit input encoding the @ESC@ byte can signal the start of an encoded control key. To--- differentiate a single @ESC@ eventfrom a control key the timing of the input is used.------ 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'.------ 2. control keys that contain @ESC@ in their encoding: The @ESC byte; followed by more bytes read--- within 'singleEscPeriod'. All bytes up until the next valid input block are passed to the--- classifier.------ If the current runtime is the threaded runtime then the terminal's @VMIN@ and @VTIME@ behavior--- reliably implement the above rules.  If the current runtime does not support forkOS then there is--- currently no implementation.------ Vty used to emulate @VMIN@ and @VTIME@. This was a input loop which did tricky things with--- non-blocking reads and timers. The implementation was not reliable. A reliable implementation is--- possible, but there are no plans to implement this.------ == Unicode Input and Escaped Control Key Sequences------ The input encoding determines how UTF-8 encoded characters are recognize.------ * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is a superset of ASCII. UTF-8 does--- not overlap escaped control key sequences. However, the escape key must be differentiated from--- escaped control key sequences by the timing of the input bytes.------ * 8 bit mode: UTF-8 cannot be input unambiguously. This does not require using the timing of--- input bytes to differentiate the escape key. Many terminals do not support 8 bit mode.------ == Terminfo------ The terminfo system is used to determine how some keys are encoded. Terminfo is incomplete. In--- some cases terminfo is incorrect. Vty assumes terminfo is correct but provides a mechanism to--- override terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'.------ == Terminal Input is Broken------ Clearly terminal input has fundemental issues. There is no easy way to reliably resolve these--- issues.------ One resolution would be to ditch standard terminal interfaces entirely and just go directly to--- scancodes. A reasonable option for vty if everybody used the linux kernel console. I hear GUIs--- are popular these days. Sadly, GUI terminal emulators don't provide access to scancodes AFAIK.------ All is lost? Not really. "Graphics.Vty.Config" supports customizing the input byte to event--- mapping and xterm supports customizing the scancode to input byte mapping. With a lot of work a--- user's system can be set up to encode all the key combos in an almost-sane manner.------ There are other tricky work arounds that can be done. I have no interest in implementing most of--- these. They are not really worth the time.------ == Terminal Output is Also Broken------ This isn't the only odd aspect of terminals due to historical aspects that no longer apply. EG:--- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes--- the control sequence to output red, for instance) This is to account for the slow speed of--- hardcopy teletype interfaces. Cause, uh, we totally still use those.--- --- The output encoding of colors and attributes are also rife with issues.------ == See also------ * http://www.leonerd.org.uk/hacks/fixterms/------ In my experience this cannot resolve the issues without changes to the terminal emulator and--- device.-module Graphics.Vty.Input ( Key(..)-                          , Modifier(..)-                          , Button(..)-                          , Event(..)-                          , Input(..)-                          , inputForConfig-                          )-    where+-- | This module provides the input abstraction for Vty.+module Graphics.Vty.Input+  ( Input(..)+  , module Graphics.Vty.Input.Events+  )+where -import Graphics.Vty.Config import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Loop-import Graphics.Vty.Input.Terminfo--import Control.Concurrent.STM-import Lens.Micro--import qualified System.Console.Terminfo as Terminfo-import System.Posix.Signals.Exts--#if !(MIN_VERSION_base(4,8,0))-import Data.Functor ((<$>))-import Data.Monoid-#else-import Data.Monoid ((<>))-#endif+import Control.Concurrent.STM (TChan) --- | Set up the terminal with file descriptor `inputFd` for input.  Returns a 'Input'.------ The table used to determine the 'Events' to produce for the input bytes comes from--- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from--- 'inputMap'.------ The terminal device is configured with the attributes:------ * IXON disabled---      - disables software flow control on outgoing data. This stops the process from being---        suspended if the output terminal cannot keep up. I presume this has little effect these---        days. I hope this means that output will be buffered if the terminal cannot keep up. In the---        old days the output might of been dropped?--- --- "raw" mode is used for input.------ * ISIG disabled---      - enables keyboard combinations that result in signals. TODO: should probably be a dynamic---      option.------ * ECHO disabled---      - input is not echod to the output. TODO: should be a dynamic option.------ * ICANON disabled---      - canonical mode (line mode) input is not used. TODO: should be a dynamic option.------ * IEXTEN disabled---      - extended functions are disabled. TODO: I don't know what those are.----inputForConfig :: Config -> IO Input-inputForConfig config@Config{ termName = Just termName-                            , inputFd = Just termFd-                            , vmin = Just _-                            , vtime = Just _-                            , .. } = do-    terminal <- Terminfo.setupTerm termName-    let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]-        activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides-    (setAttrs,unsetAttrs) <- attributeControl termFd-    setAttrs-    input <- initInput config activeInputMap-    let pokeIO = Catch $ do-            let e = error "vty internal failure: this value should not propagate to users"-            setAttrs-            atomically $ writeTChan (input^.eventChannel) (EvResize e e)-    _ <- installHandler windowChange pokeIO Nothing-    _ <- installHandler continueProcess pokeIO Nothing-    return $ input-        { shutdownInput = do-            shutdownInput input-            _ <- installHandler windowChange Ignore Nothing-            _ <- installHandler continueProcess Ignore Nothing-            unsetAttrs-        }-inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig+-- | The library's input-processing abstraction. Platform-specific+-- implementations must implement an 'Input' and provide it to+-- 'Graphics.Vty.mkVtyFromPair'.+data Input =+    Input { eventChannel :: TChan InternalEvent+          -- ^ A channel of events generated by input processing. The+          -- input implementation must write its input events to this+          -- channel; the Vty event loop will read from this channel+          -- and provide the events to the user's application via+          -- 'nextEvent'.+          , shutdownInput :: IO ()+          -- ^ Shut down the input processing. As part of shutting down+          -- the input, this should also restore the input state if+          -- appropriate.+          , restoreInputState :: IO ()+          -- ^ Restore the terminal's input state to what it was prior+          -- to configuring the input for Vty. This should be done as+          -- part of 'shutdownInput' but is exposed in case it needs to+          -- be used directly.+          , inputLogMsg :: String -> IO ()+          -- ^ Log the specified message.+          }
− src/Graphics/Vty/Input/Classify.hs 
@@ -1,84 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- This makes a kind of tri. Has space efficiency issues with large input blocks.--- Likely building a parser and just applying that would be better.--- I did not write this so I might just rewrite it for better understanding. Which is not the best--- of reasons.--- TODO: measure and rewrite if required.--- TODO: The ClassifyMap interface requires this code to always assure later entries override--- earlier.-module Graphics.Vty.Input.Classify-    ( classify-    , KClass(..)-    ) where--import Graphics.Vty.Input.Events--import Codec.Binary.UTF8.Generic (decode)--import Data.List(inits)-import qualified Data.Map as M( fromList, lookup )-import Data.Maybe ( mapMaybe )-import qualified Data.Set as S( fromList, member )--import Data.Char-import Data.Word--data KClass-    = Valid Event [Char]-    | Invalid-    | Prefix-    deriving(Show, Eq)--compile :: ClassifyMap -> [Char] -> KClass-compile table = cl' where-    -- take all prefixes and create a set of these-    prefixSet = S.fromList $ concatMap (init . inits . fst) $ table-    maxValidInputLength = maximum (map (length . fst) table)-    eventForInput = M.fromList table-    cl' [] = Prefix-    cl' inputBlock = case M.lookup inputBlock eventForInput of-            -- if the inputBlock is exactly what is expected for an event then consume the whole-            -- block and return the event-            Just e -> Valid e []-            Nothing -> case S.member inputBlock prefixSet of-                True -> Prefix-                -- look up progressively smaller tails of the input block until an event is found-                -- The assumption is that the event that consumes the most input bytes should be-                -- produced.-                -- The test verifyFullSynInputToEvent2x verifies this.-                -- H: There will always be one match. The prefixSet contains, by definition, all-                -- prefixes of an event. -                False ->-                    let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock-                    in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of-                        (s,e) : _ -> Valid e (drop (length s) inputBlock)-                        -- neither a prefix or a full event.-                        -- TODO: debug log-                        [] -> Invalid--classify :: ClassifyMap -> [Char] -> KClass-classify table =-    let standardClassifier = compile table-    in \s -> case s of-        c:cs | ord c >= 0xC2 -> classifyUtf8 c cs-        _                    -> standardClassifier s--classifyUtf8 :: Char -> [Char] -> KClass-classifyUtf8 c cs =-  let n = utf8Length (ord c)-      (codepoint,rest) = splitAt n (c:cs)--      codepoint8 :: [Word8]-      codepoint8 = map (fromIntegral . ord) codepoint--  in case decode codepoint8 of-       _ | n < length codepoint -> Prefix-       Just (unicodeChar, _)    -> Valid (EvKey (KChar unicodeChar) []) rest-       Nothing                  -> Invalid -- something bad happened; just ignore and continue.--utf8Length :: (Num t, Ord a, Num a) => a -> t-utf8Length c-    | c < 0x80 = 1-    | c < 0xE0 = 2-    | c < 0xF0 = 3-    | otherwise = 4
src/Graphics/Vty/Input/Events.hs view
@@ -1,41 +1,100 @@-module Graphics.Vty.Input.Events where+{-# Language DeriveGeneric #-}+{-# Language StrictData #-}+module Graphics.Vty.Input.Events+  ( Key(..)+  , Modifier(..)+  , Event(..)+  , Button(..)+  , ClassifyMap+  , InternalEvent(..)+  )+where +import Control.DeepSeq+import Data.ByteString+import GHC.Generics+ -- | Representations of non-modifier keys. ----- * KFun is indexed from 0 to 63. Range of supported FKeys varies by terminal and keyboard.+-- * KFun is indexed from 0 to 63. Range of supported FKeys varies by+-- terminal and keyboard. ----- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by terminal and keyboard.+-- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by+-- terminal and keyboard. ----- * Actually, support for most of these but KEsc, KChar, KBS, and KEnter vary by terminal and--- keyboard.-data Key = KEsc  | KChar Char | KBS | KEnter+-- * Actually, support for most of these but KEsc, KChar, KBS, and+-- KEnter vary by terminal and keyboard.+data Key = KEsc  | KChar {-# UNPACK #-} Char | KBS | KEnter          | KLeft | KRight | KUp | KDown          | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter-         | KFun Int | KBackTab | KPrtScr | KPause | KIns+         | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns          | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu-    deriving (Eq,Show,Read,Ord)+    deriving (Eq, Show, Read, Ord, Generic) --- | Modifier keys.  Key codes are interpreted such that users are more likely to--- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will--- generally correspond to the physical Alt key.+instance NFData Key++-- | Modifier keys. Key codes are interpreted such that users are more+-- likely to have Meta than Alt; for instance on the PC Linux console,+-- 'MMeta' will generally correspond to the physical Alt key. data Modifier = MShift | MCtrl | MMeta | MAlt-    deriving (Eq,Show,Read,Ord)+    deriving (Eq, Show, Read, Ord, Generic) +instance NFData Modifier+ -- | Mouse buttons.------ \todo not supported.-data Button = BLeft | BMiddle | BRight-    deriving (Eq,Show,Ord)+data Button+    = BLeft+    | BMiddle+    | BRight+    | BScrollUp+    | BScrollDown+    | BScrollLeft+    -- ^ Some terminals (e.g., Kitty, Alacritty) support horizontal+    -- scrolling in addition to vertical scrolling.+    | BScrollRight+    deriving (Eq, Show, Read, Ord, Generic) +instance NFData Button+ -- | Events. data Event     = EvKey Key [Modifier]-    -- | \todo mouse events are not supported-    | EvMouse Int Int Button [Modifier]-    -- | if read from 'eventChannel' this is the size at the time of the signal. If read from-    -- 'nextEvent' this is the size at the time the event was processed by Vty. Typically these are-    -- the same, but if somebody is resizing the terminal quickly they can be different.+    -- ^ A keyboard key was pressed with the specified modifiers.+    | EvMouseDown Int Int Button [Modifier]+    -- ^ A mouse button was pressed at the specified column and row. Any+    -- modifiers available in the event are also provided.+    | EvMouseUp Int Int (Maybe Button)+    -- ^ A mouse button was released at the specified column and+    -- row. Some terminals report only that a button was released+    -- without specifying which one; in that case, Nothing is provided.+    -- Otherwise Just the button released is included in the event.     | EvResize Int Int-    deriving (Eq,Show,Ord)+    -- The terminal window was resized and the size is provided in the+    -- integer fields (width, height).+    | EvPaste ByteString+    -- ^ A paste event occurs when a bracketed paste input sequence is+    -- received. For terminals that support bracketed paste mode, these+    -- events will be triggered on a paste event. Terminals that do not+    -- support bracketed pastes will send the paste contents as ordinary+    -- input (which is probably bad, so beware!) Note that the data is+    -- provided in raw form and you'll have to decode (e.g. as UTF-8) if+    -- that's what your application expects.+    | EvLostFocus+    -- ^ The terminal running the application lost input focus.+    | EvGainedFocus+    -- ^ The terminal running the application gained input focus.+    deriving (Eq, Show, Read, Ord, Generic) +instance NFData Event+ type ClassifyMap = [(String,Event)]++-- | The type of internal events that drive the internal Vty event+-- dispatching to the application.+data InternalEvent =+    ResumeAfterInterrupt+    -- ^ Vty resumed operation after the process was interrupted (e.g.+    -- with a signal). In practice this translates into a screen redraw+    -- in the input event loop.+    | InputEvent Event+    -- ^ An input event was received.
− src/Graphics/Vty/Input/Loop.hs 
@@ -1,224 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}--- | The input layer used to be a single function that correctly accounted for the non-threaded--- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with--- a more straightforward parser. The non-threaded runtime is no longer supported.------ This is an example of an algorithm where code coverage could be high, even 100%, but the--- behavior is still under tested. I should collect more of these examples...------ reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html-module Graphics.Vty.Input.Loop where--import Graphics.Vty.Config-import Graphics.Vty.Input.Classify-import Graphics.Vty.Input.Events--import Control.Applicative-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception (mask, try, SomeException)-import Data.Monoid-import Lens.Micro-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-      -- the input initialized.-    , shutdownInput :: IO ()-      -- | Changes to this value are reflected after the next event.-    , _configRef :: IORef Config-      -- | input debug log-    , _inputDebug :: Maybe Handle-    }--makeLenses ''Input--data InputBuffer = InputBuffer-    { _ptr :: Ptr Word8-    , _size :: Int-    }--makeLenses ''InputBuffer--data InputState = InputState-    { _unprocessedBytes :: String-    , _appliedConfig :: Config-    , _inputBuffer :: InputBuffer-    , _classifier :: String -> KClass-    }--makeLenses ''InputState--type InputM a = StateT InputState (ReaderT Input IO) a--logMsg :: String -> InputM ()-logMsg msg = do-    d <- view inputDebug-    case d of-        Nothing -> return ()-        Just h -> liftIO $ hPutStrLn h msg >> hFlush h---- this must be run on an OS thread dedicated to this input handling.--- otherwise the terminal timing read behavior will block the execution of the lightweight threads.-loopInputProcessor :: InputM ()-loopInputProcessor = do-    readFromDevice >>= addBytesToProcess-    validEvents <- many parseEvent-    forM_ validEvents emit-    dropInvalid-    loopInputProcessor--addBytesToProcess :: String -> InputM ()-addBytesToProcess block = unprocessedBytes <>= block--emit :: Event -> InputM ()-emit event = do-    logMsg $ "parsed event: " ++ show event-    view eventChannel >>= liftIO . atomically . flip writeTChan event---- The timing requirements are assured by the VMIN and VTIME set for the device.------ Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case--- satisfies precondition.--- TODO: When under the non-threaded runtime emulate VMIN and VTIME-readFromDevice :: InputM String-readFromDevice = do-    newConfig <- view configRef >>= liftIO . readIORef-    oldConfig <- use appliedConfig-    let Just fd = inputFd newConfig-    when (newConfig /= oldConfig) $ do-        logMsg $ "new config: " ++ show newConfig-        liftIO $ applyConfig fd newConfig-        appliedConfig .= newConfig-    bufferPtr <- use $ inputBuffer.ptr-    maxBytes  <- use $ inputBuffer.size-    stringRep <- liftIO $ do-        -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses-        -- this provides a location to be interrupted prior to the foreign call. If there is input-        -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime-        -- terminal setting.-        threadWaitRead fd-        bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)-        if bytesRead > 0-        then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr-        else return []-    when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep-    return stringRep--applyConfig :: Fd -> Config -> IO ()-applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })-    = setTermTiming fd theVmin (theVtime `div` 100)-applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"--parseEvent :: InputM Event-parseEvent = do-    c <- use classifier-    b <- use unprocessedBytes-    case c b of-        Valid e remaining -> do-            logMsg $ "valid parse: " ++ show e-            logMsg $ "remaining: " ++ show remaining-            unprocessedBytes .= remaining-            return e-        _                   -> mzero --dropInvalid :: InputM ()-dropInvalid = do-    c <- use classifier-    b <- use unprocessedBytes-    when (c b == Invalid) $ do-        logMsg "dropping input bytes"-        unprocessedBytes .= []--runInputProcessorLoop :: ClassifyMap -> Input -> IO ()-runInputProcessorLoop classifyTable input = do-    let bufferSize = 1024-    allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do-        s0 <- InputState [] <$> readIORef (_configRef input)-                            <*> pure (InputBuffer bufferPtr bufferSize)-                            <*> pure (classify classifyTable)-        runReaderT (evalStateT loopInputProcessor s0) input--attributeControl :: Fd -> IO (IO (), IO ())-attributeControl fd = do-    original <- getTerminalAttributes fd-    let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts-                                             , EnableEcho, ProcessInput, ExtendedFunctions-                                             ]-    let setAttrs = setTerminalAttributes fd vtyMode Immediately-        unsetAttrs = setTerminalAttributes fd original Immediately-    return (setAttrs,unsetAttrs)--logInitialInputState :: Input -> ClassifyMap -> IO()-logInitialInputState input classifyTable = case _inputDebug input of-    Nothing -> return ()-    Just h  -> do-        Config{ vmin = Just theVmin-              , vtime = Just theVtime-              , termName = Just theTerm, .. } <- readIORef $ _configRef input-        _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))-        forM_ classifyTable $ \i -> case i of-            (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)-                                                                     (show inBytes)-                                                                     (show k)-                                                                     (show mods)-            _ -> return ()--initInput :: Config -> ClassifyMap -> IO Input-initInput config classifyTable = do-    let Just fd = inputFd config-    setFdOption fd NonBlockingRead False-    applyConfig fd config-    stopSync <- newEmptyMVar-    input <- Input <$> atomically newTChan-                   <*> pure (return ())-                   <*> newIORef config-                   <*> maybe (return Nothing)-                             (\f -> Just <$> openFile f AppendMode)-                             (debugLog config)-    logInitialInputState input classifyTable-    inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input)-                                 (\_ -> putMVar stopSync ())-    let killAndWait = do-          killThread inputThread-          takeMVar stopSync-    return $ input { shutdownInput = killAndWait }--foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()--forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkOSFinally action and_then =-  mask $ \restore -> forkOS $ try (restore action) >>= and_then--(<>=) :: (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)
− src/Graphics/Vty/Input/Terminfo.hs 
@@ -1,185 +0,0 @@-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-module Graphics.Vty.Input.Terminfo where--import Graphics.Vty.Input.Events-import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT--import Control.Arrow-import System.Console.Terminfo---- | queries the terminal for all capability based input sequences then adds on a terminal dependent--- input sequence mapping.------ For reference see:------ * http://vimdoc.sourceforge.net/htmldoc/term.html------ * vim74/src/term.c------ * http://invisible-island.net/vttest/------ * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html------ This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect.--- Vty assumes that the an internal terminfo table added to the system provided terminfo table is--- correct.------ 1. build terminfo table for all caps. Missing caps are not added.------ 2. add tables for visible chars, esc, del plus ctrl and meta------ 3. add internally defined table for given terminal type.------ Precedence is currently implicit in the 'compile' algorithm. Which is a bit odd.------ \todo terminfo meta is not supported.--- \todo no 8bit-classifyMapForTerm :: String -> Terminal -> ClassifyMap-classifyMapForTerm termName term =-    concat $ capsClassifyMap term keysFromCapsTable-           : universalTable-           : termSpecificTables termName---- | key table applicable to all terminals.------ TODO: some probably only applicable to ANSI/VT100 terminals.-universalTable :: ClassifyMap-universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]--capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap-capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]-    where extractCap = first (getCapability terminal . tiGetStr)---- | tables specific to a given terminal that are not derivable from terminfo.------ TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier.-termSpecificTables :: String -> [ClassifyMap]-termSpecificTables _termName = ANSIVT.classifyTable---- | Visible characters in the ISO-8859-1 and UTF-8 common set.------ we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this--- classify table is reached.------ TODO: resolve--- 1. start at ' '. The earlier characters are all 'ctrlChar'-visibleChars :: ClassifyMap-visibleChars = [ ([x], EvKey (KChar x) [])-               | x <- [' ' .. toEnum 0xC1]-               ]---- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.------ \todo resolve CTRL-i is the same as tab-ctrlChars :: ClassifyMap-ctrlChars =-    [ ([toEnum x],EvKey (KChar y) [MCtrl])-    | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])-    , y /= 'i'  -- Resolve issue #3 where CTRL-i hides TAB.-    , y /= 'h'  -- CTRL-h should not hide BS-    ]---- | Ctrl+Meta+Char-ctrlMetaChars :: ClassifyMap-ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars---- | esc, meta esc, delete, meta delete, enter, meta enter-specialSupportKeys :: ClassifyMap-specialSupportKeys =-    [ -- special support for ESC-      ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])-    -- Special support for backspace-    , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])-    -- Special support for Enter-    , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])-    -- explicit support for tab-    , ("\t", EvKey (KChar '\t') [])-    ]---- | classify table directly generated from terminfo cap strings------ these are:------ * ka1 - keypad up-left------ * ka3 - keypad up-right------ * kb2 - keypad center------ * kbs - keypad backspace------ * kbeg - begin------ * kcbt - back tab------ * kc1 - keypad left-down--- --- * kc3 - keypad right-down------ * kdch1 - delete------ * kcud1 - down------ * kend - end--- --- * kent - enter------ * kf0 - kf63 - function keys------ * khome - KHome------ * kich1 - insert------ * kcub1 - left------ * knp - next page (page down)------ * kpp - previous page (page up)------ * kcuf1 - right------ * kDC - shift delete------ * kEND - shift end------ * kHOM - shift home------ * kIC - shift insert------ * kLFT - shift left------ * kRIT - shift right------ * kcuu1 - up-keysFromCapsTable :: ClassifyMap-keysFromCapsTable =-    [ ("ka1",   EvKey KUpLeft    [])-    , ("ka3",   EvKey KUpRight   [])-    , ("kb2",   EvKey KCenter    [])-    , ("kbs",   EvKey KBS        [])-    , ("kbeg",  EvKey KBegin     [])-    , ("kcbt",  EvKey KBackTab   [])-    , ("kc1",   EvKey KDownLeft  [])-    , ("kc3",   EvKey KDownRight [])-    , ("kdch1", EvKey KDel       [])-    , ("kcud1", EvKey KDown      [])-    , ("kend",  EvKey KEnd       [])-    , ("kent",  EvKey KEnter     [])-    , ("khome", EvKey KHome      [])-    , ("kich1", EvKey KIns       [])-    , ("kcub1", EvKey KLeft      [])-    , ("knp",   EvKey KPageDown  [])-    , ("kpp",   EvKey KPageUp    [])-    , ("kcuf1", EvKey KRight     [])-    , ("kDC",   EvKey KDel       [MShift])-    , ("kEND",  EvKey KEnd       [MShift])-    , ("kHOM",  EvKey KHome      [MShift])-    , ("kIC",   EvKey KIns       [MShift])-    , ("kLFT",  EvKey KLeft      [MShift])-    , ("kRIT",  EvKey KRight     [MShift])-    , ("kcuu1", EvKey KUp        [])-    ] ++ functionKeyCapsTable---- | cap names for function keys-functionKeyCapsTable :: ClassifyMap-functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])
− src/Graphics/Vty/Input/Terminfo/ANSIVT.hs 
@@ -1,87 +0,0 @@--- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo.--- --- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often--- use VT50 input bytes regardless of declared terminal type. This provides compatibility with--- programs that don't follow terminfo.-module Graphics.Vty.Input.Terminfo.ANSIVT where--import Graphics.Vty.Input.Events---- | Encoding for navigation keys.------ TODO: This is not the same as the input bytes pulled from teh caps table.-navKeys0 :: ClassifyMap-navKeys0 =-    [ k "G" KCenter-    , k "P" KPause-    , k "A" KUp-    , k "B" KDown-    , k "C" KRight-    , k "D" KLeft-    , k "H" KHome-    , k "F" KEnd-    , k "E" KBegin-    ]-    where k c s = ("\ESC["++c,EvKey s [])---- | encoding for shift, meta and ctrl plus arrows/home/end-navKeys1 :: ClassifyMap-navKeys1 =-   [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)-    | charCnt <- ["1;", ""], -- we can have a count or not-    (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),-               ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes-    (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes-   ]---- | encoding for ins, del, pageup, pagedown, home, end-navKeys2 :: ClassifyMap-navKeys2 =-    let k n s = ("\ESC["++show n++"~",EvKey s [])-    in zipWith k [2::Int,3,5,6,1,4]-                 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]---- | encoding for ctrl + ins, del, pageup, pagedown, home, end-navKeys3 :: ClassifyMap-navKeys3 =-    let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])-    in zipWith k [2::Int,3,5,6,1,4]-                 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]---- | encoding for shift plus function keys--- --- According to ------  * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html------ This encoding depends on the terminal.-functionKeys1 :: ClassifyMap-functionKeys1 =-    let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in-    concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]---- | encoding for meta plus char------ TODO: resolve ------- 1. removed 'ESC' from second list due to duplication with "special_support_keys".--- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is--- the same as ESC should examine km and current encoding.--- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by--- special_support_keys.-functionKeys2 :: ClassifyMap-functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])-                  | x <- '\t':[' ' .. '~']-                  , x /= '['-                  ]--classifyTable :: [ClassifyMap]-classifyTable =-    [ navKeys0-    , navKeys1-    , navKeys2-    , navKeys3-    , functionKeys1-    , functionKeys2-    ]-
src/Graphics/Vty/Output.hs view
@@ -1,97 +1,367 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NamedFieldPuns #-}---  | Output interface.------  Access to the current terminal or a specific terminal device.------  See also:------  1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based---  on the TERM and COLORTERM environment variables.------  2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement.------  3. "Graphics.Vty.Output.TerminfoBased": Defines a terminal instance that uses terminfo for all---  control strings.  No attempt is made to change the character set to UTF-8 for these terminals.---  I don't know a way to reliably determine if that is required or how to do so.------  4. "Graphics.Vty.Output.XTermColor": This module contains an interface suitable for xterm-like---  terminals. These are the terminals where TERM == xterm. This does use terminfo for as many---  control codes as possible.-module Graphics.Vty.Output ( module Graphics.Vty.Output-                           , Output(..) -- \todo hide constructors-                           , AssumedState(..)-                           , DisplayContext(..) -- \todo hide constructors-                           , outputPicture-                           , displayContext-                           )-    where--import Graphics.Vty.Prelude--import Graphics.Vty.Config--import Graphics.Vty.Output.Interface-import Graphics.Vty.Output.XTermColor as XTermColor-import Graphics.Vty.Output.TerminfoBased as TerminfoBased+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards, CPP #-}+-- | This module provides an abstract interface for performing terminal+-- output and functions for accessing the current terminal or a specific+-- terminal device.+module Graphics.Vty.Output+  ( Output(..)+  , AssumedState(..)+  , DisplayContext(..)+  , Mode(..)+  , displayContext+  , outputPicture+  , initialAssumedState+  , limitAttrForDisplay+  , setCursorPos+  , hideCursor+  , showCursor+  )+where -import Blaze.ByteString.Builder (writeToByteString)+import Blaze.ByteString.Builder (Write, writeToByteString)+import Blaze.ByteString.Builder.ByteString (writeByteString)+import Control.Monad (when)+import qualified Data.ByteString as BS+import Data.IORef+import qualified Data.Vector as Vector+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL -import Control.Monad.Trans+import Graphics.Vty.Attributes+import Graphics.Vty.DisplayAttributes+import Graphics.Vty.Image (DisplayRegion, regionWidth, regionHeight)+import Graphics.Vty.Picture+import Graphics.Vty.PictureToSpans+import Graphics.Vty.Span -import Data.List (isPrefixOf)-import Data.Monoid ((<>))+-- | Modal terminal features that can be enabled and disabled.+data Mode = Mouse+          -- ^ Mouse mode (whether the terminal is configured to provide+          -- mouse input events)+          | BracketedPaste+          -- ^ Paste mode (whether the terminal is configured to provide+          -- events on OS pastes)+          | Focus+          -- ^ Focus-in/focus-out events (whether the terminal is+          -- configured to provide events on focus change)+          | Hyperlink+          -- ^ Hyperlink mode via the 'withURL' attribute modifier (see+          -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).+          -- Note that this may not work gracefully in all terminal+          -- emulators so be sure to test this mode with the terminals+          -- you intend to support. It is off by default.+          deriving (Eq, Read, Show) --- | Returns a `Output` for the terminal specified in `Config`------ The specific Output implementation used is hidden from the API user. All terminal implementations--- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at--- least some terminal specific information.------ Specifics about it being based on terminfo are hidden from the API user. If a terminal--- implementation is developed for a terminal without terminfo support then Vty should work as--- expected on that terminal.------ Selection of a terminal is done as follows:------      * If TERM == xterm use XTermColor.---      * for any other TERM value TerminfoBased is used.------ \todo add an implementation for windows that does not depend on terminfo. Should be installable--- with only what is provided in the haskell platform. Use ansi-terminal-outputForConfig :: Config -> IO Output-outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do-    t <- if "xterm" `isPrefixOf` termName-        then XTermColor.reserveTerminal termName fd-        -- Not an xterm-like terminal. try for generic terminfo.-        else TerminfoBased.reserveTerminal termName fd-    return t-outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig+-- | The library's device output abstraction. Platform-specific+-- implementations must implement an 'Output' and provide it to+-- 'Graphics.Vty.mkVtyFromPair'.+data Output = Output+    { -- | Text identifier for the output device. Used for debugging.+      terminalID :: String+      -- | Release the terminal just prior to application exit and reset+      -- it to its state prior to application startup.+    , releaseTerminal :: IO ()+      -- | Clear the display and initialize the terminal to some initial+      -- display state.+      --+      -- The expectation of a program is that the display starts in some+      -- The initial state. initial state would consist of fixed values:+      --+      --  - cursor at top left+      --  - UTF-8 character encoding+      --  - drawing characteristics are the default+    , reserveDisplay :: IO ()+      -- | Return the display to the state before `reserveDisplay` If no+      -- previous state then set the display state to the initial state.+    , releaseDisplay :: IO ()+      -- | Sets the current display bounds (width, height).+    , setDisplayBounds :: (Int, Int) -> IO ()+      -- | Returns the current display bounds.+    , displayBounds :: IO DisplayRegion+      -- | Output the bytestring to the terminal device.+    , outputByteBuffer :: BS.ByteString -> IO ()+      -- | Specifies whether the cursor can be shown / hidden.+    , supportsCursorVisibility :: Bool+      -- | Indicates support for terminal modes for this output device.+    , supportsMode :: Mode -> Bool+      -- | Enables or disables a mode (does nothing if the mode is+      -- unsupported).+    , setMode :: Mode -> Bool -> IO ()+      -- | Returns whether a mode is enabled.+    , getModeStatus :: Mode -> IO Bool+    , assumedStateRef :: IORef AssumedState+      -- | Acquire display access to the given region of the display.+      -- Currently all regions have the upper left corner of (0,0) and+      -- the lower right corner at (max displayWidth providedWidth, max+      -- displayHeight providedHeight)+    , mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext+      -- | Ring the terminal bell if supported.+    , ringTerminalBell :: IO ()+      -- | Returns whether the terminal has an audio bell feature.+    , supportsBell :: IO Bool+      -- | Returns whether the terminal supports italicized text.+      --+      -- This is terminal-dependent and should make a best effort to+      -- determine whether this feature is supported, but even if the+      -- terminal advertises support (e.g. via terminfo) that might not+      -- be a reliable indicator of whether the feature will work as+      -- desired.+    , supportsItalics :: IO Bool+      -- | Returns whether the terminal supports strikethrough text.+      --+      -- This is terminal-dependent and should make a best effort to+      -- determine whether this feature is supported, but even if the+      -- terminal advertises support (e.g. via terminfo) that might not+      -- be a reliable indicator of whether the feature will work as+      -- desired.+    , supportsStrikethrough :: IO Bool+      -- | Returns how many colors the terminal supports.+    , outputColorMode :: ColorMode+      -- | Set the output's window title, if any.+    , setOutputWindowTitle :: String -> IO ()+    }  -- | Sets the cursor position to the given output column and row. ----- This is not necessarially the same as the character position with the same coordinates.--- Characters can be a variable number of columns in width.+-- This is not necessarily the same as the character position with the+-- same coordinates. Characters can be a variable number of columns in+-- width. ----- Currently, the only way to set the cursor position to a given character coordinate is to specify--- the coordinate in the Picture instance provided to outputPicture or refresh.-setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()+-- Currently, the only way to set the cursor position to a given+-- character coordinate is to specify the coordinate in the Picture+-- instance provided to 'outputPicture' or 'refresh'.+setCursorPos :: Output -> Int -> Int -> IO () setCursorPos t x y = do     bounds <- displayBounds t     when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do         dc <- displayContext t bounds-        liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y+        outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y --- | Hides the cursor-hideCursor :: MonadIO m => Output -> m ()+-- | Hides the cursor.+hideCursor :: Output -> IO () hideCursor t = do     bounds <- displayBounds t     dc <- displayContext t bounds-    liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc+    outputByteBuffer t $ writeToByteString $ writeHideCursor dc --- | Shows the cursor-showCursor :: MonadIO m => Output -> m ()+-- | Shows the cursor.+showCursor :: Output -> IO () showCursor t = do     bounds <- displayBounds t     dc <- displayContext t bounds-    liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc+    outputByteBuffer t $ writeToByteString $ writeShowCursor dc++displayContext :: Output -> DisplayRegion -> IO DisplayContext+displayContext t = mkDisplayContext t t++data AssumedState = AssumedState+    { prevFattr :: Maybe FixedAttr+    , prevOutputOps :: Maybe DisplayOps+    }++initialAssumedState :: AssumedState+initialAssumedState = AssumedState Nothing Nothing++data DisplayContext = DisplayContext+    { contextDevice :: Output+    -- | Provide the bounds of the display context.+    , contextRegion :: DisplayRegion+    -- | Sets the output position to the specified row and column+    -- where the number of bytes required for the control codes can be+    -- specified seperate from the actual byte sequence.+    , writeMoveCursor :: Int -> Int -> Write+    , writeShowCursor :: Write+    , writeHideCursor :: Write+    -- Ensure that the specified output attributes will be applied to+    -- all the following text until the next output attribute change+    -- where the number of bytes required for the control codes can be+    -- specified seperately from the actual byte sequence. The required+    -- number of bytes must be at least the maximum number of bytes+    -- required by any attribute changes. The serialization equations+    -- must provide the ptr to the next byte to be specified in the+    -- output buffer.+    --+    -- The currently applied display attributes are provided as well.+    -- The Attr data type can specify the style or color should not be+    -- changed from the currently applied display attributes. In order+    -- to support this the currently applied display attributes are+    -- required. In addition it may be possible to optimize the state+    -- changes based off the currently applied display attributes.+    , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write+    -- | Reset the display attributes to the default display attributes.+    , writeDefaultAttr :: Bool -> Write+    , writeRowEnd :: Write+    -- | See `Graphics.Vty.Output.XTermColor.inlineHack`+    , inlineHack :: IO ()+    }++-- | All terminals serialize UTF8 text to the terminal device exactly as+-- serialized in memory.+writeUtf8Text  :: BS.ByteString -> Write+writeUtf8Text = writeByteString++-- | Displays the given `Picture`.+--+--      1. The image is cropped to the display size.+--+--      2. Converted into a sequence of attribute changes and text spans.+--+--      3. The cursor is hidden.+--+--      4. Serialized to the display.+--+--      5. The cursor is then shown and positioned or kept hidden.+outputPicture :: DisplayContext -> Picture -> IO ()+outputPicture dc pic = do+    urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink+    as <- readIORef (assumedStateRef $ contextDevice dc)+    let manipCursor = supportsCursorVisibility (contextDevice dc)+        r = contextRegion dc+        ops = displayOpsForPic pic r+        initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing+        -- Diff the previous output against the requested output.+        -- Differences are currently on a per-row basis.+        diffs :: [Bool] = case prevOutputOps as of+            Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True+            Just previousOps -> if affectedRegion previousOps /= affectedRegion ops+                then replicate (displayOpsRows ops) True+                else Vector.toList $ Vector.zipWith (/=) previousOps ops+        -- build the Write corresponding to the output image+        out = (if manipCursor then writeHideCursor dc else mempty)+              `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops+              `mappend`+                (let (w,h) = contextRegion dc+                     clampX = max 0 . min (w-1)+                     clampY = max 0 . min (h-1) in+                 case picCursor pic of+                    _ | not manipCursor -> mempty+                    NoCursor            -> mempty+                    AbsoluteCursor x y ->+                        writeShowCursor dc `mappend`+                        writeMoveCursor dc (clampX x) (clampY y)+                    PositionOnly isAbs x y ->+                        if isAbs+                           then writeMoveCursor dc (clampX x) (clampY y)+                           else let (ox, oy) = charToOutputPos m (clampX x, clampY y)+                                    m = cursorOutputMap ops $ picCursor pic+                                in writeMoveCursor dc (clampX ox) (clampY oy)+                    Cursor x y           ->+                        let m = cursorOutputMap ops $ picCursor pic+                            (ox, oy) = charToOutputPos m (clampX x, clampY y)+                        in writeShowCursor dc `mappend`+                           writeMoveCursor dc (clampX ox) (clampY oy)+                )+    -- ... then serialize+    outputByteBuffer (contextDevice dc) (writeToByteString out)+    -- Cache the output spans.+    let as' = as { prevOutputOps = Just ops }+    writeIORef (assumedStateRef $ contextDevice dc) as'++writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write+writeOutputOps urlsEnabled dc initialAttr diffs ops =+    let (_, out, _) = Vector.foldl' writeOutputOps'+                                       (0, mempty, diffs)+                                       ops+    in out+    where+        writeOutputOps' (y, out, True : diffs') spanOps+            = let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps+                  out' = out `mappend` spanOut+              in (y+1, out', diffs')+        writeOutputOps' (y, out, False : diffs') _spanOps+            = (y + 1, out, diffs')+        writeOutputOps' (_y, _out, []) _spanOps+            = error "vty - output spans without a corresponding diff."++writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write+writeSpanOps urlsEnabled dc y initialAttr spanOps =+    -- The first operation is to set the cursor to the start of the row+    let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled+    -- then the span ops are serialized in the order specified+    in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of+                              (opOut, fattr') -> (out `mappend` opOut, fattr')+                           )+                           (start, initialAttr)+                           spanOps++writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)+writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =+    let attr' = limitAttrForDisplay (contextDevice dc) attr+        fattr' = fixDisplayAttr fattr attr'+        diffs = displayAttrDiffs fattr fattr'+        out =  writeSetAttr dc urlsEnabled fattr attr' diffs+               `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)+    in (out, fattr')+writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"+writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)++-- | The cursor position is given in X,Y character offsets. Due to+-- multi-column characters this needs to be translated to column, row+-- positions.+data CursorOutputMap = CursorOutputMap+    { charToOutputPos :: (Int, Int) -> (Int, Int)+    }++cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap+cursorOutputMap spanOps _cursor = CursorOutputMap+    { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)+    }++cursorColumnOffset :: DisplayOps -> Int -> Int -> Int+cursorColumnOffset ops cx cy =+    let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)+        (outOffset, _, _)+            = Vector.foldl' ( \(d, currentCx, done) op ->+                        if done then (d, currentCx, done) else case spanOpHasWidth op of+                            Nothing -> (d, currentCx, False)+                            Just (cw, ow) -> case compare cx (currentCx + cw) of+                                    GT -> ( d + ow+                                          , currentCx + cw+                                          , False+                                          )+                                    EQ -> ( d + ow+                                          , currentCx + cw+                                          , True+                                          )+                                    LT -> ( d + columnsToCharOffset (cx - currentCx) op+                                          , currentCx + cw+                                          , True+                                          )+                      )+                      (0, 0, False)+                      cursorRowOps+    in outOffset++-- | Not all terminals support all display attributes. This filters a+-- display attribute to what the given terminal can display.+limitAttrForDisplay :: Output -> Attr -> Attr+limitAttrForDisplay t attr+    = attr { attrForeColor = clampColor $ attrForeColor attr+           , attrBackColor = clampColor $ attrBackColor attr+           }+    where+        clampColor Default     = Default+        clampColor KeepCurrent = KeepCurrent+        clampColor (SetTo c)   = clampColor' (outputColorMode t) c++        clampColor' NoColor _ = Default++        clampColor' ColorMode8 (ISOColor v)+            | v >= 8    = SetTo $ ISOColor (v - 8)+            | otherwise = SetTo $ ISOColor v+        clampColor' ColorMode8 _ = Default++        clampColor' ColorMode16 c@(ISOColor _) = SetTo c+        clampColor' ColorMode16 _              = Default++        clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c+        clampColor' (ColorMode240 colorCount) c@(Color240 n)+            | n <= colorCount = SetTo c+            | otherwise       = Default+        clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =+            clampColor' colorMode (color240 r g b)++        clampColor' FullColor c = SetTo c
− src/Graphics/Vty/Output/Interface.hs 
@@ -1,265 +0,0 @@--- Copyright Corey O'Connor--- General philosophy is: MonadIO is for equations exposed to clients.-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif--module Graphics.Vty.Output.Interface-where--import Graphics.Vty.Prelude--import Graphics.Vty.Picture-import Graphics.Vty.PictureToSpans-import Graphics.Vty.Span--import Graphics.Vty.DisplayAttributes--import Blaze.ByteString.Builder (Write, writeToByteString)-import Blaze.ByteString.Builder.ByteString (writeByteString)--import Control.Monad.Trans--import qualified Data.ByteString as BS-import Data.IORef-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as Vector--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (mempty, mappend)-#endif--data Output = Output-    { -- | Text identifier for the output device. Used for debugging. -      terminalID :: String-    , releaseTerminal :: forall m. MonadIO m => m ()-    -- | Clear the display and initialize the terminal to some initial display state. -    ---    -- The expectation of a program is that the display starts in some initial state. -    -- The initial state would consist of fixed values:-    ---    --  - cursor at top left-    --  - UTF-8 character encoding-    --  - drawing characteristics are the default-    ---    -- The abstract operation I think all these behaviors are instances of is reserving exclusive-    -- access to a display such that:-    ---    --  - The previous state cannot be determined-    --  - When exclusive access to a display is released the display returns to the previous state.-    , reserveDisplay :: forall m. MonadIO m => m ()-    -- | Return the display to the state before `reserveDisplay`-    -- If no previous state then set the display state to the initial state.-    , releaseDisplay :: forall m. MonadIO m => m ()-    -- | Returns the current display bounds.-    , displayBounds :: forall m. MonadIO m => m DisplayRegion-    -- | Output the byte string to the terminal device.-    , outputByteBuffer :: BS.ByteString -> IO ()-    -- | Maximum number of colors supported by the context.-    , contextColorCount :: Int-    -- | if the cursor can be shown / hidden-    , supportsCursorVisibility :: Bool-    , assumedStateRef :: IORef AssumedState-    -- | Acquire display access to the given region of the display.-    -- Currently all regions have the upper left corner of (0,0) and the lower right corner at -    -- (max displayWidth providedWidth, max displayHeight providedHeight)-    , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext-    }--displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext-displayContext t = liftIO . mkDisplayContext t t--data AssumedState = AssumedState-    { prevFattr :: Maybe FixedAttr-    , prevOutputOps :: Maybe DisplayOps-    }--initialAssumedState :: AssumedState-initialAssumedState = AssumedState Nothing Nothing--data DisplayContext = DisplayContext-    { contextDevice :: Output-    -- | Provide the bounds of the display context. -    , contextRegion :: DisplayRegion-    --  | sets the output position to the specified row and column. Where the number of bytes-    --  required for the control codes can be specified seperate from the actual byte sequence.-    , writeMoveCursor :: Int -> Int -> Write-    , writeShowCursor :: Write-    , writeHideCursor :: Write-    --  | Assure the specified output attributes will be applied to all the following text until the-    --  next output attribute change. Where the number of bytes required for the control codes can-    --  be specified seperate from the actual byte sequence.  The required number of bytes must be-    --  at least the maximum number of bytes required by any attribute changes.  The serialization-    --  equations must provide the ptr to the next byte to be specified in the output buffer.-    ---    --  The currently applied display attributes are provided as well. The Attr data type can-    --  specify the style or color should not be changed from the currently applied display-    --  attributes. In order to support this the currently applied display attributes are required.-    --  In addition it may be possible to optimize the state changes based off the currently applied-    --  display attributes.-    , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write-    -- | Reset the display attributes to the default display attributes-    , writeDefaultAttr :: Write-    , writeRowEnd :: Write-    -- | See `Graphics.Vty.Output.XTermColor.inlineHack`-    , inlineHack :: IO ()-    }---- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.-writeUtf8Text  :: BS.ByteString -> Write-writeUtf8Text = writeByteString---- | Displays the given `Picture`.------      0. The image is cropped to the display size. ------      1. Converted into a sequence of attribute changes and text spans.---      ---      2. The cursor is hidden.------      3. Serialized to the display.------      4. The cursor is then shown and positioned or kept hidden.--- --- todo: specify possible IO exceptions.--- abstract from IO monad to a MonadIO instance.-outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()-outputPicture dc pic = liftIO $ do-    as <- readIORef (assumedStateRef $ contextDevice dc)-    let manipCursor = supportsCursorVisibility (contextDevice dc)-        r = contextRegion dc-        ops = displayOpsForPic pic r-        initialAttr = FixedAttr defaultStyleMask Nothing Nothing-        -- Diff the previous output against the requested output. Differences are currently on a per-row-        -- basis.-        -- \todo handle resizes that crop the dominate directions better.-        diffs :: [Bool] = case prevOutputOps as of-            Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True-            Just previousOps -> if effectedRegion previousOps /= effectedRegion ops-                then replicate (displayOpsRows ops) True-                else zipWith (/=) (Vector.toList previousOps)-                                  (Vector.toList ops)-        -- build the Write corresponding to the output image-        out = (if manipCursor then writeHideCursor dc else mempty)-              `mappend` writeOutputOps dc initialAttr diffs ops-              `mappend`-                (case picCursor pic of-                    _ | not manipCursor -> mempty-                    NoCursor             -> mempty-                    Cursor x y           ->-                        let m = cursorOutputMap ops $ picCursor pic-                            (ox, oy) = charToOutputPos m (x,y)-                        in writeShowCursor dc `mappend` writeMoveCursor dc ox oy-                )-    -- ... then serialize-    outputByteBuffer (contextDevice dc) (writeToByteString out)-    -- Cache the output spans.-    let as' = as { prevOutputOps = Just ops }-    writeIORef (assumedStateRef $ contextDevice dc) as'--writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write-writeOutputOps dc initialAttr diffs ops =-    let (_, out, _) = Vector.foldl' writeOutputOps'-                                       (0, mempty, diffs)-                                       ops-    in out-    where -        writeOutputOps' (y, out, True : diffs') spanOps-            = let spanOut = writeSpanOps dc y initialAttr spanOps-                  out' = out `mappend` spanOut-              in (y+1, out', diffs')-        writeOutputOps' (y, out, False : diffs') _spanOps-            = (y + 1, out, diffs')-        writeOutputOps' (_y, _out, []) _spanOps-            = error "vty - output spans without a corresponding diff."--writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write-writeSpanOps dc y initialAttr spanOps =-    -- The first operation is to set the cursor to the start of the row-    let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc-    -- then the span ops are serialized in the order specified-    in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of-                              (opOut, fattr') -> (out `mappend` opOut, fattr')-                           )-                           (start, initialAttr)-                           spanOps--writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)-writeSpanOp dc (TextSpan attr _ _ str) fattr =-    let attr' = limitAttrForDisplay (contextDevice dc) attr-        fattr' = fixDisplayAttr fattr attr'-        diffs = displayAttrDiffs fattr fattr'-        out =  writeSetAttr dc fattr attr' diffs-               `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)-    in (out, fattr')-writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"-writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)---- | The cursor position is given in X,Y character offsets. Due to multi-column characters this--- needs to be translated to column, row positions.-data CursorOutputMap = CursorOutputMap-    { charToOutputPos :: (Int, Int) -> (Int, Int)-    } --cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap-cursorOutputMap spanOps _cursor = CursorOutputMap-    { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)-    }--cursorColumnOffset :: DisplayOps -> Int -> Int -> Int-cursorColumnOffset ops cx cy =-    let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)-        (outOffset, _, _) -            = Vector.foldl' ( \(d, currentCx, done) op -> -                        if done then (d, currentCx, done) else case spanOpHasWidth op of-                            Nothing -> (d, currentCx, False)-                            Just (cw, ow) -> case compare cx (currentCx + cw) of-                                    GT -> ( d + ow-                                          , currentCx + cw-                                          , False -                                          )-                                    EQ -> ( d + ow-                                          , currentCx + cw-                                          , True -                                          )-                                    LT -> ( d + columnsToCharOffset (cx - currentCx) op-                                          , currentCx + cw-                                          , True-                                          )-                      )-                      (0, 0, False)-                      cursorRowOps-    in outOffset---- | Not all terminals support all display attributes. This filters a display attribute to what the--- given terminal can display.-limitAttrForDisplay :: Output -> Attr -> Attr-limitAttrForDisplay t attr -    = attr { attrForeColor = clampColor $ attrForeColor attr-           , attrBackColor = clampColor $ attrBackColor attr-           }-    where-        clampColor Default     = Default-        clampColor KeepCurrent = KeepCurrent-        clampColor (SetTo c)   = clampColor' c-        clampColor' (ISOColor v) -            | contextColorCount t < 8            = Default-            | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)-            | otherwise                          = SetTo $ ISOColor v-        clampColor' (Color240 v)-            -- TODO: Choose closes ISO color?-            | contextColorCount t <  8           = Default-            | contextColorCount t <  16          = Default-            | contextColorCount t <= 256         = SetTo $ Color240 v-            | otherwise -                = let p :: Double = fromIntegral v / 240.0 -                      v' = floor $ p * (fromIntegral $ contextColorCount t)-                  in SetTo $ Color240 v'
src/Graphics/Vty/Output/Mock.hs view
@@ -1,14 +1,18 @@ -- Copyright Corey O'Connor {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}--- | This provides a mock terminal implementation that is nice for testing. This transforms the--- output operations to visible characters. Which is nice for some tests.-module Graphics.Vty.Output.Mock ( MockData, mockTerminal )-    where--import Graphics.Vty.Prelude+-- | This provides a mock terminal implementation that is nice for+-- testing. This transforms the output operations to visible characters+-- which is useful for testing.+module Graphics.Vty.Output.Mock+  ( MockData+  , mockTerminal+  )+where -import Graphics.Vty.Output.Interface+import Graphics.Vty.Image (DisplayRegion)+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16))+import Graphics.Vty.Output  import Blaze.ByteString.Builder.Word (writeWord8) @@ -20,18 +24,20 @@  type MockData = IORef (UTF8.UTF8 BS.ByteString) --- | The mock display terminal produces a string representation of the requested picture.  There is--- *not* an isomorphism between the string representation and the picture.  The string--- representation is a simplification of the picture that is only useful in debugging VTY without--- considering terminal specific issues.+-- | The mock display terminal produces a string representation of+-- the requested picture. There is *not* an isomorphism between the+-- string representation and the picture. The string representation is+-- a simplification of the picture that is only useful in debugging VTY+-- without considering terminal specific issues. ----- The mock implementation is useful in manually determining if the sequence of terminal operations--- matches the expected sequence. So requirement of the produced representation is simplicity in--- parsing the text representation and determining how the picture was mapped to terminal--- operations.+-- The mock implementation is useful in manually determining if the+-- sequence of terminal operations matches the expected sequence. The+-- requirement of the produced representation is simplicity in parsing+-- the text representation and determining how the picture was mapped to+-- terminal operations. ----- The string representation is a sequence of identifiers where each identifier is the name of an--- operation in the algebra.+-- The string representation is a sequence of identifiers where each+-- identifier is the name of an operation in the algebra. mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output) mockTerminal r = liftIO $ do     outRef <- newIORef undefined@@ -41,30 +47,44 @@             , releaseTerminal = return ()             , reserveDisplay = return ()             , releaseDisplay = return ()+            , ringTerminalBell = return ()+            , supportsBell = return False+            , supportsItalics = return False+            , supportsStrikethrough = return False+            , setDisplayBounds = const $ return ()             , displayBounds = return r             , outputByteBuffer = \bytes -> do                 putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"                 writeIORef outRef $ UTF8.fromRep bytes-            , contextColorCount = 16             , supportsCursorVisibility = True+            , supportsMode = const False+            , setMode = const $ const $ return ()+            , getModeStatus = const $ return False             , assumedStateRef = newAssumedStateRef+            , outputColorMode = ColorMode16+            , setOutputWindowTitle = const $ return ()             , mkDisplayContext = \tActual rActual -> return $ DisplayContext                 { contextRegion = rActual                 , contextDevice = tActual-                -- A cursor move is always visualized as the single character 'M'+                -- A cursor move is always visualized as the single+                -- character 'M'                 , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'-                -- Show cursor is always visualized as the single character 'S'+                -- Show cursor is always visualized as the single+                -- character 'S'                 , writeShowCursor =  writeWord8 $ toEnum $ fromEnum 'S'-                -- Hide cursor is always visualized as the single character 'H'+                -- Hide cursor is always visualized as the single+                -- character 'H'                 , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'-                -- An attr change is always visualized as the single character 'A'-                , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'-                -- default attr is always visualized as the single character 'D'-                , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'-                -- row end is always visualized as the single character 'E'+                -- An attr change is always visualized as the single+                -- character 'A'+                , writeSetAttr = \_ _fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'+                -- default attr is always visualized as the single+                -- character 'D'+                , writeDefaultAttr = const $ writeWord8 $ toEnum $ fromEnum 'D'+                -- row end is always visualized as the single character+                -- 'E'                 , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'                 , inlineHack = return ()                 }             }     return (outRef, t)-
− src/Graphics/Vty/Output/TerminfoBased.hs 
@@ -1,470 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}-{-# CFILES gwinsz.c #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif---- |  Terminfo based terminal handling.------ The color handling assumes tektronix like. No HP support provided. If the terminal is not one I--- have easy access to then color support is entirely based of the docs. Probably with some--- assumptions mixed in.------ Copyright Corey O'Connor (coreyoconnor@gmail.com)-module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )-    where--import Graphics.Vty.Prelude--import Data.ByteString.Internal (toForeignPtr)-import Data.Terminfo.Parse-import Data.Terminfo.Eval--import Graphics.Vty.Attributes-import Graphics.Vty.DisplayAttributes-import Graphics.Vty.Output.Interface--import Blaze.ByteString.Builder (Write, writeToByteString)--import Control.Monad.Trans--import Data.Bits ((.&.))-import Data.IORef-import Data.Maybe (isJust, isNothing, fromJust)-import Data.Word--import Foreign.C.Types ( CInt(..), CLong(..) )-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr)--import qualified System.Console.Terminfo as Terminfo-import System.Posix.IO (fdWriteBuf)-import System.Posix.Types (Fd(..))--#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable (foldMap)-import Data.Monoid-#endif--data TerminfoCaps = TerminfoCaps -    { smcup :: Maybe CapExpression-    , rmcup :: Maybe CapExpression-    , cup :: CapExpression-    , cnorm :: Maybe CapExpression-    , civis :: Maybe CapExpression-    , supportsNoColors :: Bool-    , useAltColorMap :: Bool-    , setForeColor :: CapExpression-    , setBackColor :: CapExpression-    , setDefaultAttr :: CapExpression-    , clearScreen :: CapExpression-    , clearEol :: CapExpression-    , displayAttrCaps :: DisplayAttrCaps-    }--data DisplayAttrCaps = DisplayAttrCaps-    { setAttrStates :: Maybe CapExpression-    , enterStandout :: Maybe CapExpression-    , exitStandout :: Maybe CapExpression-    , enterUnderline :: Maybe CapExpression-    , exitUnderline :: Maybe CapExpression-    , enterReverseVideo :: Maybe CapExpression-    , enterDimMode :: Maybe CapExpression-    , enterBoldMode :: Maybe CapExpression-    }-    --- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422--- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried.-fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int-fdWriteAll outFd ptr len count-    | len <  0  = fail "fdWriteAll: len is less than 0"-    | len == 0  = return count-    | otherwise = do-        writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len)-        let len' = len - writeCount-            ptr' = ptr `plusPtr` writeCount-            count' = count + writeCount-        fdWriteAll outFd ptr' len' count'--sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()-sendCapToTerminal t cap capParams = do-    outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams--{- | Uses terminfo for all control codes. While this should provide the most compatible terminal- - terminfo does not support some features that would increase efficiency and improve compatibility:- -- -  * determine the character encoding supported by the terminal. Should this be taken from the LANG- - environment variable?  - -- -  * Provide independent string capabilities for all display attributes.- - - - todo: Some display attributes like underline and bold have independent string capabilities that- - should be used instead of the generic "sgr" string capability.- -}-reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output-reserveTerminal termName outFd = liftIO $ do-    ti <- Terminfo.setupTerm termName-    -- assumes set foreground always implies set background exists.-    -- if set foreground is not set then all color changing style attributes are filtered.-    msetaf <- probeCap ti "setaf"-    msetf <- probeCap ti "setf"-    let (noColors, useAlt, setForeCap) -            = case msetaf of-                Just setaf -> (False, False, setaf)-                Nothing -> case msetf of-                    Just setf -> (False, True, setf)-                    Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)-    msetab <- probeCap ti "setab"-    msetb <- probeCap ti "setb"-    let set_back_cap -            = case msetab of-                Nothing -> case msetb of-                    Just setb -> setb-                    Nothing -> error $ "no back color support for terminal " ++ termName-                Just setab -> setab-    terminfoCaps <- pure TerminfoCaps-        <*> probeCap ti "smcup"-        <*> probeCap ti "rmcup"-        <*> requireCap ti "cup"-        <*> probeCap ti "cnorm"-        <*> probeCap ti "civis"-        <*> pure noColors-        <*> pure useAlt-        <*> pure setForeCap-        <*> pure set_back_cap-        <*> requireCap ti "sgr0"-        <*> requireCap ti "clear"-        <*> requireCap ti "el"-        <*> currentDisplayAttrCaps ti-    newAssumedStateRef <- newIORef initialAssumedState-    let t = Output-            { terminalID = termName-            , releaseTerminal = liftIO $ do-                sendCap setDefaultAttr []-                maybeSendCap cnorm []-            , reserveDisplay = liftIO $ do-                -- If there is no support for smcup: Clear the screen and then move the mouse to the-                -- home position to approximate the behavior.-                maybeSendCap smcup []-                sendCap clearScreen []-            , releaseDisplay = liftIO $ do-                maybeSendCap rmcup []-                maybeSendCap cnorm []-            , displayBounds = do-                rawSize <- liftIO $ getWindowSize outFd-                case rawSize of-                    (w, h)  | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize-                            | otherwise      -> return (w,h)-            , outputByteBuffer = \outBytes -> do-                let (fptr, offset, len) = toForeignPtr outBytes-                actualLen <- withForeignPtr fptr-                             $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0-                when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "-                  ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen-                  ++ " Please report this bug to vty project."-            , contextColorCount-                = case supportsNoColors terminfoCaps of-                    False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of-                        Nothing -> 8-                        Just v -> toEnum v-                    True -> 1-            , supportsCursorVisibility = isJust $ civis terminfoCaps-            , assumedStateRef = newAssumedStateRef-            -- I think fix would help assure tActual is the only reference. I was having issues-            -- tho.-            , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps-            }-        sendCap s = sendCapToTerminal t (s terminfoCaps)-        maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)-    return t--requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression-requireCap ti capName -    = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of-        Nothing     -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""-        Just capStr -> parseCap capStr--probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)-probeCap ti capName -    = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of-        Nothing     -> return Nothing-        Just capStr -> Just <$> parseCap capStr--parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression-parseCap capStr = do-    case parseCapExpression capStr of-        Left e -> fail $ show e-        Right cap -> return cap--currentDisplayAttrCaps :: ( Applicative m, MonadIO m ) -                       => Terminfo.Terminal -                       -> m DisplayAttrCaps-currentDisplayAttrCaps ti -    =   pure DisplayAttrCaps -    <*> probeCap ti "sgr"-    <*> probeCap ti "smso"-    <*> probeCap ti "rmso"-    <*> probeCap ti "smul"-    <*> probeCap ti "rmul"-    <*> probeCap ti "rev"-    <*> probeCap ti "dim"-    <*> probeCap ti "bold"--foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong--getWindowSize :: Fd -> IO (Int,Int)-getWindowSize fd = do -    (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd-    return (fromIntegral b, fromIntegral a)--terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext-terminfoDisplayContext tActual terminfoCaps r = return dc-    where dc = DisplayContext-            { contextDevice = tActual-            , contextRegion = r-            , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]-            , writeShowCursor = case cnorm terminfoCaps of-                Nothing -> error "this terminal does not support show cursor"-                Just c -> writeCapExpr c []-            , writeHideCursor = case civis terminfoCaps of-                Nothing -> error "this terminal does not support hide cursor"-                Just c -> writeCapExpr c []-            , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps-            , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []-            , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []-            , inlineHack = return ()-            }---- | Portably setting the display attributes is a giant pain in the ass.------ If the terminal supports the sgr capability (which sets the on/off state of each style--- directly ; and, for no good reason, resets the colors to the default) this procedure is used: ------  0. set the style attributes. This resets the fore and back color.------  1, If a foreground color is to be set then set the foreground color------  2. likewise with the background color--- --- If the terminal does not support the sgr cap then:---  if there is a change from an applied color to the default (in either the fore or back color)---  then:------      0. reset all display attributes (sgr0)------      1. enter required style modes------      2. set the fore color if required------      3. set the back color if required------ Entering the required style modes could require a reset of the display attributes. If this is--- the case then the back and fore colors always need to be set if not default.------ This equation implements the above logic.------ \todo This assumes the removal of color changes in the display attributes is done as expected--- with noColors == True. See `limitAttrForDisplay`------ \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I--- haven't measured this or even examined terminal implementations. *shrug*-terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write-terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do-    case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of-        -- The only way to reset either color, portably, to the default is to use either the set-        -- state capability or the set default capability.-        True  -> do-            case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)-                                     (fixedStyle attr )-                                     (styleToApplySeq $ fixedStyle attr) of-                -- only way to reset a color to the defaults-                EnterExitSeq caps -> writeDefaultAttr dc-                                     `mappend` -                                     foldMap (\cap -> writeCapExpr cap []) caps-                                     `mappend`-                                     setColors-                -- implicitly resets the colors to the defaults-                SetState state -> writeCapExpr (fromJust $ setAttrStates -                                                         $ displayAttrCaps -                                                         $ terminfoCaps-                                               )-                                               (sgrArgsForState state)-                                  `mappend`-                                  setColors-        -- Otherwise the display colors are not changing or changing between two non-default-        -- points.-        False -> do-            -- Still, it could be the case that the change in display attributes requires the-            -- colors to be reset because the required capability was not available.-            case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)-                                     (fixedStyle attr)-                                     (styleDiffs diffs) of-                -- Really, if terminals were re-implemented with modern concepts instead of bowing-                -- down to 40 yr old dumb terminal requirements this would be the only case ever-                -- reached!  Changes the style and color states according to the differences with-                -- the currently applied states.-                EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps-                                     `mappend`-                                     writeColorDiff setForeColor (foreColorDiff diffs)-                                     `mappend`-                                     writeColorDiff setBackColor (backColorDiff diffs)-                -- implicitly resets the colors to the defaults-                SetState state -> writeCapExpr (fromJust $ setAttrStates -                                                         $ displayAttrCaps terminfoCaps-                                               )-                                               (sgrArgsForState state)-                                  `mappend` setColors-    where -        colorMap = case useAltColorMap terminfoCaps of-                        False -> ansiColorIndex-                        True -> altColorIndex-        attr = fixDisplayAttr prevAttr reqAttr-        setColors =-            (case fixedForeColor attr of-                Just c -> writeCapExpr (setForeColor terminfoCaps)-                                       [toEnum $ colorMap c]-                Nothing -> mempty)-            `mappend`-            (case fixedBackColor attr of-                Just c -> writeCapExpr (setBackColor terminfoCaps)-                                       [toEnum $ colorMap c]-                Nothing -> mempty)-        writeColorDiff _f NoColorChange-            = mempty-        writeColorDiff _f ColorToDefault-            = error "ColorToDefault is not a possible case for applyColorDiffs"-        writeColorDiff f (SetColor c)-            = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]---- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not--- be supported by the terminal.------ This takes a Color which clearly identifies which pallete to use and computes the index--- into the full 256 color pallete.-ansiColorIndex :: Color -> Int-ansiColorIndex (ISOColor v) = fromEnum v-ansiColorIndex (Color240 v) = 16 + fromEnum v---- | For terminals without setaf/setab--- --- See table in `man terminfo`--- Will error if not in table.-altColorIndex :: Color -> Int-altColorIndex (ISOColor 0) = 0-altColorIndex (ISOColor 1) = 4-altColorIndex (ISOColor 2) = 2-altColorIndex (ISOColor 3) = 6-altColorIndex (ISOColor 4) = 1-altColorIndex (ISOColor 5) = 5-altColorIndex (ISOColor 6) = 3-altColorIndex (ISOColor 7) = 7-altColorIndex (ISOColor v) = fromEnum v-altColorIndex (Color240 v) = 16 + fromEnum v--{- | The sequence of terminfo caps to apply a given style are determined according to these rules.- -- -  1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than- -  the full set display attribute state capability. - -- -  2. If a mode is supposed to be removed but there is not an exit capability defined then the- -  display attributes are reset to defaults then the display attribute state is set.- -- -  3. If a mode is supposed to be applied but there is not an enter capability defined then then- -  display attribute state is set if possible. Otherwise the mode is not applied.- -- -  4. If the display attribute state is being set then just update the arguments to that for any- -  apply/remove.- -- -}-data DisplayAttrSeq-    = EnterExitSeq [CapExpression]-    | SetState DisplayAttrState--data DisplayAttrState = DisplayAttrState-    { applyStandout :: Bool-    , applyUnderline :: Bool-    , applyReverseVideo :: Bool-    , applyBlink :: Bool-    , applyDim :: Bool-    , applyBold :: Bool-    }--sgrArgsForState :: DisplayAttrState -> [CapParam]-sgrArgsForState attrState = map (\b -> if b then 1 else 0)-    [ applyStandout attrState-    , applyUnderline attrState-    , applyReverseVideo attrState-    , applyBlink attrState-    , applyDim attrState-    , applyBold attrState-    , False -- invis-    , False -- protect-    , False -- alt char set-    ]--reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq-reqDisplayCapSeqFor caps s diffs-    -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap-    -- then either the state needs to be set or the attribute change ignored.-    = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of-        -- If all the diffs have an enter-exit cap then just use those-        ( False, _    ) -> EnterExitSeq $ map enterExitCap diffs-        -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out-        -- all unsupported diffs and just apply the rest-        ( True, False ) -> EnterExitSeq $ map enterExitCap -                                        $ filter (not . noEnterExitCap) diffs-        -- if not all the diffs have an enter-exit can and there is a set state cap then just use-        -- the set state cap.-        ( True, True  ) -> SetState $ stateForStyle s-    where-        noEnterExitCap ApplyStandout = isNothing $ enterStandout caps-        noEnterExitCap RemoveStandout = isNothing $ exitStandout caps-        noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps-        noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps-        noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps-        noEnterExitCap RemoveReverseVideo = True-        noEnterExitCap ApplyBlink = True-        noEnterExitCap RemoveBlink = True-        noEnterExitCap ApplyDim = isNothing $ enterDimMode caps-        noEnterExitCap RemoveDim = True-        noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps-        noEnterExitCap RemoveBold = True-        enterExitCap ApplyStandout = fromJust $ enterStandout caps-        enterExitCap RemoveStandout = fromJust $ exitStandout caps-        enterExitCap ApplyUnderline = fromJust $ enterUnderline caps-        enterExitCap RemoveUnderline = fromJust $ exitUnderline caps-        enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps-        enterExitCap ApplyDim = fromJust $ enterDimMode caps-        enterExitCap ApplyBold = fromJust $ enterBoldMode caps-        enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."--stateForStyle :: Style -> DisplayAttrState-stateForStyle s = DisplayAttrState-    { applyStandout = isStyleSet standout-    , applyUnderline = isStyleSet underline-    , applyReverseVideo = isStyleSet reverseVideo-    , applyBlink = isStyleSet blink-    , applyDim = isStyleSet dim-    , applyBold = isStyleSet bold-    }-    where isStyleSet = hasStyle s--styleToApplySeq :: Style -> [StyleStateChange]-styleToApplySeq s = concat-    [ applyIfRequired ApplyStandout standout-    , applyIfRequired ApplyUnderline underline-    , applyIfRequired ApplyReverseVideo reverseVideo-    , applyIfRequired ApplyBlink blink-    , applyIfRequired ApplyDim dim-    , applyIfRequired ApplyBlink bold-    ]-    where -        applyIfRequired op flag -            = if 0 == (flag .&. s)-                then []-                else [op]-
− src/Graphics/Vty/Output/XTermColor.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE CPP #-}--#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif---- Copyright 2009-2010 Corey O'Connor-module Graphics.Vty.Output.XTermColor ( reserveTerminal )-    where--import Graphics.Vty.Output.Interface-import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased--import Blaze.ByteString.Builder (writeToByteString)-import Blaze.ByteString.Builder.Word (writeWord8)--import Control.Monad (void)-import Control.Monad.Trans--import System.Posix.IO (fdWrite)-import System.Posix.Types (Fd)--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-import Data.Foldable (foldMap)-#endif---- | Initialize the display to UTF-8. -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output-reserveTerminal variant outFd = liftIO $ do-    let flushedPut = void . fdWrite outFd-    -- If the terminal variant is xterm-color use xterm instead since, more often than not,-    -- xterm-color is broken.-    let variant' = if variant == "xterm-color" then "xterm" else variant-    flushedPut setUtf8CharSet-    t <- TerminfoBased.reserveTerminal variant' outFd-    let t' = t-             { terminalID = terminalID t ++ " (xterm-color)"-             , releaseTerminal = do-                 liftIO $ flushedPut setDefaultCharSet-                 releaseTerminal t-             , mkDisplayContext = \tActual r -> do-                dc <- mkDisplayContext t tActual r-                return $ dc { inlineHack = xtermInlineHack t' }-             }-    return t'---- | These sequences set xterm based terminals to UTF-8 output.------ \todo I don't know of a terminfo cap that is equivalent to this.-setUtf8CharSet, setDefaultCharSet :: String-setUtf8CharSet = "\ESC%G"-setDefaultCharSet = "\ESC%@"---- | I think xterm is broken: Reseting the background color as the first bytes serialized on a--- new line does not effect the background color xterm uses to clear the line. Which is used--- *after* the next newline.-xtermInlineHack :: Output -> IO ()-xtermInlineHack t = do-    let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"-    outputByteBuffer t $ writeToByteString writeReset-
src/Graphics/Vty/Picture.hs view
@@ -1,105 +1,128 @@-{-# LANGUAGE BangPatterns #-}--- | The 'Picture' data structure is representative of the final terminal view.------ A 'Picture' is a background paired with a layer of 'Image's.-module Graphics.Vty.Picture ( module Graphics.Vty.Picture-                            , module Graphics.Vty.Image-                            )-    where+-- A 'Picture' is a background paired with a set of 'Image' layers. The+-- 'Picture' data structure is representative of the final terminal+-- view.+module Graphics.Vty.Picture+  ( Picture(..)+  , Cursor(..)+  , Background(..)+  , emptyPicture+  , addToTop+  , addToBottom+  , picForImage+  , picForLayers+  , picImage+  )+where  import Graphics.Vty.Image+import Graphics.Vty.Attributes  import Control.DeepSeq --- | The type of images to be displayed using 'update'.  +-- | A Vty picture. ----- Can be constructed directly or using `picForImage`. Which provides an initial instance with--- reasonable defaults for picCursor and picBackground.+-- These can be constructed directly or using `picForImage`. data Picture = Picture     { picCursor :: Cursor+    -- ^ The picture's cursor.     , picLayers :: [Image]+    -- ^ The picture's image layers (top-most first).     , picBackground :: Background-    }--instance Show Picture where-    show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??"+    -- ^ The picture's background to be displayed in locations with no+    -- Image data.+    } deriving (Eq, Show)  instance NFData Picture where     rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () --- | a picture with no cursor, background or image layers+-- | A picture with no cursor, background or image layers. emptyPicture :: Picture emptyPicture = Picture NoCursor [] ClearBackground --- | The given 'Image' is added as the top layer of the 'Picture'+-- | Add an 'Image' as the top-most layer of a 'Picture'. addToTop :: Picture -> Image -> Picture addToTop p i = p {picLayers = i : picLayers p} --- | The given 'Image' is added as the bottom layer of the 'Picture'+-- | Add an 'Image' as the bottom-most layer of a 'Picture'. addToBottom :: Picture -> Image -> Picture addToBottom p i = p {picLayers = picLayers p ++ [i]} --- | Create a picture for display for the given image. The picture will not have a displayed cursor--- and no background pattern (ClearBackground) will be used.+-- | Create a picture from the given image. The picture will not have a+-- displayed cursor and no background pattern (ClearBackground) will be+-- used. picForImage :: Image -> Picture-picForImage i = Picture +picForImage i = Picture     { picCursor = NoCursor     , picLayers = [i]     , picBackground = ClearBackground     } --- | Create a picture for display with the given layers. Ordered top to bottom.+-- | Create a picture with the given layers, top-most first. ----- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be--- used.--- --- The first 'Image' is the top layer.+-- The picture will not have a displayed cursor and no background+-- pattern (ClearBackgroun) will be used. picForLayers :: [Image] -> Picture-picForLayers is = Picture +picForLayers is = Picture     { picCursor = NoCursor     , picLayers = is     , picBackground = ClearBackground     } --- | A picture can be configured either to not show the cursor or show the cursor at the specified--- character position. ------ There is not a 1 to 1 map from character positions to a row and column on the screen due to--- characters that take more than 1 column.+-- | A picture can be configured to hide the cursor or to show the+-- cursor at the specified character position. ----- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the--- output region. In this case the cursor will not be shown.-data Cursor = -      NoCursor-    | Cursor Int Int+-- There is not a 1:1 map from character positions to a row and column+-- on the screen due to characters that take more than 1 column.+data Cursor =+    -- | Hide the cursor+    NoCursor+    -- | Set the terminal's cursor position without displaying a cursor+    -- character. This is important for accessibility with screen+    -- readers where a cursor position needs to be reported but we may+    -- not want to show a block cursor in that location for cosmetic+    -- reasons. The boolean argument indicates whether the positioning+    -- should be absolute as with 'AbsoluteCursor' ('True') or logical+    -- as with 'Cursor' ('False').+    | PositionOnly !Bool !Int !Int+    -- | Show the cursor at the given logical column accounting for+    -- character width in the presence of multi-column characters.+    | Cursor !Int !Int+    -- | Show the cursor at the given absolute terminal column and row+    | AbsoluteCursor !Int !Int+    deriving (Eq, Show)  instance NFData Cursor where-    rnf NoCursor = ()-    rnf (Cursor w h) = w `seq` h `seq` ()+    rnf c = c `seq` () --- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the--- layer below or is blank if the bottom layer. Or the background pattern is a character and a--- display attribute. If the display attribute used previously should be used for a background fill--- then use `currentAttr` for the background attribute.+-- | A 'Picture' has a background pattern. The background is either: ----- \todo The current attribute is always set to the default attributes at the start of updating the--- screen to a picture.+-- * ClearBackground, which shows the layer below or is blank if the+--   bottom layer+-- * A character and a display attribute+--+-- If the display attribute used previously should be used for a+-- background fill then use `currentAttr` for the background attribute. data Background-    = Background +    = Background     { backgroundChar :: Char     , backgroundAttr :: Attr     }-     -- | A ClearBackground is: +     -- | A ClearBackground is:      --      -- * the space character if there are remaining non-skip ops      --      -- * End of line if there are no remaining non-skip ops.     | ClearBackground+    deriving (Eq, Show)  instance NFData Background where     rnf (Background c a) = c `seq` a `seq` ()     rnf ClearBackground = () --- | Compatibility with applications that do not use more than a single layer.+-- | Return the top-most 'Image' layer for a picture. This is unsafe for+-- 'Picture's without at least one layer.+--+-- This is provided for compatibility with applications that do not use+-- more than a single layer. picImage :: Picture -> Image picImage = head . picLayers
src/Graphics/Vty/PictureToSpans.hs view
@@ -1,21 +1,16 @@ -- Copyright Corey O'Connor<coreyoconnor@gmail.com> {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-} -#ifndef MIN_VERSION_base-#defined MIN_VERSION_base(x,y,z) 1-#endif--{- | Transforms an image into rows of operations.- -}-module Graphics.Vty.PictureToSpans where--import Graphics.Vty.Prelude+-- | Transforms an image into rows of operations.+module Graphics.Vty.PictureToSpans+  ( displayOpsForPic+  )+where +import Graphics.Vty.Attributes (Attr, currentAttr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal import Graphics.Vty.Picture@@ -23,15 +18,10 @@  import Lens.Micro import Lens.Micro.Mtl-import Lens.Micro.TH+import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state )--#if __GLASGOW_HASKELL__ < 708-import Control.Monad.ST.Strict hiding ( unsafeIOToST )-#else import Control.Monad.ST.Strict-#endif  import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..))@@ -39,70 +29,77 @@  import qualified Data.Text.Lazy as TL -#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (mappend)-#endif- type MRowOps s = MVector s SpanOps -type MSpanOps s = MVector s SpanOp- -- transform plus clip. More or less. data BlitState = BlitState-    -- we always snoc to the operation vectors. Thus the columnOffset = length of row at rowOffset-    -- although, one possibility is to merge layers right in snocOp (naming it something else, of-    -- course). In which case columnnOffset would be applicable.-    -- Right now we need it to exist.+    -- we always snoc to the operation vectors. Thus the columnOffset =+    -- length of row at rowOffset although, one possibility is to merge+    -- layers right in snocOp (naming it something else, of course). In+    -- which case columnnOffset would be applicable. Right now we need+    -- it to exist.     { _columnOffset :: Int     , _rowOffset :: Int-    -- clip coordinate space is in image space. Which means it's >= 0 and < imageWidth.+    -- clip coordinate space is in image space. Which means it's >= 0+    -- and < imageWidth.     , _skipColumns :: Int     -- >= 0 and < imageHeight     , _skipRows :: Int-    -- includes consideration of skipColumns. In display space.-    -- The number of columns from the next column to be defined to the end of the display for the-    -- row.+    -- includes consideration of skipColumns. In display space. The+    -- number of columns from the next column to be defined to the end+    -- of the display for the row.     , _remainingColumns :: Int     -- includes consideration of skipRows. In display space.     , _remainingRows :: Int     } -makeLenses ''BlitState+columnOffset :: Lens' BlitState Int+columnOffset = lens _columnOffset (\e v -> e { _columnOffset = v }) +rowOffset :: Lens' BlitState Int+rowOffset = lens _rowOffset (\e v -> e { _rowOffset = v })++skipColumns :: Lens' BlitState Int+skipColumns = lens _skipColumns (\e v -> e { _skipColumns = v })++skipRows :: Lens' BlitState Int+skipRows = lens _skipRows (\e v -> e { _skipRows = v })++remainingColumns :: Lens' BlitState Int+remainingColumns = lens _remainingColumns (\e v -> e { _remainingColumns = v })++remainingRows :: Lens' BlitState Int+remainingRows = lens _remainingRows (\e v -> e { _remainingRows = v })+ data BlitEnv s = BlitEnv     { _region :: DisplayRegion     , _mrowOps :: MRowOps s     } -makeLenses ''BlitEnv+region :: Lens' (BlitEnv s) DisplayRegion+region = lens _region (\e r -> e { _region = r }) +mrowOps :: Lens' (BlitEnv s) (MRowOps s)+mrowOps = lens _mrowOps (\e r -> e { _mrowOps = r })+ type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a --- | Produces the span ops that will render the given picture, possibly cropped or padded, into the--- specified region.+-- | Produces the span ops that will render the given picture, possibly+-- cropped or padded, into the specified region. displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r) --- | Returns the DisplayOps for an image rendered to a window the size of the image.------ largerly used only for debugging.-displayOpsForImage :: Image -> DisplayOps-displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)- -- | Produces the span ops for each layer then combines them.------ TODO: a fold over a builder function. start with span ops that are a bg fill of the entire--- region. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r     | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0     | otherwise = do-        layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)+        layerOps <- mapM (`buildSpans` r) (picLayers pic)         case layerOps of-            []    -> fail "empty picture"+            []    -> error "empty picture"             [ops] -> substituteSkips (picBackground pic) ops-            -- instead of merging ops after generation the merging can be performed as part of-            -- snocOp.+            -- instead of merging ops after generation the merging can+            -- be performed as part of snocOp.             topOps : lowerOps -> do                 ops <- foldM mergeUnder topOps lowerOps                 substituteSkips (picBackground pic) ops@@ -111,23 +108,25 @@ substituteSkips ClearBackground ops = do     forM_ [0 .. MVector.length ops - 1] $ \row -> do         rowOps <- MVector.read ops row-        -- the image operations assure that background fills are combined.-        -- clipping a background fill does not split the background fill.-        -- merging of image layers can split a skip, but only by the insertion of a non skip.-        -- all this combines to mean we can check the last operation and remove it if it's a skip-        -- todo: or does it?+        -- the image operations assure that background fills are+        -- combined. clipping a background fill does not split the+        -- background fill. merging of image layers can split a skip,+        -- but only by the insertion of a non skip. all this combines to+        -- mean we can check the last operation and remove it if it's a+        -- skip         let rowOps' = case Vector.last rowOps of                         Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w                         _      -> rowOps-        -- now all the skips can be replaced by replications of ' ' of the required width.+        -- now all the skips can be replaced by replications of ' ' of+        -- the required width.         let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'         MVector.write ops row rowOps''     return ops substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do-    -- At this point we decide if the background character is single column or not.-    -- obviously, single column is easier.+    -- At this point we decide if the background character is single+    -- column or not. obviously, single column is easier.     case safeWcwidth backgroundChar of-        w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar+        w | w == 0 -> error $ "invalid background character " ++ show backgroundChar           | w == 1 -> do                 forM_ [0 .. MVector.length ops - 1] $ \row -> do                     rowOps <- MVector.read ops row@@ -149,12 +148,12 @@         MVector.write upper row rowOps     return upper --- fugly mergeRowUnder :: SpanOps -> SpanOps -> SpanOps-mergeRowUnder upperRowOps lowerRowOps =-    onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps+mergeRowUnder upperRowOps =+    onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps)     where-        -- H: it will never be the case that we are out of upper ops before lower ops.+        -- H: it will never be the case that we are out of upper ops+        -- before lower ops.         onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps         onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =             let lowerOps' = dropOps w lowerOps@@ -173,7 +172,7 @@  swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f-    where f (Skip ow) = let txt = TL.pack $ replicate ow c+    where f (Skip ow) = let txt = TL.take (toEnum ow) $ TL.repeat c                         in TextSpan a ow ow txt           f v = v @@ -189,30 +188,32 @@                       in TextSpan a ow cw txt         f v = v --- | Builds a vector of row operations that will output the given picture to the terminal.+-- | Builds a vector of row operations that will output the given+-- picture to the terminal. -- -- Crops to the given display region.------ \todo I'm pretty sure there is an algorithm that does not require a mutable buffer. buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s) buildSpans image outRegion = do     -- First we create a mutable vector for each rows output operations.     outOps <- MVector.replicate (regionHeight outRegion) Vector.empty-    -- \todo I think building the span operations in display order would provide better performance.-    -- However, I got stuck trying to implement an algorithm that did this. This will be considered-    -- as a possible future optimization. +    -- It's possible that building the span operations in display order+    -- would provide better performance.     ---    -- A depth first traversal of the image is performed.  ordered according to the column range-    -- defined by the image from least to greatest.  The output row ops will at least have the-    -- region of the image specified. Iterate over all output rows and output background fills for-    -- all unspecified columns.+    -- A depth first traversal of the image is performed. ordered+    -- according to the column range defined by the image from least+    -- to greatest. The output row ops will at least have the region+    -- of the image specified. Iterate over all output rows and output+    -- background fills for all unspecified columns.     ---    -- The images are made into span operations from left to right. It's possible that this could-    -- easily be made to assure top to bottom output as well. +    -- The images are made into span operations from left to right. It's+    -- possible that this could easily be made to assure top to bottom+    -- output as well.     when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do-        -- The ops builder recursively descends the image and outputs span ops that would-        -- display that image. The number of columns remaining in this row before exceeding the-        -- bounds is also provided. This is used to clip the span ops produced to the display.+        -- The ops builder recursively descends the image and outputs+        -- span ops that would display that image. The number of columns+        -- remaining in this row before exceeding the bounds is also+        -- provided. This is used to clip the span ops produced to the+        -- display.         let fullBuild = do                 startImageBuild image                 -- Fill in any unspecified columns with a skip.@@ -223,7 +224,8 @@         return ()     return outOps --- | Add the operations required to build a given image to the current set of row operations.+-- | Add the operations required to build a given image to the current+-- set of row operations. startImageBuild :: Image -> BlitM s () startImageBuild image = do     outOfBounds <- isOutOfBounds image <$> get@@ -231,23 +233,22 @@  isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s-    | s ^. remainingColumns <= 0              = True-    | s ^. remainingRows    <= 0              = True+    | s ^. remainingColumns <= 0             = True+    | s ^. remainingRows    <= 0             = True     | s ^. skipColumns      >= imageWidth i  = True     | s ^. skipRows         >= imageHeight i = True     | otherwise = False --- | This adds an image that might be partially clipped to the output ops.------ This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom--- implementations are odd. They pass the current tests but something seems terribly wrong about all--- this.+-- | This adds an image that might be partially clipped to the output+-- ops.+-- This is a very touchy algorithm. Too touchy. For instance, the+-- Crop implementations is odd. They pass the current tests but+-- something seems terribly wrong about all this. ----- \todo prove this cannot be called in an out of bounds case. addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do-    -- TODO: assumption that text spans are only 1 row high.+    -- This assumes that text spans are only 1 row high.     s <- use skipRows     when (s < 1) $ do         leftClip <- use skipColumns@@ -259,43 +260,35 @@                  in addUnclippedText a textStr'             else addUnclippedText a textStr addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do-    addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset-                           (imageHeight topImage)-                           topImage-                           bottomImage-                           oh+    when (imageHeight topImage + imageHeight bottomImage > 0) $+        addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset+                            (imageHeight topImage)+                            topImage+                            bottomImage+                            oh addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do-    addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset-                           (imageWidth leftImage)-                           leftImage-                           rightImage-                           ow+    when (imageWidth leftImage + imageWidth rightImage > 0) $+        addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset+                            (imageWidth leftImage)+                            leftImage+                            rightImage+                            ow addMaybeClipped BGFill {outputWidth, outputHeight} = do     s <- get     let outputWidth'  = min (outputWidth  - s^.skipColumns) (s^.remainingColumns)         outputHeight' = min (outputHeight - s^.skipRows   ) (s^.remainingRows)     y <- use rowOffset     forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth')-addMaybeClipped CropRight {croppedImage, outputWidth} = do-    s <- use skipColumns-    r <- use remainingColumns-    let x = outputWidth - s-    when (x < r) $ remainingColumns .= x-    addMaybeClipped croppedImage-addMaybeClipped CropLeft {croppedImage, leftSkip} = do+addMaybeClipped Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight} = do+    sx <- use skipColumns     skipColumns += leftSkip-    addMaybeClipped croppedImage-addMaybeClipped CropBottom {croppedImage, outputHeight} = do-    s <- use skipRows-    r <- use remainingRows-    let x = outputHeight - s-    when (x < r) $ remainingRows .= x-    addMaybeClipped croppedImage-addMaybeClipped CropTop {croppedImage, topSkip} = do+    modifying remainingColumns (min (outputWidth - sx))+    sy <- use skipRows     skipRows += topSkip+    modifying remainingRows (min (outputHeight - sy))     addMaybeClipped croppedImage -addMaybeClippedJoin :: forall s . String +addMaybeClippedJoin :: forall s . String                        -> Lens BlitState BlitState Int Int                        -> Lens BlitState BlitState Int Int                        -> Lens BlitState BlitState Int Int@@ -306,14 +299,13 @@                        -> BlitM s () addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do     state <- get-    when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"+    when (state^.remaining <= 0) $ error $ name ++ " with remaining <= 0"     case state^.skip of-        s -- TODO: check if clipped in other dim. if not use addUnclipped-          | s >= size -> fail $ name ++ " on fully clipped"-          | s == 0    -> if state^.remaining > i0Dim +        s | s > size -> put $ state & skip %~ subtract size+          | s == 0    -> if state^.remaining > i0Dim                             then do                                 addMaybeClipped i0-                                put $ state & offset +~ i0Dim & remaining -~ i0Dim+                                put $ state & offset %~ (+ i0Dim) & remaining %~ subtract i0Dim                                 addMaybeClipped i1                             else addMaybeClipped i0           | s < i0Dim  ->@@ -322,26 +314,26 @@                     then addMaybeClipped i0                     else do                         addMaybeClipped i0-                        put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0+                        put $ state & offset %~ (+ i0Dim') & remaining %~ subtract i0Dim' & skip .~ 0                         addMaybeClipped i1           | s >= i0Dim -> do-                put $ state & skip -~ i0Dim+                put $ state & skip %~ subtract i0Dim                 addMaybeClipped i1-        _ -> fail $ name ++ " has unhandled skip class"+        _ -> error $ name ++ " has unhandled skip class" -addUnclippedText :: Attr -> DisplayText -> BlitM s ()+addUnclippedText :: Attr -> TL.Text -> BlitM s () addUnclippedText a txt = do     let op = TextSpan a usedDisplayColumns                       (fromIntegral $ TL.length txt)                       txt-        usedDisplayColumns = wcswidth $ TL.unpack txt+        usedDisplayColumns = wctlwidth txt     use rowOffset >>= snocOp op  addRowCompletion :: DisplayRegion -> Int -> BlitM s () addRowCompletion displayRegion row = do     allRowOps <- view mrowOps     rowOps <- lift $ lift $ MVector.read allRowOps row-    let endX = spanOpsEffectedColumns rowOps+    let endX = spanOpsAffectedColumns rowOps     when (endX < regionWidth displayRegion) $ do         let ow = regionWidth displayRegion - endX         snocOp (Skip ow) row@@ -354,12 +346,6 @@     lift $ lift $ do         ops <- MVector.read theMrowOps row         let ops' = Vector.snoc ops op-        when (spanOpsEffectedColumns ops' > regionWidth theRegion)-             $ fail $ "row " ++ show row ++ " now exceeds region width"+        when (spanOpsAffectedColumns ops' > regionWidth theRegion)+             $ error $ "row " ++ show row ++ " now exceeds region width"         MVector.write theMrowOps row ops'--(-~) :: Num a => ASetter s t a a -> a -> s -> t-l -~ n = over l (subtract n)--(+~) :: Num a => ASetter s t a a -> a -> s -> t-l +~ n = over l (n +)
− src/Graphics/Vty/Prelude.hs 
@@ -1,18 +0,0 @@--- | Prelude for Vty modules. Not particularly useful outside of Vty.-module Graphics.Vty.Prelude ( module Graphics.Vty.Prelude-                            , module Control.Applicative-                            , module Control.Monad-                            )-where--import Control.Applicative hiding ((<|>))-import Control.Monad---- | Named alias for a Int pair-type DisplayRegion = (Int,Int)--regionWidth :: DisplayRegion -> Int-regionWidth = fst--regionHeight :: DisplayRegion -> Int-regionHeight = snd
src/Graphics/Vty/Span.hs view
@@ -1,23 +1,30 @@ -- Copyright Corey O'Connor-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-}-{- | A picture is translated into a sequences of state changes and character spans.- - State changes are currently limited to new attribute values. The attribute is applied to all- - following spans. Including spans of the next row.  The nth element of the sequence represents the- - nth row (from top to bottom) of the picture to render.- -- - A span op sequence will be defined for all rows and columns (and no more) of the region provided- - with the picture to `spansForPic`.- -- - todo: Partition attribute changes into multiple categories according to the serialized- - representation of the various attributes.- -}+-- | A picture is translated into a sequences of state changes and+-- character spans. The attribute is applied to all following spans,+-- including spans of the next row. The nth element of the sequence+-- represents the nth row (from top to bottom) of the picture to render.+--+-- A span op sequence will be defined for all rows and columns (and no+-- more) of the region provided with the picture to 'spansForPic'. module Graphics.Vty.Span-    where+  ( SpanOp(..)+  , columnsToCharOffset+  , spanOpHasWidth -import Graphics.Vty.Prelude+  , SpanOps+  , spanOpsAffectedColumns+  , splitOpsAt+  , dropOps +  , DisplayOps+  , displayOpsRows+  , displayOpsColumns+  , affectedRegion+  )+where++import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) @@ -25,40 +32,40 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector --- | This represents an operation on the terminal. Either an attribute change or the output of a--- text string.+-- | This represents an operation on the terminal: either an attribute+-- change or the output of a text string. data SpanOp =-    -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF-    -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width-    -- TextSpan [Attr] [output width in columns] [number of characters] [data]-      TextSpan +    -- | A span of UTF-8 text occupies a specific number of screen space+    -- columns. A single UTF character does not necessarily represent 1+    -- colunm. See Codec.Binary.UTF8.Width TextSpan [Attr] [output width+    -- in columns] [number of characters] [data]+      TextSpan       { textSpanAttr :: !Attr       , textSpanOutputWidth :: !Int       , textSpanCharWidth :: !Int-      , textSpanText :: DisplayText+      , textSpanText :: TL.Text       }-    -- | Skips the given number of columns-    -- A skip is transparent.... maybe? I am not sure how attribute changes interact.-    -- todo: separate from this type.+    -- | Skips the given number of columns.     | Skip !Int-    -- | Marks the end of a row. specifies how many columns are remaining. These columns will not be-    -- explicitly overwritten with the span ops. The terminal is require to assure the remaining+    -- | Marks the end of a row. Specifies how many columns are+    -- remaining. These columns will not be explicitly overwritten with+    -- the span ops. The terminal is require to assure the remaining     -- columns are clear.-    -- todo: separate from this type.     | RowEnd !Int     deriving Eq --- | vector of span operations. executed in succession. This represents the operations required to--- render a row of the terminal. The operations in one row may effect subsequent rows.--- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground--- color is changed.+-- | A vector of span operations executed in succession. This represents+-- the operations required to render a row of the terminal. The+-- operations in one row may affect subsequent rows. For example,+-- setting the foreground color in one row will affect all subsequent+-- rows until the foreground color is changed. type SpanOps = Vector SpanOp  dropOps :: Int -> SpanOps -> SpanOps dropOps w = snd . splitOpsAt w  splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)-splitOpsAt inW inOps = splitOpsAt' inW inOps+splitOpsAt = splitOpsAt'     where         splitOpsAt' 0 ops = (Vector.empty, ops)         splitOpsAt' remainingColumns ops = case Vector.head ops of@@ -89,9 +96,9 @@                      , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops)                      )             RowEnd _ -> error "cannot split ops containing a row end"-         --- | vector of span operation vectors for display. One per row of the output region.+-- | A vector of span operation vectors for display, one per row of the+-- output region. type DisplayOps = Vector SpanOps  instance Show SpanOp where@@ -99,40 +106,39 @@     show (Skip ow) = "Skip(" ++ show ow ++ ")"     show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" --- | Number of columns the DisplayOps are defined for+-- | The number of columns the DisplayOps are defined for. ----- All spans are verified to define same number of columns. See: VerifySpanOps+-- All spans are verified to define same number of columns. displayOpsColumns :: DisplayOps -> Int-displayOpsColumns ops +displayOpsColumns ops     | Vector.length ops == 0 = 0     | otherwise              = Vector.length $ Vector.head ops --- | Number of rows the DisplayOps are defined for+-- | The number of rows the DisplayOps are defined for. displayOpsRows :: DisplayOps -> Int-displayOpsRows ops = Vector.length ops+displayOpsRows = Vector.length -effectedRegion :: DisplayOps -> DisplayRegion-effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)+affectedRegion :: DisplayOps -> DisplayRegion+affectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) --- | The number of columns a SpanOps effects.-spanOpsEffectedColumns :: SpanOps -> Int-spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps-    where -        spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w-        spanOpsEffectedColumns' t (Skip w) = t + w-        spanOpsEffectedColumns' t (RowEnd w) = t + w+-- | The number of columns a SpanOps affects.+spanOpsAffectedColumns :: SpanOps -> Int+spanOpsAffectedColumns inOps = Vector.foldl' spanOpsAffectedColumns' 0 inOps+    where+        spanOpsAffectedColumns' t (TextSpan _ w _ _ ) = t + w+        spanOpsAffectedColumns' t (Skip w) = t + w+        spanOpsAffectedColumns' t (RowEnd w) = t + w --- | The width of a single SpanOp in columns+-- | The width of a single SpanOp in columns. spanOpHasWidth :: SpanOp -> Maybe (Int, Int) spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow) spanOpHasWidth (Skip ow) = Just (ow,ow) spanOpHasWidth (RowEnd ow) = Just (ow,ow) --- | returns the number of columns to the character at the given position in the span op+-- | The number of columns to the character at the given position in the+-- span op. columnsToCharOffset :: Int -> SpanOp -> Int columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =-    let str = TL.unpack utf8Str-    in wcswidth (take cx str)+    wctlwidth (TL.take (fromIntegral cx) utf8Str) columnsToCharOffset cx (Skip _) = cx columnsToCharOffset cx (RowEnd _) = cx-
+ src/Graphics/Vty/UnicodeWidthTable/IO.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+module Graphics.Vty.UnicodeWidthTable.IO+  ( readUnicodeWidthTable+  , parseUnicodeWidthTable+  , writeUnicodeWidthTable+  )+where++import Control.Monad (when, forM)+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Lazy as BSL+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif++import Graphics.Vty.UnicodeWidthTable.Types++-- | Load a binary unicode width table from the specified file.+--+-- This either returns a successfully parsed table or a table parsing+-- error message. This does not handle I/O exceptions.+readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)+readUnicodeWidthTable path = parseUnicodeWidthTable <$> BSL.readFile path++-- | Parse a binary unicode width table.+parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable+parseUnicodeWidthTable bs =+    case runGetOrFail tableParser bs of+        Left (_, _, msg) ->+            Left msg++        -- Even if we parsed a table, leftover bytes indicate something+        -- could be wrong.+        Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->+            Left $ "Error: " <> show (BSL.length remainingBytes) <>+                   " byte(s) left unconsumed"++        Right (_, _, table) ->+            Right table++-- | Write the unicode width table to the specified path.+--+-- This does not handle I/O exceptions.+writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()+writeUnicodeWidthTable path table = do+    let body = runPut (tableV1Writer table)+    BSL.writeFile path body++-- | Width table magic bytes for use in the binary format.+widthTableMagic :: Word32+widthTableMagic = 0xc1a9f7e0++tableParser :: Get UnicodeWidthTable+tableParser = do+    magic <- getWord32le++    when (magic /= widthTableMagic) $+        fail "Table magic number invalid"++    version <- getWord8++    case version of+        1 -> tableV1Parser+        _ -> fail "Table version invalid"++tableV1Parser :: Get UnicodeWidthTable+tableV1Parser = do+    numRanges <- getWord32le++    let parseRange = do+            start <- getWord32le+            size <- getWord32le+            cols <- getWord8+            return WidthTableRange { rangeStart = start+                                   , rangeSize = size+                                   , rangeColumns = cols+                                   }++    ranges <- forM [1..numRanges] $ const parseRange++    return UnicodeWidthTable { unicodeWidthTableRanges = ranges+                             }++tableV1Writer :: UnicodeWidthTable -> Put+tableV1Writer table = do+    -- Magic bytes+    putWord32le widthTableMagic++    -- Version+    putWord8 1++    -- Number of ranges+    let ranges = unicodeWidthTableRanges table+    let numRanges = length ranges+    putWord32le (fromIntegral numRanges)++    -- Ranges+    let putRange r = do+            putWord32le $ rangeStart r+            putWord32le $ rangeSize r+            putWord8 $ rangeColumns r++    mapM_ putRange ranges
+ src/Graphics/Vty/UnicodeWidthTable/Install.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Graphics.Vty.UnicodeWidthTable.Install+  ( TableInstallException(..)+  , installUnicodeWidthTable+  , isCustomTableReady+  )+where++import Control.Monad (when, forM_)+import qualified Control.Exception as E+import GHC.Conc.Sync (withMVar)+import Control.Concurrent.MVar (MVar, newMVar)+import Data.Word (Word8, Word32)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import System.IO.Unsafe (unsafePerformIO)++import Graphics.Vty.UnicodeWidthTable.Types++-- | The lock used to make functions in this module thread-safe.+installLock :: MVar ()+{-# NOINLINE installLock #-}+installLock = unsafePerformIO $ newMVar ()++-- | Returns True if and only if a custom table has been allocated and+-- marked as ready for use.+--+-- This function is thread-safe.+isCustomTableReady :: IO Bool+isCustomTableReady = withInstallLock $ (== 1) <$> c_isCustomTableReady++withInstallLock :: IO a -> IO a+withInstallLock act = withMVar installLock $ const act++-- This is the size of the allocated custom character width table, in+-- character slots. It's important that this be large enough to hold all+-- possible Unicode character values. At the time of this writing, the+-- valid Unicode range is 0 - 0x10ffff, hence this value.+tableSize :: Int+tableSize = 0x110000++-- | Exception type raised by 'installUnicodeWidthTable'.+data TableInstallException =+    TableInitFailure Int Int+    -- ^ The width table could not be initialized. Args: failure status,+    -- requested table size.+    | TableRangeFailure Int WidthTableRange+    -- ^ A code point range could not be configured. Args: failure+    -- status, offending range.+    | TableActivationFailure Int+    -- ^ The table could not be activated. Args: failure status.+    deriving (Eq, Show)++instance E.Exception TableInstallException++-- | Install a custom unicode character width+-- table. Such tables are obtained with+-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and+-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.+--+-- ALERT! This function is probably not what you want to use because+-- it is automatically called by 'Graphics.Vty.mkVty'. You will only+-- ever need to call this function if you want to use functions+-- in 'Graphics.Text.Width' without controlling the terminal with+-- 'Graphics.Vty.mkVty'.+--+-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'+-- function and functions that call it. It does so by+-- changing global state available to the C implementation+-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your+-- program gets consistent results from evaluating calls to+-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table+-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in+-- your program.+--+-- This is best done at Vty startup, and if you use+-- 'Graphics.Vty.mkVty', that function calls this automatically based on+-- the Vty configuration's declared width tables. It is exposed as part+-- of the public API so that applications can call this as needed if+-- they don't want to control the terminal with 'mkVty' but do want to+-- make calls to 'Graphics.Vty.Image.wcwidth'.+--+-- It's also important to note that once a custom table has been+-- installed, it is permanent for the life of the process. No new table+-- can be installed, and the new custom table cannot be removed.+--+-- If this function fails for any reason -- if the table cannot be+-- installed or is invalid, or if a custom table already exists -- this+-- will raise a 'TableInstallException' exception.+--+-- This function is thread-safe.+installUnicodeWidthTable :: UnicodeWidthTable -> IO ()+installUnicodeWidthTable table = withInstallLock $ do+    initResult <- initCustomTable tableSize+    when (initResult /= 0) $+        E.throwIO $ TableInitFailure initResult tableSize++    forM_ (unicodeWidthTableRanges table) $ \r -> do+        result <- setCustomTableRange (rangeStart r)+                                      (rangeSize r)+                                      (rangeColumns r)++        when (result /= 0) $ do+            deallocateCustomTable+            E.throwIO $ TableRangeFailure result r++    actResult <- activateCustomTable+    when (actResult /= 0) $+        E.throwIO $ TableActivationFailure actResult++------------------------------------------------------------------------+-- C imports++foreign import ccall unsafe "vty_init_custom_table"+    initCustomTable :: Int -> IO Int++foreign import ccall unsafe "vty_set_custom_table_range"+    setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int++foreign import ccall unsafe "vty_activate_custom_table"+    activateCustomTable :: IO Int++foreign import ccall unsafe "vty_custom_table_ready"+    c_isCustomTableReady :: IO Int++foreign import ccall unsafe "vty_deallocate_custom_table"+    deallocateCustomTable :: IO ()
+ src/Graphics/Vty/UnicodeWidthTable/Main.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+-- | This module provides a command-line tool implementation for+-- building Vty character width tables and updating the user's local Vty+-- configuration to load them.+--+-- The API is parameterized on a platform-specific function to obtain+-- character widths. For example, on Unix platforms, this could be done+-- with a routine that communicates with the terminal to query it for+-- character widths. On other platforms, such a routine might interact+-- with a system library.+--+-- This tool is provided as a library implementation so that the tool+-- has a consistent interface across platforms and so that it implements+-- the Vty configuration update the same way everywhere.+module Graphics.Vty.UnicodeWidthTable.Main+  ( defaultMain+  )+where++import qualified Control.Exception as E+import Control.Monad (when)+import Data.Maybe (fromMaybe)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs, getProgName)+import System.FilePath (takeDirectory)+import System.Exit (exitFailure)+import System.Console.GetOpt+import Text.Read (readMaybe)++import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName+                           , vtyConfigPath, addConfigWidthMap+                           , ConfigUpdateResult(..)+                           )+import Graphics.Vty.UnicodeWidthTable.IO+import Graphics.Vty.UnicodeWidthTable.Query++data Arg = Help+         | OutputPath String+         | TableUpperBound String+         | UpdateConfig+         | VtyConfigPath String+         deriving (Eq, Show)++options :: Config -> [OptDescr Arg]+options config =+    [ Option "h" ["help"] (NoArg Help)+      "This help output"+    , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")+      ("The maximum Unicode code point to test when building the table " <>+       "(default: " <> (show $ fromEnum $ configBound config) <> ")")+    , Option "p" ["path"] (ReqArg OutputPath "PATH")+      ("The output path to write to (default: " <>+       fromMaybe "<none>" (configOutputPath config) <> ")")+    , Option "u" ["update-config"] (NoArg UpdateConfig)+      "Create or update the Vty configuration file to use the new table (default: no)"+    , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")+      ("Update the specified Vty configuration file path when -u is set (default: " <>+       configPath config <> ")")+    ]++data Config =+    Config { configOutputPath :: Maybe FilePath+           , configBound :: Char+           , configUpdate :: Bool+           , configPath :: FilePath+           }+           deriving (Show)++mkDefaultConfig :: IO Config+mkDefaultConfig = do+    Config <$> terminalWidthTablePath+           <*> pure defaultUnicodeTableUpperBound+           <*> pure False+           <*> vtyConfigPath++usage :: IO ()+usage = do+    config <- mkDefaultConfig+    pn <- getProgName+    putStrLn $ "Usage: " <> pn <> " [options]"+    putStrLn ""+    putStrLn "This tool queries the terminal on stdout to determine the widths"+    putStrLn "of Unicode characters rendered to the terminal. The resulting data"+    putStrLn "is written to a table at the specified output path for later"+    putStrLn "loading by Vty-based applications."+    putStrLn ""++    putStrLn $ usageInfo pn (options config)++updateConfigFromArg :: Arg -> Config -> Config+updateConfigFromArg Help c =+    c+updateConfigFromArg UpdateConfig c =+    c { configUpdate = True }+updateConfigFromArg (VtyConfigPath p) c =+    c { configPath = p }+updateConfigFromArg (TableUpperBound s) c =+    case readMaybe s of+        Nothing -> error $ "Invalid table upper bound: " <> show s+        Just v  -> c { configBound = toEnum v }+updateConfigFromArg (OutputPath p) c =+    c { configOutputPath = Just p }++-- | Run the character width table builder tool using the specified+-- function to obtain character widths. This is intended to be a 'main'+-- implementation, e.g. @main = defaultMain getCharWidth@.+--+-- The tool queries the local terminal in some way (as determined by+-- the provided function) over a wide range of Unicode code points and+-- generates a table of character widths that can subsequently be loaded+-- by Vty-based applications.+--+-- The tool respects the following command-line flags, all of which are+-- optional and have sensible defaults:+--+-- * @-h@/@--help@: help output+-- * @-b@/@--bound@: Unicode code point upper bound to use when building+--   the table.+-- * @-p@/@--path@: the output path where the generated table should be+--   written.+-- * @-u@/@--update-config@: If given, create or update the user's Vty+--   configuration file to use the new table.+-- * @-c@/@--config-path@: the path to the user's Vty configuration.+defaultMain :: (Char -> IO Int) -> IO ()+defaultMain charWidth = do+    defConfig <- mkDefaultConfig+    strArgs <- getArgs+    let (args, unused, errors) = getOpt Permute (options defConfig) strArgs++    when (not $ null errors) $ do+        mapM_ putStrLn errors+        exitFailure++    when ((not $ null unused) || (Help `elem` args)) $ do+        usage+        exitFailure++    let config = foldr updateConfigFromArg defConfig args++    outputPath <- case configOutputPath config of+        Nothing -> do+            putStrLn "Error: could not obtain terminal width table path"+            exitFailure+        Just path -> return path++    putStrLn "Querying terminal:"+    builtTable <- buildUnicodeWidthTable charWidth $ configBound config++    let dir = takeDirectory outputPath+    createDirectoryIfMissing True dir+    writeUnicodeWidthTable outputPath builtTable++    putStrLn $ "\nOutput table written to " <> outputPath++    when (configUpdate config) $ do+        let cPath = configPath config+        Just tName <- currentTerminalName++        result <- E.try $ addConfigWidthMap cPath tName outputPath++        case result of+            Left (e::E.SomeException) -> do+                putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>+                           show e+                exitFailure+            Right ConfigurationCreated -> do+                putStrLn $ "Configuration file created: " <> cPath+            Right ConfigurationModified -> do+                putStrLn $ "Configuration file updated: " <> cPath+            Right (ConfigurationConflict other) -> do+                putStrLn $ "Configuration file not updated: uses a different table " <>+                           "for TERM=" <> tName <> ": " <> other+            Right ConfigurationRedundant -> do+                putStrLn $ "Configuration file not updated: configuration " <>+                           cPath <> " already uses table " <> outputPath <>+                           " for TERM=" <> tName
+ src/Graphics/Vty/UnicodeWidthTable/Query.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TupleSections #-}+module Graphics.Vty.UnicodeWidthTable.Query+  ( buildUnicodeWidthTable+  , defaultUnicodeTableUpperBound+  )+where++import Control.Monad (forM)+import Data.Char (generalCategory, GeneralCategory(..))++import Graphics.Vty.UnicodeWidthTable.Types++shouldConsider :: Char -> Bool+shouldConsider c =+    case generalCategory c of+        Control     -> False+        NotAssigned -> False+        Surrogate   -> False+        _           -> True++-- | Convert a sequence of character/width pairs into a list of+-- run-length encoded ranges. This function assumes the pairs come+-- sorted by character ordinal value. It does not require that the+-- character range is fully covered by the sequence.+--+-- The result of this function is a list of ranges in reverse order+-- relative to the input sequence.+mkRanges :: [(Char, Int)] -> [WidthTableRange]+mkRanges pairs =+    let convertedPairs = convert <$> pairs+        convert (c, i) = (fromIntegral $ fromEnum c, fromIntegral i)++        go Nothing finishedRanges [] = finishedRanges+        go (Just r) finishedRanges [] = r:finishedRanges++        go Nothing finishedRanges ((c, width):rest) =+            go (Just $ WidthTableRange c 1 width) finishedRanges rest++        go (Just r@(WidthTableRange prevCh sz prevWidth)) finishedRanges ((c, width):rest) =+            if c == prevCh + sz && prevWidth == width+            then go (Just (WidthTableRange prevCh (sz + 1) prevWidth)) finishedRanges rest+            else go (Just (WidthTableRange c 1 width)) (r:finishedRanges) rest++    in go Nothing [] convertedPairs++-- The uppermost code point to consider when building Unicode width+-- tables.+defaultUnicodeTableUpperBound :: Char+defaultUnicodeTableUpperBound = '\xe0000'++-- | Construct a unicode character width table. This works by using the+-- provided function to obtain the appropriate width for each character+-- in a wide range of Unicode code points, which on some platforms+-- may perform local terminal operations or may interact with system+-- libraries. Depending on how the provided width function works, this+-- may need to be run only in a terminal that is not actively controlled+-- by a Vty handle.+--+-- The character argument specifies the upper bound code point to test+-- when building the table. This allows callers to decide how much of+-- the Unicode code point space to scan when building the table.+--+-- This does not handle exceptions.+buildUnicodeWidthTable :: (Char -> IO Int) -> Char -> IO UnicodeWidthTable+buildUnicodeWidthTable charWidth tableUpperBound = do+    pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i ->+        (i,) <$> charWidth i++    return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs+                             }
+ src/Graphics/Vty/UnicodeWidthTable/Types.hs view
@@ -0,0 +1,29 @@+module Graphics.Vty.UnicodeWidthTable.Types+  ( UnicodeWidthTable(..)+  , WidthTableRange(..)+  )+where++import Data.Word (Word8, Word32)++-- | A range of code points in a width table.+data WidthTableRange =+    WidthTableRange { rangeStart :: Word32+                    -- ^ The range's starting code point.+                    , rangeSize :: Word32+                    -- ^ The number of code points in the contiguous+                    -- range, beginning with the starting code point+                    -- ('rangeStart').+                    , rangeColumns :: Word8+                    -- ^ The terminal width, in columns, of all of the+                    -- characters corresponding to the code points in+                    -- this range.+                    }+    deriving (Eq, Show)++-- | A run-length-encoded table of Unicode character widths.+data UnicodeWidthTable =+    UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]+                      -- ^ The ranges in the table.+                      }+    deriving (Show)
− test/Verify.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module Verify ( module Verify-              , module Control.Applicative-              , module Control.DeepSeq-              , module Control.Exception-              , module Control.Monad-              , module Test.QuickCheck-              , module Test.QuickCheck.Modifiers-              , module Text.Printf-              , succeeded-              , failed-              , monadicIO-              , liftIO-              , liftBool-              , Test(..)-              , Prop.Result(..)-              )-    where--import Control.Exception ( bracket, try, SomeException(..) )--import Distribution.TestSuite hiding ( Result(..) )-import qualified Distribution.TestSuite as TS--import Test.QuickCheck hiding ( Result(..) )-import qualified Test.QuickCheck as QC-import Test.QuickCheck.Modifiers-import Test.QuickCheck.Property hiding ( Result(..) )-import qualified Test.QuickCheck.Property as Prop-import Test.QuickCheck.Monadic ( monadicIO ) --import Text.Printf--import qualified Codec.Binary.UTF8.String as UTF8--import Control.Applicative hiding ( (<|>) )-import Control.DeepSeq-import Control.Monad ( forM, mapM, mapM_, forM_ )-import Control.Monad.State.Strict--import Numeric ( showHex )--verify :: Testable t => String -> t -> Test-verify testName p = Test $ TestInstance-  { name = testName-  , run = do-    qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p-    case qcResult of-        QC.Success {..} -> return $ Finished TS.Pass-        QC.Failure {numShrinks,reason} -> return $ Finished-            $ TS.Fail $ "After " -                      ++ show numShrinks ++ " shrinks determined failure to be: "-                      ++ show reason-        _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"-  , tags = []-  , options = []-  , setOption = \_ _ -> Left "no options supported"-  }--data SingleColumnChar = SingleColumnChar Char-    deriving (Show, Eq)--instance Arbitrary SingleColumnChar where-    arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E]--data DoubleColumnChar = DoubleColumnChar Char-    deriving (Eq)--instance Show DoubleColumnChar where-    show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c]--instance Arbitrary DoubleColumnChar where-    arbitrary = elements $ map DoubleColumnChar $-           [ toEnum 0x3040 .. toEnum 0x3098 ]-        ++ [ toEnum 0x309B .. toEnum 0xA4CF ]--liftIOResult :: Testable prop => IO prop -> Property-liftIOResult = ioProperty--#if __GLASGOW_HASKELL__ <= 701-instance Random Word where-    random g = -        let (i :: Int, g') = random g-        in (toEnum i, g')-    randomR (l,h) g =-        let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g-        in (toEnum i, g')-#endif--data Bench where-    Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench-
− test/Verify/Data/Terminfo/Parse.hs 
@@ -1,112 +0,0 @@-module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse-                                  , module Data.Terminfo.Parse-                                  )-    where--import Data.Terminfo.Parse-import Data.Terminfo.Eval-import Verify--import Data.Word-import qualified Data.Vector.Unboxed as Vector--import Numeric--hexDump :: [Word8] -> String-hexDump bytes = foldr (\b s -> showHex b s) "" bytes--data NonParamCapString = NonParamCapString String-    deriving Show--instance Arbitrary NonParamCapString where-    arbitrary -        = ( do-            s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')-            return $ NonParamCapString s-          ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) --data LiteralPercentCap = LiteralPercentCap String [Word8]-    deriving ( Show )--instance Arbitrary LiteralPercentCap where-    arbitrary -        = ( do-            NonParamCapString s <- arbitrary-            (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s-            return $ LiteralPercentCap s' bytes-          ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) --data IncFirstTwoCap = IncFirstTwoCap String [Word8]-    deriving ( Show )--instance Arbitrary IncFirstTwoCap where-    arbitrary-        = ( do-            NonParamCapString s <- arbitrary-            (s', bytes) <- insertEscapeOp "i" [] s-            return $ IncFirstTwoCap s' bytes-          ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) --data PushParamCap = PushParamCap String Int [Word8]-    deriving ( Show )--instance Arbitrary PushParamCap where-    arbitrary-        = ( do-            NonParamCapString s <- arbitrary-            n <- choose (1,9)-            (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s-            return $ PushParamCap s' n bytes-          ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) --data DecPrintCap = DecPrintCap String Int [Word8]-    deriving ( Show )--instance Arbitrary DecPrintCap where-    arbitrary-        = ( do-            NonParamCapString s <- arbitrary-            n <- choose (1,9)-            (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s-            return $ DecPrintCap s' n bytes-          ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) --insertEscapeOp opStr replBytes s = do-    insertPoints <- listOf1 $ elements [0 .. length s - 1]-    let s' = f s ('%' : opStr)-        remainingBytes = f (map (toEnum . fromEnum) s) replBytes-        f inVs out_v = concat [ vs-                              | vi <- zip inVs [0 .. length s - 1]-                              , let vs = fst vi : ( if snd vi `elem` insertPoints-                                                       then out_v-                                                       else []-                                                  )-                              ]-    return (s', remainingBytes)--isBytesOp :: CapOp -> Bool-isBytesOp (Bytes {}) = True--- isBytesOp _ = False--bytesForRange cap offset count-    = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap--collectBytes :: CapExpression -> [Word8]-collectBytes e = concat [ bytes -                        | Bytes offset count <- capOps e-                        , let bytes = bytesForRange e offset count-                        ]-    --verifyBytesEqual :: [Word8] -> [Word8] -> Result-verifyBytesEqual outBytes expectedBytes -    = if outBytes == expectedBytes-        then succeeded-        else failed -             { reason = "outBytes [" -                      ++ hexDump outBytes-                      ++ "] /= expectedBytes ["-                      ++ hexDump expectedBytes-                      ++ "]"-             }-
− test/Verify/Graphics/Vty/Attributes.hs 
@@ -1,73 +0,0 @@-module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes-                                      , module Graphics.Vty.Attributes-                                      )-    where--import Graphics.Vty.Attributes-import Verify--import Data.List ( delete )--allColors :: [Color]-allColors =-    [ black-    , red-    , green-    , yellow-    , blue-    , magenta-    , cyan-    , white-    , brightBlack-    , brightRed-    , brightGreen-    , brightYellow-    , brightBlue-    , brightMagenta-    , brightCyan-    , brightWhite-    ] ++ map Color240 [0..239]--allStyles :: [Style]-allStyles =-    [ standout-    , underline-    , reverseVideo-    , blink-    , dim-    , bold-    ]---- Limit the possible attributes to just a few for now.-possibleAttrMods :: [ AttrOp ]-possibleAttrMods = -    [ idOp -    ] ++ map setForeColorOp allColors-      ++ map setBackColorOp allColors-      ++ map setStyleOp allStyles--instance Arbitrary Attr where-    arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr--data DiffAttr = DiffAttr Attr Attr--instance Arbitrary DiffAttr where-    arbitrary = do-        op0 <- elements possibleAttrMods-        let possibleAttrMods' = delete op0 possibleAttrMods-        op1 <- elements possibleAttrMods'-        return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr)--data AttrOp = AttrOp String (Attr -> Attr)--instance Eq AttrOp where-    AttrOp n0 _ == AttrOp n1 _ = n0 == n1--setStyleOp s     = AttrOp "set_style"      (flip withStyle s)-setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c)-setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c)-idOp = AttrOp "id" id--applyOp :: AttrOp -> Attr -> Attr-applyOp (AttrOp _ f) a = f a-
− test/Verify/Graphics/Vty/DisplayAttributes.hs 
@@ -1,8 +0,0 @@-module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes-                                             , module Graphics.Vty.DisplayAttributes-                                             )-    where--import Graphics.Vty.DisplayAttributes-import Verify-
− test/Verify/Graphics/Vty/Image.hs 
@@ -1,218 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DisambiguateRecordFields #-}-module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image-                                 , module Graphics.Vty.Image-                                 )-    where--import Verify.Graphics.Vty.Attributes-import Graphics.Vty.Image-import Graphics.Vty.Image.Internal--import Verify--data UnitImage = UnitImage Char Image--instance Arbitrary UnitImage where-    arbitrary = do-        SingleColumnChar c <- arbitrary-        a <- arbitrary-        return $ UnitImage c (char a c)--instance Show UnitImage where-    show (UnitImage c _) = "UnitImage " ++ show c--data DefaultImage = DefaultImage Image--instance Show DefaultImage where-    show (DefaultImage i) -        = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i)--instance Arbitrary DefaultImage where-    arbitrary = do-        i <- return $ char defAttr 'X'-        return $ DefaultImage i--data SingleRowSingleAttrImage -    = SingleRowSingleAttrImage -      { expectedAttr :: Attr-      , expectedColumns :: Int-      , rowImage :: Image-      }--instance Show SingleRowSingleAttrImage where-    show (SingleRowSingleAttrImage attr columns image) -        = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"--newtype WidthResize = WidthResize (Image -> (Image, Int))--instance Arbitrary WidthResize where-    arbitrary = do-        WidthResize f <- arbitrary-        w <- choose (1,64)-        oneof $ map (return . WidthResize)-            [ \i -> (i, imageWidth i)-            , \i -> (resizeWidth w $ fst $ f i, w)-            , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w)-            , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w)-            ]--newtype HeightResize = HeightResize (Image -> (Image, Int))--instance Arbitrary HeightResize where-    arbitrary = do-        HeightResize f <- arbitrary-        h <- choose (1,64)-        oneof $ map (return . HeightResize)-            [ \i -> (i, imageHeight i)-            , \i -> (resizeHeight h $ fst $ f i, h)-            , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h)-            , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h)-            ]--newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))--instance Arbitrary ImageResize where-    arbitrary = oneof-        [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))-        , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))-        , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))-        , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))-        , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))-        , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))-        , do-            ImageResize f <- arbitrary-            WidthResize g <- arbitrary-            return $! ImageResize $! \i -> -                let (i0, (_, outHeight)) = f i-                    gI = g i0-                in (fst gI, (snd gI, outHeight))-        , do-            ImageResize f <- arbitrary-            HeightResize g <- arbitrary-            return $! ImageResize $! \i -> -                let (i0, (outWidth, _)) = f i-                    gI = g i0-                in (fst gI, (outWidth, snd gI))-        ]---instance Arbitrary SingleRowSingleAttrImage where-    arbitrary = do-        -- The text must contain at least one character. Otherwise the image simplifies to the-        -- IdImage which has a height of 0. If this is to represent a single row then the height-        -- must be 1-        singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)-        a <- arbitrary-        let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]-            outWidth = length singleColumnRowText-        return $ SingleRowSingleAttrImage a outWidth outImage--data SingleRowTwoAttrImage -    = SingleRowTwoAttrImage -    { part0 :: SingleRowSingleAttrImage-    , part1 :: SingleRowSingleAttrImage-    , joinImage :: Image-    } deriving Show--instance Arbitrary SingleRowTwoAttrImage where-    arbitrary = do-        p0 <- arbitrary-        p1 <- arbitrary-        return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1)--data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack -    { stackImage :: Image -    , stackSourceImages :: [SingleRowSingleAttrImage]-    , stackWidth :: Int-    , stackHeight :: Int-    }-    deriving Show--instance Arbitrary SingleAttrSingleSpanStack where-    arbitrary = do-        imageList <- Verify.resize 16 (listOf1 arbitrary)-        return $ mkSingleAttrSingleSpanStack imageList-    shrink s = do-        imageList <- shrink $ stackSourceImages s-        if null imageList-            then []-            else return $ mkSingleAttrSingleSpanStack imageList--mkSingleAttrSingleSpanStack imageList =-    let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ]-    in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList)-                                                 (toEnum $ length imageList)--instance Arbitrary Image  where-    arbitrary = oneof-        [ return EmptyImage-        , do-            SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary-            ImageResize f <- Verify.resize 2 arbitrary-            return $! fst $! f stackImage-        , do-            SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary-            ImageResize f <- Verify.resize 2 arbitrary-            return $! fst $! f stackImage-        , do-            i0 <- arbitrary-            i1 <- arbitrary-            let i = i0 <|> i1-            ImageResize f <- Verify.resize 2 arbitrary-            return $! fst $! f i-        , do-            i0 <- arbitrary-            i1 <- arbitrary-            let i = i0 <-> i1-            ImageResize f <- Verify.resize 2 arbitrary-            return $! fst $! f i-        ]-    {--    shrink i@(HorizJoin {partLeft, partRight}) = do-        let !i_alt = backgroundFill (imageWidth i) (imageHeight i)-        !partLeft' <- shrink partLeft-        !partRight' <- shrink partRight-        [i_alt, partLeft' <|> partRight']-    shrink i@(VertJoin {partTop, partBottom}) = do-        let !i_alt = backgroundFill (imageWidth i) (imageHeight i)-        !partTop' <- shrink partTop-        !partBottom' <- shrink partBottom-        [i_alt, partTop' <-> partBottom']-    shrink i@(CropRight {croppedImage, outputWidth}) = do-        let !i_alt = backgroundFill (imageWidth i) (imageHeight i)-        [i_alt, croppedImage]-    shrink i@(CropLeft {croppedImage, leftSkip, outputWidth}) = do-        let !i_alt = backgroundFill (imageWidth i) (imageHeight i)-        [i_alt, croppedImage]-    shrink i@(CropBottom {croppedImage, outputHeight}) = do-        let !i_alt = backgroundFill (imageWidth i) (imageHeight i)-        [i_alt, croppedImage]-    shrink i@(CropTop {croppedImage, topSkip, outputHeight}) = do-        let !i_alt = backgroundFill (imageWidth i) (imageHeight i)-        [i_alt, croppedImage]-    shrink i = [emptyImage, backgroundFill (imageWidth i) (imageHeight i)]-    -}--data CropOperation-    = CropFromLeft-    | CropFromRight-    | CropFromTop-    | CropFromBottom-    deriving (Eq, Show)--instance Arbitrary CropOperation where-    arbitrary = oneof $ map return [CropFromLeft, CropFromRight, CropFromTop, CropFromBottom]--data Translation = Translation Image (Int, Int) Image-    deriving (Eq, Show)--instance Arbitrary Translation where-    arbitrary = do-        i <- arbitrary-        x <- arbitrary `suchThat` (> 0)-        y <- arbitrary `suchThat` (> 0)-        let i' = translate x y i-        return $ Translation i (x,y) i'-
− test/Verify/Graphics/Vty/Output.hs 
@@ -1,61 +0,0 @@-module Verify.Graphics.Vty.Output where--import Control.Applicative ((<$>))--import Graphics.Vty.Output.Mock--import qualified Data.ByteString as BS-import Data.IORef-import qualified Data.String.UTF8 as UTF8--import Test.QuickCheck.Property---- A list of terminals that should be supported.--- This started with a list of terminals ubuntu supported. Then those terminals that really could--- not be supported were removed. Then a few more were pruned until a reasonable looking set was--- made.-terminalsOfInterest :: [String]-terminalsOfInterest = -    [ "vt100"-    , "vt220"-    , "vt102"-    , "xterm-r5"-    , "xterm-xfree86"-    , "xterm-r6"-    , "xterm-256color"-    , "xterm-vt220"-    , "xterm-debian"-    , "xterm-mono"-    , "xterm-color"-    , "xterm"-    , "mach"-    , "mach-bold"-    , "mach-color"-    , "linux"-    , "ansi"-    , "hurd"-    , "Eterm"-    , "pcansi"-    , "screen-256color"-    , "screen-bce"-    , "screen-s"-    , "screen-w"-    , "screen"-    , "screen-256color-bce"-    , "sun"-    , "rxvt"-    , "rxvt-unicode"-    , "rxvt-basic"-    , "cygwin"-    ]--compareMockOutput :: MockData -> String -> IO Result-compareMockOutput mockData expectedStr = do-    outStr <- UTF8.toString <$> readIORef mockData-    if outStr /=  expectedStr-        then return $ failed { reason = "bytes\n" ++ outStr-                                      ++ "\nare not the expected bytes\n"-                                      ++ expectedStr-                             }-        else return succeeded-
− test/Verify/Graphics/Vty/Picture.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture-                                   , module Graphics.Vty.Picture-                                   )-    where--import Verify.Graphics.Vty.Prelude--import Graphics.Vty.Picture-import Graphics.Vty.Debug--import Verify.Graphics.Vty.Attributes-import Verify.Graphics.Vty.Image--import Verify--data DefaultPic = DefaultPic -    { defaultPic :: Picture-    , defaultWin :: MockWindow -    }--instance Show DefaultPic where-    show (DefaultPic pic win)-        = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n"--instance Arbitrary DefaultPic where-    arbitrary = do-        DefaultImage image <- arbitrary-        let win = MockWindow (imageWidth image) (imageHeight image)-        return $ DefaultPic (picForImage image) -                            win --data PicWithBGAttr = PicWithBGAttr -    { withAttrPic :: Picture-    , withAttrWin :: MockWindow-    , withAttrSpecifiedAttr :: Attr-    } deriving ( Show )--instance Arbitrary PicWithBGAttr where-    arbitrary = do-        DefaultImage image <- arbitrary-        let win = MockWindow (imageWidth image) (imageHeight image)-        attr <- arbitrary-        return $ PicWithBGAttr (picForImage image) -                               win -                               attr-        -instance Arbitrary Picture where-    arbitrary = do-        layers <- Verify.resize 20 (listOf1 arbitrary)-        return $ picForLayers layers-
− test/Verify/Graphics/Vty/Prelude.hs 
@@ -1,26 +0,0 @@-module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude-                                   , module Graphics.Vty.Prelude-                                   , MockWindow(..)-                                   )-    where--import Graphics.Vty.Prelude--import Graphics.Vty.Debug--import Verify--data EmptyWindow = EmptyWindow MockWindow--instance Arbitrary EmptyWindow where-    arbitrary = return $ EmptyWindow (MockWindow (0 :: Int) (0 :: Int))--instance Show EmptyWindow where-    show (EmptyWindow _) = "EmptyWindow"--instance Arbitrary MockWindow where-    arbitrary = do-        w <- choose (1,1024)-        h <- choose (1,1024)-        return $ MockWindow w h-
− test/Verify/Graphics/Vty/Span.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span-                                , module Graphics.Vty.Span-                                )-    where--import Graphics.Vty.Debug-import Graphics.Vty.Span--import Verify.Graphics.Vty.Picture--import qualified Data.Vector as Vector-import Data.Word--import Verify--isAttrSpanOp :: SpanOp -> Bool-isAttrSpanOp TextSpan {} = True-isAttrSpanOp _           = False--verifyAllSpansHaveWidth i spans w-    = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)-      in case any ((== True) . fst) v of-        False -> succeeded-        True -> failed { reason = "Not all spans contained operations defining exactly " -                                ++ show w-                                ++ " columns of output - \n"-                                ++ (concatMap ((++ "\n") . show)) v-                            }--verifyOpsEquality i_ops i_alt_ops =-    if i_ops == i_alt_ops-        then succeeded-        else failed { reason = "ops for alternate image " ++ show i_alt_ops-                               ++ " are not the same as " ++ show i_ops-                    }-
− test/VerifyAttributeOps.hs 
@@ -1,9 +0,0 @@-module VerifyAttributeOps where--import Verify.Graphics.Vty.Attributes--import Verify--tests :: IO [Test]-tests = return []-
− test/VerifyConfig.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Main where--import Graphics.Vty.Config-import Graphics.Vty.Input.Events--import Data.Default-import Data.String.QQ--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--exampleConfig :: String-exampleConfig = [s|--- comments should be ignored.-map _ "\ESC[B" KUp []-askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored-map _ "\ESC[1;3B" KDown [MAlt]-map "xterm" "\ESC[1;3B" KDown [MAlt]-map "xterm-256-color" "\ESC[1;3B" KDown [MAlt]-debugLog "/tmp/vty-debug.txt"-|]--exampleConfigConfig :: Config-exampleConfigConfig = def-    { debugLog = Just "/tmp/vty-debug.txt"-    , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])-                 , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])-                 , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt])-                 , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt])-                 ]-    }--exampleConfigParses :: IO ()-exampleConfigParses = assertEqual "example config parses as expected"-                                  exampleConfigConfig-                                  (runParseConfig "exampleConfig" exampleConfig)--main :: IO ()-main = defaultMain-    [ testCase "example config parses" $ exampleConfigParses-    ]-
− test/VerifyCropSpanGeneration.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyCropSpanGeneration where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Span--import Graphics.Vty.Debug-import Graphics.Vty.PictureToSpans--import Verify--import qualified Data.Vector as Vector --cropOpDisplayOps :: (Int -> Image -> Image) ->-                    Int -> Image -> (DisplayOps, Image)-cropOpDisplayOps cropOp v i =-    let iOut = cropOp v i-        p = picForImage iOut-        w = MockWindow (imageWidth iOut) (imageHeight iOut)-    in (displayOpsForPic p (regionForWindow w), iOut)--widthCropOutputColumns :: (Int -> Image -> Image) ->-                          SingleAttrSingleSpanStack ->-                          NonNegative Int ->-                          Property-widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==>-    let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s)-    in verifyAllSpansHaveWidth iOut ops w--heightCropOutputColumns :: (Int -> Image -> Image) ->-                           SingleAttrSingleSpanStack ->-                           NonNegative Int ->-                           Property-heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==>-    let (ops, _) = cropOpDisplayOps cropOp h (stackImage s)-    in displayOpsRows ops == h--cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropRightOutputColumns = widthCropOutputColumns cropRight--cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropLeftOutputColumns = widthCropOutputColumns cropLeft--cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropTopOutputRows = heightCropOutputColumns cropTop--cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property-cropBottomOutputRows = heightCropOutputColumns cropBottom---- TODO: known benign failure.-cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property-cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==>-    let i = stackImage stack-        -- the right part is made by cropping the image from the left.-        iR = cropLeft (imageWidth i `div` 2) i-        -- the left part is made by cropping the image from the right-        iL = cropRight (imageWidth i `div` 2) i-        iAlt = iL <|> iR-        iOps = displayOpsForImage i-        iAltOps = displayOpsForImage iAlt-    in verifyOpsEquality iOps iAltOps--cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property-cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==>-    let i = stackImage stack-        -- the top part is made by cropping the image from the bottom.-        iT = cropBottom (imageHeight i `div` 2) i-        -- the bottom part is made by cropping the image from the top.-        iB = cropTop (imageHeight i `div` 2) i-        iAlt = iT <-> iB-    in displayOpsForImage i == displayOpsForImage iAlt--tests :: IO [Test]-tests = return -    [ verify "cropping from the bottom produces display operations covering the expected rows"-        cropBottomOutputRows-    , verify "cropping from the top produces display operations covering the expected rows"-        cropTopOutputRows-    , verify "cropping from the left produces display operations covering the expected columns"-        cropLeftOutputColumns-    , verify "cropping from the right produces display operations covering the expected columns"-        cropRightOutputColumns-    -- TODO: known benign failure.-    -- , verify "the output of a stack is the same as that stack cropped left & right and joined together"-    --     cropRightAndLeftRejoinedEquivalence-    , verify "the output of a stack is the same as that stack cropped top & bottom and joined together"-        cropTopAndBottomRejoinedEquivalence-    ]-
− test/VerifyDisplayAttributes.hs 
@@ -1,9 +0,0 @@-module VerifyDisplayAttributes where--import Verify.Graphics.Vty.DisplayAttributes-import Verify.Graphics.Vty.Attributes--import Verify--tests :: IO [Test]-tests = return []
− test/VerifyEmptyImageProps.hs 
@@ -1,13 +0,0 @@-module VerifyEmptyImageProps where--import Verify---- should be exported by Graphics.Vty.Picture-import Graphics.Vty.Picture ( Image, emptyImage )--tests :: IO [Test]-tests = do-    -- should provide an image type.-    let _ :: Image = emptyImage-    return []-
− test/VerifyEvalTerminfoCaps.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyEvalTerminfoCaps where--import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)-import Data.Terminfo.Eval -import Data.Terminfo.Parse-import Control.DeepSeq--import qualified System.Console.Terminfo as Terminfo--import Verify-import Verify.Graphics.Vty.Output--import Control.Applicative ( (<$>) )-import Control.Exception ( try, SomeException(..) )--import Control.Monad ( mapM_, forM, forM_ )--import Data.Maybe ( fromJust )-import Data.Word--import Foreign.Marshal.Alloc (mallocBytes)-import Foreign.Ptr (Ptr, minusPtr)-import Numeric---- If a terminal defines one of the caps then it's expected to be parsable.-capsOfInterest = -    [ "cup"-    , "sc"-    , "rc"-    , "setf"-    , "setb"-    , "setaf"-    , "setab"-    , "op"-    , "cnorm"-    , "civis"-    , "smcup"-    , "rmcup"-    , "clear"-    , "hpa"-    , "vpa"-    , "sgr"-    , "sgr0"-    ]--fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)--tests :: IO [Test]-tests = do-    evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)-    fmap concat $ forM terminalsOfInterest $ \termName -> do-        putStrLn $ "adding tests for terminal: " ++ termName-        mti <- try $ Terminfo.setupTerm termName-        case mti of-            Left (_e :: SomeException) -                -> return []-            Right ti -> do-                fmap concat $ forM capsOfInterest $ \capName -> do-                    case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of-                        Just capDef -> do-                            putStrLn $ "\tadding test for cap: " ++ capName-                            let testName = termName ++ "(" ++ capName ++ ")"-                            case parseCapExpression capDef of-                                Left error -> return [verify testName (failed {reason = "parse error " ++ show error})]-                                Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)]-                        Nothing      -> do-                            return []--{-# NOINLINE verifyEvalCap #-}-verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property-verifyEvalCap evalBuffer expr !junkInt = do-    forAll (vector 9) $ \inputValues -> -        let write = writeCapExpr expr inputValues-            !byteCount = getBound write-        in liftIOResult $ do-            let startPtr :: Ptr Word8 = evalBuffer-            forM_ [0..100] $ \i -> runWrite write startPtr-            endPtr <- runWrite write startPtr-            case endPtr `minusPtr` startPtr of-                count | count < 0        -> -                            return $ failed { reason = "End pointer before start pointer." }-                      | toEnum count > byteCount -> -                            return $ failed { reason = "End pointer past end of buffer by " -                                                       ++ show (toEnum count - byteCount) -                                            }-                      | otherwise        -> -                            return succeeded-
− test/VerifyImageOps.hs 
@@ -1,174 +0,0 @@-module VerifyImageOps where--import Graphics.Vty.Attributes-import Graphics.Vty.Image.Internal-import Verify.Graphics.Vty.Image--import Verify--import Control.DeepSeq--twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool-twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) = -    imageWidth (char defAttr c1 <|> char defAttr c2) == 2--manySwHorizConcat :: [SingleColumnChar] -> Bool-manySwHorizConcat cs = -    let chars = [ char | SingleColumnChar char <- cs ]-        l = fromIntegral $ length cs-    in imageWidth ( horizCat $ map (char defAttr) chars ) == l--twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool-twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) = -    imageHeight (char defAttr c1 <-> char defAttr c2) == 2--horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool-horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = -    (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 -    == -    char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)--twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool-twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = -    imageWidth (char defAttr c1 <|> char defAttr c2) == 4--manyDwHorizConcat :: [DoubleColumnChar] -> Bool-manyDwHorizConcat cs = -    let chars = [ char | DoubleColumnChar char <- cs ]-        l = fromIntegral $ length cs-    in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2--twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool-twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = -    imageHeight (char defAttr c1 <-> char defAttr c2) == 2--horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool-horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = -    (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 -    == -    char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)--vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool-vertContatSingleRow (NonEmpty stack) =-    let expectedHeight :: Int = length stack-        stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]-    in imageHeight stackImage == expectedHeight--disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage -                              -> NonEmptyList SingleRowSingleAttrImage-                              -> Bool-disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =-    let expectedHeight :: Int = max (length stack0) (length stack1)-        stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]-        stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]-    in imageHeight (stackImage0 <|> stackImage1) == expectedHeight---disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage -                                      -> NonEmptyList SingleRowSingleAttrImage-                                      -> Bool-disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =-    let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]-        stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]-        image = stackImage0 <|> stackImage1-        expectedHeight = imageHeight image-    in case image of-        HorizJoin {}  -> ( expectedHeight == (imageHeight $ partLeft image) )-                         && -                         ( expectedHeight == (imageHeight $ partRight image) )-        _             -> True--disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage -                      -> NonEmptyList SingleRowSingleAttrImage-                      -> Bool-disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) =-    let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)-        stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]-        stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]-        stack0Image = vertCat stack0Images -        stack1Image = vertCat stack1Images -        image = stack0Image <-> stack1Image-    in imageWidth image == expectedWidth--disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage -                            -> NonEmptyList SingleRowSingleAttrImage-                            -> Bool-disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =-    let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)-        stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]-        stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]-        stack0Image = vertCat stack0Images -        stack1Image = vertCat stack1Images -        image = stack0Image <-> stack1Image-    in case image of-        VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )-                       &&-                       ( expectedWidth == (imageWidth $ partBottom image) )-        _           -> True--translationIsLinearOnOutSize :: Translation -> Bool-translationIsLinearOnOutSize (Translation i (x,y) i') =-    imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y--paddingIsLinearOnOutSize :: Image -> Gen Bool-paddingIsLinearOnOutSize i = do-    l <- offset-    t <- offset-    r <- offset-    b <- offset-    let i' = pad l t r b i-    return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b-    where offset = choose (1,1024)--cropLeftLimitsWidth :: Image -> Int -> Property-cropLeftLimitsWidth i v = v >= 0 ==>-    v >= imageWidth (cropLeft v i)--cropRightLimitsWidth :: Image -> Int -> Property-cropRightLimitsWidth i v = v >= 0 ==>-    v >= imageWidth (cropRight v i)--cropTopLimitsHeight :: Image -> Int -> Property-cropTopLimitsHeight i v = v >= 0 ==>-    v >= imageHeight (cropTop v i)--cropBottomLimitsHeight :: Image -> Int -> Property-cropBottomLimitsHeight i v = v >= 0 ==>-    v >= imageHeight (cropBottom v i)---- rediculous tests just to satisfy my desire for nice code coverage :-P-canShowImage :: Image -> Bool-canShowImage i = length (show i) > 0--canRnfImage :: Image -> Bool-canRnfImage i = rnf i == ()--canPpImage :: Image -> Bool-canPpImage i = length (ppImageStructure i) > 0--tests :: IO [Test]-tests = return-    [ verify "twoSwHorizConcat" twoSwHorizConcat-    , verify "manySwHorizConcat" manySwHorizConcat-    , verify "twoSwVertConcat" twoSwVertConcat-    , verify "horizConcatSwAssoc" horizConcatSwAssoc-    , verify "manyDwHorizConcat" manyDwHorizConcat-    , verify "twoDwHorizConcat" twoDwHorizConcat-    , verify "twoDwVertConcat" twoDwVertConcat-    , verify "horizConcatDwAssoc" horizConcatDwAssoc-    , verify "single row vert concats to correct height" vertContatSingleRow-    , verify "disjointHeightHorizJoin" disjointHeightHorizJoin-    , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill-    , verify "disjointWidthVertJoin" disjointWidthVertJoin-    , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill-    , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize-    , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize-    , verify "crop left limits width" cropLeftLimitsWidth-    , verify "crop right limits width" cropRightLimitsWidth-    , verify "crop top limits height" cropTopLimitsHeight-    , verify "crop bottom limits height" cropBottomLimitsHeight-    , verify "can show image" canShowImage-    , verify "can rnf image" canRnfImage-    , verify "can pp image" canPpImage-    ]-
− test/VerifyImageTrans.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-module VerifyImageTrans where--import Verify.Graphics.Vty.Image--import Graphics.Vty.Image.Internal--import Verify--import Data.Word--isHorizTextOfColumns :: Image -> Int -> Bool-isHorizTextOfColumns (HorizText { outputWidth = inW }) expectedW = inW == expectedW-isHorizTextOfColumns (BGFill { outputWidth = inW }) expectedW = inW == expectedW-isHorizTextOfColumns _image _expectedW = False--verifyHorizContatWoAttrChangeSimplifies :: SingleRowSingleAttrImage -> Bool-verifyHorizContatWoAttrChangeSimplifies (SingleRowSingleAttrImage _attr charCount image) =-    isHorizTextOfColumns image charCount--verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool-verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0)-                                                               (SingleRowSingleAttrImage attr1 charCount1 _image1)-                                                               i-                                             ) -    | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1)-    | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1)--tests :: IO [Test]-tests = return-    [ verify "verifyHorizContatWoAttrChangeSimplifies" verifyHorizContatWoAttrChangeSimplifies-    , verify "verifyHorizContatWAttrChangeSimplifies" verifyHorizContatWAttrChangeSimplifies-    ]-
− test/VerifyInline.hs 
@@ -1,31 +0,0 @@-module VerifyInline where--import Graphics.Vty.Inline-import Graphics.Vty.Output-import Graphics.Vty.Output.TerminfoBased as TerminfoBased--import Verify.Graphics.Vty.Output--import Verify--import Distribution.TestSuite--import System.IO--tests :: IO [Test]-tests = concat <$> forM terminalsOfInterest (\termName -> return $-    [ Test $ TestInstance-        { name = "verify vty inline"-        , run = do-            {- disabled because I cannot get useful output out of cabal why this fails.-            nullOut <- openFile "/dev/null" WriteMode-            t <- TerminfoBased.reserveTerminal termName nullOut-            putAttrChange t $ default_all-            releaseTerminal t-            -}-            return $ Finished Pass-        , tags = []-        , options = []-        , setOption = \_ _ -> Left "no options supported"-        }-    ])
− test/VerifyLayersSpanGeneration.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifyLayersSpanGeneration where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Span--import Graphics.Vty.Debug-import Graphics.Vty.PictureToSpans--import Verify--import qualified Data.Vector as Vector --largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-largerHorizSpanOcclusion row0 row1 =-    let i0 = rowImage row0-        i1 = rowImage row1-        (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0)-        expectedOps = displayOpsForImage iLarger-        p = picForLayers [iLarger, iSmaller]-        ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)-    in verifyOpsEquality expectedOps ops---- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the--- second row rendered as a bottom layer with a background fill where the first row would be.-vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-vertStackLayerEquivalence0 row0 row1 =-    let i0 = rowImage row0-        i1 = rowImage row1-        i = i0 <-> i1-        p = picForImage i-        iLower = backgroundFill (imageWidth i0) 1 <-> i1-        pLayered = picForLayers [i0, iLower]-        expectedOps = displayOpsForImage i-        opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)-    in verifyOpsEquality expectedOps opsLayered--vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-vertStackLayerEquivalence1 row0 row1 =-    let i0 = rowImage row0-        i1 = rowImage row1-        i = i0 <-> i1-        p = picForImage i-        iLower = i0 <-> backgroundFill (imageWidth i1) 1-        iUpper = backgroundFill (imageWidth i0) 1 <-> i1-        pLayered = picForLayers [iUpper, iLower]-        expectedOps = displayOpsForImage i-        opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)-    in verifyOpsEquality expectedOps opsLayered---- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the--- second row rendered as a bottom layer with a background fill where the first row would be.-horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-horizJoinLayerEquivalence0 row0 row1 =-    let i0 = rowImage row0-        i1 = rowImage row1-        i = i0 <|> i1-        p = picForImage i-        iLower = backgroundFill (imageWidth i0) 1 <|> i1-        pLayered = picForLayers [i0, iLower]-        expectedOps = displayOpsForImage i-        opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)-    in verifyOpsEquality expectedOps opsLayered--horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result-horizJoinLayerEquivalence1 row0 row1 =-    let i0 = rowImage row0-        i1 = rowImage row1-        i = i0 <|> i1-        p = picForImage i-        iLower = i0 <|> backgroundFill (imageWidth i1) 1-        iUpper = backgroundFill (imageWidth i0) 1 <|> i1-        pLayered = picForLayers [iUpper, iLower]-        expectedOps = displayOpsForImage i-        opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)-    in verifyOpsEquality expectedOps opsLayered--horizJoinAlternate0 :: Result-horizJoinAlternate0 =-    let size = 4-        str0 = replicate size 'a'-        str1 = replicate size 'b'-        i0 = string defAttr str0-        i1 = string defAttr str1-        i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)-        layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1-        layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1-        expectedOps = displayOpsForImage i-        opsLayered = displayOpsForPic (picForLayers [layer0, layer1])-                                      (imageWidth i,imageHeight i)-    in verifyOpsEquality expectedOps opsLayered--horizJoinAlternate1 :: Result-horizJoinAlternate1 =-    let size = 4-        str0 = replicate size 'a'-        str1 = replicate size 'b'-        i0 = string defAttr str0-        i1 = string defAttr str1-        i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)-        layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1]-        expectedOps = displayOpsForImage i-        opsLayered = displayOpsForPic (picForLayers layers)-                                      (imageWidth i,imageHeight i)-    in verifyOpsEquality expectedOps opsLayered--tests :: IO [Test]-tests = return -    [ verify "a larger horiz span occludes a smaller span on a lower layer"-        largerHorizSpanOcclusion-    , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"-        vertStackLayerEquivalence0-    , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)"-        vertStackLayerEquivalence1-    -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)"-    --     horizJoinLayerEquivalence0-    -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)"-    --     horizJoinLayerEquivalence1-    -- , verify "alternating images using joins is the same as alternating images using layers (0)"-    --     horizJoinAlternate0-    -- , verify "alternating images using joins is the same as alternating images using layers (1)"-    --     horizJoinAlternate1-    ]-
− test/VerifyOutput.hs 
@@ -1,55 +0,0 @@-{- We setup the environment to envoke certain terminals of interest.- - This assumes appropriate definitions exist in the current environment for the terminals of- - interest.- -}-module VerifyOutput where-import Verify--import Graphics.Vty--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Output--import Control.Monad--import Data.Default--import qualified System.Console.Terminfo as Terminfo-import System.Posix.Env-import System.Posix.IO--tests :: IO [Test]-tests = concat <$> forM terminalsOfInterest (\termName -> do-    -- check if that terminfo exists-    -- putStrLn $ "testing end to end for terminal: " ++ termName-    mti <- try $ Terminfo.setupTerm termName-    case mti of-        Left (_ :: SomeException) -> return []-        Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture")-                                   (smokeTestTermNonMac termName)-                          ]-    )--smokeTestTermNonMac :: String -> Image -> Property-smokeTestTermNonMac termName i = liftIOResult $ do-    smokeTestTerm termName i--smokeTestTerm :: String -> Image -> IO Result-smokeTestTerm termName i = do-    nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags-    t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName }-    -- putStrLn $ "context color count: " ++ show (contextColorCount t)-    reserveDisplay t-    dc <- displayContext t (100,100)-    -- always show the cursor to produce tests for terminals with no cursor support.-    let pic = (picForImage i) { picCursor = Cursor 0 0 }-    outputPicture dc pic-    setCursorPos t 0 0-    when (supportsCursorVisibility t) $ do-        hideCursor t-        showCursor t-    releaseDisplay t-    releaseTerminal t-    closeFd nullOut-    return succeeded-
− test/VerifyParseTerminfoCaps.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-module VerifyParseTerminfoCaps where--import Prelude hiding ( catch )--import qualified System.Console.Terminfo as Terminfo--import Verify.Data.Terminfo.Parse-import Verify.Graphics.Vty.Output-import Verify--import Data.Maybe ( catMaybes, fromJust )-import Data.Word--import Numeric---- If a terminal defines one of the caps then it's expected to be parsable.--- TODO: reduce duplication with terminfo terminal implementation.-capsOfInterest = -    [ "cup"-    , "sc"-    , "rc"-    , "setf"-    , "setb"-    , "setaf"-    , "setab"-    , "op"-    , "cnorm"-    , "civis"-    , "smcup"-    , "rmcup"-    , "clear"-    , "hpa"-    , "vpa"-    , "sgr"-    , "sgr0"-    ]--fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)--tests :: IO [Test]-tests = do-    parseTests <- concat <$> forM terminalsOfInterest (\termName ->-        liftIO (try $ Terminfo.setupTerm termName)-        >>= either (\(_e :: SomeException) -> return [])-                   (\ti -> concat <$> forM capsOfInterest (\capName -> do-                        let caseName = "\tparsing cap: " ++ capName-                        liftIO $ putStrLn caseName-                        return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of-                            Just capDef -> [verify (caseName ++ " -> " ++ show capDef)-                                                   (verifyParseCap capDef $ const succeeded)]-                            Nothing      -> []-                    )-                   )-        )-    return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps-             , verify "parse cap string with literal %" literalPercentCaps-             , verify "parse cap string with %i op" incFirstTwoCaps-             , verify "parse cap string with %pN op" pushParamCaps-             ] ++ parseTests--verifyParseCap capString onParse =-    case parseCapExpression capString of-        Left error -> failed { reason = "parse error " ++ show error }-        Right e    -> onParse e--nonParamaterizedCaps (NonParamCapString cap) = do-    verifyParseCap cap $ \e -> -        let expectedBytes = map (toEnum . fromEnum) cap-            outBytes = bytesForRange e 0 (length cap)-        in verifyBytesEqual outBytes expectedBytes--literalPercentCaps (LiteralPercentCap capString expectedBytes) = do-    verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes--incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do-    verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes-    -pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do-    verifyParseCap capString $ \e ->-        let outBytes = collectBytes e-            outParamCount = paramCount e-        in if outParamCount == expectedParamCount-            then verifyBytesEqual outBytes expectedBytes-            else failed { reason = "out param count /= expected param count" }--decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do-    verifyParseCap capString $ \e ->-        let outBytes = collectBytes e-            outParamCount = paramCount e-        in if outParamCount == expectedParamCount-            then verifyBytesEqual outBytes expectedBytes-            else failed { reason = "out param count /= expected param count" }--printCap ti capName = do-    putStrLn $ capName ++ ": " ++ show (fromCapname ti capName)--printExpression ti capName = do-    let parseResult = parseCapExpression $ fromCapname ti capName-    putStrLn $ capName ++ ": " ++ show parseResult-
− test/VerifySimpleSpanGeneration.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}-module VerifySimpleSpanGeneration where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Span--import Graphics.Vty.Debug-import Graphics.Vty.PictureToSpans--import Verify--import qualified Data.Vector as Vector --unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool-unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) = -    let p = picForImage i-        ops = displayOpsForPic p (regionForWindow w)-    in displayOpsColumns ops == 0 && displayOpsRows ops == 0--unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool-unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) = -    let p = picForImage i-        ops = displayOpsForPic p (regionForWindow w)-    in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )--horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool-horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = -    let p = picForImage i-        ops = displayOpsForPic p (regionForWindow w)-    in displayOpsColumns ops == 0 && displayOpsRows ops == 0--horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool-horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = -    let p = picForImage i-        ops = displayOpsForPic p (regionForWindow w)-    in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )--horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result-horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =-    let p = picForImage i-        w = MockWindow c 1-        ops = displayOpsForPic p (regionForWindow w)-    in verifyAllSpansHaveWidth i ops c--horizSpanImageAndEqualWindow1 :: SingleRowSingleAttrImage -> Bool-horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =-    let p = picForImage i-        w = MockWindow c 1-        ops = displayOpsForPic p (regionForWindow w)-    in spanOpsEffectedRows ops == 1--horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result-horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =-    let p = picForImage i-        lesserWidth = c `div` 2-        w = MockWindow lesserWidth 1-        ops = displayOpsForPic p (regionForWindow w)-    in verifyAllSpansHaveWidth i ops lesserWidth--singleAttrSingleSpanStackCropped0 :: SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackCropped0 stack =-    let p = picForImage (stackImage stack)-        w = MockWindow (stackWidth stack `div` 2) (stackHeight stack)-        ops = displayOpsForPic p (regionForWindow w)-    in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack `div` 2)--singleAttrSingleSpanStackCropped1 :: SingleAttrSingleSpanStack -> Bool-singleAttrSingleSpanStackCropped1 stack =-    let p = picForImage (stackImage stack)-        expectedRowCount = stackHeight stack `div` 2-        w = MockWindow (stackWidth stack) expectedRowCount-        ops = displayOpsForPic p (regionForWindow w)-        actualRowCount = spanOpsEffectedRows ops-    in expectedRowCount == actualRowCount--singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackCropped2 stack0 stack1 =-    let p = picForImage (stackImage stack0 <|> stackImage stack1)-        w = MockWindow (stackWidth stack0) (imageHeight (picImage p))-        ops = displayOpsForPic p (regionForWindow w)-    in verifyAllSpansHaveWidth (picImage p) ops (stackWidth stack0)--singleAttrSingleSpanStackCropped3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool-singleAttrSingleSpanStackCropped3 stack0 stack1 =-    let p = picForImage (stackImage stack0 <|> stackImage stack1)-        w = MockWindow (imageWidth (picImage p))  expectedRowCount-        ops = displayOpsForPic p (regionForWindow w)-        expectedRowCount = imageHeight (picImage p) `div` 2-        actualRowCount = spanOpsEffectedRows ops-    in expectedRowCount == actualRowCount--singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackCropped4 stack0 stack1 =-    let p = picForImage (stackImage stack0 <-> stackImage stack1)-        w = MockWindow expectedWidth (imageHeight (picImage p))-        ops = displayOpsForPic p (regionForWindow w)-        expectedWidth = imageWidth (picImage p) `div` 2-    in verifyAllSpansHaveWidth (picImage p) ops expectedWidth--singleAttrSingleSpanStackCropped5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool-singleAttrSingleSpanStackCropped5 stack0 stack1 =-    let p = picForImage (stackImage stack0 <-> stackImage stack1)-        w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)-        ops = displayOpsForPic p (regionForWindow w)-        expectedRowCount = stackHeight stack0-        actualRowCount = spanOpsEffectedRows ops-    in expectedRowCount == actualRowCount--horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result-horizSpanImageAndGreaterWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =-    let p = picForImage i-        -- SingleRowSingleAttrImage always has width >= 1-        greaterWidth = c * 2-        w = MockWindow greaterWidth 1-        ops = displayOpsForPic p (regionForWindow w)-    in verifyAllSpansHaveWidth i ops greaterWidth--arbImageIsCropped :: DefaultImage -> MockWindow -> Bool-arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =-    let pic = picForImage image-        ops = displayOpsForPic pic (regionForWindow win)-    in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w )--spanOpsActuallyFillRows :: DefaultPic -> Bool-spanOpsActuallyFillRows (DefaultPic pic win) =-    let ops = displayOpsForPic pic (regionForWindow win)-        expectedRowCount = regionHeight (regionForWindow win)-        actualRowCount = spanOpsEffectedRows ops-    in expectedRowCount == actualRowCount--spanOpsActuallyFillColumns :: DefaultPic -> Bool-spanOpsActuallyFillColumns (DefaultPic pic win) =-    let ops = displayOpsForPic pic (regionForWindow win)-        expectedColumnCount = regionWidth (regionForWindow win)-    in allSpansHaveWidth ops expectedColumnCount--firstSpanOpSetsAttr :: DefaultPic -> Bool-firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } = -    let ops = displayOpsForPic pic (regionForWindow win)-    in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops )--singleAttrSingleSpanStackOpCoverage ::  SingleAttrSingleSpanStack -> Result-singleAttrSingleSpanStackOpCoverage stack =-    let p = picForImage (stackImage stack)-        w = MockWindow (stackWidth stack) (stackHeight stack)-        ops = displayOpsForPic p (regionForWindow w)-    in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack)--imageCoverageMatchesBounds :: Image -> Result-imageCoverageMatchesBounds i =-    let p = picForImage i-        r = (imageWidth i,imageHeight i)-        ops = displayOpsForPic p r-    in verifyAllSpansHaveWidth i ops (imageWidth i)--tests :: IO [Test]-tests = return -    [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0-    , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1-    , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0-    , verify "horiz span image is cropped when window size == (0,0) [1]" horizSpanImageAndZeroWindow1-    , verify "horiz span image is not cropped when window size == size of image [width]" horizSpanImageAndEqualWindow0-    , verify "horiz span image is not cropped when window size == size of image [height]" horizSpanImageAndEqualWindow1-    , verify "horiz span image is not cropped when window size < size of image [width]" horizSpanImageAndLesserWindow0-    , verify "horiz span image is not cropped when window size > size of image [width]" horizSpanImageAndGreaterWindow0-    , verify "first span op is always to set the text attribute" firstSpanOpSetsAttr-    , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"-        singleAttrSingleSpanStackOpCoverage-    , verify "a single attr text span is cropped when window size < size of stack image [width]"-        singleAttrSingleSpanStackCropped0 -    , verify "a single attr text span is cropped when window size < size of stack image [height]"-        singleAttrSingleSpanStackCropped1-    , verify "single attr text span <|> single attr text span display cropped. [width]"-        singleAttrSingleSpanStackCropped2-    , verify "single attr text span <|> single attr text span display cropped. [height]"-        singleAttrSingleSpanStackCropped3-    , verify "single attr text span <-> single attr text span display cropped. [width]"-        singleAttrSingleSpanStackCropped4-    , verify "single attr text span <-> single attr text span display cropped. [height]"-        singleAttrSingleSpanStackCropped5-    , verify "an arbitrary image when rendered to a window of the same size will cover the entire window"-        imageCoverageMatchesBounds-    ]-
− test/VerifyUsingMockInput.hs 
@@ -1,219 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced- - are as expected.- -}-module Main where--import Verify.Graphics.Vty.Output--import Graphics.Vty hiding (resize)-import Graphics.Vty.Input.Events-import Graphics.Vty.Input.Loop-import Graphics.Vty.Input.Terminfo--import Control.Applicative-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception-import Lens.Micro ((^.))-import Control.Monad--import Data.Default-import Data.IORef-import Data.List (intersperse, reverse, nubBy)--import System.Console.Terminfo-import System.Posix.IO-import System.Posix.Terminal (openPseudoTerminal)-import System.Posix.Types-import System.Timeout--import Test.Framework.Providers.SmallCheck-import Test.Framework-import Test.SmallCheck-import Test.SmallCheck.Series--import Text.Printf---- processing a block of 16 chars is the largest I can do without taking too long to run the test.-maxBlockSize :: Int-maxBlockSize = 16--maxTableSize :: Int-maxTableSize = 28--forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m-forEachOf l = over (generate (\n -> take n l))--data InputEvent-    = Bytes String  -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.-    | Delay Int     -- | microsecond delay-    deriving Show--type InputSpec = [InputEvent]--type ExpectedSpec = [Event]--synthesizeInput :: InputSpec -> Fd -> IO ()-synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")-    where-        f (Bytes str) = void $ fdWrite outHandle str-        f (Delay t) = threadDelay t--minDetectableDelay :: Int-minDetectableDelay = 4000--minTimout :: Int-minTimout = 4000000--testKeyDelay :: Int-testKeyDelay = minDetectableDelay * 4--testEscSampleDelay :: Int-testEscSampleDelay = minDetectableDelay * 2--genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()-genEventsUsingIoActions maxDuration inputAction outputAction = do-    let maxDuration' = max minTimout maxDuration-    readComplete <- newEmptyMVar-    writeComplete <- newEmptyMVar-    _ <- forkOS $ inputAction `finally` putMVar writeComplete ()-    _ <- forkOS $ outputAction `finally` putMVar readComplete ()-    Just () <- timeout maxDuration' $ takeMVar writeComplete-    Just () <- timeout maxDuration' $ takeMVar readComplete-    return ()--compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool-compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents-    where-        compareEvents' [] []         = return True-        compareEvents' [] outEvents' = do-            printf "extra events %s\n" (show outEvents') :: IO ()-            return False-        compareEvents' expectedEvents' [] = do-            printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()-            printf "expected events %s\n" (show expectedEvents) :: IO ()-            printf "received events %s\n" (show outEvents) :: IO ()-            return False-        compareEvents' (e : expectedEvents') (o : outEvents')-            | e == o    = compareEvents' expectedEvents' outEvents'-            | otherwise = do-                printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()-                printf "expected events %s\n" (show expectedEvents) :: IO ()-                printf "received events %s\n" (show outEvents) :: IO ()-                return False--assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool-assertEventsFromSynInput table inputSpec expectedEvents = do-    let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay-        eventCount = length expectedEvents-    (writeFd, readFd) <- openPseudoTerminal-    (setTermAttr,_) <- attributeControl readFd-    setTermAttr-    let testConfig = def { inputFd = Just readFd-                         , termName = Just "dummy"-                         , vmin = Just 1-                         , vtime = Just 100-                         }-    input <- initInput testConfig table-    eventsRef <- newIORef []-    let writeWaitClose = do-            synthesizeInput inputSpec writeFd-            threadDelay minDetectableDelay-            shutdownInput input-            threadDelay minDetectableDelay-            closeFd writeFd-            closeFd readFd-    -- drain output pipe-    let readEvents = readLoop eventCount-        readLoop 0 = return ()-        readLoop n = do-            e <- atomically $ readTChan $ input^.eventChannel-            modifyIORef eventsRef ((:) e)-            readLoop (n - 1)-    genEventsUsingIoActions maxDuration writeWaitClose readEvents-    outEvents <- reverse <$> readIORef eventsRef-    compareEvents inputSpec expectedEvents outEvents--newtype InputBlocksUsingTable event-    = InputBlocksUsingTable ([(String,event)] -> [(String, event)])--instance Show (InputBlocksUsingTable event) where-    show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"--instance Monad m => Serial m (InputBlocksUsingTable event) where-    series = do-        n :: Int <- localDepth (const maxTableSize) series-        return $ InputBlocksUsingTable $ \raw_table ->-                 let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table-                 in concat (take n (selections table))-        where-            selections []     = []-            selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)--verifyVisibleSynInputToEvent :: Property IO-verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do-    let table    = visibleChars-        inputSeq = gen table-        events   = map snd inputSeq-        keydowns = map (Bytes . fst) inputSeq-        input    = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]-    assertEventsFromSynInput universalTable input events--verifyCapsSynInputToEvent :: Property IO-verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->-    forEachOf terminalsOfInterest $ \termName -> monadic $ do-        term <- setupTerm termName-        let table         = capsClassifyMap term keysFromCapsTable-            inputSeq      = gen table-            events        = map snd inputSeq-            keydowns      = map (Bytes . fst) inputSeq-            input         = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]-        assertEventsFromSynInput table input events--verifySpecialSynInputToEvent :: Property IO-verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do-    let table         = specialSupportKeys-        inputSeq      = gen table-        events        = map snd inputSeq-        keydowns      = map (Bytes . fst) inputSeq-        input         = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]-    assertEventsFromSynInput universalTable input events--verifyFullSynInputToEvent :: Property IO-verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->-    forEachOf terminalsOfInterest $ \termName -> monadic $ do-        term <- setupTerm termName-        let table         = classifyMapForTerm termName term-            inputSeq      = gen table-            events        = map snd inputSeq-            keydowns      = map (Bytes . fst) inputSeq-            input         = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]-        assertEventsFromSynInput table input events--verifyFullSynInputToEvent_2x :: Property IO-verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->-    forEachOf terminalsOfInterest $ \termName -> monadic $ do-        term <- setupTerm termName-        let table         = classifyMapForTerm termName term-            inputSeq      = gen table-            events        = concatMap ((\s -> [s,s]) . snd) inputSeq-            keydowns      = map (Bytes . (\s -> s ++ s) . fst) inputSeq-            input         = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]-        assertEventsFromSynInput table input events--main :: IO ()-main = defaultMain-    [ testProperty "synthesized typing of single visible chars translates to expected events"-        verifyVisibleSynInputToEvent-    , testProperty "synthesized typing of keys from capabilities tables translates to expected events"-        verifyCapsSynInputToEvent-    , testProperty "synthesized typing of hard coded special keys translates to expected events"-        verifySpecialSynInputToEvent-    , testProperty "synthesized typing of any key in the table translates to its paired event"-        verifyFullSynInputToEvent-    , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"-        verifyFullSynInputToEvent_2x-    ]-
− test/VerifyUsingMockTerminal.hs 
@@ -1,100 +0,0 @@-module VerifyUsingMockTerminal where--import Verify.Graphics.Vty.Prelude--import Verify.Graphics.Vty.Picture-import Verify.Graphics.Vty.Image-import Verify.Graphics.Vty.Span-import Verify.Graphics.Vty.Output-import Graphics.Vty.Output-import Graphics.Vty.Output.Mock--import Graphics.Vty.Debug--import Verify--import qualified Data.ByteString as BS-import Data.IORef-import qualified Data.String.UTF8 as UTF8--import System.IO--unitImageUnitBounds :: UnitImage -> Property-unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do-    (_,t) <- mockTerminal (1,1)-    dc <- displayBounds t >>= displayContext t-    let pic = picForImage i-    outputPicture dc pic-    return succeeded--unitImageArbBounds :: UnitImage -> MockWindow -> Property-unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do-    (_,t) <- mockTerminal (w,h)-    dc <- displayBounds t >>= displayContext t-    let pic = picForImage i-    outputPicture dc pic-    return succeeded--singleTRow :: MockWindow -> Property-singleTRow (MockWindow w h) = liftIOResult $ do-    (mockData,t) <- mockTerminal (w,h)-    dc <- displayBounds t >>= displayContext t-    -- create an image that contains just the character T repeated for a single row-    let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')-        pic = (picForImage i) { picBackground = Background 'B' defAttr }-    outputPicture dc pic-    -- The mock output string that represents the output bytes a single line containing the T-    -- string: Followed by h - 1 lines of a change to the background attribute and then the-    -- background character-    let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'-                 ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')-    compareMockOutput mockData expected-    -manyTRows :: MockWindow -> Property-manyTRows (MockWindow w h) = liftIOResult $ do-    (mockData, t) <- mockTerminal (w,h)-    dc <- displayBounds t >>= displayContext t-    -- create an image that contains the character 'T' repeated for all the rows-    let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')-        pic = (picForImage i) { picBackground = Background 'B' defAttr }-    outputPicture dc pic-    -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an-    -- attribute change. 'A', followed by w 'T's-    let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')-    compareMockOutput mockData expected--manyTRowsCroppedWidth :: MockWindow -> Property-manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do-    (mockData,t) <- mockTerminal (w,h)-    dc <- displayBounds t >>= displayContext t-    -- create an image that contains the character 'T' repeated for all the rows-    let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')-        pic = (picForImage i) { picBackground = Background 'B' defAttr }-    outputPicture dc pic-    -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an-    -- attribute change. 'A', followed by w 'T's-    let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')-    compareMockOutput mockData expected--manyTRowsCroppedHeight :: MockWindow -> Property-manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do-    (mockData,t) <- mockTerminal (w,h)-    dc <- displayBounds t >>= displayContext t-    -- create an image that contains the character 'T' repeated for all the rows-    let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')-        pic = (picForImage i) { picBackground = Background 'B' defAttr }-    outputPicture dc pic-    -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an-    -- attribute change. 'A', followed by w count 'T's-    let expected = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T')-    compareMockOutput mockData expected--tests :: IO [Test]-tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds-               , verify "unitImageArbBounds" unitImageArbBounds-               , verify "singleTRow" singleTRow-               , verify "manyTRows" manyTRows-               , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth-               , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight-               ]-
− test/VerifyUtf8Width.hs 
@@ -1,28 +0,0 @@-module VerifyUtf8Width where-import Verify--import Graphics.Text.Width-import Graphics.Vty.Attributes-import Graphics.Vty.Picture--swIs1Column :: SingleColumnChar -> Bool-swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1--dwIs2Column :: DoubleColumnChar -> Bool-dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2--dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool-dcStringIsEven (NonEmpty dw_list) =-    even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ]--safeWcwidthForControlChars :: Bool-safeWcwidthForControlChars = 0 == safeWcwidth '\NUL'--tests :: IO [Test]-tests = return-  [ verify "swIs1Column" swIs1Column-  , verify "dwIs2Column" dwIs2Column-  , verify "a string of double characters is an even width" dcStringIsEven-  , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars-  ]-
vty.cabal view
@@ -1,620 +1,86 @@ name:                vty-version:             5.5.0+version:             6.6 license:             BSD3 license-file:        LICENSE author:              AUTHORS-maintainer:          Corey O'Connor (coreyoconnor@gmail.com)-homepage:            https://github.com/coreyoconnor/vty+maintainer:          Jonathan Daugherty (cygnus@foobox.com)+homepage:            https://github.com/jtdaugherty/vty category:            User Interfaces synopsis:            A simple terminal UI library description:   vty is terminal GUI library in the niche of ncurses. It is intended to-  be easy to use, have no confusing corner cases, and good support for-  common terminal types.-  .-  Included in the source distribution is a program-  test/interactive_terminal_test.hs that demonstrates the various-  features.-  .-  Developers: See the "Graphics.Vty" module.-  .-  Users: See the "Graphics.Vty.Config" module.-  .-  If your terminal is not behaving as expected the results of the-  vty-interactive-terminal-test executable should be sent to the Vty-  maintainter to aid in debugging the issue.-  .-  Notable infelicities: Assumes UTF-8 character encoding support by the-  terminal; Poor signal handling; Requires terminfo.-  .-  This project is hosted on github.com: <https://github.com/coreyoconnor/vty>+  be easy to use and to provide good support for common terminal types.   .-  > git clone git://github.com/coreyoconnor/vty.git+  See the example programs in the @vty-crossplatform@ package examples+  on how to use the library.   .   &#169; 2006-2007 Stefan O'Rear; BSD3 license.   .   &#169; Corey O'Connor; BSD3 license.-cabal-version:       >= 1.18+  .+  &#169; Jonathan Daugherty; BSD3 license.+cabal-version:       1.18 build-type:          Simple-data-files:          README.md,-                     TODO,+extra-doc-files:     README.md,                      AUTHORS,-                     CHANGELOG,+                     CHANGELOG.md,                      LICENSE-tested-with:         GHC >= 7.6.2+tested-with:         GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7,+                     GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.4, GHC==9.10.1,+                     GHC==9.12.1  source-repository head   type: git-  location: https://github.com/coreyoconnor/vty.git+  location: https://github.com/jtdaugherty/vty.git  library   default-language:    Haskell2010-  build-depends:       base >= 4 && < 5,+  include-dirs:        cbits+  hs-source-dirs:      src+  ghc-options:         -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10+  ghc-prof-options:    -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10+  build-depends:       base >= 4.8 && < 5,                        blaze-builder >= 0.3.3.2 && < 0.5,                        bytestring,-                       containers,-                       data-default >= 0.5.3,-                       deepseq >= 1.1 && < 1.5,-                       directory,-                       filepath >= 1.0 && < 2.0,-                       microlens,+                       deepseq >= 1.1 && < 1.6,+                       microlens < 0.6,                        microlens-mtl,-                       microlens-th,-                       -- required for nice installation with yi-                       hashable >= 1.2,-                       mtl >= 1.1.1.0 && < 2.3,-                       parallel >= 2.2 && < 3.3,-                       parsec >= 2 && < 4,+                       mtl >= 1.1.1.0 && < 2.4,                        stm,-                       terminfo >= 0.3 && < 0.5,-                       transformers >= 0.3.0.0,                        text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7+                       utf8-string >= 0.3.1 && < 1.1,+                       vector >= 0.7,+                       binary,+                       parsec,+                       filepath,+                       directory -  exposed-modules:     Graphics.Vty+  if !impl(ghc >= 8.0)+    build-depends:     semigroups >= 0.16,+                       fail++  exposed-modules:     Graphics.Text.Width+                       Graphics.Vty                        Graphics.Vty.Attributes+                       Graphics.Vty.Attributes.Color+                       Graphics.Vty.Attributes.Color240                        Graphics.Vty.Config+                       Graphics.Vty.Debug+                       Graphics.Vty.DisplayAttributes                        Graphics.Vty.Error                        Graphics.Vty.Image+                       Graphics.Vty.Image.Internal                        Graphics.Vty.Inline-                       Graphics.Vty.Inline.Unsafe                        Graphics.Vty.Input                        Graphics.Vty.Input.Events-                       Graphics.Vty.Picture-                       Graphics.Vty.Prelude                        Graphics.Vty.Output-                       Graphics.Text.Width-                       -- the modules below are only meant to be used by the tests.-                       Codec.Binary.UTF8.Debug-                       Data.Terminfo.Parse-                       Data.Terminfo.Eval-                       Graphics.Vty.Debug-                       Graphics.Vty.DisplayAttributes-                       Graphics.Vty.Image.Internal-                       Graphics.Vty.Input.Classify-                       Graphics.Vty.Input.Loop-                       Graphics.Vty.Input.Terminfo+                       Graphics.Vty.Output.Mock+                       Graphics.Vty.Picture                        Graphics.Vty.PictureToSpans                        Graphics.Vty.Span-                       Graphics.Vty.Output.Mock-                       Graphics.Vty.Output.Interface-                       Graphics.Vty.Output.XTermColor-                       Graphics.Vty.Output.TerminfoBased--  other-modules:       Graphics.Vty.Attributes.Color-                       Graphics.Vty.Attributes.Color240-                       Graphics.Vty.Debug.Image-                       Graphics.Vty.Input.Terminfo.ANSIVT--  c-sources:           cbits/gwinsz.c-                       cbits/set_term_timing.c-                       cbits/mk_wcwidth.c--  include-dirs:        cbits--  hs-source-dirs:      src--  default-extensions:  ScopedTypeVariables-                       ForeignFunctionInterface--  ghc-options:         -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10--  ghc-prof-options:    -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10--  cc-options:          -O2--executable vty-demo-  main-is:             Demo.hs--  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables-  ghc-options:         -threaded--  build-depends:       vty,-                       base >= 4 && < 5,-                       containers,-                       data-default >= 0.5.3,-                       microlens,-                       microlens-mtl,-                       mtl >= 1.1.1.0 && < 2.3--test-suite verify-attribute-ops-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables-  type:                detailed-0.9-  hs-source-dirs:      test-  test-module:         VerifyAttributeOps-  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-using-mock-terminal-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyUsingMockTerminal--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Prelude-                       Verify.Graphics.Vty.Picture-                       Verify.Graphics.Vty.Image-                       Verify.Graphics.Vty.Span-                       Verify.Graphics.Vty.Output--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       terminfo >= 0.3 && < 0.5,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-terminal-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyOutput--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Prelude-                       Verify.Graphics.Vty.Picture-                       Verify.Graphics.Vty.Image-                       Verify.Graphics.Vty.Span-                       Verify.Graphics.Vty.Output--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       data-default >= 0.5.3,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       terminfo >= 0.3 && < 0.5,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-display-attributes-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyDisplayAttributes--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.DisplayAttributes-                       Verify.Graphics.Vty.Prelude-                       Verify.Graphics.Vty.Picture-                       Verify.Graphics.Vty.Image-                       Verify.Graphics.Vty.Span--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-empty-image-props-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyEmptyImageProps--  other-modules:       Verify--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-eval-terminfo-caps-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyEvalTerminfoCaps--  other-modules:       Verify-                       Verify.Graphics.Vty.Output--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       blaze-builder >= 0.3.3.2 && < 0.5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       terminfo >= 0.3 && < 0.5,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-image-ops-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyImageOps--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Image--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-image-trans-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyImageTrans--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Image--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-inline-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyInline--  other-modules:       Verify-                       Verify.Graphics.Vty.Output--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-parse-terminfo-caps-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyParseTerminfoCaps--  other-modules:       Verify-                       Verify.Data.Terminfo.Parse-                       Verify.Graphics.Vty.Output--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       terminfo >= 0.3 && < 0.5,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-simple-span-generation-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifySimpleSpanGeneration--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Prelude-                       Verify.Graphics.Vty.Picture-                       Verify.Graphics.Vty.Image-                       Verify.Graphics.Vty.Span--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7---test-suite verify-crop-span-generation-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyCropSpanGeneration--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Prelude-                       Verify.Graphics.Vty.Picture-                       Verify.Graphics.Vty.Image-                       Verify.Graphics.Vty.Span--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7---test-suite verify-layers-span-generation-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyLayersSpanGeneration--  other-modules:       Verify-                       Verify.Graphics.Vty.Attributes-                       Verify.Graphics.Vty.Prelude-                       Verify.Graphics.Vty.Picture-                       Verify.Graphics.Vty.Image-                       Verify.Graphics.Vty.Span--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-utf8-width-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                detailed-0.9--  hs-source-dirs:      test--  test-module:         VerifyUtf8Width--  other-modules:       Verify--  build-depends:       vty,-                       Cabal >= 1.20,-                       QuickCheck >= 2.7,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       mtl >= 1.1.1.0 && < 2.3,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--test-suite verify-using-mock-input-  default-language:    Haskell2010-  default-extensions:  ScopedTypeVariables--  type:                exitcode-stdio-1.0--  hs-source-dirs:      test--  main-is:             VerifyUsingMockInput.hs--  build-depends:       vty,-                       Cabal >= 1.20,-                       data-default >= 0.5.3,-                       QuickCheck >= 2.7,-                       smallcheck == 1.*,-                       quickcheck-assertions >= 0.1.1,-                       test-framework == 0.8.*,-                       test-framework-smallcheck == 0.2.*,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       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,-                       data-default >= 0.5.3,-                       HUnit,-                       QuickCheck >= 2.7,-                       smallcheck == 1.*,-                       quickcheck-assertions >= 0.1.1,-                       test-framework == 0.8.*,-                       test-framework-smallcheck == 0.2.*,-                       test-framework-hunit,-                       random >= 1.0 && < 1.2,-                       base >= 4 && < 5,-                       bytestring,-                       containers,-                       deepseq >= 1.1 && < 1.5,-                       microlens,-                       microlens-mtl,-                       mtl >= 1.1.1.0 && < 2.3,-                       string-qq,-                       terminfo >= 0.3 && < 0.5,-                       text >= 0.11.3,-                       unix,-                       utf8-string >= 0.3 && < 1.1,-                       vector >= 0.7--  ghc-options:         -threaded -Wall+                       Graphics.Vty.UnicodeWidthTable.IO+                       Graphics.Vty.UnicodeWidthTable.Install+                       Graphics.Vty.UnicodeWidthTable.Main+                       Graphics.Vty.UnicodeWidthTable.Query+                       Graphics.Vty.UnicodeWidthTable.Types+  c-sources:           cbits/mk_wcwidth.c