packages feed

reflex-vty 0.5.2.1 → 1.3.0.0

raw patch · 97 files changed

Files

ChangeLog.md view
@@ -1,5 +1,104 @@ # Revision history for reflex-vty +## 1.3.0.0++* Fix: `splitAtWidth` uses character boundaries instead of storage offsets. This preserves Unicode text when the function wraps wide characters.+* Fix: The host checks post-build shutdown before it draws output or starts input. On normal and exceptional exits, it restores signal handlers and waits for the input worker to stop. Closed event queues reject writes even when capacity remains.+* Fix: Nested panes inherit focus and add their viewport origins to the parent origin. Terminal cursors use cell coordinates. Draggable splits start without sampling a recursive layout and follow the mouse row. Scroll requests and display offsets stay within content bounds.+* Text inputs apply local theme changes immediately. `textInputTile` samples its size after each frame to prevent a recursive-layout deadlock. It also requires `PostBuild`, `PerformEvent`, and `MonadSample t (Performable m)`. The standard widget host supplies these constraints.+* Golden tests fail if a fixture is missing. They change fixtures only when `REFLEX_VTY_GOLDEN_UPDATE=1` and `CI` is not `true`.+* Add widget and composition tests that use the production host. Check fixture bytes in source packages. Add POSIX PTY checks and a GHC 9.12.3 coverage baseline for all library modules. Coverage reports combine parent and signal-child tick counts.+* Fix CI portability: use supported macOS runners, explicitly enable Cabal test suites, and import the Windows signal installer in its console test. PTY checks drain output during shutdown and distinguish Darwin's kernel-managed `PENDIN` state from configurable terminal modes.+* Fix the Windows console-test callback types and pin coverage toolchain metadata so GHCup installs the baseline's exact GHC 9.12.3 release rather than a dated rebuild.+* Fix the Windows signal test's explicit console-event enumeration and child readiness handshake, and verify each event's mapped application signal.+* Keep golden fixtures and signal-child protocol lines in LF form on Windows. Golden-policy checks exercise file locking rather than platform-specific permission bits and no longer depend on exception formatting.+* *Breaking change*: `Reflex.Vty.Canvas` uses `CanvasCell` instead of `(Char, V.Attr)` for each glyph. A cell contains the column width and attributed text for one base character and its zero-width marks. `canvasCells :: Map (Int, Int) CanvasCell` uses each glyph's start column as its key. `canvasCellAt` returns the covering glyph for each column of a wide glyph. It returns `Nothing` for transparent positions. `imageToCanvas` reads Vty's rendered spans to preserve joins, clipping, backgrounds, wide characters, and combining marks. `canvasToImage` uses `V.backgroundFill` for transparent gaps so that lower images remain visible. Partial wide glyphs use Vty's ellipsis rule: the remaining half becomes a one-column `…`. Right-edge clipping removes the combining suffix. Left-edge clipping keeps the suffix. Use `CanvasCell` values when you construct a `Canvas` map.++## 1.2.0.0++* Fix: `inputInFocusedRegion` now drops `EvPaste` events in unfocused regions, so paste doesn't go to every `textInput` on screen. Previously only `EvKey` was gated on focus.+* Fix: `grout` no longer sets focus to `True` for its child elements. Instead it inherits focus from its parent.+* *Breaking change*: Add `_textInputConfig_acceptTab` to control tab key behavior in text inputs.+* Update the Nix build and project skeleton to NixOS 26.05 and support GHC 9.8, 9.10, and 9.12. Generated projects now pin the committed, upstream-available reflex-vty revision from which the skeleton is run.++## 1.1.0.0++* *Breaking change*: reflex-vty now builds on Windows. OS signals are handled through a platform-agnostic type called `AppSignal`. This changes `VtyApp`'s signal argument (`Event t AppSignal` instead of `Event t Signal` (synonym for `CInt`)).++## 1.0.0.1++* Add some more examples, especially of the new canvas features++## 1.0.0.0++* *Breaking change*: Add `HasColorProfile` class (with `colorProfile`/`localColorProfile` and a `ColorProfileReader` transformer) to `Reflex.Vty.Widget`. Widgets can call `colorProfile` to make decisions based on terminal capability.+* *Breaking change*: `CheckboxConfig._checkboxConfig_attributes` removed; `checkbox` reads from `HasTheme`.+* *Breaking change*: `HasDisplayRegion` now has `askViewport` and `localLayoutRegion` methods, separating layout height (inflated inside `scrollable`) from viewport height (real terminal size). Rendering widgets use `viewportWidth`/`viewportHeight`; layout system uses `displayWidth`/`displayHeight`.+* *Breaking change*: `HasTheme` now has a structured `Theme` record (in `Reflex.Vty.Theme`) instead of `Behavior t V.Attr`. Use `themeAttr` to get the `V.Attr`, or `theme` for the full record.+* *Breaking change*: `Reflex.Vty.Style.render` border attr now inherits from the content `baseAttr` instead of `transparentAttr`, so borders pick up themed foreground/background unless `withBorderForeground`/`withBorderBackground` is explicitly set.+* *Breaking change*: `Reflex.Vty.Style` re-exports color constants (`red`/`yellow`/`white`/etc.) from `Reflex.Vty`.+* *Breaking change*: `ScrollableConfig` has a new field `_scrollableConfig_scrollbarVisibility :: ScrollbarVisibility`.+* *Breaking change*: `TextInputConfig` has a new field, `_textInputConfig_alignment :: TextAlignment`, controlling how entered text is aligned within the input region. `def` uses `TextAlignment_Left`.+* *Breaking change*: `boxTitle` now takes a `Behavior t TextAlignment` as its first argument, controlling title alignment within the top border. Pass `pure TextAlignment_Center` to preserve the old behavior. `box` and `boxStatic` are unchanged.+* *Breaking change*: `scrollable` and `scrollableText` now require `PerformEvent t m`, `TriggerEvent t m`, and `MonadIO (Performable m)` constraints (needed for `ScrollbarWhileScrolling` debounce).+* *Breaking change*: `Reflex.Vty.Host.runVtyAppWithHandle`, `runVtyApp`, and `Reflex.Vty.Widget.mainWidget`/`mainWidgetWithHandle` now take a `VtyAppConfig` as their first argument. Use `def` (a `Default` instance) or `defaultVtyAppConfig` for the defaults. `_vtyConfig_eventQueueCapacity` configures the bounded event-queue capacity used to backpressure fast external producers.+* *Breaking change*: `Reflex.Vty.Widget.Input.Mouse.Drag` replaces the `_drag_end :: Bool` field with `_drag_state :: DragState`, where `DragState` is `DragStart | Dragging | DragEnd`. This distinguishes the start of a drag from its continuation ([#87](https://github.com/reflex-frp/reflex-vty/issues/87)). Migrate `_drag_end d` to `_drag_state d == DragEnd`. The pure state machine is now exposed as `stepDrag` for testing.+* Add `Reflex.Vty.Canvas` module: per-cell compositing with transparency. `Canvas` type (sparse `Map` of cells), `placeCanvas`, `translate`, `stack`, `imageToCanvas`/`canvasToImage` conversions.+* Add `Reflex.Vty.ColorProfile` module: `ColorProfile` datatype (`TrueColor`/`Ansi256`/`Ansi16`/`Ascii`/`NoTTY`), `detectColorProfile`/`colorProfileFromVty` to read the terminal's capability from vty handle, `convertColor` for downsampling, and `applyProfile` to downsample an entire `V.Attr` (resets colors/style to `Default` for `Ascii`/`NoTTY`).+* Add `Reflex.Vty.Color` module: `RGB` color type with `darken`, `lighten`, `complementary`, `mix`, `alpha` operations; `Gradient1D` (n-stop linear interpolation) and `Gradient2D` (bilinear corner interpolation); `toRGB`/`fromRGB` conversions to/from vty `Color`.+* Add `Reflex.Vty.Style.mergeAttr`: overlay one `V.Attr` on another, where `SetTo` fields take precedence and `Default`/`KeepCurrent` fall through.+* Add `Reflex.Vty.Style` border presets: `innerHalfBorder` (▀▄▌▐), `outerHalfBlockBorder` (▔▁▏▕).+* Add `Reflex.Vty.Style` image composition: `joinHorizontal`, `joinVertical`, `placeHorizontal`, `placeVertical`, `place`.+* Add `Reflex.Vty.Style` setters: `withTransform` (text transform), `withTabWidth` (tab expansion), `withMarginBackground` (colored margin), `withInline` (skip margin/padding/border), `withColorWhitespace` (toggle fill coloring), `withBorderTopForeground`/`withBorderBottomBackground`/etc (per-side border colors, 8 setters).+* Add `Reflex.Vty.Style` text utilities: `truncateWith` (ellipsis truncation respecting display width), `textHeight`, `textSize`.+* Add `Reflex.Vty.Style`: Lip Gloss-inspired declarative styling.+* Add `Reflex.Vty.Theme.darkTheme`.+* Add `Reflex.Vty.Theme` presets: `charmTheme`, `draculaTheme`, `nordTheme`, `zenburnTheme`, `gruvboxTheme`.+* Add `Reflex.Vty.Widget.Box.alignText`, a general-purpose text alignment function.+* Add `Reflex.Vty.Widget.Text.textWithAlignment`, an alignable version of `text`. `text` is now a synonym for `textWithAlignment TextAlignment_Left`.+* Add visual scrollbar to `Reflex.Vty.Widget.Scroll.scrollable` with four visibility modes: `ScrollbarAlways` (gutter + thumb), `ScrollbarThumbOnly` (thumb only), `ScrollbarWhileScrolling` (thumb appears while scrolling, hides via `debounce`), `ScrollbarHidden`. Default is `ScrollbarThumbOnly`. Controlled via `_scrollableConfig_scrollbarVisibility` on `ScrollableConfig`.+* Change `Reflex.Vty.Theme.darkTheme`: specify colors directly (`green` on `black`) instead of using `reverseVideo`.+* Fix `Reflex.Vty.Style.measure`: uses `textWidth` (wcwidth) and splits on newlines for correct multi-line and wide-character dimensions.+* Fix `Reflex.Vty.Style.render`: now handles multi-line text via `V.vertCat` per-line rendering.+* Fix `Reflex.Vty.Widget.Input.link`: now uses `_theme_link` on ambient `themeAttr` instead of `V.defAttr` to preserve themed background.+* Fix `Reflex.Vty.Widget.Text.richText`: now merges config attrs on `themeAttr` via `mergeAttr`, so `RichTextConfig def` inherits the ambient theme.+* Fix `textButton` centering: now uses `textWithAlignment TextAlignment_Center`.+* Fix `textInput` cursor: uses `_theme_textInputCursor` instead of hardcoded `reverseVideo`.+* Fix `Data.Text.Zipper.displayLinesWithAlignment`: the cursor is now rendered as a blank highlighted cell when it sits past the last character of a line or on an empty line.+* Fix space leak in `Reflex.Vty.Host.runVtyAppWithHandle`: an application that fired external triggers (e.g. a hot `performEventAsync` callback) faster than the host could process would grow the host's event channel without limit. The host now backpressures producers via a bounded, closeable event queue, and drains every available batch each frame (firing each in its own Reflex frame, redrawing once), so memory is bounded and no event occurrences are dropped. The bounded capacity is configurable via the new `VtyAppConfig` (see the breaking-change entry above; default 4096).+* Behavior change: external event triggers (`performEventAsync`, `newTriggerEvent`, etc.) may now block when the host's event queue is full, throttling a producer that fires faster than the host can process to the host's own rate. This is the intended flow-control; shutdown closes the queue so any blocked producer is released.+* Debounce terminal resize events (50ms) to reduce lag and flicker during window drag.+* Enable terminal focus tracking mode by default. Add `gainedFocus` and `lostFocus` helpers to `Reflex.Vty.Widget`.+* Enable bracketed paste by default. Add `paste` helper to `Reflex.Vty.Widget`. `textInput` now handles paste events.+* Add `mousePosition` helper to `Reflex.Vty.Widget.Input.Mouse` — tracks last known mouse coordinates from click/release events. True hover (motion without button) deferred — requires terminal mode 1003 which vty does not expose.+* Add terminal cursor control: `CursorStyle`, `CursorVisibility`, `CursorState`, and the `HasCursor` capability with `setCursor`/`tellCursor` helpers.+* Add alternate screen support: `ScreenMode`, `setScreenMode`, and the `HasScreenMode` capability with `tellScreenMode`/`enterAlternateScreen`/`exitAlternateScreen` helpers. The host restores normal screen on shutdown.+* *Breaking change*: `VtyApp` now takes a third argument, `Event t Signal`, exposing POSIX signals (SIGINT, SIGTERM, SIGHUP). SIGINT and SIGTERM automatically trigger clean shutdown, replacing the old Ctrl-C key detection.+* Install POSIX signal handlers (SIGINT, SIGTERM, SIGHUP) in `runVtyAppWithHandle`. Add `unix` dependency.++## 0.6.2.1++* Update dependency version bounds++## 0.6.2.0++* Relax bounds for GHC 9.12.2 by @plt-amy in https://github.com/reflex-frp/reflex-vty/pull/97+* scrollable: promptly use `displayHight` on scroll by @Rosuavio in https://github.com/reflex-frp/reflex-vty/pull/94++## 0.6.1.1++* Extend version bounds+* Add support for GHC 9.8.4++## 0.6.1.0++* Fix mouse input translation in scrollable elements++## 0.6.0.0++* *Breaking Change*: `Reflex.Vty.Widget.Scroll.scrollable`'s type has changed. The child widget no longer has to return images (see `captureImages` below), but can return a value. Specifically, the child widget type has gone from `m (Behavior t Image, Event t ())` to `m (Event t (), a)`.+* *Breaking Change*: Instance of `HasImageWriter` must now implement `captureImages`, a function that allows the `Image`s produced by a widget to be intercepted and not rendered. This is used to implement `scrollable`.+ ## 0.5.2.1 * Extend version bounds
README.md view
@@ -1,17 +1,78 @@+<div align="center">+ # reflex-vty -[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-vty.svg)](https://hackage.haskell.org/package/reflex-vty) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex-vty/blob/master/LICENSE)+**Build terminal user interfaces with functional reactive programming.** -Build terminal applications using functional reactive programming (FRP) with [Reflex FRP](https://reflex-frp.org).+reflex-vty provides a [Reflex FRP](https://reflex-frp.org) host and a library of reactive widgets for [Vty](https://hackage.haskell.org/package/vty) terminal applications: layout, text input and editing, boxes, scrolling, mouse support, focus management, and theming. -![Example Animation](https://i.imgur.com/FULQNtu.gif)+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-vty.svg)](https://hackage.haskell.org/package/reflex-vty) [![Github CI](https://github.com/reflex-frp/reflex-vty/actions/workflows/haskell.yml/badge.svg)](https://github.com/reflex-frp/reflex-vty/actions) [![Obsidian](https://img.shields.io/badge/Obsidian-Systems-white)](https://obsidian.systems) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) -Feature requests, pull requests, and other feedback are welcome and appreciated (see the [contribution guide](CONTRIBUTING.md)). This library-is still experimental, so big changes are possible!+<img src="https://vhs.charm.sh/vhs-4ch4hhuTGZMXLIOPgNcA0G.gif" alt="reflex-vty example walkthrough: gradient menu, to-do list, scrollbar modes, and styling showcase" width="80%">++</div>++### A minimal app++```haskell+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Reflex.Vty++main :: IO ()+main = mainWidget def $ do+  text "Hello, reflex-vty! Press Ctrl+C to quit."+  ctrlc+```++`mainWidget` takes a `VtyAppConfig` (`def` for the defaults) and runs a widget until the `Event t ()` it returns fires. Here that is `ctrlc`, which fires when the user presses Ctrl+C. Docs are available on [Hackage](https://hackage.haskell.org/package/reflex-vty/docs/Reflex-Vty.html).++### Features++- **Layout**: arrange widgets into rows and columns (`tile` / `grout`) with fixed or proportional (stretch) size constraints.+- **Focus**: tab-cycling focus management across the focusable widgets in a layout (`tabNavigation`).+- **Text**: word-wrapped text display, rich text with per-span attributes, and single- or multi-line text input backed by a zipper that handles wide characters, tabs, and wrapping.+- **Inputs**: clickable buttons, hyperlinks, and checkboxes.+- **Boxes**: single, thick, double, rounded, ASCII, inner-half, and outer-half border styles, with optional titles and horizontal rules.+- **Scrolling**: scrollable containers with programmatic scrolling, auto-scroll-to-bottom mode, and a visual scrollbar with four visibility modes (always, thumb-only, while-scrolling, hidden).+- **Split panes**: fixed horizontal and vertical splits, plus a mouse-draggable splitter you can resize at runtime (`splitVDrag`).+- **Mouse**: button clicks, drags (with from/to/button/modifier tracking), scroll-wheel events, and last-known mouse-position tracking.+- **Keyboard**: individual key and key-combo events, plus input filtering.+- **Runtime**: alternate-screen mode, terminal cursor control (shape, visibility, and position), bracketed paste, terminal focus tracking, resize, and POSIX signal handling.+- **Theming**: a `Theme` record with presets (default, dark, charm, dracula, nord, zenburn, gruvbox). Widgets inherit the ambient theme and can override locally.+- **Declarative styling**: Lip Gloss-inspired `Style` type with foreground/background colors, text attributes (bold/italic/underline/etc.), padding, margin, borders with per-side colors, width/height constraints, alignment, text transforms, tab expansion, inline mode, whitespace coloring, and border presets.+- **Color**: `RGB` color type, operations (`darken`, `lighten`, `complementary`, `mix`, `alpha`), and gradients (`Gradient1D`, `Gradient2D`).+- **Compositing**: `Reflex.Vty.Canvas` module with per-cell transparency for overlays and layered rendering.+- **Image composition**: `joinHorizontal`/`joinVertical`/`place` utilities for composing rendered images.+- **Color profiles**: automatic terminal color-capability detection (`TrueColor`/`Ansi256`/`Ansi16`/`Ascii`/`NoTTY`) with downsampling.++Run the bundled demo with `cabal run example` to see many of these in action: a text editor, a to-do list, scrollable text, clickable buttons, a live CPU-usage display with a true-color gradient bar, a scrollbar-modes demo, a terminal-cursor demo, and a little styling showcase featuring gradients, color operations, a canvas overlay, border presets, theming, and color-profile downsampling.++### Example gallery++Each of these examples is a module in [`src-bin/Example/`](src-bin/Example/). You can run any of them with `cabal run examples -- <name>`.++|                                                 |                                                                                                     |+| :--                                             | :--                                                                                                 |+| **`spinner`** — an animated braille spinner     | <img src="https://vhs.charm.sh/vhs-2ZldM9gFD9ovea54MAwio3.gif" alt="spinner demo" width="420">      |+| **`progress`** — a gradient-filled progress bar | <img src="https://vhs.charm.sh/vhs-3oJNQQcQH6vM4VyH7Yww56.gif" alt="progress bar demo" width="420"> |+| **`stopwatch`** — a tick-driven count-up timer  | <img src="https://vhs.charm.sh/vhs-5C8hkG3W9P4tATBBtLhxIm.gif" alt="stopwatch demo" width="420">    |+| **`timer`** — a count-down timer                | <img src="https://vhs.charm.sh/vhs-3gpq3fy1zWP3IsXysnT7WT.gif" alt="timer demo" width="420">        |+| **`textinput`** — a focused text-input field    | <img src="https://vhs.charm.sh/vhs-4FzSVaJAnGq4V1NNrk1lal.gif" alt="text input demo" width="420">   |+| **`pager`** — a scrollable text viewport        | <img src="https://vhs.charm.sh/vhs-7a2bCmFHleF9MG3KxY4yeh.gif" alt="pager demo" width="420">        |+| **`views`** — toggle between two views          | <img src="https://vhs.charm.sh/vhs-7rflGBcgFrmIQgk0JmZNKe.gif" alt="views demo" width="420">        |++**More demos**: full-screen canvas animations (the classic Doom fire, a plasma field, a starfield, an animated splash) live on the [examples page](EXAMPLES.md).++Feature requests, pull requests, and other feedback are welcome and appreciated (see the [contribution guide](CONTRIBUTING.md)).+ ### How to Build  #### With reflex-platform +Prebuilt Nix dependencies are available from `https://nixcache.reflex-frp.org`. NixOS users can enable the cache by following the [binary cache setup instructions](https://github.com/reflex-frp/reflex-platform/blob/f70e481fa59ecb7958abeb2cb928c79efcd65f43/notes/NixOS.md).+ Enter a nix-shell for the project: ```bash git clone https://github.com/reflex-frp/reflex-vty.git@@ -20,22 +81,22 @@ ```  From within the nix-shell you can:-* Run the example: `cabal repl example`+* Run the example: `cabal run example` * Load the library in the repl: `cabal repl reflex-vty` * Build the example executable: `cabal build example` * Build the docs: `cabal haddock`-* Run ghcid for immediate compiler feedback when you save a .hs file: `ghcid -c "cabal repl reflex-vty --ghc-options=-Wall"`+* Run ghcid for immediate compiler feedback when you save a .hs file: `ghcid -c "cabal repl library:reflex-vty executable:example test:reflex-vty-test --ghc-options=-Wall" -o ghcid-output.txt` * etc.  ##### Selecting a compiler -When entering the nix-shell, you can select from the following compilers: ghc-8.10.7 and ghc-9.4.3. By default, ghc-8.10.7 is selected. To enter a shell with ghc-9.4.3, run:+`nix-shell` defaults to GHC 9.12. The compilers defined in `release.nix` are `ghc98`, `ghc910`, and `ghc912`. To enter a shell with one of them, pass it as the `compiler` argument:  ```bash-nix-shell --argstr compiler ghc943+nix-shell --argstr compiler ghc98 ``` -You may need to run `cabal clean` and `cabal configure -w ghc-9.4.3` if you were previously working on the project with a different compiler.+If you were previously building with a different compiler, you may need to run `cabal clean` first.   #### With cabal@@ -46,8 +107,29 @@  ```bash # nix-shell -p cabal-install binutils icu # for nix users-cabal new-configure-cabal new-build # to build the library and example-cabal new-repl # to enter a repl for the library-cabal new-repl example # to enter a repl for the example executable+cabal build          # to build the library, example, and test suite+cabal repl           # to enter a multi-repl covering all components+cabal repl example   # to enter a repl for the example executable only ```++### Tests++```bash+cabal test all --enable-tests+```++See the [QA guide](doc/qa.md) for golden files, terminal checks, and coverage commands.++## About Obsidian Systems++reflex-vty is built and maintained by **[Obsidian Systems](https://obsidian.systems)**. We provide frontier engineering for high-assurance systems: we build production software in Haskell and Nix, and we're long-time stewards of open-source tooling like [Obelisk](https://github.com/obsidiansystems/obelisk), [Reflex](https://reflex-frp.org/), and [nix-thunk](https://github.com/obsidiansystems/nix-thunk).++If you're working with Reflex, terminal or web UIs in Haskell, or Nix and want a partner to help design, build, or ship it, we'd love to hear from you.++- Website: <https://obsidian.systems>+- Blog: <https://blog.obsidian.systems>+- GitHub: <https://github.com/obsidiansystems>++## License++reflex-vty is released under the [BSD-3-Clause License](LICENSE), © 2018 Obsidian Systems LLC.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
+ doc/qa.md view
@@ -0,0 +1,170 @@+# QA Guide++Use this guide for automated tests and manual terminal checks.++Run these commands from the repository root.++## Test suite++```bash+REFLEX_VTY_GOLDEN_UPDATE=0 cabal test all --enable-tests --test-show-details=direct+```++The portable suite uses an in-memory Vty to run the production host.+It compares rendered spans, including wide characters, combining marks, and attributes.++## Golden files++Missing or different golden files cause test failures. Tests do not change these files in normal mode.+To replace local golden files, use this command:++```bash+REFLEX_VTY_GOLDEN_UPDATE=1 cabal test reflex-vty-test --enable-tests --test-option=--match=Golden+```++Review each changed fixture before you commit it. Update mode cannot run when `CI=true`.+The source-distribution CI job checks fixture bytes in the package.+It then runs the suite from the extracted package.++## Terminal checks++```bash+cabal build -ftest-tools reflex-vty-test-driver+python3 test/pty_smoke.py "$(cabal list-bin -ftest-tools reflex-vty-test-driver)"+```++The PTY checks require POSIX, Python 3, a UTF-8 locale, and the `xterm-256color` terminfo entry.+They check terminal input, paste, resize, and scrolling.+They also check terminal restoration after normal exits, signals, and exceptions.+The harness drains terminal output while waiting for shutdown, so PTY backpressure cannot block the child.+On Darwin, restoration comparisons exclude only `PENDIN`, the kernel-managed pending-input flag set when canonical mode is restored; all other flags, speeds, and control characters must match.+Windows runs the portable suite and separate console-handler checks.+These tests do not check interactive ConPTY operation.++## Coverage++Coverage includes every declared module in both libraries, including modules that did not execute.+`test/Coverage.hs` compares expression, boolean-pair, and alternative ratios with `test/coverage-baseline.tsv` for each module.+These ratios do not prove complete behavioral coverage.+Use GHC **9.12.3** with optimization disabled and a new instrumented build directory for baseline comparisons.+Use the coverage commands in [the CI workflow](../.github/workflows/haskell.yml).+CI pins GHCup metadata to install the original release and checks `ghc --numeric-version` before building.+GHCup's current default metadata may resolve `9.12.3` to `9.12.3.20260311`; that dated rebuild does not match this baseline.+When changing the coverage compiler, update the metadata pin, workflow version check, reporting tool, and measured baseline together.++The reporting tool must use the Cabal version that wrote `setup-config`.+The workflow specifies Cabal **3.16.1.0**. GHC can supply a different Cabal version.+Install the specified Cabal library in a separate package environment:++```bash+cabal install --lib Cabal-3.16.1.0 extra --package-env=/tmp/reflex-vty-coverage.env+```++Before you run the instrumented suite, create an empty `dist-coverage/child-tix` directory.+Create `dist-coverage/child-tix/run-start` with `touch`.+Set `REFLEX_VTY_COVERAGE_CHILD_DIR` to the absolute path of the child directory and export the variable.+Keep this variable set during analysis.+The tool rejects unknown child files.+It also rejects child tick files older than the marker or newer than the parent tick file.+After the suite passes, use this command to update the local baseline:++```bash+runghc -package-env=/tmp/reflex-vty-coverage.env \+  -package=Cabal -package=hpc -package=extra -package=directory \+  -package=filepath -package=process -package=time -package=containers \+  test/Coverage.hs update dist-coverage test/coverage-baseline.tsv dist-coverage/report+```++Review the baseline changes before you commit them.+Use `check` instead of `update` to compare coverage with the committed baseline.+Analysis does not change the tick files. Repeated checks use the same data.+Baseline updates cannot run when `CI=true`.++## Manual checks++These checks require Nix.++Clone and examples++```bash+nix-shell -p git+cd $(mktemp -d)+git clone https://github.com/reflex-frp/reflex-vty.git --branch develop+nix run -f reflex-vty/release.nix reflex-vty --command example+```++The build may take a while to complete.++Once it's done you can test the following:++  * On the main menu, make sure the top line shows a "reflex-vty · functional reactive terminal UIs" banner whose characters fade through a pink → violet → cyan true-color gradient.++  * Make sure that resizing your terminal window causes the editor to resize as well.++  * Click on `Todo List`.+    * Make sure a cyan "To-Do · Tab to move · Space/click/Ctrl+T toggles · Enter adds a task" header appears above the list.+    * Make sure you can check and uncheck a task by clicking its checkbox, or by focusing the checkbox (see the focus indicators below) and pressing <kbd>Space</kbd>. Make sure you can add new tasks and edit the text of tasks.+    * Make sure pressing <kbd>Enter</kbd> while a row is focused inserts a new empty task directly beneath that row (not at the bottom of the list) and moves focus to it, so you can type immediately. The other rows keep their text and checkbox state. Pressing <kbd>Enter</kbd> on the last row, or clicking "Add another task", appends at the end.+    * Make sure pressing <kbd>Ctrl</kbd>+<kbd>T</kbd> toggles the focused row's checkbox from anywhere in the row, including while the text field is focused (and that it does not type a literal character into the text field).+    * Make sure a cyan "▸" caret appears in the left gutter of the focused row, and that pressing <kbd>Tab</kbd> / <kbd>Shift</kbd>+<kbd>Tab</kbd> moves it from row to row (and between the checkbox and the text field within a row).+    * Make sure that, within the focused row, you can tell which element has focus: the checkbox is drawn in reverse video when it is focused, and a reverse-video cursor block appears in the text field when the text field is focused — including at the very end of the text and in an empty (newly added) task, where it sits on a blank cell.+    * Make sure that resizing your terminal window causes the editor to resize as well.+    * Type <kbd>Esc</kbd>.++  * Click on `Text Editor`.+    * Make sure you can edit text in the "Text Edit" box. Try entering lots of text so that it doesn't all fit. It should scroll down as you type. Using they arrow keys on your keyboard should move the cursor and let you go back up and see text that was out of view before.+    * Make sure that clicking, right-clicking, using the scroll-wheel on your mouse, and dragging in the "Text Edit" box updates the message in the box lying above and behind the "Text Edit" box.+    * Make sure that dragging your mouse cursor around inside the lowest box causes the message to update. This should update only when dragging *inside* that box, not outside of it.+    * Make sure that resizing your terminal window causes the boxes to resize as well.+    * Type <kbd>Esc</kbd>.++  * Click on `Scrollable text display`.+    * Make sure that you can scroll up and down through the small box of text with your mouse's scroll wheel. The box has a rounded, cyan-tinted border titled "De Bello Gallico", and the Latin body text stays in the default (un-tinted) color.+    * Make sure that the second box, "This one scrolls automatically as the output grows", appends one timestamped line per second and stays scrolled to the bottom as new lines appear.+    * Make sure that the "Height", "Scroll", and "Length" readouts below (inside a cyan-tinted box titled "Scroll state") update as you scroll and as new lines arrive.+    * Make sure that resizing your terminal window causes the boxes to resize as well.+    * Type <kbd>Esc</kbd>.++  * Click on `Clickable buttons`.+    * Make sure that clicking each of the nine buttons (or focusing one and pressing <kbd>Enter</kbd> or <kbd>Space</kbd>) appends its associated emoji into the "CLICK BUTTONS TO DRAW" box.+    * Make sure the "CLICK BUTTONS TO DRAW" box has a rounded, cyan-tinted border and title.+    * Make sure the focused button is rendered with a double-line border; unfocused buttons use the default single-line border.+    * Type <kbd>Esc</kbd>.++  * Click on `CPU Usage`.+    * Make sure a vertical bar appears inside the titled box and updates several times per second.+    * Make sure the bar is filled with a smooth vertical true-color gradient — green at the bottom, through yellow and orange, to red at the top — and that its top edge uses partial unicode block elements (▁▂▃…█). The bar grows upward as CPU load increases.+    * Make sure that resizing your terminal window causes the chart to resize as well.+    * Type <kbd>Esc</kbd>.++  * Click on `Scrollbar modes`.+    * Make sure a cyan instruction header appears above the panels.+    * Make sure you see four side-by-side panels labeled "Always", "Thumb Only", "While Scrolling", and "Hidden", each containing 50 lines of numbered text.+    * Make sure the "Always" panel shows a gutter (░) with a solid thumb (█) on the right side.+    * Make sure the "Thumb Only" panel shows just the thumb (█), no gutter.+    * Make sure the "While Scrolling" panel shows a thumb only while you are actively scrolling (arrow keys or mouse wheel); it should disappear when you press a non-scroll key.+    * Make sure the "Hidden" panel has no scrollbar at all and its text uses the full width.+    * Make sure that resizing your terminal window causes the panels to resize as well.+    * Type <kbd>Esc</kbd>.++  * Click on `Cursor`.+    * Make sure a cyan instruction header appears at the top of the panel.+    * Make sure a real terminal cursor (not the reverse-video fake) appears at position 0,0 inside the panel.+    * Make sure the arrow keys move the terminal cursor around; it should track the displayed position.+    * Make sure pressing <kbd>s</kbd> cycles the cursor shape through `CursorStyleBlock`, `CursorStyleUnderline`, and `CursorStyleBar` (your terminal must support DECSCUSR).+    * Make sure pressing <kbd>v</kbd> toggles cursor visibility on and off.+    * Type <kbd>Esc</kbd>.++  * Click on `Showcase`. This is one scrollable screen with a header line and two columns; scroll it with the mouse wheel or arrow keys.+    * Make sure the header line shows the current theme name, your terminal's detected `ColorProfile` (e.g. `ColorProfile_TrueColor`), a focus indicator (● focused / ○ unfocused), and the last-known mouse position. The focus indicator should flip when you switch to another terminal window and back; the mouse position should update as you move the mouse over the pane.+    * In the left column, make sure you see labeled samples demonstrating every border preset (single, rounded, thick, double, ascii), padding and margin, foreground/background colors (including an RGB true-color swatch), color operations (darken, lighten, mix, complementary), a 1D gradient swatch (red→green→blue) that fills the width of its row and transitions smoothly, a canvas overlay (a bordered box floating over background text that shows through around it), text transforms (bold, italic, underline, reverse), horizontal alignment within a fixed-width box (left/center/right), a combined rounded-border + padded + colored box, and a hyperlink (underline + OSC 8 clickable in supporting terminals).+    * In the right column, make sure you see themed widgets (a button, a checkbox, a link, and a text input) and a row of color-profile swatches showing the same RGB orange (200,100,50) rendered through each profile: TrueColor shows the exact orange, Ansi256 a close approximation, Ansi16 the nearest ANSI color, and Ascii/NoTTY plain text with no color.+    * Make sure pressing <kbd>Tab</kbd> cycles through the seven predefined themes (`default`, `dark`, `charm`, `dracula`, `nord`, `zenburn`, `gruvbox`), updating the header label and the colors of every element each time. The checkbox should still toggle, and the text input should accept typing in every theme.+    * Make sure that resizing your terminal window causes the layout to resize as well.+    * Type <kbd>Esc</kbd>.++  * Type <kbd>Ctrl</kbd>+<kbd>C</kbd> (or send SIGTERM / `kill <pid>`) to quit.++  * Make sure that after quitting, the terminal restores the content that was on screen before the app launched (alternate screen mode).++There should be 8 examples to cover (Todo List, Text Editor, Scrollable text display, Clickable buttons, CPU Usage, Scrollbar modes, Cursor, Showcase). If there are more or fewer than this then this QA guide is out of date and QA should fail.
+ internal/Reflex/Vty/Host/Signal.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Reflex.Vty.Host.Signal+-- Description: Cross-platform OS signal handling for reflex-vty.+module Reflex.Vty.Host.Signal+  ( AppSignal (..)+  , installAppSignalHandlers+  ) where++import Control.Exception (SomeException, mask, throwIO, try)+import Control.Monad (forM_, void)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Foreign.C.Types (CInt)++#if defined(mingw32_HOST_OS)+import qualified GHC.ConsoleHandler as Console+#else+import System.Posix.Signals (Handler (Catch), installHandler, sigHUP, sigINT, sigTERM)+#endif++-- | An OS-level signal delivered to a running application.+--+--   * 'AppSignal_Interrupt': POSIX @SIGINT@ or Windows @ControlC@+--   * 'AppSignal_Terminate': POSIX @SIGTERM@ or Windows @Shutdown@+--   * 'AppSignal_Hangup': POSIX @SIGHUP@ or Windows @Close@ or Windows @Logoff@+--+-- All other signals go through the 'AppSignal_Platform' constructor.+data AppSignal+  = AppSignal_Interrupt+  | AppSignal_Terminate+  | AppSignal_Hangup+  | AppSignal_Platform CInt+  deriving (Eq, Show)++-- | Install handlers for OS signals. Returns an action that restores+-- the previous handlers. Acquisition is masked. If any registration+-- fails, every handler installed so far is restored before the+-- exception propagates.+installAppSignalHandlers :: (AppSignal -> IO ()) -> IO (IO ())++#if defined(mingw32_HOST_OS)++-- via 'GHC.ConsoleHandler'+installAppSignalHandlers fire =+  mask $ \_ -> do+    r <- try (Console.installHandler (Console.Catch (fire . toAppSignal)))+    case r of+      Left (e :: SomeException) -> throwIO e+      Right previous -> pure (void (Console.installHandler previous))+  where+    toAppSignal :: Console.ConsoleEvent -> AppSignal+    toAppSignal ev = case ev of+      Console.ControlC -> AppSignal_Interrupt -- Ctrl-C: same intent as SIGINT.+      Console.Break -> AppSignal_Interrupt -- Ctrl-Break: closest to an interrupt.+      Console.Close -> AppSignal_Hangup -- Console window closed: the terminal is going away.+      Console.Logoff -> AppSignal_Hangup -- User logging off: the session is going away.+      Console.Shutdown -> AppSignal_Terminate -- System shutting down: clean termination.++#else++installAppSignalHandlers fire =+  mask $ \_ -> do+    installed <- newIORef ([] :: [(Handler, Handler -> IO ())])+    r <-+      try $+        forM_ signals $ \(sig, appSignal) -> do+          previous <- installHandler sig (Catch (fire appSignal)) Nothing+          modifyIORef' installed ((previous, \h -> void (installHandler sig h Nothing)) :)+    case r of+      Left (e :: SomeException) -> do+        rollback installed+        throwIO e+      Right () -> pure (rollback installed)+  where+    rollback :: IORef [(Handler, Handler -> IO ())] -> IO ()+    rollback installed =+      readIORef installed >>= \ps -> forM_ ps (\(previous, restoreOne) -> restoreOne previous)+    signals =+      [ (sigINT, AppSignal_Interrupt)+      , (sigTERM, AppSignal_Terminate)+      , (sigHUP, AppSignal_Hangup)+      ]++#endif
+ internal/Reflex/Vty/Host/Trigger.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module: Reflex.Vty.Host.Trigger+-- Description: A bounded 'TriggerEvent' layer that backpressures hot producers+--+-- This is an internal module used by "Reflex.Vty.Host". It provides a+-- direct replacement for reflex's+-- @'Reflex.TriggerEvent.Base.TriggerEventT'@ whose underlying queue is+-- bounded and closeable. External triggers+-- ('Reflex.performEventAsync', 'Reflex.newTriggerEvent', etc.) write+-- into a fixed-capacity queue. A producer that fires faster than the+-- host can process is throttled: its @fire@ callback blocks when the+-- queue is full. Memory use stays bounded. Because the producer's own+-- write blocks, no event occurrences are dropped.+--+-- The queue is also closeable. On shutdown the host closes it. This+-- releases any producer currently blocked on a full queue.+module Reflex.Vty.Host.Trigger+  ( -- * Bounded event queue+    BoundedEventQueue+  , Batch+  , newBoundedEventQueue+  , closeBoundedEventQueue+  , writeBoundedEventQueue+  , drainBoundedEventQueue++    -- * TriggerEvent transformer+  , BoundedTriggerT+  , runBoundedTriggerT+  ) where++import Control.Concurrent.STM+  ( STM+  , TBQueue+  , TMVar+  , atomically+  , flushTBQueue+  , newEmptyTMVarIO+  , newTBQueueIO+  , orElse+  , readTBQueue+  , readTMVar+  , tryPutTMVar+  , writeTBQueue+  )+import Control.Monad (void)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Morph (MFunctor (hoist))+import Control.Monad.Primitive (PrimMonad (..))+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Ref (MonadAtomicRef (..), MonadRef (..), Ref)+import Control.Monad.Trans (MonadTrans, lift)+import Data.Coerce (coerce)+import Data.Dependent.Sum (DSum ((:=>)))+import Numeric.Natural (Natural)+import Reflex+import Reflex.Host.Class (MonadReflexCreateTrigger (..), newEventWithTriggerRef)++-- | A pending batch of trigger invocations. Each external @fire@ enqueues one+-- such batch (almost always a singleton).+type Batch t = [DSum (EventTriggerRef t) TriggerInvocation]++-- | A bounded, closeable queue of pending trigger invocations.+--+-- * Writes ('writeBoundedEventQueue') block when the queue is full.+--   This applies backpressure to the producer.+-- * Once closed, writes return immediately without enqueueing.+--   Producers blocked at shutdown are released.+-- * Reads ('drainBoundedEventQueue') block until at least one batch is+--   available (or the queue is closed), then drain everything+--   currently queued.+data BoundedEventQueue t = BoundedEventQueue+  { _beqQueue :: !(TBQueue (Batch t))+  , _beqClosed :: !(TMVar ())+  -- ^ Full when the queue has been closed.+  }++-- | Create a bounded event queue with the given capacity. Capacity+-- must be at least 1. Smaller values are clamped to 1.+newBoundedEventQueue :: Natural -> IO (BoundedEventQueue t)+newBoundedEventQueue cap =+  BoundedEventQueue+    <$> newTBQueueIO (max 1 cap)+    <*> newEmptyTMVarIO++-- | Close a queue. Idempotent. After this call, blocked and future writers+-- return immediately without enqueueing.+closeBoundedEventQueue :: BoundedEventQueue t -> IO ()+closeBoundedEventQueue q = atomically $ void $ tryPutTMVar (_beqClosed q) ()++-- | Enqueue a batch, blocking if the queue is full. This becomes a+-- no-op once the queue is closed. A producer blocked here then+-- unblocks on shutdown. Closure is checked first, in the same+-- transaction, so a closed queue refuses writes even when it has+-- spare capacity.+writeBoundedEventQueue :: BoundedEventQueue t -> Batch t -> STM ()+writeBoundedEventQueue q batch =+  void (readTMVar (_beqClosed q)) `orElse` writeTBQueue (_beqQueue q) batch++-- | Block until at least one batch is available. Then return it+-- together with every other batch currently queued, as a list of+-- distinct batches (not concatenated). The host fires each batch in+-- its own frame, so multiple occurrences of the same trigger that+-- landed in the same drain are preserved. Reflex collapses+-- simultaneous same-trigger firings; firing them as one batch would+-- drop occurrences. Returns 'Nothing' if the queue is closed and+-- empty.+drainBoundedEventQueue :: BoundedEventQueue t -> IO (Maybe [Batch t])+drainBoundedEventQueue q =+  atomically $+    let readFirst = Just <$> readTBQueue (_beqQueue q)+        waitClosed = Nothing <$ readTMVar (_beqClosed q)+    in do+         mFirst <- readFirst `orElse` waitClosed+         case mFirst of+           Nothing -> return Nothing+           Just first -> do+             rest <- flushTBQueue (_beqQueue q)+             return $ Just (first : rest)++----------------------------------------------------------------------------+-- TriggerEvent transformer+----------------------------------------------------------------------------++-- | A 'TriggerEvent' implementation that writes external triggers into a+-- 'BoundedEventQueue', applying backpressure when the queue is full. It is a+-- direct replacement for @TriggerEventT@ with the same instance set. Only its+-- 'TriggerEvent' instance differs. It routes writes through+-- 'writeBoundedEventQueue'.+newtype BoundedTriggerT t m a = BoundedTriggerT+  { unBoundedTriggerT :: ReaderT (BoundedEventQueue t) m a+  }+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadCatch+    , MonadFix+    , MonadIO+    , MonadMask+    , MonadThrow+    )++-- | Run a 'BoundedTriggerT' action against a particular 'BoundedEventQueue'.+runBoundedTriggerT :: BoundedTriggerT t m a -> BoundedEventQueue t -> m a+runBoundedTriggerT = runReaderT . unBoundedTriggerT++instance MonadTrans (BoundedTriggerT t) where+  lift = BoundedTriggerT . lift++instance MFunctor (BoundedTriggerT t) where+  hoist f = BoundedTriggerT . hoist f . unBoundedTriggerT++instance PrimMonad m => PrimMonad (BoundedTriggerT t m) where+  type PrimState (BoundedTriggerT t m) = PrimState m+  primitive = lift . primitive++instance PerformEvent t m => PerformEvent t (BoundedTriggerT t m) where+  type Performable (BoundedTriggerT t m) = Performable m+  performEvent_ = lift . performEvent_+  performEvent = lift . performEvent++instance PostBuild t m => PostBuild t (BoundedTriggerT t m) where+  getPostBuild = lift getPostBuild++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BoundedTriggerT t m) where+  newEventWithTrigger = lift . newEventWithTrigger+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance NotReady t m => NotReady t (BoundedTriggerT t m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance MonadRef m => MonadRef (BoundedTriggerT t m) where+  type Ref (BoundedTriggerT t m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (BoundedTriggerT t m) where+  atomicModifyRef r = lift . atomicModifyRef r++instance MonadSample t m => MonadSample t (BoundedTriggerT t m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (BoundedTriggerT t m) where+  hold v0 v' = lift $ hold v0 v'+  holdDyn v0 v' = lift $ holdDyn v0 v'+  holdIncremental v0 v' = lift $ holdIncremental v0 v'+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++instance Adjustable t m => Adjustable t (BoundedTriggerT t m) where+  runWithReplace (BoundedTriggerT a0) a' = BoundedTriggerT $ runWithReplace a0 (coerceEvent a')+  traverseIntMapWithKeyWithAdjust f dm0 dm' =+    BoundedTriggerT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'+  traverseDMapWithKeyWithAdjust f dm0 dm' =+    BoundedTriggerT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' =+    BoundedTriggerT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'++instance+  ( Monad m+  , MonadRef m+  , Ref m ~ Ref IO+  , MonadReflexCreateTrigger t m+  )+  => TriggerEvent t (BoundedTriggerT t m)+  where+  newTriggerEvent = do+    (e, t) <- newTriggerEventWithOnComplete+    return (e, \a -> t a $ return ())+  newTriggerEventWithOnComplete = do+    q <- BoundedTriggerT ask+    (eResult, reResultTrigger) <- lift newEventWithTriggerRef+    return . (,) eResult $ \a cb ->+      atomically $ writeBoundedEventQueue q [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]+  newEventWithLazyTriggerWithOnComplete f = do+    q <- BoundedTriggerT ask+    lift . newEventWithTrigger $ \t ->+      f $ \a cb -> do+        reResultTrigger <- newRef $ Just t+        atomically $ writeBoundedEventQueue q [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
reflex-vty.cabal view
@@ -1,32 +1,101 @@+cabal-version: 3.0 name: reflex-vty-version: 0.5.2.1+version: 1.3.0.0 synopsis: Reflex FRP host and widgets for VTY applications description:   Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).   .-  <<https://i.imgur.com/FULQNtu.gif>>-license: BSD3+  <<https://vhs.charm.sh/vhs-1QNXpqEc9fg8E2WKtkDsD9.gif>>+license: BSD-3-Clause license-file: LICENSE author: Obsidian Systems LLC maintainer: maintainer@obsidian.systems copyright: 2020 Obsidian Systems LLC category: FRP build-type: Simple-cabal-version: 1.18 extra-source-files:   README.md+  test/goldens/*.txt+  test/coverage-baseline.tsv+  test/Coverage.hs+  test/pty_smoke.py+extra-doc-files:+  doc/tasks.png+  doc/qa.md   ChangeLog.md-extra-doc-files: doc/tasks.png tested-with:-  GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.4.5 || ==9.6.1+  GHC ==9.8.4 || ==9.10.1 || == 9.12.2  source-repository head   type: git   location: https://github.com/reflex-frp/reflex-vty +common library-settings+  default-language: Haskell2010+  ghc-options: -Wall+  default-extensions:+    BangPatterns+    ConstraintKinds+    CPP+    DataKinds+    DefaultSignatures+    DeriveFunctor+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    OverloadedStrings+    PatternGuards+    PolyKinds+    QuasiQuotes+    RankNTypes+    RecursiveDo+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeApplications+    TypeOperators+    TypeFamilies++-- Keep the trigger queue and signal handlers in a private library.+-- Tests can use these modules without public exports or duplicate sources.+library reflex-vty-internal+  import: library-settings+  visibility: private+  hs-source-dirs: internal+  exposed-modules:+    Reflex.Vty.Host.Signal+    Reflex.Vty.Host.Trigger+  build-depends:+    base >= 4.10.0 && < 4.22,+    dependent-sum >= 0.7 && < 0.8,+    exceptions >= 0.10 && < 0.11,+    mmorph >= 1.1 && < 1.3,+    mtl >= 2.2.2 && < 2.4,+    primitive >= 0.6.3 && < 0.10,+    ref-tf >= 0.4.0 && < 0.6,+    reflex >= 0.9.2 && < 1,+    stm >= 2.4 && < 2.6,+    transformers >= 0.5.5 && < 0.7+  if !os(windows)+    build-depends: unix >= 2.7 && < 2.10+ library+  import: library-settings   exposed-modules: Reflex.Vty+                 , Reflex.Vty.Canvas+                 , Reflex.Vty.Color+                 , Reflex.Vty.ColorProfile                  , Reflex.Vty.Host+                 , Reflex.Vty.Style+                 , Reflex.Vty.Theme                  , Reflex.Vty.Widget                  , Reflex.Vty.Widget.Box                  , Reflex.Vty.Widget.Input@@ -37,32 +106,59 @@                  , Reflex.Vty.Widget.Split                  , Reflex.Vty.Widget.Text                  , Data.Text.Zipper-                 , Reflex.Spider.Orphans                  , Control.Monad.NodeId   build-depends:-    base >= 4.10.0 && < 4.20,+    base >= 4.10.0 && < 4.22,+    async >= 2.2.6 && < 2.3,     bimap >= 0.3.3 && < 0.6,-    containers >= 0.5.0 && < 0.7,+    bytestring >= 0.12.1 && < 0.13,+    containers >= 0.5.0 && < 0.8,     mtl >= 2.2.2 && < 2.4,     transformers >= 0.5.5 && < 0.7,     stm >= 2.4 && < 2.6,-    data-default >= 0.7.1 && < 0.8,+    data-default >= 0.7.1 && < 0.9,     dependent-map >= 0.4 && < 0.5,     exceptions >= 0.10 && < 0.11,-    text >= 1.2.3 && < 2.1,+    text >= 1.2.3 && < 2.2,     dependent-sum >= 0.7 && < 0.8,     exception-transformers >= 0.4.0 && < 0.5,     mmorph >= 1.1 && < 1.3,     ordered-containers >= 0.2.2 && < 0.3,-    primitive >= 0.6.3 && < 0.9,+    primitive >= 0.6.3 && < 0.10,     ref-tf >= 0.4.0 && < 0.6,     reflex >= 0.9.2 && < 1,-    time >= 1.8.0 && < 1.13,-    vty >= 6.0 && < 6.3,-    vty-crossplatform >= 0.1 && < 0.5+    time >= 1.8.0 && < 1.15,+    vector >= 0.12 && < 0.14,+    vty >= 6.0 && < 6.7,+    vty-crossplatform >= 0.1 && < 0.6,+    reflex-vty:reflex-vty-internal   hs-source-dirs: src++flag leaktest+  description: Build the space-leak profiling repro (src-bin/leaktest.hs)+  manual: True+  default: False++flag test-tools+  description: Build the PTY test driver (reflex-vty-test-driver).+  manual: True+  default: False++executable example+  hs-source-dirs: src-bin+  main-is: example.hs+  ghc-options: -threaded -Wall+  build-depends:+    base,+    containers,+    reflex,+    reflex-vty,+    text,+    time,+    transformers,+    vty   default-language: Haskell2010-  ghc-options: -Wall+  other-modules: Example.CPU   default-extensions:     BangPatterns     ConstraintKinds@@ -94,9 +190,9 @@     TypeOperators     TypeFamilies -executable example+executable examples   hs-source-dirs: src-bin-  main-is: example.hs+  main-is: examples.hs   ghc-options: -threaded -Wall   build-depends:     base,@@ -105,54 +201,123 @@     reflex-vty,     text,     time,-    transformers,     vty   default-language: Haskell2010-  other-modules: Example.CPU+  other-modules:+    Example.CellBuffer+    Example.Common+    Example.DoomFire+    Example.Pager+    Example.Progress+    Example.Space+    Example.Spinner+    Example.Splash+    Example.Stopwatch+    Example.TextInput+    Example.Timer+    Example.Views   default-extensions:-    BangPatterns     ConstraintKinds-    CPP-    DataKinds-    DefaultSignatures-    DeriveFunctor-    DeriveGeneric     FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    KindSignatures     LambdaCase-    MultiParamTypeClasses-    MultiWayIf     OverloadedStrings-    PatternGuards-    PolyKinds-    QuasiQuotes     RankNTypes-    RecursiveDo     ScopedTypeVariables-    StandaloneDeriving-    TemplateHaskell-    TupleSections-    TypeApplications-    TypeFamilies +executable leaktest+  if !flag(leaktest)+    buildable: False+  hs-source-dirs: src-bin+  main-is: leaktest.hs+  ghc-options: -threaded -Wall -rtsopts+  build-depends:+    base,+    async >= 2.2.6 && < 2.3,+    reflex,+    reflex-vty,+    text,+    transformers,+    vty+  default-language: Haskell2010+  default-extensions:+    LambdaCase+    OverloadedStrings +executable reflex-vty-test-driver+  if !flag(test-tools) || os(windows)+    buildable: False+  hs-source-dirs: test/pty+  main-is: Main.hs+  ghc-options: -threaded -Wall+  default-language: Haskell2010+  build-depends:+    base >= 4.10.0 && < 4.22,+    reflex-vty,+    reflex >= 0.9.2 && < 1,+    vty >= 6.0 && < 6.5,+    text,+    bytestring,+    transformers >= 0.5.5 && < 0.7,+    data-default+  if !os(windows)+    build-depends: unix >= 2.7 && < 2.10+ test-suite reflex-vty-test   hs-source-dirs: test   main-is: Spec.hs   type: exitcode-stdio-1.0   ghc-options: -threaded   other-modules:+    Control.Monad.NodeIdSpec     Data.Text.ZipperSpec+    Reflex.Vty.Test.Generators+    Reflex.Vty.CanvasSpec+    Reflex.Vty.ColorProfileSpec+    Reflex.Vty.ColorSpec+    Reflex.Vty.HostSpec+    Reflex.Vty.Host.SignalSpec+    Reflex.Vty.Host.TriggerSpec+    Reflex.Vty.Test.AppHarness+    Reflex.Vty.StyleSpec+    Reflex.Vty.StyleJoinSpec+    Reflex.Vty.Test.Snapshot+    Reflex.Vty.Test.SnapshotSpec+    Reflex.Vty.Test.GoldenPolicySpec+    Reflex.Vty.Test.GoldenSpec+    Reflex.Vty.Widget.BoxSpec+    Reflex.Vty.Widget.CursorSpec+    Reflex.Vty.Widget.LayoutSpec+    Reflex.Vty.WidgetSpec+    Reflex.Vty.Widget.InputSpec+    Reflex.Vty.Widget.Input.TextSpec+    Reflex.Vty.Widget.TextSpec+    Reflex.Vty.Widget.SplitSpec+    Reflex.Vty.ThemeSpec+    Reflex.Vty.CompositionSpec+    Reflex.Vty.Widget.MouseSpec+    Reflex.Vty.Widget.ScrollSpec   build-depends:     base,     reflex,+    async >= 2.2.6 && < 2.3,+    bytestring,+    dependent-sum,     containers,+    directory,+    exceptions,+    filepath,+    ordered-containers,+    process >= 1.6 && < 1.7,     reflex-vty,+    reflex-vty:reflex-vty-internal,+    stm,     text,+    transformers,+    vector >= 0.12 && < 0.14,     extra,-    hspec >= 2.7 && < 2.12+    QuickCheck >= 2.14 && < 2.16,+    hspec >= 2.7 && < 2.12,+    vty+  if !os(windows)+    build-depends: unix >= 2.7 && < 2.10   default-language: Haskell2010
src-bin/Example/CPU.hs view
@@ -1,34 +1,34 @@-{-|-  Description: A CPU usage indicator--}+-- |+--   Description: A CPU usage indicator module Example.CPU where  import Control.Exception import Control.Monad.Fix import Control.Monad.IO.Class import Data.Ratio+import qualified Data.Text as T import Data.Time import Data.Word-import qualified Data.Text as T import qualified Graphics.Vty as V+import Reflex import Text.Printf -import Reflex+import Data.Text.Zipper (TextAlignment (..)) import Reflex.Vty  -- | Each constructor represents a cpu statistic column as presented in @/proc/stat@ data CpuStat-   = CpuStat_User-   | CpuStat_Nice-   | CpuStat_System-   | CpuStat_Idle-   | CpuStat_Iowait-   | CpuStat_Irq-   | CpuStat_Softirq-   | CpuStat_Steal-   | CpuStat_Guest-   | CpuStat_GuestNice-   deriving (Show, Read, Eq, Ord, Enum, Bounded)+  = CpuStat_User+  | CpuStat_Nice+  | CpuStat_System+  | CpuStat_Idle+  | CpuStat_Iowait+  | CpuStat_Irq+  | CpuStat_Softirq+  | CpuStat_Steal+  | CpuStat_Guest+  | CpuStat_GuestNice+  deriving (Bounded, Enum, Eq, Ord, Read, Show)  -- | Read @/proc/stat@ getCpuStat :: IO (Maybe (CpuStat -> Word64))@@ -85,7 +85,6 @@ -- > ║█████████████████████████████║ -- > ║█████████████████████████████║ -- > ╚═════════════════════════════╝--- cpuStats   :: ( Reflex t      , MonadFix m@@ -100,17 +99,19 @@      , HasLayout t m      , HasFocus t m      , HasInput t m-     , HasFocusReader t m, HasTheme t m+     , HasFocusReader t m+     , HasTheme t m      )   => m () cpuStats = do   tick <- tickLossy 0.25 =<< liftIO getCurrentTime   cpuStat :: Event t (Word64, Word64) <- fmap (fmapMaybe id) $-    performEvent $ ffor tick $ \_ -> do-      get <- liftIO getCpuStat-      pure $ case get of-        Nothing -> Nothing-        Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats)+    performEvent $+      ffor tick $ \_ -> do+        get <- liftIO getCpuStat+        pure $ case get of+          Nothing -> Nothing+          Just get' -> Just (sumStats get' nonIdleStats, sumStats get' idleStats)   active <- foldDyn cpuPercentStep ((0, 0), 0) cpuStat   let pct = fmap snd active   chart pct@@ -123,84 +124,51 @@      , HasImageWriter t m      , HasInput t m      , HasDisplayRegion t m-     , HasFocusReader t m, HasTheme t m+     , HasFocusReader t m+     , HasTheme t m      )   => Dynamic t (Ratio Word64) -> m () chart pct = do-  let title = ffor pct $ \x -> mconcat-        [ " CPU Usage: "-        , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int))-        , "% "-        ]-  boxTitle (pure doubleBoxStyle) (current title) $ col $ do-    grout flex blank-    dh <- displayHeight-    let heights = calcRowHeights <$> dh <*> pct-        quarters = fst <$> heights-        eighths = snd <$> heights-        eighthRow = ffor eighths $ \x -> if x == 0 then 0 else 1-    grout (fixed eighthRow) $ fill' (current $ eighthBlocks <$> eighths) $ current $-      ffor quarters $ \q ->-        if | _quarter_fourth q > 0 -> red-           | _quarter_third q > 0 -> orange-           | _quarter_second q > 0 -> yellow-           | otherwise -> white-    grout (fixed $ _quarter_fourth <$> quarters) $ fill' (pure '█') (pure red)-    grout (fixed $ _quarter_third <$> quarters) $ fill' (pure '█') (pure orange)-    grout (fixed $ _quarter_second <$> quarters) $ fill' (pure '█') (pure yellow)-    grout (fixed $ _quarter_first <$> quarters) $ fill' (pure '█') (pure white)-  where-    -- Calculate number of full rows, height of partial row-    calcRowHeights :: Int -> Ratio Word64 -> (Quarter Int, Int)-    calcRowHeights h r =-      let (full, leftovers) = divMod (numerator r * fromIntegral h) (denominator r)-          partial = ceiling $ 8 * (leftovers % denominator r)-          quarter = ceiling $ fromIntegral h / (4 :: Double)-          n = fromIntegral full-      in if | n <= quarter ->-                (Quarter n 0 0 0, partial)-            | n <= (2 * quarter) ->-                (Quarter quarter (n - quarter) 0 0, partial)-            | n <= (3 * quarter) ->-                (Quarter quarter quarter (n - (2 * quarter)) 0, partial)-            | otherwise ->-                (Quarter quarter quarter quarter (n - (3 * quarter)), partial)-    fill' bc attr = do-      dw <- displayWidth+  let title = ffor pct $ \x ->+        mconcat+          [ " CPU Usage: "+          , T.pack (printf "%3d" $ (ceiling $ x * 100 :: Int))+          , "% "+          ]+  boxTitle (pure TextAlignment_Center) (pure doubleBoxStyle) (current title) $+    grout flex $ do       dh <- displayHeight-      let fillImg =-            (\w h c a -> [V.charFill a c w h])-            <$> current dw-            <*> current dh-            <*> bc-            <*> attr-      tellImages fillImg-    color :: Int -> Int -> Int -> V.Color-    color = V.rgbColor-    red = V.withForeColor V.defAttr $ color 255 0 0-    orange = V.withForeColor V.defAttr $ color 255 165 0-    yellow = V.withForeColor V.defAttr $ color 255 255 0-    white = V.withForeColor V.defAttr $ color 255 255 255--data Quarter a = Quarter-  { _quarter_first :: a-  , _quarter_second :: a-  , _quarter_third :: a-  , _quarter_fourth :: a-  }+      dw <- displayWidth+      let grad = gradient1D [(0.0, RGB 50 205 50), (0.4, RGB 255 220 0), (0.7, RGB 255 140 0), (1.0, RGB 220 40 40)]+          chartImgs h w r =+            let filledF = fromIntegral (numerator r) * fromIntegral h / fromIntegral (denominator r) :: Double+                filled = min h $ floor filledF+                frac = filledF - fromIntegral filled+                partial = if frac > 0 && filled < h then ceiling (8 * frac) :: Int else 0+                rowColor i = V.withForeColor V.defAttr $ fromRGB $ sampleGradient1D grad (fromIntegral i / fromIntegral (max 1 (h - 1)))+                fullImgs =+                  [ V.translate 0 (h - 1 - i) $ V.charFill (rowColor i) '█' w 1+                  | i <- [0 .. filled - 1]+                  ]+                partialImg =+                  if partial > 0 && filled < h+                    then [V.translate 0 (h - 1 - filled) $ V.text' (rowColor filled) (T.replicate w (T.singleton $ eighthBlocks partial))]+                    else []+            in fullImgs ++ partialImg+      tellImages $ chartImgs <$> current dh <*> current dw <*> current pct  eighthBlocks :: (Eq a, Num a, Ord a) => a -> Char eighthBlocks n =   if-     | n <= 0 -> ' '-     | n == 1 -> '▁'-     | n == 2 -> '▂'-     | n == 3 -> '▃'-     | n == 4 -> '▄'-     | n == 5 -> '▅'-     | n == 6 -> '▆'-     | n == 7 -> '▇'-     | otherwise -> '█'+    | n <= 0 -> ' '+    | n == 1 -> '▁'+    | n == 2 -> '▂'+    | n == 3 -> '▃'+    | n == 4 -> '▄'+    | n == 5 -> '▅'+    | n == 6 -> '▆'+    | n == 7 -> '▇'+    | otherwise -> '█'  -- | Determine the current percentage usage according to this algorithm: --
+ src-bin/Example/CellBuffer.hs view
@@ -0,0 +1,48 @@+-- |+--   Description: An animated plasma field rendered cell-by-cell, à la the+--   cellbuffer example.+module Example.CellBuffer (cellBuffer) where++import Control.Monad.IO.Class (liftIO)+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | A classic plasma effect: each cell's character and color are a pure+-- function of its position and the frame, summed over a few sine waves.+cellBuffer :: Demo t m => m (Event t ())+cellBuffer = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.06 t0+  n <- foldDyn (\_ i -> i + 1) (0 :: Int) tick+  dw <- displayWidth+  dh <- displayHeight+  tellImages $ (\w h i -> [plasma w h i]) <$> current dw <*> current dh <*> current n+  quit+  where+    ramp = " .:-=+*#%@"+    grad =+      gradient1D+        [ (0, RGB 25 20 70)+        , (0.4, RGB 190 40 140)+        , (0.7, RGB 255 150 40)+        , (1, RGB 255 240 150)+        ]+    plasma w h i =+      let t = fromIntegral i * 0.12 :: Double+          cell x y =+            let fx = fromIntegral x+                fy = fromIntegral y+                v =+                  sin (fx * 0.18 + t)+                    + sin (fy * 0.27 + t * 1.2)+                    + sin ((fx + fy) * 0.12 + t * 0.8)+                    + sin (sqrt (fx * fx + fy * fy) * 0.2 - t)+                u = (v + 4) / 8 -- normalize roughly to [0,1]+                ci = max 0 $ min (length ramp - 1) $ floor (u * fromIntegral (length ramp))+                clr = fromRGB $ sampleGradient1D grad u+            in V.char (V.withForeColor V.defAttr clr) (ramp !! ci)+      in V.vertCat [V.horizCat [cell x y | x <- [0 .. w - 1]] | y <- [0 .. h - 1]]
+ src-bin/Example/Common.hs view
@@ -0,0 +1,44 @@+-- |+--   Description: Shared scaffolding for the small standalone example demos.+module Example.Common where++import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import qualified Graphics.Vty as V+import Reflex++import Reflex.Vty++-- | The set of capabilities the little single-screen demos rely on. They draw+-- with 'tellImages'\/'text', read the clock via 'tickLossy', and quit on a key.+type Demo t m =+  ( Reflex t+  , MonadFix m+  , MonadHold t m+  , MonadIO m+  , MonadIO (Performable m)+  , PerformEvent t m+  , PostBuild t m+  , TriggerEvent t m+  , HasInput t m+  , HasImageWriter t m+  , HasDisplayRegion t m+  , HasFocusReader t m+  , HasTheme t m+  )++-- | The brand accent color (cyan), matching the rest of the demos.+accent :: V.Color+accent = rgbColor 0 200 230++-- | A dim grey for hints.+dim :: V.Color+dim = rgbColor 120 120 140++-- | An 'Event' that fires when the user asks to quit (q or Ctrl+C). Demos+-- return this from their widget so 'mainWidget' shuts down.+quit :: (Reflex t, Monad m, HasInput t m) => m (Event t ())+quit = do+  q <- key (V.KChar 'q')+  c <- ctrlc+  pure $ leftmost [() <$ q, c]
+ src-bin/Example/DoomFire.hs view
@@ -0,0 +1,63 @@+-- |+--   Description: The classic Doom fire effect, à la the doom-fire example.+module Example.DoomFire (doomFire) where++import Control.Monad.IO.Class (liftIO)+import Data.Bits (shiftR, xor)+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++maxHeat :: Int+maxHeat = 36++-- | A heat grid seeded from a hot bottom row; each frame every cell cools and+-- drifts upward from the cell below it, producing rising flames. The grid is+-- sized to the terminal when the demo starts.+doomFire :: Demo t m => m (Event t ())+doomFire = do+  w <- sample . current =<< displayWidth+  h <- sample . current =<< displayHeight+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.05 t0+  st <- foldDyn (\_ (g, f) -> (step w h f g, f + 1)) (initGrid w h, 0 :: Int) tick+  tellImages $ current $ ffor st $ \(g, _) -> [renderFire g]+  quit+  where+    initGrid w h =+      [[if y == h - 1 then maxHeat else 0 | _ <- [0 .. w - 1]] | y <- [0 .. h - 1]]+    step w h f grid =+      let stepRow y below =+            [ let r = rnd x y f+                  srcX = max 0 $ min (w - 1) $ x + ((r `div` 5) `mod` 3 - 1)+                  decay = r `mod` 5+              in max 0 (below !! srcX - decay)+            | x <- [0 .. w - 1]+            ]+      in [stepRow y (grid !! (y + 1)) | y <- [0 .. h - 2]] ++ [replicate w maxHeat]+    renderFire grid = V.vertCat [V.horizCat (map cell rowHeats) | rowHeats <- grid]+    cell heat+      | heat <= 0 = V.char V.defAttr ' '+      | otherwise = V.char (V.withForeColor V.defAttr (heatColor heat)) (heatChar heat)+    heatChar heat+      | heat < 10 = '░'+      | heat < 19 = '▒'+      | heat < 28 = '▓'+      | otherwise = '█'+    heatColor heat = fromRGB $ sampleGradient1D fireGrad (fromIntegral heat / fromIntegral maxHeat)+    fireGrad =+      gradient1D+        [ (0.0, RGB 12 8 8)+        , (0.18, RGB 90 0 0)+        , (0.4, RGB 210 35 0)+        , (0.6, RGB 255 110 0)+        , (0.8, RGB 255 200 40)+        , (1.0, RGB 255 255 200)+        ]+    rnd x y f =+      let a = x * 374761393 + y * 668265263 + f * 2246822519 + 12345+          b = (a `xor` (a `shiftR` 13)) * 1274126177+      in abs (b `xor` (b `shiftR` 16))
+ src-bin/Example/Pager.hs view
@@ -0,0 +1,28 @@+-- |+--   Description: A scrollable pager, à la bubbles\/viewport (pager example).+module Example.Pager (pager) where++import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | A 'scrollableText' viewport over a block of numbered lines. Scroll it with+-- the arrow keys or the mouse wheel.+pager :: Demo t m => m (Event t ())+pager = do+  tellImages $+    pure [V.text' (V.withForeColor V.defAttr accent) "  ↑/↓ or mouse wheel to scroll · q to quit"]+  dw <- displayWidth+  dh <- displayHeight+  let viewport w h = Region 0 2 w (max 1 (h - 2))+  _ <- pane (viewport <$> dw <*> dh) (pure True) $ scrollableText def (pure body)+  quit+  where+    body =+      T.unlines+        [ "Line " <> T.pack (show n) <> " — scrollable viewport content"+        | n <- [1 .. 60 :: Int]+        ]
+ src-bin/Example/Progress.hs view
@@ -0,0 +1,36 @@+-- |+--   Description: An animated, gradient-filled progress bar, à la bubbles\/progress.+module Example.Progress (progressBar) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex+import Text.Printf (printf)++import Example.Common+import Reflex.Vty++-- | A progress bar that fills 0→100% (then loops), tinted with a red→yellow→+-- green 'Gradient1D' so each cell carries its own color.+progressBar :: Demo t m => m (Event t ())+progressBar = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.04 t0+  pct <- foldDyn (\_ p -> if p >= 1 then 0 else min 1 (p + 0.008)) (0 :: Double) tick+  dw <- displayWidth+  tellImages $ (\w p -> [barImage w p]) <$> current dw <*> current pct+  quit+  where+    grad = gradient1D [(0, RGB 255 70 90), (0.5, RGB 250 200 60), (1, RGB 80 220 120)]+    barImage w p =+      let barW = max 1 (w - 7)+          filled = round (p * fromIntegral barW) :: Int+          cellColor i = fromRGB $ sampleGradient1D grad (fromIntegral i / fromIntegral (max 1 (barW - 1)))+          cell i+            | i < filled = V.char (V.withForeColor V.defAttr (cellColor i)) '█'+            | otherwise = V.char (V.withForeColor V.defAttr (rgbColor 64 64 78)) '░'+          bar = V.horizCat $ map cell [0 .. barW - 1]+          label = V.text' (V.withForeColor V.defAttr accent) $ T.pack $ printf " %3d%%" (round (p * 100) :: Int)+      in V.horizCat [bar, label]
+ src-bin/Example/Space.hs view
@@ -0,0 +1,50 @@+-- |+--   Description: A drifting starfield, à la the space example.+module Example.Space (space) where++import Control.Monad.IO.Class (liftIO)+import Data.Bits (shiftR, xor)+import qualified Data.Map as Map+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | A starfield warping leftward. Each star has a pseudo-random row and speed+-- (its "depth"); faster stars are brighter and drawn with a bolder glyph.+space :: Demo t m => m (Event t ())+space = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.06 t0+  n <- foldDyn (\_ i -> i + 1) (0 :: Int) tick+  dw <- displayWidth+  dh <- displayHeight+  tellImages $ (\w h i -> [starfield w h i]) <$> current dw <*> current dh <*> current n+  quit+  where+    starfield w h i+      | w <= 0 || h <= 0 = V.emptyImage+      | otherwise =+          let nStars = max 1 (w * h `div` 14)+              stars = Map.fromList [star w h i k | k <- [0 .. nStars - 1]]+              mkRow y = V.horizCat [Map.findWithDefault gap (x, y) stars | x <- [0 .. w - 1]]+          in V.vertCat [mkRow y | y <- [0 .. h - 1]]+    gap = V.char V.defAttr ' '+    star w h i k =+      let y = hash (k * 2 + 1) `mod` h+          speed = 1 + hash (k * 3 + 2) `mod` 3+          x = (hash k - i * speed) `mod` w+          (ch, clr) = case speed of+            1 -> ('·', rgbColor 90 90 120)+            2 -> ('*', rgbColor 170 170 205)+            _ -> ('✦', rgbColor 255 255 255)+      in ((x, y), V.char (V.withForeColor V.defAttr clr) ch)+    -- A cheap integer hash, always non-negative.+    hash :: Int -> Int+    hash k0 =+      let a = k0 * 374761393 + 668265263+          b = (a `xor` (a `shiftR` 13)) * 1274126177+          c = b `xor` (b `shiftR` 16)+      in abs c
+ src-bin/Example/Spinner.hs view
@@ -0,0 +1,29 @@+-- |+--   Description: An animated spinner, à la bubbles\/spinner.+module Example.Spinner (spinner) where++import Control.Monad.IO.Class (liftIO)+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | A braille spinner that cycles a frame every 80ms.+spinner :: Demo t m => m (Event t ())+spinner = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.08 t0+  idx <- foldDyn (\_ i -> (i + 1) `mod` n) 0 tick+  tellImages $ current $ ffor idx frame+  quit+  where+    frames = "⣾⣽⣻⢿⡿⣟⣯⣷"+    n = length frames+    frame i =+      [ V.horizCat+          [ V.char (V.withForeColor V.defAttr accent) (frames !! i)+          , V.text' (V.withForeColor V.defAttr dim) "  Spinning forever…  (q to quit)"+          ]+      ]
+ src-bin/Example/Splash.hs view
@@ -0,0 +1,51 @@+-- |+--   Description: An animated splash screen, à la the splash example.+module Example.Splash (splash) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | A centered title that types out in a pink→violet→cyan gradient, with a+-- subtitle that fades in beneath it; the whole thing loops.+splash :: Demo t m => m (Event t ())+splash = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.06 t0+  n <- foldDyn (\_ i -> i + 1) (0 :: Int) tick+  dw <- displayWidth+  dh <- displayHeight+  tellImages $ (\w h i -> [frame w h i]) <$> current dw <*> current dh <*> current n+  quit+  where+    title = "reflex-vty"+    subtitle = "reactive terminal UIs"+    grad = gradient1D [(0, RGB 255 64 160), (0.5, RGB 150 90 255), (1, RGB 0 200 230)]+    frame w h i =+      let p = i `mod` 95+          revealed = min (length title) (max 0 (p `div` 2))+          subAlpha = max 0 (min 1 (fromIntegral (p - 26) / 18 :: Double))+          pad k = V.text' V.defAttr (T.replicate (max 0 k) " ")+          center len = (w - len) `div` 2+          titleImg =+            V.horizCat+              [ V.char (V.withStyle (V.withForeColor V.defAttr (charColor k)) V.bold) c+              | (k, c) <- zip [0 :: Int ..] (take revealed title)+              ]+          charColor k = fromRGB $ sampleGradient1D grad (fromIntegral k / fromIntegral (max 1 (length title - 1)))+          subImg+            | subAlpha <= 0 = V.emptyImage+            | otherwise = V.text' (V.withForeColor V.defAttr (fromRGB (mix subAlpha (RGB 35 35 45) (RGB 150 150 170)))) (T.pack subtitle)+          gap = V.char V.defAttr ' '+          top = max 0 (h `div` 2 - 1)+      in V.vertCat $+           replicate top gap+             ++ [ V.horizCat [pad (center (length title)), titleImg]+                , gap+                , V.horizCat [pad (center (length subtitle)), subImg]+                ]
+ src-bin/Example/Stopwatch.hs view
@@ -0,0 +1,30 @@+-- |+--   Description: A count-up stopwatch, à la bubbles\/stopwatch.+module Example.Stopwatch (stopwatch) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex+import Text.Printf (printf)++import Example.Common+import Reflex.Vty++-- | Counts up from zero, ticking every 100ms.+stopwatch :: Demo t m => m (Event t ())+stopwatch = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.1 t0+  elapsed <- foldDyn (\_ d -> d + 0.1) (0 :: Double) tick+  tellImages $ current $ ffor elapsed line+  quit+  where+    line d =+      [ V.horizCat+          [ V.text' (V.withForeColor V.defAttr accent) "  ⏱  "+          , V.text' V.defAttr $ T.pack $ printf "%.1fs" d+          , V.text' (V.withForeColor V.defAttr dim) "   (q to quit)"+          ]+      ]
+ src-bin/Example/TextInput.hs view
@@ -0,0 +1,27 @@+-- |+--   Description: A single text input field, à la bubbles\/textinput.+module Example.TextInput (textInputExample) where++import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | A prompt and a 'textInput' below it. The input lives in an always-focused+-- 'pane', so it accepts typing immediately. Quit with Ctrl+C (q is a character).+textInputExample :: Demo t m => m (Event t ())+textInputExample = do+  dw <- displayWidth+  tellImages $+    pure+      [ V.vertCat+          [ V.text' (V.withForeColor V.defAttr accent) "  What's your name?"+          , V.text' V.defAttr ""+          ]+      ]+  let inputRegion w = Region 2 2 (max 1 (w - 4)) 1+  _ <- pane (inputRegion <$> dw) (pure True) $ textInput def+  tellImages $+    pure [V.translate 2 4 $ V.text' (V.withForeColor V.defAttr dim) "(type away — Ctrl+C to quit)"]+  ctrlc
+ src-bin/Example/Timer.hs view
@@ -0,0 +1,31 @@+-- |+--   Description: A countdown timer, à la bubbles\/timer.+module Example.Timer (timer) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Data.Time (getCurrentTime)+import qualified Graphics.Vty as V+import Reflex+import Text.Printf (printf)++import Example.Common+import Reflex.Vty++-- | Counts down from ten seconds, ticking every 100ms.+timer :: Demo t m => m (Event t ())+timer = do+  t0 <- liftIO getCurrentTime+  tick <- tickLossy 0.1 t0+  remaining <- foldDyn (\_ r -> max 0 (r - 0.1)) (10 :: Double) tick+  tellImages $ current $ ffor remaining line+  quit+  where+    line r =+      [ V.horizCat+          [ V.text' (V.withForeColor V.defAttr accent) "  ⏳  "+          , V.text' V.defAttr $ T.pack $ printf "%.1fs" r+          , V.text' (V.withForeColor V.defAttr dim) $+              if r <= 0 then "   time's up!  (q to quit)" else "   remaining  (q to quit)"+          ]+      ]
+ src-bin/Example/Views.hs view
@@ -0,0 +1,36 @@+-- |+--   Description: Switching between views, à la the composable-views example.+module Example.Views (views) where++import qualified Graphics.Vty as V+import Reflex++import Example.Common+import Reflex.Vty++-- | Two views toggled with Tab. Each is just a different rendering chosen from+-- a 'Dynamic' index — the FRP way to swap "views".+views :: Demo t m => m (Event t ())+views = do+  tab <- key (V.KChar '\t')+  n <- foldDyn (\_ i -> (i + 1) `mod` 2) (0 :: Int) tab+  tellImages $ current $ ffor n viewImage+  quit+  where+    hint = V.text' (V.withForeColor V.defAttr dim) "  Tab to switch views · q to quit"+    viewImage 0 =+      [ V.vertCat+          [ V.text' (V.withStyle (V.withForeColor V.defAttr accent) V.bold) "  ◖ View one ◗"+          , V.text' V.defAttr "  reactive, composable terminal UIs"+          , V.char V.defAttr ' '+          , hint+          ]+      ]+    viewImage _ =+      [ V.vertCat+          [ V.text' (V.withStyle (V.withForeColor V.defAttr (rgbColor 200 120 255)) V.bold) "  ◆ View two ◆"+          , V.text' V.defAttr "  swapped with a single keystroke"+          , V.char V.defAttr ' '+          , hint+          ]+      ]
src-bin/example.hs view
@@ -10,14 +10,15 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Zipper as TZ import Data.Time (getCurrentTime) import qualified Graphics.Vty as V import Reflex import Reflex.Network-import Reflex.Vty +import Data.Text.Zipper (TextAlignment (..))+import qualified Data.Text.Zipper as TZ import Example.CPU+import Reflex.Vty  type VtyExample t m =   ( MonadFix m@@ -29,6 +30,9 @@   , HasFocus t m   , HasFocusReader t m   , HasTheme t m+  , HasColorProfile t m+  , HasCursor t m+  , HasScreenMode t m   )  type Manager t m =@@ -36,12 +40,16 @@   , HasFocus t m   ) -data Example = Example_TextEditor-             | Example_Todo-             | Example_ScrollableTextDisplay-             | Example_ClickButtonsGetEmojis-             | Example_CPUStat-  deriving (Show, Read, Eq, Ord, Enum, Bounded)+data Example+  = Example_TextEditor+  | Example_Todo+  | Example_ScrollableTextDisplay+  | Example_ClickButtonsGetEmojis+  | Example_CPUStat+  | Example_Scrollbar+  | Example_Cursor+  | Example_Showcase+  deriving (Bounded, Enum, Eq, Ord, Read, Show)  withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ()) withCtrlC f = do@@ -51,37 +59,112 @@     V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()     _ -> Nothing -darkTheme :: V.Attr-darkTheme = V.Attr {-  V.attrStyle = V.SetTo V.standout-  , V.attrForeColor = V.SetTo V.black-  , V.attrBackColor = V.Default-  , V.attrURL = V.Default-}+-- * Shared styling helpers +-- | The brand accent color (cyan), matching the bright end of 'brandGradient'.+accent :: Color+accent = rgbColor 0 200 230++-- | A pink → violet → cyan true-color gradient used for the brand banner.+brandGradient :: Gradient1D+brandGradient =+  gradient1D+    [ (0.0, RGB 255 64 160)+    , (0.5, RGB 150 90 255)+    , (1.0, RGB 0 200 230)+    ]++-- | Emit a single line of bold text whose characters are colored along a+-- horizontal 1D gradient. Shows off true-color 'Gradient1D' sampling.+gradientText+  :: (Reflex t, HasImageWriter t m)+  => Gradient1D -> Text -> m ()+gradientText grad txt = tellImages $ pure [img]+  where+    cs = T.unpack txt+    n = length cs+    img =+      V.horizCat+        [ V.char (V.withStyle (V.withForeColor V.defAttr (fromRGB (sampleGradient1D grad p))) V.bold) c+        | (i, c) <- zip [0 :: Int ..] cs+        , let p = fromIntegral i / fromIntegral (max 1 (n - 1))+        ]++-- | A line of text tinted with an accent foreground color (used for the+-- short instructional headers above each example).+accentText+  :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)+  => Color -> Text -> m ()+accentText c t =+  localTheme (const (pure (defTheme {_theme_default = withForeground c def}))) $+    text (pure t)++-- | A titled box whose border and title are tinted with an accent color,+-- while its content stays in the default theme so body text remains+-- readable.+accentBox+  :: ( MonadFix m+     , MonadHold t m+     , HasDisplayRegion t m+     , HasImageWriter t m+     , HasInput t m+     , HasFocusReader t m+     , HasTheme t m+     )+  => Color -> BoxStyle -> Text -> m a -> m a+accentBox c style title child =+  localTheme (const (pure (defTheme {_theme_default = withForeground c def}))) $+    boxTitle (pure TextAlignment_Center) (pure style) (pure title) $+      localTheme (const (pure defTheme)) child++-- | A theme transformer that reverse-videos the default style while the+-- given dynamic is True. Used to highlight a focused widget (e.g. the+-- checkbox in a to-do row).+highlightFocus+  :: Reflex t+  => Dynamic t Bool -> Behavior t Theme -> Behavior t Theme+highlightFocus d thB =+  (\th foc -> if foc then th {_theme_default = withReverse (_theme_default th)} else th)+    <$> thB+    <*> current d+ main :: IO ()-main = mainWidget $ withCtrlC $ do+main = mainWidget def $ withCtrlC $ do+  enterAlternateScreen   initManager_ $ do     tabNavigation     let gf = grout . fixed-        t = tile flex-        buttons = col $ do-          gf 3 $ col $ do-            gf 1 $ text "Select an example."-            gf 1 $ text "Esc will bring you back here."-            gf 1 $ text "Ctrl+c to quit."-          a <- t $ textButtonStatic def "Todo List"-          b <- t $ textButtonStatic def "Text Editor"-          c <- t $ textButtonStatic def "Scrollable text display"-          d <- t $ textButtonStatic def "Clickable buttons"-          e <- t $ textButtonStatic def "CPU Usage"-          return $ leftmost-            [ Left Example_Todo <$ a-            , Left Example_TextEditor <$ b-            , Left Example_ScrollableTextDisplay <$ c-            , Left Example_ClickButtonsGetEmojis <$ d-            , Left Example_CPUStat <$ e-            ]+        t = tile (fixed 3)+        buttons = do+          (_, ev) <-+            scrollable def $+              col $ do+                gf 3 $ col $ do+                  gf 1 $ gradientText brandGradient "reflex-vty · functional reactive terminal UIs"+                  gf 1 $ text "Select an example."+                  gf 1 $ text "Esc brings you back here · Ctrl+C quits."+                a <- t $ textButtonStatic def "Todo List"+                b <- t $ textButtonStatic def "Text Editor"+                c <- t $ textButtonStatic def "Scrollable text display"+                d <- t $ textButtonStatic def "Clickable buttons"+                e <- t $ textButtonStatic def "CPU Usage"+                f <- t $ textButtonStatic def "Scrollbar modes"+                g <- t $ textButtonStatic def "Cursor"+                h <- t $ textButtonStatic def "Showcase"+                pure+                  ( never+                  , leftmost+                      [ Left Example_Todo <$ a+                      , Left Example_TextEditor <$ b+                      , Left Example_ScrollableTextDisplay <$ c+                      , Left Example_ClickButtonsGetEmojis <$ d+                      , Left Example_CPUStat <$ e+                      , Left Example_Scrollbar <$ f+                      , Left Example_Cursor <$ g+                      , Left Example_Showcase <$ h+                      ]+                  )+          pure ev     let escapable w = do           void w           i <- input@@ -94,31 +177,103 @@           Left Example_ScrollableTextDisplay -> escapable scrolling           Left Example_ClickButtonsGetEmojis -> escapable easyExample           Left Example_CPUStat -> escapable cpuStats+          Left Example_Scrollbar -> escapable scrollbarDemo+          Left Example_Cursor -> escapable cursorDemo+          Left Example_Showcase -> escapable showcaseDemo           Right () -> buttons     return () +scrollbarDemo :: (VtyExample t m, Manager t m, MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => m ()+scrollbarDemo = col $ do+  grout (fixed 1) $ accentText accent "Four scrollbar modes. Use arrow keys or mouse wheel to scroll each panel:"+  grout flex $ row $ do+    grout flex $ void $ sbPanel "Always" ScrollbarAlways+    grout flex $ void $ sbPanel "Thumb Only" ScrollbarThumbOnly+    grout flex $ void $ sbPanel "While Scrolling" ScrollbarWhileScrolling+    grout flex $ void $ sbPanel "Hidden" ScrollbarHidden+  where+    sampleText = T.unlines $ map (\n -> "Line " <> T.pack (show n)) [(1 :: Int) .. 50]+    sbPanel label vis =+      boxTitle (pure TextAlignment_Center) (pure singleBoxStyle) (pure label) $+        scrollableText (def {_scrollableConfig_scrollbarVisibility = vis}) (constDyn sampleText)++-- * Terminal cursor demo++cursorDemo :: (VtyExample t m, Manager t m, MonadHold t m, PostBuild t m) => m ()+cursorDemo = col $ do+  grout (fixed 1) $ accentText accent "Arrows: move | s: style | v: visibility | f: alt-screen | Esc: back"+  let styles = [CursorStyleBlock, CursorStyleUnderline, CursorStyleBar]+  upE <- key V.KUp+  downE <- key V.KDown+  leftE <- key V.KLeft+  rightE <- key V.KRight+  sE <- key (V.KChar 's')+  vE <- key (V.KChar 'v')+  fE <- key (V.KChar 'f')+  posDyn <- foldDyn move (0, 0) $ leftmost [upE, downE, leftE, rightE]+  idxDyn <- foldDyn (\_ n -> (n + 1) `mod` length styles) 0 sE+  visDyn <- foldDyn (\_ b -> not b) True vE+  altDyn <- foldDyn (\_ b -> not b) True fE+  tellScreenMode $ (\b -> if b then ScreenAlternate else ScreenNormal) <$> updated altDyn+  let styleDyn = (styles !!) <$> idxDyn+      cursorDyn =+        (\(x, y) s v -> CursorState (if v then CursorVisible else CursorHidden) s (x, y))+          <$> posDyn+          <*> styleDyn+          <*> visDyn+  setCursor cursorDyn+  grout flex $+    text $+      current $+        ( \(x, y) s v a ->+            "Position: "+              <> T.pack (show x)+              <> ","+              <> T.pack (show y)+              <> " | Style: "+              <> T.pack (show s)+              <> " | Visible: "+              <> (if v then "on" else "off")+              <> " | Alt-screen: "+              <> (if a then "on" else "off")+        )+          <$> posDyn+          <*> styleDyn+          <*> visDyn+          <*> altDyn+  where+    move (k, _) (x, y) = case k of+      V.KUp -> (x, max 0 (y - 1))+      V.KDown -> (x, y + 1)+      V.KLeft -> (max 0 (x - 1), y)+      V.KRight -> (x + 1, y)+      _ -> (x, y)+ -- * Mouse button and emojis example easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ()) easyExample = do   row $ grout (fixed 39) $ col $ do-    (a1,b1,c1) <- grout (fixed 3) $ row $ do+    (a1, b1, c1) <- grout (fixed 3) $ row $ do       a <- tile flex $ btn "POTATO"       b <- tile flex $ btn "TOMATO"       c <- tile flex $ btn "EGGPLANT"-      return (a,b,c)-    (a2,b2,c2) <- grout (fixed 3) $ row $ do+      return (a, b, c)+    (a2, b2, c2) <- grout (fixed 3) $ row $ do       a <- tile flex $ btn "CHEESE"       b <- tile flex $ btn "BEES"       c <- tile flex $ btn "MY KNEES"-      return (a,b,c)-    (a3,b3,c3) <- grout (fixed 3) $ row $ do+      return (a, b, c)+    (a3, b3, c3) <- grout (fixed 3) $ row $ do       a <- tile flex $ btn "TIME"       b <- tile flex $ btn "RHYME"       c <- tile flex $ btn "A BIG CRIME"-      return (a,b,c)-    tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do-      outputDyn <- foldDyn (<>) "" $ mergeWith (<>)-        [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]+      return (a, b, c)+    tile (fixed 7) $ accentBox accent roundedBoxStyle "CLICK BUTTONS TO DRAW*" $ do+      outputDyn <-+        foldDyn (<>) "" $+          mergeWith+            (<>)+            [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]       text (current outputDyn)     tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map."   inp <- input@@ -127,12 +282,14 @@     _ -> Nothing   where     btn label = do-      let cfg = def { _buttonConfig_focusStyle = pure doubleBoxStyle }+      let cfg = def {_buttonConfig_focusStyle = pure doubleBoxStyle}       buttonClick <- textButtonStatic cfg label-      keyPress <- keyCombos $ Set.fromList-        [ (V.KEnter, [])-        , (V.KChar ' ', [])-        ]+      keyPress <-+        keyCombos $+          Set.fromList+            [ (V.KEnter, [])+            , (V.KChar ' ', [])+            ]       pure $ leftmost [() <$ buttonClick, () <$ keyPress]  -- * Task list example@@ -140,6 +297,7 @@   :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)   => m () taskList = col $ do+  grout (fixed 1) $ accentText accent "To-Do · Tab to move · Ctrl+T toggles · Enter adds a task"   let todos0 =         [ Todo "Find reflex-vty" True         , Todo "Become functional reactive" False@@ -155,13 +313,16 @@   { _todo_label :: Text   , _todo_done :: Bool   }-  deriving (Show, Read, Eq, Ord)+  deriving (Eq, Ord, Read, Show)  data TodoOutput t = TodoOutput   { _todoOutput_todo :: Dynamic t Todo   , _todoOutput_delete :: Event t ()   , _todoOutput_height :: Dynamic t Int   , _todoOutput_focusId :: FocusId+  , _todoOutput_focused :: Dynamic t Bool+  -- ^ Whether any element of this row (checkbox or text field) is focused.+  --   Used to insert a newly added task directly beneath the active row.   }  todo@@ -169,38 +330,55 @@   => Todo   -> m (TodoOutput t) todo t0 = row $ do-  let toggleKeys = Set.fromList-        [ (V.KChar ' ', [V.MCtrl])-        , (V.KChar '@', [V.MCtrl])-        ]+  let toggleKeys = Set.singleton (V.KChar 't', [V.MCtrl])   anyChildFocused $ \focused -> do     toggleE <- keyCombos toggleKeys     filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do-      rec let cfg = def-                { _checkboxConfig_setValue = setVal-                }-          value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0+      rec -- Which sub-element of this row has focus: the row is focused+          -- when either the checkbox or the text input is, so the+          -- checkbox is focused if the row is focused and the text isn't.+          textFocused <- isFocused fid+          let cbFocused = (\f tf -> f && not tf) <$> focused <*> textFocused+          -- A caret in a left gutter marks which to-do row is active.+          grout (fixed 2) $+            tellImages $+              ffor (current focused) $ \f ->+                [V.text' (V.withStyle (V.withForeColor V.defAttr accent) V.bold) (if f then "▸ " else "  ")]+          let cfg =+                def+                  { _checkboxConfig_setValue = setVal+                  }+          value <-+            tile (fixed 4) $+              localTheme (highlightFocus cbFocused) $+                checkbox cfg $+                  _todo_done t0           let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE           (fid, (ti, d)) <- tile' flex $ do             i <- input-            v <- textInput $ def-              { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }+            v <-+              textInput $+                def+                  { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0+                  }             let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i             return (v, deleteSelf)-      return $ TodoOutput-        { _todoOutput_todo = Todo <$> _textInput_value ti <*> value-        , _todoOutput_delete = d-        , _todoOutput_height = _textInput_lines ti-        , _todoOutput_focusId = fid-        }+      return $+        TodoOutput+          { _todoOutput_todo = Todo <$> _textInput_value ti <*> value+          , _todoOutput_delete = d+          , _todoOutput_height = _textInput_lines ti+          , _todoOutput_focusId = fid+          , _todoOutput_focused = focused+          }   where     backspaceOnEmpty v = \case       V.EvKey V.KBS _ | T.null v -> Just ()       _ -> Nothing  todos-  :: forall t m.-     ( MonadHold t m+  :: forall t m+   . ( MonadHold t m      , Manager t m      , VtyExample t m      , Adjustable t m@@ -208,9 +386,9 @@      )   => [Todo]   -> Event t ()-  -> m (Dynamic t (Map Int (TodoOutput t)))+  -> m (Dynamic t (Map Rational (TodoOutput t))) todos todos0 newTodo = do-  let todosMap0 = Map.fromList $ zip [0..] todos0+  let todosMap0 = Map.fromList $ zip [0 ..] todos0   rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do         to <- todo t         let sel = select selectOnDelete $ Const2 k@@ -219,18 +397,37 @@         pure to       let delete = flip Map.singleton Nothing <$> todoDelete           todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut-          insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of-             Nothing -> Map.singleton 0 $ Just $ Todo "" False-             Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False+          -- The key of the row that currently holds focus, if any.+          focusedKey =+            fmap (fmap fst . Map.lookupMin . Map.filter id) $+              joinDynThroughMap $+                fmap _todoOutput_focused <$> listOut+          -- Insert the new task directly beneath the focused row by choosing a+          -- key halfway between it and the next row (so existing rows keep+          -- their keys and edit state). With no focus, or when the focused row+          -- is last, append at the end.+          insert = ffor (attach (current todosMap) (tag (current focusedKey) newTodo)) $ \(m, mfk) ->+            let newKey = case mfk of+                  Just fk -> case Map.lookupGT fk m of+                    Just (knext, _) -> (fk + knext) / 2+                    Nothing -> fk + 1+                  Nothing -> maybe 0 ((+ 1) . fst) (Map.lookupMax m)+            in Map.singleton newKey $ Just $ Todo "" False           updates = leftmost [insert, delete]-          todoDelete = switch . current $-            leftmost .  Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut+          todoDelete =+            switch . current $+              leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut -          selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe-            (\m k -> let (before, after) = Map.split k m-                      in  fmap fst $ Map.lookupMax before <|> Map.lookupMin after)-            (current todosMap)-            todoDelete+          selectOnDelete =+            fanMap $+              (`Map.singleton` ())+                <$> attachWithMaybe+                  ( \m k ->+                      let (before, after) = Map.split k m+                      in fmap fst $ Map.lookupMax before <|> Map.lookupMin after+                  )+                  (current todosMap)+                  todoDelete   return listOut  -- * Scrollable text example@@ -247,13 +444,14 @@   => m () scrolling = col $ do   grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"-  (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText def $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."+  (fid, out) <- tile' (fixed 5) $ accentBox accent roundedBoxStyle " De Bello Gallico " $ scrollableText def $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."   pb <- getPostBuild   requestFocus $ Refocus_Id fid <$ pb-  grout (fixed 1) $ text $ ffor (_scrollable_scrollPosition out) $ \p -> "Scrolled to " <> case p of-    ScrollPos_Top -> "top"-    ScrollPos_Bottom -> "bottom"-    ScrollPos_Line n -> "line " <> T.pack (show n)+  grout (fixed 1) $ text $ ffor (_scrollable_scrollPosition out) $ \p ->+    "Scrolled to " <> case p of+      ScrollPos_Top -> "top"+      ScrollPos_Bottom -> "bottom"+      ScrollPos_Line n -> "line " <> T.pack (show n)   e <- performEventAsync $ ffor pb $ \_ cb -> liftIO $ void $ forkIO $ forever $ do     threadDelay 1000000     t <- getCurrentTime@@ -262,10 +460,11 @@   grout (fixed 3) blank   tile (fixed 10) $ col $ do     grout (fixed 1) $ text "This one scrolls automatically as the output grows:"-    Scrollable pos total h <- tile flex $-      scrollableText (ScrollableConfig never never ScrollPos_Bottom (pure $ Just ScrollToBottom_Maintain)) $-        T.unlines <$> xs-    grout (fixed 5) $ boxStatic def $ do+    Scrollable pos total h <-+      tile flex $+        scrollableText (ScrollableConfig never never ScrollPos_Bottom (pure $ Just ScrollToBottom_Maintain) ScrollbarAlways) $+          T.unlines <$> xs+    grout (fixed 5) $ accentBox accent singleBoxStyle " Scroll state " $ do       grout (fixed 1) $ row $ do         grout (fixed 8) (text "Height:")         grout flex $ display h@@ -287,25 +486,23 @@   let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)       region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)   pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput-  _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $-    let cfg = def-          { _textInputConfig_initialValue =-            "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."-          }-        textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $-          multilineTextInput cfg-        dragBox = boxStatic roundedBoxStyle dragTest-    in splitVDrag (hRule doubleBoxStyle) textBox dragBox+  _ <-+    pane region2 (constDyn True) . boxStatic singleBoxStyle $+      let cfg =+            def+              { _textInputConfig_initialValue =+                  "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."+              }+          textBox =+            boxTitle (pure TextAlignment_Center) (pure roundedBoxStyle) "Text Edit" $+              multilineTextInput cfg+          dragBox = boxStatic roundedBoxStyle dragTest+      in splitVDrag (hRule doubleBoxStyle) textBox dragBox   return ()   where     div' :: (Integral a, Applicative f) => f a -> f a -> f a     div' = liftA2 div -debugFocus :: (VtyExample t m) => m ()-debugFocus = do-  f <- focus-  text $ T.pack . show <$> current f- debugInput :: (VtyExample t m, MonadHold t m) => m () debugInput = do   lastEvent <- hold "No event yet" . fmap show =<< input@@ -316,6 +513,147 @@   lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft   text $ T.pack <$> lastEvent -testStringBox :: VtyExample t m => m ()-testStringBox = boxStatic singleBoxStyle .-  text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])+-- * Showcase: one screen showing off all styling, theming, and color++-- profiling. Tab cycles the predefined themes; the whole screen is+-- rendered under the current theme.+showcaseDemo :: (VtyExample t m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), HasLayout t m, HasColorProfile t m) => m ()+showcaseDemo = do+  tab <- key (V.KChar '\t')+  nDyn <- foldDyn (\_ n -> n + 1) 0 tab+  prof <- colorProfile+  let themes =+        cycle+          [ ("default", defTheme)+          , ("dark", darkTheme)+          , ("charm", charmTheme)+          , ("dracula", draculaTheme)+          , ("nord", nordTheme)+          , ("zenburn", zenburnTheme)+          , ("gruvbox", gruvboxTheme)+          ]+      pick n = drop (n `mod` 7) themes+      curTheme n = case pick n of+        (_, th) : _ -> th+        [] -> defTheme+      curLabel n = case pick n of+        (label, _) : _ -> label+        [] -> ""+      themeBeh = curTheme <$> current nDyn+  focusGainedE <- gainedFocus+  focusLostE <- lostFocus+  focusedDyn <- holdDyn True $ leftmost [True <$ focusGainedE, False <$ focusLostE]+  mousePosDyn <- mousePosition+  let headerBeh =+        (\n p f (mx, my) -> T.pack (curLabel n <> " | " <> show p <> " | Focus: " <> (if f then "●" else "○") <> " | Mouse: " <> show mx <> "," <> show my <> " | Tab/Esc"))+          <$> current nDyn+          <*> prof+          <*> current focusedDyn+          <*> current mousePosDyn+  localTheme (const themeBeh) $ do+    fill (pure ' ')+    col $ do+      grout (fixed 1) $ text headerBeh+      grout flex $ void $ scrollable def $ do+        row $ do+          -- Left column: style samples+          grout flex $ col $ do+            grout (fixed 1) $ text "Borders:"+            grout (fixed 3) $ row $ do+              grout flex $ styledImage "single" (withBorder singleBorder def)+              grout flex $ styledImage "rounded" (withBorder roundedBorder def)+              grout flex $ styledImage "thick" (withBorder thickBorder def)+              grout flex $ styledImage "double" (withBorder doubleBorder def)+              grout flex $ styledImage "ascii" (withBorder asciiBorder def)+            grout (fixed 1) $ text "Padding/Margin:"+            grout (fixed 3) $ row $ do+              grout flex $ styledImage "pad 1" (withPadding 1 1 1 1 def)+              grout flex $ styledImage "pad 2" (withPadding 2 2 2 2 def)+              grout flex $ styledImage "margin 1" (withMargin 1 1 1 1 def)+            grout (fixed 1) $ text "Colors:"+            grout (fixed 3) $ row $ do+              grout flex $ styledImage "red fg" (withForeground red def)+              grout flex $ styledImage "blue bg" (withBackground blue def)+              grout flex $ styledImage "rgb" (withForeground (rgbColor 200 100 50) def)+            grout (fixed 1) $ text "Color ops:"+            grout (fixed 3) $ row $ do+              grout flex $ styledImage "darken" (withForeground (fromRGB (darken 0.4 (RGB 255 128 0))) def)+              grout flex $ styledImage "lighten" (withForeground (fromRGB (lighten 0.5 (RGB 100 0 200))) def)+              grout flex $ styledImage "mix" (withForeground (fromRGB (mix 0.5 (RGB 255 0 0) (RGB 0 0 255))) def)+              grout flex $ styledImage "complement" (withForeground (fromRGB (complementary (RGB 255 128 0))) def)+            grout (fixed 1) $ text "Gradient (1D):"+            grout (fixed 3) $ gradientSwatch+            grout (fixed 1) $ text "Canvas overlay:"+            grout (fixed 3) $ canvasOverlayDemo+            grout (fixed 1) $ text "Transforms:"+            grout (fixed 3) $ row $ do+              grout flex $ styledImage "bold" (withBold def)+              grout flex $ styledImage "italic" (withItalic def)+              grout flex $ styledImage "underline" (withUnderline UnderlineSingle def)+              grout flex $ styledImage "reverse" (withReverse def)+            grout (fixed 1) $ text "Alignment:"+            grout (fixed 3) $ row $ do+              grout flex $ styledImage "left" (withAlignH HAlignLeft . withWidth 20 $ def)+              grout flex $ styledImage "center" (withAlignH HAlignCenter . withWidth 20 $ def)+              grout flex $ styledImage "right" (withAlignH HAlignRight . withWidth 20 $ def)+            grout (fixed 1) $ text "Combined & Hyperlink:"+            grout (fixed 5) $ row $ do+              grout flex $+                styledImage+                  "combined"+                  ( withBorder roundedBorder+                      . withPadding 1 2 1 2+                      . withForeground brightGreen+                      . withBorderForeground brightMagenta+                      $ def+                  )+              grout flex $+                styledImage+                  "link"+                  (withHyperlink "https://reflex-frp.org" . withUnderline UnderlineSingle $ def)+          -- Right column: themed widgets + color profile swatches+          grout flex $ col $ do+            grout (fixed 1) $ text "Themed Widgets:"+            void $ grout (fixed 3) $ textButtonStatic def "A button"+            void $ grout (fixed 3) $ checkbox def False+            void $ grout (fixed 3) $ linkStatic "A link"+            void $ grout (fixed 3) $ textInput def+            grout (fixed 1) $ text "Color Profile Swatches:"+            grout (fixed 2) $ row $ do+              grout flex $ profileSwatch "TrueColor" ColorProfile_TrueColor+              grout flex $ profileSwatch "Ansi256" ColorProfile_Ansi256+              grout flex $ profileSwatch "Ansi16" ColorProfile_Ansi16+              grout flex $ profileSwatch "Ascii" ColorProfile_Ascii+              grout flex $ profileSwatch "NoTTY" ColorProfile_NoTTY+        pure (never, ())+  where+    orange = rgbColor 200 100 50+    styledImage label s = do+      th <- theme+      tellImages $ (\t -> [render (inherit (_theme_default t) s) label]) <$> th+    profileSwatch label prof = do+      bt <- themeAttr+      tellImages $ (\a -> [V.text' (applyProfile prof (V.withForeColor a orange)) (label <> " ")]) <$> bt+    gradientSwatch = do+      th <- theme+      dw <- displayWidth+      let grad = gradient1D [(0.0, RGB 255 0 0), (0.5, RGB 0 255 0), (1.0, RGB 0 0 255)]+          sampleAt w i = sampleGradient1D grad (fromIntegral i / fromIntegral (max 1 (w - 1)))+          bar t w = [V.horizCat $ map (\i -> render (inherit (_theme_default t) (withBackground (fromRGB (sampleAt w i)) def)) " ") [0 .. max 1 (w - 1)]]+      tellImages $ bar <$> th <*> current dw+    canvasOverlayDemo = do+      th <- theme+      let bgText = "background text shows through around the overlay"+          mkCanvas t =+            let bgBase = applyAttr (inherit (_theme_default t) def) V.defAttr+                bgRow = V.text' bgBase bgText+                bg = imageToCanvas $ V.vertCat [bgRow, bgRow, bgRow]+                overlayStyle =+                  withBorder roundedBorder+                    . withBackground (fromRGB (RGB 40 42 54))+                    . withForeground (fromRGB (RGB 255 184 108))+                    $ def+                overlayCanvas = imageToCanvas $ render overlayStyle " Overlay "+                result = placeCanvas 3 0 overlayCanvas bg+            in [canvasToImage result]+      tellImages $ mkCanvas <$> th
+ src-bin/examples.hs view
@@ -0,0 +1,50 @@+-- | A gallery of small, standalone reflex-vty demos — ports of the Bubble Tea+-- examples (https://github.com/charmbracelet/bubbletea/tree/main/examples).+--+-- Run one with: @cabal run examples -- <name>@ (defaults to @spinner@).+module Main where++import qualified Data.Text as T+import Reflex+import System.Environment (getArgs)++import Example.CellBuffer+import Example.Common+import Example.DoomFire+import Example.Pager+import Example.Progress+import Example.Space+import Example.Spinner+import Example.Splash+import Example.Stopwatch+import Example.TextInput+import Example.Timer+import Example.Views+import Reflex.Vty++main :: IO ()+main = do+  args <- getArgs+  let name = case args of+        (a : _) -> a+        _ -> "spinner"+  mainWidget def $ runExample name++-- | Dispatch to a demo by name.+runExample :: Demo t m => String -> m (Event t ())+runExample = \case+  "spinner" -> spinner+  "progress" -> progressBar+  "progress-bar" -> progressBar+  "stopwatch" -> stopwatch+  "timer" -> timer+  "textinput" -> textInputExample+  "pager" -> pager+  "views" -> views+  "cellbuffer" -> cellBuffer+  "doom-fire" -> doomFire+  "space" -> space+  "splash" -> splash+  other -> do+    text $ pure $ "Unknown example: " <> T.pack other <> "  (q to quit)"+    quit
+ src-bin/leaktest.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- Space-leak repro for profiling. A streaming producer fires into the FRP+-- network as fast as possible via 'performEventAsync'; the only buffer in+-- play is the reflex host's event channel. The program self-terminates after+-- a short delay via 'exitSuccess' so the RTS flushes profiling output.+--+-- Uses @forever@ (not @forM_ [1..n]@) so the producer itself doesn't+-- materialize a list -- keeping the profile focused on the host's event+-- channel rather than the producer's enumeration.+--+-- Run under the threaded RTS with >=2 capabilities, e.g.:+--   leaktest +RTS -N2 -hy -p -M4000m -RTS+module Main (main) where++import Control.Concurrent (threadDelay)+import qualified Control.Concurrent.Async as Async+import Control.Monad (forever, void)+import Control.Monad.IO.Class (liftIO)+import Data.Text (pack)+import qualified Graphics.Vty as V+import Reflex+import System.Exit (exitSuccess)++import Data.Text.Zipper (TextAlignment (..))+import Reflex.Vty++main :: IO ()+main = do+  void $ Async.async (threadDelay 2000000 >> exitSuccess)+  mainWidget def $ initManager_ $ do+    setupE <- getPostBuild+    inp <- input+    sE <-+      performEventAsync $+        ffor setupE $+          \() fire -> liftIO . void . Async.async $ forever (fire (0 :: Int))+    sB <- current <$> holdDyn 0 sE+    col $+      grout (fixed 17) $+        boxTitle (constant TextAlignment_Left) (constant doubleBoxStyle) "" $+          grout (fixed 1) $+            text (pack . show <$> sB)+    pure $ fforMaybe inp $ \case+      V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()+      _ -> Nothing
src/Control/Monad/NodeId.hs view
@@ -1,22 +1,21 @@-{-|-Module: Control.Monad.NodeId-Description: Monad providing a supply of unique identifiers--}-{-# Language UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module: Control.Monad.NodeId+-- Description: Monad providing a supply of unique identifiers module Control.Monad.NodeId   ( NodeId   , MonadNodeId (..)-  , NodeIdT+  , NodeIdT (..)   , runNodeIdT   ) where -import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)-import Control.Monad.Morph+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix+import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.Ref import Data.IORef- import Reflex import Reflex.Host.Class @@ -33,26 +32,26 @@   getNextNodeId = lift getNextNodeId  -- | A monad transformer that internally keeps track of the next 'NodeId'-newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }+newtype NodeIdT m a = NodeIdT {unNodeIdT :: ReaderT (IORef NodeId) m a}   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor     , MFunctor     , Monad+    , MonadCatch     , MonadFix     , MonadHold t     , MonadIO+    , MonadMask     , MonadRef     , MonadReflexCreateTrigger t     , MonadSample t+    , MonadThrow     , MonadTrans     , NotReady t     , PerformEvent t     , PostBuild t     , TriggerEvent t-    , MonadCatch-    , MonadThrow-    , MonadMask     )  instance MonadNodeId m => MonadNodeId (ReaderT x m)
src/Data/Text/Zipper.hs view
@@ -1,33 +1,28 @@-{-|-Module: Data.Text.Zipper-Description: A zipper for text documents that allows convenient editing and navigation--'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position.--'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper.---}+-- |+-- Module: Data.Text.Zipper+-- Description: A zipper for text documents that allows convenient editing and navigation+--+-- 'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position.+--+-- 'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper. module Data.Text.Zipper where  import Control.Exception (assert) import Control.Monad import Control.Monad.State (evalState, get, put) import Data.Char (isSpace)-import Data.Map (Map)-import Data.String- import qualified Data.List as L+import Data.Map (Map) import qualified Data.Map as Map+import Data.String import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Internal (Text(..), text)+import Data.Text.Internal (Text (..)) import Data.Text.Internal.Fusion (stream)-import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))+import Data.Text.Internal.Fusion.Types (Step (..), Stream (..)) import Data.Text.Unsafe- import Graphics.Text.Width (wcwidth) - -- | A zipper of the logical text input contents (the "document"). The lines -- before the line containing the cursor are stored in reverse order. -- The cursor is logically between the "before" and "after" text.@@ -40,19 +35,20 @@   , _textZipper_after :: Text -- The cursor is on top of the first character of this text   , _textZipper_linesAfter :: [Text]   }-  deriving (Show, Eq)+  deriving (Eq, Show)  instance IsString TextZipper where   fromString = fromText . T.pack  -- | Map a replacement function over the characters in a 'TextZipper' mapZipper :: (Char -> Char) -> TextZipper -> TextZipper-mapZipper f (TextZipper lb b a la) = TextZipper-  { _textZipper_linesBefore = fmap (T.map f) lb-  , _textZipper_before = T.map f b-  , _textZipper_after = T.map f a-  , _textZipper_linesAfter = fmap (T.map f) la-  }+mapZipper f (TextZipper lb b a la) =+  TextZipper+    { _textZipper_linesBefore = fmap (T.map f) lb+    , _textZipper_before = T.map f b+    , _textZipper_after = T.map f a+    , _textZipper_linesAfter = fmap (T.map f) la+    }  -- | Move the cursor left one character, if possible left :: TextZipper -> TextZipper@@ -65,10 +61,10 @@   if T.length b >= n     then       let n' = T.length b - n-      in  TextZipper lb (T.take n' b) (T.drop n' b <> a) la+      in TextZipper lb (T.take n' b) (T.drop n' b <> a) la     else case lb of-           [] -> home z-           (l:ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la)+      [] -> home z+      (l : ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la)  -- | Move the cursor right one character, if possible right :: TextZipper -> TextZipper@@ -81,14 +77,14 @@   if T.length a >= n     then TextZipper lb (b <> T.take n a) (T.drop n a) la     else case la of-           [] -> end z-           (l:ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls+      [] -> end z+      (l : ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls  -- | Move the cursor up one logical line, if possible up :: TextZipper -> TextZipper up z@(TextZipper lb b a la) = case lb of   [] -> z-  (l:ls) ->+  (l : ls) ->     let (b', a') = T.splitAt (T.length b) l     in TextZipper ls b' a' ((b <> a) : la) @@ -96,21 +92,23 @@ down :: TextZipper -> TextZipper down z@(TextZipper lb b a la) = case la of   [] -> z-  (l:ls) ->+  (l : ls) ->     let (b', a') = T.splitAt (T.length b) l     in TextZipper ((b <> a) : lb) b' a' ls  -- | Move the cursor up by the given number of lines pageUp :: Int -> TextZipper -> TextZipper-pageUp pageSize z = if pageSize <= 0-  then z-  else pageUp (pageSize - 1) $ up z+pageUp pageSize z =+  if pageSize <= 0+    then z+    else pageUp (pageSize - 1) $ up z  -- | Move the cursor down by the given number of lines pageDown :: Int -> TextZipper -> TextZipper-pageDown pageSize z = if pageSize <= 0-  then z-  else pageDown (pageSize - 1) $ down z+pageDown pageSize z =+  if pageSize <= 0+    then z+    else pageDown (pageSize - 1) $ down z  -- | Move the cursor to the beginning of the current logical line home :: TextZipper -> TextZipper@@ -124,7 +122,7 @@ top :: TextZipper -> TextZipper top (TextZipper lb b a la) = case reverse lb of   [] -> TextZipper [] "" (b <> a) la-  (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)+  (start : rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)  -- | Insert a character at the current cursor position insertChar :: Char -> TextZipper -> TextZipper@@ -132,18 +130,18 @@  -- | Insert text at the current cursor position insert :: Text -> TextZipper -> TextZipper-insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of+insert i z@(TextZipper lb b a la) = case T.split (== '\n') i of   [] -> z-  (start:rest) -> case reverse rest of+  (start : rest) -> case reverse rest of     [] -> TextZipper lb (b <> start) a la-    (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la+    (l : ls) -> TextZipper (ls <> [b <> start] <> lb) l a la  -- | Delete the character to the left of the cursor-deleteLeft :: TextZipper-> TextZipper+deleteLeft :: TextZipper -> TextZipper deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of   Nothing -> case lb of     [] -> z-    (l:ls) -> TextZipper ls l a la+    (l : ls) -> TextZipper ls l a la   Just (b', _) -> TextZipper lb b' a la  -- | Delete the character under/to the right of the cursor@@ -151,7 +149,7 @@ deleteRight z@(TextZipper lb b a la) = case T.uncons a of   Nothing -> case la of     [] -> z-    (l:ls) -> TextZipper lb b l ls+    (l : ls) -> TextZipper lb b l ls   Just (_, a') -> TextZipper lb b a' la  -- | Delete a word to the left of the cursor. Deletes all whitespace until it@@ -160,11 +158,11 @@ deleteLeftWord :: TextZipper -> TextZipper deleteLeftWord (TextZipper lb b a la) =   let b' = T.dropWhileEnd isSpace b-  in  if T.null b'-        then case lb of-          [] -> TextZipper [] b' a la-          (l:ls) -> deleteLeftWord $ TextZipper ls l a la-        else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la+  in if T.null b'+       then case lb of+         [] -> TextZipper [] b' a la+         (l : ls) -> deleteLeftWord $ TextZipper ls l a la+       else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la  -- | Insert up to n spaces to get to the next logical column that is a multiple of n tab :: Int -> TextZipper -> TextZipper@@ -173,10 +171,13 @@  -- | The plain text contents of the zipper value :: TextZipper -> Text-value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb-  , [b <> a]-  , la-  ]+value (TextZipper lb b a la) =+  T.intercalate "\n" $+    mconcat+      [ reverse lb+      , [b <> a]+      , la+      ]  -- | The empty zipper empty :: TextZipper@@ -193,8 +194,8 @@   deriving (Eq, Show)  -- | Text alignment type-data TextAlignment =-  TextAlignment_Left+data TextAlignment+  = TextAlignment_Left   | TextAlignment_Right   | TextAlignment_Center   deriving (Eq, Show)@@ -208,18 +209,21 @@ -- | Helper type representing a single visual line that may be part of a wrapped logical line data WrappedLine = WrappedLine   { _wrappedLines_text :: Text-  , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character-  , _wrappedLines_offset :: Int -- ^ offset from beginning of line+  , _wrappedLines_hiddenWhitespace :: Bool+  -- ^ 'True' if this line ends with a deleted whitespace character+  , _wrappedLines_offset :: Int+  -- ^ offset from beginning of line   }   deriving (Eq, Show)  -- | Information about the document as it is displayed (i.e., post-wrapping)-data DisplayLines tag = DisplayLines {-    _displayLines_spans :: [[Span tag]]-    -- ^ NOTE this will contain a dummy space character if the cursor is at the end-    , _displayLines_offsetMap :: OffsetMapWithAlignment-    -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line-    , _displayLines_cursorPos :: (Int, Int) -- ^ cursor position relative to upper left hand corner+data DisplayLines tag = DisplayLines+  { _displayLines_spans :: [[Span tag]]+  -- ^ NOTE this will contain a dummy space character if the cursor is at the end+  , _displayLines_offsetMap :: OffsetMapWithAlignment+  -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line+  , _displayLines_cursorPos :: (Int, Int)+  -- ^ cursor position relative to upper left hand corner   }   deriving (Eq, Show) @@ -229,11 +233,10 @@ -- -- because the first character has a width of two (see 'charWidth' for more on that). splitAtWidth :: Int -> Text -> (Text, Text)-splitAtWidth n t@(Text arr off len)-    | n <= 0 = (T.empty, t)-    | n >= textWidth t = (t, T.empty)-    | otherwise = let k = characterIndexFromWidth n t-                  in (text arr off k, text arr (off+k) (len-k))+splitAtWidth n t+  | n <= 0 = (T.empty, t)+  | n >= textWidth t = (t, T.empty)+  | otherwise = T.splitAt (characterIndexFromWidth n t) t  -- | Convert a physical width index to a character index. For example, the -- physical index 3 of the string "ᄀabc" corresponds to the character index 2,@@ -247,14 +250,15 @@       -> Int -- The accumulated physical width       -> Int -- The new logical index     loop !bytes !li !cumw-        -- if we've gone past the last byte-        | bytes >= len' = li-1-        -- if we hit our target-        | cumw + w > n' = li-        -- advance one character-        | otherwise = loop (bytes+byteWidth) (li+1) (cumw + w)-      where Iter c byteWidth = iter t' bytes-            w = charWidth c+      -- if we've gone past the last byte+      | bytes >= len' = li - 1+      -- if we hit our target+      | cumw + w > n' = li+      -- advance one character+      | otherwise = loop (bytes + byteWidth) (li + 1) (cumw + w)+      where+        Iter c byteWidth = iter t' bytes+        w = charWidth c  -- | Takes the given number of columns of characters. For example --@@ -300,27 +304,25 @@ -- fullwidth unicode forms. widthI :: Stream Char -> Int widthI (Stream next s0 _len) = loop_length 0 s0-    where-      loop_length !z s  = case next s of-                           Done       -> z-                           Skip    s' -> loop_length z s'-                           Yield c s' -> loop_length (z + charWidth c) s'-{-# INLINE[0] widthI #-}+  where+    loop_length !z s = case next s of+      Done -> z+      Skip s' -> loop_length z s'+      Yield c s' -> loop_length (z + charWidth c) s'+{-# INLINE [0] widthI #-}  -- | Compute the logical index position of a stream of characters from a visual -- position taking into account fullwidth unicode forms. charIndexAt :: Int -> Stream Char -> Int charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0-    where-      loop_length i !z s  = case next s of-                           Done       -> i-                           Skip    s' -> loop_length i z s'-                           Yield c s' -> if w > pos then i else loop_length (i+1) w s' where-                             w = z + charWidth c-{-# INLINE[0] charIndexAt #-}---+  where+    loop_length i !z s = case next s of+      Done -> i+      Skip s' -> loop_length i z s'+      Yield c s' -> if w > pos then i else loop_length (i + 1) w s'+        where+          w = z + charWidth c+{-# INLINE [0] charIndexAt #-}  -- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...]) -- 'Char's representing white space.@@ -328,43 +330,50 @@ wordsWithWhitespace t@(Text arr off len) = loop 0 0 False   where     loop !start !n !wasSpace-        | n >= len = [Text arr (start+off) (n-start) | not (start == n)]-        | isSpace c = loop start (n+d) True-        | wasSpace = Text arr (start+off) (n-start) : loop n n False-        | otherwise = loop start (n+d) False-        where Iter c d = iter t n+      | n >= len = [Text arr (start + off) (n - start) | not (start == n)]+      | isSpace c = loop start (n + d) True+      | wasSpace = Text arr (start + off) (n - start) : loop n n False+      | otherwise = loop start (n + d) False+      where+        Iter c d = iter t n {-# INLINE wordsWithWhitespace #-}  -- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]-splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where-  appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]-  appendOut [] t b           = [(t,b)]-  appendOut ((t',_):ts') t b = (t'<>t,b) : ts'--  -- remove the last whitespace in output-  modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]-  modifyOutForNewLine [] = error "should never happen"-  modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of-    Nothing           -> error "should never happen"-    Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace+splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 []+  where+    appendOut :: [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)]+    appendOut [] t b = [(t, b)]+    appendOut ((t', _) : ts') t b = (t' <> t, b) : ts' -  loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]-  loop [] _ out = out-  loop (x:xs) cumw out = r where-    newWidth = textWidth x + cumw-    r = if newWidth > maxWidth-      then if isSpace $ T.index x (characterIndexFromWidth (maxWidth - cumw) x)-        -- if line runs over but character of splitting is whitespace then split on the whitespace-        then let (t1,t2) = splitAtWidth (maxWidth - cumw) x-          in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True-        else if cumw == 0-          -- single word exceeds max width, so just split on the word-          then let (t1,t2) = splitAtWidth (maxWidth - cumw) x-            in loop (t2:xs) 0 [] <> appendOut out t1 False-          -- otherwise start a new line-          else loop (x:xs) 0 [] <> modifyOutForNewLine out-      else loop xs newWidth $ appendOut out x False+    -- remove the last whitespace in output+    modifyOutForNewLine :: [(Text, Bool)] -> [(Text, Bool)]+    modifyOutForNewLine [] = error "should never happen"+    modifyOutForNewLine ((t', _) : ts) = case T.unsnoc t' of+      Nothing -> error "should never happen"+      Just (t, lastChar) -> assert (isSpace lastChar) $ (t, True) : ts -- assume last char is whitespace+    loop :: [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]+    loop [] _ out = out+    loop (x : xs) cumw out = r+      where+        newWidth = textWidth x + cumw+        r =+          if newWidth > maxWidth+            then+              if isSpace $ T.index x (characterIndexFromWidth (maxWidth - cumw) x)+                -- if line runs over but character of splitting is whitespace then split on the whitespace+                then+                  let (t1, t2) = splitAtWidth (maxWidth - cumw) x+                  in loop (T.drop 1 t2 : xs) 0 [] <> appendOut out t1 True+                else+                  if cumw == 0+                    -- single word exceeds max width, so just split on the word+                    then+                      let (t1, t2) = splitAtWidth (maxWidth - cumw) x+                      in loop (t2 : xs) 0 [] <> appendOut out t1 False+                    -- otherwise start a new line+                    else loop (x : xs) 0 [] <> modifyOutForNewLine out+            else loop xs newWidth $ appendOut out x False  -- | Calculate the offset that will result in rendered text being aligned left, -- right, or center@@ -374,8 +383,8 @@   -> Text   -> Int alignmentOffset alignment maxWidth t = case alignment of-  TextAlignment_Left   -> 0-  TextAlignment_Right  -> (maxWidth - l)+  TextAlignment_Left -> 0+  TextAlignment_Right -> (maxWidth - l)   TextAlignment_Center -> (maxWidth - l) `div` 2   where     l = textWidth t@@ -385,37 +394,43 @@ -- lines are not. wrapWithOffsetAndAlignment   :: TextAlignment-  -> Int -- ^ Maximum width-  -> Int -- ^ Offset for first line-  -> Text -- ^ Text to be wrapped+  -> Int+  -- ^ Maximum width+  -> Int+  -- ^ Offset for first line+  -> Text+  -- ^ Text to be wrapped   -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line) wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []-wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where-  r' = if T.null txt-    then [("",False)]-    -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't)-    -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere)-    else splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)-  fmapfn (t,b) = WrappedLine t b $ alignmentOffset alignment maxWidth t-  r'' =  case r' of-    []       -> []-    (x,b):xs -> (T.drop n x,b):xs-  r = fmap fmapfn r''+wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r+  where+    r' =+      if T.null txt+        then [("", False)]+        -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't)+        -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere)+        else splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace (T.replicate n "." <> txt)+    fmapfn (t, b) = WrappedLine t b $ alignmentOffset alignment maxWidth t+    r'' = case r' of+      [] -> []+      (x, b) : xs -> (T.drop n x, b) : xs+    r = fmap fmapfn r''  -- | converts deleted eol spaces into logical lines eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]-eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) .  concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))+eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a, c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))  offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines  offsetMapWithAlignment-  :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines+  :: [[(Text, Int)]]+  -- ^ The outer list represents logical lines, inner list represents wrapped lines   -> OffsetMapWithAlignment offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)   where     offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do-      maps <- forM x $ \(line,align) -> do+      maps <- forM x $ \(line, align) -> do         let l = T.length line         (dl, o) <- get         put (dl + 1, o + l)@@ -423,8 +438,7 @@       (dl, o) <- get       put (dl, o + 1)       -- add additional offset to last line in wrapped lines (for newline char)-      return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps-+      return $ Map.adjust (\(align, _) -> (align, o + 1)) dl $ Map.unions maps  -- | Given a width and a 'TextZipper', produce a list of display lines -- (i.e., lines of wrapped text) with special attributes applied to@@ -433,14 +447,17 @@ -- offset displayLinesWithAlignment   :: TextAlignment-  -> Int -- ^ Width, used for wrapping-  -> tag -- ^ Metadata for normal characters-  -> tag -- ^ Metadata for the cursor-  -> TextZipper -- ^ The text input contents and cursor state+  -> Int+  -- ^ Width, used for wrapping+  -> tag+  -- ^ Metadata for normal characters+  -> tag+  -- ^ Metadata for the cursor+  -> TextZipper+  -- ^ The text input contents and cursor state   -> DisplayLines tag displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =-  let-      linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line+  let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line       linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb       linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line       linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la@@ -448,17 +465,19 @@       -- simulate trailing cursor character when computing OffsetMap       afterWithCursor = if T.null a then " " else a       offsets :: OffsetMapWithAlignment-      offsets = offsetMapWithAlignmentInternal $ mconcat-        [ linesBefore-        , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]-        , linesAfter-        ]+      offsets =+        offsetMapWithAlignmentInternal $+          mconcat+            [ linesBefore+            , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]+            , linesAfter+            ]       flattenLines = concatMap (fmap _wrappedLines_text)-      spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore-      spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter+      spansBefore = map ((: []) . Span tag) $ flattenLines linesBefore+      spansAfter = map ((: []) . Span tag) $ flattenLines linesAfter       -- Separate the spans before the cursor into-      -- * spans that are on earlier display lines (though on the same logical line), and-      -- * spans that are on the same display line+      -- \* spans that are on earlier display lines (though on the same logical line), and+      -- \* spans that are on the same display line        -- do the current line       curlinetext = b <> a@@ -467,54 +486,68 @@        -- map to spans and highlight the cursor       -- accumulator type (accumulated text length, Either (current y position) (cursor y and x position))-      --mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])-      mapaccumlfn (acclength, ecpos) (WrappedLine t dwseol xoff) = r where-        tlength = T.length t-        -- how many words we've gone through-        nextacclength = acclength + tlength + if dwseol then 1 else 0-        nextacc = (nextacclength, nextecpos)-        cursoroncurspan = nextacclength >= blength && (blength >= acclength)-        charsbeforecursor = blength-acclength-        ctlength = textWidth $ T.take charsbeforecursor t-        cursorx = xoff + ctlength-        nextecpos = case ecpos of-          Left y -> if cursoroncurspan-            then if ctlength == width-              -- cursor wraps to next line case-              then Right (y+1, 0)-              else Right (y, cursorx)-            else Left (y+1)-          Right x -> Right x+      -- mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])+      mapaccumlfn (acclength, ecpos) (WrappedLine t dwseol xoff) = r+        where+          tlength = T.length t+          -- how many words we've gone through+          nextacclength = acclength + tlength + if dwseol then 1 else 0+          nextacc = (nextacclength, nextecpos)+          cursoroncurspan = nextacclength >= blength && (blength >= acclength)+          charsbeforecursor = blength - acclength+          ctlength = textWidth $ T.take charsbeforecursor t+          cursorx = xoff + ctlength+          nextecpos = case ecpos of+            Left y ->+              if cursoroncurspan+                then+                  if ctlength == width+                    -- cursor wraps to next line case+                    then Right (y + 1, 0)+                    else Right (y, cursorx)+                else Left (y + 1)+            Right x -> Right x -        beforecursor = T.take charsbeforecursor t-        cursortext = T.take 1 $ T.drop charsbeforecursor t-        aftercursor = T.drop (charsbeforecursor+1) t+          beforecursor = T.take charsbeforecursor t+          cursortext = T.take 1 $ T.drop charsbeforecursor t+          aftercursor = T.drop (charsbeforecursor + 1) t -        cursorspans = [Span tag beforecursor, Span cursorTag cursortext] <> if T.null aftercursor then [] else [Span tag aftercursor]+          -- When the cursor goes past the last character of the current+          -- logical line (@a@ is empty), there is no character under it to+          -- highlight, so we render a blank cell carrying the cursor tag. This+          -- keeps the cursor visible at the end of the text. We only do this+          -- at the true end of the line, never at a soft-wrap boundary (which+          -- would double the cursor).+          cursorcell = if T.null cursortext && T.null a then " " else cursortext+          cursorspans = [Span tag beforecursor, Span cursorTag cursorcell] <> if T.null aftercursor then [] else [Span tag aftercursor] -        r = if cursoroncurspan-          then (nextacc, cursorspans)-          else (nextacc, [Span tag t])-      ((_, ecpos_out), curlinespans) = if T.null curlinetext-        -- manually handle empty case because mapaccumlfn doesn't handle it-        then ((0, Right (0, alignmentOffset alignment width "")), [[Span cursorTag ""]])-        else L.mapAccumL mapaccumlfn (0, Left 0) curwrappedlines+          r =+            if cursoroncurspan+              then (nextacc, cursorspans)+              else (nextacc, [Span tag t])+      ((_, ecpos_out), curlinespans) =+        if T.null curlinetext+          -- Manually handle empty case. Render a blank cursor cell (a space)+          -- so the cursor stays visible on an empty line instead of collapsing+          -- to nothing.+          then ((0, Right (0, alignmentOffset alignment width "")), [[Span cursorTag " "]])+          else L.mapAccumL mapaccumlfn (0, Left 0) curwrappedlines        (cursorY', cursorX) = case ecpos_out of-        Right (y,x) -> (y,x)+        Right (y, x) -> (y, x)         -- if we never hit the cursor position, this means it's at the beginning of the next line-        Left y      -> (y+1, alignmentOffset alignment width "")+        Left y -> (y + 1, alignmentOffset alignment width "")       cursorY = cursorY' + length spansBefore--  in  DisplayLines-        { _displayLines_spans = concat-          [ spansBefore-          , curlinespans-          , spansAfter-          ]-        , _displayLines_offsetMap = offsets-        , _displayLines_cursorPos = (cursorX, cursorY)-        }+  in DisplayLines+       { _displayLines_spans =+           concat+             [ spansBefore+             , curlinespans+             , spansAfter+             ]+       , _displayLines_offsetMap = offsets+       , _displayLines_cursorPos = (cursorX, cursorY)+       }  -- | Move the cursor of the given 'TextZipper' to the logical position indicated -- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'@@ -523,15 +556,14 @@ goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper goToDisplayLinePosition x y dl tz =   let offset = Map.lookup y $ _displayLines_offsetMap dl-  in  case offset of-        Nothing -> tz-        Just (alignOff,o) ->-          let-            trueX = max 0 (x - alignOff)-            moveRight = case drop y $ _displayLines_spans dl of-                []    -> 0-                (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s-          in  rightN (o + moveRight) $ top tz+  in case offset of+       Nothing -> tz+       Just (alignOff, o) ->+         let trueX = max 0 (x - alignOff)+             moveRight = case drop y $ _displayLines_spans dl of+               [] -> 0+               (s : _) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s+         in rightN (o + moveRight) $ top tz  -- | Given a width and a 'TextZipper', produce a list of display lines -- (i.e., lines of wrapped text) with special attributes applied to@@ -539,10 +571,14 @@ -- y-coordinate of the cursor and a mapping from display line number to text -- offset displayLines-  :: Int -- ^ Width, used for wrapping-  -> tag -- ^ Metadata for normal characters-  -> tag -- ^ Metadata for the cursor-  -> TextZipper -- ^ The text input contents and cursor state+  :: Int+  -- ^ Width, used for wrapping+  -> tag+  -- ^ Metadata for normal characters+  -> tag+  -- ^ Metadata for the cursor+  -> TextZipper+  -- ^ The text input contents and cursor state   -> DisplayLines tag displayLines = displayLinesWithAlignment TextAlignment_Left @@ -550,8 +586,11 @@ -- wrapped line is offset by the number of columns provided. Subsequent wrapped -- lines are not. wrapWithOffset-  :: Int -- ^ Maximum width-  -> Int -- ^ Offset for first line-  -> Text -- ^ Text to be wrapped+  :: Int+  -- ^ Maximum width+  -> Int+  -- ^ Offset for first line+  -> Text+  -- ^ Text to be wrapped   -> [Text] wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs
− src/Reflex/Spider/Orphans.hs 
@@ -1,20 +0,0 @@-{-|-Module: Reflex.Spider.Orphans-Description: Orphan instances for SpiderTimeline and SpiderHost--}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Reflex.Spider.Orphans where--#if MIN_VERSION_reflex(0,6,3)-#else-import Reflex-import Reflex.Spider.Internal--instance NotReady (SpiderTimeline x) (SpiderHost x) where-  notReadyUntil _ = pure ()-  notReady = pure ()--instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where-  notReadyUntil _ = pure ()-  notReady = pure ()-#endif
src/Reflex/Vty.hs view
@@ -1,18 +1,21 @@-{-|-Module: Reflex.Vty-Description: A library for building vty apps with reflex-Copyright   : (c) Obsidian Systems LLC-License     : GPL-3-Maintainer  : maintainer@obsidian.systems-Stability   : experimental-Portability : POSIX--<<./doc/tasks.png>>---}+-- |+-- Module: Reflex.Vty+-- Description: A library for building vty apps with reflex+-- Copyright   : (c) Obsidian Systems LLC+-- License     : BSD-3+-- Maintainer  : maintainer@obsidian.systems+-- Stability   : experimental+-- Portability : POSIX+--+-- <<./doc/tasks.png>> module Reflex.Vty   ( module Reflex+  , module Reflex.Vty.Canvas+  , module Reflex.Vty.Color+  , module Reflex.Vty.ColorProfile   , module Reflex.Vty.Host+  , module Reflex.Vty.Style+  , module Reflex.Vty.Theme   , module Reflex.Vty.Widget   , module Reflex.Vty.Widget.Box   , module Reflex.Vty.Widget.Input@@ -24,7 +27,14 @@   ) where  import Reflex++import Control.Monad.NodeId+import Reflex.Vty.Canvas+import Reflex.Vty.Color+import Reflex.Vty.ColorProfile import Reflex.Vty.Host+import Reflex.Vty.Style+import Reflex.Vty.Theme import Reflex.Vty.Widget import Reflex.Vty.Widget.Box import Reflex.Vty.Widget.Input@@ -32,5 +42,3 @@ import Reflex.Vty.Widget.Scroll import Reflex.Vty.Widget.Split import Reflex.Vty.Widget.Text--import Control.Monad.NodeId
+ src/Reflex/Vty/Canvas.hs view
@@ -0,0 +1,378 @@+-- |+-- Module: Reflex.Vty.Canvas+-- Description: Per-glyph compositing with transparency+--+-- A 'Canvas' is a 2D grid keyed by glyph-start cells. Absent keys+-- mean transparent. Each 'CanvasCell' holds one positive-width base+-- character and its zero-width text. This records wide glyphs and+-- combining marks exactly. A wide glyph occupies its continuation+-- column without a second map entry. Combining marks keep their own+-- attribute runs inside the covered glyph.+--+-- 'imageToCanvas' decodes the spans that Vty rendered.+-- 'canvasToImage' emits transparent gaps as 'V.backgroundFill'. An+-- underlying image then shows through. Partial retention of a wide+-- glyph follows Vty's ellipsis policy. The retained half becomes a+-- width-one @…@. Right clipping drops a trailing combining suffix.+-- Left clipping keeps it.+--+-- Typical usage: capture a child widget's images via 'captureImages',+-- convert to a 'Canvas' with 'imageToCanvas', composite overlay+-- 'Canvas'es on top with 'stack', then convert back to an 'Image' with+-- 'canvasToImage' and emit via 'tellImages'.+module Reflex.Vty.Canvas+  ( Canvas (..)+  , CanvasCell (..)+  , canvasCellAt+  , blankCanvas+  , placeCanvas+  , translate+  , stack+  , imageToCanvas+  , canvasToImage+  ) where++import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, maybeToList)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as Vec+import Graphics.Text.Width (wcwidth)+import qualified Graphics.Vty as V+import Graphics.Vty.DisplayAttributes (fixDisplayAttr)+import qualified Graphics.Vty.PictureToSpans as PTS+import Graphics.Vty.Span (SpanOp (RowEnd, Skip, TextSpan))++-- | A 2D grid of glyph cells. The 'Map' is keyed by @(x, y)@ where+-- @(0,0)@ is the top-left corner and @x@ is the glyph's /start/+-- column. Keys absent from the map are transparent. Valid canvases+-- have nonoverlapping, in-bounds glyph intervals whose stored widths+-- match their text. 'imageToCanvas' and the combinators below+-- preserve this invariant.+data Canvas = Canvas+  { canvasWidth :: !Int+  , canvasHeight :: !Int+  , canvasCells :: !(Map (Int, Int) CanvasCell)+  }+  deriving (Eq, Show)++-- | One glyph: its total column width on screen and its attributed+-- text runs in order. The runs are the zero-width prefix runs, the+-- single positive-width base run, and the zero-width suffix runs.+-- Consecutive runs always differ in attribute. 'canvasCellColumns' is+-- the Vty width of the payload, normally 1 or 2.+data CanvasCell = CanvasCell+  { canvasCellColumns :: !Int+  , canvasCellRuns :: !(NonEmpty (V.Attr, T.Text))+  }+  deriving (Eq, Show)++-- | A fully transparent canvas of the given dimensions.+blankCanvas :: Int -> Int -> Canvas+blankCanvas w h = Canvas w h Map.empty++-- | Look up the glyph covering @(x, y)@. This is either the glyph+-- starting at @x@ or the glyph whose continuation column @x@ is.+-- Returns 'Nothing' for transparent and out-of-bounds coordinates.+canvasCellAt :: Int -> Int -> Canvas -> Maybe CanvasCell+canvasCellAt x y (Canvas w h cells)+  | x < 0 || y < 0 || x >= w || y >= h = Nothing+  | otherwise = case Map.lookup (x, y) cells of+      Just c -> Just c+      Nothing -> do+        prev <- Map.lookup (x - 1, y) cells+        if x - 1 + canvasCellColumns prev > x then Just prev else Nothing++----------------------------------------------------------------------------+-- Glyph anatomy and clipping+----------------------------------------------------------------------------++-- | A glyph split around its single positive-width base character: the+-- zero-width prefix runs, the base run's attribute, and the zero-width+-- suffix runs.+data GlyphParts = GlyphParts+  { glyphPrefix :: [(V.Attr, T.Text)]+  , glyphBaseAttr :: V.Attr+  , glyphSuffix :: [(V.Attr, T.Text)]+  }++splitGlyph :: CanvasCell -> GlyphParts+splitGlyph (CanvasCell _ glyphRuns) = go (NE.toList glyphRuns) []+  where+    go [] acc = GlyphParts (dropNull acc) V.defAttr []+    go ((attr, txt) : rest) acc =+      case T.findIndex (\c -> wcwidth c > 0) txt of+        Nothing -> go rest (acc ++ [(attr, txt)])+        Just i ->+          let (before, fromBase) = T.splitAt i txt+              afterTxt = T.drop 1 fromBase+          in GlyphParts+               { glyphPrefix = dropNull (acc ++ [(attr, before)])+               , glyphBaseAttr = attr+               , glyphSuffix = dropNull ([(attr, afterTxt)] ++ rest)+               }++dropNull :: [(a, T.Text)] -> [(a, T.Text)]+dropNull = filter (not . T.null . snd)++-- | Build a cell from runs, coalescing adjacent equal-attribute runs+-- and computing the column width from the text itself.+cellFromRuns :: [(V.Attr, T.Text)] -> CanvasCell+cellFromRuns runs0 =+  let glyphRuns = coalesce (dropNull runs0)+      width = sum [w | (_, txt) <- glyphRuns, ch <- T.unpack txt, let w = wcwidth ch, w > 0]+  in CanvasCell width (fromMaybe ((V.defAttr, "\x2026") :| []) (NE.nonEmpty glyphRuns))+  where+    coalesce = List.foldl' step []+    step [] r = [r]+    step acc r@(attr, txt)+      | attr == fst (last acc) = init acc ++ [(attr, snd (last acc) <> txt)]+      | otherwise = acc ++ [r]++-- | The clipped cell that keeps the /left/ part of a glyph. It is a+-- width-one @…@ with the base attribute and any zero-width prefix.+-- The zero-width suffix is dropped, as in Vty's right-edge clipping.+clipLeftPart :: GlyphParts -> CanvasCell+clipLeftPart parts = cellFromRuns (glyphPrefix parts ++ [(glyphBaseAttr parts, "\x2026")])++-- | The clipped cell that keeps the /right/ part. It is a width-one+-- @…@ with the base attribute, followed by the zero-width suffix. This+-- matches Vty's left-edge clipping.+clipRightPart :: GlyphParts -> CanvasCell+clipRightPart parts = cellFromRuns ((glyphBaseAttr parts, "\x2026") : glyphSuffix parts)++-- | Clip the glyph starting at column @x@ to the window @[lo, hi)@.+-- Wholly outside yields nothing. A partially retained glyph becomes+-- its clipped half.+clipInterval :: Int -> Int -> Int -> CanvasCell -> Maybe (Int, CanvasCell)+clipInterval lo hi x c+  | end <= lo || x >= hi = Nothing+  | x >= lo && end <= hi = Just (x, c)+  | x < lo = Just (lo, clipRightPart (splitGlyph c))+  | otherwise = Just (x, clipLeftPart (splitGlyph c))+  where+    end = x + canvasCellColumns c++-- | The columns occupied by opaque glyphs.+coveredColumns :: Map Int CanvasCell -> [Int]+coveredColumns =+  concatMap (\(x, c) -> [x .. x + canvasCellColumns c - 1]) . Map.toList++-- | Clip a destination glyph against the overwritten columns. This+-- can split it into several retained cells. A wholly covered glyph+-- disappears. A partially covered glyph is clipped to each of its+-- remaining column runs.+clipAgainst :: [Int] -> Int -> CanvasCell -> [(Int, CanvasCell)]+clipAgainst covered x c =+  case runs (filter (`notElem` covered) [x .. end - 1]) of+    [(s, l)] | (s, l) == (x, canvasCellColumns c) -> [(x, c)]+    rs -> map mk rs+  where+    end = x + canvasCellColumns c+    parts = splitGlyph c+    mk (s, _)+      | s == x = (s, clipLeftPart parts)+      | otherwise = (s, clipRightPart parts)++-- | Group ascending, consecutive columns into maximal @(start, length)@+-- runs.+runs :: [Int] -> [(Int, Int)]+runs = List.foldl' step []+  where+    step [] n = [(n, 1)]+    step acc@((s, l) : rest) n+      | s + l == n = (s, l + 1) : rest+      | otherwise = (n, 1) : acc++----------------------------------------------------------------------------+-- Composition+----------------------------------------------------------------------------++-- | Place a source canvas onto a destination at offset @(dx, dy)@.+-- The result has the destination's dimensions. Transparent source+-- positions do not change the destination. Opaque source glyphs+-- overwrite the destination. They clip destination glyphs that they+-- partially cover, with Vty's ellipsis policy. Source glyphs+-- partially outside the destination are clipped the same way. Glyphs+-- wholly outside disappear.+placeCanvas :: Int -> Int -> Canvas -> Canvas -> Canvas+placeCanvas dx dy src dst = Canvas dw dh (Map.unions (map row [0 .. dh - 1]))+  where+    dw = canvasWidth dst+    dh = canvasHeight dst+    srcRows = rowsOf src+    dstRows = rowsOf dst+    row y =+      let srcRow = Map.findWithDefault Map.empty (y - dy) srcRows+          dstRow = Map.findWithDefault Map.empty y dstRows+          srcClipped =+            Map.fromList+              [ (x', c')+              | (x, c) <- Map.toList srcRow+              , (x', c') <- maybeToList (clipInterval 0 dw (x + dx) c)+              ]+          dstClipped =+            Map.fromList+              [ (x', c')+              | (x, c) <- Map.toList dstRow+              , (x', c') <- clipAgainst (coveredColumns srcClipped) x c+              ]+      in Map.mapKeysMonotonic (\x -> (x, y)) (Map.union dstClipped srcClipped)++-- | Shift a canvas by @(dx, dy)@. Dimensions are preserved. Glyphs+-- that move outside bounds are clipped or lost. Vacated positions+-- become transparent.+translate :: Int -> Int -> Canvas -> Canvas+translate dx dy src =+  placeCanvas dx dy src (blankCanvas (canvasWidth src) (canvasHeight src))++-- | Stack canvases in z-order (last = topmost). The result has the+-- first canvas's dimensions; later canvases overlay earlier ones.+stack :: [Canvas] -> Canvas+stack [] = blankCanvas 0 0+stack (c : cs) = List.foldl' (\dst src -> placeCanvas 0 0 src dst) c cs++-- | Group a canvas's cells by row, keyed by glyph start column.+rowsOf :: Canvas -> Map Int (Map Int CanvasCell)+rowsOf = Map.foldlWithKey' insert Map.empty . canvasCells+  where+    insert acc (x, y) cell = Map.insertWith Map.union y (Map.singleton x cell) acc++----------------------------------------------------------------------------+-- Conversions+----------------------------------------------------------------------------++-- | Terminal default attributes.+defaultFixedAttr :: V.FixedAttr+defaultFixedAttr = V.FixedAttr V.defaultStyleMask Nothing Nothing Nothing++-- | Convert a resolved 'V.FixedAttr' back to a fully specified+-- 'V.Attr' with no 'V.KeepCurrent' fields.+fixedToAttr :: V.FixedAttr -> V.Attr+fixedToAttr f =+  V.Attr+    { V.attrStyle =+        if V.fixedStyle f == V.defaultStyleMask then V.Default else V.SetTo (V.fixedStyle f)+    , V.attrForeColor = maybe V.Default V.SetTo (V.fixedForeColor f)+    , V.attrBackColor = maybe V.Default V.SetTo (V.fixedBackColor f)+    , V.attrURL = maybe V.Default V.SetTo (V.fixedURL f)+    }++-- | Convert a vty 'Image' to an opaque 'Canvas'. This decodes the+-- spans that Vty rendered for the image. Every column becomes a+-- concrete glyph cell, including row-end and background blanks. A+-- zero-area image has no cells.+imageToCanvas :: V.Image -> Canvas+imageToCanvas img+  | w <= 0 || h <= 0 = Canvas w h Map.empty+  | otherwise =+      Canvas+        { canvasWidth = w+        , canvasHeight = h+        , canvasCells =+            Map.fromList+              [ ((x, y), c)+              | (y, row) <- zip [0 ..] (map (decodeRow . Vec.toList) (Vec.toList ops))+              , (x, c) <- Map.toList row+              ]+        }+  where+    w = V.imageWidth img+    h = V.imageHeight img+    ops = PTS.displayOpsForPic (V.picForImage img) (w, h)++-- | Decode one row of span operations into glyph cells. Zero-width+-- characters become suffix runs of the preceding glyph. A zero-width+-- prefix of the row, before the first base character, becomes a+-- prefix of the first glyph.+decodeRow :: [SpanOp] -> Map Int CanvasCell+decodeRow = go defaultFixedAttr 0 Nothing [] Map.empty+  where+    go _ _ _ _ acc [] = acc+    go cur col lastStart pending acc (op : rest) = case op of+      TextSpan attr _ _ tl ->+        let eff = fixDisplayAttr cur attr+            attr' = fixedToAttr eff+            (col', lastStart', pending', acc') =+              decodeText attr' (TL.toStrict tl) col lastStart pending acc+        in go eff col' lastStart' pending' acc' rest+      RowEnd n ->+        let blankAttr = fixedToAttr defaultFixedAttr+            (col', lastStart', pending', acc') =+              decodeText blankAttr (T.replicate n " ") col lastStart pending acc+        in go defaultFixedAttr col' lastStart' pending' acc' rest+      Skip n ->+        error $+          "canvas decode error: unexpected Skip ("+            ++ show n+            ++ " columns) in final picture spans"++-- | Decode attributed text into glyph cells. The column cursor, the+-- start of the last emitted glyph (for zero-width attachment), and+-- any pending zero-width prefix are threaded through.+decodeText+  :: V.Attr+  -> T.Text+  -> Int+  -> Maybe Int+  -> [(V.Attr, T.Text)]+  -> Map Int CanvasCell+  -> (Int, Maybe Int, [(V.Attr, T.Text)], Map Int CanvasCell)+decodeText baseAttr txt startCol startGlyph startPending startCells = T.foldl' step (startCol, startGlyph, startPending, startCells) txt+  where+    step (col, lastStart, pending, acc) ch =+      let cw = wcwidth ch+      in if cw <= 0+           then case lastStart of+             Just ls ->+               ( col+               , lastStart+               , pending+               , Map.adjust (appendRun (baseAttr, T.singleton ch)) ls acc+               )+             Nothing ->+               (col, lastStart, pending ++ [(baseAttr, T.singleton ch)], acc)+           else+             let cell = cellFromRuns (pending ++ [(baseAttr, T.singleton ch)])+             in (col + cw, Just col, [], Map.insert col cell acc)++-- | Append a run to a cell, re-coalescing and recomputing its width.+appendRun :: (V.Attr, T.Text) -> CanvasCell -> CanvasCell+appendRun run c =+  cellFromRuns (NE.toList (canvasCellRuns c) ++ [run])++-- | One horizontal piece of an output row: attributed text or a+-- transparent gap.+data RowPart = TextRun (V.Attr, T.Text) | Gap !Int++-- | Convert a 'Canvas' to a vty 'Image'. Transparent gaps become+-- 'V.backgroundFill', so an underlying image shows through. Each+-- glyph consumes its full column width; no continuation space is+-- emitted. Adjacent equal-attribute text runs are coalesced.+-- Nonpositive area renders as 'V.emptyImage'.+canvasToImage :: Canvas -> V.Image+canvasToImage canvas@(Canvas w h _)+  | w <= 0 || h <= 0 = V.emptyImage+  | otherwise = V.vertCat [rowImage y | y <- [0 .. h - 1]]+  where+    rowsMap = rowsOf canvas+    rowImage y =+      V.horizCat . map partImage . mergeParts $+        walkRow 0 (Map.toList (Map.findWithDefault Map.empty y rowsMap))+    walkRow col [] = [Gap (w - col) | w - col > 0]+    walkRow col ((x, c) : rest) =+      [Gap (x - col) | x - col > 0]+        ++ map TextRun (NE.toList (canvasCellRuns c))+        ++ walkRow (x + canvasCellColumns c) rest+    mergeParts = List.foldl' merge []+    merge [] p = [p]+    merge acc p = case (last acc, p) of+      (TextRun (a1, t1), TextRun (a2, t2))+        | a1 == a2 -> init acc ++ [TextRun (a1, t1 <> t2)]+      _ -> acc ++ [p]+    partImage (TextRun (attr, txt)) = V.text' attr txt+    partImage (Gap n) = V.backgroundFill n 1
+ src/Reflex/Vty/Color.hs view
@@ -0,0 +1,162 @@+-- |+-- Module: Reflex.Vty.Color+-- Description: Color manipulation and gradient utilities+module Reflex.Vty.Color+  ( -- * RGB color type+    RGB (..)+  , toRGB+  , fromRGB++    -- * Color operations+  , darken+  , lighten+  , complementary+  , mix+  , alpha++    -- * Gradients+  , Gradient1D (..)+  , gradient1D+  , sampleGradient1D+  , Gradient2D (..)+  , gradient2D+  , sampleGradient2D+  ) where++import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Word (Word8)+import qualified Graphics.Vty as V++----------------------------------------------------------------------------+-- RGB color type+----------------------------------------------------------------------------++-- | An sRGB color triplet. This is the working type for all color+-- operations; convert to\/from vty's 'V.Color' with 'toRGB' \/ 'fromRGB'.+data RGB = RGB+  { rgbRed :: !Word8+  , rgbGreen :: !Word8+  , rgbBlue :: !Word8+  }+  deriving (Eq, Ord, Show)++-- | Extract 'RGB' components from a vty 'V.Color'. Returns 'Nothing' for+-- 'ISOColor' and 'Color240' (which require a palette lookup).+toRGB :: V.Color -> Maybe RGB+toRGB (V.RGBColor r g b) = Just (RGB r g b)+toRGB _ = Nothing++-- | Convert an 'RGB' triplet to a vty 'V.Color' as an 'RGBColor'.+fromRGB :: RGB -> V.Color+fromRGB (RGB r g b) = V.RGBColor r g b++----------------------------------------------------------------------------+-- Color operations+----------------------------------------------------------------------------++-- | Darken a color by a factor.+-- @darken 0.0@ = black, @darken 1.0@ = unchanged.+darken :: Double -> RGB -> RGB+darken factor (RGB r g b) =+  RGB (scale r) (scale g) (scale b)+  where+    scale c = clampByte (fromIntegral c * clamp01 factor)++-- | Lighten a color by a factor (towards white).+-- @lighten 0.0@ = unchanged, @lighten 1.0@ = white.+lighten :: Double -> RGB -> RGB+lighten factor (RGB r g b) =+  RGB (lift r) (lift g) (lift b)+  where+    f = clamp01 factor+    lift c = clampByte (fromIntegral c + (255 - fromIntegral c) * f)++-- | Complementary color (RGB inversion).+complementary :: RGB -> RGB+complementary (RGB r g b) =+  RGB (255 - r) (255 - g) (255 - b)++-- | Mix two colors.+-- @mix 0.0 a b@ = @a@, @mix 1.0 a b@ = @b@, @mix 0.5 a b@ = average.+mix :: Double -> RGB -> RGB -> RGB+mix t (RGB r1 g1 b1) (RGB r2 g2 b2) =+  RGB (blend r1 r2) (blend g1 g2) (blend b1 b2)+  where+    f = clamp01 t+    blend a b = clampByte (fromIntegral a * (1 - f) + fromIntegral b * f)++-- | Alpha-blend a foreground over a background.+-- @alpha 0.0 fg bg@ = @bg@ (transparent), @alpha 1.0 fg bg@ = @fg@ (opaque).+alpha :: Double -> RGB -> RGB -> RGB+alpha t fg bg = mix t bg fg++----------------------------------------------------------------------------+-- Gradients (1D)+----------------------------------------------------------------------------++-- | A 1D gradient defined by color stops at positions [0, 1].+data Gradient1D = Gradient1D+  { gradient1DStops :: [(Double, RGB)]+  -- ^ Sorted list of (position, color) pairs.+  }++-- | Create a 1D gradient from a list of stops. Stops are sorted by+-- position. Positions should be in [0, 1].+gradient1D :: [(Double, RGB)] -> Gradient1D+gradient1D = Gradient1D . sortBy (comparing fst)++-- | Sample a 1D gradient at the given position [0, 1].+-- Linearly interpolates between the two nearest stops.+sampleGradient1D :: Gradient1D -> Double -> RGB+sampleGradient1D (Gradient1D stops) pos+  | null stops = RGB 0 0 0+  | pos <= 0 = snd (headStops stops)+  | pos >= 1 = snd (last stops)+  | otherwise = go stops+  where+    headStops :: [(Double, RGB)] -> (Double, RGB)+    headStops ((_, c) : _) = (0, c)+    headStops [] = (0, RGB 0 0 0)+    go ((p1, c1) : rest@((p2, c2) : _))+      | pos <= p2 = lerp (pos - p1) (p2 - p1) c1 c2+      | otherwise = go rest+    go [(_, c)] = c+    go [] = RGB 0 0 0++----------------------------------------------------------------------------+-- Gradients (2D)+----------------------------------------------------------------------------++-- | A 2D gradient defined by four corner colors.+data Gradient2D = Gradient2D+  { gradient2DTopLeft :: !RGB+  , gradient2DTopRight :: !RGB+  , gradient2DBottomLeft :: !RGB+  , gradient2DBottomRight :: !RGB+  }++-- | Create a 2D gradient from four corner colors (TL, TR, BL, BR).+gradient2D :: RGB -> RGB -> RGB -> RGB -> Gradient2D+gradient2D = Gradient2D++-- | Sample a 2D gradient at the given (x, y) position, each in [0, 1].+-- Uses bilinear interpolation between the four corners.+sampleGradient2D :: Gradient2D -> Double -> Double -> RGB+sampleGradient2D (Gradient2D tl tr bl br) x y =+  mix y (mix x tl tr) (mix x bl br)++----------------------------------------------------------------------------+-- Internal helpers+----------------------------------------------------------------------------++lerp :: Double -> Double -> RGB -> RGB -> RGB+lerp t range c1 c2+  | range <= 0 = c2+  | otherwise = mix (t / range) c1 c2++clamp01 :: Double -> Double+clamp01 = max 0 . min 1++clampByte :: Double -> Word8+clampByte x = fromIntegral (round (max 0 (min (255 :: Double) x)) :: Int)
+ src/Reflex/Vty/ColorProfile.hs view
@@ -0,0 +1,156 @@+-- |+-- Module: Reflex.Vty.ColorProfile+-- Description: Terminal color-capability detection and downsampling+--+-- A 'ColorProfile' describes how many colors the terminal can display.+-- 'detectColorProfile' reads the capability from a vty+-- 'Graphics.Vty.Output.Output' handle, and 'applyProfile' downsamples an+-- 'Graphics.Vty.Attr' so that colors and styles the terminal cannot render are+-- replaced with the closest approximation (or dropped entirely for+-- 'ColorProfile_Ascii' and 'ColorProfile_NoTTY').+--+-- Widgets build with 'Graphics.Vty.Attributes.Color.RGBColor' (which is true+-- color) and the host downsamples once per frame at the 'Graphics.Vty.Picture'+-- boundary, so widget code never needs to worry about terminal capability.+module Reflex.Vty.ColorProfile+  ( ColorProfile (..)+  , colorProfileFromColorMode+  , colorProfileFromVty+  , detectColorProfile+  , convertColor+  , applyProfile+  ) where++import Control.Monad.IO.Class (MonadIO)+import Data.List (minimumBy)+import Data.Ord (comparing)+import qualified Graphics.Vty as V+import qualified Graphics.Vty.Attributes.Color as V.Color+import qualified Graphics.Vty.Attributes.Color240 as V.Color240+import qualified Graphics.Vty.Output as V.Output++-- | The color rendering capability of a terminal. Ordered from richest to+-- poorest; see 'applyProfile' for how each profile affects an 'V.Attr'.+data ColorProfile+  = -- | 24-bit RGB; any color renders verbatim.+    ColorProfile_TrueColor+  | -- | 8-bit (216-color cube + 24 greys); 'V.Color.RGBColor' is downsampled+    --     to 'V.Color.Color240'.+    ColorProfile_Ansi256+  | -- | 4-bit (the 16 ANSI colors); 'V.Color.RGBColor' and 'V.Color.Color240'+    --     are downsampled to the nearest 'V.Color.ISOColor'.+    ColorProfile_Ansi16+  | -- | No color support; all colors are stripped.+    ColorProfile_Ascii+  | -- | Not a TTY at all; all ANSI escapes (colors /and/ styles) are stripped.+    ColorProfile_NoTTY+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++-- | Map vty's 'V.Color.ColorMode' to a 'ColorProfile'. 'V.Color.ColorMode240'+-- maps to 'ColorProfile_Ansi256'; 'V.Color.FullColor' to 'ColorProfile_TrueColor';+-- 'V.Color.ColorMode16' to 'ColorProfile_Ansi16'; 'V.Color.ColorMode8' to+-- 'ColorProfile_Ansi16' as well (the 8 ANSI colors are a subset of the 16);+-- 'V.Color.NoColor' to 'ColorProfile_Ascii'.+colorProfileFromColorMode :: V.Color.ColorMode -> ColorProfile+colorProfileFromColorMode = \case+  V.Color.NoColor -> ColorProfile_Ascii+  V.Color.ColorMode8 -> ColorProfile_Ansi16+  V.Color.ColorMode16 -> ColorProfile_Ansi16+  V.Color.ColorMode240 {} -> ColorProfile_Ansi256+  V.Color.FullColor -> ColorProfile_TrueColor++-- | Read the color profile from a vty 'V.Output.Output' by inspecting its+-- 'V.Output.outputColorMode'.+colorProfileFromVty :: V.Vty -> ColorProfile+colorProfileFromVty = colorProfileFromColorMode . V.Output.outputColorMode . V.outputIface++-- | 'colorProfileFromVty' in 'MonadIO' for convenience at call sites that+-- are already lifted. Reads from the 'V.Vty' handle's output interface.+detectColorProfile :: MonadIO m => V.Vty -> m ColorProfile+detectColorProfile = pure . colorProfileFromVty++-- | Downsample a single 'V.Color' to the closest representation the profile+-- can render. For 'ColorProfile_Ascii' and 'ColorProfile_NoTTY' the color is+-- returned unchanged: callers should use 'applyProfile' to set the+-- surrounding 'V.Attr' field to 'V.Default' instead, since those profiles+-- have no color representation at all.+convertColor :: ColorProfile -> V.Color.Color -> V.Color.Color+convertColor = \case+  ColorProfile_TrueColor -> id+  ColorProfile_Ansi256 -> \case+    V.Color.RGBColor r g b -> V.Color.Color240 (V.Color240.rgbColorToColor240 r g b)+    c -> c+  ColorProfile_Ansi16 -> nearestIso+  ColorProfile_Ascii -> id+  ColorProfile_NoTTY -> id++-- | Downsample an entire 'V.Attr' for the profile: colors via 'convertColor',+-- and for 'ColorProfile_Ascii' / 'ColorProfile_NoTTY' the foreground,+-- background, and style are all reset to 'V.Default' so no color or style+-- escapes are emitted. The URL field is preserved (hyperlinks are not color).+applyProfile :: ColorProfile -> V.Attr -> V.Attr+applyProfile profile attr = case profile of+  ColorProfile_NoTTY ->+    attr {V.attrStyle = V.Default, V.attrForeColor = V.Default, V.attrBackColor = V.Default}+  ColorProfile_Ascii ->+    attr {V.attrForeColor = V.Default, V.attrBackColor = V.Default}+  _ ->+    attr+      { V.attrForeColor = downsampleColorField V.attrForeColor+      , V.attrBackColor = downsampleColorField V.attrBackColor+      }+  where+    downsampleColorField sel = case sel attr of+      V.SetTo c -> V.SetTo (convertColor profile c)+      other -> other++-- | Perceptual nearest-neighbor mapping from any 'V.Color' to the closest of+-- the 16 ANSI 'V.Color.ISOColor' values. Uses the standard xterm 16-color+-- RGB table and the redmean weighted distance, which approximates human+-- color perception better than naive Euclidean RGB distance.+nearestIso :: V.Color.Color -> V.Color.Color+nearestIso c = case c of+  V.Color.ISOColor {} -> c+  V.Color.Color240 i -> case V.Color240.color240CodeToRGB i of+    Nothing -> c+    Just rgb3 -> nearestIsoRGB rgb3+  V.Color.RGBColor r g b -> nearestIsoRGB (fromIntegral r, fromIntegral g, fromIntegral b)++-- | The 16 ANSI colors paired with their standard xterm RGB coordinates.+isoRgbTable :: [(V.Color.Color, (Int, Int, Int))]+isoRgbTable =+  [ (V.Color.black, (0, 0, 0))+  , (V.Color.red, (205, 0, 0))+  , (V.Color.green, (0, 205, 0))+  , (V.Color.yellow, (205, 205, 0))+  , (V.Color.blue, (0, 0, 205))+  , (V.Color.magenta, (205, 0, 205))+  , (V.Color.cyan, (0, 205, 205))+  , (V.Color.white, (229, 229, 229))+  , (V.Color.brightBlack, (127, 127, 127))+  , (V.Color.brightRed, (255, 0, 0))+  , (V.Color.brightGreen, (0, 255, 0))+  , (V.Color.brightYellow, (255, 255, 0))+  , (V.Color.brightBlue, (0, 0, 255))+  , (V.Color.brightMagenta, (255, 0, 255))+  , (V.Color.brightCyan, (0, 255, 255))+  , (V.Color.brightWhite, (255, 255, 255))+  ]++-- | Redmean weighted distance between two RGB triples. Approximates+-- human color perception: green matters most, then red, then blue.+rgbDistanceSq :: (Int, Int, Int) -> (Int, Int, Int) -> Int+rgbDistanceSq (r1, g1, b1) (r2, g2, b2) =+  ((512 + rmean) * dr * dr) `div` 256+    + 4 * dg * dg+    + ((512 + 255 - rmean) * db * db) `div` 256+  where+    rmean = (r1 + r2) `div` 2+    dr = r1 - r2+    dg = g1 - g2+    db = b1 - b2++-- | Find the nearest ANSI-16 color to the given RGB value.+nearestIsoRGB :: (Int, Int, Int) -> V.Color.Color+nearestIsoRGB target =+  fst $ minimumBy (comparing (rgbDistanceSq target . snd)) isoRgbTable
src/Reflex/Vty/Host.hs view
@@ -1,10 +1,17 @@-{-|-Module: Reflex.Vty.Host-Description: Scaffolding for running a reflex-vty application--}+-- |+-- Module: Reflex.Vty.Host+-- Description: Scaffolding for running a reflex-vty application module Reflex.Vty.Host   ( VtyApp-  , VtyResult(..)+  , VtyResult (..)+  , VtyAppConfig (..)+  , defaultVtyAppConfig+  , CursorStyle (..)+  , CursorVisibility (..)+  , setCursorStyle+  , ScreenMode (..)+  , setScreenMode+  , AppSignal (..)   , getDefaultVty   , runVtyApp   , runVtyAppWithHandle@@ -12,27 +19,37 @@   , VtyEvent   ) where -import Control.Concurrent (forkIO, killThread)-import Control.Concurrent.Chan (newChan, readChan, writeChan)-import Control.Exception (onException)-import Control.Monad (forM, forM_, forever)-import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)+import Control.Concurrent.Async (AsyncCancelled, async, cancel, link, waitCatch)+import Control.Concurrent.STM (atomically)+import Control.Exception (SomeException, catch, mask, throwIO, try)+import Control.Monad (forM, forM_, forever, void)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix (MonadFix, fix)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Monad.Identity (Identity(..))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Identity (Identity (..)) import Control.Monad.Primitive (PrimMonad) import Control.Monad.Ref (MonadRef, Ref, readRef)+import Data.Default (Default (..)) import Data.Dependent.Sum (DSum ((:=>)))-import Data.IORef (IORef, readIORef)+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (catMaybes)--import Reflex-import Reflex.Host.Class-import Reflex.Spider.Orphans ()+import Graphics.Vty (DisplayRegion) import qualified Graphics.Vty as V import qualified Graphics.Vty.CrossPlatform as V+import Reflex+import Reflex.Host.Class -import Graphics.Vty (DisplayRegion)+import Reflex.Vty.Host.Signal+  ( AppSignal (..)+  , installAppSignalHandlers+  )+import Reflex.Vty.Host.Trigger+  ( closeBoundedEventQueue+  , drainBoundedEventQueue+  , newBoundedEventQueue+  , runBoundedTriggerT+  , writeBoundedEventQueue+  )  -- | A synonym for the underlying vty event type from 'Graphics.Vty'. This should -- probably ultimately be replaced by something defined in this library.@@ -42,7 +59,7 @@ data VtyResult t = VtyResult   { _vtyResult_picture :: Behavior t V.Picture   -- ^ The current vty output. 'runVtyAppWithHandle' samples this value every time an-  -- event fires and updates the display.+  --   event fires and updates the display.   , _vtyResult_shutdown :: Event t ()   -- ^ An event that requests application termination.   }@@ -74,138 +91,251 @@   )  -- | A functional reactive vty application.-type VtyApp t m = MonadVtyApp t m+type VtyApp t m =+  MonadVtyApp t m   => DisplayRegion   -- ^ The initial display size (updates to this come as events)   -> Event t V.Event   -- ^ Vty input events.+  -> Event t AppSignal+  -- ^ OS signal events, normalized across platforms. 'AppSignal_Interrupt',+  -- 'AppSignal_Terminate', and 'AppSignal_Hangup' all trigger shutdown.+  -- NOTE: This behavior will be configurable in the future.   -> m (VtyResult t)   -- ^ The output of the 'VtyApp'. The application runs in a context that,-  -- among other things, allows new events to be created and triggered-  -- ('TriggerEvent'), provides access to an event that fires immediately upon-  -- app instantiation ('PostBuild'), and allows actions to be run upon-  -- occurrences of events ('PerformEvent').+  --   among other things, allows new events to be created and triggered+  --   ('TriggerEvent'), provides access to an event that fires immediately upon+  --   app instantiation ('PostBuild'), and allows actions to be run upon+  --   occurrences of events ('PerformEvent'). +-- | Configuration for running a 'VtyApp'.+data VtyAppConfig = VtyAppConfig+  { _vtyConfig_eventQueueCapacity :: !Int+  -- ^ Maximum number of pending external trigger invocations the host will+  -- buffer before backpressuring producers (e.g. a hot+  -- 'Reflex.performEventAsync' callback). When the buffer is full, a+  -- producer's @fire@ blocks until the host catches up, bounding memory+  -- without dropping any occurrences. See 'defaultVtyAppConfig'.+  }++-- | A sensible default 'VtyAppConfig': an event-queue capacity of 4096, which+-- is large enough to absorb any realistic burst (a large paste, a flappy+-- mouse, network callbacks) without throttling, while keeping worst-case+-- per-frame fire work and memory modest (~530 KB ceiling).+instance Default VtyAppConfig where+  def = VtyAppConfig {_vtyConfig_eventQueueCapacity = 4096}++-- | The default 'VtyAppConfig' (identical to 'def').+defaultVtyAppConfig :: VtyAppConfig+defaultVtyAppConfig = def+ -- | Runs a 'VtyApp' in a given 'Graphics.Vty.Vty'.+--+-- The whole run is wrapped in one masked lifecycle. Resources are+-- acquired and recorded under masking. Exactly one cleanup path owns+-- teardown. Every exit path uses it: normal shutdown, guest failure,+-- rendering or input failure, or external cancellation. The cleanup+-- steps run in order. They close the event queue and release blocked+-- producers. They cancel and join the input worker if it was started.+-- They restore the OS signal handlers if they were installed. They+-- restore the default cursor style and the primary screen. They shut+-- Vty down exactly once. Every step is attempted even if an earlier+-- step failed. The application's own exception, if any, takes+-- precedence over cleanup failures. runVtyAppWithHandle-  :: V.Vty+  :: VtyAppConfig+  -- ^ Host configuration (event-queue capacity, etc.). Use+  -- 'defaultVtyAppConfig' for defaults.+  -> V.Vty   -- ^ A 'Graphics.Vty.Vty' handle.   -> (forall t m. VtyApp t m)   -- ^ A functional reactive vty application.   -> IO ()-runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $--  -- We are using the 'Spider' implementation of reflex. Running the host-  -- allows us to take actions on the FRP timeline. The scoped type signature-  -- specifies that our host runs on the Global timeline.-  -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'.-  (runSpiderHost :: SpiderHost Global a -> IO a) $ do--    -- Create an 'Event' and a "trigger" reference for that event. The trigger-    -- reference can be used to determine whether anyone is "subscribed" to-    -- that 'Event' and, therefore, whether we need to bother performing any-    -- updates when the 'Event' fires.-    -- The 'Event' below will be used to convey vty input events.-    (vtyEvent, vtyEventTriggerRef) <- newEventWithTriggerRef--    -- Create the "post-build" event and associated trigger. This event fires-    -- once, when the application starts.-    (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef--    -- Create a queue to which we will write 'Event's that need to be-    -- processed.-    events <- liftIO newChan+runVtyAppWithHandle cfg vty vtyGuest = mask $ \restore -> do+  workerRef <- newIORef Nothing+  signalRestoreRef <- newIORef Nothing+  pending <- newBoundedEventQueue (fromIntegral (max 1 (_vtyConfig_eventQueueCapacity cfg)))+  appResult <-+    try $+      restore $+        (runSpiderHost :: SpiderHost Global () -> IO ()) $ do+          -- We are using the 'Spider' implementation of reflex. Running the host+          -- allows us to take actions on the FRP timeline. The scoped type signature+          -- specifies that our host runs on the Global timeline.+          -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'. -    displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty+          -- Create an 'Event' and a "trigger" reference for that event. The trigger+          -- reference can be used to determine whether anyone is "subscribed" to+          -- that 'Event' and, therefore, whether we need to bother performing any+          -- updates when the 'Event' fires.+          -- The 'Event' below will be used to convey vty input events.+          (vtyEvent, vtyEventTriggerRef) <- newEventWithTriggerRef -    -- Run the vty "guest" application, providing the appropriate context. The-    -- result is a 'VtyResult', and a 'FireCommand' that will be used to-    -- trigger events.-    (vtyResult, fc@(FireCommand fire)) <- do-      hostPerformEventT $                 -- Allows the guest app to run-                                          -- 'performEvent', so that actions-                                          -- (e.g., IO actions) can be run when-                                          -- 'Event's fire.+          -- Create the "post-build" event and associated trigger. This event fires+          -- once, when the application starts.+          (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef -        flip runPostBuildT postBuild $    -- Allows the guest app to access to-                                          -- a "post-build" 'Event'+          -- Create an 'Event' for OS signals.+          (signalEvent, signalTriggerRef) <- newEventWithTriggerRef -          flip runTriggerEventT events $  -- Allows the guest app to create new-                                          -- events and triggers and writes-                                          -- those triggers to a channel from-                                          -- which they will be read and-                                          -- processed.+          displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty -            vtyGuest displayRegion0 vtyEvent-                                          -- The guest app is provided the-                                          -- initial display region and an-                                          -- 'Event' of vty inputs.+          -- Run the vty "guest" application, providing the appropriate context.+          -- The result is a 'VtyResult', and a 'FireCommand' that will be used to+          -- trigger events. The guest runs in 'BoundedTriggerT' so that its+          -- 'TriggerEvent' methods (and hence 'Reflex.performEventAsync') route+          -- writes through the bounded queue above. A producer that fires+          -- faster than the host can process then blocks instead of leaking+          -- memory.+          (vtyResult, fc@(FireCommand fire)) <- do+            hostPerformEventT $ -- Allows the guest app to run+            -- 'performEvent', so that actions+            -- (e.g., IO actions) can be run when+            -- 'Event's fire.+              flip runPostBuildT postBuild $ -- Allows the guest app to access to+              -- a "post-build" 'Event'+                flip runBoundedTriggerT pending $+                  vtyGuest displayRegion0 vtyEvent signalEvent+          -- The guest app is provided the+          -- initial display region, an+          -- 'Event' of vty inputs, and an+          -- 'Event' of OS signals. -    -- Reads the current value of the 'Picture' behavior and updates the-    -- display with it. This will be called whenever we determine that a-    -- display update is necessary. In this implementation that is when various-    -- events occur.-    let updateVty =-          sample (_vtyResult_picture vtyResult) >>= liftIO . V.update vty+          -- Subscribe, before anything is fired or drawn, to the 'Event' the+          -- guest application can use to request shutdown. SIGINT, SIGTERM,+          -- and SIGHUP from the host also trigger shutdown. This early+          -- subscription means the frame that fires post-build observes a+          -- shutdown request made at post-build.+          let sigShutdown =+                () <$ ffilter (\s -> s == AppSignal_Interrupt || s == AppSignal_Terminate || s == AppSignal_Hangup) signalEvent+          shutdown <- subscribeEvent $ leftmost [_vtyResult_shutdown vtyResult, sigShutdown]+          let readShutdown =+                readEvent shutdown >>= \case+                  Nothing -> return False+                  Just _ -> return True -    -- Read the trigger reference for the post-build event. This will be-    -- 'Nothing' if the guest application hasn't subscribed to this event.-    mPostBuildTrigger <- readRef postBuildTriggerRef+          -- Install OS signal handlers now. This happens after guest+          -- construction and shutdown subscription, but before firing+          -- post-build or drawing the first picture. Record how to restore+          -- the previous handlers. From this point on, a signal is enqueued+          -- and processed by the main loop below.+          liftIO $ do+            restoreSignals <-+              installAppSignalHandlers $ \appSignal ->+                atomically $+                  writeBoundedEventQueue pending [EventTriggerRef signalTriggerRef :=> TriggerInvocation appSignal (return ())]+            writeIORef signalRestoreRef (Just restoreSignals) -    -- When there is a subscriber to the post-build event, fire the event.-    forM_ mPostBuildTrigger $ \postBuildTrigger ->-      fire [postBuildTrigger :=> Identity ()] $ return ()+          -- Reads the current value of the 'Picture' behavior and updates the+          -- display with it. This will be called whenever we determine that a+          -- display update is necessary.+          let updateVty = sample (_vtyResult_picture vtyResult) >>= liftIO . V.update vty -    -- After firing the post-build event, sample the vty result and update-    -- the display.-    updateVty+          -- Read the trigger reference for the post-build event. This will be+          -- 'Nothing' if the guest application hasn't subscribed to this event.+          -- When firing it, the read phase checks the (already subscribed)+          -- shutdown event. Every frame result returned by @fire@ is+          -- examined, including follow-up frames from 'performEvent'+          -- actions. A shutdown requested at post-build therefore terminates+          -- here, before the input worker starts or an unnecessary frame is+          -- drawn.+          mPostBuildTrigger <- readRef postBuildTriggerRef+          stopAtPostBuild <- case mPostBuildTrigger of+            Nothing -> return False+            Just postBuildTrigger -> or <$> fire [postBuildTrigger :=> Identity ()] readShutdown -    -- Subscribe to an 'Event' of that the guest application can use to-    -- request application shutdown. We'll check whether this 'Event' is firing-    -- to determine whether to terminate.-    shutdown <- subscribeEvent $ _vtyResult_shutdown vtyResult+          if stopAtPostBuild+            then return ()+            else do+              -- Draw the first picture.+              updateVty -    -- Fork a thread and continuously get the next vty input event, and then-    -- write the input event to our channel of FRP 'Event' triggers.-    -- The thread is forked here because 'nextEvent' blocks.-    nextEventThread <- liftIO $ forkIO $ forever $ do-      -- Retrieve the next input event.-      ne <- V.nextEvent vty-      let -- The reference to the vty input 'EventTrigger'. This is the trigger-          -- we'd like to associate the input event value with.-          triggerRef = EventTriggerRef vtyEventTriggerRef-          -- Create an event 'TriggerInvocation' with the value that we'd like-          -- the event to have if it is fired. It may not fire with this value-          -- if nobody is subscribed to the 'Event'.-          triggerInvocation = TriggerInvocation ne $ return ()-      -- Write our input event's 'EventTrigger' with the newly created-      -- 'TriggerInvocation' value to the queue of events.-      writeChan events [triggerRef :=> triggerInvocation]+              -- Continuously read the next vty input event and enqueue it.+              -- nextEvent blocks, so this runs on its own thread. The worker+              -- is linked, so an unexpected input-reader failure is rethrown+              -- in this (host) thread. Deliberate cancellation during+              -- teardown completes the worker normally and does not+              -- propagate.+              inputWorker <-+                liftIO $+                  async $+                    ( restore $ forever $ do+                        ne <- V.nextEvent vty+                        atomically $+                          writeBoundedEventQueue pending [EventTriggerRef vtyEventTriggerRef :=> TriggerInvocation ne (return ())]+                    )+                      `catch` \(_ :: AsyncCancelled) -> return ()+              liftIO $ link inputWorker+              liftIO $ writeIORef workerRef (Just inputWorker) -    -- The main application loop. We wait for new events, fire those that-    -- have subscribers, and update the display. If we detect a shutdown-    -- request, the application terminates.-    fix $ \loop -> do-      -- Read the next event (blocking).-      ers <- liftIO $ readChan events-      stop <- do-        -- Fire events that have subscribers.-        fireEventTriggerRefs fc ers $-          -- Check if the shutdown 'Event' is firing.-          readEvent shutdown >>= \case-            Nothing -> return False-            Just _ -> return True-      if or stop-        then liftIO $ do             -- If we received a shutdown 'Event'-          killThread nextEventThread -- then stop reading input events and-          V.shutdown vty             -- call the 'Graphics.Vty.Vty's shutdown command.+              -- The main application loop. We block until at least one batch+              -- of events is available, then drain every other batch that has+              -- accumulated in the meantime, fire each batch in its own+              -- Reflex frame, and redraw once.+              --+              -- Draining the whole queue each frame keeps the host from+              -- falling behind under bursts, while the queue's bounded+              -- capacity (see 'VtyAppConfig') backpressures a producer that+              -- fires faster than the host can process, bounding memory+              -- without dropping occurrences. Firing each batch in its own+              -- frame preserves every occurrence even when many firings of+              -- the same trigger land in one drain (Reflex collapses+              -- simultaneous same-trigger firings, so merging them into one+              -- frame would drop occurrences); drawing only once per drain+              -- decouples the display rate from the event rate.+              fix $ \loop -> do+                -- Block until at least one batch is available, then+                -- atomically drain every other batch that has accumulated.+                mBatches <- liftIO $ restore $ drainBoundedEventQueue pending+                case mBatches of+                  -- Queue was closed and empty (e.g. another thread+                  -- triggered shutdown); stop the loop.+                  Nothing -> return ()+                  Just batches -> do+                    -- Fire each batch in its own frame, stopping early if+                    -- the shutdown event fires in any frame. This includes+                    -- follow-up frames from 'performEvent' actions.+                    let fireUntilShutdown [] = return False+                        fireUntilShutdown (b : bs) = do+                          stops <- fireEventTriggerRefs fc b readShutdown+                          if or stops then return True else fireUntilShutdown bs+                    stop <- fireUntilShutdown batches+                    if stop+                      then return ()+                      else do+                        updateVty+                        loop -        else do                      -- Otherwise, update the display and loop.-          updateVty-          loop+  -- Exactly one cleanup path owns teardown. Each step is attempted even+  -- if a previous step failed. The application's own exception, if any,+  -- takes precedence over the first cleanup failure.+  firstCleanupFailure <- do+    let steps =+          [ closeBoundedEventQueue pending+          , do+              mw <- readIORef workerRef+              forM_ mw $ \w -> cancel w >> void (waitCatch w)+          , do+              mr <- readIORef signalRestoreRef+              forM_ mr id+          , setCursorStyle (V.outputIface vty) CursorStyleDefault+          , setScreenMode (V.outputIface vty) ScreenNormal+          , V.shutdown vty+          ]+    results <- mapM (\act -> try act :: IO (Either SomeException ())) steps+    return $ case [e | Left e <- results] of+      (e : _) -> Just e+      [] -> Nothing+  case (appResult, firstCleanupFailure) of+    (Left appErr, _) -> throwIO (appErr :: SomeException)+    (Right (), Just cleanupErr) -> throwIO (cleanupErr :: SomeException)+    (Right (), Nothing) -> return ()   where-    -- | Use the given 'FireCommand' to fire events that have subscribers-    -- and call the callback for the 'TriggerInvocation' of each.+    -- \| Use the given 'FireCommand' to fire events that have subscribers+    -- and call the callback for the 'TriggerInvocation' of each. The+    -- completion callback of every /processed/ batch runs exactly once,+    -- whether or not its trigger has a subscriber. Batches dropped after+    -- closure, and batches never drained, do not run callbacks.     fireEventTriggerRefs       :: (Monad (ReadPhase m), MonadIO m)       => FireCommand t m@@ -223,17 +353,80 @@  -- | Run a 'VtyApp' with a 'Graphics.Vty.Vty' handle with a standard configuration. runVtyApp-  :: (forall t m. VtyApp t m)+  :: VtyAppConfig+  -> (forall t m. VtyApp t m)   -> IO ()-runVtyApp app = do+runVtyApp cfg app = do   vty <- getDefaultVty-  runVtyAppWithHandle vty app+  runVtyAppWithHandle cfg vty app --- | Returns the standard vty configuration with mouse mode enabled.+-- | Terminal cursor shape. Not all terminals support all styles; the+-- fallback is always a block cursor. Set via DECSCUSR escape sequences+-- (not part of vty 6.2's API).+data CursorStyle+  = -- | Restore the terminal's default cursor shape.+    CursorStyleDefault+  | -- | Steady block cursor.+    CursorStyleBlock+  | -- | Steady underline cursor.+    CursorStyleUnderline+  | -- | Steady vertical bar cursor (xterm extension).+    CursorStyleBar+  | CursorStyleBlinkingBlock+  | CursorStyleSteadyBlock+  | CursorStyleBlinkingUnderline+  | CursorStyleSteadyUnderline+  | -- | Blinking vertical bar (xterm extension).+    CursorStyleBlinkingBar+  | -- | Steady vertical bar (xterm extension).+    CursorStyleSteadyBar+  deriving (Bounded, Enum, Eq, Ord, Show)++-- | Whether the terminal cursor should be rendered.+data CursorVisibility+  = CursorVisible+  | CursorHidden+  deriving (Bounded, Enum, Eq, Ord, Show)++-- | Set the terminal cursor shape by emitting DECSCUSR escape sequences+-- directly to the output byte buffer.+setCursorStyle :: V.Output -> CursorStyle -> IO ()+setCursorStyle out style =+  V.outputByteBuffer out (toSeq style)+  where+    toSeq CursorStyleDefault = "\ESC[0 q"+    toSeq CursorStyleBlock = "\ESC[2 q"+    toSeq CursorStyleUnderline = "\ESC[4 q"+    toSeq CursorStyleBar = "\ESC[6 q"+    toSeq CursorStyleBlinkingBlock = "\ESC[1 q"+    toSeq CursorStyleSteadyBlock = "\ESC[2 q"+    toSeq CursorStyleBlinkingUnderline = "\ESC[3 q"+    toSeq CursorStyleSteadyUnderline = "\ESC[4 q"+    toSeq CursorStyleBlinkingBar = "\ESC[5 q"+    toSeq CursorStyleSteadyBar = "\ESC[6 q"++-- | Which screen buffer to use. Most full-screen TUI apps use the+-- alternate screen so the terminal restores prior content on exit.+data ScreenMode+  = ScreenNormal+  | ScreenAlternate+  deriving (Bounded, Enum, Eq, Ord, Show)++-- | Enter or exit the alternate screen buffer by emitting DECSET/DECRST+-- escape sequences (1049) directly to the output byte buffer.+setScreenMode :: V.Output -> ScreenMode -> IO ()+setScreenMode out = \case+  ScreenNormal -> V.outputByteBuffer out "\ESC[?1049l"+  ScreenAlternate -> V.outputByteBuffer out "\ESC[?1049h"++-- | Returns the standard vty configuration with mouse, focus tracking,+-- and bracketed paste enabled. getDefaultVty :: IO V.Vty getDefaultVty = do   cfg <- V.userConfig   vty <- V.mkVty cfg-  liftIO $ V.setMode (V.outputIface vty) V.Mouse True+  liftIO $ do+    V.setMode (V.outputIface vty) V.Mouse True+    V.setMode (V.outputIface vty) V.Focus True+    V.setMode (V.outputIface vty) V.BracketedPaste True   return vty-
+ src/Reflex/Vty/Style.hs view
@@ -0,0 +1,1116 @@+-- |+-- Module: Reflex.Vty.Style+-- Description: Lip Gloss-inspired declarative styling for vty images+--+-- A 'Style' is a record of presentation rules (foreground/background color, text+-- transforms and variants, padding, margin, borders, dimensions, and alignment)+-- that can be rendered to 'Graphics.Vty.Image'. Styles support inheritance:+-- 'inherit' fills only the fields that are unset in the child, and the 'with*'+-- setters replace fields.+--+-- Use 'render' or 'renderB' to produce an 'Image' from a 'Style' and some text.+module Reflex.Vty.Style+  ( -- * Types+    Style (..)+  , def++    -- ** Sub-types+  , Color+  , UnderlineStyle (..)+  , BorderStyle (..)+  , HAlign (..)+  , VAlign (..)+  , Padding (..)+  , Margin (..)++    -- * Color constants+  , black+  , red+  , green+  , yellow+  , blue+  , magenta+  , cyan+  , white+  , brightBlack+  , brightRed+  , brightGreen+  , brightYellow+  , brightBlue+  , brightMagenta+  , brightCyan+  , brightWhite+  , rgbColor++    -- * Border style presets+  , singleBorder+  , roundedBorder+  , thickBorder+  , doubleBorder+  , asciiBorder+  , markdownBorder+  , noBorder+  , innerHalfBorder+  , outerHalfBlockBorder++    -- * Setters++    -- ** Color+  , withForeground+  , withBackground++    -- ** Text transforms+  , withBold+  , withItalic+  , withFaint+  , withBlink+  , withStrikethrough+  , withReverse++    -- ** Underline+  , withUnderline+  , withUnderlineColor++    -- ** Hyperlink+  , withHyperlink++    -- ** Padding and margin+  , withPadding+  , withPaddingTop+  , withPaddingRight+  , withPaddingBottom+  , withPaddingLeft+  , withMargin+  , withMarginTop+  , withMarginRight+  , withMarginBottom+  , withMarginLeft++    -- ** Border+  , withBorder+  , withBorderForeground+  , withBorderBackground+  , withBorderTop+  , withBorderBottom+  , withBorderLeft+  , withBorderRight++    -- ** Dimensions+  , withWidth+  , withHeight+  , withMaxWidth+  , withMaxHeight++    -- ** Alignment+  , withAlignH+  , withAlignV++    -- ** Whitespace+  , withWhitespace++    -- ** Text transform+  , withTransform++    -- ** Tab width+  , withTabWidth++    -- ** Margin background+  , withMarginBackground++    -- ** Inline mode+  , withInline++    -- ** Color whitespace+  , withColorWhitespace++    -- ** Per-side border colors+  , withBorderTopForeground+  , withBorderTopBackground+  , withBorderBottomForeground+  , withBorderBottomBackground+  , withBorderLeftForeground+  , withBorderLeftBackground+  , withBorderRightForeground+  , withBorderRightBackground++    -- * Composition+  , inherit++    -- * Rendering+  , render+  , renderB+  , applyAttr+  , mergeAttr+  , measure++    -- * Image composition+  , joinHorizontal+  , joinVertical+  , placeHorizontal+  , placeVertical+  , place++    -- * Text utilities+  , truncateWith+  , textHeight+  , textSize+  ) where++import Control.Applicative ((<|>))+import Data.Default (Default (..))+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex (Behavior, Reflex)++import Data.Text.Zipper (charWidth, textWidth)++-- | A terminal color. Currently an alias for vty's 'V.Color'; this keeps the+-- public API stable if vty's representation changes later.+type Color = V.Color++-- | Underline decoration variants. vty only supports a single+-- 'V.underline' style bit, so 'UnderlineSingle' is the only one rendered+-- distinctly; the others are accepted for API compatibility with Lip Gloss+-- and degrade to single underline (or none) at render time.+data UnderlineStyle+  = UnderlineNone+  | UnderlineSingle+  | UnderlineDouble+  | UnderlineCurly+  | UnderlineDotted+  | UnderlineDashed+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++-- | Horizontal alignment within the available width.+data HAlign = HAlignLeft | HAlignCenter | HAlignRight+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++-- | Vertical alignment within the available height.+data VAlign = VAlignTop | VAlignMiddle | VAlignBottom+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++-- | Padding on the four sides (top, right, bottom, left), in cells.+data Padding = Padding+  { _padding_top :: !Int+  , _padding_right :: !Int+  , _padding_bottom :: !Int+  , _padding_left :: !Int+  }+  deriving (Eq, Ord, Show)++instance Default Padding where+  def = Padding 0 0 0 0++-- | Margin on the four sides (top, right, bottom, left), in cells. Margin+-- is drawn outside the border using the same whitespace character as+-- padding.+data Margin = Margin+  { _margin_top :: !Int+  , _margin_right :: !Int+  , _margin_bottom :: !Int+  , _margin_left :: !Int+  }+  deriving (Eq, Ord, Show)++instance Default Margin where+  def = Margin 0 0 0 0++-- | The eight characters that make up a box border. 'Nothing' on a side+-- means the side is not drawn; 'Nothing' on a corner means the corner is+-- not drawn when both adjacent sides are present.+data BorderStyle = BorderStyle+  { _border_top :: !(Maybe Char)+  , _border_bottom :: !(Maybe Char)+  , _border_left :: !(Maybe Char)+  , _border_right :: !(Maybe Char)+  , _border_topLeft :: !(Maybe Char)+  , _border_topRight :: !(Maybe Char)+  , _border_bottomLeft :: !(Maybe Char)+  , _border_bottomRight :: !(Maybe Char)+  }+  deriving (Eq, Ord, Show)++-- | A declarative presentational style, modelled on Lip Gloss's @Style@.+-- Every field is 'Maybe' so that 'inherit' can fill only the gaps; use the+-- 'with*' setters to populate fields and 'def' for an empty style.+data Style = Style+  { _style_foreground :: !(Maybe Color)+  , _style_background :: !(Maybe Color)+  , _style_bold :: !(Maybe Bool)+  , _style_italic :: !(Maybe Bool)+  , _style_faint :: !(Maybe Bool)+  , _style_blink :: !(Maybe Bool)+  , _style_strikethrough :: !(Maybe Bool)+  , _style_reverse :: !(Maybe Bool)+  , _style_underline :: !(Maybe UnderlineStyle)+  , _style_underlineColor :: !(Maybe Color)+  , _style_hyperlink :: !(Maybe Text)+  , _style_padding :: !Padding+  , _style_margin :: !Margin+  , _style_border :: !(Maybe BorderStyle)+  , _style_borderTop :: !(Maybe Bool)+  , _style_borderBottom :: !(Maybe Bool)+  , _style_borderLeft :: !(Maybe Bool)+  , _style_borderRight :: !(Maybe Bool)+  , _style_borderForeground :: !(Maybe Color)+  , _style_borderBackground :: !(Maybe Color)+  , _style_width :: !(Maybe Int)+  , _style_height :: !(Maybe Int)+  , _style_maxWidth :: !(Maybe Int)+  , _style_maxHeight :: !(Maybe Int)+  , _style_alignHorizontal :: !(Maybe HAlign)+  , _style_alignVertical :: !(Maybe VAlign)+  , _style_whitespaceChar :: !(Maybe Char)+  , _style_transform :: !(Maybe (Text -> Text))+  , _style_tabWidth :: !(Maybe Int)+  , _style_marginBackground :: !(Maybe Color)+  , _style_inline :: !(Maybe Bool)+  , _style_colorWhitespace :: !(Maybe Bool)+  , _style_borderTopForeground :: !(Maybe Color)+  , _style_borderTopBackground :: !(Maybe Color)+  , _style_borderBottomForeground :: !(Maybe Color)+  , _style_borderBottomBackground :: !(Maybe Color)+  , _style_borderLeftForeground :: !(Maybe Color)+  , _style_borderLeftBackground :: !(Maybe Color)+  , _style_borderRightForeground :: !(Maybe Color)+  , _style_borderRightBackground :: !(Maybe Color)+  }++instance Default Style where+  def =+    Style+      { _style_foreground = Nothing+      , _style_background = Nothing+      , _style_bold = Nothing+      , _style_italic = Nothing+      , _style_faint = Nothing+      , _style_blink = Nothing+      , _style_strikethrough = Nothing+      , _style_reverse = Nothing+      , _style_underline = Nothing+      , _style_underlineColor = Nothing+      , _style_hyperlink = Nothing+      , _style_padding = def+      , _style_margin = def+      , _style_border = Nothing+      , _style_borderTop = Nothing+      , _style_borderBottom = Nothing+      , _style_borderLeft = Nothing+      , _style_borderRight = Nothing+      , _style_borderForeground = Nothing+      , _style_borderBackground = Nothing+      , _style_width = Nothing+      , _style_height = Nothing+      , _style_maxWidth = Nothing+      , _style_maxHeight = Nothing+      , _style_alignHorizontal = Nothing+      , _style_alignVertical = Nothing+      , _style_whitespaceChar = Nothing+      , _style_transform = Nothing+      , _style_tabWidth = Nothing+      , _style_marginBackground = Nothing+      , _style_inline = Nothing+      , _style_colorWhitespace = Nothing+      , _style_borderTopForeground = Nothing+      , _style_borderTopBackground = Nothing+      , _style_borderBottomForeground = Nothing+      , _style_borderBottomBackground = Nothing+      , _style_borderLeftForeground = Nothing+      , _style_borderLeftBackground = Nothing+      , _style_borderRightForeground = Nothing+      , _style_borderRightBackground = Nothing+      }++-- | Fill the gaps in @child@ with values from @parent@. Only 'Nothing'+-- fields (and zero padding/margin) are inherited; non-'Nothing' fields in+-- @child@ are kept. This mirrors Lip Gloss's @Inherit@ semantics.+inherit :: Style -> Style -> Style+inherit parent child =+  Style+    { _style_foreground = pick _style_foreground+    , _style_background = pick _style_background+    , _style_bold = pick _style_bold+    , _style_italic = pick _style_italic+    , _style_faint = pick _style_faint+    , _style_blink = pick _style_blink+    , _style_strikethrough = pick _style_strikethrough+    , _style_reverse = pick _style_reverse+    , _style_underline = pick _style_underline+    , _style_underlineColor = pick _style_underlineColor+    , _style_hyperlink = pick _style_hyperlink+    , _style_padding = inheritPadding (_style_padding parent) (_style_padding child)+    , _style_margin = inheritMargin (_style_margin parent) (_style_margin child)+    , _style_border = pick _style_border+    , _style_borderTop = pick _style_borderTop+    , _style_borderBottom = pick _style_borderBottom+    , _style_borderLeft = pick _style_borderLeft+    , _style_borderRight = pick _style_borderRight+    , _style_borderForeground = pick _style_borderForeground+    , _style_borderBackground = pick _style_borderBackground+    , _style_width = pick _style_width+    , _style_height = pick _style_height+    , _style_maxWidth = pick _style_maxWidth+    , _style_maxHeight = pick _style_maxHeight+    , _style_alignHorizontal = pick _style_alignHorizontal+    , _style_alignVertical = pick _style_alignVertical+    , _style_whitespaceChar = pick _style_whitespaceChar+    , _style_transform = pick _style_transform+    , _style_tabWidth = pick _style_tabWidth+    , _style_marginBackground = pick _style_marginBackground+    , _style_inline = pick _style_inline+    , _style_colorWhitespace = pick _style_colorWhitespace+    , _style_borderTopForeground = pick _style_borderTopForeground+    , _style_borderTopBackground = pick _style_borderTopBackground+    , _style_borderBottomForeground = pick _style_borderBottomForeground+    , _style_borderBottomBackground = pick _style_borderBottomBackground+    , _style_borderLeftForeground = pick _style_borderLeftForeground+    , _style_borderLeftBackground = pick _style_borderLeftBackground+    , _style_borderRightForeground = pick _style_borderRightForeground+    , _style_borderRightBackground = pick _style_borderRightBackground+    }+  where+    pick :: forall a. (Style -> Maybe a) -> Maybe a+    pick f = case f child of+      Just x -> Just x+      Nothing -> f parent++inheritPadding :: Padding -> Padding -> Padding+inheritPadding parent child =+  Padding+    { _padding_top = nz (_padding_top child) (_padding_top parent)+    , _padding_right = nz (_padding_right child) (_padding_right parent)+    , _padding_bottom = nz (_padding_bottom child) (_padding_bottom parent)+    , _padding_left = nz (_padding_left child) (_padding_left parent)+    }+  where+    nz c p = if c /= 0 then c else p++inheritMargin :: Margin -> Margin -> Margin+inheritMargin parent child =+  Margin+    { _margin_top = nz (_margin_top child) (_margin_top parent)+    , _margin_right = nz (_margin_right child) (_margin_right parent)+    , _margin_bottom = nz (_margin_bottom child) (_margin_bottom parent)+    , _margin_left = nz (_margin_left child) (_margin_left parent)+    }+  where+    nz c p = if c /= 0 then c else p++----------------------------------------------------------------------------+-- Color constants (re-exported from vty for convenience)+----------------------------------------------------------------------------++black, red, green, yellow, blue, magenta, cyan, white :: Color+black = V.black+red = V.red+green = V.green+yellow = V.yellow+blue = V.blue+magenta = V.magenta+cyan = V.cyan+white = V.white++brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite :: Color+brightBlack = V.brightBlack+brightRed = V.brightRed+brightGreen = V.brightGreen+brightYellow = V.brightYellow+brightBlue = V.brightBlue+brightMagenta = V.brightMagenta+brightCyan = V.brightCyan+brightWhite = V.brightWhite++-- | Construct a true-color 'Color' from sRGB components. Unlike vty's+-- 'V.rgbColor' (which downsamples to the 256-color cube at construction), this+-- preserves the full 24-bit 'V.RGBColor' so the host can downsample once per+-- frame based on the detected 'Reflex.Vty.ColorProfile.ColorProfile'.+rgbColor :: Int -> Int -> Int -> Color+rgbColor = V.srgbColor++----------------------------------------------------------------------------+-- Border style presets+----------------------------------------------------------------------------++-- | Single-line box-drawing border: @┌─┐│┘─└│@.+singleBorder :: BorderStyle+singleBorder =+  BorderStyle+    (Just '─')+    (Just '─')+    (Just '│')+    (Just '│')+    (Just '┌')+    (Just '┐')+    (Just '└')+    (Just '┘')++-- | Rounded-corner single-line border: @╭─╮│╯─╰│@.+roundedBorder :: BorderStyle+roundedBorder =+  BorderStyle+    (Just '─')+    (Just '─')+    (Just '│')+    (Just '│')+    (Just '╭')+    (Just '╮')+    (Just '╰')+    (Just '╯')++-- | Thick single-line border: @┏━┓┃┛━┗┃@.+thickBorder :: BorderStyle+thickBorder =+  BorderStyle+    (Just '━')+    (Just '━')+    (Just '┃')+    (Just '┃')+    (Just '┏')+    (Just '┓')+    (Just '┗')+    (Just '┛')++-- | Double-line border: @╔═╗║╝═╚║@.+doubleBorder :: BorderStyle+doubleBorder =+  BorderStyle+    (Just '═')+    (Just '═')+    (Just '║')+    (Just '║')+    (Just '╔')+    (Just '╗')+    (Just '╚')+    (Just '╝')++-- | ASCII-only border using @-|+@.+asciiBorder :: BorderStyle+asciiBorder =+  BorderStyle+    (Just '-')+    (Just '-')+    (Just '|')+    (Just '|')+    (Just '+')+    (Just '+')+    (Just '+')+    (Just '+')++-- | Markdown-table border using @-|@ with no corners.+markdownBorder :: BorderStyle+markdownBorder =+  BorderStyle+    (Just '-')+    (Just '-')+    (Just '|')+    (Just '|')+    Nothing+    Nothing+    Nothing+    Nothing++-- | A border with all sides absent. Useful as a base to enable only+-- specific sides via 'withBorderTop' etc.+noBorder :: BorderStyle+noBorder = BorderStyle Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++-- | Inner half-block border using half-block characters: @▀▄▌▐@.+innerHalfBorder :: BorderStyle+innerHalfBorder =+  BorderStyle+    (Just '▀')+    (Just '▄')+    (Just '▌')+    (Just '▐')+    (Just '▀')+    (Just '▀')+    (Just '▄')+    (Just '▄')++-- | Outer half-block border using lower-eighth block characters: @▔▁@.+outerHalfBlockBorder :: BorderStyle+outerHalfBlockBorder =+  BorderStyle+    (Just '▔')+    (Just '▁')+    (Just '▏')+    (Just '▕')+    (Just '▔')+    (Just '▔')+    (Just '▁')+    (Just '▁')++----------------------------------------------------------------------------+-- Setters+----------------------------------------------------------------------------++withForeground :: Color -> Style -> Style+withForeground c s = s {_style_foreground = Just c}++withBackground :: Color -> Style -> Style+withBackground c s = s {_style_background = Just c}++withBold :: Style -> Style+withBold s = s {_style_bold = Just True}++withItalic :: Style -> Style+withItalic s = s {_style_italic = Just True}++withFaint :: Style -> Style+withFaint s = s {_style_faint = Just True}++withBlink :: Style -> Style+withBlink s = s {_style_blink = Just True}++withStrikethrough :: Style -> Style+withStrikethrough s = s {_style_strikethrough = Just True}++withReverse :: Style -> Style+withReverse s = s {_style_reverse = Just True}++withUnderline :: UnderlineStyle -> Style -> Style+withUnderline u s = s {_style_underline = Just u}++withUnderlineColor :: Color -> Style -> Style+withUnderlineColor c s = s {_style_underlineColor = Just c}++withHyperlink :: Text -> Style -> Style+withHyperlink url s = s {_style_hyperlink = Just url}++withPadding :: Int -> Int -> Int -> Int -> Style -> Style+withPadding t r b l s = s {_style_padding = Padding t r b l}++withPaddingTop :: Int -> Style -> Style+withPaddingTop n s = s {_style_padding = (_style_padding s) {_padding_top = n}}++withPaddingRight :: Int -> Style -> Style+withPaddingRight n s = s {_style_padding = (_style_padding s) {_padding_right = n}}++withPaddingBottom :: Int -> Style -> Style+withPaddingBottom n s = s {_style_padding = (_style_padding s) {_padding_bottom = n}}++withPaddingLeft :: Int -> Style -> Style+withPaddingLeft n s = s {_style_padding = (_style_padding s) {_padding_left = n}}++withMargin :: Int -> Int -> Int -> Int -> Style -> Style+withMargin t r b l s = s {_style_margin = Margin t r b l}++withMarginTop :: Int -> Style -> Style+withMarginTop n s = s {_style_margin = (_style_margin s) {_margin_top = n}}++withMarginRight :: Int -> Style -> Style+withMarginRight n s = s {_style_margin = (_style_margin s) {_margin_right = n}}++withMarginBottom :: Int -> Style -> Style+withMarginBottom n s = s {_style_margin = (_style_margin s) {_margin_bottom = n}}++withMarginLeft :: Int -> Style -> Style+withMarginLeft n s = s {_style_margin = (_style_margin s) {_margin_left = n}}++withBorder :: BorderStyle -> Style -> Style+withBorder b s = s {_style_border = Just b}++withBorderForeground :: Color -> Style -> Style+withBorderForeground c s = s {_style_borderForeground = Just c}++withBorderBackground :: Color -> Style -> Style+withBorderBackground c s = s {_style_borderBackground = Just c}++withBorderTop :: Bool -> Style -> Style+withBorderTop b s = s {_style_borderTop = Just b}++withBorderBottom :: Bool -> Style -> Style+withBorderBottom b s = s {_style_borderBottom = Just b}++withBorderLeft :: Bool -> Style -> Style+withBorderLeft b s = s {_style_borderLeft = Just b}++withBorderRight :: Bool -> Style -> Style+withBorderRight b s = s {_style_borderRight = Just b}++withWidth :: Int -> Style -> Style+withWidth n s = s {_style_width = Just n}++withHeight :: Int -> Style -> Style+withHeight n s = s {_style_height = Just n}++withMaxWidth :: Int -> Style -> Style+withMaxWidth n s = s {_style_maxWidth = Just n}++withMaxHeight :: Int -> Style -> Style+withMaxHeight n s = s {_style_maxHeight = Just n}++withAlignH :: HAlign -> Style -> Style+withAlignH a s = s {_style_alignHorizontal = Just a}++withAlignV :: VAlign -> Style -> Style+withAlignV a s = s {_style_alignVertical = Just a}++withWhitespace :: Char -> Style -> Style+withWhitespace c s = s {_style_whitespaceChar = Just c}++withTransform :: (Text -> Text) -> Style -> Style+withTransform fn s = s {_style_transform = Just fn}++withTabWidth :: Int -> Style -> Style+withTabWidth w s = s {_style_tabWidth = Just w}++withMarginBackground :: Color -> Style -> Style+withMarginBackground c s = s {_style_marginBackground = Just c}++withInline :: Bool -> Style -> Style+withInline b s = s {_style_inline = Just b}++withColorWhitespace :: Bool -> Style -> Style+withColorWhitespace b s = s {_style_colorWhitespace = Just b}++withBorderTopForeground :: Color -> Style -> Style+withBorderTopForeground c s = s {_style_borderTopForeground = Just c}++withBorderTopBackground :: Color -> Style -> Style+withBorderTopBackground c s = s {_style_borderTopBackground = Just c}++withBorderBottomForeground :: Color -> Style -> Style+withBorderBottomForeground c s = s {_style_borderBottomForeground = Just c}++withBorderBottomBackground :: Color -> Style -> Style+withBorderBottomBackground c s = s {_style_borderBottomBackground = Just c}++withBorderLeftForeground :: Color -> Style -> Style+withBorderLeftForeground c s = s {_style_borderLeftForeground = Just c}++withBorderLeftBackground :: Color -> Style -> Style+withBorderLeftBackground c s = s {_style_borderLeftBackground = Just c}++withBorderRightForeground :: Color -> Style -> Style+withBorderRightForeground c s = s {_style_borderRightForeground = Just c}++withBorderRightBackground :: Color -> Style -> Style+withBorderRightBackground c s = s {_style_borderRightBackground = Just c}++----------------------------------------------------------------------------+-- Rendering+----------------------------------------------------------------------------++-- | An attr where every field is 'V.KeepCurrent', so painted cells inherit+-- the underlying layer's value for any attribute the 'Style' doesn't+-- explicitly set. Used as the base for 'render' so themed backgrounds+-- show through where the 'Style' has no explicit color.+transparentAttr :: V.Attr+transparentAttr =+  V.Attr+    { V.attrStyle = V.KeepCurrent+    , V.attrForeColor = V.KeepCurrent+    , V.attrBackColor = V.KeepCurrent+    , V.attrURL = V.KeepCurrent+    }++-- | Merge the color and text-transform fields of a 'Style' onto an+-- existing 'V.Attr'. Fields that are 'Nothing' in the 'Style' are left+-- unchanged (the existing 'V.Attr' value is kept). Padding, margin,+-- border, dimensions, and alignment are not handled here: those are+-- layout concerns handled by 'render'. This is used by widgets that want+-- to layer a 'Style' on top of the ambient 'HasTheme' attribute.+applyAttr :: Style -> V.Attr -> V.Attr+applyAttr s attr0 =+  applyUnderline $+    applyHyperlink $+      applyReverse $+        applyStrikethrough $+          applyBlink $+            applyFaint $+              applyItalic $+                applyBold $+                  applyBackground $+                    applyForeground attr0+  where+    applyForeground a = maybe a (V.withForeColor a) (_style_foreground s)+    applyBackground a = maybe a (V.withBackColor a) (_style_background s)+    applyFlag field st a = case field s of+      Just True -> V.withStyle a st+      _ -> a+    applyBold = applyFlag _style_bold V.bold+    applyItalic = applyFlag _style_italic V.italic+    applyFaint = applyFlag _style_faint V.dim+    applyBlink = applyFlag _style_blink V.blink+    applyStrikethrough = applyFlag _style_strikethrough V.strikethrough+    applyReverse = applyFlag _style_reverse V.reverseVideo+    applyUnderline a = case _style_underline s of+      Nothing -> a+      Just UnderlineNone -> a+      Just _ -> V.withStyle a V.underline+    applyHyperlink a = maybe a (V.withURL a) (_style_hyperlink s)++-- | Overlay one 'V.Attr' on top of another. Fields in the overlay that+-- are 'V.SetTo' take precedence; 'V.Default' and 'V.KeepCurrent' fall+-- through to the base. Used by 'Reflex.Vty.Widget.Text.richText' to layer+-- custom attributes on top of the ambient theme attr, so that unset fields+-- inherit the theme rather than falling back to terminal defaults.+mergeAttr :: V.Attr -> V.Attr -> V.Attr+mergeAttr base overlay =+  V.Attr+    { V.attrStyle = pick (V.attrStyle base) (V.attrStyle overlay)+    , V.attrForeColor = pick (V.attrForeColor base) (V.attrForeColor overlay)+    , V.attrBackColor = pick (V.attrBackColor base) (V.attrBackColor overlay)+    , V.attrURL = pick (V.attrURL base) (V.attrURL overlay)+    }+  where+    pick _ (V.SetTo v) = V.SetTo v+    pick b _ = b++-- | Render some 'Text' with a 'Style' to a vty 'V.Image'. Applies text+-- transforms and colors (via 'applyAttr'), pads and aligns the content,+-- draws the border, applies margin, and finally enforces width/height+-- minimums and max-width/max-height clipping.+render :: Style -> Text -> V.Image+render s content =+  if fromMaybe False (_style_inline s)+    then applyMaxSize contentImage+    else applyMaxSize $ applySize $ applyMargin $ applyBorder $ applyPadding $ contentImage+  where+    ws = fromMaybe ' ' (_style_whitespaceChar s)+    -- Use KeepCurrent for all unset attrs so underlying layers (e.g. the+    -- themed fill) show through where the Style doesn't explicitly set a+    -- color or style.+    baseAttr = applyAttr s transparentAttr+    -- Attr for whitespace fills: use transparent when colorWhitespace is False.+    fillAttr = if fromMaybe True (_style_colorWhitespace s) then baseAttr else transparentAttr+    -- Per-side border attrs, falling back to the generic border fg/bg,+    -- layered on top of the content attr.+    borderAttrTop = applyAttr (borderSideStyle (_style_borderTopForeground s) (_style_borderTopBackground s)) baseAttr+    borderAttrBottom = applyAttr (borderSideStyle (_style_borderBottomForeground s) (_style_borderBottomBackground s)) baseAttr+    borderAttrLeft = applyAttr (borderSideStyle (_style_borderLeftForeground s) (_style_borderLeftBackground s)) baseAttr+    borderAttrRight = applyAttr (borderSideStyle (_style_borderRightForeground s) (_style_borderRightBackground s)) baseAttr+    borderSideStyle perSideFg perSideBg =+      def+        { _style_foreground = perSideFg <|> _style_borderForeground s+        , _style_background = perSideBg <|> _style_borderBackground s+        }+    -- Render text with newlines+    contentImage = V.vertCat $ map (V.text' baseAttr) (T.split (== '\n') processedContent)+    processedContent = expandTabs $ case _style_transform s of+      Just fn -> fn content+      Nothing -> content+    expandTabs txt = case _style_tabWidth s of+      Just w -> T.replace "\t" (T.replicate w " ") txt+      Nothing -> txt+    -- Whitespace fill of a given width/height using the whitespace char.+    fillImage :: V.Attr -> Int -> Int -> V.Image+    fillImage a w h+      | w <= 0 || h <= 0 = V.emptyImage+      | otherwise = V.charFill a ws w h+    -- Horizontal alignment of an image within a width.+    placeH :: V.Attr -> Int -> V.Image -> V.Image+    placeH a w img+      | imgW >= w = img+      | otherwise = V.horizCat [leftPad, img, rightPad]+      where+        imgW = V.imageWidth img+        imgH = V.imageHeight img+        slack = w - imgW+        leftPad = case fromMaybe HAlignLeft (_style_alignHorizontal s) of+          HAlignLeft -> V.emptyImage+          HAlignCenter -> fillImage a (slack `div` 2) imgH+          HAlignRight -> fillImage a slack imgH+        rightPad = case fromMaybe HAlignLeft (_style_alignHorizontal s) of+          HAlignLeft -> fillImage a slack imgH+          HAlignCenter -> fillImage a (slack - slack `div` 2) imgH+          HAlignRight -> V.emptyImage+    -- Vertical alignment of an image within a height.+    placeV :: V.Attr -> Int -> V.Image -> V.Image+    placeV a h img+      | imgH >= h = img+      | otherwise = V.vertCat [topPad, img, bottomPad]+      where+        imgH = V.imageHeight img+        imgW = V.imageWidth img+        slack = h - imgH+        topPad = case fromMaybe VAlignTop (_style_alignVertical s) of+          VAlignTop -> V.emptyImage+          VAlignMiddle -> fillImage a imgW (slack `div` 2)+          VAlignBottom -> fillImage a imgW slack+        bottomPad = case fromMaybe VAlignTop (_style_alignVertical s) of+          VAlignTop -> fillImage a imgW slack+          VAlignMiddle -> fillImage a imgW (slack - slack `div` 2)+          VAlignBottom -> V.emptyImage+    -- Width/height minimums: pad the image out to the requested size.+    applySize img =+      let w = fromMaybe (V.imageWidth img) (_style_width s)+          h = fromMaybe (V.imageHeight img) (_style_height s)+          img' =+            if V.imageWidth img < w+              then placeH fillAttr w img+              else img+          img'' =+            if V.imageHeight img' < h+              then placeV fillAttr h img'+              else img'+      in img''+    -- Padding.+    applyPadding img =+      let p = _style_padding s+          top = fillImage fillAttr (innerW img) (_padding_top p)+          bottom = fillImage fillAttr (innerW img) (_padding_bottom p)+          left = fillImage fillAttr (_padding_left p) (innerH img)+          right = fillImage fillAttr (_padding_right p) (innerH img)+          innerW = V.imageWidth+          innerH = V.imageHeight+      in V.vertCat+           [ top+           , V.horizCat [left, img, right]+           , bottom+           ]+    -- Border.+    applyBorder img =+      case _style_border s of+        Nothing -> img+        Just b ->+          drawBorder+            borderAttrTop+            borderAttrBottom+            borderAttrLeft+            borderAttrRight+            b+            (_style_borderTop s)+            (_style_borderBottom s)+            (_style_borderLeft s)+            (_style_borderRight s)+            img+    -- Margin. Uses colored fill when _style_marginBackground is set,+    -- otherwise transparent pad so underlying layers show through.+    applyMargin img =+      let m = _style_margin s+      in case _style_marginBackground s of+           Nothing -> V.pad (_margin_left m) (_margin_top m) (_margin_right m) (_margin_bottom m) img+           Just _ ->+             let marginAttr = applyAttr (borderStyleAttr s {_style_border = Nothing, _style_borderForeground = _style_marginBackground s}) baseAttr+                 w = V.imageWidth img+                 h = V.imageHeight img+                 leftPad = fillImage marginAttr (_margin_left m) h+                 rightPad = fillImage marginAttr (_margin_right m) h+                 topW = w + _margin_left m + _margin_right m+                 topPad = fillImage marginAttr topW (_margin_top m)+                 bottomPad = fillImage marginAttr topW (_margin_bottom m)+             in V.vertCat [topPad, V.horizCat [leftPad, img, rightPad], bottomPad]+    -- Max-width / max-height clipping.+    applyMaxSize img =+      let clipW = maybe img (\w -> V.crop w (V.imageHeight img) img) (_style_maxWidth s)+          clipH = maybe clipW (\h -> V.crop (V.imageWidth clipW) h clipW) (_style_maxHeight s)+      in clipH++-- | A 'Style' that carries only the border color fields, for use as the+-- 'V.Attr' when drawing border characters.+borderStyleAttr :: Style -> Style+borderStyleAttr s =+  def+    { _style_foreground = _style_borderForeground s+    , _style_background = _style_borderBackground s+    }++-- | Draw a border around an image, respecting per-side toggles. A side is+-- drawn when the 'BorderStyle' has a character for it and the+-- per-side toggle (if set) is 'True'. When a side's toggle is 'Nothing',+-- the side is drawn iff the 'BorderStyle' defines it. Corners are drawn+-- when both adjacent sides are present and the 'BorderStyle' defines the+-- corner.+drawBorder+  :: V.Attr+  -- ^ top attr+  -> V.Attr+  -- ^ bottom attr+  -> V.Attr+  -- ^ left attr+  -> V.Attr+  -- ^ right attr+  -> BorderStyle+  -> Maybe Bool+  -- ^ top toggle+  -> Maybe Bool+  -- ^ bottom toggle+  -> Maybe Bool+  -- ^ left toggle+  -> Maybe Bool+  -- ^ right toggle+  -> V.Image+  -> V.Image+drawBorder topA bottomA leftA rightA b mTop mBot mLeft mRight img =+  V.vertCat [topRow, middleRow, bottomRow]+  where+    w = V.imageWidth img+    topOn = sideOn _border_top mTop+    bottomOn = sideOn _border_bottom mBot+    leftOn = sideOn _border_left mLeft+    rightOn = sideOn _border_right mRight+    sideOn f mt = maybe (isJust (f b)) id mt+    hFillTop c n = V.charFill topA c (max 0 n) 1+    hFillBottom c n = V.charFill bottomA c (max 0 n) 1+    vFillLeft c n = V.charFill leftA c 1 (max 0 n)+    vFillRight c n = V.charFill rightA c 1 (max 0 n)+    topChar = _border_top b >>= \c -> if topOn then Just c else Nothing+    bottomChar = _border_bottom b >>= \c -> if bottomOn then Just c else Nothing+    leftChar = _border_left b >>= \c -> if leftOn then Just c else Nothing+    rightChar = _border_right b >>= \c -> if rightOn then Just c else Nothing+    topLeftChar = _border_topLeft b >>= \c -> if topOn && leftOn then Just (V.char topA c) else Nothing+    topRightChar = _border_topRight b >>= \c -> if topOn && rightOn then Just (V.char topA c) else Nothing+    bottomLeftChar = _border_bottomLeft b >>= \c -> if bottomOn && leftOn then Just (V.char bottomA c) else Nothing+    bottomRightChar = _border_bottomRight b >>= \c -> if bottomOn && rightOn then Just (V.char bottomA c) else Nothing+    topRow =+      V.horizCat $+        maybe [] (: []) topLeftChar+          ++ maybe [] (\c -> [hFillTop c w]) topChar+          ++ maybe [] (: []) topRightChar+    middleRow =+      V.horizCat $+        maybe [] (\c -> [vFillLeft c (V.imageHeight img)]) leftChar+          ++ [img]+          ++ maybe [] (\c -> [vFillRight c (V.imageHeight img)]) rightChar+    bottomRow =+      V.horizCat $+        maybe [] (: []) bottomLeftChar+          ++ maybe [] (\c -> [hFillBottom c w]) bottomChar+          ++ maybe [] (: []) bottomRightChar++-- | Reactive variant of 'render' for the common widget case.+renderB :: Reflex t => Behavior t Style -> Behavior t Text -> Behavior t V.Image+renderB bs bt = render <$> bs <*> bt++-- | The width and height (in terminal cells) that 'render' will produce+-- for the given 'Style' and 'Text', /before/ max-width/max-height+-- clipping. Useful for layout-sensitive widgets that need to measure+-- before rendering.+measure :: Style -> Text -> (Int, Int)+measure s content =+  (totalW, totalH)+  where+    contentLines = T.split (== '\n') processedContent+    processedContent = case _style_tabWidth s of+      Just w -> T.replace "\t" (T.replicate w " ") $ case _style_transform s of+        Just fn -> fn content+        Nothing -> content+      Nothing -> case _style_transform s of+        Just fn -> fn content+        Nothing -> content+    contentW = maximum (0 : map textWidth contentLines)+    contentH = length contentLines+    p = _style_padding s+    m = _style_margin s+    borderWidth = if hasBorder then 2 else 0+    borderHeight = if hasBorder then 2 else 0+    hasBorder =+      maybe False (const True) (_style_border s)+        || any+          id+          [ fromMaybe False (_style_borderTop s)+          , fromMaybe False (_style_borderBottom s)+          , fromMaybe False (_style_borderLeft s)+          , fromMaybe False (_style_borderRight s)+          ]+    minW = fromMaybe 0 (_style_width s)+    minH = fromMaybe 0 (_style_height s)+    innerW = max minW contentW + _padding_left p + _padding_right p+    innerH = max minH contentH + _padding_top p + _padding_bottom p+    totalW = innerW + borderWidth + _margin_left m + _margin_right m+    totalH = innerH + borderHeight + _margin_top m + _margin_bottom m++----------------------------------------------------------------------------+-- Image composition+----------------------------------------------------------------------------++-- | Join images horizontally, aligning them vertically by the given+-- 'VAlign'. Shorter images are padded with spaces to match the tallest.+joinHorizontal :: VAlign -> [V.Image] -> V.Image+joinHorizontal _ [] = V.emptyImage+joinHorizontal align imgs = V.horizCat (map pad imgs)+  where+    maxH = maximum (map V.imageHeight imgs)+    pad img = placeVertical align maxH img++-- | Join images vertically, aligning them horizontally by the given+-- 'HAlign'. Narrower images are padded with spaces to match the widest.+joinVertical :: HAlign -> [V.Image] -> V.Image+joinVertical _ [] = V.emptyImage+joinVertical align imgs = V.vertCat (map pad imgs)+  where+    maxW = maximum (map V.imageWidth imgs)+    pad img = placeHorizontal align maxW img++-- | Place an image within a target width, horizontally aligned.+-- Pads with spaces on the appropriate side(s).+placeHorizontal :: HAlign -> Int -> V.Image -> V.Image+placeHorizontal align targetW img+  | imgW >= targetW = img+  | otherwise = V.horizCat [leftPad, img, rightPad]+  where+    imgW = V.imageWidth img+    slack = targetW - imgW+    (leftW, rightW) = case align of+      HAlignLeft -> (0, slack)+      HAlignCenter -> (slack `div` 2, slack - slack `div` 2)+      HAlignRight -> (slack, 0)+    leftPad = padImg leftW (V.imageHeight img)+    rightPad = padImg rightW (V.imageHeight img)++-- | Place an image within a target height, vertically aligned.+-- Pads with spaces above and/or below.+placeVertical :: VAlign -> Int -> V.Image -> V.Image+placeVertical align targetH img+  | imgH >= targetH = img+  | otherwise = V.vertCat [topPad, img, bottomPad]+  where+    imgH = V.imageHeight img+    slack = targetH - imgH+    (topH, bottomH) = case align of+      VAlignTop -> (0, slack)+      VAlignMiddle -> (slack `div` 2, slack - slack `div` 2)+      VAlignBottom -> (slack, 0)+    topPad = padImg (V.imageWidth img) topH+    bottomPad = padImg (V.imageWidth img) bottomH++-- | Place an image within a target @(width, height)@ with both+-- horizontal and vertical alignment.+place :: HAlign -> VAlign -> Int -> Int -> V.Image -> V.Image+place hAlign vAlign targetW targetH =+  placeHorizontal hAlign targetW . placeVertical vAlign targetH++padImg :: Int -> Int -> V.Image+padImg w h+  | w <= 0 || h <= 0 = V.emptyImage+  | otherwise = V.charFill V.defAttr ' ' w h++----------------------------------------------------------------------------+-- Text utilities+----------------------------------------------------------------------------++-- | Truncate text to fit within a display width, using the given+-- character as an ellipsis if truncation is needed. Wide characters+-- are handled correctly via 'textWidth'.+truncateWith :: Char -> Int -> Text -> Text+truncateWith ellipsis maxWidth txt+  | textWidth txt <= maxWidth = txt+  | maxWidth <= 0 = ""+  | otherwise = takeToWidth (maxWidth - charWidth ellipsis) txt <> T.singleton ellipsis++-- | Number of lines in the text (counting newlines + 1).+textHeight :: Text -> Int+textHeight = length . T.split (== '\n')++-- | Display width and height of the text.+textSize :: Text -> (Int, Int)+textSize txt = (maximum (0 : map textWidth (T.split (== '\n') txt)), textHeight txt)++----------------------------------------------------------------------------+-- Internal helpers for truncateWith+----------------------------------------------------------------------------++takeToWidth :: Int -> Text -> Text+takeToWidth targetW txt = go 0 (T.unpack txt)+  where+    go _ [] = ""+    go w (c : cs)+      | w >= targetW = ""+      | w + cw > targetW = ""+      | otherwise = T.singleton c <> go (w + cw) cs+      where+        cw = max 1 (charWidth c)
+ src/Reflex/Vty/Theme.hs view
@@ -0,0 +1,131 @@+-- |+-- Module: Reflex.Vty.Theme+-- Description: Structured theme record for reflex-vty widgets+--+-- A 'Theme' is a record of 'Style's for each part of the UI. 'HasTheme' delivers+-- the ambient 'Theme' to widgets; 'localTheme' overrides it for a subtree.+module Reflex.Vty.Theme+  ( Theme (..)+  , defTheme+  , darkTheme+  , charmTheme+  , draculaTheme+  , nordTheme+  , zenburnTheme+  , gruvboxTheme+  , themeToAttr+  ) where++import Data.Default (Default (..))+import qualified Graphics.Vty as V+import Reflex (Behavior, Reflex)++import Reflex.Vty.Style++-- | A structured theme: one 'Style' per UI element.+data Theme = Theme+  { _theme_default :: Style+  , _theme_border :: Style+  , _theme_title :: Style+  , _theme_link :: Style+  , _theme_buttonFocused :: Style+  , _theme_buttonUnfocused :: Style+  , _theme_checkbox :: Style+  , _theme_textInput :: Style+  , _theme_textInputCursor :: Style+  }++instance Default Theme where+  def = defTheme++-- | The default theme: no colors, no transforms, links underlined.+defTheme :: Theme+defTheme =+  Theme+    { _theme_default = def+    , _theme_border = def+    , _theme_title = withBold def+    , _theme_link = withUnderline UnderlineSingle def+    , _theme_buttonFocused = def+    , _theme_buttonUnfocused = def+    , _theme_checkbox = def+    , _theme_textInput = def+    , _theme_textInputCursor = withReverse def+    }++-- | A dark-background theme matching the legacy @darkTheme :: V.Attr@.+darkTheme :: Theme+darkTheme =+  defTheme+    { _theme_default = withForeground green . withBackground black $ def+    }++-- | The Charm theme: magenta/purple accents on a dark background.+charmTheme :: Theme+charmTheme =+  defTheme+    { _theme_default = withForeground white . withBackground (rgbColor 22 18 30) $ def+    , _theme_border = withForeground magenta def+    , _theme_title = withForeground magenta . withBold $ def+    , _theme_link = withForeground magenta . withUnderline UnderlineSingle $ def+    , _theme_buttonFocused = withForeground magenta . withBold $ def+    , _theme_buttonUnfocused = withForeground white def+    , _theme_textInputCursor = withReverse def+    }++-- | The Dracula theme: pink/cyan/green on a dark background.+draculaTheme :: Theme+draculaTheme =+  defTheme+    { _theme_default = withForeground white . withBackground (rgbColor 40 42 54) $ def+    , _theme_border = withForeground (rgbColor 98 114 164) def+    , _theme_title = withForeground (rgbColor 255 184 108) . withBold $ def+    , _theme_link = withForeground (rgbColor 139 233 253) . withUnderline UnderlineSingle $ def+    , _theme_buttonFocused = withForeground (rgbColor 189 147 249) . withBold $ def+    , _theme_buttonUnfocused = withForeground white def+    , _theme_textInputCursor = withReverse def+    }++-- | The Nord theme: blues and cool greys on a dark slate background.+nordTheme :: Theme+nordTheme =+  defTheme+    { _theme_default = withForeground (rgbColor 216 222 233) . withBackground (rgbColor 46 52 64) $ def+    , _theme_border = withForeground (rgbColor 76 86 106) def+    , _theme_title = withForeground (rgbColor 136 192 208) . withBold $ def+    , _theme_link = withForeground (rgbColor 143 188 187) . withUnderline UnderlineSingle $ def+    , _theme_buttonFocused = withForeground (rgbColor 136 192 208) . withBold $ def+    , _theme_buttonUnfocused = withForeground (rgbColor 216 222 233) def+    , _theme_textInputCursor = withReverse def+    }++-- | The Zenburn theme: muted greens and warm browns on a dark background.+zenburnTheme :: Theme+zenburnTheme =+  defTheme+    { _theme_default = withForeground (rgbColor 220 220 204) . withBackground (rgbColor 64 64 64) $ def+    , _theme_border = withForeground (rgbColor 102 153 153) def+    , _theme_title = withForeground (rgbColor 233 233 191) . withBold $ def+    , _theme_link = withForeground (rgbColor 159 159 95) . withUnderline UnderlineSingle $ def+    , _theme_buttonFocused = withForeground (rgbColor 159 159 95) . withBold $ def+    , _theme_buttonUnfocused = withForeground (rgbColor 220 220 204) def+    , _theme_textInputCursor = withReverse def+    }++-- | The Gruvbox theme: warm earthy tones on a dark background.+gruvboxTheme :: Theme+gruvboxTheme =+  defTheme+    { _theme_default = withForeground (rgbColor 235 219 178) . withBackground (rgbColor 40 40 40) $ def+    , _theme_border = withForeground (rgbColor 152 151 26) def+    , _theme_title = withForeground (rgbColor 250 189 47) . withBold $ def+    , _theme_link = withForeground (rgbColor 131 165 152) . withUnderline UnderlineSingle $ def+    , _theme_buttonFocused = withForeground (rgbColor 214 93 14) . withBold $ def+    , _theme_buttonUnfocused = withForeground (rgbColor 235 219 178) def+    , _theme_textInputCursor = withReverse def+    }++-- | Convenience: extract the ambient 'V.Attr' from the theme's+-- '_theme_default' 'Style'. Most widgets only need this.+themeToAttr :: Reflex t => Behavior t Theme -> Behavior t V.Attr+themeToAttr = fmap (flip applyAttr V.defAttr . _theme_default)
src/Reflex/Vty/Widget.hs view
@@ -1,64 +1,97 @@-{-|-Module: Reflex.Vty.Widget-Description: Basic set of widgets and building blocks for reflex-vty applications--}-{-# Language UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} +-- |+-- Module: Reflex.Vty.Widget+-- Description: Basic set of widgets and building blocks for reflex-vty applications module Reflex.Vty.Widget where -import Control.Applicative (liftA2)-import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor(..))-import Control.Monad.NodeId-import Control.Monad.Reader (ReaderT, ask, local, runReaderT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Morph (MFunctor (..))+import Control.Monad.Reader (ReaderT (..), ask, local, runReaderT) import Control.Monad.Ref import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.State.Strict+import qualified Data.ByteString as BS+import Data.Default (Default (..))+import Data.Kind (Type)+import Data.Semigroup (Last (..)) import Data.Set (Set) import qualified Data.Set as Set import Graphics.Vty (Image) import qualified Graphics.Vty as V import Reflex import Reflex.Class ()-import Reflex.Host.Class (MonadReflexCreateTrigger)+import Reflex.Host.Class++import Control.Monad.NodeId+import Reflex.Vty.ColorProfile import Reflex.Vty.Host+import Reflex.Vty.Theme (Theme (..), defTheme, themeToAttr)  -- * Running a vty application  -- | Sets up the top-level context for a vty widget and runs it with that context mainWidgetWithHandle-  :: V.Vty-  -> (forall t m.-      ( MonadVtyApp t m-      , HasImageWriter t m-      , MonadNodeId m-      , HasDisplayRegion t m-      , HasFocusReader t m-      , HasInput t m-      , HasTheme t m-      ) => m (Event t ()))+  :: VtyAppConfig+  -> V.Vty+  -> ( forall t m+        . ( MonadVtyApp t m+          , HasImageWriter t m+          , MonadNodeId m+          , HasDisplayRegion t m+          , HasFocusReader t m+          , HasInput t m+          , HasTheme t m+          , HasColorProfile t m+          , HasCursor t m+          , HasScreenMode t m+          )+       => m (Event t ())+     )   -> IO ()-mainWidgetWithHandle vty child =-  runVtyAppWithHandle vty $ \dr0 inp -> do-    size <- holdDyn dr0 $ fforMaybe inp $ \case-      V.EvResize w h -> Just (w, h)-      _ -> Nothing+mainWidgetWithHandle cfg vty child =+  runVtyAppWithHandle cfg vty $ \dr0 inp _sigs -> do+    let profile = colorProfileFromVty vty+    let resizeRaw = fforMaybe inp $ \case+          V.EvResize w h -> Just (w, h)+          _ -> Nothing+    resizeDebounced <- debounce 0.05 resizeRaw+    size <- holdDyn dr0 resizeDebounced     let inp' = fforMaybe inp $ \case           V.EvResize {} -> Nothing           x -> Just x-    (shutdown, images) <- runThemeReader (constant V.defAttr) $-      runFocusReader (pure True) $-        runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $-          runImageWriter $-            runNodeIdT $-              runInput inp' $ do-                tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]-                child-    return $ VtyResult-      { _vtyResult_picture = fmap (V.picForLayers . reverse) images-      , _vtyResult_shutdown = shutdown-      }+    (((shutdown, images), cursorUpdates), screenModeUpdates) <- runThemeReader (constant defTheme) $+      runColorProfileReader (constant profile) $+        runFocusReader (pure True) $+          runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $+            runScreenModeWriter $+              runCursorWriter $+                runImageWriter $+                  runNodeIdT $+                    runInput inp' $ do+                      tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]+                      child+    let cursorStates = getLast <$> cursorUpdates+    cursorState <- holdDyn defaultCursorState cursorStates+    performEvent_ $ ffor cursorStates $ \st ->+      liftIO $ setCursorStyle (V.outputIface vty) (_cursorState_style st)+    performEvent_ $ ffor (getLast <$> screenModeUpdates) $ \mode ->+      liftIO $ setScreenMode (V.outputIface vty) mode+    return $+      VtyResult+        { _vtyResult_picture = makePicture <$> current cursorState <*> images+        , _vtyResult_shutdown = shutdown+        }+  where+    makePicture cursorState layers =+      (V.picForLayers $ reverse layers)+        { V.picCursor = cursorStateToVtyCursor cursorState+        }  -- | The output of a vty widget data VtyWidgetOut t = VtyWidgetOut@@ -67,19 +100,25 @@  -- | Like 'mainWidgetWithHandle', but uses a default vty configuration mainWidget-  :: (forall t m.-      ( MonadVtyApp t m-      , HasImageWriter t m-      , MonadNodeId m-      , HasDisplayRegion t m-      , HasFocusReader t m-      , HasTheme t m-      , HasInput t m-      ) => m (Event t ()))+  :: VtyAppConfig+  -> ( forall t m+        . ( MonadVtyApp t m+          , HasImageWriter t m+          , MonadNodeId m+          , HasDisplayRegion t m+          , HasFocusReader t m+          , HasTheme t m+          , HasColorProfile t m+          , HasInput t m+          , HasCursor t m+          , HasScreenMode t m+          )+       => m (Event t ())+     )   -> IO ()-mainWidget child = do+mainWidget cfg child = do   vty <- getDefaultVty-  mainWidgetWithHandle vty child+  mainWidgetWithHandle cfg vty child  -- * Input Events @@ -88,8 +127,9 @@   input :: m (Event t VtyEvent)   default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)   input = lift input+   -- | User input events that the widget's parent chooses to share. These will generally-  -- be filtered for relevance.+  --   be filtered for relevance.   localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a   default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a   localInput f = hoist (localInput f)@@ -101,24 +141,26 @@ -- | A widget that can receive input events. See 'Graphics.Vty.Event' newtype Input t m a = Input   { unInput :: ReaderT (Event t VtyEvent) m a-  } deriving-    ( Functor-    , Applicative+  }+  deriving+    ( Applicative+    , Functor     , Monad-    , MonadSample t-    , MonadHold t+    , MonadCatch     , MonadFix+    , MonadHold t     , MonadIO+    , MonadMask     , MonadRef-    , MonadCatch+    , MonadSample t     , MonadThrow-    , MonadMask     )  instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where   runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a'-  traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $-    traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'+  traverseIntMapWithKeyWithAdjust f dm0 dm' =+    Input $+      traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'   traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do     traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'   traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do@@ -129,7 +171,10 @@ deriving instance PerformEvent t m => PerformEvent t (Input t m) deriving instance PostBuild t m => PostBuild t (Input t m) deriving instance TriggerEvent t m => TriggerEvent t (Input t m)-instance HasImageWriter t m => HasImageWriter t (Input t m)+instance HasImageWriter t m => HasImageWriter t (Input t m) where+  captureImages x = do+    a <- input+    lift $ captureImages $ runInput a x instance HasDisplayRegion t m => HasDisplayRegion t (Input t m) instance HasFocusReader t m => HasFocusReader t (Input t m) @@ -177,16 +222,23 @@ keyCombos ks = do   i <- input   return $ fforMaybe i $ \case-    V.EvKey k m -> if Set.member (k, m) ks-      then Just (k, m)-      else Nothing+    V.EvKey k m ->+      if Set.member (k, m) ks+        then Just (k, m)+        else Nothing     _ -> Nothing  -- | Filter the keyboard input that a child widget may receive filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a-filterKeys f x = localInput (ffilter (\case-  V.EvKey k mods -> f (k, mods)-  _ -> True)) x+filterKeys f x =+  localInput+    ( ffilter+        ( \case+            V.EvKey k mods -> f (k, mods)+            _ -> True+        )+    )+    x  -- | Filter mouse input events based on whether they target a particular region -- and translate them to the internal coordinate system of that region.@@ -199,18 +251,21 @@   _ -> Just e   where     mouse con x y-      | or [ x < l-           , y < t-           , x >= l + w-           , y >= t + h ] = Nothing+      | or+          [ x < l+          , y < t+          , x >= l + w+          , y >= t + h+          ] =+          Nothing       | otherwise =-        Just (con (x - l) (y - t))+          Just (con (x - l) (y - t))  -- | -- * 'Tracking' state means actively tracking the current stream of mouse events -- * 'NotTracking' state means not tracking the current stream of mouse events -- * 'WaitingForInput' means state will be set on next 'EvMouseDown' event-data MouseTrackingState = Tracking V.Button | NotTracking | WaitingForInput deriving (Show, Eq)+data MouseTrackingState = Tracking V.Button | NotTracking | WaitingForInput deriving (Eq, Show)  -- | Filter mouse input outside the current display region -- keyboard input is reported only if the region is focused@@ -219,50 +274,77 @@ -- EXCEPT mouse drag sequences that start OFF the region are NOT reported -- AND mouse drag sequences that start ON the region and drag off ARE reported inputInFocusedRegion-  :: forall t m. (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasInput t m)+  :: forall t m+   . (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasInput t m)   => m (Event t VtyEvent) inputInFocusedRegion = do   inp <- input   regBeh <- current <$> askRegion   foc <- current <$> focus-  let-    trackMouse ::-      VtyEvent-      -> (MouseTrackingState, Maybe VtyEvent)-      -> PushM t (Maybe (MouseTrackingState, Maybe VtyEvent))-    trackMouse e (tracking, _) = do-      -- sampling (as oppose to using attachPromptlyDyn) is necessary here as the focus may change from the event produced here-      focused <- sample foc-      -- strictly speaking the same could also happen here too-      reg@(Region l t _ _) <- sample regBeh-      return $ case e of+  let trackMouse+        :: VtyEvent+        -> (MouseTrackingState, Maybe VtyEvent)+        -> PushM t (Maybe (MouseTrackingState, Maybe VtyEvent))+      trackMouse e (tracking, _) = do+        -- sampling (as oppose to using attachPromptlyDyn) is necessary here as the focus may change from the event produced here+        focused <- sample foc+        -- strictly speaking the same could also happen here too+        reg@(Region l t _ _) <- sample regBeh+        return $ case e of+          -- filter keyboard input if region is not focused+          V.EvKey _ _ | not focused -> Nothing+          -- pastes are keyboard input too; deliver them only to the focused+          -- region so they don't land in every 'textInput' at once+          V.EvPaste _ | not focused -> Nothing+          -- filter scroll wheel input based on mouse position+          V.EvMouseDown x y btn m | btn == V.BScrollUp || btn == V.BScrollDown -> case tracking of+            trck@(Tracking _) -> Just (trck, Nothing)+            _ -> Just (WaitingForInput, if withinRegion reg x y then Just (V.EvMouseDown (x - l) (y - t) btn m) else Nothing)+          -- only do tracking for l/m/r mouse buttons+          V.EvMouseDown x y btn m ->+            if tracking == Tracking btn || (tracking == WaitingForInput && withinRegion reg x y)+              then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m)+              else Just (NotTracking, Nothing)+          V.EvMouseUp x y mbtn -> case mbtn of+            Nothing -> case tracking of+              Tracking _ -> Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn)+              _ -> Just (WaitingForInput, Nothing)+            Just btn ->+              if tracking == Tracking btn+                -- NOTE we only report EvMouseUp for the button we are tracking+                -- vty has mouse buttons override others (seems to be based on ordering of Button) when multiple are pressed.+                -- so it IS possible for child widget to miss out on a 'EvMouseUp' event with this current implementation+                then Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn)+                else Just (WaitingForInput, Nothing)+          _ -> Just (tracking, Just e)+  dynInputEvTracking <- foldDynMaybeM trackMouse (WaitingForInput, Nothing) $ inp+  return (fmapMaybe snd $ updated dynInputEvTracking) -        -- filter keyboard input if region is not focused-        V.EvKey _ _ | not focused -> Nothing+-- | Fires when the terminal window gains focus (requires focus tracking+-- mode, which is enabled by default via 'getDefaultVty').+gainedFocus :: (Monad m, Reflex t, HasInput t m) => m (Event t ())+gainedFocus = do+  inp <- input+  return $ fforMaybe inp $ \case+    V.EvGainedFocus -> Just ()+    _ -> Nothing -        -- filter scroll wheel input based on mouse position-        ev@(V.EvMouseDown x y btn m) | btn == V.BScrollUp || btn == V.BScrollDown -> case tracking of-          trck@(Tracking _) -> Just (trck, Nothing)-          _ -> Just (WaitingForInput, if withinRegion reg x y then Just (V.EvMouseDown (x - l) (y - t) btn m) else Nothing)+-- | Fires when the terminal window loses focus.+lostFocus :: (Monad m, Reflex t, HasInput t m) => m (Event t ())+lostFocus = do+  inp <- input+  return $ fforMaybe inp $ \case+    V.EvLostFocus -> Just ()+    _ -> Nothing -        -- only do tracking for l/m/r mouse buttons-        V.EvMouseDown x y btn m ->-          if tracking == Tracking btn || (tracking == WaitingForInput && withinRegion reg x y)-            then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m)-            else Just (NotTracking, Nothing)-        V.EvMouseUp x y mbtn -> case mbtn of-          Nothing -> case tracking of-            Tracking _ -> Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn)-            _ -> Just (WaitingForInput, Nothing)-          Just btn -> if tracking == Tracking btn-            -- NOTE we only report EvMouseUp for the button we are tracking-            -- vty has mouse buttons override others (seems to be based on ordering of Button) when multiple are pressed.-            -- so it IS possible for child widget to miss out on a 'EvMouseUp' event with this current implementation-            then Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn)-            else Just (WaitingForInput, Nothing)-        _ -> Just (tracking, Just e)-  dynInputEvTracking <- foldDynMaybeM trackMouse (WaitingForInput, Nothing) $ inp-  return (fmapMaybe snd $ updated dynInputEvTracking)+-- | Fires when text is pasted (bracketed paste mode). Carries the pasted+-- bytes. Enable bracketed paste via 'getDefaultVty' (on by default).+paste :: (Monad m, Reflex t, HasInput t m) => m (Event t BS.ByteString)+paste = do+  inp <- input+  return $ fforMaybe inp $ \case+    V.EvPaste bs -> Just bs+    _ -> Nothing  -- * Getting and setting the display region @@ -273,7 +355,7 @@   , _region_width :: Int   , _region_height :: Int   }-  deriving (Show, Read, Eq, Ord)+  deriving (Eq, Ord, Read, Show)  -- | A region that occupies no space. nilRegion :: Region@@ -291,13 +373,238 @@   -> Int   -- ^ y-coordinate   -> Bool-withinRegion (Region l t w h) x y = not . or $-  [ x < l-  , y < t-  , x >= l + w-  , y >= t + h-  ]+withinRegion (Region l t w h) x y =+  not . or $+    [ x < l+    , y < t+    , x >= l + w+    , y >= t + h+    ] +-- * Terminal cursor state++-- | Complete terminal cursor state.+--+-- Coordinates are interpreted relative to the current viewport by 'setCursor'.+-- Use 'tellCursor' only when supplying absolute terminal coordinates.+data CursorState = CursorState+  { _cursorState_visibility :: CursorVisibility+  -- ^ Whether the cursor should be visible.+  , _cursorState_style :: CursorStyle+  -- ^ Shape to request from the terminal.+  , _cursorState_position :: (Int, Int)+  -- ^ Cursor position as @(x, y)@.+  }+  deriving (Eq, Ord, Show)++-- | The default cursor state: hidden, terminal-default shape, at @(0, 0)@.+defaultCursorState :: CursorState+defaultCursorState = CursorState CursorHidden CursorStyleDefault (0, 0)++instance Default CursorState where+  def = defaultCursorState++-- | A class for widgets that can request terminal cursor updates.+class (Reflex t, Monad m) => HasCursor t m | m -> t where+  -- | Request an absolute terminal cursor state update.+  tellCursor :: Event t CursorState -> m ()+  default tellCursor :: (f m' ~ m, MonadTrans f, HasCursor t m') => Event t CursorState -> m ()+  tellCursor = lift . tellCursor++-- | Keep the terminal cursor synchronized with a dynamic state.+--+-- The cursor position is relative to the current viewport. If a visible cursor+-- is outside the viewport, it is hidden until it comes back into bounds.+setCursor+  :: (HasCursor t m, HasDisplayRegion t m, PostBuild t m)+  => Dynamic t CursorState+  -> m ()+setCursor cursorState = do+  viewport <- askViewport+  postBuild <- getPostBuild+  let absoluteCursorState = zipDynWith translateCursorState viewport cursorState+  tellCursor $ leftmost [tag (current absoluteCursorState) postBuild, updated absoluteCursorState]++-- | Translate a viewport-relative cursor state to an absolute terminal cursor+-- state, hiding visible cursors that are outside the viewport.+translateCursorState :: Region -> CursorState -> CursorState+translateCursorState (Region left top width height) (CursorState visibility style (x, y)) =+  let absolute = CursorState visibility style (left + x, top + y)+  in case visibility of+       CursorHidden -> absolute+       CursorVisible+         | withinRegion (Region 0 0 width height) x y -> absolute+         | otherwise -> absolute {_cursorState_visibility = CursorHidden}++-- | Convert reflex-vty cursor state to vty's picture cursor.+cursorStateToVtyCursor :: CursorState -> V.Cursor+cursorStateToVtyCursor (CursorState CursorHidden _ _) = V.NoCursor+-- reflex-vty cursor coordinates are terminal cells, so the visible+-- cursor maps to 'V.AbsoluteCursor' (cell coordinates), not 'V.Cursor'+-- (character offsets).+cursorStateToVtyCursor (CursorState CursorVisible _ (x, y)) = V.AbsoluteCursor x y++instance HasCursor t m => HasCursor t (ReaderT x m)+instance HasCursor t m => HasCursor t (BehaviorWriterT t x m)+instance HasCursor t m => HasCursor t (DynamicWriterT t x m)+instance HasCursor t m => HasCursor t (EventWriterT t x m)+instance HasCursor t m => HasCursor t (NodeIdT m)+instance HasCursor t m => HasCursor t (Input t m)+instance HasCursor t m => HasCursor t (ImageWriter t m)+instance HasCursor t m => HasCursor t (DisplayRegion t m)+instance HasCursor t m => HasCursor t (FocusReader t m)+instance HasCursor t m => HasCursor t (ThemeReader t m)+instance HasCursor t m => HasCursor t (ColorProfileReader t m)++-- | A widget transformer that collects cursor updates from child widgets.+newtype CursorWriter t m a = CursorWriter+  {unCursorWriter :: EventWriterT t (Last CursorState) m a}+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadCatch+    , MonadFix+    , MonadHold t+    , MonadIO+    , MonadMask+    , MonadRef+    , MonadSample t+    , MonadThrow+    )++instance MonadTrans (CursorWriter t) where+  lift = CursorWriter . lift++instance MFunctor (CursorWriter t) where+  hoist f = CursorWriter . hoist f . unCursorWriter++instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (CursorWriter t m) where+  runWithReplace (CursorWriter a) e = CursorWriter $ runWithReplace a $ fmap unCursorWriter e+  traverseIntMapWithKeyWithAdjust f m e = CursorWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unCursorWriter $ f k v) m e+  traverseDMapWithKeyWithAdjust f m e = CursorWriter $ traverseDMapWithKeyWithAdjust (\k v -> unCursorWriter $ f k v) m e+  traverseDMapWithKeyWithAdjustWithMove f m e = CursorWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unCursorWriter $ f k v) m e++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (CursorWriter t m)+deriving instance NotReady t m => NotReady t (CursorWriter t m)+deriving instance PerformEvent t m => PerformEvent t (CursorWriter t m)+deriving instance PostBuild t m => PostBuild t (CursorWriter t m)+deriving instance TriggerEvent t m => TriggerEvent t (CursorWriter t m)++instance (Monad m, Reflex t) => HasCursor t (CursorWriter t m) where+  tellCursor = CursorWriter . tellEvent . fmap Last++instance HasImageWriter t m => HasImageWriter t (CursorWriter t m) where+  captureImages (CursorWriter x) = CursorWriter $ do+    ((a, cursorUpdates), images) <- lift $ captureImages $ runEventWriterT x+    tellEvent cursorUpdates+    pure (a, images)++instance HasDisplayRegion t m => HasDisplayRegion t (CursorWriter t m)+instance HasFocusReader t m => HasFocusReader t (CursorWriter t m)+instance HasTheme t m => HasTheme t (CursorWriter t m)+instance HasColorProfile t m => HasColorProfile t (CursorWriter t m)+instance MonadNodeId m => MonadNodeId (CursorWriter t m)++-- | Run a widget that can request terminal cursor updates.+runCursorWriter+  :: (Reflex t, Monad m)+  => CursorWriter t m a+  -> m (a, Event t (Last CursorState))+runCursorWriter = runEventWriterT . unCursorWriter++-- * Screen mode (alt-screen)++-- | A class for widgets that can request terminal screen mode changes.+class (Reflex t, Monad m) => HasScreenMode t m | m -> t where+  -- | Request a screen mode change.+  tellScreenMode :: Event t ScreenMode -> m ()+  default tellScreenMode :: (f m' ~ m, MonadTrans f, HasScreenMode t m') => Event t ScreenMode -> m ()+  tellScreenMode = lift . tellScreenMode++instance HasScreenMode t m => HasScreenMode t (ReaderT x m)+instance HasScreenMode t m => HasScreenMode t (BehaviorWriterT t x m)+instance HasScreenMode t m => HasScreenMode t (DynamicWriterT t x m)+instance HasScreenMode t m => HasScreenMode t (EventWriterT t x m)+instance HasScreenMode t m => HasScreenMode t (NodeIdT m)+instance HasScreenMode t m => HasScreenMode t (Input t m)+instance HasScreenMode t m => HasScreenMode t (ImageWriter t m)+instance HasScreenMode t m => HasScreenMode t (DisplayRegion t m)+instance HasScreenMode t m => HasScreenMode t (FocusReader t m)+instance HasScreenMode t m => HasScreenMode t (ThemeReader t m)+instance HasScreenMode t m => HasScreenMode t (ColorProfileReader t m)+instance HasScreenMode t m => HasScreenMode t (CursorWriter t m)++-- | Enter alternate screen mode immediately (on post-build).+enterAlternateScreen :: (HasScreenMode t m, PostBuild t m) => m ()+enterAlternateScreen = do+  pb <- getPostBuild+  tellScreenMode $ ScreenAlternate <$ pb++-- | Return to normal screen mode immediately (on post-build).+exitAlternateScreen :: (HasScreenMode t m, PostBuild t m) => m ()+exitAlternateScreen = do+  pb <- getPostBuild+  tellScreenMode $ ScreenNormal <$ pb++-- | A widget transformer that collects screen mode requests from child widgets.+newtype ScreenModeWriter t m a = ScreenModeWriter+  {unScreenModeWriter :: EventWriterT t (Last ScreenMode) m a}+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadCatch+    , MonadFix+    , MonadHold t+    , MonadIO+    , MonadMask+    , MonadRef+    , MonadSample t+    , MonadThrow+    )++instance MonadTrans (ScreenModeWriter t) where+  lift = ScreenModeWriter . lift++instance MFunctor (ScreenModeWriter t) where+  hoist f = ScreenModeWriter . hoist f . unScreenModeWriter++instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (ScreenModeWriter t m) where+  runWithReplace (ScreenModeWriter a) e = ScreenModeWriter $ runWithReplace a $ fmap unScreenModeWriter e+  traverseIntMapWithKeyWithAdjust f m e = ScreenModeWriter $ traverseIntMapWithKeyWithAdjust (\k v -> unScreenModeWriter $ f k v) m e+  traverseDMapWithKeyWithAdjust f m e = ScreenModeWriter $ traverseDMapWithKeyWithAdjust (\k v -> unScreenModeWriter $ f k v) m e+  traverseDMapWithKeyWithAdjustWithMove f m e = ScreenModeWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unScreenModeWriter $ f k v) m e++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ScreenModeWriter t m)+deriving instance NotReady t m => NotReady t (ScreenModeWriter t m)+deriving instance PerformEvent t m => PerformEvent t (ScreenModeWriter t m)+deriving instance PostBuild t m => PostBuild t (ScreenModeWriter t m)+deriving instance TriggerEvent t m => TriggerEvent t (ScreenModeWriter t m)++instance (Monad m, Reflex t) => HasScreenMode t (ScreenModeWriter t m) where+  tellScreenMode = ScreenModeWriter . tellEvent . fmap Last++instance HasImageWriter t m => HasImageWriter t (ScreenModeWriter t m) where+  captureImages (ScreenModeWriter x) = ScreenModeWriter $ do+    ((a, modeUpdates), images) <- lift $ captureImages $ runEventWriterT x+    tellEvent modeUpdates+    pure (a, images)++instance HasDisplayRegion t m => HasDisplayRegion t (ScreenModeWriter t m)+instance HasFocusReader t m => HasFocusReader t (ScreenModeWriter t m)+instance HasTheme t m => HasTheme t (ScreenModeWriter t m)+instance HasColorProfile t m => HasColorProfile t (ScreenModeWriter t m)+instance HasCursor t m => HasCursor t (ScreenModeWriter t m)+instance MonadNodeId m => MonadNodeId (ScreenModeWriter t m)++-- | Run a widget that can request screen mode changes.+runScreenModeWriter+  :: (Reflex t, Monad m)+  => ScreenModeWriter t m a+  -> m (a, Event t (Last ScreenMode))+runScreenModeWriter = runEventWriterT . unScreenModeWriter+ -- | Produces an 'Image' that fills a region with space characters regionBlankImage :: V.Attr -> Region -> Image regionBlankImage attr r@(Region _ _ width height) =@@ -305,15 +612,35 @@  -- | A class for things that know their own display size dimensions class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where-  -- | Retrieve the display region+  -- | Retrieve the display region. This is the "layout region" — the+  -- space the layout system uses to distribute among children. Inside+  -- 'scrollable', this may be larger than the actual viewport.   askRegion :: m (Dynamic t Region)   default askRegion :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)   askRegion = lift askRegion-  -- | Run an action in a local region, by applying a transformation to the region++  -- | Run an action in a local region, by applying a transformation to+  -- the region. Affects both layout and viewport.   localRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a   default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a   localRegion f = hoist (localRegion f) +  -- | The actual on-screen viewport region. May differ from 'askRegion'+  -- inside containers that inflate the layout region (e.g. 'scrollable').+  -- Use this for rendering decisions: how many rows\/cols to fill, how+  -- tall to draw a box, etc.+  askViewport :: m (Dynamic t Region)+  default askViewport :: (f m' ~ m, MonadTrans f, HasDisplayRegion t m') => m (Dynamic t Region)+  askViewport = lift askViewport++  -- | Run an action with a modified layout region only, leaving the+  -- viewport unchanged. Used by 'scrollable' to give children more+  -- layout height than is visible, while widgets still know the real+  -- viewport size for rendering.+  localLayoutRegion :: (Dynamic t Region -> Dynamic t Region) -> m a -> m a+  default localLayoutRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a+  localLayoutRegion f = hoist (localLayoutRegion f)+ -- | Retrieve the display width displayWidth :: HasDisplayRegion t m => m (Dynamic t Int) displayWidth = fmap _region_width <$> askRegion@@ -322,6 +649,14 @@ displayHeight :: HasDisplayRegion t m => m (Dynamic t Int) displayHeight = fmap _region_height <$> askRegion +-- | Retrieve the viewport width (actual on-screen width)+viewportWidth :: HasDisplayRegion t m => m (Dynamic t Int)+viewportWidth = fmap _region_width <$> askViewport++-- | Retrieve the viewport height (actual on-screen height)+viewportHeight :: HasDisplayRegion t m => m (Dynamic t Int)+viewportHeight = fmap _region_height <$> askViewport+ instance HasDisplayRegion t m => HasDisplayRegion t (ReaderT x m) instance HasDisplayRegion t m => HasDisplayRegion t (BehaviorWriterT t x m) instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)@@ -330,31 +665,37 @@  -- | A widget that has access to a particular region of the vty display newtype DisplayRegion t m a = DisplayRegion-  { unDisplayRegion :: ReaderT (Dynamic t Region) m a }+  {unDisplayRegion :: ReaderT (Dynamic t (Region, Region)) m a}   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor     , Monad+    , MonadCatch     , MonadFix     , MonadHold t     , MonadIO+    , MonadMask     , MonadRef     , MonadSample t-    , MonadCatch     , MonadThrow-    , MonadMask     )  instance (Monad m, Reflex t) => HasDisplayRegion t (DisplayRegion t m) where-  askRegion = DisplayRegion ask-  localRegion f = DisplayRegion . local f . unDisplayRegion+  askRegion = DisplayRegion $ fmap fst <$> ask+  localRegion f = DisplayRegion . local (\dr -> (,) <$> f (fst <$> dr) <*> f (snd <$> dr)) . unDisplayRegion+  askViewport = DisplayRegion $ fmap snd <$> ask+  localLayoutRegion f = DisplayRegion . local (\dr -> (,) <$> f (fst <$> dr) <*> (snd <$> dr)) . unDisplayRegion  deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DisplayRegion t m) deriving instance NotReady t m => NotReady t (DisplayRegion t m) deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m) deriving instance PostBuild t m => PostBuild t (DisplayRegion t m) deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)-instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)+instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m) where+  captureImages x = do+    reg <- askRegion+    vp <- askViewport+    lift $ captureImages $ runDisplayRegionBoth reg vp x instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)  instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where@@ -371,14 +712,27 @@  instance MonadNodeId m => MonadNodeId (DisplayRegion t m) --- | Run a 'DisplayRegion' action with a given 'Region'+-- | Run a 'DisplayRegion' action with a given 'Region'. Sets both the+-- layout region and viewport to the same value. runDisplayRegion   :: (Reflex t, Monad m)   => Dynamic t Region   -> DisplayRegion t m a   -> m a-runDisplayRegion r = flip runReaderT r . unDisplayRegion+runDisplayRegion r = runDisplayRegionBoth r r +-- | Run a 'DisplayRegion' action with separate layout and viewport regions.+runDisplayRegionBoth+  :: (Reflex t, Monad m)+  => Dynamic t Region+  -- ^ Layout region (what 'askRegion' returns)+  -> Dynamic t Region+  -- ^ Viewport region (what 'askViewport' returns)+  -> DisplayRegion t m a+  -> m a+runDisplayRegionBoth layout viewport =+  flip runReaderT ((,) <$> layout <*> viewport) . unDisplayRegion+ -- * Getting focus state  -- | A class for things that can dynamically gain and lose focus@@ -398,19 +752,19 @@  -- | A widget that has access to information about whether it is focused newtype FocusReader t m a = FocusReader-  { unFocusReader :: ReaderT (Dynamic t Bool) m a }+  {unFocusReader :: ReaderT (Dynamic t Bool) m a}   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor     , Monad+    , MonadCatch     , MonadFix     , MonadHold t     , MonadIO+    , MonadMask     , MonadRef     , MonadSample t-    , MonadCatch     , MonadThrow-    , MonadMask     )  instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where@@ -422,7 +776,10 @@ deriving instance PerformEvent t m => PerformEvent t (FocusReader t m) deriving instance PostBuild t m => PostBuild t (FocusReader t m) deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)-instance HasImageWriter t m => HasImageWriter t (FocusReader t m)+instance HasImageWriter t m => HasImageWriter t (FocusReader t m) where+  captureImages x = do+    a <- focus+    lift $ captureImages $ runFocusReader a x  instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where   runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e@@ -449,36 +806,40 @@ -- * "Image" output  -- | A class for widgets that can produce images to draw to the display-class (Reflex t, Monad m) => HasImageWriter t m | m -> t where+class (Reflex t, Monad m) => HasImageWriter (t :: Type) m | m -> t where   -- | Send images upstream for rendering   tellImages :: Behavior t [Image] -> m ()   default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()   tellImages = lift . tellImages+   -- | Apply a transformation to the images produced by the child actions   mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a   default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a   mapImages f = hoist (mapImages f) +  -- | Capture images, preventing them from being drawn+  captureImages :: m a -> m (a, Behavior t [Image])+ -- | A widget that can produce images to draw onto the display newtype ImageWriter t m a = ImageWriter-  { unImageWriter :: BehaviorWriterT t [Image] m a }+  {unImageWriter :: BehaviorWriterT t [Image] m a}   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor     , Monad+    , MonadCatch     , MonadFix     , MonadHold t     , MonadIO+    , MonadMask     , MonadRef     , MonadReflexCreateTrigger t     , MonadSample t+    , MonadThrow     , NotReady t     , PerformEvent t     , PostBuild t     , TriggerEvent t-    , MonadCatch-    , MonadThrow-    , MonadMask     )  instance MonadTrans (ImageWriter t) where@@ -493,18 +854,43 @@   traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e   traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e -instance HasImageWriter t m => HasImageWriter t (ReaderT x m)-instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)-instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)-instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)-instance HasImageWriter t m => HasImageWriter t (NodeIdT m)+instance HasImageWriter t m => HasImageWriter t (ReaderT x m) where+  captureImages x = do+    a <- ask+    lift $ captureImages $ runReaderT x a+instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m) where+  captureImages (BehaviorWriterT x) = BehaviorWriterT $ do+    s <- get+    ((result, s'), images) <- lift $ captureImages $ runStateT x s+    put s'+    return (result, images)+instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m) where+  captureImages (DynamicWriterT x) = DynamicWriterT $ do+    s <- get+    ((result, s'), images) <- lift $ captureImages $ runStateT x s+    put s'+    return (result, images) +instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m) where+  captureImages (EventWriterT x) = EventWriterT $ do+    s <- get+    ((result, s'), images) <- lift $ captureImages $ runStateT x s+    put s'+    return (result, images)++instance HasImageWriter t m => HasImageWriter t (NodeIdT m) where+  captureImages x = NodeIdT $ do+    ref <- ask+    lift $ captureImages $ flip runReaderT ref . unNodeIdT $ x+ instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where   tellImages = ImageWriter . tellBehavior   mapImages f (ImageWriter x) = ImageWriter $ do     (a, images) <- lift $ runBehaviorWriterT x     tellBehavior $ f images     pure a+  captureImages (ImageWriter x) = ImageWriter $ do+    lift $ runBehaviorWriterT x  instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m) instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)@@ -520,11 +906,18 @@  -- | A class for things that can be visually styled class (Reflex t, Monad m) => HasTheme t m | m -> t where-  theme :: m (Behavior t V.Attr)-  default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)+  theme :: m (Behavior t Theme)+  default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t Theme)   theme = lift theme-  localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a-  default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a++  -- | Convenience: the ambient 'V.Attr' from '_theme_default'. Most widgets+  --   only need this.+  themeAttr :: m (Behavior t V.Attr)+  default themeAttr :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)+  themeAttr = lift themeAttr++  localTheme :: (Behavior t Theme -> Behavior t Theme) -> m a -> m a+  default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t Theme -> Behavior t Theme) -> m a -> m a   localTheme f = hoist (localTheme f)  instance HasTheme t m => HasTheme t (ReaderT x m)@@ -539,23 +932,24 @@  -- | A widget that has access to theme information newtype ThemeReader t m a = ThemeReader-  { unThemeReader :: ReaderT (Behavior t V.Attr) m a }+  {unThemeReader :: ReaderT (Behavior t Theme) m a}   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor     , Monad+    , MonadCatch     , MonadFix     , MonadHold t     , MonadIO+    , MonadMask     , MonadRef     , MonadSample t-    , MonadCatch     , MonadThrow-    , MonadMask     )  instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where   theme = ThemeReader ask+  themeAttr = Reflex.Vty.Theme.themeToAttr <$> ThemeReader ask   localTheme f = ThemeReader . local f . unThemeReader  deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)@@ -563,7 +957,10 @@ deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m) deriving instance PostBuild t m => PostBuild t (ThemeReader t m) deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)-instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)+instance HasImageWriter t m => HasImageWriter t (ThemeReader t m) where+  captureImages x = ThemeReader $ do+    a <- ask+    lift $ captureImages $ flip runReaderT a $ unThemeReader x  instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where   runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e@@ -579,15 +976,95 @@  instance MonadNodeId m => MonadNodeId (ThemeReader t m) --- | Run a 'ThemeReader' action with the given focus value+-- | Run a 'ThemeReader' action with the given theme runThemeReader   :: (Reflex t, Monad m)-  => Behavior t V.Attr+  => Behavior t Theme   -> ThemeReader t m a   -> m a runThemeReader b = flip runReaderT b . unThemeReader +-- * Color profile +-- | A class for widgets that need to know the terminal's color capability.+-- Widgets build with true-color 'V.Attr's and the host downsamples via+-- 'Reflex.Vty.ColorProfile.applyProfile' at the 'V.Picture' boundary, so+-- most widgets never need to call 'colorProfile' directly: it is useful+-- when a widget wants to make a structural decision based on capability+-- (e.g. choosing a different glyph for an 8-color terminal).+class (Reflex t, Monad m) => HasColorProfile t m | m -> t where+  colorProfile :: m (Behavior t ColorProfile)+  default colorProfile :: (f m' ~ m, Monad m', MonadTrans f, HasColorProfile t m') => m (Behavior t ColorProfile)+  colorProfile = lift colorProfile+  localColorProfile :: (Behavior t ColorProfile -> Behavior t ColorProfile) -> m a -> m a+  default localColorProfile :: (f m' ~ m, Monad m', MFunctor f, HasColorProfile t m') => (Behavior t ColorProfile -> Behavior t ColorProfile) -> m a -> m a+  localColorProfile f = hoist (localColorProfile f)++instance HasColorProfile t m => HasColorProfile t (ReaderT x m)+instance HasColorProfile t m => HasColorProfile t (BehaviorWriterT t x m)+instance HasColorProfile t m => HasColorProfile t (DynamicWriterT t x m)+instance HasColorProfile t m => HasColorProfile t (EventWriterT t x m)+instance HasColorProfile t m => HasColorProfile t (NodeIdT m)+instance HasColorProfile t m => HasColorProfile t (Input t m)+instance HasColorProfile t m => HasColorProfile t (ImageWriter t m)+instance HasColorProfile t m => HasColorProfile t (DisplayRegion t m)+instance HasColorProfile t m => HasColorProfile t (FocusReader t m)+instance HasColorProfile t m => HasColorProfile t (ThemeReader t m)++-- | A widget that has access to the terminal's 'ColorProfile'.+newtype ColorProfileReader t m a = ColorProfileReader+  {unColorProfileReader :: ReaderT (Behavior t ColorProfile) m a}+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadCatch+    , MonadFix+    , MonadHold t+    , MonadIO+    , MonadMask+    , MonadRef+    , MonadSample t+    , MonadThrow+    )++instance (Monad m, Reflex t) => HasColorProfile t (ColorProfileReader t m) where+  colorProfile = ColorProfileReader ask+  localColorProfile f = ColorProfileReader . local f . unColorProfileReader++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ColorProfileReader t m)+deriving instance NotReady t m => NotReady t (ColorProfileReader t m)+deriving instance PerformEvent t m => PerformEvent t (ColorProfileReader t m)+deriving instance PostBuild t m => PostBuild t (ColorProfileReader t m)+deriving instance TriggerEvent t m => TriggerEvent t (ColorProfileReader t m)+instance HasImageWriter t m => HasImageWriter t (ColorProfileReader t m) where+  captureImages x = ColorProfileReader $ do+    a <- ask+    lift $ captureImages $ flip runReaderT a $ unColorProfileReader x+instance HasTheme t m => HasTheme t (ColorProfileReader t m)++instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ColorProfileReader t m) where+  runWithReplace (ColorProfileReader a) e = ColorProfileReader $ runWithReplace a $ fmap unColorProfileReader e+  traverseIntMapWithKeyWithAdjust f m e = ColorProfileReader $ traverseIntMapWithKeyWithAdjust (\k v -> unColorProfileReader $ f k v) m e+  traverseDMapWithKeyWithAdjust f m e = ColorProfileReader $ traverseDMapWithKeyWithAdjust (\k v -> unColorProfileReader $ f k v) m e+  traverseDMapWithKeyWithAdjustWithMove f m e = ColorProfileReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unColorProfileReader $ f k v) m e++instance MonadTrans (ColorProfileReader t) where+  lift = ColorProfileReader . lift++instance MFunctor (ColorProfileReader t) where+  hoist f = ColorProfileReader . hoist f . unColorProfileReader++instance MonadNodeId m => MonadNodeId (ColorProfileReader t m)++-- | Run a 'ColorProfileReader' action with the given profile.+runColorProfileReader+  :: (Reflex t, Monad m)+  => Behavior t ColorProfile+  -> ColorProfileReader t m a+  -> m a+runColorProfileReader b = flip runReaderT b . unColorProfileReader+ -- ** Manipulating images  -- | Translates and crops an 'Image' so that it is contained by@@ -613,7 +1090,7 @@ -- | Low-level widget combinator that runs a child widget within -- a given region and context. This widget filters and modifies the input -- that the child widget receives such that:--- * unfocused widgets receive no key events+-- * widgets receive key and paste events only when they and their parent are focused -- * mouse inputs inside the region have their coordinates translated such --   that (0,0) is the top-left corner of the region -- * mouse drag sequences that start OFF the region are ignored@@ -621,13 +1098,20 @@ pane   :: (MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)   => Dynamic t Region-  -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.+  -> Dynamic t Bool+  -- ^ Whether the widget should be focused when the parent is.   -> m a   -> m a-pane dr foc child = localRegion (const dr) $-  mapImages (imagesInRegion $ current dr) $-    localFocus (const foc) $-      inputInFocusedRegion >>= \e -> localInput (const e) child+pane dr foc child = do+  parentViewport <- askViewport+  let viewport = zipDynWith composeViewport parentViewport dr+      composeViewport (Region px py _ _) (Region x y w h) =+        Region (px + x) (py + y) w h+  localRegion (const viewport) $+    localLayoutRegion (const dr) $+      mapImages (imagesInRegion $ current dr) $+        localFocus (zipDynWith (&&) foc) $+          inputInFocusedRegion >>= \e -> localInput (const e) child  -- * Misc
src/Reflex/Vty/Widget/Box.hs view
@@ -1,6 +1,5 @@-{-|-  Description: Drawing boxes in various styles--}+-- |+--   Description: Drawing boxes in various styles module Reflex.Vty.Widget.Box where  import Control.Monad.Fix (MonadFix)@@ -10,6 +9,8 @@ import Graphics.Vty (Image) import qualified Graphics.Vty as V import Reflex++import Data.Text.Zipper (TextAlignment (..), textWidth) import Reflex.Vty.Widget import Reflex.Vty.Widget.Text @@ -55,31 +56,33 @@ roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'  -- | Draws a titled box in the provided style and a child widget inside of that box-boxTitle :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)-    => Behavior t BoxStyle-    -> Behavior t Text-    -> m a-    -> m a-boxTitle boxStyle title child = do-  dh <- displayHeight-  dw <- displayWidth-  bt <- theme+boxTitle+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)+  => Behavior t TextAlignment+  -> Behavior t BoxStyle+  -> Behavior t Text+  -> m a+  -> m a+boxTitle align boxStyle title child = do+  dh <- viewportHeight+  dw <- viewportWidth+  bt <- themeAttr   let boxReg = Region 0 0 <$> dw <*> dh       innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh) -  tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg)+  tellImages (boxImages <$> bt <*> align <*> title <*> boxStyle <*> current boxReg)   tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r]))    pane innerReg (pure True) child   where-    boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image]-    boxImages attr title' style (Region left top width height) =+    boxImages :: V.Attr -> TextAlignment -> Text -> BoxStyle -> Region -> [Image]+    boxImages attr align' title' style (Region left top width height) =       let right = left + width - 1           bottom = top + height - 1           sides =             [ withinImage (Region (left + 1) top (width - 2) 1) $                 V.text' attr $-                  centerText title' (_boxStyle_n style) (width - 2)+                  alignText align' title' (_boxStyle_n style) (width - 2)             , withinImage (Region right (top + 1) 1 (height - 2)) $                 V.charFill attr (_boxStyle_e style) 1 (height - 2)             , withinImage (Region (left + 1) bottom (width - 2) 1) $@@ -99,29 +102,49 @@             ]       in sides ++ if width > 1 && height > 1 then corners else [] --- | Pad text  on the left and right with the given character so that it is--- centered-centerText-  :: T.Text -- ^ Text to center-  -> Char -- ^ Padding character-  -> Int -- ^ Width-  -> T.Text -- ^ Padded text-centerText t c l = if lt >= l-                 then t-                 else left <> t <> right+-- | Pad text on the left and right with the given character so that it+-- fills the given width, aligned according to the 'TextAlignment'.+alignText+  :: TextAlignment+  -- ^ Alignment+  -> T.Text+  -- ^ Text to align+  -> Char+  -- ^ Padding character+  -> Int+  -- ^ Target width+  -> T.Text+  -- ^ Aligned text+alignText align t c l+  | tw >= l = t+  | otherwise = case align of+      TextAlignment_Left -> t <> pad delta+      TextAlignment_Right -> pad delta <> t+      TextAlignment_Center -> pad ((delta + 1) `div` 2) <> t <> pad (delta `div` 2)   where-    lt = T.length t-    delta = l - lt-    mkHalf n = T.replicate (n `div` 2) (T.singleton c)-    left = mkHalf $ delta + 1-    right = mkHalf delta+    tw = textWidth t+    delta = l - tw+    pad n = T.replicate n (T.singleton c) +-- | Specialized 'alignText' for center alignment.+centerText+  :: T.Text+  -- ^ Text to center+  -> Char+  -- ^ Padding character+  -> Int+  -- ^ Width+  -> T.Text+  -- ^ Padded text+centerText = alignText TextAlignment_Center+ -- | A box without a title-box :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)-    => Behavior t BoxStyle-    -> m a-    -> m a-box boxStyle = boxTitle boxStyle mempty+box+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)+  => Behavior t BoxStyle+  -> m a+  -> m a+box boxStyle = boxTitle (pure TextAlignment_Center) boxStyle mempty  -- | A box whose style is static boxStatic
src/Reflex/Vty/Widget/Input.hs view
@@ -1,25 +1,26 @@-{-|-Module: Reflex.Vty.Widget.Input-Description: User input widgets for reflex-vty--}+-- |+-- Module: Reflex.Vty.Widget.Input+-- Description: User input widgets for reflex-vty module Reflex.Vty.Widget.Input   ( module Export   , module Reflex.Vty.Widget.Input   ) where --import Reflex.Vty.Widget.Input.Mouse as Export-import Reflex.Vty.Widget.Input.Text as Export- import Control.Monad (join) import Control.Monad.Fix (MonadFix)-import Data.Default (Default(..))-import Data.List (foldl')+import Data.Default (Default (..))+import qualified Data.List as List import Data.Text (Text) import qualified Graphics.Vty as V import Reflex++import Data.Text.Zipper (TextAlignment (..))+import Reflex.Vty.Style (applyAttr)+import Reflex.Vty.Theme (Theme (..)) import Reflex.Vty.Widget import Reflex.Vty.Widget.Box+import Reflex.Vty.Widget.Input.Mouse as Export+import Reflex.Vty.Widget.Input.Text as Export import Reflex.Vty.Widget.Text  -- * Buttons@@ -57,7 +58,7 @@   => ButtonConfig t   -> Behavior t Text   -> m (Event t ())-textButton cfg = button cfg . text -- TODO Centering etc.+textButton cfg = button cfg . textWithAlignment TextAlignment_Center  -- | A button widget that displays a static bit of text textButtonStatic@@ -75,11 +76,11 @@   => Behavior t Text   -> m (Event t MouseUp) link t = do-  bt <- theme-  let cfg = RichTextConfig-        { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt-        }-  richText cfg t+  th <- theme+  bt <- themeAttr+  let linkStyle = fmap _theme_link th+      attrs = applyAttr <$> linkStyle <*> bt+  richText (RichTextConfig attrs) t   mouseUp  -- | A clickable link widget with a static label@@ -102,32 +103,32 @@  -- | This checkbox style uses an "x" to indicate the checked state checkboxStyleX :: CheckboxStyle-checkboxStyleX = CheckboxStyle-  { _checkboxStyle_unchecked = "[ ]"-  , _checkboxStyle_checked = "[x]"-  }+checkboxStyleX =+  CheckboxStyle+    { _checkboxStyle_unchecked = "[ ]"+    , _checkboxStyle_checked = "[x]"+    }  -- | This checkbox style uses a unicode tick mark to indicate the checked state checkboxStyleTick :: CheckboxStyle-checkboxStyleTick = CheckboxStyle-  { _checkboxStyle_unchecked = "[ ]"-  , _checkboxStyle_checked = "[✓]"-  }+checkboxStyleTick =+  CheckboxStyle+    { _checkboxStyle_unchecked = "[ ]"+    , _checkboxStyle_checked = "[✓]"+    }  -- | Configuration options for a checkbox data CheckboxConfig t = CheckboxConfig   { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle-  -- TODO DELETE and use HasTheme instead-  , _checkboxConfig_attributes :: Behavior t V.Attr   , _checkboxConfig_setValue :: Event t Bool   } -instance (Reflex t) => Default (CheckboxConfig t) where-  def = CheckboxConfig-    { _checkboxConfig_checkboxStyle = pure def-    , _checkboxConfig_attributes = pure V.defAttr-    , _checkboxConfig_setValue = never-    }+instance Reflex t => Default (CheckboxConfig t) where+  def =+    CheckboxConfig+      { _checkboxConfig_checkboxStyle = pure def+      , _checkboxConfig_setValue = never+      }  -- | A checkbox widget checkbox@@ -140,19 +141,22 @@   mu <- mouseUp   space <- key (V.KChar ' ')   f <- focus-  v <- foldDyn ($) v0 $ leftmost-    [ not <$ mu-    , not <$ space-    , const <$> _checkboxConfig_setValue cfg-    ]-  depressed <- hold V.defaultStyleMask $ leftmost-    [ V.bold <$ md-    , V.defaultStyleMask <$ mu-    ]+  v <-+    foldDyn ($) v0 $+      leftmost+        [ not <$ mu+        , not <$ space+        , const <$> _checkboxConfig_setValue cfg+        ]+  depressed <-+    hold V.defaultStyleMask $+      leftmost+        [ V.bold <$ md+        , V.defaultStyleMask <$ mu+        ]   let focused = ffor (current f) $ \x -> if x then V.bold else V.defaultStyleMask-  let attrs = combineStyles-        <$> _checkboxConfig_attributes cfg-        <*> sequence [depressed, focused]+  bt <- themeAttr+  let attrs = combineStyles <$> bt <*> sequence [depressed, focused]   richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->     if checked       then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg@@ -160,7 +164,7 @@   return v   where     combineStyles :: V.Attr -> [V.Style] -> V.Attr-    combineStyles x xs = foldl' V.withStyle x xs+    combineStyles x xs = List.foldl' V.withStyle x xs  -- | The ctrl-c keypress event ctrlc :: (Monad m, HasInput t m, Reflex t) => m (Event t ())
src/Reflex/Vty/Widget/Input/Mouse.hs view
@@ -1,23 +1,70 @@-{-|-  Description: Mouse clicks, drags, and scrolls--}+-- |+--   Description: Mouse clicks, drags, and scrolls module Reflex.Vty.Widget.Input.Mouse where  import Control.Monad.Fix import qualified Graphics.Vty as V import Reflex+ import Reflex.Vty.Widget +-- | The phase of a drag operation. A drag is a sequence of events that begins+-- with a 'DragStart' (the button is pressed), continues with zero or more+-- 'Dragging' events (the mouse moves with the button held), and finishes with+-- a 'DragEnd' (the button is released).+data DragState+  = -- | The button was just pressed; this is the first event of the drag.+    DragStart+  | -- | The mouse is moving with the button held down.+    Dragging+  | -- | The button was released; this is the last event of the drag.+    DragEnd+  deriving (Bounded, Enum, Eq, Ord, Read, Show)+ -- | Information about a drag operation data Drag = Drag-  { _drag_from :: (Int, Int) -- ^ Where the drag began-  , _drag_to :: (Int, Int) -- ^ Where the mouse currently is-  , _drag_button :: V.Button -- ^ Which mouse button is dragging-  , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held-  , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)+  { _drag_from :: (Int, Int)+  -- ^ Where the drag began+  , _drag_to :: (Int, Int)+  -- ^ Where the mouse currently is+  , _drag_button :: V.Button+  -- ^ Which mouse button is dragging+  , _drag_modifiers :: [V.Modifier]+  -- ^ What modifiers are held+  , _drag_state :: DragState+  -- ^ Which phase of the drag this event represents. Use this to tell the+  -- start of a drag ('DragStart') apart from its continuation ('Dragging')+  -- and its end ('DragEnd').   }   deriving (Eq, Ord, Show) +-- | Pure state transition driving 'drag'. Given the button being tracked, the+-- previous 'Drag' state (if any), and an incoming vty event, produce the next+-- 'Drag' or 'Nothing' if the event is irrelevant. The first relevant mouse-down+-- yields a 'DragStart', subsequent moves yield 'Dragging', and the button+-- release yields 'DragEnd'; a mouse-down after a 'DragEnd' starts a fresh drag.+stepDrag :: V.Button -> Maybe Drag -> V.Event -> Maybe Drag+stepDrag btn = \case+  Nothing -> \case+    V.EvMouseDown x y btn' mods+      | btn == btn' -> Just $ Drag (x, y) (x, y) btn' mods DragStart+      | otherwise -> Nothing+    _ -> Nothing+  Just (Drag from _ _ mods st) -> \case+    V.EvMouseDown x y btn' mods'+      | st == DragEnd && btn == btn' -> Just $ Drag (x, y) (x, y) btn' mods' DragStart+      | btn == btn' -> Just $ Drag from (x, y) btn mods' Dragging+      | otherwise -> Nothing -- Ignore other buttons.+    V.EvMouseUp x y (Just btn')+      | st == DragEnd -> Nothing+      | btn == btn' -> Just $ Drag from (x, y) btn mods DragEnd+      | otherwise -> Nothing+    V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,+    -- assume it's the right one.+      | st == DragEnd -> Nothing+      | otherwise -> Just $ Drag from (x, y) btn mods DragEnd+    _ -> Nothing+ -- | Converts raw vty mouse drag events into an event stream of 'Drag's drag   :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)@@ -25,27 +72,7 @@   -> m (Event t Drag) drag btn = do   inp <- input-  let f :: Maybe Drag -> V.Event -> Maybe Drag-      f Nothing = \case-        V.EvMouseDown x y btn' mods-          | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False-          | otherwise   -> Nothing-        _ -> Nothing-      f (Just (Drag from _ _ mods end)) = \case-        V.EvMouseDown x y btn' mods'-          | end && btn == btn'  -> Just $ Drag (x,y) (x,y) btn' mods' False-          | btn == btn'         -> Just $ Drag from (x,y) btn mods' False-          | otherwise           -> Nothing -- Ignore other buttons.-        V.EvMouseUp x y (Just btn')-          | end         -> Nothing-          | btn == btn' -> Just $ Drag from (x,y) btn mods True-          | otherwise   -> Nothing-        V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,-                                -- assume it's the right one.-          | end       -> Nothing-          | otherwise -> Just $ Drag from (x,y) btn mods True-        _ -> Nothing-  rec let newDrag = attachWithMaybe f (current dragD) inp+  rec let newDrag = attachWithMaybe (stepDrag btn) (current dragD) inp       dragD <- holdDyn Nothing $ Just <$> newDrag   return (fmapMaybe id $ updated dragD) @@ -57,9 +84,10 @@ mouseDown btn = do   i <- input   return $ fforMaybe i $ \case-    V.EvMouseDown x y btn' mods -> if btn == btn'-      then Just $ MouseDown btn' (x, y) mods-      else Nothing+    V.EvMouseDown x y btn' mods ->+      if btn == btn'+        then Just $ MouseDown btn' (x, y) mods+        else Nothing     _ -> Nothing  -- | Mouse up events for a particular mouse button@@ -98,9 +126,22 @@ mouseScroll = do   up <- mouseDown V.BScrollUp   down <- mouseDown V.BScrollDown-  return $ leftmost-    [ ScrollDirection_Up <$ up-    , ScrollDirection_Down <$ down-    ]-+  return $+    leftmost+      [ ScrollDirection_Up <$ up+      , ScrollDirection_Down <$ down+      ] +-- | Track the last known mouse position from any mouse event (down or up).+-- Note: true hover (motion without a button held) requires terminal mode+-- 1003, which vty 6.2 does not expose. Position updates only on click/release.+mousePosition+  :: (Reflex t, MonadHold t m, HasInput t m)+  => m (Dynamic t (Int, Int))+mousePosition = do+  inp <- input+  let posEvent = fforMaybe inp $ \case+        V.EvMouseDown x y _ _ -> Just (x, y)+        V.EvMouseUp x y _ -> Just (x, y)+        _ -> Nothing+  holdDyn (0, 0) posEvent
src/Reflex/Vty/Widget/Input/Text.hs view
@@ -1,60 +1,71 @@-{-|-Module: Reflex.Vty.Widget.Input.Text-Description: Widgets for accepting text input from users and manipulating text within those inputs--}+-- |+-- Module: Reflex.Vty.Widget.Input.Text+-- Description: Widgets for accepting text input from users and manipulating text within those inputs module Reflex.Vty.Widget.Input.Text   ( module Reflex.Vty.Widget.Input.Text   , def   ) where -import Control.Monad (join) import Control.Monad.Fix (MonadFix)-import Data.Default (Default(..))+import Data.Default (Default (..)) import Data.Function ((&)) import Data.Text (Text)-import Data.Text.Zipper+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode) import qualified Graphics.Vty as V import Reflex +import Data.Text.Zipper+import Reflex.Vty.Style (Style, applyAttr)+import Reflex.Vty.Theme (Theme (..)) import Reflex.Vty.Widget-import Reflex.Vty.Widget.Layout import Reflex.Vty.Widget.Input.Mouse+import Reflex.Vty.Widget.Layout  -- | Configuration options for a 'textInput'. For more information on -- 'TextZipper', see 'Data.Text.Zipper'. data TextInputConfig t = TextInputConfig   { _textInputConfig_initialValue :: TextZipper   -- ^ Initial value. This is a 'TextZipper' because it is more flexible-  -- than plain 'Text'. For example, this allows to set the Cursor position,-  -- by choosing appropriate values for '_textZipper_before' and '_textZipper_after'.+  --   than plain 'Text'. For example, this allows to set the Cursor position,+  --   by choosing appropriate values for '_textZipper_before' and '_textZipper_after'.   , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)   -- ^ Event to update the value of the 'textInput'.   ---  -- Event is applied after other Input sources have been applied to the 'TextZipper',-  -- thus you may modify the final value that is displayed to the user.+  --   Event is applied after other Input sources have been applied to the 'TextZipper',+  --   thus you may modify the final value that is displayed to the user.   ---  -- You may set the value of the displayed text in 'textInput' by ignoring the input parameter.+  --   You may set the value of the displayed text in 'textInput' by ignoring the input parameter.   ---  -- Additionally, you can modify the updated value before displaying it to the user.-  -- For example, the following 'TextInputConfig' inserts an additional 'a'-  -- when the letter 'b' is entered into 'textInput':+  --   Additionally, you can modify the updated value before displaying it to the user.+  --   For example, the following 'TextInputConfig' inserts an additional 'a'+  --   when the letter 'b' is entered into 'textInput':   ---  -- @+  --   @   --   i <- input   --   textInput def   --     { _textInputConfig_modify = fforMaybe i $ \case   --         V.EvKey (V.KChar 'b') _ -> Just (insert "a")   --         _ -> Nothing   --     }-  -- @+  --   @   , _textInputConfig_tabWidth :: Int+  -- ^ Number of columns a tab character occupies when @'acceptTab'@ is enabled.+  , _textInputConfig_acceptTab :: Bool+  -- ^ Whether the Tab key inserts a tab character into the input. Defaults to+  --   'False', so Tab is left available for focus cycling (e.g.+  --   'Reflex.Vty.Widget.Input.tabNavigation'). Set to 'True' for editors that+  --   should insert tabs.   , _textInputConfig_display :: Dynamic t (Char -> Char)   -- ^ Transform the characters in a text input before displaying them. This is useful, e.g., for-  -- masking characters when entering passwords.+  --   masking characters when entering passwords.+  , _textInputConfig_alignment :: TextAlignment+  -- ^ How to align the entered text within the input region. Defaults to+  --   'TextAlignment_Left'. See 'Data.Text.Zipper.displayLinesWithAlignment'.   }  instance Reflex t => Default (TextInputConfig t) where-  def = TextInputConfig empty never 4 (pure id)+  def = TextInputConfig empty never 4 False (pure id) TextAlignment_Left  -- | The output produced by text input widgets, including the text -- value and the number of display lines (post-wrapping). Note that some@@ -64,8 +75,8 @@   -- ^ The current value of the textInput as Text.   , _textInput_userInput :: Event t TextZipper   -- ^ UI Event updates with the current 'TextZipper'.-  -- This does not include Events added by '_textInputConfig_setValue', but-  -- it does include '_textInputConfig_modify' Events.+  --   This does not include Events added by '_textInputConfig_setValue', but+  --   it does include '_textInputConfig_modify' Events.   , _textInput_lines :: Dynamic t Int   } @@ -77,38 +88,57 @@ textInput cfg = do   i <- input   f <- focus-  dh <- displayHeight-  dw <- displayWidth-  bt <- theme-  attr0 <- sample bt-  rec-      -- we split up the events from vty and the one users provide to avoid cyclical+  dh <- viewportHeight+  dw <- viewportWidth+  bt <- themeAttr+  th <- theme+  rec -- we split up the events from vty and the one users provide to avoid cyclical       -- update dependencies. This way, users may subscribe only to UI updates.       let valueChangedByCaller = _textInputConfig_modify cfg-      let valueChangedByUI = mergeWith (.)-            [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i-            , let displayInfo = (,) <$> current rows <*> scrollTop-              in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) ->-                goToDisplayLinePosition mx (st + my) dl+          -- Unless tab insertion is enabled, drop Tab/BackTab so they remain+          -- available for focus cycling instead of being typed into the field.+          keyForZipper =+            if _textInputConfig_acceptTab cfg+              then i+              else ffilter notTabKey i+      let valueChangedByUI =+            mergeWith+              (.)+              [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) keyForZipper+              , let displayInfo = (,) <$> current rows <*> scrollTop+                in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) ->+                     goToDisplayLinePosition mx (st + my) dl+              , fforMaybe i $ \case+                  V.EvPaste bs -> Just (insert (TE.decodeUtf8With lenientDecode bs))+                  _ -> Nothing+              ]+      v <-+        foldDyn ($) (_textInputConfig_initialValue cfg) $+          mergeWith+            (.)+            [ valueChangedByCaller+            , valueChangedByUI             ]-      v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)-        [ valueChangedByCaller-        , valueChangedByUI-        ]       click <- mouseDown V.BLeft -      -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)-      let toCursorAttrs attr = V.withStyle attr V.reverseVideo-          rowInputDyn = (,,)-            <$> dw-            <*> (mapZipper <$> _textInputConfig_display cfg <*> v)-            <*> f-          toDisplayLines attr (w, s, x)  =-            let c = if x then toCursorAttrs attr else attr-            in displayLines w attr c s-      attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)-      let rows = ffor2 attrDyn rowInputDyn toDisplayLines-          img = images . _displayLines_spans <$> rows+      -- The layout rows carry a marker tag instead of a resolved+      -- attribute. The tag is @False@ for ordinary spans and @True@+      -- for the cursor span (which exists only while focused).+      -- Rendering maps those tags onto the /current/ theme attribute+      -- and cursor style. A theme change then re-renders without any+      -- input event.+      let rows =+            (\w s x -> displayLinesWithAlignment (_textInputConfig_alignment cfg) w False x s)+              <$> dw+              <*> (mapZipper <$> _textInputConfig_display cfg <*> v)+              <*> f+          img =+            ( \dl attr cursorStyle ->+                images . fmap (fmap (retagSpan attr cursorStyle)) $ _displayLines_spans dl+            )+              <$> current rows+              <*> bt+              <*> (fmap _theme_textInputCursor th)       y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows       let newScrollTop :: Int -> (Int, Int) -> Int           newScrollTop st (h, cursorY)@@ -117,13 +147,20 @@             | otherwise = st       let hy = attachWith newScrollTop scrollTop $ updated $ zipDyn dh y       scrollTop <- hold 0 hy-      tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop-  return $ TextInput-    { _textInput_value = value <$> v-    , _textInput_userInput = attachWith (&) (current v) valueChangedByUI-    , _textInput_lines = length . _displayLines_spans <$> rows-    }+      tellImages $ (\imgs st -> (: []) . V.vertCat $ drop st imgs) <$> img <*> scrollTop+  return $+    TextInput+      { _textInput_value = value <$> v+      , _textInput_userInput = attachWith (&) (current v) valueChangedByUI+      , _textInput_lines = length . _displayLines_spans <$> rows+      } +-- | Resolve a tagged span against the current theme. A cursor span+-- applies the text-input cursor style over the theme attribute.+retagSpan :: V.Attr -> Style -> Span Bool -> Span V.Attr+retagSpan attr cursorStyle (Span isCursor txt) =+  Span (if isCursor then applyAttr cursorStyle attr else attr) txt+ -- | A widget that allows multiline text input multilineTextInput   :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)@@ -131,30 +168,54 @@   -> m (TextInput t) multilineTextInput cfg = do   i <- input-  textInput $ cfg-    { _textInputConfig_modify = mergeWith (.)-      [ fforMaybe i $ \case-          V.EvKey V.KEnter [] -> Just $ insert "\n"-          _ -> Nothing-      , _textInputConfig_modify cfg-      ]-    }+  textInput $+    cfg+      { _textInputConfig_modify =+          mergeWith+            (.)+            [ fforMaybe i $ \case+                V.EvKey V.KEnter [] -> Just $ insert "\n"+                _ -> Nothing+            , _textInputConfig_modify cfg+            ]+      }  -- | Wraps a 'textInput' or 'multilineTextInput' in a tile. Uses -- the computed line count to greedily size the tile when vertically -- oriented, and uses the fallback width when horizontally oriented.+-- The size is sampled after post-build and after content or width+-- changes. This avoids demanding the recursive layout solution during+-- construction. textInputTile-  :: (MonadFix m, MonadHold t m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)+  :: (MonadFix m, MonadHold t m, PostBuild t m, PerformEvent t m, MonadSample t (Performable m), HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)   => m (TextInput t)   -> Dynamic t Int   -> m (TextInput t) textInputTile txt width = do+  -- The tile's size depends on its own region (the line count is a+  -- function of the allocated width). The orientation is itself part+  -- of the solved layout. Reading those during construction or during+  -- a frame therefore deadlocks the layout knot. Seed a constant size+  -- instead. Re-read the true size in post-frame IO: at post-build and+  -- after every line-count or width change. The result is+  -- deduplicated, so a stable size cannot re-trigger the solver.   o <- askOrientation+  pb <- getPostBuild   rec t <- tile (Constraint_Fixed <$> sz) txt-      let sz = join $ ffor o $ \case-            Orientation_Column -> _textInput_lines t-            Orientation_Row -> width-  return t+      let readSize = do+            occ <- sample (current o)+            case occ of+              Orientation_Column -> sample (current (_textInput_lines t))+              Orientation_Row -> sample (current width)+          sizeMayChange =+            leftmost+              [ () <$ pb+              , () <$ updated (_textInput_lines t)+              , () <$ updated width+              ]+      reads <- performEvent $ ffor sizeMayChange $ \_ -> readSize+      sz <- holdUniqDyn =<< holdDyn 1 reads+  pure t  -- | Turn a set of display line rows into a list of images (one per line) images :: [[Span V.Attr]] -> [V.Image]@@ -170,11 +231,15 @@  -- | Default vty event handler for text inputs updateTextZipper-  :: Int -- ^ Tab width-  -> Int -- ^ Page size-  -> V.Event -- ^ The vty event to handle-  -> TextZipper -- ^ The zipper to modify+  :: Int+  -- ^ Tab width+  -> Int+  -- ^ Page size+  -> V.Event+  -- ^ The vty event to handle   -> TextZipper+  -- ^ The zipper to modify+  -> TextZipper updateTextZipper tabWidth pageSize ev = case ev of   -- Special characters   V.EvKey (V.KChar '\t') [] -> tab tabWidth@@ -196,3 +261,11 @@   V.EvKey V.KPageUp [] -> pageUp pageSize   V.EvKey V.KPageDown [] -> pageDown pageSize   _ -> id++-- | 'True' unless the event is a (possibly shifted) Tab keypress. Used to keep+-- Tab available for focus cycling when '_textInputConfig_acceptTab' is off.+notTabKey :: V.Event -> Bool+notTabKey = \case+  V.EvKey (V.KChar '\t') _ -> False+  V.EvKey V.KBackTab _ -> False+  _ -> True
src/Reflex/Vty/Widget/Layout.hs view
@@ -1,34 +1,34 @@-{-|-Module: Reflex.Vty.Widget.Layout-Description: Monad transformer and tools for arranging widgets and building screen layouts--}-{-# Language UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-} +-- |+-- Module: Reflex.Vty.Widget.Layout+-- Description: Monad transformer and tools for arranging widgets and building screen layouts module Reflex.Vty.Widget.Layout where -import Control.Applicative (liftA2)-import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)-import Control.Monad.Morph-import Control.Monad.NodeId (MonadNodeId(..), NodeId)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix+import Control.Monad.Morph import Control.Monad.Reader import Data.List (mapAccumL) import Data.Map.Ordered (OMap) import qualified Data.Map.Ordered as OMap import Data.Maybe (fromMaybe, isNothing) import Data.Ratio ((%))-import Data.Semigroup (First(..))+import Data.Semigroup (First (..)) import Data.Set.Ordered (OSet) import qualified Data.Set.Ordered as OSet import qualified Graphics.Vty as V- import Reflex import Reflex.Host.Class (MonadReflexCreateTrigger)++import Control.Monad.NodeId (MonadNodeId (..), NodeId) import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse  -- * Focus+ --+ -- $focus -- -- The focus monad tracks which element is currently focused and processes@@ -48,7 +48,7 @@  -- | An ordered set of focus identifiers. The order here determines the order -- in which focus cycles between focusable elements.-newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }+newtype FocusSet = FocusSet {unFocusSet :: OSet FocusId}  instance Semigroup FocusSet where   FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b@@ -63,9 +63,13 @@ -- ** Changing focus state  -- | Operations that change the currently focused element.-data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS')-             | Refocus_Id FocusId -- ^ Focus a particular element-             | Refocus_Clear -- ^ Remove focus from all elements+data Refocus+  = -- | Shift the focus by a certain number of positions (see 'shiftFS')+    Refocus_Shift Int+  | -- | Focus a particular element+    Refocus_Id FocusId+  | -- | Remove focus from all elements+    Refocus_Clear  -- | Given a 'FocusSet', a currently focused element, and a number of positions -- to move by, determine the newly focused element.@@ -81,43 +85,52 @@ class (Monad m, Reflex t) => HasFocus t m | m -> t where   -- | Create a focusable element.   makeFocus :: m FocusId+   -- | Emit an 'Event' of requests to change the focus.   requestFocus :: Event t Refocus -> m ()+   -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused.   isFocused :: FocusId -> m (Dynamic t Bool)+   -- | Run an action, additionally returning the focusable elements it produced.   subFoci :: m a -> m (a, Dynamic t FocusSet)+   -- | Get a 'Dynamic' of the currently focused element identifier.   focusedId :: m (Dynamic t (Maybe FocusId))  -- | A monad transformer that keeps track of the set of focusable elements and -- which, if any, are currently focused, and allows focus requests. newtype Focus t m a = Focus-  { unFocus :: DynamicWriterT t FocusSet-      (ReaderT (Dynamic t (Maybe FocusId))-        (EventWriterT t (First Refocus) m)) a+  { unFocus+      :: DynamicWriterT+           t+           FocusSet+           ( ReaderT+               (Dynamic t (Maybe FocusId))+               (EventWriterT t (First Refocus) m)+           )+           a   }   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor+    , HasDisplayRegion t     , Monad+    , MonadCatch+    , MonadFix     , MonadHold t+    , MonadIO+    , MonadMask+    , MonadNodeId+    , MonadReflexCreateTrigger t     , MonadSample t-    , MonadFix-    , TriggerEvent t-    , PerformEvent t+    , MonadThrow     , NotReady t-    , MonadReflexCreateTrigger t-    , HasDisplayRegion t+    , PerformEvent t     , PostBuild t-    , MonadNodeId-    , MonadIO-    , MonadCatch-    , MonadThrow-    , MonadMask+    , TriggerEvent t     ) - instance MonadTrans (Focus t) where   lift = Focus . lift . lift . lift @@ -135,11 +148,21 @@  instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where   mapImages f = hoist (mapImages f)+  captureImages (Focus x) = Focus $ do+    ((a, fs), images) <- lift $ captureImages $ runDynamicWriterT x+    tellDyn fs+    return (a, images)  instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)  instance (HasTheme t m, Monad m) => HasTheme t (Focus t m) +instance (HasColorProfile t m, Monad m) => HasColorProfile t (Focus t m)++instance HasCursor t m => HasCursor t (Focus t m)++instance HasScreenMode t m => HasScreenMode t (Focus t m)+ instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where   makeFocus = do     fid <- FocusId <$> lift getNextNodeId@@ -169,9 +192,10 @@     f (fs, rf) mf = case getFirst rf of       Refocus_Clear -> Nothing       Refocus_Id fid -> Just fid-      Refocus_Shift n -> if n < 0 && isNothing mf-        then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n-        else shiftFS fs mf n+      Refocus_Shift n ->+        if n < 0 && isNothing mf+          then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n+          else shiftFS fs mf n  -- | Runs an action in the focus monad, providing it with information about -- whether any of the foci created within it are focused.@@ -182,9 +206,14 @@ anyChildFocused f = do   fid <- focusedId   rec (a, fs) <- subFoci (f b)-      let b = liftA2 (\foc s -> case foc of-            Nothing -> False-            Just f' -> OSet.member f' $ unFocusSet s) fid fs+      let b =+            liftA2+              ( \foc s -> case foc of+                  Nothing -> False+                  Just f' -> OSet.member f' $ unFocusSet s+              )+              fid+              fs   pure a  -- ** Focus controls@@ -198,7 +227,9 @@   requestFocus $ Refocus_Shift <$> leftmost [fwd, back]  -- * Layout+ --+ -- $layout -- The layout monad keeps track of a tree of elements, each having its own -- layout constraints and orientation. Given the available rendering space, it@@ -209,16 +240,16 @@ -- -- - 'axis', which lays out its children in a particular orientation, and -- - 'region', which "claims" some part of the screen according to its constraints---  -- ** Layout restrictions  -- *** Constraints  -- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')-data Constraint = Constraint_Fixed Int-                | Constraint_Min Int-  deriving (Show, Read, Eq, Ord)+data Constraint+  = Constraint_Fixed Int+  | Constraint_Min Int+  deriving (Eq, Ord, Read, Show)  -- | Shorthand for constructing a fixed constraint fixed@@ -243,9 +274,10 @@ -- *** Orientation  -- | The main-axis orientation of a 'Layout' widget-data Orientation = Orientation_Column-                 | Orientation_Row-  deriving (Show, Read, Eq, Ord)+data Orientation+  = Orientation_Column+  | Orientation_Row+  deriving (Eq, Ord, Read, Show)  -- | Create a row-oriented 'axis' row@@ -271,7 +303,7 @@  -- | An ordered, indexed collection of 'LayoutTree's representing information -- about the children of some widget.-newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }+newtype LayoutForest a = LayoutForest {unLayoutForest :: OMap NodeId (LayoutTree a)}   deriving (Show)  instance Semigroup (LayoutForest a) where@@ -313,15 +345,22 @@         Orientation_Row -> _region_width r0         Orientation_Column -> _region_height r0       sizes = computeEdges $ computeSizes extent a-      chunks = [ (nodeId, solve o1 r1 f)-               | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes-               , let r1 = chunk o0 r0 sz-               ]+      chunks =+        [ (nodeId, solve o1 r1 f)+        | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes+        , let r1 = chunk o0 r0 sz+        ]   in LayoutTree (r0, o0) $ fromListLF chunks   where     computeEdges :: [(a, Int)] -> [(a, (Int, Int))]-    computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->-      (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)+    computeEdges =+      ($ [])+        . fst+        . foldl+          ( \(m, offset) (a, sz) ->+              (((a, (offset, sz)) :) . m, sz + offset)+          )+          (id, 0)     computeSizes       :: Int       -> [(a, Constraint)]@@ -332,22 +371,27 @@       let minTotal = sum $ ffor constraints $ \case             (_, Constraint_Fixed n) -> n             (_, Constraint_Min n) -> n-      -- The leftover space is the area we can allow stretchable items to-      -- expand into+          -- The leftover space is the area we can allow stretchable items to+          -- expand into           leftover = max 0 (available - minTotal)-      -- The number of stretchable items that will try to share some of the-      -- leftover space+          -- The number of stretchable items that will try to share some of the+          -- leftover space           numStretch = length $ filter (isMin . snd) constraints-      -- Space to allocate to the stretchable items (this is the same for all-      -- items and there may still be additional leftover space that will have-      -- to be unevenly distributed)+          -- Space to allocate to the stretchable items (this is the same for all+          -- items and there may still be additional leftover space that will have+          -- to be unevenly distributed)           szStretch = floor $ leftover % max numStretch 1-      -- Remainder of available space after even distribution. This extra space-      -- will be distributed to as many stretchable widgets as possible.+          -- Remainder of available space after even distribution. This extra space+          -- will be distributed to as many stretchable widgets as possible.           adjustment = max 0 $ available - minTotal - szStretch * numStretch-      in snd $ mapAccumL (\adj (a, c) -> case c of-          Constraint_Fixed n -> (adj, (a, n))-          Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints+      in snd $+           mapAccumL+             ( \adj (a, c) -> case c of+                 Constraint_Fixed n -> (adj, (a, n))+                 Constraint_Min n -> (max 0 (adj - 1), (a, n + szStretch + signum adj))+             )+             adjustment+             constraints     isMin (Constraint_Min _) = True     isMin _ = False @@ -355,53 +399,61 @@ -- and main-axis size of the chunk. chunk :: Orientation -> Region -> (Int, Int) -> Region chunk o r (offset, sz) = case o of-  Orientation_Column -> r-    { _region_top = _region_top r + offset-    , _region_height = sz-    }-  Orientation_Row -> r-    { _region_left = _region_left r + offset-    , _region_width = sz-    }+  Orientation_Column ->+    r+      { _region_top = _region_top r + offset+      , _region_height = sz+      }+  Orientation_Row ->+    r+      { _region_left = _region_left r + offset+      , _region_width = sz+      }  -- ** The layout monad  -- | A class of operations for creating screen layouts. class Monad m => HasLayout t m | m -> t where   -- | Starts a parent element in the current layout with the given size-  -- constraint, which lays out its children according to the provided-  -- orientation.+  --   constraint, which lays out its children according to the provided+  --   orientation.   axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a+   -- | Creates a child element in the current layout with the given size-  -- constraint, returning the 'Region' that the child element is allocated.+  --   constraint, returning the 'Region' that the child element is allocated.   region :: Dynamic t Constraint -> m (Dynamic t Region)+   -- | Returns the orientation of the containing 'axis'.   askOrientation :: m (Dynamic t Orientation)  -- | A monad transformer that collects layout constraints and provides a layout -- solution that satisfies those constraints. newtype Layout t m a = Layout-  { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))-      (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a+  { unLayout+      :: DynamicWriterT+           t+           (LayoutForest (Constraint, Orientation))+           (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m)+           a   }   deriving-    ( Functor-    , Applicative+    ( Applicative+    , Functor     , HasDisplayRegion t     , Monad+    , MonadCatch     , MonadFix     , MonadHold t     , MonadIO+    , MonadMask     , MonadNodeId     , MonadReflexCreateTrigger t     , MonadSample t+    , MonadThrow     , NotReady t     , PerformEvent t     , PostBuild t     , TriggerEvent t-    , MonadCatch-    , MonadThrow-    , MonadMask     )  instance MonadTrans (Layout t) where@@ -437,11 +489,22 @@  instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where   mapImages f = hoistRunLayout (mapImages f)+  captureImages (Layout x) = Layout $ do+    y <- ask+    ((a, w), images) <- lift $ lift $ captureImages $ flip runReaderT y $ runDynamicWriterT x+    tellDyn w+    pure (a, images)  instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)  instance (HasTheme t m, Monad m) => HasTheme t (Layout t m) +instance (HasColorProfile t m, Monad m) => HasColorProfile t (Layout t m)++instance HasCursor t m => HasCursor t (Layout t m)++instance HasScreenMode t m => HasScreenMode t (Layout t m)+ instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where   axis o c (Layout x) = Layout $ do     nodeId <- getNextNodeId@@ -489,7 +552,9 @@   runLayout (pure Orientation_Column) r f  -- * The tile "window manager"+ --+ -- $tiling -- Generally HasLayout and HasFocus are used together to build a user -- interface. These functions check the available screen size and initialize@@ -554,4 +619,5 @@   -> m a grout c w = do   r <- region c-  pane r (pure True) w+  foc <- focus -- Inherit the ambient focus+  pane r foc w
src/Reflex/Vty/Widget/Scroll.hs view
@@ -1,23 +1,39 @@-{-| Description: Widgets that scroll when their contents don't fit--}+-- | Description: Widgets that scroll when their contents don't fit module Reflex.Vty.Widget.Scroll where  import Control.Monad.Fix+import Control.Monad.IO.Class import Data.Default+import Data.Functor (void)+import qualified Data.List as List import qualified Graphics.Vty as V import Reflex+ import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse  -- | Configuration options for automatic scroll-to-bottom behavior data ScrollToBottom-  = ScrollToBottom_Always-  -- ^ Always scroll to the bottom on new output-  | ScrollToBottom_Maintain-  -- ^ Scroll down with new output only when, prior to the new output being-  -- added, the widget was scrolled all the way to the bottom.+  = -- | Always scroll to the bottom on new output+    ScrollToBottom_Always+  | -- | Scroll down with new output only when, prior to the new output being+    --     added, the widget was scrolled all the way to the bottom.+    ScrollToBottom_Maintain   deriving (Eq, Ord, Show) +-- | Controls when the scrollbar is visible.+data ScrollbarVisibility+  = -- | Always show gutter (track) + thumb when content overflows+    ScrollbarAlways+  | -- | Show thumb only (no gutter) when content overflows+    ScrollbarThumbOnly+  | -- | Show thumb only while actively scrolling; hides on the next+    -- non-scroll input. No gutter.+    ScrollbarWhileScrolling+  | -- | Never show scrollbar; child gets full width+    ScrollbarHidden+  deriving (Eq, Ord, Show)+ -- | Configuration for the scrollable element. Controls scroll behavior. data ScrollableConfig t = ScrollableConfig   { _scrollableConfig_scrollBy :: Event t Int@@ -28,14 +44,16 @@   -- ^ The initial scroll position   , _scrollableConfig_scrollToBottom :: Behavior t (Maybe ScrollToBottom)   -- ^ How the scroll position should be adjusted as new content is added+  , _scrollableConfig_scrollbarVisibility :: ScrollbarVisibility+  -- ^ When to show the scrollbar   }  instance Reflex t => Default (ScrollableConfig t) where-  def = ScrollableConfig never never ScrollPos_Top (pure Nothing)+  def = ScrollableConfig never never ScrollPos_Top (pure Nothing) ScrollbarThumbOnly  -- | The scroll position data ScrollPos = ScrollPos_Top | ScrollPos_Line Int | ScrollPos_Bottom-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show)  -- | The output of a 'scrollable', indicating its current scroll position. data Scrollable t = Scrollable@@ -47,49 +65,108 @@ -- | Scrollable widget. The output exposes the current scroll position and -- total number of lines (including those that are hidden) scrollable-  :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)+  :: forall t m a+   . ( Reflex t+     , MonadHold t m+     , MonadFix m+     , PerformEvent t m+     , TriggerEvent t m+     , MonadIO (Performable m)+     , HasDisplayRegion t m+     , HasInput t m+     , HasImageWriter t m+     , HasTheme t m+     )   => ScrollableConfig t-  -> (m (Behavior t V.Image, Event t ()))-  -> m (Scrollable t)-scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do-  (img, update) <- mkImg-  let sz = V.imageHeight <$> img+  -> (m (Event t (), a))+  -> m (Scrollable t, a)+scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend sbVisibility) mkImg = do+  dh <- displayHeight+  dw <- displayWidth+  bt <- themeAttr   kup <- key V.KUp   kdown <- key V.KDown   m <- mouseScroll   let requestedScroll :: Event t Int-      requestedScroll = leftmost-        [ 1 <$ kdown-        , (-1) <$ kup-        , ffor m $ \case-            ScrollDirection_Up -> (-1)-            ScrollDirection_Down -> 1-        , scrollBy-        ]-  dh <- displayHeight-  lineIndex <- foldDynMaybe ($) startingPos $ leftmost-    [ (\((totalLines, h), d) sp -> Just $ scrollByLines sp totalLines h d) <$> attach ((,) <$> sz <*> current dh) requestedScroll-    , (\((totalLines, h), newScrollPosition) _ -> Just $ case newScrollPosition of-        ScrollPos_Line n -> scrollToLine totalLines h n-        ScrollPos_Top -> ScrollPos_Top-        ScrollPos_Bottom -> ScrollPos_Bottom-      ) <$> attach ((,) <$> sz <*> current dh) scrollTo-    , (\cfg sp -> case cfg of-        Just ScrollToBottom_Always -> case sp of-          ScrollPos_Bottom -> Nothing-          _ -> Just ScrollPos_Bottom-        _ -> Nothing) <$> tag onAppend update-    ]-  let imgsToTell height scrollPos totalLines images = case scrollPos of-        ScrollPos_Bottom -> V.translateY ((-1) * max 0 (totalLines - height)) images-        ScrollPos_Top -> images -- take height images-        ScrollPos_Line n -> V.translateY ((-1) * n) images-  tellImages $ fmap (:[]) $ imgsToTell <$> current dh <*> current lineIndex <*> sz <*> img-  return $ Scrollable-    { _scrollable_scrollPosition = current lineIndex-    , _scrollable_totalLines = sz-    , _scrollable_scrollHeight = current dh-    }+      requestedScroll =+        leftmost+          [ 1 <$ kdown+          , (-1) <$ kup+          , ffor m $ \case+              ScrollDirection_Up -> (-1)+              ScrollDirection_Down -> 1+          , scrollBy+          ]+      widthTransform = case sbVisibility of+        ScrollbarHidden -> id+        _ -> fmap shrinkRegionForScrollbar+      heightTransform = fmap (\r -> r {_region_height = largeScrollHeight})+        where+          largeScrollHeight = 10000+  scrollingNow <- case sbVisibility of+    ScrollbarWhileScrolling -> do+      let scrollActivity = void requestedScroll+      hideAfterQuiet <- debounce 1.5 scrollActivity+      hold False $ leftmost [True <$ scrollActivity, False <$ hideAfterQuiet]+    _ -> pure (pure True)+  rec ((update, a), imgs) <- captureImages $ localLayoutRegion heightTransform $ localRegion widthTransform $ localInput (translateMouseEvents translation) $ mkImg+      let sz = List.foldl' max 0 . fmap V.imageHeight <$> imgs+      lineIndex <-+        foldDynMaybe ($) startingPos $+          leftmost+            [ (\(totalLines, (h, d)) sp -> Just $ scrollByLines sp totalLines h d) <$> attach sz (attachPromptlyDyn dh requestedScroll)+            , ( \(totalLines, (h, newScrollPosition)) _ -> Just $ case newScrollPosition of+                  ScrollPos_Line n -> scrollToLine totalLines h n+                  ScrollPos_Top -> ScrollPos_Top+                  ScrollPos_Bottom -> ScrollPos_Bottom+              )+                <$> attach sz (attachPromptlyDyn dh scrollTo)+            , ( \cfg sp -> case cfg of+                  Just ScrollToBottom_Always -> case sp of+                    ScrollPos_Bottom -> Nothing+                    _ -> Just ScrollPos_Bottom+                  _ -> Nothing+              )+                <$> tag onAppend update+            ]+      let translation =+            calculateTranslation+              <$> current dh+              <*> current lineIndex+              <*> sz+  let cropImages dy images = cropFromTop dy <$> images+  tellImages $ cropImages <$> translation <*> imgs+  let sbImgs = scrollbarImages sbVisibility <$> bt <*> current dh <*> sz <*> translation <*> current dw+      sbGated = case sbVisibility of+        ScrollbarWhileScrolling ->+          (\vis imgs' -> if vis then imgs' else []) <$> scrollingNow <*> sbImgs+        _ -> sbImgs+  tellImages sbGated+  return $+    (,a) $+      Scrollable+        { _scrollable_scrollPosition = current lineIndex+        , _scrollable_totalLines = sz+        , _scrollable_scrollHeight = current dh+        }+  where+    shrinkRegionForScrollbar (Region l t w h) = Region l t (max 0 (w - 1)) h+    cropFromTop :: Int -> V.Image -> V.Image+    cropFromTop rows i =+      V.cropTop (max 0 $ V.imageHeight i - rows) i+    calculateTranslation height scrollPos totalLines = case scrollPos of+      ScrollPos_Bottom -> max 0 (totalLines - height)+      ScrollPos_Top -> 0+      -- A stored line can be past the last page after the content+      -- shrinks or the viewport grows. The rendered offset clamps to+      -- the last page, so no blank over-scroll is shown.+      ScrollPos_Line n -> min (max 0 n) (max 0 (totalLines - height))+    translateMouseEvents translation vtyEvent =+      let e = attach translation vtyEvent+      in ffor e $ \case+           (dy, V.EvMouseDown x y btn mods) -> V.EvMouseDown x (y + dy) btn mods+           (dy, V.EvMouseUp x y btn) -> V.EvMouseUp x (y + dy) btn+           (_, otherEvent) -> otherEvent  -- | Modify the scroll position by the given number of lines scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos@@ -103,8 +180,47 @@  -- | Scroll to a particular line scrollToLine :: Int -> Int -> Int -> ScrollPos-scrollToLine totalLines height newPos = if-  | totalLines <= height -> ScrollPos_Top-  | newPos == 0 -> ScrollPos_Top-  | newPos + height >= totalLines -> ScrollPos_Bottom-  | otherwise -> ScrollPos_Line newPos+scrollToLine totalLines height newPos =+  if+    | totalLines <= height -> ScrollPos_Top+    | newPos <= 0 -> ScrollPos_Top+    | newPos + height >= totalLines -> ScrollPos_Bottom+    | otherwise -> ScrollPos_Line newPos++-- | Build the scrollbar images (gutter + thumb). Returns empty list when+-- the scrollbar is hidden, the content fits within the viewport, or the+-- viewport is too narrow. In 'ScrollbarThumbOnly' and+-- 'ScrollbarWhileScrolling' modes, only the thumb is drawn (no gutter).+scrollbarImages+  :: ScrollbarVisibility+  -> V.Attr+  -- ^ Attribute for both gutter and thumb+  -> Int+  -- ^ Viewport height+  -> Int+  -- ^ Total content lines+  -> Int+  -- ^ Current scroll offset (lines scrolled from top)+  -> Int+  -- ^ Viewport width+  -> [V.Image]+scrollbarImages visibility attr vpHeight totalLines scrollLine vpWidth+  | visibility == ScrollbarHidden = []+  | totalLines <= vpHeight = []+  | vpWidth <= 1 = []+  | otherwise =+      let maxScroll = max 1 (totalLines - vpHeight)+          thumbLen = max 1 (vpHeight * vpHeight `div` totalLines)+          thumbTrack = vpHeight - thumbLen+          thumbTop = min thumbTrack (scrollLine * thumbTrack `div` maxScroll)+          gutterCol = vpWidth - 1+          thumbImg =+            withinImage (Region gutterCol thumbTop 1 thumbLen) $+              V.charFill attr '█' 1 thumbLen+          gutterImgs = case visibility of+            ScrollbarAlways ->+              [ withinImage (Region gutterCol 0 1 vpHeight) $+                  V.charFill attr '░' 1 vpHeight+              ]+            _ -> []+      in gutterImgs ++ [thumbImg]
src/Reflex/Vty/Widget/Split.hs view
@@ -1,45 +1,78 @@-{-|-  Description: Widgets that split the display vertically or horizontally.--}+-- |+--   Description: Widgets that split the display vertically or horizontally. module Reflex.Vty.Widget.Split where -import Control.Applicative import Control.Monad.Fix import Graphics.Vty as V import Reflex+ import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse  -- | A split of the available space into two parts with a draggable separator. -- Starts with half the space allocated to each, and the first pane has focus. -- Clicking in a pane switches focus.-splitVDrag :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)+splitVDrag+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)   => m ()   -> m a   -> m b-  -> m (a,b)+  -> m (a, b) splitVDrag wS wA wB = do-  dh <- displayHeight-  dw <- displayWidth-  h0 <- sample $ current dh -- TODO+  dh <- viewportHeight+  dw <- viewportWidth   dragE <- drag V.BLeft-  let splitter0 = h0 `div` 2-  rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]-      splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]-      splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->-        fromIntegral x / max 1 (fromIntegral h)-      let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $-            \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->-              if splitterY == fromY then Just (toY, end) else Nothing-          regA = Region 0 0 <$> dw <*> splitterPos-          regS = Region 0 <$> splitterPos <*> dw <*> 1-          regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1)-          resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $-            \(frac, h) -> round (frac * fromIntegral h)-      focA <- holdDyn True $ leftmost-        [ True <$ mA-        , False <$ mB-        ]+  rec -- The divider's displayed position comes from the current+      -- height and the user-chosen fraction, never from a sampled+      -- initial height. While no drag has happened, the divider sits+      -- at half the height. The position is always clamped, so the+      -- divider row itself stays inside the viewport.+      let displayedPos =+            ( \h mf ->+                let raw = case mf of+                      Nothing -> h `div` 2+                      Just frac -> round (frac * fromIntegral (max 1 h))+                in min (max 0 raw) (max 0 (h - 1))+            )+              <$> dh+              <*> userFraction+          startsOnDivider =+            ffilter id $+              ffor (attach (current displayedPos) dragE) $+                \(p, Drag (_, fromY) _ _ _ st) -> st == DragStart && p == fromY+          dragEnded = ffilter (\d -> _drag_state d == DragEnd) dragE+      -- Drag ownership is decided at DragStart, against the pre-event+      -- divider position, and kept until DragEnd. Drags that start+      -- elsewhere are ignored.+      dragOwned <-+        holdDyn False $+          leftmost+            [ True <$ startsOnDivider+            , False <$ dragEnded+            ]+      userFraction <-+        holdDyn Nothing $+          fforMaybe (attach (current dragOwned) (attach (current dh) dragE)) $+            \(owned, (h, Drag _ (_, toY) _ _ _)) ->+              if not owned+                then Nothing+                else+                  Just+                    ( Just+                        ( fromIntegral (min (max 0 toY) (max 0 (h - 1)))+                            / max 1 (fromIntegral h)+                            :: Double+                        )+                    )+      let regA = Region 0 0 <$> dw <*> displayedPos+          regS = Region 0 <$> displayedPos <*> dw <*> 1+          regB = Region 0 <$> (displayedPos + 1) <*> dw <*> (dh - displayedPos - 1)+      focA <-+        holdDyn True $+          leftmost+            [ True <$ mA+            , False <$ mB+            ]       (mA, rA) <- pane regA focA $ withMouseDown wA       pane regS (pure False) wS       (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB@@ -52,40 +85,42 @@  -- | A plain split of the available space into vertically stacked panes. -- No visual separator is built in here.-splitV :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)-       => Dynamic t (Int -> Int)-       -- ^ Function used to determine size of first pane based on available size-       -> Dynamic t (Bool, Bool)-       -- ^ How to focus the two sub-panes, given that we are focused.-       -> m a-       -- ^ Widget for first pane-       -> m b-       -- ^ Widget for second pane-       -> m (a,b)+splitV+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)+  => Dynamic t (Int -> Int)+  -- ^ Function used to determine size of first pane based on available size+  -> Dynamic t (Bool, Bool)+  -- ^ How to focus the two sub-panes, given that we are focused.+  -> m a+  -- ^ Widget for first pane+  -> m b+  -- ^ Widget for second pane+  -> m (a, b) splitV sizeFunD focD wA wB = do-  dw <- displayWidth-  dh <- displayHeight+  dw <- viewportWidth+  dh <- viewportHeight   let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh)       regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA)   ra <- pane regA (fst <$> focD) wA   rb <- pane regB (snd <$> focD) wB-  return (ra,rb)+  return (ra, rb)  -- | A plain split of the available space into horizontally stacked panes. -- No visual separator is built in here.-splitH :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)-       => Dynamic t (Int -> Int)-       -- ^ Function used to determine size of first pane based on available size-       -> Dynamic t (Bool, Bool)-       -- ^ How to focus the two sub-panes, given that we are focused.-       -> m a-       -- ^ Widget for first pane-       -> m b-       -- ^ Widget for second pane-       -> m (a,b)+splitH+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)+  => Dynamic t (Int -> Int)+  -- ^ Function used to determine size of first pane based on available size+  -> Dynamic t (Bool, Bool)+  -- ^ How to focus the two sub-panes, given that we are focused.+  -> m a+  -- ^ Widget for first pane+  -> m b+  -- ^ Widget for second pane+  -> m (a, b) splitH sizeFunD focD wA wB = do-  dw <- displayWidth-  dh <- displayHeight+  dw <- viewportWidth+  dh <- viewportHeight   let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh       regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh   liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
src/Reflex/Vty/Widget/Text.hs view
@@ -1,30 +1,32 @@-{-|-  Description: Text- and character-rendering widgets--}+-- |+--   Description: Text- and character-rendering widgets module Reflex.Vty.Widget.Text where  import Control.Monad.Fix+import Control.Monad.IO.Class import Data.Default import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Zipper as TZ import qualified Graphics.Vty as V import Reflex++import Data.Text.Zipper as TZ+import Reflex.Vty.Style (mergeAttr) import Reflex.Vty.Widget import Reflex.Vty.Widget.Scroll  -- | Fill the background with a particular character. fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m () fill bc = do-  dw <- displayWidth-  dh <- displayHeight-  bt <- theme+  dw <- viewportWidth+  dh <- viewportHeight+  bt <- themeAttr   let fillImg =         (\attr w h c -> [V.charFill attr c w h])-        <$> bt-        <*> current dw-        <*> current dh-        <*> bc+          <$> bt+          <*> current dw+          <*> current dh+          <*> bc   tellImages fillImg  -- | Configuration options for displaying "rich" text@@ -35,8 +37,6 @@ instance Reflex t => Default (RichTextConfig t) where   def = RichTextConfig $ pure V.defAttr ---- TODO delete this and use new local theming -- | A widget that displays text with custom time-varying attributes richText   :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)@@ -45,25 +45,54 @@   -> m () richText cfg t = do   dw <- displayWidth-  let img = (\w a s -> [wrapText w a s])-        <$> current dw-        <*> _richTextConfig_attributes cfg-        <*> t+  bt <- themeAttr+  let attrs = mergeAttr <$> bt <*> _richTextConfig_attributes cfg+      img =+        (\w a s -> [wrapTextImage TextAlignment_Left w a s])+          <$> current dw+          <*> attrs+          <*> t   tellImages img-  where-    wrapText maxWidth attrs = V.vertCat-      . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)-      . T.split (=='\n')  -- | Renders text, wrapped to the container width text   :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)   => Behavior t Text   -> m ()-text t = do-  bt <- theme-  richText (RichTextConfig bt) t+text = textWithAlignment TextAlignment_Left +-- | Like 'text' but with explicit 'TextAlignment'. The alignment is+-- applied to each logical line after wrapping; see+-- 'Data.Text.Zipper.wrapWithOffsetAndAlignment' for details.+textWithAlignment+  :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)+  => TextAlignment+  -> Behavior t Text+  -> m ()+textWithAlignment alignment t = do+  dw <- displayWidth+  bt <- themeAttr+  let img =+        (\w a s -> [wrapTextImage alignment w a s])+          <$> current dw+          <*> bt+          <*> t+  tellImages img++-- | Pure helper: wrap a 'Text' to the given width with the given+-- 'TextAlignment' and render it as a single 'V.Image' using the supplied+-- 'V.Attr'. Newlines split logical lines; each logical line is wrapped and+-- aligned independently.+wrapTextImage :: TextAlignment -> Int -> V.Attr -> Text -> V.Image+wrapTextImage alignment maxWidth attrs =+  V.vertCat+    . concatMap (fmap (V.string attrs . T.unpack) . wrapLine)+    . T.split (== '\n')+  where+    wrapLine =+      map _wrappedLines_text+        . wrapWithOffsetAndAlignment alignment maxWidth 0+ -- | Renders any behavior whose value can be converted to -- 'String' as text display@@ -75,11 +104,11 @@ -- | Scrollable text widget. The output exposes the current scroll position and -- total number of lines (including those that are hidden) scrollableText-  :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m, PostBuild t m)+  :: forall t m+   . (Reflex t, MonadHold t m, MonadFix m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m, PostBuild t m)   => ScrollableConfig t   -> Dynamic t Text   -> m (Scrollable t)-scrollableText cfg t = do-  scrollable cfg $ do-    ((), images) <- runImageWriter $ text (current t)-    pure $ (V.vertCat <$> images, () <$ updated t)+scrollableText cfg t = fmap fst $ scrollable cfg $ do+  text (current t)+  pure (() <$ updated t, ())
+ test/Control/Monad/NodeIdSpec.hs view
@@ -0,0 +1,29 @@+-- |+-- Description: Uniqueness of node identifiers within one allocation scope.+--+-- Identifiers are unique only within a single 'runNodeIdT' scope.+-- This includes allocations during tree replacement; the widget-level+-- specs exercise those through the production 'Adjustable' instances.+-- The printed representation, global uniqueness, and the first+-- identifier value are unspecified.+module Control.Monad.NodeIdSpec (spec) where++import Control.Monad (replicateM)+import Data.List (nub)+import Test.Hspec+import Test.QuickCheck (choose, counterexample, forAll, ioProperty)++import Control.Monad.NodeId+import Reflex.Vty.Test.Generators (runPlanProperty)++spec :: Spec+spec = describe "Control.Monad.NodeId" $ do+  it "allocates unique identifiers within one runNodeIdT" $+    runPlanProperty $+      forAll (choose (1, 300)) $ \n ->+        ioProperty $ do+          ids <- runNodeIdT (replicateM n getNextNodeId)+          pure $+            counterexample+              ("expected " ++ show n ++ " distinct ids, got " ++ show (length (nub ids)))+              (length (nub ids) == n)
+ test/Coverage.hs view
@@ -0,0 +1,899 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Coverage measurement and baseline checks for all library modules+--+-- This tool runs separately from the test suite.+-- doc/qa.md and .github/workflows/haskell.yml give the commands and package versions.+-- The tool must use the Cabal version that configured the build.+--+-- > runghc <package flags> test/Coverage.hs check  <build-dir> test/coverage-baseline.tsv <report-dir>+-- > runghc <package flags> test/Coverage.hs update <build-dir> test/coverage-baseline.tsv <report-dir>+-- > runghc <package flags> test/Coverage.hs self-test+--+-- The tool reads all library module names from the Cabal package description.+-- It includes the private @reflex-vty-internal@ library.+-- It finds @.mix@ files and the parent @.tix@ file only in the specified build directory.+-- It adds child tick counts from @REFLEX_VTY_COVERAGE_CHILD_DIR@ to the parent counts.+-- Compiled modules without tick counts receive zero counts.+-- The report gives covered and total counts for expressions, boolean pairs, and alternatives.+-- @check@ uses integer cross multiplication to compare coverage with the committed baseline.+-- @update@ replaces the local baseline but cannot run when @CI=true@.+-- @self-test@ checks the calculations with synthetic Mix/Tix data in temporary directories.+module Main (main) where++import Control.Exception (SomeException, try)+import Control.Monad (forM, forM_, unless, when)+import Data.Char (isDigit, isLower, isSpace)+import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, sort, sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Time.Clock (UTCTime, addUTCTime)+import Distribution.ModuleName (components)+import Distribution.PackageDescription+  ( Library (..)+  , PackageDescription (..)+  , otherModules+  )+import Distribution.PackageDescription.Configuration+  ( flattenPackageDescription+  )+import Distribution.Pretty (prettyShow)+import Distribution.Simple.Compiler (OptimisationLevel (..), compilerId)+import Distribution.Simple.Configure (getPersistBuildConfig)+import Distribution.Simple.PackageDescription (readGenericPackageDescription)+import Distribution.Types.LibraryName (libraryNameString)+import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..))+import Distribution.Utils.Path (makeSymbolicPath)+import Distribution.Verbosity (silent)+import System.Directory+import System.Environment (getArgs, lookupEnv)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath+import System.IO+import System.IO.Extra (withTempDir)+import System.Process (rawSystem, readProcess)+import Trace.Hpc.Mix+import Trace.Hpc.Tix+import Trace.Hpc.Util (Hash, HpcPos, toHpcPos)++-- | The supported compiler, optimization, and schema versions.+-- Report the required commands if these settings differ.+expectedGhc :: String+expectedGhc = "9.12.3"++expectedOpt :: String+expectedOpt = "0"++schemaVersion :: String+schemaVersion = "1"++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  getArgs >>= \case+    ["self-test"] -> selfTest+    ["check", buildDir, baseline, reportDir] -> do+      current <- analyzeEverything buildDir+      baselineRows <- readBaseline baseline+      let problems = compareWithBaseline baselineRows current+      writeReports reportDir current+      if null problems+        then putStrLn "coverage check: OK"+        else do+          putStrLn "coverage check: FAILED"+          mapM_ (putStrLn . ("  - " ++)) problems+          exitWith (ExitFailure 1)+    ["update", buildDir, baseline, reportDir] -> do+      ci <- lookupEnv "CI"+      when (ci == Just "true") $ do+        putStrLn "coverage update: forbidden under CI=true"+        exitWith (ExitFailure 1)+      current <- analyzeEverything buildDir+      writeReports reportDir current+      writeBaseline baseline current+      putStrLn ("coverage update: wrote " ++ baseline)+    _ -> do+      putStrLn "usage: Coverage.hs check|update <build-dir> <baseline.tsv> <report-dir>"+      putStrLn "       Coverage.hs self-test"+      exitWith (ExitFailure 2)++-- | A tix module's declared tick count.+tixLen :: TixModule -> Int+tixLen (TixModule _ _ n _) = n++-- | The modules in a tix file.+theTixModules :: Tix -> [TixModule]+theTixModules (Tix xs) = xs++-- | Fail with a clear message.+die :: String -> IO a+die msg = hPutStrLn stderr ("coverage: " ++ msg) >> exitWith (ExitFailure 1)++----------------------------------------------------------------------------+-- Package inventory+----------------------------------------------------------------------------++data ComponentKind = CompMain | CompInternal+  deriving (Eq, Ord, Show)++componentName :: ComponentKind -> String+componentName CompMain = "main"+componentName CompInternal = "internal"++-- | Get each library module and its component from the Cabal package description.+-- Include all conditional branches in the module list.+-- The coverage build must compile each module in this list.+-- @packageDescription gpd@ alone does not include modules in conditional branches.+-- Exclude generated @Paths_@ modules.+inventoryModules :: IO [(ComponentKind, String)]+inventoryModules = do+  gpd <- readGenericPackageDescription silent Nothing (makeSymbolicPath "reflex-vty.cabal")+  let pd = flattenPackageDescription gpd+      dotted = intercalate "." . components+      modsOf lib = nub (map dotted (exposedModules lib ++ otherModules (libBuildInfo lib)))+      mainMods = maybe [] modsOf (library pd)+      subs =+        [ (fromMaybe "sub" (libraryNameString (libName sub)), modsOf sub)+        | sub <- subLibraries pd+        ]+      internalNames = ["reflex-vty-internal"]+      internalMods = concat [ms | (n, ms) <- subs, n `elem` internalNames]+  when (null internalMods) $+    die "internal sublibrary reflex-vty-internal not found in reflex-vty.cabal"+  let classify m = if m `elem` internalMods then CompInternal else CompMain+      modsWithComp =+        [ (classify m, m)+        | m <- nub (mainMods ++ concat (map snd subs))+        , not ("Paths_" `isPrefixOf` m)+        ]+  pure (sortOn (\(c, m) -> (componentName c, m)) modsWithComp)++----------------------------------------------------------------------------+-- Analysis+----------------------------------------------------------------------------++data ModuleCounts = ModuleCounts+  { mcExpressions :: (Int, Int)+  -- ^ (covered, total) expression boxes+  , mcBooleans :: (Int, Int)+  -- ^ (both-branches-taken pairs, total boolean pairs)+  , mcAlternatives :: (Int, Int)+  -- ^ (covered, total) alternative boxes+  }+  deriving (Eq, Show)++data ModuleResult = ModuleResult+  { mrComponent :: ComponentKind+  , mrModule :: String+  , mrCounts :: ModuleCounts+  , mrHash :: Hash+  , mrTicks :: [Integer]+  , mrMixPath :: FilePath+  -- ^ The source .mix file. The report uses a copy of this file.+  }++-- | Discover mix and tix files under the build dir and analyze.+analyzeEverything :: FilePath -> IO [ModuleResult]+analyzeEverything buildDir = do+  mods <- inventoryModules+  when (null mods) $ die "package inventory is empty"+  validateBuildSettings buildDir+  mixFiles <- filter (hasComponents ["hpc", "vanilla", "mix"]) <$> findWithSuffix buildDir ".mix"+  parentTix0 <-+    filter (\p -> hasComponents ["t", "reflex-vty-test"] p && hasComponents ["hpc", "vanilla", "tix"] p)+      <$> findWithSuffix buildDir ".tix"+  childDir <- lookupEnv "REFLEX_VTY_COVERAGE_CHILD_DIR"+  -- Convert relative paths to normalised absolute paths before comparison.+  -- This prevents incorrect matches caused by ".", "..", or different base directories.+  childDirAbs <- traverse (\d -> normalise <$> makeAbsolute d) childDir+  -- Use an empty child directory for each run.+  -- Create the run-start marker before the suite starts.+  -- Each child writes a signal-<mode>.tix file after the marker and before the parent tix file.+  -- Analysis does not change this directory. Thus, one run can supply data for repeated checks and updates.+  (childMarkerTime, childTix) <- case childDir of+    Nothing -> pure (Nothing, [])+    Just dir -> do+      exists <- doesDirectoryExist dir+      unless exists $+        die ("REFLEX_VTY_COVERAGE_CHILD_DIR=" ++ dir ++ " does not exist")+      let marker = dir </> runStartName+      markerExists <- doesFileExist marker+      unless markerExists $+        die+          ( "run-start marker "+              ++ marker+              ++ " is missing. Start each run with an empty child directory."+              ++ " Create the marker before the instrumented run:\n"+              ++ "  rm -rf "+              ++ dir+              ++ " && mkdir -p "+              ++ dir+              ++ " && touch "+              ++ marker+          )+      markerTime <- getModificationTime marker+      entries <- filter (/= runStartName) . sort <$> listDirectory dir+      tix <- forM entries $ \e -> do+        let f = dir </> e+        isDir <- doesDirectoryExist f+        if isDir || not (".tix" `isSuffixOf` e)+          then die ("unexplained file in child tix directory: " ++ f)+          else do+            unless (knownSignalTixName e) $+              die+                ( "unknown child tix name "+                    ++ e+                    ++ " (expected signal-<mode>.tix from the signal child harness)"+                )+            pure f+      pure (Just markerTime, tix)+  parentPairs <-+    traverse (\f -> (,) f . normalise <$> makeAbsolute f) parentTix0+  let parentTix =+        [ f+        | (f, fa) <- parentPairs+        , not (maybe False (isUnderDir fa) childDirAbs)+        ]+  case (childMarkerTime, parentTix) of+    (Just markerTime, [p]) -> do+      parentTime <- getModificationTime p+      forM_ childTix $ \c -> do+        t <- getModificationTime c+        case childTimeProblem markerTime parentTime c t of+          Just problem -> die problem+          Nothing -> pure ()+    _ -> pure () -- analyze reports missing or multiple parent files.+  analyze buildDir mods mixFiles parentTix childTix++-- | The marker file that the run creates before the suite starts.+runStartName :: String+runStartName = "run-start"++-- | Accept @signal-<mode>.tix@ names from the signal test children.+-- Reject other names in the child directory.+knownSignalTixName :: String -> Bool+knownSignalTixName name =+  "signal-" `isPrefixOf` name+    && ".tix" `isSuffixOf` name+    && not (null mode)+    && all okMode mode+  where+    prefix = "signal-" :: String+    suffix = ".tix" :: String+    mode = drop (length prefix) (take (length name - length suffix) name)+    okMode c = isLower c || isDigit c || c == '-'++-- | Check the modification time of a child tix file.+-- Return 'Nothing' if the time is between the marker time and the parent tix time, inclusive.+-- Otherwise, return an error message.+childTimeProblem :: UTCTime -> UTCTime -> FilePath -> UTCTime -> Maybe String+childTimeProblem markerTime parentTime path t+  | t < markerTime =+      Just+        ( "child tix "+            ++ path+            ++ " is older than the run-start marker."+            ++ " Use only files from this run."+        )+  | t > parentTime =+      Just+        ( "child tix "+            ++ path+            ++ " is newer than parent tix."+            ++ " Each child must stop before the parent writes its tix file."+            ++ " Use only files from this run."+        )+  | otherwise = Nothing++-- | Check each saved Cabal build configuration in the build directory.+-- Each configuration must specify the required GHC version and no optimization.+-- HPC files do not record these settings.+-- The tool must use the Cabal version that wrote @setup-config@.+-- Stop if the tool cannot read a configuration.+validateBuildSettings :: FilePath -> IO ()+validateBuildSettings buildDir = do+  ghcDirNames <- nub . map takeFileName <$> findMatching (isGhcDirName . takeFileName) buildDir+  case ghcDirNames of+    [n] | n == "ghc-" ++ expectedGhc -> pure ()+    [] -> die ("no ghc-" ++ expectedGhc ++ " artifacts under " ++ buildDir)+    ds ->+      die+        ( "ambiguous compiler directories under "+            ++ buildDir+            ++ ": "+            ++ show ds+            ++ "; the coverage build dir must contain exactly one compiler's artifacts"+        )+  setupConfigs <- sort <$> findMatching ((== "setup-config") . takeFileName) buildDir+  case setupConfigs of+    [] ->+      die+        ( "no setup-config under "+            ++ buildDir+            ++ ". Use the Cabal build directory from the instrumented run."+        )+    cfgs -> do+      results <-+        forM cfgs $ \cfg ->+          (,) cfg+            <$> try+              ( getPersistBuildConfig+                  (Just (makeSymbolicPath "."))+                  (makeSymbolicPath (takeDirectory cfg))+              )+      let readable = [(c, lbi) | (c, Right lbi) <- results]+          unreadable = [c | (c, Left (_ :: SomeException)) <- results]+          firstUnreadable = case unreadable of+            (c : _) -> Just c+            [] -> Nothing+      unless (null unreadable) $+        die+          ( "cannot read saved build configurations under "+              ++ buildDir+              ++ " ("+              ++ show (length unreadable)+              ++ " config(s)"+              ++ maybe "" ("; first: " ++) firstUnreadable+              ++ "). Use the Cabal library version that configured the build directory."+          )+      forM_ readable $ \(cfg, lbi) -> do+        let cid = prettyShow (compilerId (compiler lbi))+        when (cid /= "ghc-" ++ expectedGhc) $+          die+            ( cfg+                ++ " was configured with "+                ++ cid+                ++ ", but the baseline requires ghc-"+                ++ expectedGhc+                ++ ". Use the required settings:\n  "+                ++ canonicalCommand+            )+        let opt = withOptimization lbi+        when (opt /= NoOptimisation) $+          die+            ( cfg+                ++ " was configured with optimization "+                ++ show opt+                ++ ", but the baseline requires optimization "+                ++ expectedOpt+                ++ ". Use the required settings:\n  "+                ++ canonicalCommand+            )+  mixFiles <- filter (hasComponents ["hpc", "vanilla", "mix"]) <$> findWithSuffix buildDir ".mix"+  when (null mixFiles) $ die "no vanilla instrumented mix artifacts found"+  where+    isGhcDirName n =+      "ghc-" `isPrefixOf` n+        && not (null (drop 4 n))+        && all (\c -> isDigit c || c == '.') (drop 4 n)++-- | Match consecutive path components, not a text prefix.+hasComponents :: [FilePath] -> FilePath -> Bool+hasComponents wanted = go . splitDirectories+  where+    go [] = False+    go parts@(_ : rest) = wanted `isPrefixOf` parts || go rest++-- | Whether @path@ lies at or under directory @dir@. Both arguments must be+-- normalised and absolute (see 'analyzeEverything').+isUnderDir :: FilePath -> FilePath -> Bool+isUnderDir path dir = splitDirectories dir `isPrefixOf` splitDirectories path++-- | Search @root@ and its subdirectories for paths that satisfy the predicate.+findMatching :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findMatching p root = go root+  where+    go dir = do+      entries <- listDirectory dir+      fmap concat . forM (sort entries) $ \e -> do+        let f = dir </> e+        isDir <- doesDirectoryExist f+        if isDir+          then do+            rest <- go f+            pure ([f | p f] ++ rest)+          else pure [f | p f]++-- | Search for a suffix only in the root directory and its subdirectories.+findWithSuffix :: FilePath -> String -> IO [FilePath]+findWithSuffix root suffix = findMatching (suffix `isSuffixOf`) root++-- | Analyze the specified files. Tests can supply synthetic files.+analyze+  :: FilePath+  -> [(ComponentKind, String)]+  -> [FilePath]+  -> [FilePath]+  -> [FilePath]+  -> IO [ModuleResult]+analyze _buildDir mods mixFiles parentTix childTix = do+  parent <- case nub parentTix of+    [] -> die ("no .tix found under " ++ _buildDir ++ "; run the instrumented suite first")+    [path] -> readTheTix path+    paths -> die ("ambiguous parent tix candidates: " ++ show paths)+  children <- mapM readTheTix childTix+  let byModule =+        Map.fromListWith+          (\a b -> a ++ b)+          [(dropExtension (takeFileName f), [f]) | f <- mixFiles]+      tixByName =+        Map.fromListWith+          (\a b -> a ++ b)+          [ (tixModuleName tm, [tm])+          | t <- parent : children+          , tm <- theTixModules t+          ]+  forM mods $ \(comp, m) -> do+    mixPath <- case Map.lookup m byModule of+      Nothing -> pure Nothing+      Just [f] -> pure (Just f)+      Just fs -> die ("ambiguous mix files for " ++ m ++ ": " ++ show fs)+    case mixPath of+      Nothing ->+        -- A missing module would reduce the denominator.+        -- Report an error instead of omitting the module.+        die ("missing mix file for " ++ m ++ " under " ++ _buildDir)+      Just mixPath' -> do+        (mixHash', labels) <- readMixFile mixPath' m+        let qualifiedName = takeFileName (takeDirectory mixPath') ++ "/" ++ m+            tms = Map.findWithDefault [] qualifiedName tixByName ++ Map.findWithDefault [] m tixByName+        ticks <- case tms of+          [] -> pure (replicate (length labels) 0)+          (tm0 : _) -> do+            let hashes = map tixModuleHash tms+                lengths = map tixLen tms+            when (length (nub (map show hashes)) > 1) $+              die ("tick hash mismatch for " ++ m)+            when (length (nub lengths) > 1) $+              die ("tick length mismatch for " ++ m)+            when (tixModuleHash tm0 /= mixHash') $+              die ("tix hash does not match mix for " ++ m)+            when (tixLen tm0 /= length labels) $+              die+                ( "tick length "+                    ++ show (tixLen tm0)+                    ++ " does not match mix box count "+                    ++ show (length labels)+                    ++ " for "+                    ++ m+                )+            pure (foldl1 (zipWith (+)) (map tixModuleTixs tms))+        pure+          ModuleResult+            { mrComponent = comp+            , mrModule = m+            , mrCounts = classifyBoxes labels ticks+            , mrHash = mixHash'+            , mrTicks = ticks+            , mrMixPath = mixPath'+            }+  where+    readTheTix p =+      readTix p >>= \case+        Nothing -> die ("malformed tix " ++ p)+        Just t -> do+          forM_ (theTixModules t) $ \tm ->+            when (tixLen tm /= length (tixModuleTixs tm)) $+              die+                ( "tix "+                    ++ p+                    ++ ": module "+                    ++ tixModuleName tm+                    ++ " declares "+                    ++ show (tixLen tm)+                    ++ " ticks but carries "+                    ++ show (length (tixModuleTixs tm))+                )+          pure t++readMixFile :: FilePath -> String -> IO (Hash, [BoxLabel])+readMixFile mixPath m = do+  mix <- readMix [takeDirectory mixPath] (Left m)+  case mix of+    Mix _ _ h _ entries -> pure (h, map snd entries)++-- | Split box labels into the three metrics with their tick values.+classifyBoxes :: [BoxLabel] -> [Integer] -> ModuleCounts+classifyBoxes labels ticks =+  let pairs = zip labels ticks+      exprs =+        ( length [() | (ExpBox _, t) <- pairs, t > 0]+        , length [() | (ExpBox _, _) <- pairs]+        )+      bools = boolCounts pairs+      alts =+        ( length [() | (b, t) <- pairs, isAlt b, t > 0]+        , length [() | (b, _) <- pairs, isAlt b]+        )+  in ModuleCounts exprs bools alts+  where+    isAlt (ExpBox True) = True+    isAlt _ = False+    -- HPC uses adjacent True and False boxes for each boolean condition.+    -- Both boxes must have the same constructor.+    -- Do not pair boxes from different conditions.+    boolCounts :: [(BoxLabel, Integer)] -> (Int, Int)+    boolCounts = go (0, 0)+      where+        go acc [] = acc+        go (cov, tot) ((BinBox c True, t1) : (BinBox c' False, t2) : rest)+          | c == c' =+              go (cov + (if t1 > 0 && t2 > 0 then 1 else 0), tot + 1) rest+        go acc (_ : rest) = go acc rest++----------------------------------------------------------------------------+-- Baseline+----------------------------------------------------------------------------++data BaselineRow = BaselineRow+  { brComponent :: String+  , brModule :: String+  , brCounts :: ModuleCounts+  }+  deriving (Eq, Show)++baselineHeader :: String+baselineHeader =+  "# reflex-vty coverage baseline\tschema="+    ++ schemaVersion+    ++ "\tghc="+    ++ expectedGhc+    ++ "\topt="+    ++ expectedOpt++canonicalCommand :: String+canonicalCommand =+  unlines+    [ "Use the coverage job in .github/workflows/haskell.yml."+    , "Use GHC 9.12.3, Cabal 3.16.1.0, and a new dist-coverage build."+    , "Install the matching Cabal library in a separate package environment. See doc/qa.md."+    , "export REFLEX_VTY_COVERAGE_CHILD_DIR=\"$PWD/dist-coverage/child-tix\""+    , "mkdir -p \"$REFLEX_VTY_COVERAGE_CHILD_DIR\""+    , "touch \"$REFLEX_VTY_COVERAGE_CHILD_DIR/run-start\""+    , "REFLEX_VTY_GOLDEN_UPDATE=0 cabal test reflex-vty-test --builddir=dist-coverage --disable-optimization --enable-coverage --test-show-details=direct"+    , "Then run Coverage.hs check using the matching package environment."+    ]++readBaseline :: FilePath -> IO [BaselineRow]+readBaseline path = do+  exists <- doesFileExist path+  unless exists $ die ("missing baseline " ++ path)+  ls <- lines <$> readFile path+  case ls of+    (h : rows) -> do+      unless (h == baselineHeader) $+        die+          ( "baseline header mismatch (this tool only compares ticks from GHC "+              ++ expectedGhc+              ++ " at optimization "+              ++ expectedOpt+              ++ "); regenerate canonically:\n  "+              ++ canonicalCommand+          )+      mapM parseRow rows+    [] -> die ("malformed baseline " ++ path ++ ": no header")+  where+    parseRow row = case splitTab row of+      [comp, m, ec, et, bc, bt, ac, at] -> do+        ec' <- readI ec+        et' <- readI et+        bc' <- readI bc+        bt' <- readI bt+        ac' <- readI ac+        at' <- readI at+        pure (BaselineRow comp m (ModuleCounts (ec', et') (bc', bt') (ac', at')))+      _ -> die ("malformed baseline row: " ++ show row)+    readI s = case reads s of+      [(n, "")] -> pure (n :: Int)+      _ -> die ("non-integer in baseline: " ++ s)++splitTab :: String -> [String]+splitTab s = case break (== '\t') s of+  (a, '\t' : rest) -> a : splitTab rest+  (a, _) -> [a]++writeBaseline :: FilePath -> [ModuleResult] -> IO ()+writeBaseline path results = do+  createDirectoryIfMissing True (takeDirectory path)+  writeFile path (unlines (baselineHeader : map row results))+  where+    row r =+      componentName (mrComponent r)+        ++ "\t"+        ++ mrModule r+        ++ "\t"+        ++ fmt (mcExpressions (mrCounts r))+        ++ "\t"+        ++ fmt (mcBooleans (mrCounts r))+        ++ "\t"+        ++ fmt (mcAlternatives (mrCounts r))+    fmt (c, t) = show c ++ "\t" ++ show t++----------------------------------------------------------------------------+-- Baseline comparison+----------------------------------------------------------------------------++compareWithBaseline :: [BaselineRow] -> [ModuleResult] -> [String]+compareWithBaseline baseline current =+  drift+    ++ concatMap problemsFor current+    ++ zeroExecution+  where+    baseSet = sort [(brComponent b, brModule b) | b <- baseline]+    curSet = sort [(componentName (mrComponent c), mrModule c) | c <- current]+    drift =+      [ "module set drift: missing from current " ++ show m+      | m <- baseSet \\ curSet+      ]+        ++ [ "module set drift: not in baseline " ++ show m+           | m <- curSet \\ baseSet+           ]+    baseMap =+      Map.fromList [(brComponent b ++ "\t" ++ brModule b, brCounts b) | b <- baseline]+    problemsFor r =+      let key = componentName (mrComponent r) ++ "\t" ++ mrModule r+      in case Map.lookup key baseMap of+           Nothing -> []+           Just base ->+             metricProblem "expressions" (mcExpressions base) (mcExpressions (mrCounts r))+               ++ metricProblem "booleans" (mcBooleans base) (mcBooleans (mrCounts r))+               ++ metricProblem "alternatives" (mcAlternatives base) (mcAlternatives (mrCounts r))+    zeroExecution =+      [ "module with expression boxes executed no expressions: " ++ mrModule r+      | r <- current+      , let (cov, tot) = mcExpressions (mrCounts r)+      , tot > 0+      , cov == 0+      ]+    metricProblem name (bc, bt) (cc, ct)+      | bt == 0 && ct == 0 = [] -- N/A on both sides+      | bt == 0 = [name ++ " denominator is nonzero, but the baseline denominator is zero"]+      | ct == 0 = [name ++ " denominator is zero, but the baseline denominator is nonzero"]+      | bc * ct > cc * bt =+          [ "decreased "+              ++ name+              ++ ": baseline "+              ++ show (bc, bt)+              ++ " current "+              ++ show (cc, ct)+          ]+      | otherwise = []++(\\) :: Eq a => [a] -> [a] -> [a]+a \\ b = [x | x <- a, x `notElem` b]++----------------------------------------------------------------------------+-- Reports+----------------------------------------------------------------------------++-- | Write a tix file that contains only library data.+-- Run @hpc report@ and @hpc markup@ with this file.+-- Copy each module's .mix file into one directory without changing its contents.+-- Use @--hpcdir@ to select this directory instead of @.hpc@.+-- Save and print the report. Stop if the report is empty.+writeReports :: FilePath -> [ModuleResult] -> IO ()+writeReports dir results = do+  createDirectoryIfMissing True dir+  let mixDir = dir </> "mix"+      tixPath = dir </> "reflex-vty-library.tix"+  createDirectoryIfMissing True mixDir+  forM_ results $ \r -> do+    present <- doesFileExist (mrMixPath r)+    when present $+      copyFile (mrMixPath r) (mixDir </> mrModule r <.> "mix")+  writeTix tixPath (Tix results')+  reportOut <- try (readProcess "hpc" (["report", "--hpcdir=" ++ mixDir, tixPath]) "")+  case reportOut of+    Left (_ :: SomeException) -> die "hpc report failed"+    Right text+      | all isSpace text -> die "hpc report produced an empty report"+      | otherwise -> do+          writeFile (dir </> "report.txt") text+          putStr text+  code <- rawSystem "hpc" ["markup", "--hpcdir=" ++ mixDir, tixPath, "--destdir=" ++ (dir </> "markup")]+  unless (code == ExitSuccess) $ die "hpc markup failed"+  where+    results' =+      [ TixModule (mrModule r) (mrHash r) (length (mrTicks r)) (mrTicks r)+      | r <- results+      ]++----------------------------------------------------------------------------+-- Self-test+----------------------------------------------------------------------------++selfTestLabels :: [BoxLabel]+selfTestLabels =+  [ ExpBox True+  , ExpBox True+  , ExpBox False+  , BinBox GuardBinBox True+  , BinBox GuardBinBox False+  , BinBox CondBinBox True+  , BinBox CondBinBox False+  , TopLevelBox ["alt"]+  , LocalBox ["case"]+  ]++selfTestPositions :: [HpcPos]+selfTestPositions = [toHpcPos (i, 1, i, 2) | i <- [1 :: Int ..]]++-- | A fixed past time for modification-time comparisons.+pastTime :: UTCTime+pastTime = read "2000-01-01 00:00:00 UTC"++selfTest :: IO ()+selfTest = withTempDir $ \dir -> do+  let mixDir = dir </> "mix"+      tixDir = dir </> "tix"+  createDirectoryIfMissing True mixDir+  createDirectoryIfMissing True tixDir+  let mkMix name hash =+        mixCreate+          mixDir+          name+          ( Mix+              ("src" </> name)+              pastTime+              hash+              (length selfTestLabels)+              (zip selfTestPositions selfTestLabels)+          )+  mkMix "Mod.Executed" 11+  mkMix "Mod.NeverRun" 12+  mkMix "Test.Helper" 13+  mkMix "Mod.Internal" 14+  let executedTicks = [1, 1, 0, 1, 1, 0, 1, 0, 1] :: [Integer]+  writeTix+    (tixDir </> "suite.tix")+    ( Tix+        [ TixModule "mix/Mod.Executed" 11 (length executedTicks) executedTicks+        , TixModule "dependency/Mod.Executed" 99 (length executedTicks) executedTicks+        , TixModule "Test.Helper" 13 (length executedTicks) executedTicks+        ]+    )+  let mods =+        [ (CompMain, "Mod.Executed")+        , (CompMain, "Mod.NeverRun")+        , (CompInternal, "Mod.Internal")+        ]+      mixes =+        [ mixDir </> "Mod.Executed" <.> "mix"+        , mixDir </> "Mod.NeverRun" <.> "mix"+        , mixDir </> "Mod.Internal" <.> "mix"+        ]+  results <- analyze dir mods mixes [tixDir </> "suite.tix"] []+  -- 1. Count the boxes of an unexecuted module in the denominator.+  case [r | r <- results, mrModule r == "Mod.NeverRun"] of+    (r : _) -> do+      expectEq (mcExpressions (mrCounts r)) (0, 3) "omitted module contributes expressions denominator"+      expectEq (mcBooleans (mrCounts r)) (0, 2) "omitted module contributes boolean denominator"+    [] -> die "self-test: missing omitted module"+  -- 2. Count internal modules in the denominator.+  case [r | r <- results, mrComponent r == CompInternal] of+    (r : _) -> do+      expectEq (mrTicks r) (replicate (length executedTicks) 0) "internal module without tix has zero ticks"+      expectEq (mcExpressions (mrCounts r)) (0, 3) "internal module denominator"+    [] -> die "self-test: missing internal module"+  -- 3. Exclude test modules and dependency modules.+  expectEq (length results) 3 "test/dependency modules excluded"+  -- 4. Pair the True and False boxes from the same condition.+  case [r | r <- results, mrModule r == "Mod.Executed"] of+    (r : _) -> do+      expectEq (mcExpressions (mrCounts r)) (2, 3) "expression classification"+      expectEq (mcBooleans (mrCounts r)) (1, 2) "boolean pair classification"+      expectEq (mcAlternatives (mrCounts r)) (2, 2) "alternative classification"+    [] -> die "self-test: missing executed module"+  -- 5. Add child tick counts without replacing parent counts.+  writeTix+    (tixDir </> "child-a.tix")+    (Tix [TixModule "mix/Mod.Executed" 11 (length executedTicks) (map (* 2) executedTicks)])+  merged <-+    analyze+      dir+      [(CompMain, "Mod.Executed")]+      [mixDir </> "Mod.Executed" <.> "mix"]+      [tixDir </> "suite.tix"]+      [tixDir </> "child-a.tix"]+  case merged of+    (r : _) ->+      expectEq+        (mrTicks r)+        (zipWith (+) executedTicks (map (* 2) executedTicks))+        "child ticks merge additively"+    [] -> die "self-test: merge produced nothing"+  -- 6. Reject a hash mismatch.+  writeTix+    (tixDir </> "badhash.tix")+    (Tix [TixModule "Mod.Executed" 99 (length executedTicks) executedTicks])+  hashFailure <-+    dies+      ( analyze+          dir+          [(CompMain, "Mod.Executed")]+          [mixDir </> "Mod.Executed" <.> "mix"]+          [tixDir </> "badhash.tix"]+          []+      )+  expectEq hashFailure True "hash mismatch fails"+  -- 7. Reject a tick array if its length differs from the declared length.+  writeTix+    (tixDir </> "badlen.tix")+    (Tix [TixModule "Mod.Executed" 11 (length executedTicks) (take 7 executedTicks)])+  lenFailure <-+    dies+      ( analyze+          dir+          [(CompMain, "Mod.Executed")]+          [mixDir </> "Mod.Executed" <.> "mix"]+          [tixDir </> "badlen.tix"]+          []+      )+  expectEq lenFailure True "declared tick length mismatch fails"+  -- 8. Accept child files only between the marker time and the parent tix time, inclusive.+  let marker = pastTime+      parent = addUTCTime 100 marker+      justBefore = addUTCTime (-1) marker+      justAfter = addUTCTime 101 parent+      ok = addUTCTime 50 marker+  expectEq (childTimeProblem marker parent "c.tix" ok) Nothing "fresh child tix accepted"+  expectEq+    (fmap (containsInfix "run-start marker") (childTimeProblem marker parent "c.tix" justBefore))+    (Just True)+    "child tix predating the run-start marker fails"+  expectEq+    (fmap (containsInfix "newer than parent") (childTimeProblem marker parent "c.tix" justAfter))+    (Just True)+    "child tix newer than the parent tix fails"+  expectEq (knownSignalTixName "signal-sigint.tix") True "signal child name accepted"+  expectEq (knownSignalTixName "signal-sigterm.tix") True "second signal child name accepted"+  expectEq (knownSignalTixName "stale-sigint.tix") False "non-signal child name rejected"+  expectEq (knownSignalTixName "signal-.tix") False "empty signal mode rejected"+  expectEq (knownSignalTixName "signal-x/y.tix") False "path separators rejected"+  -- 9. Compare directory components, not text prefixes.+  expectEq (isUnderDir "/x/a.tix" "/x") True "isUnderDir direct child"+  expectEq (isUnderDir "/x/y/a.tix" "/x") True "isUnderDir deep child"+  expectEq (isUnderDir "/xy/a.tix" "/x") False "isUnderDir prefix is not containment"+  expectEq (isUnderDir (normalise "/x/child/../a.tix") "/x") True "isUnderDir after normalisation"+  -- 10. Fail if a baseline module is missing.+  let baselineRows =+        [ BaselineRow "main" "Mod.Executed" (ModuleCounts (2, 3) (1, 2) (2, 2))+        , BaselineRow "main" "Mod.Gone" (ModuleCounts (1, 1) (0, 0) (0, 0))+        ]+  problems <- pure (compareWithBaseline baselineRows results)+  expectEq (any (containsInfix "module set drift") problems) True "missing baseline module fails"+  -- 11. Fail if the coverage ratio decreases, even if the covered count increases.+  let lowerRatio =+        compareWithBaseline+          [BaselineRow "main" "M" (ModuleCounts (1, 4) (0, 0) (0, 0))]+          [ModuleResult CompMain "M" (ModuleCounts (2, 20) (0, 0) (0, 0)) 0 [] ""]+  expectEq (any (containsInfix "decreased expressions") lowerRatio) True "lower ratio with higher hits fails"+  -- 12. Treat zero denominators on both sides as N/A.+  expectEq+    ( compareWithBaseline+        [BaselineRow "main" "N" (ModuleCounts (0, 0) (0, 0) (0, 0))]+        [ModuleResult CompMain "N" (ModuleCounts (0, 0) (0, 0) (0, 0)) 0 [] ""]+    )+    []+    "N/A handling"+  putStrLn "self-test: OK"+  where+    expectEq actual expected label =+      when (actual /= expected) $+        die ("self-test failure (" ++ label ++ "): expected " ++ show expected ++ ", got " ++ show actual)+    containsInfix needle hay = any (needle `prefixOf`) (tails' hay)+    prefixOf p s = take (length p) s == p+    tails' s = case s of+      [] -> [[]]+      (_ : rest) -> s : tails' rest++-- | Return 'True' if the action raises an exception.+dies :: IO a -> IO Bool+dies act = do+  r <- try act+  pure $ case r of+    Left (_ :: SomeException) -> True+    Right _ -> False
test/Data/Text/ZipperSpec.hs view
@@ -1,18 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.Text.ZipperSpec (-  spec-) where--import           Prelude--import           Test.Hspec+module Data.Text.ZipperSpec+  ( spec+  ) where -import qualified Data.Map         as Map-import qualified          Data.Text as T import Control.Monad+import Data.Char (isSpace)+import Data.List (mapAccumL)+import qualified Data.Map as Map+import qualified Data.Text as T+import Test.Hspec+import Test.QuickCheck (conjoin, counterexample, forAll)+import Prelude -import           Data.Text.Zipper+import Data.Text.Zipper+import Reflex.Vty.Test.Generators+  ( EditOp (..)+  , genEditScript+  , genMixedWidthText+  , runPlanProperty+  )  someSentence :: T.Text someSentence = "12345 1234 12"@@ -26,112 +33,253 @@ spec :: Spec spec =   describe "Zipper" $ do-  it "wordsWithWhitespace" $ do-    wordsWithWhitespace "" `shouldBe` []-    wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]-    wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"]-    wordsWithWhitespace "aoeu    " `shouldBe` ["aoeu    "]-  it "splitWordsAtDisplayWidth" $ do-    fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"]-    fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"]-    fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"]-    fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"]-    fmap fst (splitSentenceAtDisplayWidth 5 "1234   56") `shouldBe` ["1234 "," 56"]-    fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4","5 6 7 8", "9 1"]-  it "wrapWithOffsetAndAlignment" $ do-    wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]-    wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]-    wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]-    wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]+    it "wordsWithWhitespace" $ do+      wordsWithWhitespace "" `shouldBe` []+      wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]+      wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ", "efgf ", "f"]+      wordsWithWhitespace "aoeu    " `shouldBe` ["aoeu    "]+    it "splitWordsAtDisplayWidth" $ do+      fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345", "6"]+      fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345", "6"]+      fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234", "56"]+      fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345", "67891", "2345"]+      fmap fst (splitSentenceAtDisplayWidth 5 "1234   56") `shouldBe` ["1234 ", " 56"]+      fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4", "5 6 7 8", "9 1"]+    it "wrapWithOffsetAndAlignment" $ do+      wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]+      wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]+      wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]+      wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] -  it "eolSpacesToLogicalLines" $ do-    eolSpacesToLogicalLines-      [-        [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]-        , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]-      ]-      `shouldBe`-      [-        [ ("😱",1) ]-        , [ ("😱",2), ("😱",3) ]-        , [ ("aa",1) ]-        , [ ("aa",2) ]-        , [ ("aa",3) ]-      ]-  it "offsetMapWithAlignmentInternal" $ do-    offsetMapWithAlignmentInternal-      [-        [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]-        , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]-      ]-      `shouldBe`-      Map.fromList-      [ (0, (1,0))-      , (1, (2,2)) -- jump by 1 for char and 1 for space-      , (2, (3,3)) -- jump by 1 for char-      , (3, (1,5)) -- jump by 1 for char and 1 for newline-      , (4, (2,8)) -- jump by 2 for char and 1 for space-      , (5, (3,11)) -- jump by 2 for char and 1 for space-      ]-  it "displayLinesWithAlignment - spans" $ do-    let-      makespans = fmap (fmap (Span ()))-      insertcharnewlinesentence = insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ fromText ""-      cursorspan = [[Span () " "]]-      -- newline cases-      dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText newlineSentence)-      dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\naoeu")-      dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "\n\n\naoeu")-      dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\n")-      dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (empty)+    it "eolSpacesToLogicalLines" $ do+      eolSpacesToLogicalLines+        [ [(WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3)]+        , [(WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3)]+        ]+        `shouldBe` [ [("😱", 1)]+                   , [("😱", 2), ("😱", 3)]+                   , [("aa", 1)]+                   , [("aa", 2)]+                   , [("aa", 3)]+                   ]+    it "offsetMapWithAlignmentInternal" $ do+      offsetMapWithAlignmentInternal+        [ [(WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3)]+        , [(WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3)]+        ]+        `shouldBe` Map.fromList+          [ (0, (1, 0))+          , (1, (2, 2)) -- jump by 1 for char and 1 for space+          , (2, (3, 3)) -- jump by 1 for char+          , (3, (1, 5)) -- jump by 1 for char and 1 for newline+          , (4, (2, 8)) -- jump by 2 for char and 1 for space+          , (5, (3, 11)) -- jump by 2 for char and 1 for space+          ]+    it "displayLinesWithAlignment - spans" $ do+      let makespans = fmap (fmap (Span ()))+          insertcharnewlinesentence = insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ fromText ""+          cursorspan = [[Span () " "]]+          -- newline cases+          dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText newlineSentence)+          dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\naoeu")+          dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "\n\n\naoeu")+          dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\n")+          dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (empty) +      insertcharnewlinesentence `shouldBe` fromText newlineSentence -    insertcharnewlinesentence `shouldBe` fromText newlineSentence+      -- NOTE the trailing " " is the generated cursor cell: when the cursor+      -- sits past the last character of its line, it is rendered as a blank+      -- cell carrying the cursor tag so it stays visible.+      _displayLines_spans dl0 `shouldBe` makespans [[""], [""], [""], [""], [""], [" "]]+      _displayLines_spans dl1 `shouldBe` makespans [["aoeu"], [""], [""], ["aoeu", " "]]+      _displayLines_spans dl2 `shouldBe` makespans [[""], [""], [""], ["aoeu", " "]]+      _displayLines_spans dl3 `shouldBe` makespans [["aoeu"], [""], [""], [" "]]+      _displayLines_spans dl4 `shouldBe` makespans [[" "]] -    -- NOTE last " " is the generated cursor span char-    _displayLines_spans dl0 `shouldBe` makespans [[""],[""],[""],[""],[""],[""]]-    _displayLines_spans dl1 `shouldBe` makespans [["aoeu"],[""],[""],["aoeu", ""]]-    _displayLines_spans dl2 `shouldBe` makespans [[""],[""],[""],["aoeu", ""]]-    _displayLines_spans dl3 `shouldBe` makespans [["aoeu"],[""],[""],[""]]-    _displayLines_spans dl4 `shouldBe` makespans [[""]]+    it "displayLinesWithAlignment - cursor tag" $ do+      let dl0 = displayLinesWithAlignment TextAlignment_Right 10 0 1 (fromText "abc")+          dl1 = displayLinesWithAlignment TextAlignment_Right 10 0 1 empty+          -- cursor moved left into the text: it lands on a real character+          dl2 = displayLinesWithAlignment TextAlignment_Right 10 0 1 (left (fromText "abc"))+      -- cursor at end of text and on an empty line render a blank cursor cell+      -- so the cursor remains visible (see Data.Text.Zipper cursorcell)+      _displayLines_spans dl0 `shouldBe` [[Span 0 "abc", Span 1 " "]]+      _displayLines_spans dl1 `shouldBe` [[Span 1 " "]]+      -- when the cursor is over a character, that character carries the tag+      _displayLines_spans dl2 `shouldBe` [[Span 0 "ab", Span 1 "c"]] -  -  it "displayLinesWithAlignment - cursor tag" $ do-    let-      dl0 = displayLinesWithAlignment TextAlignment_Right 10 0 1 (fromText "abc")-      dl1 = displayLinesWithAlignment TextAlignment_Right 10 0 1 empty-    _displayLines_spans dl0 `shouldBe` [[Span 0 "abc", Span 1 ""]]-    _displayLines_spans dl1 `shouldBe` [[Span 1 ""]]+    it "displayLines - cursorPos" $ do+      let dl0 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "")+          dl1 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu")+          dl2 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu\n")+          dl3 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "0123456789")+          dl4 = displayLinesWithAlignment TextAlignment_Left 10 () () (insertChar 'a' $ fromText "aoeu")+          dl5 = displayLinesWithAlignment TextAlignment_Left 10 () () (left $ insertChar 'a' $ fromText "aoeu")+          dl6 = displayLinesWithAlignment TextAlignment_Left 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")+          dl7 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "") +      _displayLines_cursorPos dl0 `shouldBe` (0, 0)+      _displayLines_cursorPos dl1 `shouldBe` (4, 0)+      _displayLines_cursorPos dl2 `shouldBe` (0, 1)+      _displayLines_cursorPos dl3 `shouldBe` (0, 1)+      _displayLines_cursorPos dl4 `shouldBe` (5, 0)+      _displayLines_cursorPos dl5 `shouldBe` (4, 0)+      _displayLines_cursorPos dl6 `shouldBe` (4, 0)+      _displayLines_cursorPos dl7 `shouldBe` (10, 0)+    it "displayLinesWithAlignment - spans" $ do+      let someText = top $ fromText "0123456789abcdefgh"+      -- outer span length should be invariant when changing TextAlignment and CursorPosition+      -- print $ displayLinesWithAlignment TextAlignment_Left 5 () () someText+      forM_ [0 .. 4] $ \x -> do+        forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do+          let t = rightN x $ someText+          length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4 +    describe "editing against a flat-text model" $ do+      it "contents and cursor index agree after every operation of a random script" $+        runPlanProperty $+          forAll ((,) <$> genMixedWidthText <*> genEditScript) $ \(t, script) ->+            let walk (z, m) op =+                  ( (applyZipper op z, applyModel op m)+                  , let z' = applyZipper op z+                        (flat', idx') = applyModel op m+                    in counterexample+                         ( "after op "+                             ++ show op+                             ++ ": zipper value "+                             ++ show (value z')+                             ++ " vs model "+                             ++ show flat'+                             ++ "; marked zipper "+                             ++ show (value (insert "^" z'))+                             ++ " vs marked model "+                             ++ show (T.take idx' flat' <> "^" <> T.drop idx' flat')+                         )+                         ( value z' == flat'+                             && value (insert "^" z')+                               == T.take idx' flat' <> "^" <> T.drop idx' flat'+                         )+                  )+                (_, checks) =+                  mapAccumL+                    walk+                    -- 'fromText' places the cursor at the end of the+                    -- document.+                    (fromText t, (t, T.length t))+                    script+            in conjoin checks +      it "line joining, splitting, empty documents, and boundaries" $ do+        -- Directed boundary cases for the same model.+        let model z m = value z == fst m && value (insert "^" z) == markerOf m+            markerOf (flat, idx) = T.take idx flat <> "^" <> T.drop idx flat+        model (deleteLeft (insertChar 'a' (fromText ""))) (applyModel OpDeleteLeft (applyModel (OpInsertChar 'a') ("", 0)))+          `shouldBe` True+        model (up (fromText "ab\ncd")) (applyModel OpUp ("ab\ncd", 5)) `shouldBe` True+        model (down (up (fromText "ab\ncd"))) (applyModel OpDown (applyModel OpUp ("ab\ncd", 5))) `shouldBe` True+        model (deleteLeftWord (fromText "ab cd  ")) (applyModel OpDeleteLeftWord ("ab cd  ", 7)) `shouldBe` True+        model (tab 4 (fromText "ab")) (applyModel (OpTab 4) ("ab", 2)) `shouldBe` True+        model (pageUp 0 (fromText "a\nb")) (applyModel (OpPageUp 0) ("a\nb", 3)) `shouldBe` True+        model (pageDown (-2) (fromText "a\nb")) (applyModel (OpPageDown (-2)) ("a\nb", 3)) `shouldBe` True -  it "displayLines - cursorPos" $ do-    let-      dl0 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "")-      dl1 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu")-      dl2 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu\n")-      dl3 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "0123456789")-      dl4 = displayLinesWithAlignment TextAlignment_Left 10 () () (insertChar 'a' $ fromText "aoeu")-      dl5 = displayLinesWithAlignment TextAlignment_Left 10 () () (left $ insertChar 'a' $ fromText "aoeu")-      dl6 = displayLinesWithAlignment TextAlignment_Left 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")-      dl7 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")+applyZipper :: EditOp -> TextZipper -> TextZipper+applyZipper op z = case op of+  OpLeft -> left z+  OpRight -> right z+  OpUp -> up z+  OpDown -> down z+  OpHome -> home z+  OpEnd -> end z+  OpPageUp n -> pageUp n z+  OpPageDown n -> pageDown n z+  OpInsertChar c -> insertChar c z+  OpInsertNewline -> insertChar '\n' z+  OpInsertText s -> insert s z+  OpDeleteLeft -> deleteLeft z+  OpDeleteRight -> deleteRight z+  OpDeleteLeftWord -> deleteLeftWord z+  OpTab n -> tab n z+  OpTop -> top z -    _displayLines_cursorPos dl0 `shouldBe` (0,0)-    _displayLines_cursorPos dl1 `shouldBe` (4,0)-    _displayLines_cursorPos dl2 `shouldBe` (0,1)-    _displayLines_cursorPos dl3 `shouldBe` (0,1)-    _displayLines_cursorPos dl4 `shouldBe` (5,0)-    _displayLines_cursorPos dl5 `shouldBe` (4,0)-    _displayLines_cursorPos dl6 `shouldBe` (4,0)-    _displayLines_cursorPos dl7 `shouldBe` (10,0)-  it "displayLinesWithAlignment - spans" $ do-    let-      someText = top $ fromText "0123456789abcdefgh"-    -- outer span length should be invariant when changing TextAlignment and CursorPosition-    --print $ displayLinesWithAlignment TextAlignment_Left 5 () () someText-    forM_ [0..4] $ \x -> do-      forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do-        let t = rightN x $ someText-        length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4-        length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2+-- | The independent model: flat text plus a logical character index.+type FlatModel = (T.Text, Int)++dropTrailing :: (Char -> Bool) -> T.Text -> T.Text+dropTrailing p = T.dropWhileEnd p++applyModel :: EditOp -> FlatModel -> FlatModel+applyModel op (flat, idx) = case op of+  OpLeft -> (flat, max 0 (idx - 1))+  OpRight -> (flat, min (T.length flat) (idx + 1))+  OpUp -> (flat, moveLine flat idx (-1))+  OpDown -> (flat, moveLine flat idx 1)+  OpHome ->+    let start = lineStart flat idx+    in (flat, start)+  OpEnd ->+    let ls = T.splitOn "\n" flat+        (ln, _) = lineCol flat idx+        endIdx = lineStart flat idx + T.length (ls !! ln)+    in (flat, endIdx)+  OpPageUp 0 -> (flat, idx)+  OpPageUp n -> (flat, iterate moveUp idx !! max 0 n)+    where+      moveUp i = moveLine flat i (-1)+  OpPageDown 0 -> (flat, idx)+  OpPageDown n -> (flat, iterate moveDown idx !! max 0 n)+    where+      moveDown i = moveLine flat i 1+  OpInsertChar c -> (T.take idx flat <> T.singleton c <> T.drop idx flat, idx + 1)+  OpInsertNewline -> (T.take idx flat <> "\n" <> T.drop idx flat, idx + 1)+  OpInsertText s ->+    ( T.take idx flat <> s <> T.drop idx flat+    , idx + T.length s+    )+  OpDeleteLeft+    | idx > 0 -> (T.take (idx - 1) flat <> T.drop idx flat, idx - 1)+    | otherwise -> (flat, idx)+  OpDeleteRight+    | idx < T.length flat -> (T.take idx flat <> T.drop (idx + 1) flat, idx)+    | otherwise -> (flat, idx)+  OpDeleteLeftWord ->+    let prefix = T.take idx flat+        suffix = T.drop idx flat+        p1 = dropTrailing isSpace prefix+        p2 = dropTrailing (not . isSpace) p1+    in (p2 <> suffix, T.length p2)+  OpTab n ->+    let n' = max 1 n+        lb = idx - lineStart flat idx+        k = n - lb `mod` n'+        k' = max 0 k+    in ( T.take idx flat <> T.replicate k' " " <> T.drop idx flat+       , idx + k'+       )+  OpTop -> (flat, 0)++lineStart :: T.Text -> Int -> Int+lineStart flat idx =+  let prefix = T.take idx flat+      breaks = T.findIndex (== '\n') (T.reverse prefix)+  in case breaks of+       Nothing -> 0+       Just k -> idx - k++lineCol :: T.Text -> Int -> (Int, Int)+lineCol flat idx = (ln, col)+  where+    start = lineStart flat idx+    ln = T.count "\n" (T.take start flat)+    col = idx - start++moveLine :: T.Text -> Int -> Int -> Int+moveLine flat idx delta =+  let ls = T.splitOn "\n" flat+      (ln, col) = lineCol flat idx+      ln' = ln + delta+  in if ln' < 0 || ln' >= length ls+       then idx+       else lineStartOf ln' + min col (T.length (ls !! ln'))+  where+    lineStartOf l = sum (map (\s -> T.length s + 1) (take l (T.splitOn "\n" flat)))
+ test/Reflex/Vty/CanvasSpec.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.CanvasSpec (spec) where++import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T+import Graphics.Text.Width (wcwidth)+import qualified Graphics.Vty as V+import Test.Hspec+import Test.QuickCheck (Gen, counterexample, forAll, suchThat)++import Reflex.Vty.Canvas+import Reflex.Vty.Style (HAlign (..), placeHorizontal)+import Reflex.Vty.Test.Generators (genDim, genLineText, runPlanProperty)+import Reflex.Vty.Test.Snapshot++red, blue, green :: V.Attr+red = V.withForeColor V.defAttr (V.ISOColor 1)+blue = V.withForeColor V.defAttr (V.ISOColor 4)+green = V.withForeColor V.defAttr (V.ISOColor 2)++cell :: Char -> CanvasCell+cell ch = CanvasCell 1 ((V.defAttr, T.singleton ch) :| [])++wideCell :: Char -> CanvasCell+wideCell ch = CanvasCell 2 ((V.defAttr, T.singleton ch) :| [])++-- | Render a canvas to row text through the independent oracle.+canvasText :: Canvas -> [String]+canvasText = imageText . canvasToImage++-- | Row text the oracle produces for a direct Vty picture. The+-- picture is built from layers; the first layer is topmost.+refLayers :: [V.Image] -> Int -> Int -> [String]+refLayers layers w h =+  map (concatMap (T.unpack . renderSpanText)) (gridRows (pictureToGrid (w, h) (V.picForLayers layers)))++spec :: Spec+spec = describe "Reflex.Vty.Canvas" $ do+  describe "blankCanvas" $ do+    it "is fully transparent" $ do+      let c = blankCanvas 3 3+      canvasCells c `shouldSatisfy` null+      canvasCellAt 1 1 c `shouldBe` Nothing++    it "converts to background fill that lets a lower image show through" $ do+      let top = canvasToImage (blankCanvas 2 1)+          pic = V.picForLayers [top, V.string blue "xy"]+      map (concatMap (T.unpack . renderSpanText)) (gridRows (pictureToGrid (2, 1) pic))+        `shouldBe` ["xy"]+      attrAt 0 0 (pictureToGrid (2, 1) pic) `shouldBe` Just (V.FixedAttr V.defaultStyleMask (Just (V.ISOColor 4)) Nothing Nothing)++  describe "canvasCellAt" $ do+    it "returns the covering glyph at a wide glyph's continuation column" $ do+      let c = imageToCanvas (V.string V.defAttr "a\30028b")+      canvasCellAt 1 0 c `shouldBe` Just (wideCell '\30028')+      canvasCellAt 2 0 c `shouldBe` Just (wideCell '\30028')+      canvasCellAt 0 0 c `shouldBe` Just (cell 'a')+      canvasCellAt 3 0 c `shouldBe` Just (cell 'b')++    it "returns Nothing out of bounds or on transparent cells" $ do+      let c = placeCanvas 0 0 (imageToCanvas (V.string red "b")) (blankCanvas 3 1)+      canvasCellAt (-1) 0 c `shouldBe` Nothing+      canvasCellAt 3 0 c `shouldBe` Nothing+      canvasCellAt 0 1 c `shouldBe` Nothing+      canvasCellAt 1 0 c `shouldBe` Nothing++  describe "imageToCanvas / canvasToImage roundtrips" $ do+    it "preserves ASCII text and attributes after conversion to a canvas" $ do+      let c = imageToCanvas (V.string red "ab")+      canvasCellAt 0 0 c `shouldBe` Just (CanvasCell 1 ((red, "a") :| []))+      canvasCellAt 1 0 c `shouldBe` Just (CanvasCell 1 ((red, "b") :| []))+      canvasText c `shouldBe` ["ab"]++    it "preserves mixed-width text without adding continuation cells" $ do+      let c = imageToCanvas (V.string V.defAttr "a\30028b")+      canvasCells c `shouldSatisfy` not . null+      canvasText c `shouldBe` ["a\30028b"]+      V.imageWidth (canvasToImage c) `shouldBe` 4++    it "preserves a combining mark inside its glyph" $ do+      let c = imageToCanvas (V.string V.defAttr "e\769")+      canvasCellAt 0 0 c `shouldBe` Just (CanvasCell 1 ((V.defAttr, "e\769") :| []))++    it "keeps different attrs across a combining sequence" $ do+      let img = V.horizCat [V.text' red "e", V.text' blue "\769", V.text' green "x"]+          c = imageToCanvas img+      canvasCellAt 0 0 c `shouldBe` Just (CanvasCell 1 ((red, "e") :| [(blue, "\769")]))+      canvasCellAt 1 0 c `shouldBe` Just (CanvasCell 1 ((green, "x") :| []))+      canvasText c `shouldBe` imageText img++    it "converts backgrounds opaquely, including trailing blanks" $ do+      let c = imageToCanvas (V.horizCat [V.string V.defAttr "ab", V.backgroundFill 3 1])+      canvasCellAt 2 0 c `shouldBe` Just (cell ' ')+      canvasCellAt 4 0 c `shouldBe` Just (cell ' ')+      canvasText c `shouldBe` ["ab   "]++    it "has no cells for a zero-area image" $ do+      imageToCanvas V.emptyImage `shouldBe` Canvas 0 0 (canvasCells (blankCanvas 0 0))+      V.imageWidth (canvasToImage (blankCanvas 0 5)) `shouldBe` 0+      V.imageHeight (canvasToImage (blankCanvas 5 0)) `shouldBe` 0++  describe "placeCanvas" $ do+    it "overlays opaque glyphs and leaves transparent holes" $ do+      let src = imageToCanvas (V.string red "b")+          dst = blankCanvas 3 1+          c = placeCanvas 0 0 src dst+      canvasCellAt 0 0 c `shouldBe` Just (CanvasCell 1 ((red, "b") :| []))+      canvasCellAt 2 0 c `shouldBe` Nothing+      -- The holes must let a lower image show through, like Vty layers.+      canvasText c `shouldBe` ["b  "]+      let layered = V.picForLayers [canvasToImage c, V.string blue "xyz"]+      map (concatMap (T.unpack . renderSpanText)) (gridRows (pictureToGrid (3, 1) layered))+        `shouldBe` ["byz"]++    it "clips source glyphs moving past the right edge, removing the combining suffix" $ do+      let src = imageToCanvas (V.string V.defAttr "\30028\769")+          c = placeCanvas 1 0 src (blankCanvas 2 1)+      canvasCellAt 1 0 c `shouldBe` Just (CanvasCell 1 ((V.defAttr, "\8230") :| []))+      canvasText c `shouldBe` [" \8230"]++    it "clips source glyphs entering from the left, retaining the combining suffix" $ do+      let src = imageToCanvas (V.string V.defAttr "\30028\769")+          c = placeCanvas (-1) 0 src (blankCanvas 2 1)+      canvasCellAt 0 0 c `shouldBe` Just (CanvasCell 1 ((V.defAttr, "\8230\769") :| []))+      canvasText c `shouldBe` ["\8230\769 "]++    it "drops width-one glyphs wholly outside" $ do+      let c = translate (-1) 0 (imageToCanvas (V.string V.defAttr "ab"))+      canvasText c `shouldBe` ["b "]++    it "overwriting the second column of a wide glyph matches Vty's clipping" $ do+      let dst = imageToCanvas (V.string V.defAttr "a\30028b")+          c = placeCanvas 2 0 (imageToCanvas (V.string V.defAttr "X")) dst+      canvasText c `shouldBe` refLayers [V.translate 2 (0 :: Int) (V.string V.defAttr "X"), V.string V.defAttr "a\30028b"] 4 1++    it "overwriting the first column of a wide glyph matches Vty's clipping" $ do+      let dst = imageToCanvas (V.string V.defAttr "a\30028b")+          c = placeCanvas 1 0 (imageToCanvas (V.string V.defAttr "X")) dst+      canvasText c `shouldBe` refLayers [V.translate 1 (0 :: Int) (V.string V.defAttr "X"), V.string V.defAttr "a\30028b"] 4 1++    it "removes the combining suffix from the retained half of an overwritten wide glyph" $ do+      let dst = imageToCanvas (V.string V.defAttr "a\30028\769b")+          c = placeCanvas 2 0 (imageToCanvas (V.string V.defAttr "X")) dst+      canvasText c+        `shouldBe` refLayers [V.translate 2 (0 :: Int) (V.string V.defAttr "X"), V.string V.defAttr "a\30028\769b"] 4 1++    it "moves wholly outside the bounds to nothing" $ do+      let c = translate 10 10 (imageToCanvas (V.string V.defAttr "ab"))+      canvasCells c `shouldSatisfy` null+      canvasText c `shouldBe` ["  "]++    it "composes three overlapping layers like Vty" $ do+      let bottom = imageToCanvas (V.string blue "abcd")+          mid = placeCanvas 1 0 (imageToCanvas (V.string green "XY")) bottom+          top = placeCanvas 3 0 (imageToCanvas (V.string V.defAttr "Z")) mid+      canvasText top+        `shouldBe` refLayers+          [ V.translate 3 (0 :: Int) (V.string V.defAttr "Z")+          , V.translate 1 (0 :: Int) (V.string green "XY")+          , V.string blue "abcd"+          ]+          4+          1++    it "onto a zero-size destination yields an empty canvas" $ do+      placeCanvas 0 0 (imageToCanvas (V.string V.defAttr "a")) (blankCanvas 0 0)+        `shouldBe` Canvas 0 0 (canvasCells (blankCanvas 0 0))++  describe "translate" $ do+    it "preserves dimensions" $ do+      let c = translate 1 1 (imageToCanvas (V.string V.defAttr "ab"))+      canvasWidth c `shouldBe` 2+      canvasHeight c `shouldBe` 1+      canvasCellAt 1 1 c `shouldBe` Nothing -- moved off the single row+    it "shifts glyphs within bounds" $ do+      let c = translate 1 0 (imageToCanvas (V.string V.defAttr "ab"))+      canvasCellAt 1 0 c `shouldBe` Just (cell 'a')+      canvasCellAt 2 0 c `shouldBe` Nothing -- 'b' moved past the 2-wide bounds+      canvasCellAt 0 0 c `shouldBe` Nothing++    it "clips a wide glyph at the right edge" $ do+      let c = translate 1 0 (imageToCanvas (V.string V.defAttr "a\30028"))+      canvasText c `shouldBe` [" a\8230"]++    it "clips a wide glyph at the left edge" $ do+      let c = translate (-1) 0 (imageToCanvas (V.string V.defAttr "a\30028"))+      canvasText c `shouldBe` ["\30028 "]++    it "drops content shifted past the bottom" $ do+      let c = translate 0 1 (imageToCanvas (V.string V.defAttr "a"))+      canvasCells c `shouldSatisfy` null++  describe "stack" $ do+    it "stacks nothing into an empty canvas" $ do+      stack [] `shouldBe` blankCanvas 0 0++    it "uses the first canvas's dimensions" $ do+      let c = stack [blankCanvas 2 1, imageToCanvas (V.string V.defAttr "abc")]+      canvasWidth c `shouldBe` 2+      canvasText c `shouldBe` ["ab"]++  describe "layer/translate/clip properties against direct Vty pictures" $ do+    it "opaque roundtrips preserve text, widths, and attributes" $+      runPlanProperty $+        forAll ((,) <$> genDim <*> positiveWidthText) $ \(w, txt) ->+          let img = V.string red (T.unpack txt)+              padded = placeHorizontal HAlignLeft w img+              c = imageToCanvas padded+              rendered = canvasToImage c+              gridC = imageToGrid rendered+              gridRef = imageToGrid padded+          in counterexample (show txt ++ " at width " ++ show w) $+               gridEquals gridC gridRef == Nothing++    it "translations match the identically cropped Vty picture" $+      runPlanProperty $+        forAll ((,,) <$> genDim <*> genDim <*> positiveWidthText) $ \(dx, dy, txt) ->+          let img = V.string red (T.unpack txt)+              w = V.imageWidth img+              h = V.imageHeight img+              c = translate dx dy (imageToCanvas img)+              gridC = imageToGrid (canvasToImage c)+              gridRef = pictureToGrid (w, h) (V.picForImage (V.translate dx dy img))+          in counterexample ("translate " ++ show (dx, dy) ++ " of " ++ show txt) $+               gridEquals gridC gridRef == Nothing++-- | Non-empty text carrying at least one positive-width base glyph.+positiveWidthText :: Gen T.Text+positiveWidthText =+  suchThat genLineText (\t -> not (T.null t) && T.any (\ch -> wcwidth ch > 0) t)
+ test/Reflex/Vty/ColorProfileSpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.ColorProfileSpec (spec) where++import Control.Monad (forM_)+import qualified Graphics.Vty as V+import qualified Graphics.Vty.Attributes.Color as V.Color+import Test.Hspec++import Reflex.Vty.ColorProfile++spec :: Spec+spec = describe "Reflex.Vty.ColorProfile" $ do+  describe "colorProfileFromColorMode" $ do+    it "maps NoColor to Ascii" $+      colorProfileFromColorMode V.Color.NoColor `shouldBe` ColorProfile_Ascii+    it "maps ColorMode8 to Ansi16" $+      colorProfileFromColorMode V.Color.ColorMode8 `shouldBe` ColorProfile_Ansi16+    it "maps ColorMode16 to Ansi16" $+      colorProfileFromColorMode V.Color.ColorMode16 `shouldBe` ColorProfile_Ansi16+    it "maps ColorMode240 to Ansi256" $+      colorProfileFromColorMode (V.Color.ColorMode240 0) `shouldBe` ColorProfile_Ansi256+    it "maps FullColor to TrueColor" $+      colorProfileFromColorMode V.Color.FullColor `shouldBe` ColorProfile_TrueColor++  describe "convertColor" $ do+    it "is identity for TrueColor" $+      convertColor ColorProfile_TrueColor (V.Color.RGBColor 10 20 30)+        `shouldBe` V.Color.RGBColor 10 20 30+    it "downsamples RGB to Color240 for Ansi256" $+      convertColor ColorProfile_Ansi256 (V.Color.RGBColor 10 20 30)+        `shouldSatisfy` \case+          V.Color.Color240 {} -> True+          _ -> False+    it "is identity for ISOColor under Ansi16" $+      convertColor ColorProfile_Ansi16 V.Color.red `shouldBe` V.Color.red+    it "maps pure black RGB to the black ISO color under Ansi16" $+      convertColor ColorProfile_Ansi16 (V.Color.RGBColor 0 0 0)+        `shouldBe` V.Color.black+    it "maps pure white RGB to the white ISO color under Ansi16" $+      convertColor ColorProfile_Ansi16 (V.Color.RGBColor 255 255 255)+        `shouldBe` V.Color.brightWhite++  describe "applyProfile" $ do+    let redAttr = V.withForeColor V.defAttr V.Color.red+    it "preserves the foreground color under TrueColor" $ do+      V.attrForeColor (applyProfile ColorProfile_TrueColor redAttr)+        `shouldBe` V.SetTo V.Color.red+    it "resets the foreground to Default under Ascii" $ do+      V.attrForeColor (applyProfile ColorProfile_Ascii redAttr)+        `shouldBe` V.Default+    it "resets foreground, background, and style to Default under NoTTY" $ do+      let attr = V.withStyle (V.withForeColor (V.withBackColor V.defAttr V.Color.blue) V.Color.red) V.bold+          applied = applyProfile ColorProfile_NoTTY attr+      V.attrForeColor applied `shouldBe` V.Default+      V.attrBackColor applied `shouldBe` V.Default+      V.attrStyle applied `shouldBe` V.Default+    it "preserves the URL field under NoTTY" $ do+      let attr = V.withURL V.defAttr "https://example.com"+      V.attrURL (applyProfile ColorProfile_NoTTY attr)+        `shouldBe` V.SetTo "https://example.com"++  describe "applyProfile (fields)" $ do+    it "downsamples both foreground and background under Ansi256" $ do+      let attr = V.withBackColor (V.withForeColor V.defAttr (V.Color.RGBColor 10 20 30)) (V.Color.RGBColor 40 50 60)+          applied = applyProfile ColorProfile_Ansi256 attr+      V.attrForeColor applied `shouldSatisfy` \case+        V.SetTo (V.Color.Color240 _) -> True+        _ -> False+      V.attrBackColor applied `shouldSatisfy` \case+        V.SetTo (V.Color.Color240 _) -> True+        _ -> False+    it "resets only the color fields of a fully transparent attr under Ascii" $ do+      let attr = V.Attr V.KeepCurrent V.KeepCurrent V.KeepCurrent V.KeepCurrent+          applied = applyProfile ColorProfile_Ascii attr+      -- Ascii supports no colors at all. Color requests collapse to+      -- Default, even transparent ones. Style and URL survive.+      V.attrForeColor applied `shouldBe` V.Default+      V.attrBackColor applied `shouldBe` V.Default+      V.attrStyle applied `shouldBe` V.KeepCurrent+      V.attrURL applied `shouldBe` V.KeepCurrent+    it "keeps ISO colors under Ansi256" $ do+      let attr = V.withBackColor (V.withForeColor V.defAttr V.Color.blue) V.Color.red+          applied = applyProfile ColorProfile_Ansi256 attr+      V.attrForeColor applied `shouldBe` V.SetTo V.Color.blue+      V.attrBackColor applied `shouldBe` V.SetTo V.Color.red+    it "only ever produces valid output colors" $ do+      let attr = V.withBackColor (V.withForeColor V.defAttr (V.Color.RGBColor 1 2 3)) (V.Color.RGBColor 250 251 252)+      forM_ [ColorProfile_TrueColor, ColorProfile_Ansi256, ColorProfile_Ansi16] $ \profile ->+        forM_ [V.attrForeColor, V.attrBackColor] $ \sel ->+          sel (applyProfile profile attr) `shouldSatisfy` \case+            V.SetTo V.Color.RGBColor {} -> profile == ColorProfile_TrueColor+            V.SetTo (V.Color.Color240 _) -> profile == ColorProfile_Ansi256+            V.SetTo V.Color.ISOColor {} -> profile == ColorProfile_Ansi16+            _ -> False
+ test/Reflex/Vty/ColorSpec.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.ColorSpec (spec) where++import qualified Graphics.Vty as V+import Test.Hspec+import Test.QuickCheck (counterexample, forAll, property)++import Reflex.Vty.Color+import Reflex.Vty.Test.Generators (genFiniteDouble, runPlanProperty)++spec :: Spec+spec = describe "Reflex.Vty.Color" $ do+  let black = RGB 0 0 0+      white = RGB 255 255 255+      red = RGB 255 0 0+      blue = RGB 0 0 255++  describe "toRGB / fromRGB" $ do+    it "extracts RGB from RGBColor" $ do+      toRGB (V.RGBColor 10 20 30) `shouldBe` Just (RGB 10 20 30)+    it "returns Nothing for ISOColor" $ do+      toRGB (V.ISOColor 1) `shouldBe` Nothing+    it "returns Nothing for Color240" $ do+      toRGB (V.Color240 100) `shouldBe` Nothing+    it "round-trips RGB through fromRGB . toRGB" $ do+      fromRGB red `shouldBe` V.RGBColor 255 0 0++  describe "darken" $ do+    it "black at 0.0 stays black" $ do+      darken 0.0 white `shouldBe` black+    it "white at 1.0 stays white" $ do+      darken 1.0 white `shouldBe` white+    it "halves all channels" $ do+      darken 0.5 (RGB 200 100 50) `shouldBe` RGB 100 50 25++  describe "lighten" $ do+    it "black at 0.0 stays black" $ do+      lighten 0.0 black `shouldBe` black+    it "black at 1.0 becomes white" $ do+      lighten 1.0 black `shouldBe` white+    it "lightens by half towards white" $ do+      lighten 0.5 (RGB 0 0 0) `shouldBe` RGB 128 128 128++  describe "complementary" $ do+    it "inverts all channels" $ do+      complementary (RGB 100 200 50) `shouldBe` RGB 155 55 205+    it "complement of black is white" $ do+      complementary black `shouldBe` white++  describe "mix" $ do+    it "at 0.0 returns first color" $ do+      mix 0.0 red blue `shouldBe` red+    it "at 1.0 returns second color" $ do+      mix 1.0 red blue `shouldBe` blue+    it "at 0.5 averages channels" $ do+      mix 0.5 red blue `shouldBe` RGB 128 0 128++  describe "alpha" $ do+    it "at 0.0 returns background" $ do+      alpha 0.0 red blue `shouldBe` blue+    it "at 1.0 returns foreground" $ do+      alpha 1.0 red blue `shouldBe` red++  describe "Gradient1D" $ do+    let grad = gradient1D [(0.0, black), (1.0, white)]+    it "samples first stop at 0.0" $ do+      sampleGradient1D grad 0.0 `shouldBe` black+    it "samples last stop at 1.0" $ do+      sampleGradient1D grad 1.0 `shouldBe` white+    it "interpolates at 0.5" $ do+      sampleGradient1D grad 0.5 `shouldBe` RGB 128 128 128+    it "clamps below 0.0 to first stop" $ do+      sampleGradient1D grad (-0.5) `shouldBe` black+    it "clamps above 1.0 to last stop" $ do+      sampleGradient1D grad 1.5 `shouldBe` white++    it "handles three stops with correct interpolation" $ do+      let grad3 = gradient1D [(0.0, red), (0.5, white), (1.0, blue)]+      sampleGradient1D grad3 0.25 `shouldBe` RGB 255 128 128+      sampleGradient1D grad3 0.75 `shouldBe` RGB 128 128 255++    it "returns black for empty gradient" $ do+      sampleGradient1D (gradient1D []) 0.5 `shouldBe` black++  describe "Gradient2D" $ do+    let g2 = gradient2D black white red blue+    it "samples corners exactly" $ do+      sampleGradient2D g2 0 0 `shouldBe` black+      sampleGradient2D g2 1 0 `shouldBe` white+      sampleGradient2D g2 0 1 `shouldBe` red+      sampleGradient2D g2 1 1 `shouldBe` blue+    it "interpolates center" $ do+      sampleGradient2D g2 0.5 0.5 `shouldBe` RGB 128 64 128++  describe "channel bounds" $ do+    it "treats out-of-range factors as the nearest endpoint" $ do+      darken 2.0 (RGB 200 200 200) `shouldBe` RGB 200 200 200+      darken (-1.0) (RGB 200 200 200) `shouldBe` black+      lighten 2.0 (RGB 200 200 200) `shouldBe` white+      lighten (-1.0) (RGB 200 200 200) `shouldBe` RGB 200 200 200+      mix 2.0 red blue `shouldBe` blue+      mix (-1.0) red blue `shouldBe` red+      alpha 2.0 red blue `shouldBe` red+      alpha (-1.0) red blue `shouldBe` blue+    it "unsorted stops use the actual interval selection" $ do+      -- The stops are out of order. The implementation defines the+      -- interval for each sample. Assert only the exact endpoints.+      let grad = gradient1D [(1.0, white), (0.0, black)]+      sampleGradient1D grad 0.0 `shouldBe` black+      sampleGradient1D grad 1.0 `shouldBe` white+    it "duplicate stops pin their shared position" $ do+      let grad = gradient1D [(0.0, black), (0.5, red), (0.5, blue), (1.0, white)]+      sampleGradient1D grad 0.5 `shouldSatisfy` \c -> c == red || c == blue+    it "degenerate 2D dimensions sample the single corner color" $ do+      let g = gradient2D red red red red+      sampleGradient2D g 0 0 `shouldBe` red+      sampleGradient2D g 0.7 0.3 `shouldBe` red++  describe "interpolation rounding" $ do+    it "stays within one channel unit of exact interpolation" $+      runPlanProperty $+        forAll genFiniteDouble $ \f ->+          let exact = min 255 (max 0 (round (255 * f))) :: Int+              RGB sampled _ _ = sampleGradient1D (gradient1D [(0.0, black), (1.0, white)]) f+          in counterexample ("factor " ++ show f ++ " -> " ++ show sampled ++ ", exact " ++ show exact) $+               abs (fromIntegral sampled - exact) <= 1
+ test/Reflex/Vty/CompositionSpec.hs view
@@ -0,0 +1,621 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Specs for composition-level behavior. Real widget trees run through+-- the production host ('Reflex.Vty.Test.AppHarness.withApp'). Each test+-- asserts the observable widget state and the rendered output ('Grid').+module Reflex.Vty.CompositionSpec (spec) where++import Control.Monad (forM_, void)+import Control.Monad.Fix (MonadFix)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Control.Monad.NodeId (MonadNodeId)+import Data.Text.Zipper (fromText, value)+import Reflex.Vty.Host+import Reflex.Vty.Style (withForeground)+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), attrAt)+import Reflex.Vty.Theme+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Box+import Reflex.Vty.Widget.Input.Mouse (MouseDown (..), mouseDown)+import Reflex.Vty.Widget.Input.Text+import Reflex.Vty.Widget.Layout+import Reflex.Vty.Widget.Scroll+import Reflex.Vty.Widget.Split+import Reflex.Vty.Widget.Text (fill)++spec :: Spec+spec = describe "Reflex.Vty composition" $ do+  nestedPaneSpec+  focusIsolationSpec+  simultaneousModificationSpec+  nestedAllocationSpec+  scrollLayoutInputSpec+  splitDragSpec+  captureReplacementSpec+  contextIsolationSpec+  smallBoundarySpec++----------------------------------------------------------------------------+-- Grid helpers+----------------------------------------------------------------------------++gridRowText :: Int -> Grid -> String+gridRowText y g+  | y < 0 || y >= gridHeight g = ""+  | otherwise = T.unpack . T.concat . map renderSpanText $ gridRows g !! y++-- | 'gridRowText' with the render padding's trailing spaces stripped.+gridRowTrimmed :: Int -> Grid -> String+gridRowTrimmed y g = reverse (dropWhile (== ' ') (reverse (gridRowText y g)))++-- | The subrectangle of the grid as strings, @x0 y0 w h@.+gridSubLines :: Int -> Int -> Int -> Int -> Grid -> [String]+gridSubLines x0 y0 w h g =+  [take w (drop x0 (gridRowText y g)) | y <- [y0 .. y0 + h - 1]]++countChar :: Char -> Grid -> Int+countChar c g = length (filter (== c) (concat [gridRowText y g | y <- [0 .. gridHeight g - 1]]))++----------------------------------------------------------------------------+-- 1. Nested pane equivalence+----------------------------------------------------------------------------++innerField+  :: ( Reflex t+     , MonadHold t m+     , MonadFix m+     , HasInput t m+     , HasFocusReader t m+     , HasTheme t m+     , HasDisplayRegion t m+     , HasImageWriter t m+     )+  => m (Dynamic t (Text, (Int, Int)))+innerField = do+  md <- mouseDown V.BLeft+  clicks <- holdDyn (99, 99) (_mouseDown_coordinates <$> md)+  ti <- textInput def {_textInputConfig_initialValue = fromText "abcdef"}+  pure (zipDyn (_textInput_value ti) clicks)++-- | A field inside pane (3,2,12,5) which itself contains pane (1,1,8,3):+-- the field's global origin is (4,3).+nestedPaneApp :: TestApp () (Text, (Int, Int))+nestedPaneApp _ = do+  d <-+    pane (pure (Region 3 2 12 5)) (pure True) $+      pane (pure (Region 1 1 8 3)) (pure True) innerField+  pure (d, never)++-- | The same field placed directly at the summed origin.+flatPaneApp :: TestApp () (Text, (Int, Int))+flatPaneApp _ = do+  d <- pane (pure (Region 4 3 8 3)) (pure True) innerField+  pure (d, never)++nestedPaneSpec :: Spec+nestedPaneSpec = describe "nested pane equivalence" $ do+  it "translates clicks through both panes like a single summed origin" $ do+    nested <- withApp defaultVtyAppConfig (20, 8) nestedPaneApp $ \driver -> do+      f1 <- stepInput driver (V.EvMouseDown 5 4 V.BLeft []) -- global (5,4) -> local (1,1)+      frameObservation f1 `shouldBe` ("abcdef", (1, 1))+      _ <- stepInput driver (V.EvMouseDown 6 3 V.BLeft []) -- -> local (2,0): cursor after "ab"+      f3 <- stepInput driver (V.EvKey (V.KChar 'X') [])+      -- Clicking at column 2 puts the zipper cursor before 'c'. The+      -- keystroke inserts there; it does not overwrite.+      frameObservation f3 `shouldBe` ("abXcdef", (2, 0))+      sub <- gridSubLines 4 3 8 3 . frameGrid <$> lastFrame driver+      stopApp driver+      pure (frameObservation f3, sub)+    flat <- withApp defaultVtyAppConfig (20, 8) flatPaneApp $ \driver -> do+      _ <- stepInput driver (V.EvMouseDown 5 4 V.BLeft [])+      _ <- stepInput driver (V.EvMouseDown 6 3 V.BLeft [])+      f3 <- stepInput driver (V.EvKey (V.KChar 'X') [])+      sub <- gridSubLines 4 3 8 3 . frameGrid <$> lastFrame driver+      stopApp driver+      pure (frameObservation f3, sub)+    nested `shouldBe` flat+    -- The shared content subrectangle really contains the typed text+    -- (compare content, not unrelated padding).+    case snd nested of+      (top : _) -> take 6 top `shouldBe` "abXcde"+      [] -> expectationFailure "expected at least one content row"++lastFrame :: AppDriver c o -> IO (Frame o)+lastFrame driver = do+  fs <- driverFrames driver+  case reverse fs of+    (f : _) -> pure f+    [] -> fail "expected at least one frame"++----------------------------------------------------------------------------+-- 2. Focus isolation+----------------------------------------------------------------------------++twoInputApp :: TestApp () (Text, Text)+twoInputApp _ = do+  (t1, t2) <- initManager_ $ do+    tabNavigation+    row $ do+      a <- textInputTile (textInput def) (pure 9)+      b <- textInputTile (textInput def) (pure 9)+      pure (a, b)+  pure (zipDyn (_textInput_value t1) (_textInput_value t2), never)++focusIsolationSpec :: Spec+focusIsolationSpec = describe "focus isolation in a managed row" $ do+  it "delivers typing, paste, and BackTab only to the focused tile" $+    withApp defaultVtyAppConfig (20, 3) twoInputApp $ \driver -> do+      f0 <- stepInput driver (V.EvKey (V.KChar 'z') [])+      frameObservation f0 `shouldBe` ("", "") -- nothing focused yet+      _ <- stepInput driver (V.EvKey (V.KChar '\t') []) -- select first tile+      f1 <- stepInput driver (V.EvKey (V.KChar 'a') [])+      frameObservation f1 `shouldBe` ("a", "")+      _ <- stepInput driver (V.EvKey (V.KChar '\t') []) -- select second tile+      f2 <- stepInput driver (V.EvPaste (TE.encodeUtf8 "界"))+      frameObservation f2 `shouldBe` ("a", "界")+      _ <- stepInput driver (V.EvKey V.KBackTab []) -- back to first tile+      f4 <- stepInput driver (V.EvKey (V.KChar 'b') [])+      frameObservation f4 `shouldBe` ("ab", "界")+      take 2 (gridRowText 0 (frameGrid f4)) `shouldBe` "ab"+      stopApp driver++  it "a click moves the cursor and does not duplicate typed input" $+    withApp defaultVtyAppConfig (20, 3) twoInputApp $ \driver -> do+      _ <- stepInput driver (V.EvKey (V.KChar '\t') [])+      _ <- stepInput driver (V.EvKey (V.KChar 'a') [])+      _ <- stepInput driver (V.EvKey (V.KChar 'b') [])+      _ <- stepInput driver (V.EvMouseDown 0 0 V.BLeft []) -- cursor to col 0+      f <- stepInput driver (V.EvKey (V.KChar 'c') [])+      frameObservation f `shouldBe` ("cab", "")+      take 3 (gridRowText 0 (frameGrid f)) `shouldBe` "cab"+      stopApp driver++----------------------------------------------------------------------------+-- 3. Simultaneous UI input and caller modification+----------------------------------------------------------------------------++data SimCmd = SimBoth | SimModifyOnly+  deriving (Eq)++simApp :: TestApp SimCmd (Text, Maybe Text, Int)+simApp cmd = do+  let syntheticY = V.EvKey (V.KChar 'y') [] <$ fforMaybe cmd (\c -> if c == SimBoth then Just () else Nothing)+      -- Replace the whole zipper. The final value is the modify result,+      -- even when a UI keystroke occurs in the same frame.+      modE = fforMaybe cmd $ \case+        SimBoth -> Just (const (fromText "SET"))+        SimModifyOnly -> Just (const (fromText "MOD"))+  ti <-+    localInput (\e -> leftmost [e, syntheticY]) $+      textInput def {_textInputConfig_modify = modE}+  n <- count (_textInput_userInput ti)+  lastUI <- holdDyn Nothing (Just . value <$> _textInput_userInput ti)+  pure ((,,) <$> _textInput_value ti <*> lastUI <*> n, never)++simultaneousModificationSpec :: Spec+simultaneousModificationSpec =+  describe "simultaneous UI input and _textInputConfig_modify" $+    it "modify sets the final value; userInput contains the UI-only result" $+      withApp defaultVtyAppConfig (10, 3) simApp $ \driver -> do+        f0 <- lastFrame driver+        frameObservation f0 `shouldBe` ("", Nothing, 0)+        f1 <- stepCommand driver SimBoth+        frameObservation f1 `shouldBe` ("SET", Just "y", 1)+        take 3 (gridRowText 0 (frameGrid f1)) `shouldBe` "SET"+        f2 <- stepCommand driver SimModifyOnly+        frameObservation f2 `shouldBe` ("MOD", Just "y", 1) -- no new userInput+        take 3 (gridRowText 0 (frameGrid f2)) `shouldBe` "MOD"+        stopApp driver++----------------------------------------------------------------------------+-- 4. Nested allocation+----------------------------------------------------------------------------++data AllocCmd = AllocReorder | AllocDropA++-- | Paint a one-character label at the child region's origin.+label+  :: (Reflex t, Monad m, HasImageWriter t m)+  => Char+  -> m ()+label c = tellImages (pure [V.string V.defAttr [c]])++-- | Run a 'Dynamic' of child widgets, replacing the child on updates.+switchWidget :: (Reflex t, Adjustable t m, MonadSample t m) => Dynamic t (m ()) -> m ()+switchWidget d = do+  d0 <- sample (current d)+  _ <- runWithReplace d0 (updated d)+  pure ()++allocApp :: TestApp AllocCmd [Char]+allocApp cmd = do+  kidsD <- holdDyn ['A', 'B', 'C'] $+    fforMaybe cmd $ \case+      AllocReorder -> Just ['C', 'A', 'B']+      AllocDropA -> Just ['B', 'C']+  initManager_ . col . switchWidget . ffor kidsD $ \ls -> do+    -- Children get regions in list order. Each 'C' takes one full-width+    -- flex slot. Each run of non-'C' children forms one fixed-3 row:+    -- A is fixed 5 wide, and B takes the rest.+    let place [] = pure ()+        place ('C' : rest) = grout flex (label 'C') >> place rest+        place rest = do+          let (rowKids, rest') = span (/= 'C') rest+          axis (pure Orientation_Row) (fixed (pure 3)) $+            forM_ rowKids $ \c ->+              grout (if c == 'A' then fixed (pure 5) else flex) (label c)+          place rest'+    place ls+  pure (kidsD, never)++nestedAllocationSpec :: Spec+nestedAllocationSpec = describe "nested allocation" $ do+  it "allocates fixed 5, flex, and outer flex in order" $+    withApp defaultVtyAppConfig (20, 10) allocApp $ \driver -> do+      f0 <- lastFrame driver+      frameObservation f0 `shouldBe` ['A', 'B', 'C']+      -- A fixed 5x3 at (0,0), B flex 15x3 at (5,0), C flex 20x7 at (0,3)+      take 1 (gridRowText 0 (frameGrid f0)) `shouldBe` "A"+      take 1 (drop 5 (gridRowText 0 (frameGrid f0))) `shouldBe` "B"+      take 1 (gridRowText 3 (frameGrid f0)) `shouldBe` "C"+      stopApp driver++  it "reorders, resizes, and removes a held child" $+    withApp defaultVtyAppConfig (20, 10) allocApp $ \driver -> do+      f1 <- stepCommand driver AllocReorder+      frameObservation f1 `shouldBe` ['C', 'A', 'B']+      take 1 (gridRowText 0 (frameGrid f1)) `shouldBe` "C" -- C flex on top, rows 0-6+      take 1 (gridRowText 7 (frameGrid f1)) `shouldBe` "A" -- fixed row now at rows 7-9+      take 1 (drop 5 (gridRowText 7 (frameGrid f1))) `shouldBe` "B"+      f2 <- resizeApp driver (10, 10)+      take 1 (gridRowText 0 (frameGrid f2)) `shouldBe` "C"+      take 1 (gridRowText 7 (frameGrid f2)) `shouldBe` "A"+      take 1 (drop 5 (gridRowText 7 (frameGrid f2))) `shouldBe` "B"+      f3 <- stepCommand driver AllocDropA+      frameObservation f3 `shouldBe` ['B', 'C']+      take 1 (gridRowText 0 (frameGrid f3)) `shouldBe` "B" -- B flexes to full width+      take 1 (gridRowText 3 (frameGrid f3)) `shouldBe` "C"+      stopApp driver++----------------------------------------------------------------------------+-- 5. Scroll / layout / input+----------------------------------------------------------------------------++data ScrollCmd = ScrollAppend | ScrollFollow+  deriving (Eq)++scrollApp :: TestApp ScrollCmd ((Int, Int), Int)+scrollApp cmd = do+  appends <- count (fforMaybe cmd (\c -> if c == ScrollAppend then Just () else Nothing))+  let rowsD = (8 +) <$> appends+  followD <-+    holdDyn+      (Just ScrollToBottom_Maintain)+      (Just ScrollToBottom_Always <$ fforMaybe cmd (\c -> if c == ScrollFollow then Just () else Nothing))+  let mkContent = do+        md <- mouseDown V.BLeft+        clicks <- holdDyn (99, 99) (_mouseDown_coordinates <$> md)+        tellImages $+          ffor (current rowsD) $ \n ->+            [V.vertCat [V.string V.defAttr (show i) | i <- [1 .. n]]]+        pure (void (updated rowsD), clicks)+  (_, clicks) <-+    pane (pure (Region 0 0 12 4)) (pure True) $+      scrollable+        def+          { _scrollableConfig_scrollToBottom = current followD+          , _scrollableConfig_scrollbarVisibility = ScrollbarHidden+          }+        mkContent+  pure (zipDyn clicks rowsD, never)++scrollBoxApp :: TestApp () ((Int, Int), Int)+scrollBoxApp _ = do+  let mkContent = do+        md <- mouseDown V.BLeft+        clicks <- holdDyn (99, 99) (_mouseDown_coordinates <$> md)+        tellImages (pure [V.vertCat [V.string V.defAttr (show i) | i <- [1 .. 8 :: Int]]])+        pure (never, clicks)+  (_, clicks) <-+    initManager_ . tile flex . boxStatic singleBoxStyle $+      scrollable+        def {_scrollableConfig_scrollbarVisibility = ScrollbarHidden}+        mkContent+  pure (zipDyn clicks (pure (8 :: Int)), never)++scrollLayoutInputSpec :: Spec+scrollLayoutInputSpec = describe "scrollable composition" $ do+  it "scrolls, translates clicks to content coordinates, and follows appends" $+    withApp defaultVtyAppConfig (12, 4) scrollApp $ \driver -> do+      f0 <- lastFrame driver+      mapM_+        (\(y, e) -> gridRowTrimmed y (frameGrid f0) `shouldBe` e)+        [(0, "1"), (1, "2"), (2, "3"), (3, "4")]+      _ <- stepInput driver (V.EvKey V.KDown [])+      f2 <- stepInput driver (V.EvKey V.KDown [])+      mapM_+        (\(y, e) -> gridRowTrimmed y (frameGrid f2) `shouldBe` e)+        [(0, "3"), (1, "4"), (2, "5"), (3, "6")]+      fc <- stepInput driver (V.EvMouseDown 0 1 V.BLeft [])+      frameObservation fc `shouldBe` ((0, 3), 8) -- viewport (0,1) -> content y=3+      fA <- stepCommand driver ScrollAppend+      gridRowTrimmed 0 (frameGrid fA) `shouldBe` "3" -- Maintain keeps view+      frameObservation fA `shouldBe` ((0, 3), 9)+      _ <- stepInput driver (V.EvKey V.KDown [])+      _ <- stepInput driver (V.EvKey V.KDown [])+      fB <- stepInput driver (V.EvKey V.KDown []) -- now at the bottom+      gridRowTrimmed 0 (frameGrid fB) `shouldBe` "6"+      _ <- stepCommand driver ScrollFollow+      fF <- stepCommand driver ScrollAppend -- at bottom: follow the append+      gridRowTrimmed 0 (frameGrid fF) `shouldBe` "7"+      gridRowTrimmed 3 (frameGrid fF) `shouldBe` "10"+      stopApp driver++  it "inside a tile and a box: one-cell inset, no double translation" $+    withApp defaultVtyAppConfig (12, 8) scrollBoxApp $ \driver -> do+      _ <- stepInput driver (V.EvMouseDown 1 1 V.BLeft [])+      _ <- stepInput driver (V.EvMouseUp 1 1 (Just V.BLeft))+      _ <- stepInput driver (V.EvKey V.KDown [])+      _ <- stepInput driver (V.EvKey V.KDown [])+      f <- stepInput driver (V.EvMouseDown 1 2 V.BLeft []) -- box inset (1,1), scroll offset 2+      take 1 (drop 1 (gridRowText 1 (frameGrid f))) `shouldBe` "3"+      frameObservation f `shouldBe` ((0, 3), 8)+      stopApp driver++----------------------------------------------------------------------------+-- 6. Drag and resize of splitVDrag+----------------------------------------------------------------------------++splitApp :: TestApp () ()+splitApp _ = do+  void $ splitVDrag (fill (pure '-')) (fill (pure 'A')) (fill (pure 'B'))+  pure (pure (), never)++-- | Drag from row @fromY@ to row @toY@ and return the final frame.+dragDivider :: AppDriver () () -> Int -> Int -> IO (Frame ())+dragDivider driver fromY toY = do+  _ <- stepInput driver (V.EvMouseDown 3 fromY V.BLeft [])+  _ <- stepInput driver (V.EvMouseDown 3 toY V.BLeft [])+  stepInput driver (V.EvMouseUp 3 toY (Just V.BLeft))++splitDragSpec :: Spec+splitDragSpec = describe "splitVDrag drag and resize" $ do+  it "starts at half height, drags, and re-drags after resize" $+    withApp defaultVtyAppConfig (20, 10) splitApp $ \driver -> do+      f0 <- lastFrame driver+      gridRowText 5 (frameGrid f0) `shouldBe` replicate 20 '-' -- divider row 5+      gridRowText 0 (frameGrid f0) `shouldBe` replicate 20 'A' -- A rows 0..4+      gridRowText 9 (frameGrid f0) `shouldBe` replicate 20 'B' -- B rows 6..9+      _ <- stepInput driver (V.EvMouseDown 3 5 V.BLeft [])+      moving <- stepInput driver (V.EvMouseDown 3 7 V.BLeft [])+      gridRowText 7 (frameGrid moving) `shouldBe` replicate 20 '-'+      f1 <- stepInput driver (V.EvMouseUp 3 7 (Just V.BLeft))+      gridRowText 7 (frameGrid f1) `shouldBe` replicate 20 '-'+      gridRowText 6 (frameGrid f1) `shouldBe` replicate 20 'A'+      gridRowText 8 (frameGrid f1) `shouldBe` replicate 20 'B'+      f2 <- resizeApp driver (20, 20) -- fraction 0.7 keeps divider at row 14+      gridRowText 14 (frameGrid f2) `shouldBe` replicate 20 '-'+      gridRowText 13 (frameGrid f2) `shouldBe` replicate 20 'A'+      gridRowText 15 (frameGrid f2) `shouldBe` replicate 20 'B'+      f3 <- dragDivider driver 14 3 -- repeated drag+      gridRowText 3 (frameGrid f3) `shouldBe` replicate 20 '-'+      gridRowText 2 (frameGrid f3) `shouldBe` replicate 20 'A'+      gridRowText 4 (frameGrid f3) `shouldBe` replicate 20 'B'+      stopApp driver++  it "clamps out-of-bounds drags without negative extents" $+    withApp defaultVtyAppConfig (20, 10) splitApp $ \driver -> do+      f1 <- dragDivider driver 5 100 -- far below the viewport+      gridRowText 9 (frameGrid f1) `shouldBe` replicate 20 '-' -- clamped to last row+      gridRowText 8 (frameGrid f1) `shouldBe` replicate 20 'A' -- B has zero height+      f2 <- dragDivider driver 9 (-1) -- above the viewport+      gridRowText 0 (frameGrid f2) `shouldBe` replicate 20 '-' -- clamped to row 0+      gridRowText 1 (frameGrid f2) `shouldBe` replicate 20 'B' -- A has zero height+      gridHeight (frameGrid f2) `shouldBe` 10 -- nothing shrank negatively+      stopApp driver++  it "works at tiny heights" $ do+    withApp defaultVtyAppConfig (20, 1) splitApp $ \driver -> do+      f <- lastFrame driver+      gridRowText 0 (frameGrid f) `shouldBe` replicate 20 '-'+      stopApp driver+    withApp defaultVtyAppConfig (20, 2) splitApp $ \driver -> do+      f <- lastFrame driver+      gridRowText 0 (frameGrid f) `shouldBe` replicate 20 'A'+      gridRowText 1 (frameGrid f) `shouldBe` replicate 20 '-'+      stopApp driver++----------------------------------------------------------------------------+-- 7. Capture and replacement+----------------------------------------------------------------------------++data CapCmd = CapEmit | CapRemove+  deriving (Eq)++data CapMode = CapHeld | CapShown | CapGone+  deriving (Eq)++-- | A managed child: paints a marker plus its own 'x'-press count,+-- requests a terminal cursor, and owns a focus tile.+capChild+  :: ( Reflex t+     , MonadHold t m+     , MonadFix m+     , MonadNodeId m+     , MonadSample t m+     , PostBuild t m+     , HasInput t m+     , HasImageWriter t m+     , HasDisplayRegion t m+     , HasFocusReader t m+     , HasCursor t m+     , HasFocus t m+     , HasLayout t m+     , HasTheme t m+     )+  => m ()+capChild = do+  _ <- tile' flex $ do+    xE <- key (V.KChar 'x')+    n <- count xE+    tellImages $ ffor (current n) $ \k -> [V.string V.defAttr ('M' : show k)]+    setCursor (pure (CursorState CursorVisible CursorStyleDefault (0, 0)))+  pure ()++capApp :: TestApp CapCmd Bool+capApp cmd = do+  modeD <-+    holdDyn CapHeld $+      leftmost+        [ CapShown <$ fforMaybe cmd (\c -> if c == CapEmit then Just () else Nothing)+        , CapGone <$ fforMaybe cmd (\c -> if c == CapRemove then Just () else Nothing)+        ]+  removed <- holdUniqDyn ((== CapGone) <$> modeD)+  initManager_ $ do+    tabNavigation+    switchWidget $ ffor removed $ \gone ->+      if gone+        then blank+        else do+          (_, images) <- captureImages capChild+          tellImages $ (\mode imgs -> if mode == CapShown then imgs else []) <$> current modeD <*> images+  pure ((== CapGone) <$> modeD, never)++captureReplacementSpec :: Spec+captureReplacementSpec =+  describe "capture and replacement of a managed child" $+    it "keeps the image, re-emits once, and leaves no old image or stale handler" $+      withApp defaultVtyAppConfig (10, 4) capApp $ \driver -> do+        f0 <- lastFrame driver+        countChar 'M' (frameGrid f0) `shouldBe` 0 -- marker captured, not painted+        frameCursor f0 `shouldBe` V.AbsoluteCursor 0 0 -- cursor request still applies+        _ <- stepInput driver (V.EvKey (V.KChar '\t') [])+        f1 <- stepInput driver (V.EvKey (V.KChar 'x') [])+        countChar 'M' (frameGrid f1) `shouldBe` 0 -- still held+        f2 <- stepCommand driver CapEmit -- re-emit exactly once+        countChar 'M' (frameGrid f2) `shouldBe` 1+        -- Re-emitting the captured images preserves the child's state.+        take 2 (gridRowText 0 (frameGrid f2)) `shouldBe` "M1"+        f3 <- stepInput driver (V.EvKey (V.KChar 'x') [])+        countChar 'M' (frameGrid f3) `shouldBe` 1+        take 2 (gridRowText 0 (frameGrid f3)) `shouldBe` "M2"+        f4 <- stepCommand driver CapRemove -- replace/remove the child+        countChar 'M' (frameGrid f4) `shouldBe` 0 -- no old image+        f5 <- stepInput driver (V.EvKey (V.KChar 'x') []) -- no stale handler+        countChar 'M' (frameGrid f5) `shouldBe` 0+        frameGrid f5 `shouldBe` frameGrid f4 -- nothing changed at all+        frameObservation f5 `shouldBe` True+        stopApp driver++----------------------------------------------------------------------------+-- 8. Context isolation (themes, cursors)+----------------------------------------------------------------------------++data ThemeCmd = ThemeFlip++flippedTheme :: Theme+flippedTheme =+  defTheme+    { -- textInput paints its text with the ambient default style+      -- ('themeAttr') and its cursor span with '_theme_textInputCursor'.+      _theme_default = withForeground (V.rgbColor 200 0 0) def+    , _theme_textInputCursor = withForeground (V.rgbColor 200 0 0) def+    }++themeApp :: TestApp ThemeCmd (Text, Text)+themeApp cmd = do+  t1 <- holdDyn defTheme (flippedTheme <$ cmd)+  ti1 <-+    pane (pure (Region 0 0 20 4)) (pure True) $+      localTheme (const (current t1)) $+        textInput def {_textInputConfig_initialValue = fromText "a"}+  ti2 <-+    pane (pure (Region 0 5 20 4)) (pure False) $+      localTheme (const (pure defTheme)) $+        textInput def {_textInputConfig_initialValue = fromText "b"}+  pure (zipDyn (_textInput_value ti1) (_textInput_value ti2), never)++wideCursorApp :: TestApp () ()+wideCursorApp _ = do+  -- The cursor widget sits in a contained inner pane. The terminal+  -- cursor must add the viewport origins of both panes.+  pane (pure (Region 2 2 10 3)) (pure True) $+    pane (pure (Region 1 1 8 3)) (pure True) $ do+      tellImages (pure [V.string V.defAttr "a\30028|"])+      setCursor (pure (CursorState CursorVisible CursorStyleDefault (3, 0)))+  pure (pure (), never)++contextIsolationSpec :: Spec+contextIsolationSpec = describe "context isolation" $ do+  it "a local theme change restyles only its own subtree, across a resize" $+    withApp defaultVtyAppConfig (20, 10) themeApp $ \driver -> do+      f0 <- lastFrame driver+      frameObservation f0 `shouldBe` ("a", "b")+      let g0 = frameGrid f0+      attr0 <- pure (attrAt 0 0 g0)+      f1 <- stepCommand driver ThemeFlip+      let g1 = frameGrid f1+      attrAt 0 0 g1 `shouldNotBe` attr0 -- text attribute changed+      attrAt 1 0 g1 `shouldNotBe` attrAt 1 0 g0 -- image cursor changed+      attrAt 0 5 g1 `shouldBe` attrAt 0 5 g0 -- second box untouched+      frameObservation f1 `shouldBe` ("a", "b")+      f2 <- resizeApp driver (30, 10)+      let g2 = frameGrid f2+      attrAt 0 0 g2 `shouldBe` attrAt 0 0 g1 -- unchanged by the resize+      attrAt 1 0 g2 `shouldBe` attrAt 1 0 g1+      attrAt 0 5 g2 `shouldBe` attrAt 0 5 g1+      f3 <- stepInput driver (V.EvKey (V.KChar 'z') []) -- still focused, values intact+      frameObservation f3 `shouldBe` ("az", "b")+      stopApp driver++  it "setCursor over a wide glyph reports cell coordinates from the pane origin" $+    withApp defaultVtyAppConfig (16, 5) wideCursorApp $ \driver -> do+      f0 <- lastFrame driver+      -- Inner pane's composed viewport origin is (2,2)+(1,1) = (3,3);+      -- local (3,0) is 3 *cells* from that origin, so the cell is '|'+      -- (character indexing would put it one cell further right).+      frameCursor f0 `shouldBe` V.AbsoluteCursor 6 3+      take 3 (drop 3 (gridRowText 3 (frameGrid f0))) `shouldBe` "a\30028|"+      stopApp driver++----------------------------------------------------------------------------+-- Small boundaries+----------------------------------------------------------------------------++narrowInputApp :: TestApp () Text+narrowInputApp _ = do+  ti <- textInput def+  pure (_textInput_value ti, never)++smallBoundarySpec :: Spec+smallBoundarySpec = describe "small boundaries" $ do+  it "wraps typed text and follows the cursor in a one-column viewport" $+    withApp defaultVtyAppConfig (1, 2) narrowInputApp $ \driver -> do+      _ <- stepInput driver (V.EvKey (V.KChar 'a') [])+      f <- stepInput driver (V.EvKey (V.KChar 'b') [])+      frameObservation f `shouldBe` "ab"+      -- The insertion cursor wraps to a third row; a two-row viewport+      -- follows it, showing the last character and its blank cursor row.+      gridRowText 0 (frameGrid f) `shouldBe` "b"+      gridRowText 1 (frameGrid f) `shouldBe` " "+      top <- stepInput driver (V.EvKey V.KHome [])+      gridRowText 0 (frameGrid top) `shouldBe` "a"+      gridRowText 1 (frameGrid top) `shouldBe` "b"+      stopApp driver++  it "a zero-height terminal produces an empty but well-formed grid" $+    withApp defaultVtyAppConfig (20, 0) splitApp $ \driver -> do+      f <- lastFrame driver+      gridHeight (frameGrid f) `shouldBe` 0+      stopApp driver
+ test/Reflex/Vty/Host/SignalSpec.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: OS signal installation, mapping, and restoration.+--+-- Signal handlers are process-global state. The delivery scenarios+-- therefore run in isolated child processes of this test executable.+-- @test/Spec.hs@ dispatches the children via @REFLEX_VTY_SIGNAL_CHILD@+-- before Hspec starts. The parent only spawns children, raises+-- signals at them, and checks the reported sequence; it never+-- installs handlers itself. POSIX children verify real signal+-- delivery, mapping, and restoration. Windows children exercise+-- console-handler mapping and restoration. They have no desktop+-- console and no real OS shutdown, so they prove installation,+-- mapping, and restoration, not OS delivery.+module Reflex.Vty.Host.SignalSpec+  ( spec+  , runSignalChild+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Async (waitCatch)+import Control.Concurrent.MVar+import Control.Exception (SomeException, bracketOnError, catch)+import Control.Monad (forM_, forever)+import qualified Data.ByteString.Char8 as BS+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.List (isPrefixOf)+import System.Environment (getEnvironment, getExecutablePath, lookupEnv)+import System.Exit (ExitCode (..), exitFailure, exitSuccess)+import System.FilePath ((</>))+import System.IO+import System.Process+import System.Timeout (timeout)+import Test.Hspec++#if defined(mingw32_HOST_OS)+import qualified GHC.ConsoleHandler as Console+#else+import System.Posix.Signals+  ( Handler (Catch)+  , Signal+  , installHandler+  , raiseSignal+  , sigHUP+  , sigINT+  , sigTERM+  , signalProcess+  )+#endif++import Control.Monad.IO.Class (liftIO)+import qualified Graphics.Vty as V+import Reflex++import Reflex.Vty.Host (AppSignal (..), VtyApp, VtyResult (..), defaultVtyAppConfig)+#if defined(mingw32_HOST_OS)+import Reflex.Vty.Host.Signal (installAppSignalHandlers)+#endif+import Reflex.Vty.Test.AppHarness (defaultRecordingVtyConfig, recordingVty, runHostAsync)++-- | Deadline for one expected line from a child (microseconds).+lineDeadline :: Int+lineDeadline = 10 * 1000000++-- | Background reader that turns a handle into a line mailbox.+startLineReader :: Handle -> IO (MVar (Maybe BS.ByteString))+startLineReader h = do+  v <- newEmptyMVar+  _ <-+    forkIO $+      (forever (BS.hGetLine h >>= putMVar v . Just))+        `catch` \(_ :: SomeException) -> putMVar v Nothing+  pure v++-- | Read the next line with a deadline. A deadline expiry and the+-- end of output are both reported as 'Nothing'.+nextLine :: MVar (Maybe BS.ByteString) -> IO (Maybe String)+nextLine v = do+  r <- timeout lineDeadline (takeMVar v)+  pure $ case r of+    Nothing -> Nothing+    Just Nothing -> Nothing+    Just (Just bs) -> Just (BS.unpack bs)++-- | Read lines until one equals the expected string.+awaitLine :: MVar (Maybe BS.ByteString) -> String -> IO ()+awaitLine v expected = do+  ml <- nextLine v+  case ml of+    Nothing -> expectationFailure ("child closed stdout while waiting for " ++ show expected) >> pure ()+    Just l+      | l == expected -> pure ()+      | otherwise -> awaitLine v expected++-- | Read lines until one starts with the prefix and return it.+awaitPrefix :: MVar (Maybe BS.ByteString) -> String -> IO String+awaitPrefix v prefix = do+  ml <- nextLine v+  case ml of+    Nothing -> expectationFailure ("child closed stdout while waiting for prefix " ++ show prefix) >> pure ""+    Just l+      | prefix `isPrefixOf` l -> pure l+      | otherwise -> awaitPrefix v prefix++-- | The child modes exercised on this platform.+childModes :: [(String, String, String)]+#if defined(mingw32_HOST_OS)+childModes = [("console", "", "")]+#else+childModes =+  [ ("int", "AppSignal_Interrupt", "sigINT")+  , ("term", "AppSignal_Terminate", "sigTERM")+  , ("hup", "AppSignal_Hangup", "sigHUP")+  ]+#endif++spec :: Spec+spec = describe "Reflex.Vty.Host.Signal" $ do+  forM_ childModes $ \(mode, mapped, _signalName) ->+    it ("installs, maps, and restores handlers for " ++ mode ++ " in an isolated child") $+      runChildScenario mode mapped++-- | Spawn this executable as a signal child, drive the expected+-- sequence, and verify clean termination.+runChildScenario :: String -> String -> IO ()+runChildScenario mode mapped = do+  exe <- getExecutablePath+  parentEnv <- getEnvironment+  tixOverride <- coverageChildTix mode+  let childEnv = (tixOverride ++) . (("REFLEX_VTY_SIGNAL_CHILD", mode) :) $ parentEnv+  bracketOnError+    -- The child gets its own process group. No signal in these+    -- scenarios can then reach the pane or session that runs the+    -- suite.+    ( createProcess+        (proc exe []) {env = Just childEnv, std_out = CreatePipe, create_group = True}+    )+    (\(_, _, _, ph) -> terminateProcess ph >> waitForProcess ph)+    $ \(mIn, mOut, _, ph) -> do+      case mOut of+        Nothing -> expectationFailure "child stdout was not piped"+        Just hOut -> do+          hSetBinaryMode hOut True+          hSetBuffering hOut LineBuffering+          v <- startLineReader hOut+          awaitLine v "READY"+          checkSignalDelivery ph v mode mapped+          ec <- waitForProcess ph+          ec `shouldBe` ExitSuccess++checkSignalDelivery :: ProcessHandle -> MVar (Maybe BS.ByteString) -> String -> String -> IO ()+#if !defined(mingw32_HOST_OS)+checkSignalDelivery ph v mode mapped = do+  mpid <- getPid ph+  case mpid of+    Nothing -> expectationFailure "could not get child pid"+    Just pid -> do+      signalProcess (childSignal mode) pid+      appLine <- awaitPrefix v "APP "+      appLine `shouldBe` ("APP " ++ mapped)+      awaitLine v "HOSTDONE"+      -- After host shutdown, delivery must reach the prior handler.+      signalProcess (childSignal mode) pid+      awaitLine v "PRIOR"+#else+checkSignalDelivery _ v _ _ = do+  forM_ consoleEvents $ \(_, expected) -> do+    l <- awaitPrefix v "APP "+    l `shouldBe` ("APP " ++ show expected)+  awaitLine v "COUNT 1"+  awaitLine v "HOSTDONE"+#endif++#if defined(mingw32_HOST_OS)+consoleEvents :: [(Console.ConsoleEvent, AppSignal)]+consoleEvents =+  [ (Console.ControlC, AppSignal_Interrupt)+  , (Console.Break, AppSignal_Interrupt)+  , (Console.Close, AppSignal_Hangup)+  , (Console.Logoff, AppSignal_Hangup)+  , (Console.Shutdown, AppSignal_Terminate)+  ]+#else+childSignal :: String -> Signal+childSignal mode = case mode of+  "int" -> sigINT+  "hup" -> sigHUP+  _ -> sigTERM+#endif++-- | The tix-file override for coverage runs: each child gets its own+-- file so children never overwrite the parent's tix.+coverageChildTix :: String -> IO [(String, String)]+coverageChildTix mode = do+  mdir <- lookupEnv "REFLEX_VTY_COVERAGE_CHILD_DIR"+  pure $ case mdir of+    Nothing -> []+    Just d -> [("HPCTIXFILE", d </> ("signal-" ++ mode ++ ".tix"))]++----------------------------------------------------------------------------+-- Child process implementation+----------------------------------------------------------------------------++-- | Entry point for child modes, dispatched from test/Spec.hs before+-- Hspec starts.+runSignalChild :: IO ()+runSignalChild = do+  hSetBuffering stdout LineBuffering+  hSetNewlineMode stdout noNewlineTranslation+  mmode <- lookupEnv "REFLEX_VTY_SIGNAL_CHILD"+  case mmode of+    Nothing -> putStrLn "CHILDERR no mode" >> exitFailure+#if defined(mingw32_HOST_OS)+    Just _ -> windowsConsoleChild+#else+    Just mode -> posixSignalChild mode+#endif++#if !defined(mingw32_HOST_OS)++posixSignalChild :: String -> IO ()+posixSignalChild mode = do+  let sig = childSignal mode+  priorDone <- newEmptyMVar+  _ <- installHandler sig (Catch (putStrLn "PRIOR" >> putMVar priorDone ())) Nothing+  (vty, _st) <- recordingVty defaultRecordingVtyConfig+  hostA <- runHostAsync defaultVtyAppConfig vty signalGuest+  r <- waitCatch hostA+  case r of+    Left e -> putStrLn ("HOSTFAIL " ++ show e) >> exitFailure+    Right () -> pure ()+  putStrLn "HOSTDONE"+  raiseSignal sig+  -- The restored prior handler signals completion from its own+  -- thread.+  done <- timeout (5 * 1000000) (takeMVar priorDone)+  case done of+    Nothing -> putStrLn "CHILDERR prior handler never ran" >> exitFailure+    Just () -> exitSuccess++-- | The guest reports readiness at post-build. The host installs+-- signal handlers before post-build. The guest reports each received+-- application signal and shuts down on the first one.+signalGuest :: VtyApp t m+signalGuest _dr _inp sigs = do+  pb <- getPostBuild+  performEvent_ $ ffor pb $ \_ -> liftIO (putStrLn "READY")+  performEvent_ $ ffor sigs $ \s -> liftIO (putStrLn ("APP " ++ show s))+  return+    VtyResult+      { _vtyResult_picture = constant (V.picForImage V.emptyImage)+      , _vtyResult_shutdown = () <$ sigs+      }++#else++-- | Windows child scenario. Install a counting handler. Install the+-- library's handler. Retrieve and invoke its callback for each+-- console event to observe the mapping. Restore all handlers. Verify+-- that the counting handler is active again.+windowsConsoleChild :: IO ()+windowsConsoleChild = do+  countRef <- newIORef (0 :: Int)+  _ <- Console.installHandler (Console.Catch (\_ -> modifyIORef' countRef (+1)))+  restore <- installAppSignalHandlers $ \s ->+    putStrLn ("APP " ++ show s)+  putStrLn "READY"+  -- Temporarily retrieve the active (library) handler; invoking its+  -- callback with each console event exercises the mapping without a+  -- desktop console or a real shutdown.+  active <- Console.installHandler (Console.Catch (\_ -> pure ()))+  case active of+    Console.Catch act ->+      forM_ consoleEvents (act . fst)+    _ -> pure ()+  _ <- Console.installHandler active -- restore the retrieved handler+  restore -- restore the counting handler+  -- The counting handler is active again.+  counting <- Console.installHandler (Console.Catch (\_ -> pure ()))+  case counting of+    Console.Catch act -> act Console.ControlC+    _ -> pure ()+  _ <- Console.installHandler counting+  n <- readIORef countRef+  putStrLn ("COUNT " ++ show n)+  putStrLn "HOSTDONE"++#endif
+ test/Reflex/Vty/Host/TriggerSpec.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Bounded trigger-queue semantics.+--+-- Batch payloads are existentially typed, so these queue-level checks+-- assert counts and states. The production host proves true+-- first-in-first-out /ordering/ in "Reflex.Vty.HostSpec".+module Reflex.Vty.Host.TriggerSpec (spec) where++import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Monad (forM)+import Data.Dependent.Sum (DSum ((:=>)))+import Data.IORef+import Reflex+import Reflex.Spider (Spider)+import System.Timeout (timeout)+import Test.Hspec++import Reflex.Vty.Host.Trigger++-- | A synthetic batch. The trigger ref points at an empty IORef (no+-- subscriber), which is enough for queue-level semantics.+mkBatch :: Int -> IO (Batch Spider)+mkBatch _n = do+  r <- newIORef Nothing+  pure [EventTriggerRef r :=> TriggerInvocation () (pure ())]++-- | A batch whose completion callback appends to the reference.+mkBatchWithCallback :: IORef [Int] -> Int -> IO (Batch Spider)+mkBatchWithCallback logRef n = do+  r <- newIORef Nothing+  pure+    [ EventTriggerRef r+        :=> TriggerInvocation () (atomicModifyIORef' logRef (\ls -> (ls ++ [n], ())))+    ]++-- | Would the write commit immediately (True) or block (False)?+probeWrite :: BoundedEventQueue Spider -> Batch Spider -> IO Bool+probeWrite q batch =+  atomically ((writeBoundedEventQueue q batch >> pure True) `orElse` pure False)++-- | A deadline for these fast, deterministic checks (microseconds).+fastDeadline :: Int+fastDeadline = 5 * 1000000++-- | Expect a drain to yield batches, with the count checked.+expectDrained :: Maybe (Maybe [Batch Spider]) -> Int -> Expectation+expectDrained result n = case result of+  Nothing -> expectationFailure "drain did not finish within the deadline"+  Just Nothing ->+    expectationFailure ("expected " ++ show n ++ " drained batches, got the closed-and-empty end")+  Just (Just batches) -> length batches `shouldBe` n++-- | The drain blocked (its deadline expired without a result).+expectBlocked :: Maybe (Maybe [Batch Spider]) -> Expectation+expectBlocked Nothing = pure ()+expectBlocked (Just r) =+  expectationFailure+    ("expected the drain to block, but it returned " ++ maybe "the closed end" (\bs -> show (length bs) ++ " batches") r)++-- | The drain finished and reported the closed-and-empty end.+expectClosedAndEmpty :: Maybe (Maybe [Batch Spider]) -> Expectation+expectClosedAndEmpty result = case result of+  Nothing -> expectationFailure "drain did not finish within the deadline"+  Just Nothing -> pure ()+  Just (Just batches) ->+    expectationFailure+      ("expected the closed-and-empty end, but drained " ++ show (length batches) ++ " batches")++spec :: Spec+spec = describe "Reflex.Vty.Host.Trigger" $ do+  describe "newBoundedEventQueue" $ do+    it "clamps capacity 0 to one slot" $ do+      q <- newBoundedEventQueue 0+      b1 <- mkBatch 1+      b2 <- mkBatch 2+      ok1 <- probeWrite q b1+      ok1 `shouldBe` True+      ok2 <- probeWrite q b2+      ok2 `shouldBe` False -- single slot, now full+    it "accepts several batches and blocks when full" $ do+      q <- newBoundedEventQueue 4+      bs <- forM [1 .. 4] mkBatch+      results <- mapM (probeWrite q) bs+      results `shouldBe` [True, True, True, True]+      b5 <- mkBatch 5+      ok5 <- probeWrite q b5+      ok5 `shouldBe` False -- backpressure: the queue is full+      drained <- timeout fastDeadline (drainBoundedEventQueue q)+      expectDrained drained 4+      -- The queue is empty and still open: draining blocks again.+      immediate <- timeout 10000 (drainBoundedEventQueue q)+      expectBlocked immediate++  describe "drainBoundedEventQueue" $ do+    it "waits on an open empty queue, then completes after enqueue and close" $ do+      q <- newBoundedEventQueue 2+      resultVar <- newEmptyTMVarIO+      _ <- forkIO $ drainBoundedEventQueue q >>= atomically . putTMVar resultVar+      -- The drain is still blocked.+      notYet <- atomically $ (Just <$> readTMVar resultVar) `orElse` pure Nothing+      expectBlocked notYet+      b <- mkBatch 42+      atomically $ writeBoundedEventQueue q b+      closeBoundedEventQueue q+      r <- timeout fastDeadline (atomically (readTMVar resultVar))+      case r of+        Just (Just batches) -> length batches `shouldBe` 1+        _ -> expectationFailure "drain did not complete after enqueue and close"++    it "drains queued batches despite closure, then reports the end" $ do+      q <- newBoundedEventQueue 4+      bs <- forM [7, 8] mkBatch+      mapM_ (atomically . writeBoundedEventQueue q) bs+      closeBoundedEventQueue q+      first <- timeout fastDeadline (drainBoundedEventQueue q)+      expectDrained first 2+      second <- timeout fastDeadline (drainBoundedEventQueue q)+      expectClosedAndEmpty second++  describe "closeBoundedEventQueue" $ do+    it "is idempotent" $ do+      q <- newBoundedEventQueue 1+      closeBoundedEventQueue q+      closeBoundedEventQueue q+      r <- timeout fastDeadline (drainBoundedEventQueue q)+      expectClosedAndEmpty r++    it "refuses writes even with spare capacity (closed-first check)" $ do+      q <- newBoundedEventQueue 8+      b <- mkBatch 1+      atomically $ writeBoundedEventQueue q b+      closeBoundedEventQueue q+      -- Seven slots are free, but the closed queue must refuse the+      -- write: it commits as a no-op rather than enqueueing.+      ok <- probeWrite q b+      ok `shouldBe` True+      r <- timeout fastDeadline (drainBoundedEventQueue q)+      expectDrained r 1 -- only the pre-close batch+    it "releases a producer blocked on a full queue without enqueueing" $ do+      q <- newBoundedEventQueue 1+      b1 <- mkBatch 1+      b2 <- mkBatch 2+      atomically $ writeBoundedEventQueue q b1+      committedVar <- newEmptyTMVarIO+      _ <- forkIO $ do+        -- Blocks until the write commits (or the queue closes).+        atomically (writeBoundedEventQueue q b2)+        atomically (putTMVar committedVar ())+      -- The producer is still blocked.+      notYet <- atomically $ (Just <$> readTMVar committedVar) `orElse` pure Nothing+      notYet `shouldBe` Nothing+      closeBoundedEventQueue q+      -- Block (do not probe) until the released producer completes.+      done <- timeout fastDeadline (atomically (Just <$> readTMVar committedVar))+      done `shouldBe` Just (Just ())+      -- The released write must not have enqueued.+      r <- timeout fastDeadline (drainBoundedEventQueue q)+      expectDrained r 1++    it "drops post-close writes without running their completion callbacks" $ do+      q <- newBoundedEventQueue 1+      cbLog <- newIORef ([] :: [Int])+      closeBoundedEventQueue q+      b <- mkBatchWithCallback cbLog 1+      ok <- probeWrite q b+      ok `shouldBe` True+      r <- timeout fastDeadline (drainBoundedEventQueue q)+      expectClosedAndEmpty r+      readIORef cbLog `shouldReturn` []++  describe "producer/drain completion handshake" $ do+    it "drains everything a joined producer wrote, then ends" $ do+      q <- newBoundedEventQueue 3+      let n = 20 :: Int+      producerDone <- newEmptyTMVarIO+      _ <- forkIO $ do+        bs <- forM [1 .. n] mkBatch+        mapM_ (atomically . writeBoundedEventQueue q) bs+        closeBoundedEventQueue q+        atomically $ putTMVar producerDone ()+      _ <- timeout fastDeadline (atomically (readTMVar producerDone))+      let drainAll count = do+            r <- timeout fastDeadline (drainBoundedEventQueue q)+            case r of+              -- The deadline is not part of the contract; treat it as+              -- the end so a regression surfaces as a count mismatch.+              Nothing -> pure count+              Just Nothing -> pure count+              Just (Just batches) -> drainAll (count + length batches)+      total <- drainAll 0+      total `shouldBe` n
+ test/Reflex/Vty/HostSpec.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Host lifecycle, backpressure, and failure semantics.+--+-- All scenarios run the real 'Reflex.Vty.Host.runVtyAppWithHandle'+-- against the recording terminal from "Reflex.Vty.Test.AppHarness".+-- Host tests are serial because signal handlers are process-global.+module Reflex.Vty.HostSpec (spec) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Async (Async, cancel, waitCatch)+import Control.Concurrent.MVar+import Control.Exception (SomeException, throwIO, try)+import Control.Monad (forM_, replicateM_, when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef+import Data.List (isInfixOf)+import qualified Graphics.Vty as V+import Reflex+import System.Timeout (timeout)+import Test.Hspec++#if !defined(mingw32_HOST_OS)+import System.Posix.Signals (Handler (Catch), installHandler, sigUSR1)+#endif++import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+  ( RecordingVtyConfig (..)+  , defaultRecordingVtyConfig+  , recordingLogHistory+  , recordingReleaseGate+  , recordingVty+  , runHostAsync+  )++-- | Burst for the drain regression: far beyond what a+-- one-redraw-per-batch loop could finish inside 'defaultDeadline'.+burstN :: Int+burstN = 10000++-- | Occurrence-preservation burst, deliberately far beyond the queue+-- capacity used in that test so backpressure provably engages.+overloadN :: Int+overloadN = 50000++-- | Deadlines (microseconds).+defaultDeadline :: Int+defaultDeadline = 10 * 1000000++slowDeadline :: Int+slowDeadline = 30 * 1000000++-- | Count exact log-marker occurrences.+countIn :: String -> [String] -> Int+countIn tag logs = length [() | l <- logs, l == tag]++-- | An empty-picture result that shuts down on the given event.+emptyPictureResult :: Reflex t => Event t () -> VtyResult t+emptyPictureResult shutdown =+  VtyResult+    { _vtyResult_picture = constant (V.picForImage V.emptyImage)+    , _vtyResult_shutdown = shutdown+    }++-- | Build a guest with an external tick trigger and a stop trigger.+-- Hand both fire functions to the test through the 'MVar' during+-- guest construction. The result builder receives the tick and stop+-- events.+triggerGuest+  :: MVar (() -> IO () -> IO (), () -> IO () -> IO ())+  -> (forall t. Reflex t => Event t () -> Event t () -> VtyResult t)+  -> (forall t m. VtyApp t m)+triggerGuest ready mkResult _dr _inp _sigs = do+  (tickE, fireTick) <- newTriggerEventWithOnComplete+  (stopE, fireStop) <- newTriggerEventWithOnComplete+  -- Subscribe to the tick so occurrences do real frame work.+  performEvent_ $ ffor tickE $ \() -> pure ()+  liftIO $ putMVar ready (fireTick, fireStop)+  return (mkResult tickE stopE)++-- | Expect the host to finish successfully within the deadline;+-- cancel it and fail with diagnostics otherwise.+expectHostOk :: Async () -> [String] -> IO ()+expectHostOk hostA logs = do+  r <- timeout slowDeadline (waitCatch hostA)+  case r of+    Nothing -> do+      cancel hostA+      expectationFailure+        ( "host did not terminate within deadline; log tail: "+            ++ show (drop (max 0 (length logs - 40)) logs)+        )+    Just (Left e) ->+      expectationFailure+        ( "host failed: "+            ++ show e+            ++ "; log tail: "+            ++ show (drop (max 0 (length logs - 40)) logs)+        )+    Just (Right ()) -> pure ()++spec :: Spec+spec = describe "Reflex.Vty.Host" $ do+  describe "runVtyAppWithHandle" $ do+    it "drains a burst of external triggers in bounded frames (regression)" $ do+      -- The old host drew once per queued batch and could not reach+      -- shutdown inside the deadline; the draining host redraws once+      -- per drain.+      ready <- newEmptyMVar+      let cfg = defaultVtyAppConfig+          guest :: VtyApp t m+          guest = triggerGuest ready (\_tick stop -> emptyPictureResult stop)+      (vty, st) <- recordingVty defaultRecordingVtyConfig+      hostA <- runHostAsync cfg vty guest+      (fireTick, fireStop) <- takeMVar ready+      _ <- forkIO $ replicateM_ burstN (fireTick () (pure ())) >> fireStop () (pure ())+      logsAfter <- recordingLogHistory st+      expectHostOk hostA logsAfter+      logs <- recordingLogHistory st+      countIn "draw" logs `shouldSatisfy` (< 100)++    it "preserves every occurrence of an overloaded external trigger (backpressure)" $ do+      counter <- newIORef (0 :: Int)+      ready <- newEmptyMVar+      let cfg = defaultVtyAppConfig {_vtyConfig_eventQueueCapacity = 16}+          guest :: VtyApp t m+          guest = triggerGuest ready (\_tick stop -> emptyPictureResult stop)+      (vty, st) <- recordingVty defaultRecordingVtyConfig+      hostA <- runHostAsync cfg vty guest+      (fireTick, fireStop) <- takeMVar ready+      _ <- forkIO $ do+        replicateM_ overloadN $ fireTick () (atomicModifyIORef' counter (\i -> (i + 1, ())))+        fireStop () (pure ())+      logsAfter <- recordingLogHistory st+      expectHostOk hostA logsAfter+      readIORef counter `shouldReturn` overloadN++    it "drains a gated, capacity-filling burst with bounded redraws" $ do+      ready <- newEmptyMVar+      let cfg = defaultVtyAppConfig {_vtyConfig_eventQueueCapacity = 10001}+          guest :: VtyApp t m+          guest = triggerGuest ready (\_tick stop -> emptyPictureResult stop)+      (vty, st) <- recordingVty defaultRecordingVtyConfig {recordingGateRedraw = True}+      hostA <- runHostAsync cfg vty guest+      (fireTick, fireStop) <- takeMVar ready+      -- The initial redraw is gated. Enqueue the entire finite burst+      -- and the shutdown: 10,001 writes fit the 10,001-capacity queue,+      -- so the producer cannot deadlock against the gate.+      forM_ [1 .. 10000 :: Int] $ \_ -> fireTick () (pure ())+      fireStop () (pure ())+      recordingReleaseGate st+      logsAfter <- recordingLogHistory st+      expectHostOk hostA logsAfter+      logs <- recordingLogHistory st+      countIn "draw" logs `shouldSatisfy` (<= 3)++    it "terminates immediately on post-build shutdown without drawing" $ do+      -- Regression: post-build shutdown used to be lost (the shutdown+      -- subscription happened after the post-build fire), leaving the+      -- host blocked on input forever.+      let guest :: VtyApp t m+          guest _dr _inp _sigs = do+            pb <- getPostBuild+            return (emptyPictureResult pb)+      (vty, st) <- recordingVty defaultRecordingVtyConfig+      hostA <- runHostAsync defaultVtyAppConfig vty guest+      r <- timeout defaultDeadline (waitCatch hostA)+      case r of+        Nothing -> cancel hostA >> expectationFailure "host did not terminate at post-build shutdown"+        Just (Left e) -> expectationFailure ("host failed: " ++ show e)+        Just (Right ()) -> pure ()+      logs <- recordingLogHistory st+      countIn "draw" logs `shouldBe` 0 -- no unnecessary frame was drawn+    it "terminates immediately when a post-build perform-event requests shutdown" $ do+      let guest :: VtyApp t m+          guest _dr _inp _sigs = do+            (stopE, fireStop) <- newTriggerEventWithOnComplete+            pb <- getPostBuild+            performEvent_ $ ffor pb $ \_ -> liftIO (fireStop () (pure ()))+            return (emptyPictureResult (() <$ stopE))+      (vty, st) <- recordingVty defaultRecordingVtyConfig+      hostA <- runHostAsync defaultVtyAppConfig vty guest+      r <- timeout defaultDeadline (waitCatch hostA)+      case r of+        Nothing -> cancel hostA >> expectationFailure "host did not terminate on perform-event shutdown"+        Just (Left e) -> expectationFailure ("host failed: " ++ show e)+        Just (Right ()) -> pure ()+      logs <- recordingLogHistory st+      -- The stop request travels through the external-trigger queue.+      -- The host therefore draws at most the initial picture, never+      -- starts the input pump, and runs no interactive frame.+      countIn "draw" logs `shouldSatisfy` (<= 1)++    it "runs processed trigger callbacks exactly once, without subscribers" $ do+      callbacks <- newIORef (0 :: Int)+      ready <- newEmptyMVar+      let guest :: VtyApp t m+          guest _dr _inp _sigs = do+            (fireE, fire) <- newTriggerEventWithOnComplete+            (stopE, fireStop) <- newTriggerEventWithOnComplete+            -- Nobody subscribes to fireE; its occurrences must still+            -- run their completion callbacks exactly once each when+            -- processed.+            liftIO $ putMVar ready (fire, fireStop)+            return (emptyPictureResult (() <$ stopE))+      (vty, _) <- recordingVty defaultRecordingVtyConfig+      hostA <- runHostAsync defaultVtyAppConfig vty guest+      (fire, fireStop) <- takeMVar ready+      let bump = atomicModifyIORef' callbacks (\i -> (i + 1, ()))+      fire () bump+      fire () bump+      fire () bump+      fireStop () (pure ())+      r <- timeout defaultDeadline (waitCatch hostA)+      case r of+        Nothing -> cancel hostA >> expectationFailure "host did not terminate"+        Just (Left e) -> expectationFailure ("host failed: " ++ show e)+        Just (Right ()) -> pure ()+      readIORef callbacks `shouldReturn` 3++    describe "failure scenarios" $ do+      it "propagates guest construction failure and shuts vty down once" $ do+        let guest :: VtyApp t m+            guest _dr _inp _sigs = liftIO (ioError (userError "guest-boom"))+        (vty, st) <- recordingVty defaultRecordingVtyConfig+        r <- timeout defaultDeadline (try (runVtyAppWithHandle defaultVtyAppConfig vty guest) :: IO (Either SomeException ()))+        case r of+          Nothing -> expectationFailure "host did not fail fast"+          Just (Left e) -> show e `shouldContain` "guest-boom"+          Just (Right ()) -> expectationFailure "expected the guest failure to propagate"+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "propagates initial update failure" $ do+        ready <- newEmptyMVar+        let guest :: VtyApp t m+            guest = triggerGuest ready (\_tick _stop -> emptyPictureResult never)+        (vty, st) <-+          recordingVty+            defaultRecordingVtyConfig+              { recordingOnPicture = \_ -> throwIO (userError "update-boom")+              }+        hostA <- runHostAsync defaultVtyAppConfig vty guest+        r <- timeout defaultDeadline (waitCatch hostA)+        case r of+          Nothing -> cancel hostA >> expectationFailure "host did not fail fast"+          Just (Left e) -> show e `shouldContain` "update-boom"+          Just (Right ()) -> expectationFailure "expected the update failure to propagate"+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "propagates a later update failure" $ do+        ready <- newEmptyMVar+        drawRef <- newIORef (0 :: Int)+        let guest :: VtyApp t m+            guest = triggerGuest ready (\_tick stop -> emptyPictureResult stop)+        (vty, st) <-+          recordingVty+            defaultRecordingVtyConfig+              { recordingOnPicture = \_ -> do+                  n <- atomicModifyIORef' drawRef (\i -> (i + 1, i + 1))+                  when (n >= 2) $ throwIO (userError "later-update-boom")+              }+        hostA <- runHostAsync defaultVtyAppConfig vty guest+        (fireTick, _) <- takeMVar ready+        -- One tick forces the next drain's redraw. The guest never+        -- shuts down, so the host must make that redraw (and its+        -- failure) happen.+        fireTick () (pure ())+        r <- timeout defaultDeadline (waitCatch hostA)+        case r of+          Nothing -> cancel hostA >> expectationFailure "host did not fail fast"+          Just (Left e) -> show e `shouldContain` "later-update-boom"+          Just (Right ()) -> expectationFailure "expected the later update failure to propagate"+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "propagates input-reader failure" $ do+        let guest :: VtyApp t m+            guest _dr _inp _sigs = return (emptyPictureResult never)+        (vty0, st) <- recordingVty defaultRecordingVtyConfig+        let vty = vty0 {V.nextEvent = throwIO (userError "input-boom")}+        hostA <- runHostAsync defaultVtyAppConfig vty guest+        r <- timeout defaultDeadline (waitCatch hostA)+        case r of+          Nothing -> cancel hostA >> expectationFailure "input failure did not propagate"+          Just (Left e) -> show e `shouldContain` "input-boom"+          Just (Right ()) -> expectationFailure "expected input failure to fail the host"+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "propagates perform-event failure" $ do+        let guest :: VtyApp t m+            guest _dr _inp _sigs = do+              pb <- getPostBuild+              performEvent_ $ ffor pb $ \_ -> liftIO (throwIO (userError "perform-boom"))+              return (emptyPictureResult never)+        (vty, st) <- recordingVty defaultRecordingVtyConfig+        r <- timeout defaultDeadline (try (runVtyAppWithHandle defaultVtyAppConfig vty guest) :: IO (Either SomeException ()))+        case r of+          Nothing -> expectationFailure "host did not fail fast"+          Just (Left e) -> show e `shouldContain` "perform-boom"+          Just (Right ()) -> expectationFailure "expected perform-event failure to propagate"+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "releases a backpressured producer on external cancellation" $ do+        producerDone <- newEmptyMVar+        ready <- newEmptyMVar+        let cfg = defaultVtyAppConfig {_vtyConfig_eventQueueCapacity = 1}+            guest :: VtyApp t m+            guest = triggerGuest ready (\_tick stop -> emptyPictureResult stop)+        (vty, st) <- recordingVty defaultRecordingVtyConfig+        hostA <- runHostAsync cfg vty guest+        (fireTick, _) <- takeMVar ready+        _ <- forkIO $ do+          -- Fires far more than the capacity: it backpressures until+          -- cancellation closes the queue, then finishes.+          replicateM_ 100 (fireTick () (pure ()))+          putMVar producerDone ()+        threadDelay 200000 -- let the producer hit the full queue+        cancel hostA+        done <- timeout defaultDeadline (takeMVar producerDone)+        done `shouldBe` Just ()+        _ <- waitCatch hostA+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "prefers the application failure over a cleanup failure, still running later cleanup" $ do+        let guest :: VtyApp t m+            guest _dr _inp _sigs = liftIO (ioError (userError "app-boom"))+        (vty0, st) <- recordingVty defaultRecordingVtyConfig+        let vty =+              vty0+                { V.outputIface =+                    (V.outputIface vty0)+                      { V.outputByteBuffer = \_ -> throwIO (userError "cleanup-boom")+                      }+                }+        r <- timeout defaultDeadline (try (runVtyAppWithHandle defaultVtyAppConfig vty guest) :: IO (Either SomeException ()))+        case r of+          Nothing -> expectationFailure "host did not fail fast"+          Just (Left e) -> do+            show e `shouldContain` "app-boom"+            show e `shouldNotContain` "cleanup-boom"+          Just (Right ()) -> expectationFailure "expected the application failure"+        -- Later cleanup steps still ran despite the cursor/screen+        -- restore failing.+        logs <- recordingLogHistory st+        countIn "vty:shutdown" logs `shouldBe` 1++      it "attempts cursor and screen restoration on normal shutdown" $ do+        ready <- newEmptyMVar+        let guest :: VtyApp t m+            guest = triggerGuest ready (\_tick stop -> emptyPictureResult stop)+        (vty, st) <- recordingVty defaultRecordingVtyConfig+        hostA <- runHostAsync defaultVtyAppConfig vty guest+        (_, fireStop) <- takeMVar ready+        fireStop () (pure ())+        r <- timeout defaultDeadline (waitCatch hostA)+        case r of+          Nothing -> cancel hostA >> expectationFailure "host did not terminate"+          Just (Left e) -> expectationFailure ("host failed: " ++ show e)+          Just (Right ()) -> pure ()+        logs <- recordingLogHistory st+        -- The primary-screen restore emits escape sequence 1049l+        -- through the output byte buffer.+        any ("?1049l" `isInfixOf`) logs `shouldBe` True+        countIn "vty:shutdown" logs `shouldBe` 1++#if !defined(mingw32_HOST_OS)+      it "restores prior signal handlers on shutdown" $ do+        priorCount <- newIORef (0 :: Int)+        _ <- installHandler sigUSR1 (Catch (atomicModifyIORef' priorCount (\i -> (i + 1, ())))) Nothing+        ready <- newEmptyMVar+        -- The guest signals construction completion at post-build.+        -- The host installs signal handlers before post-build, so the+        -- handshake cannot race installation.+        let guest :: VtyApp t m+            guest _dr _inp _sigs = do+              pb <- getPostBuild+              performEvent_ $ ffor pb $ \_ -> liftIO (putMVar ready ())+              return (emptyPictureResult never)+        (vty, _) <- recordingVty defaultRecordingVtyConfig+        hostA <- runHostAsync defaultVtyAppConfig vty guest+        _ <- timeout defaultDeadline (takeMVar ready)+        cancel hostA+        _ <- waitCatch hostA+        -- Retrieve the currently active handler: it must be the prior+        -- counting handler again.+        active <- installHandler sigUSR1 (Catch (pure ())) Nothing+        case active of+          Catch act -> act+          _ -> expectationFailure "expected the prior handler to be restored"+        _ <- installHandler sigUSR1 active Nothing+        readIORef priorCount `shouldReturn` 1+#endif
+ test/Reflex/Vty/StyleJoinSpec.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.StyleJoinSpec (spec) where++import qualified Graphics.Vty as V+import Test.Hspec++import Reflex.Vty.Style++spec :: Spec+spec = describe "Image composition" $ do+  let imgA = V.text' V.defAttr "AB"+      imgB = V.text' V.defAttr "XYZ"++  describe "joinHorizontal" $ do+    it "concatenates images side by side" $ do+      let result = joinHorizontal VAlignTop [imgA, imgB]+      V.imageWidth result `shouldBe` 5++    it "returns empty for empty list" $ do+      V.imageWidth (joinHorizontal VAlignTop []) `shouldBe` 0++    it "pads shorter images to match tallest" $ do+      let tall = V.charFill V.defAttr 'X' 2 3+          short = V.text' V.defAttr "AB"+          result = joinHorizontal VAlignTop [short, tall]+      V.imageHeight result `shouldBe` 3++    it "top-aligns (shorter gets bottom padding)" $ do+      let tall = V.charFill V.defAttr 'X' 2 3+          short = V.text' V.defAttr "AB"+          result = joinHorizontal VAlignTop [short, tall]+      V.imageHeight result `shouldBe` 3++    it "bottom-aligns (shorter gets top padding)" $ do+      let tall = V.charFill V.defAttr 'X' 2 3+          short = V.text' V.defAttr "AB"+          result = joinHorizontal VAlignBottom [short, tall]+      V.imageHeight result `shouldBe` 3++  describe "joinVertical" $ do+    it "stacks images vertically" $ do+      let result = joinVertical HAlignLeft [imgA, imgB]+      V.imageHeight result `shouldBe` 2++    it "returns empty for empty list" $ do+      V.imageHeight (joinVertical HAlignLeft []) `shouldBe` 0++    it "pads narrower images to match widest" $ do+      let wide = V.charFill V.defAttr 'X' 5 1+          narrow = V.text' V.defAttr "AB"+          result = joinVertical HAlignLeft [narrow, wide]+      V.imageWidth result `shouldBe` 5++  describe "placeHorizontal" $ do+    it "left-aligns within target width" $ do+      let result = placeHorizontal HAlignLeft 5 imgA+      V.imageWidth result `shouldBe` 5++    it "right-aligns within target width" $ do+      let result = placeHorizontal HAlignRight 5 imgA+      V.imageWidth result `shouldBe` 5++    it "center-aligns within target width" $ do+      let result = placeHorizontal HAlignCenter 6 imgA+      V.imageWidth result `shouldBe` 6++    it "returns image as-is when already at target width" $ do+      let result = placeHorizontal HAlignLeft 2 imgA+      V.imageWidth result `shouldBe` 2++  describe "placeVertical" $ do+    it "top-aligns within target height" $ do+      let result = placeVertical VAlignTop 3 imgA+      V.imageHeight result `shouldBe` 3++    it "bottom-aligns within target height" $ do+      let result = placeVertical VAlignBottom 3 imgA+      V.imageHeight result `shouldBe` 3++  describe "place" $ do+    it "places within both dimensions" $ do+      let result = place HAlignCenter VAlignMiddle 6 3 imgA+      V.imageWidth result `shouldBe` 6+      V.imageHeight result `shouldBe` 3
+ test/Reflex/Vty/StyleSpec.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.StyleSpec (spec) where++import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import qualified Graphics.Vty.Attributes.Color as V.Color+import qualified Graphics.Vty.Image as V.Image+import Test.Hspec++import Reflex.Vty.Style+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), imageText, imageToGrid)++spec :: Spec+spec = describe "Reflex.Vty.Style" $ do+  describe "inherit" $ do+    let parent = withForeground red . withBold . withWidth 10 $ def+    it "keeps the child's foreground when set" $ do+      let child = withForeground blue def+      _style_foreground (inherit parent child) `shouldBe` Just blue+    it "inherits the parent's foreground when the child's is Nothing" $ do+      let child = def+      _style_foreground (inherit parent child) `shouldBe` Just red+    it "keeps the child's width when set" $ do+      let child = withWidth 5 def+      _style_width (inherit parent child) `shouldBe` Just 5+    it "inherits the parent's width when the child's is Nothing" $ do+      let child = def+      _style_width (inherit parent child) `shouldBe` Just 10+    it "inherits the parent's bold flag when the child's is Nothing" $ do+      let child = def+      _style_bold (inherit parent child) `shouldBe` Just True++  describe "applyAttr" $ do+    it "applies the foreground color" $ do+      let s = withForeground red def+      V.attrForeColor (applyAttr s V.defAttr) `shouldBe` V.SetTo red+    it "applies the background color" $ do+      let s = withBackground blue def+      V.attrBackColor (applyAttr s V.defAttr) `shouldBe` V.SetTo blue+    it "applies bold when Just True" $ do+      let s = withBold def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.bold `shouldBe` True+    it "does not apply bold when Nothing" $ do+      V.hasStyle (V.styleMask (applyAttr def V.defAttr)) V.bold `shouldBe` False+    it "applies underline for UnderlineSingle" $ do+      let s = withUnderline UnderlineSingle def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.underline `shouldBe` True+    it "does not apply underline for UnderlineNone" $ do+      let s = withUnderline UnderlineNone def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.underline `shouldBe` False+    it "applies italic" $ do+      let s = withItalic def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.italic `shouldBe` True+    it "applies faint (dim)" $ do+      let s = withFaint def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.dim `shouldBe` True+    it "applies blink" $ do+      let s = withBlink def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.blink `shouldBe` True+    it "applies strikethrough" $ do+      let s = withStrikethrough def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.strikethrough `shouldBe` True+    it "applies reverse video" $ do+      let s = withReverse def+      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.reverseVideo `shouldBe` True+    it "applies the hyperlink URL" $ do+      let s = withHyperlink "https://example.com" def+      V.attrURL (applyAttr s V.defAttr) `shouldBe` V.SetTo "https://example.com"+    it "leaves the base attr unchanged for def" $ do+      applyAttr def V.defAttr `shouldBe` V.defAttr++  describe "mergeAttr" $ do+    let base = V.defAttr `V.withForeColor` red `V.withBackColor` blue+    it "uses overlay's SetTo fields over the base" $ do+      let overlay = V.defAttr `V.withForeColor` green+          result = mergeAttr base overlay+      V.attrForeColor result `shouldBe` V.SetTo green+      V.attrBackColor result `shouldBe` V.SetTo blue+    it "falls through to base when overlay is Default" $ do+      let overlay = V.defAttr+          result = mergeAttr base overlay+      V.attrForeColor result `shouldBe` V.SetTo red+      V.attrBackColor result `shouldBe` V.SetTo blue+    it "falls through to base when overlay is KeepCurrent" $ do+      let overlay = V.Attr {V.attrStyle = V.KeepCurrent, V.attrForeColor = V.KeepCurrent, V.attrBackColor = V.KeepCurrent, V.attrURL = V.KeepCurrent}+          result = mergeAttr base overlay+      V.attrForeColor result `shouldBe` V.SetTo red++  describe "render" $ do+    it "produces a non-empty image for plain text" $ do+      let img = render def "hello"+      V.Image.imageWidth img `shouldSatisfy` (> 0)+      V.Image.imageHeight img `shouldBe` 1+    it "respects withWidth by padding" $ do+      let img = render (withWidth 10 def) "hi"+      V.Image.imageWidth img `shouldBe` 10+    it "respects withHeight by padding" $ do+      let img = render (withHeight 3 def) "hi"+      V.Image.imageHeight img `shouldBe` 3+    it "respects withMaxWidth by clipping" $ do+      let img = render (withMaxWidth 3 def) "hello"+      V.Image.imageWidth img `shouldBe` 3+    it "respects withMaxHeight by clipping" $ do+      let img = render (withMaxHeight 1 def) "hello"+      V.Image.imageHeight img `shouldBe` 1+    it "adds padding around content" $ do+      let s = withPadding 1 1 1 1 def+          img = render s "hi"+      V.Image.imageWidth img `shouldBe` 4+      V.Image.imageHeight img `shouldBe` 3+    it "adds a border around content" $ do+      let s = withBorder singleBorder def+          img = render s "hi"+      V.Image.imageWidth img `shouldBe` 4+      V.Image.imageHeight img `shouldBe` 3+    it "adds margin outside content" $ do+      let s = withMargin 1 1 1 1 def+          img = render s "hi"+      V.Image.imageWidth img `shouldBe` 4+      V.Image.imageHeight img `shouldBe` 3+    it "renders multi-line text with correct height" $ do+      let img = render def "hello\nworld"+      V.Image.imageHeight img `shouldBe` 2+    it "renders multi-line text width as longest line" $ do+      let img = render def "hello\nhi"+      V.Image.imageWidth img `shouldBe` 5+    it "renders wide characters at correct width" $ do+      let img = render def "文"+      V.Image.imageWidth img `shouldBe` 2++  describe "measure" $ do+    it "matches render's width for plain text" $ do+      let s = def+      fst (measure s "hello") `shouldBe` V.Image.imageWidth (render s "hello")+    it "accounts for padding" $ do+      let s = withPadding 2 3 2 3 def+      fst (measure s "hi") `shouldBe` 2 + 3 + 3+    it "accounts for border" $ do+      let s = withBorder singleBorder def+      fst (measure s "hi") `shouldBe` 2 + 2+    it "accounts for margin" $ do+      let s = withMargin 1 1 1 1 def+      fst (measure s "hi") `shouldBe` 2 + 2+    it "measures multi-line text with correct height" $ do+      snd (measure def "hello\nworld") `shouldBe` 2+    it "measures multi-line text with correct width" $ do+      fst (measure def "hello\nhi") `shouldBe` 5+    it "measures multi-line text with matching render dimensions" $ do+      let s = withBorder singleBorder def+          (w, h) = measure s "hello\nworld"+          img = render s "hello\nworld"+      w `shouldBe` V.Image.imageWidth img+      h `shouldBe` V.Image.imageHeight img+    it "measures wide characters at display width" $ do+      fst (measure def "文") `shouldBe` 2+    it "measures mixed wide and narrow characters" $ do+      fst (measure def "a文b") `shouldBe` 4+    it "measures empty content as zero width, one line" $ do+      measure def "" `shouldBe` (0, 1)++  describe "withTransform" $ do+    it "applies transform before rendering" $ do+      let img = render (withTransform T.toUpper def) "hello"+      V.Image.imageWidth img `shouldBe` 5++    it "renders transformed text" $ do+      let img = render (withTransform (T.replace "a" "AA") def) "cat"+      V.Image.imageWidth img `shouldBe` 4++  describe "withTabWidth" $ do+    it "expands tabs to spaces" $ do+      let img = render (withTabWidth 4 def) "a\tb"+      V.Image.imageWidth img `shouldBe` 6++    it "does not expand tabs when not set" $ do+      let img = render def "a\tb"+      V.Image.imageWidth img `shouldSatisfy` (< 6)++  describe "withMarginBackground" $ do+    it "produces correct dimensions with margin background" $ do+      let s = withMarginBackground red . withMargin 1 1 1 1 $ def+          (w, h) = measure s "hi"+      w `shouldBe` 4+      h `shouldBe` 3++  describe "new border presets" $ do+    it "innerHalfBorder has all sides" $ do+      _border_top innerHalfBorder `shouldBe` Just '▀'+      _border_left innerHalfBorder `shouldBe` Just '▌'+    it "outerHalfBlockBorder has all sides" $ do+      _border_top outerHalfBlockBorder `shouldBe` Just '▔'+      _border_left outerHalfBlockBorder `shouldBe` Just '▏'+    it "renders innerHalfBorder" $ do+      let img = render (withBorder innerHalfBorder def) "X"+      V.Image.imageWidth img `shouldBe` 3+      V.Image.imageHeight img `shouldBe` 3++  describe "image composition coordinates" $ do+    let imgA = render def "ab"+        imgTall = render def "x\ny"+    it "placeHorizontal aligns content within the padded width" $ do+      imageText (placeHorizontal HAlignLeft 5 imgA) `shouldBe` ["ab   "]+      imageText (placeHorizontal HAlignCenter 5 imgA) `shouldBe` [" ab  "]+      imageText (placeHorizontal HAlignRight 5 imgA) `shouldBe` ["   ab"]+    it "placeVertical aligns content within the padded height" $ do+      imageText (placeVertical VAlignTop 3 imgA) `shouldBe` ["ab", "  ", "  "]+      imageText (placeVertical VAlignBottom 3 imgA) `shouldBe` ["  ", "  ", "ab"]+    it "place combines both axes" $ do+      imageText (place HAlignRight VAlignBottom 4 2 imgA) `shouldBe` ["    ", "  ab"]+    it "joinHorizontal pads to the tallest and concatenates widths" $ do+      let joined = joinHorizontal VAlignTop [imgA, imgTall]+      V.imageWidth joined `shouldBe` 3+      V.imageHeight joined `shouldBe` 2+      imageText joined `shouldBe` ["abx", "  y"]+    it "joinVertical pads to the widest and stacks heights" $ do+      let joined = joinVertical HAlignRight [imgA, imgTall]+      V.imageWidth joined `shouldBe` 2+      V.imageHeight joined `shouldBe` 3+      imageText joined `shouldBe` ["ab", " x", " y"]+    it "placeHorizontal leaves oversized images untouched" $ do+      imageText (placeHorizontal HAlignCenter 1 imgA) `shouldBe` ["ab"]++  describe "hyperlinks" $ do+    it "renders the URL attribute onto the text" $ do+      let img = render (withHyperlink "https://example.com" def) "link"+          grid = imageToGrid img+      case gridRows grid of+        [[s]] -> do+          V.fixedURL (renderSpanAttr s) `shouldBe` Just "https://example.com"+          T.unpack (renderSpanText s) `shouldBe` "link"+        _ -> expectationFailure "expected one row with one span"
+ test/Reflex/Vty/Test/AppHarness.hs view
@@ -0,0 +1,607 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: A deterministic harness around the production widget host+--+-- This module runs real widget applications through+-- 'Reflex.Vty.Widget.mainWidgetWithHandle' against a fully implemented+-- recording 'V.Vty'. It never recreates the widget transformer stack.+--+-- Determinism comes from /fences/. Every injected terminal input is+-- followed by a reserved marker event ('V.KFun' with a negative+-- argument, which terminals cannot produce). Every injected command is+-- followed by a control message. The widget tree observes the+-- marker's arrival and stamps it onto the next drawn frame. A step+-- therefore returns exactly the frame in which its input or command+-- took effect. Markers never reach the application under test. All+-- waits are STM-based and race against host failure, so a dying host+-- can never hang a test. Every step has a deadline. Timeouts report+-- the outstanding fence, recent frames, and the output\/lifecycle+-- log.+module Reflex.Vty.Test.AppHarness+  ( -- * Widget applications under test+    TestWidget+  , TestApp+  , Frame (..)+  , AppDriver (..)+  , withApp+  , awaitFrameWhereFor++    -- * Failures+  , HarnessTimeout (..)+  , HostFailure (..)+  , UnexpectedOperation (..)++    -- * Lower-level host access+  , RecordingVtyConfig (..)+  , defaultRecordingVtyConfig+  , runHostAsync+  , recordingVty+  , RecordingState (..)+  , recordingLog+  , recordingLogHistory+  , recordingInput+  , recordingSetBounds+  , recordingReleaseGate+  ) where++import Control.Concurrent.Async+  ( Async+  , async+  , cancel+  , poll+  , waitCatch+  , waitCatchSTM+  )+import Control.Concurrent.STM+  ( STM+  , TMVar+  , TQueue+  , TVar+  , atomically+  , check+  , modifyTVar'+  , newEmptyTMVarIO+  , newTMVarIO+  , newTQueueIO+  , newTVarIO+  , readTMVar+  , readTQueue+  , readTVar+  , readTVarIO+  , retry+  , tryReadTQueue+  , writeTQueue+  , writeTVar+  )+import Control.Exception (Exception, SomeException, catch, displayException, throwIO, try)+import Control.Monad (forM_, void, when)+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import Data.IORef+  ( IORef+  , atomicModifyIORef'+  , modifyIORef'+  , newIORef+  , readIORef+  , writeIORef+  )+import Data.List (intercalate)+import GHC.Conc (unsafeIOToSTM)+import qualified Graphics.Vty as V+import Graphics.Vty.Attributes.Color (ColorMode (..))+import Reflex+import System.Timeout (timeout)++import Control.Monad.NodeId (MonadNodeId)+import Reflex.Vty.Host (MonadVtyApp, VtyApp, VtyAppConfig)+import qualified Reflex.Vty.Host as Host+import Reflex.Vty.Test.Snapshot (Grid, pictureToGrid)+import Reflex.Vty.Widget++-- | Exactly the constraint set 'Reflex.Vty.Widget.mainWidgetWithHandle'+-- accepts for its child widget. This is a constraint alias only: the+-- application under test runs in the production widget stack.+type TestWidget t m =+  ( MonadVtyApp t m+  , MonadNodeId m+  , HasImageWriter t m+  , HasDisplayRegion t m+  , HasFocusReader t m+  , HasInput t m+  , HasTheme t m+  , HasColorProfile t m+  , HasCursor t m+  , HasScreenMode t m+  )++-- | A widget application under test: it receives an event of external+-- commands (fired by 'stepCommand') and returns its current+-- observation together with a shutdown event.+type TestApp command observation =+  forall t m. TestWidget t m => Event t command -> m (Dynamic t observation, Event t ())++-- | One drawn frame: what the terminal actually received.+data Frame observation = Frame+  { frameNumber :: !Int+  -- ^ Monotonically increasing draw counter.+  , frameFence :: !Word+  -- ^ The fence stamped into this frame (0 = none yet).+  , frameViewport :: !V.DisplayRegion+  -- ^ The root viewport the application actually rendered with.+  , frameGrid :: Grid+  -- ^ The rendered picture, normalized through the independent oracle.+  , frameCursor :: V.Cursor+  -- ^ The picture's cursor request.+  , framePicture :: V.Picture+  -- ^ The raw picture, for assertion diagnostics.+  , frameObservation :: observation+  -- ^ The application's observed value at draw time.+  }++-- | The handle for driving one running application.+data AppDriver command observation = AppDriver+  { stepInput :: V.Event -> IO (Frame observation)+  -- ^ Deliver a terminal input event and return the frame in which it+  -- took effect.+  , stepCommand :: command -> IO (Frame observation)+  -- ^ Fire an external command and return the frame in which it took+  -- effect.+  , resizeApp :: V.DisplayRegion -> IO (Frame observation)+  -- ^ Change the terminal size, run the production resize debounce,+  -- and return the first frame rendered at the requested size.+  , awaitFrameWhere :: (Frame observation -> Bool) -> IO (Frame observation)+  -- ^ Block (STM) until a /new/ frame satisfies the predicate.+  , driverAwaitFor :: Int -> (Frame observation -> Bool) -> IO (Frame observation)+  -- ^ 'awaitFrameWhere' with an explicit microsecond deadline.+  , stopApp :: IO ()+  -- ^ Request shutdown and wait for the host to finish.+  , driverFrames :: IO [Frame observation]+  -- ^ All frames recorded so far, oldest first.+  , driverOutputLog :: IO [String]+  -- ^ Ordered input, control, output-byte, mode-change, and shutdown+  -- trace.+  , driverReleaseRedrawGate :: IO ()+  -- ^ Release the redraw gate (a no-op unless the recorder was created+  -- with gating enabled).+  , driverHostResult :: IO (Maybe (Either SomeException ()))+  -- ^ 'Nothing' while the host runs; otherwise its final result.+  }++-- | 'awaitFrameWhere' with an explicit microsecond deadline.+awaitFrameWhereFor+  :: AppDriver command observation -> Int -> (Frame observation -> Bool) -> IO (Frame observation)+awaitFrameWhereFor = driverAwaitFor++-- | Default per-operation deadline (microseconds).+defaultDeadline :: Int+defaultDeadline = 10 * 1000000++-- | Deadline for sustained-trigger scenarios, including the production+-- resize debounce and scrollbar quiet period (microseconds).+slowDeadline :: Int+slowDeadline = 30 * 1000000++-- | A step deadline expired.+newtype HarnessTimeout = HarnessTimeout String+  deriving (Show)++instance Exception HarnessTimeout++-- | The host failed while a step was waiting.+newtype HostFailure = HostFailure String+  deriving (Show)++instance Exception HostFailure++----------------------------------------------------------------------------+-- Recording Vty+----------------------------------------------------------------------------++-- | The recording terminal throws this for operations that no+-- supported host action performs.+newtype UnexpectedOperation = UnexpectedOperation String+  deriving (Show)++instance Exception UnexpectedOperation++-- | Configuration for the recording terminal.+data RecordingVtyConfig = RecordingVtyConfig+  { recordingColorMode :: V.ColorMode+  -- ^ Reported terminal color mode ('FullColor' by default).+  , recordingGateRedraw :: Bool+  -- ^ When true, every redraw blocks until 'recordingReleaseGate'.+  , recordingInitialBounds :: V.DisplayRegion+  , recordingOnPicture :: V.Picture -> IO ()+  -- ^ Called on every redraw with the drawn picture.+  }++-- | A sensible default: full color, no gating, 80x24, no observer.+defaultRecordingVtyConfig :: RecordingVtyConfig+defaultRecordingVtyConfig =+  RecordingVtyConfig+    { recordingColorMode = FullColor+    , recordingGateRedraw = False+    , recordingInitialBounds = (80, 24)+    , recordingOnPicture = \_ -> pure ()+    }++-- | The mutable state behind the recording terminal.+data RecordingState = RecordingState+  { rsInputQueue :: TQueue V.Event+  , rsBoundsRef :: IORef V.DisplayRegion+  , rsGate :: TVar Bool+  , rsLogRef :: IORef [String]+  }++-- | Append to the ordered operation log (oldest first when read back).+recordingLog :: RecordingState -> String -> IO ()+recordingLog st msg = atomicModifyIORef' (rsLogRef st) (\acc -> (msg : acc, ()))++-- | Read the full ordered operation log.+recordingLogHistory :: RecordingState -> IO [String]+recordingLogHistory st = reverse <$> readIORef (rsLogRef st)++-- | Enqueue a terminal input event.+recordingInput :: RecordingState -> V.Event -> IO ()+recordingInput st e = do+  recordingLog st ("input: " ++ show e)+  atomically $ writeTQueue (rsInputQueue st) e++-- | Change the terminal size reported by the recorder.+recordingSetBounds :: RecordingState -> V.DisplayRegion -> IO ()+recordingSetBounds st b = do+  recordingLog st ("resize: " ++ show b)+  writeIORef (rsBoundsRef st) b++-- | Release the redraw gate (a no-op when ungated).+recordingReleaseGate :: RecordingState -> IO ()+recordingReleaseGate st = atomically (writeTVar (rsGate st) True)++-- | Build a fully implemented recording 'V.Vty' plus its state. Every+-- operation is real; operations unreachable through initialization,+-- rendering, mode changes, and teardown throw 'UnexpectedOperation'+-- rather than diverging.+recordingVty :: RecordingVtyConfig -> IO (V.Vty, RecordingState)+recordingVty cfg = do+  inputQueue <- newTQueueIO+  boundsRef <- newIORef (recordingInitialBounds cfg)+  gate <-+    if recordingGateRedraw cfg+      then newTVarIO False+      else newTVarIO True+  logRef <- newIORef ([] :: [String])+  let st =+        RecordingState+          { rsInputQueue = inputQueue+          , rsBoundsRef = boundsRef+          , rsGate = gate+          , rsLogRef = logRef+          }+      log msg = recordingLog st msg+      updateAction pic = do+        -- Blocking on a closed latch gates redraws in backpressure+        -- tests; an ungated latch returns immediately. The latch is+        -- level-triggered: every redraw waits until it is open.+        atomically (readTVar gate >>= check)+        log "draw"+        recordingOnPicture cfg pic+      input =+        V.Input+          { V.eventChannel = error "recordingVty: eventChannel unused (nextEvent is used)"+          , V.shutdownInput = log "input:shutdown"+          , V.restoreInputState = log "input:restore"+          , V.inputLogMsg = \_ -> pure ()+          }+  out <- recordingOutput cfg log boundsRef+  let vty =+        V.Vty+          { V.update = updateAction+          , V.nextEvent = atomically (readTQueue inputQueue)+          , V.nextEventNonblocking = atomically (tryReadTQueue inputQueue)+          , V.inputIface = input+          , V.outputIface = out+          , V.refresh = log "refresh"+          , V.shutdown = log "vty:shutdown"+          , V.isShutdown = pure False+          }+  pure (vty, st)++recordingOutput :: RecordingVtyConfig -> (String -> IO ()) -> IORef V.DisplayRegion -> IO V.Output+recordingOutput cfg log boundsRef =+  pure output+  where+    output =+      V.Output+        { V.terminalID = "reflex-vty-test-recorder"+        , V.releaseTerminal = log "output:releaseTerminal"+        , V.reserveDisplay = log "output:reserveDisplay"+        , V.releaseDisplay = log "output:releaseDisplay"+        , V.setDisplayBounds = \r -> log ("output:setDisplayBounds " ++ show r)+        , V.displayBounds = readIORef boundsRef+        , V.outputByteBuffer = \bs -> log ("output:bytes[" ++ show (BS.length bs) ++ "] " ++ show bs)+        , V.supportsCursorVisibility = True+        , V.supportsMode = const True+        , V.setMode = \m onOff -> log ("output:setMode " ++ show (m, onOff))+        , V.getModeStatus = \m -> do+            log ("output:getModeStatus " ++ show m)+            pure False+        , V.assumedStateRef = error "recordingVty: assumedStateRef unreachable"+        , V.mkDisplayContext = \_ _ ->+            throwIO (UnexpectedOperation "mkDisplayContext: the recorder draws no display context")+        , V.ringTerminalBell = log "output:bell"+        , V.supportsBell = pure True+        , V.supportsItalics = pure True+        , V.supportsStrikethrough = pure True+        , V.outputColorMode = recordingColorMode cfg+        , V.setOutputWindowTitle = \t -> log ("output:title " ++ show t)+        }++-- | Run the production host asynchronously. For startup-shutdown and+-- failure-injection scenarios that must not wait for a first frame.+runHostAsync :: VtyAppConfig -> V.Vty -> (forall t m. VtyApp t m) -> IO (Async ())+runHostAsync cfg vty app = async (Host.runVtyAppWithHandle cfg vty app)++----------------------------------------------------------------------------+-- Fence markers and control messages+----------------------------------------------------------------------------++-- | The reserved marker event encoding fence @n@. Terminals cannot+-- deliver negative function-key arguments, so these never collide with+-- real input.+markerEvent :: Word -> V.Event+markerEvent n = V.EvKey (V.KFun (negate (fromIntegral n))) []++markerFenceOf :: V.Event -> Maybe Word+markerFenceOf e = case e of+  V.EvKey (V.KFun n) [] | n < 0 -> Just (fromIntegral (negate n))+  _ -> Nothing++dropMarker :: V.Event -> Maybe V.Event+dropMarker e = case markerFenceOf e of+  Just _ -> Nothing+  Nothing -> Just e++-- | Control-stream messages. The application only ever sees+-- 'CtrlCommand' payloads.+data Ctrl c = CtrlCommand c | CtrlFence Word | CtrlStop++isCtrlStop :: Ctrl c -> Bool+isCtrlStop CtrlStop = True+isCtrlStop _ = False++ctrlCommand :: Ctrl c -> Maybe c+ctrlCommand (CtrlCommand c) = Just c+ctrlCommand _ = Nothing++ctrlFence :: Ctrl c -> Maybe Word+ctrlFence (CtrlFence n) = Just n+ctrlFence _ = Nothing++----------------------------------------------------------------------------+-- Frame waiting+----------------------------------------------------------------------------++-- | Block (STM) until a frame newer than the baseline satisfies the+-- predicate. The wait races against host failure. A deadline expiry+-- throws 'HarnessTimeout' with diagnostics.+awaitNewFrame+  :: forall observation+   . TVar [Frame observation]+  -> IORef (Maybe (Async ()))+  -> IO [String]+  -> Int+  -> Int+  -> (Frame observation -> Bool)+  -> IO (Frame observation)+awaitNewFrame framesVar hostRef logs deadline baseline p = do+  r <- timeout deadline (atomically stm)+  case r of+    Nothing -> timeoutFailure+    Just (Left hostErr) -> do+      details <- diagnostics+      throwIO+        ( HostFailure $+            "host failed while waiting for a frame: "+              ++ hostErr+              ++ "\n"+              ++ details+        )+    Just (Right f) -> pure f+  where+    stm :: STM (Either String (Frame observation))+    stm = do+      fs <- readTVar framesVar+      case [f | f <- drop baseline fs, p f] of+        (f : _) -> pure (Right f)+        [] -> do+          mh <- unsafeIOToSTM (readIORef hostRef)+          case mh of+            Just h -> do+              r <- waitCatchSTM h+              case r of+                Left e -> pure (Left (displayException e))+                Right _ -> retry+            Nothing -> retry+    diagnostics = do+      fs <- readTVarIO framesVar+      logLines <- logs+      pure $+        "frames="+          ++ show (length fs)+          ++ " baseline="+          ++ show baseline+          ++ "\nlast frames:\n"+          ++ intercalate "\n" (map describeFrame (drop (max 0 (length fs - 5)) fs))+          ++ "\nlog (tail):\n"+          ++ intercalate "\n" (drop (max 0 (length logLines - 30)) logLines)+    timeoutFailure = do+      details <- diagnostics+      throwIO (HarnessTimeout ("harness timeout after " ++ show deadline ++ "us\n" ++ details))+    describeFrame f =+      "frame#"+        ++ show (frameNumber f)+        ++ " fence="+        ++ show (frameFence f)+        ++ " viewport="+        ++ show (frameViewport f)+        ++ " cursor="+        ++ show (frameCursor f)++----------------------------------------------------------------------------+-- withApp+----------------------------------------------------------------------------++-- | Run a 'TestApp' against a recording terminal of the given initial+-- size. Hand the driver to the continuation. The harness awaits the+-- initial frame before the continuation runs. When the continuation+-- returns (or throws), the harness shuts down and joins the host.+withApp+  :: forall command observation a+   . Show observation+  => VtyAppConfig+  -> V.DisplayRegion+  -> TestApp command observation+  -> (AppDriver command observation -> IO a)+  -> IO a+withApp cfg size app k = do+  framesVar <- newTVarIO ([] :: [Frame observation]) -- oldest first+  obsBug <- newIORef (0 :: Int)+  frameCounter <- newIORef (0 :: Int)+  fenceCounter <- newIORef (0 :: Word)+  lastFenceRef <- newIORef (0 :: Word)+  obsRef <- newIORef (Nothing :: Maybe observation)+  regionRef <- newIORef size+  ctrlRef <- newIORef (Nothing :: Maybe (Ctrl command -> IO () -> IO ()))+  hostRef <- newIORef (Nothing :: Maybe (Async ()))++  (vty, st) <-+    recordingVty+      defaultRecordingVtyConfig+        { recordingInitialBounds = size+        , recordingOnPicture = \pic -> do+            n <- atomicModifyIORef' frameCounter (\i -> (i + 1, i + 1))+            fence <- readIORef lastFenceRef+            vp <- readIORef regionRef+            mobs <- readIORef obsRef+            case mobs of+              Nothing ->+                modifyIORef' obsBug (+ 1)+              Just o ->+                atomically $+                  modifyTVar' framesVar (++ [Frame n fence vp (pictureToGrid vp pic) (V.picCursor pic) pic o])+        }+  let stampFence n = writeIORef lastFenceRef n+      nextFence = atomicModifyIORef' fenceCounter (\i -> (i + 1, i + 1))+      fireCtrl msg k' = do+        mfire <- readIORef ctrlRef+        case mfire of+          Nothing -> throwIO (UnexpectedOperation "control stream not yet initialized")+          Just fire -> fire msg k'+      awaitNew deadline baseline p =+        awaitNewFrame framesVar hostRef (recordingLogHistory st) deadline baseline p++      wrapper :: forall t m. TestWidget t m => m (Event t ())+      wrapper = do+        inp <- input+        pb <- getPostBuild+        -- Track the root viewport the application actually uses+        -- (after the production resize debounce).+        vp <- askViewport+        performEvent_ $+          ffor (leftmost [tag (current vp) pb, updated vp]) $ \r ->+            liftIO $ writeIORef regionRef (_region_width r, _region_height r)+        -- External command stream.+        (ctrl, fireCtrlRef) <- newTriggerEventWithOnComplete+        liftIO $ writeIORef ctrlRef (Just fireCtrlRef)+        -- The application under test: markers filtered out of its+        -- input; commands from the control stream.+        (obsDyn, appShutdown) <-+          localInput (fmapMaybe dropMarker) $+            app (fmapMaybe ctrlCommand ctrl)+        -- Observation stamping: initial value at post-build, then+        -- every update, so each draw sees the settled value.+        performEvent_ $+          ffor (leftmost [tag (current obsDyn) pb, updated obsDyn]) $+            liftIO . writeIORef obsRef . Just+        -- Fences: control-stream fences and input markers.+        performEvent_ $ ffor (fmapMaybe ctrlFence ctrl) (liftIO . stampFence)+        performEvent_ $ ffor (fmapMaybe markerFenceOf inp) (liftIO . stampFence)+        let stop = () <$ ffilter isCtrlStop ctrl+        return $ leftmost [appShutdown, stop]++  hostA <- async (mainWidgetWithHandle cfg vty wrapper)+  writeIORef hostRef (Just hostA)++  let awaitFrameFenced n = do+        fs0 <- readTVarIO framesVar+        awaitNew defaultDeadline (length fs0) ((== n) . frameFence)+      stepInputImpl ev = do+        n <- nextFence+        recordingInput st ev+        recordingInput st (markerEvent n)+        awaitFrameFenced n+      stepCommandImpl c = do+        n <- nextFence+        fireCtrl (CtrlCommand c) (pure ())+        fireCtrl (CtrlFence n) (pure ())+        awaitFrameFenced n+      resizeImpl dims = do+        recordingSetBounds st dims+        n <- nextFence+        recordingInput st (uncurry V.EvResize dims)+        recordingInput st (markerEvent n)+        _ <- awaitFrameFenced n+        fs0 <- readTVarIO framesVar+        awaitNew slowDeadline (length fs0) ((== dims) . frameViewport)+      stopImpl = do+        mfire <- readIORef ctrlRef+        forM_ mfire $ \fire ->+          fire CtrlStop (pure ()) `catch` \(_ :: SomeException) -> pure ()+        joinHost+      joinHost = do+        mh <- readIORef hostRef+        forM_ mh $ \h -> do+          pr <- poll h+          case pr of+            Just _ -> pure ()+            Nothing -> do+              r <- timeout defaultDeadline (waitCatch h)+              case r of+                Nothing -> cancel h >> void (waitCatch h)+                Just _ -> pure ()++      driver =+        AppDriver+          { stepInput = stepInputImpl+          , stepCommand = stepCommandImpl+          , resizeApp = resizeImpl+          , awaitFrameWhere = \p -> do+              fs0 <- readTVarIO framesVar+              awaitNew defaultDeadline (length fs0) p+          , driverAwaitFor = \deadline p -> do+              fs0 <- readTVarIO framesVar+              awaitNew deadline (length fs0) p+          , stopApp = stopImpl+          , driverFrames = readTVarIO framesVar+          , driverOutputLog = recordingLogHistory st+          , driverReleaseRedrawGate = recordingReleaseGate st+          , driverHostResult = do+              mh <- readIORef hostRef+              case mh of+                Nothing -> pure Nothing+                Just h -> poll h+          }++  -- The initial frame must exist before interaction begins (or the+  -- host must fail loudly rather than hang).+  _ <- awaitNew defaultDeadline 0 (const True)++  result <- try (k driver)+  stopImpl+  case result of+    Left e -> throwIO (e :: SomeException)+    Right a -> pure a
+ test/Reflex/Vty/Test/Generators.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Bounded QuickCheck generators and the fixed-seed property runner+--+-- Every property in the suite runs through 'runPlanProperty'. It runs+-- 300 cases with maximum size 50. It uses a fixed replay seed, so+-- failures are reproducible. Generated domains are bounded and valid.+-- Specs contain explicit boundary cases, not these generators.+module Reflex.Vty.Test.Generators+  ( runPlanProperty+  , planSeed+  , genDim+  , genPositiveDim+  , genAsciiChar+  , genAsciiText+  , genMixedWidthText+  , genLineText+  , genFiniteDouble+  , genEditScript+  , EditOp (..)+  ) where++import Control.Monad (forM)+import Data.Char (chr)+import Data.Text (Text)+import qualified Data.Text as T+import Test.Hspec (Expectation, expectationFailure)+import Test.QuickCheck+import Test.QuickCheck.Random (mkQCGen)++-- | The fixed replay seed for the suite's properties.+planSeed :: Int+planSeed = 731947++-- | Run a property with the suite configuration: 300 cases, maximum+-- size 50, replay seed 'planSeed'. Failures report the seed and the+-- shrunk counterexample.+runPlanProperty :: Testable prop => prop -> Expectation+runPlanProperty prop = do+  r <-+    quickCheckWithResult+      stdArgs+        { maxSuccess = 300+        , maxSize = 50+        , replay = Just (mkQCGen planSeed, 0)+        , chatty = False+        }+      prop+  case r of+    Success {} -> pure ()+    _ -> expectationFailure ("[fixed replay seed " ++ show planSeed ++ "]\n" ++ output r)++-- | A nonnegative dimension up to 40.+genDim :: Gen Int+genDim = choose (0, 40)++-- | A positive dimension up to 40.+genPositiveDim :: Gen Int+genPositiveDim = choose (1, 40)++-- | A printable ASCII character (no control characters, no tabs).+genAsciiChar :: Gen Char+genAsciiChar = chr <$> choose (32, 126)++-- | ASCII text of bounded length (at most 200).+genAsciiText :: Gen Text+genAsciiText = T.pack <$> scale (min 200) (listOf genAsciiChar)++-- | One line of mixed-width content: ASCII, wide CJK, zero-width+-- combining marks, and spaces. There are no newlines. Line-oriented+-- APIs receive explicit newlines from 'genEditScript' inserts instead.+genLineText :: Gen Text+genLineText =+  fmap T.concat $+    scale (min 100) $+      listOf $+        frequency+          [ (6, T.singleton <$> genAsciiChar)+          , (2, pure "\30028")+          , (2, pure "\28450")+          , (1, pure "\769")+          , (1, pure " ")+          ]++-- | Multi-line mixed-width text (bounded).+genMixedWidthText :: Gen Text+genMixedWidthText = do+  ls <- scale (min 20) (listOf genLineText)+  pure (T.intercalate "\n" ls)++-- | A finite (non-NaN, non-infinite) double in [0, 2].+genFiniteDouble :: Gen Double+genFiniteDouble =+  suchThat+    (choose (0, 2))+    (\d -> not (isNaN d) && not (isInfinite d))++-- | Editing operations for zipper scripts.+data EditOp+  = OpLeft+  | OpRight+  | OpUp+  | OpDown+  | OpHome+  | OpEnd+  | OpPageUp !Int+  | OpPageDown !Int+  | OpInsertChar !Char+  | OpInsertNewline+  | OpInsertText !Text+  | OpDeleteLeft+  | OpDeleteRight+  | OpDeleteLeftWord+  | OpTab !Int+  | OpTop+  deriving (Eq, Show)++genEditOp :: Gen EditOp+genEditOp =+  frequency+    [ (3, pure OpLeft)+    , (3, pure OpRight)+    , (2, pure OpUp)+    , (2, pure OpDown)+    , (2, pure OpHome)+    , (2, pure OpEnd)+    , (1, OpPageUp <$> choose (-1, 3))+    , (1, OpPageDown <$> choose (-1, 3))+    , (6, OpInsertChar <$> genAsciiChar)+    , (2, pure OpInsertNewline)+    , (2, OpInsertText <$> scale (min 20) genLineText)+    , (3, pure OpDeleteLeft)+    , (3, pure OpDeleteRight)+    , (2, pure OpDeleteLeftWord)+    , (1, OpTab <$> choose (0, 8))+    , (1, pure OpTop)+    ]++-- | An edit script of at most 100 operations.+genEditScript :: Gen [EditOp]+genEditScript = scale (min 100) (listOf genEditOp)
+ test/Reflex/Vty/Test/GoldenPolicySpec.hs view
@@ -0,0 +1,93 @@+module Reflex.Vty.Test.GoldenPolicySpec (spec) where++import Control.Exception (SomeException, try)+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import System.Directory+  ( doesDirectoryExist+  , doesFileExist+  , getPermissions+  , setPermissions+  , writable+  )+import System.FilePath ((<.>), (</>))+import System.IO (IOMode (ReadWriteMode), withBinaryFile)+import System.IO.Extra (withTempDir)+import Test.Hspec++import Reflex.Vty.Test.Snapshot++spec :: Spec+spec = describe "Golden policy" $ do+  describe "CheckGoldens" $ do+    it "fails on a missing file and creates nothing" $+      withTempDir $ \dir -> do+        let goldenDir = dir </> "goldens"+            name = "missing_fixture"+        result <-+          try (assertGolden CheckGoldens goldenDir name "actual") :: IO (Either SomeException ())+        case result of+          Left _ -> pure ()+          Right () -> expectationFailure "expected a failure for a missing golden file"+        doesFileExist (goldenDir </> name <.> "txt") `shouldReturn` False+        doesDirectoryExist goldenDir `shouldReturn` False++    it "passes when the file matches exactly" $+      withTempDir $ \dir -> do+        let name = "matching"+            path = dir </> name <.> "txt"+        BS.writeFile path (TE.encodeUtf8 (T.pack "expected\n"))+        assertGolden CheckGoldens dir name "expected\n"++    it "fails on a mismatch, leaving the file unchanged" $+      withTempDir $ \dir -> do+        let name = "mismatched"+            path = dir </> name <.> "txt"+        BS.writeFile path (TE.encodeUtf8 (T.pack "expected\n"))+        result <-+          try (assertGolden CheckGoldens dir name "actual\n") :: IO (Either SomeException ())+        case result of+          Left _ -> pure ()+          Right () -> expectationFailure "expected a failure for a mismatched golden file"+        BS.readFile path `shouldReturn` TE.encodeUtf8 (T.pack "expected\n")++    it "fails when a golden file is locked for writing" $+      withTempDir $ \dir -> do+        let name = "locked"+            path = dir </> name <.> "txt"+        BS.writeFile path (TE.encodeUtf8 (T.pack "expected\n"))+        result <- withBinaryFile path ReadWriteMode $ \_ ->+          try (assertGolden CheckGoldens dir name "expected\n") :: IO (Either SomeException ())+        case result of+          Left _ -> pure ()+          Right () -> expectationFailure "expected a failure for a locked golden file"++  describe "UpdateGoldens" $ do+    it "creates a missing file with the exact UTF-8 bytes, including the directory" $+      withTempDir $ \dir -> do+        let goldenDir = dir </> "goldens"+            name = "created"+        assertGolden UpdateGoldens goldenDir name "a\30028b\n"+        BS.readFile (goldenDir </> name <.> "txt")+          `shouldReturn` TE.encodeUtf8 (T.pack "a\30028b\n")++    it "overwrites a changed file" $+      withTempDir $ \dir -> do+        let name = "stale"+            path = dir </> name <.> "txt"+        BS.writeFile path (TE.encodeUtf8 (T.pack "old\n"))+        assertGolden UpdateGoldens dir name "new\n"+        BS.readFile path `shouldReturn` TE.encodeUtf8 (T.pack "new\n")++    it "leaves an equal file untouched" $+      withTempDir $ \dir -> do+        let name = "equal"+            path = dir </> name <.> "txt"+        BS.writeFile path (TE.encodeUtf8 (T.pack "same\n"))+        perms <- getPermissions path+        setPermissions path perms {writable = False}+        assertGolden UpdateGoldens dir name "same\n"+        -- The file was not rewritten. An attempted write would have+        -- failed against the write-protected file.+        BS.readFile path `shouldReturn` TE.encodeUtf8 (T.pack "same\n")
+ test/Reflex/Vty/Test/GoldenSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.Test.GoldenSpec (spec) where++import System.FilePath ((</>))+import Test.Hspec++import Reflex.Vty.Style+import Reflex.Vty.Test.Snapshot++goldenDir :: FilePath+goldenDir = "test" </> "goldens"++spec :: GoldenMode -> Spec+spec = describe "Golden snapshots" . withMode+  where+    withMode mode = do+      -- Borders+      golden mode "border_single" $ render (withBorder singleBorder def) "Box"+      golden mode "border_rounded" $ render (withBorder roundedBorder def) "Box"+      golden mode "border_thick" $ render (withBorder thickBorder def) "Box"+      golden mode "border_double" $ render (withBorder doubleBorder def) "Box"+      golden mode "border_ascii" $ render (withBorder asciiBorder def) "Box"++      -- Padding & Margin+      golden mode "padding_1" $ render (withPadding 1 1 1 1 def) "pad"+      golden mode "padding_2" $ render (withPadding 2 2 2 2 def) "pad"+      golden mode "margin_1" $ render (withMargin 1 1 1 1 def) "m"++      -- Colors+      golden mode "color_red_fg" $ render (withForeground red def) "Red"+      golden mode "color_blue_bg" $ render (withBackground blue def) "Blue"+      golden mode "color_rgb" $ render (withForeground (rgbColor 200 100 50) def) "RGB"++      -- Transforms+      golden mode "transform_bold" $ render (withBold def) "Bold"+      golden mode "transform_italic" $ render (withItalic def) "Italic"+      golden mode "transform_underline" $ render (withUnderline UnderlineSingle def) "UL"+      golden mode "transform_reverse" $ render (withReverse def) "Rev"++      -- Alignment+      golden mode "align_left" $ render (withAlignH HAlignLeft . withWidth 20 $ def) "Left"+      golden mode "align_center" $ render (withAlignH HAlignCenter . withWidth 20 $ def) "Center"+      golden mode "align_right" $ render (withAlignH HAlignRight . withWidth 20 $ def) "Right"++      -- Combined+      golden mode "combined" $+        render+          ( withBorder roundedBorder+              . withPadding 1 2 1 2+              . withForeground brightGreen+              . withBorderForeground brightMagenta+              $ def+          )+          "Combined"++      -- Multi-line+      golden mode "multiline" $ render def "Hello\nWorld"++      -- Wide chars+      golden mode "wide_chars" $ render def "a文b"++      -- Plain text (baseline)+      golden mode "plain" $ render def "hello"+    golden mode name img =+      it name $+        assertGolden mode goldenDir name $+          renderGrid $+            imageToGrid img
+ test/Reflex/Vty/Test/Snapshot.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+--+-- Renders a 'V.Picture' (or 'V.Image') through Vty's own renderer+-- ("Graphics.Vty.PictureToSpans" 'displayOpsForPic') and decodes the+-- resulting spans into a test-friendly 'Grid'. The renderer produces+-- the spans, so continuation columns and zero-width marks need no+-- reconstruction. A span keeps its complete text and its reported+-- column width.+--+-- Each row is a list of 'RenderSpan's covering the full row width.+-- Trailing blank columns ('RowEnd') become default-attribute blank+-- spans. Effective (fully resolved) attributes are computed per row,+-- starting from terminal defaults, exactly as Vty's output stage does.+--+-- Golden file format (produced by 'renderGrid'):+--+-- > 4x1+-- > "a\30028b"+-- > --- spans ---+-- > 0:0+4 text="a\30028b" attr=FixedAttr {fixedStyle = 0, ...}+--+-- The first line is @WxH@. Then comes one Haskell-escaped row string+-- per row (@show@ of the row's 'String'). Then comes @--- spans ---@+-- and one line per canonical span:+-- @row:column+width text=<quoted> attr=<show FixedAttr>@.+-- Default attributes are included, as well as explicit colors,+-- styles, and URLs.+module Reflex.Vty.Test.Snapshot+  ( RenderSpan (..)+  , Grid (..)+  , pictureToGrid+  , imageToGrid+  , imageText+  , renderGrid+  , gridEquals+  , attrAt+  , GoldenMode (..)+  , assertGolden+  , goldenUpdateCommand+  ) where++import Control.Exception (IOException, try)+import qualified Data.ByteString as BS+import Data.List (foldl')+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as Vec+import qualified Graphics.Vty as V+import Graphics.Vty.DisplayAttributes (fixDisplayAttr)+import qualified Graphics.Vty.PictureToSpans as PTS+import Graphics.Vty.Span (SpanOp (RowEnd, Skip, TextSpan))+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.FilePath ((<.>), (</>))+import Test.Hspec (Expectation, expectationFailure, shouldBe)++-- | A rendered span: its total column width on screen, its complete+-- text (including any zero-width marks), and its fully resolved+-- attribute.+data RenderSpan = RenderSpan+  { renderSpanColumns :: !Int+  , renderSpanText :: !T.Text+  , renderSpanAttr :: !V.FixedAttr+  }+  deriving (Eq, Show)++-- | A rendered grid: requested dimensions plus one row of spans per+-- display row. Every row's spans cover exactly 'gridWidth' columns.+data Grid = Grid+  { gridWidth :: !Int+  , gridHeight :: !Int+  , gridRows :: ![[RenderSpan]]+  }+  deriving (Eq, Show)++-- | Terminal default attributes; the starting point of attribute+-- resolution on each row.+defaultFixedAttr :: V.FixedAttr+defaultFixedAttr = V.FixedAttr V.defaultStyleMask Nothing Nothing Nothing++-- | Render a picture into a 'Grid' of the requested size, using Vty's+-- own renderer. Requested negative dimensions are clamped to zero. A+-- zero-area region yields a grid with those (nonnegative) dimensions+-- and no rows. A picture with no layers is normalized to a single+-- 'V.emptyImage' layer. Vty rejects a nonzero-sized picture with no+-- layers.+pictureToGrid :: V.DisplayRegion -> V.Picture -> Grid+pictureToGrid (reqW, reqH) pic0+  | w == 0 || h == 0 = Grid w h []+  | otherwise = Grid w h padded+  where+    w = max 0 reqW+    h = max 0 reqH+    pic = case pic0 of+      V.Picture {V.picLayers = []} -> pic0 {V.picLayers = [V.emptyImage]}+      _ -> pic0+    rows = map (decodeRow w . Vec.toList) (Vec.toList (PTS.displayOpsForPic pic (w, h)))+    padded = rows ++ replicate (h - length rows) [blankSpan w]++-- | Decode one row of span operations into canonical 'RenderSpan's,+-- resolving attributes from terminal defaults and converting trailing+-- blank columns to default-attribute blanks. The final picture stage+-- must not produce 'Skip' operations. A 'Skip' is an oracle error,+-- not a rendering result.+decodeRow :: Int -> [SpanOp] -> [RenderSpan]+decodeRow width ops =+  padTo width . coalesceSpans . snd $ foldl' step (defaultFixedAttr, []) ops+  where+    step (cur, acc) op = case op of+      TextSpan attr w _ tl ->+        let eff = fixDisplayAttr cur attr+        in (eff, acc ++ [RenderSpan w (TL.toStrict tl) eff])+      RowEnd n -> (defaultFixedAttr, acc ++ [blankSpan n])+      Skip n ->+        error $+          "oracle error: unexpected Skip ("+            ++ show n+            ++ " columns) in final picture spans"++-- | A blank span of @n@ default-attribute columns.+blankSpan :: Int -> RenderSpan+blankSpan n = RenderSpan n (T.replicate n (T.singleton ' ')) defaultFixedAttr++-- | Merge adjacent spans with equal effective attributes without+-- changing their text or widths.+coalesceSpans :: [RenderSpan] -> [RenderSpan]+coalesceSpans = foldl' step []+  where+    step [] s = [s]+    step acc s+      | renderSpanAttr s == renderSpanAttr (last acc) =+          init acc+            ++ [ RenderSpan+                   (renderSpanColumns (last acc) + renderSpanColumns s)+                   (renderSpanText (last acc) <> renderSpanText s)+                   (renderSpanAttr s)+               ]+      | otherwise = acc ++ [s]++-- | Ensure a row's spans cover the full width by appending+-- default-attribute blanks if the renderer left the row short.+padTo :: Int -> [RenderSpan] -> [RenderSpan]+padTo width ss =+  let covered = sum (map renderSpanColumns ss)+  in if covered < width then ss ++ [blankSpan (width - covered)] else ss++-- | Render an image to a grid using the image's own dimensions.+imageToGrid :: V.Image -> Grid+imageToGrid img =+  pictureToGrid (V.imageWidth img, V.imageHeight img) (V.picForImage img)++-- | Extract the visible text of an image, one string per row. The+-- text includes actual trailing blank columns. It never invents a+-- space for a wide-glyph continuation column.+imageText :: V.Image -> [String]+imageText img =+  map (T.unpack . T.concat . map renderSpanText) (gridRows (imageToGrid img))++-- | Look up the effective attribute at a cell coordinate. A wide+-- glyph's continuation column reports the same attribute as its start+-- column. Both columns are covered by the same span. Out-of-bounds+-- coordinates return 'Nothing'.+attrAt :: Int -> Int -> Grid -> Maybe V.FixedAttr+attrAt x y (Grid w h rows)+  | x < 0 || y < 0 || x >= w || y >= h = Nothing+  | otherwise = case drop y rows of+      [] -> Nothing+      (r : _) -> go 0 r+  where+    go _ [] = Nothing+    go col (s : ss)+      | x < col + renderSpanColumns s = Just (renderSpanAttr s)+      | otherwise = go (col + renderSpanColumns s) ss++-- | Check whether two grids are equal. Returns 'Nothing' when they+-- match, or a description of the first difference in dimensions, text,+-- widths, or effective attributes (including URLs).+gridEquals :: Grid -> Grid -> Maybe String+gridEquals a b+  | gridWidth a /= gridWidth b =+      Just $ "width: " ++ show (gridWidth a) ++ " vs " ++ show (gridWidth b)+  | gridHeight a /= gridHeight b =+      Just $ "height: " ++ show (gridHeight a) ++ " vs " ++ show (gridHeight b)+  | otherwise = firstDiff 0 (gridRows a) (gridRows b)+  where+    firstDiff _ [] [] = Nothing+    firstDiff y (ra : ras) (rb : rbs) = case compareRows y ra rb of+      Just d -> Just d+      Nothing -> firstDiff (y + 1) ras rbs+    firstDiff y [] _ = Just ("row " ++ show y ++ ": missing")+    firstDiff y _ [] = Just ("row " ++ show y ++ ": extra")+    compareRows y ra rb+      | rowText ra /= rowText rb =+          Just $+            "row "+              ++ show y+              ++ " text: "+              ++ show (rowText ra)+              ++ " vs "+              ++ show (rowText rb)+      | ra /= rb =+          Just $+            "row "+              ++ show y+              ++ " spans: "+              ++ show ra+              ++ " vs "+              ++ show rb+      | otherwise = Nothing+    rowText = T.unpack . T.concat . map renderSpanText++-- | Pretty-print a grid for golden-file comparison and debugging.+-- See the module documentation for the exact format.+renderGrid :: Grid -> String+renderGrid grid =+  unlines (header : rowStrings)+    ++ unlines ("--- spans ---" : spanLines)+  where+    header = show (gridWidth grid) ++ "x" ++ show (gridHeight grid)+    rowStrings =+      [ show (T.unpack (T.concat (map renderSpanText row)))+      | row <- gridRows grid+      ]+    spanLines =+      [ show y+          ++ ":"+          ++ show col+          ++ "+"+          ++ show (renderSpanColumns s)+          ++ " text="+          ++ show (T.unpack (renderSpanText s))+          ++ " attr="+          ++ show (renderSpanAttr s)+      | (y, row) <- zip [0 :: Int ..] (gridRows grid)+      , (col, s) <- zip (scanl (+) 0 (map renderSpanColumns row)) row+      ]++----------------------------------------------------------------------------+-- Golden file comparison+----------------------------------------------------------------------------++-- | Whether golden fixtures are being checked (the default, and the+-- only mode allowed in CI) or explicitly updated.+data GoldenMode = CheckGoldens | UpdateGoldens+  deriving (Eq, Show)++-- | The exact command that creates or updates golden fixtures.+goldenUpdateCommand :: String+goldenUpdateCommand =+  "REFLEX_VTY_GOLDEN_UPDATE=1 cabal test reflex-vty-test"+    ++ " --test-show-details=direct --test-option=--match=Golden"++-- | Compare the serialized actual output against the golden fixture+-- @\<dir>\</\<name>.txt@. In 'UpdateGoldens' mode, write the output+-- instead of comparing.+--+-- In 'CheckGoldens' mode, create nothing. A missing file fails with+-- the path and 'goldenUpdateCommand'. A mismatch fails through Hspec+-- equality, so the expected and actual contents are visible. IO,+-- permission, and encoding errors fail with the path in the message.+--+-- In 'UpdateGoldens' mode, create the directory. Write changed or+-- missing files in UTF-8. Leave equal files untouched.+assertGolden :: GoldenMode -> FilePath -> String -> String -> Expectation+assertGolden mode dir name actual = do+  let path = dir </> name <.> "txt"+  case mode of+    CheckGoldens -> do+      exists <- doesFileExist path+      if not exists+        then+          expectationFailure $+            "missing golden file "+              ++ path+              ++ "; to create or update it, run: "+              ++ goldenUpdateCommand+        else do+          er <- readGolden path+          case er of+            Left err -> expectationFailure err+            Right expected -> expected `shouldBe` actual+    UpdateGoldens -> do+      createDirectoryIfMissing True dir+      exists <- doesFileExist path+      if not exists+        then do+          merr <- writeGolden path actual+          maybe (pure ()) expectationFailure merr+        else do+          er <- readGolden path+          case er of+            Left err -> expectationFailure err+            Right expected+              | expected /= actual -> do+                  merr <- writeGolden path actual+                  maybe (pure ()) expectationFailure merr+              | otherwise -> pure ()++readGolden :: FilePath -> IO (Either String String)+readGolden path = do+  r <- try (TE.decodeUtf8With TEE.lenientDecode <$> BS.readFile path)+  pure $ case r of+    Left (e :: IOException) ->+      Left ("could not read golden file " ++ path ++ ": " ++ show e)+    Right txt -> Right (T.unpack txt)++writeGolden :: FilePath -> String -> IO (Maybe String)+writeGolden path contents = do+  r <- try (BS.writeFile path (TE.encodeUtf8 (T.pack contents)))+  pure $ case r of+    Left (e :: IOException) ->+      Just ("could not write golden file " ++ path ++ ": " ++ show e)+    Right () -> Nothing
+ test/Reflex/Vty/Test/SnapshotSpec.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.Test.SnapshotSpec (spec) where++import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Test.Hspec++import Reflex.Vty.Test.Snapshot++red, blue :: V.Attr+red = V.withForeColor V.defAttr (V.ISOColor 1)+blue = V.withForeColor V.defAttr (V.ISOColor 4)++redFixed, blueFixed :: V.FixedAttr+redFixed = V.FixedAttr V.defaultStyleMask (Just (V.ISOColor 1)) Nothing Nothing+blueFixed = V.FixedAttr V.defaultStyleMask (Just (V.ISOColor 4)) Nothing Nothing++defaultFixed :: V.FixedAttr+defaultFixed = V.FixedAttr V.defaultStyleMask Nothing Nothing Nothing++spec :: Spec+spec = describe "Reflex.Vty.Test.Snapshot" $ do+  describe "imageToGrid" $ do+    it "empty image has zero dimensions and no rows" $ do+      let g = imageToGrid V.emptyImage+      g `shouldBe` Grid 0 0 []+      imageText V.emptyImage `shouldBe` []++    it "renders plain single-row text" $ do+      let g = imageToGrid (V.string V.defAttr "hello")+      gridWidth g `shouldBe` 5+      gridHeight g `shouldBe` 1+      imageText (V.string V.defAttr "hello") `shouldBe` ["hello"]++    it "wide text occupies its full column width but no continuation space" $ do+      let img = V.string V.defAttr "a\30028b"+      V.imageWidth img `shouldBe` 4+      let g = imageToGrid img+      gridWidth g `shouldBe` 4+      imageText img `shouldBe` ["a\30028b"]+      case gridRows g of+        [[s]] -> do+          renderSpanColumns s `shouldBe` 4+          renderSpanText s `shouldBe` T.pack "a\30028b"+        _ -> expectationFailure "expected exactly one row with one span"++    it "preserves a zero-width combining mark after its base" $ do+      let img = V.string V.defAttr "e\769"+      imageText img `shouldBe` ["e\769"]+      case gridRows (imageToGrid img) of+        [[s]] -> renderSpanColumns s `shouldBe` 1+        _ -> expectationFailure "expected exactly one row with one span"++    it "keeps a trailing combining mark inside its own span at a span boundary" $ do+      let img = V.horizCat [V.text' red "e\769", V.text' blue "x"]+      imageText img `shouldBe` ["e\769x"]+      case gridRows (imageToGrid img) of+        [[s0, s1]] -> do+          renderSpanText s0 `shouldBe` T.pack "e\769"+          renderSpanAttr s0 `shouldBe` redFixed+          renderSpanText s1 `shouldBe` "x"+          renderSpanAttr s1 `shouldBe` blueFixed+        _ -> expectationFailure "expected exactly one row with two spans"++    it "keeps differently styled adjacent spans apart" $ do+      let img = V.horizCat [V.string red "ab", V.string blue "cd"]+      case gridRows (imageToGrid img) of+        [[s0, s1]] -> do+          renderSpanAttr s0 `shouldBe` redFixed+          renderSpanAttr s1 `shouldBe` blueFixed+        _ -> expectationFailure "expected exactly one row with two spans"++    it "resolves URL attributes" $ do+      let img = V.string (V.withURL V.defAttr "http://x") "u"+          g = imageToGrid img+      case gridRows g of+        [(s : _)] -> do+          V.fixedURL (renderSpanAttr s) `shouldBe` Just "http://x"+          V.fixedForeColor (renderSpanAttr s) `shouldBe` Nothing+        _ -> expectationFailure "expected one span"++    it "includes actual trailing blank columns in imageText" $ do+      let img = V.horizCat [V.string V.defAttr "ab", V.backgroundFill 2 1]+      V.imageWidth img `shouldBe` 4+      imageText img `shouldBe` ["ab  "]++    it "coalesces adjacent spans with equal effective attributes" $ do+      let img = V.horizCat [V.text' red "ab", V.text' red "cd"]+      imageText img `shouldBe` ["abcd"]+      case gridRows (imageToGrid img) of+        [[s]] -> do+          renderSpanColumns s `shouldBe` 4+          renderSpanText s `shouldBe` "abcd"+        _ -> expectationFailure "expected exactly one row with one span"++  describe "wide-glyph clipping follows Vty's ellipsis policy" $ do+    it "keeping the left half of a wide glyph renders an ellipsis" $ do+      let img = V.cropRight 2 (V.string V.defAttr "a\30028")+      imageText img `shouldBe` ["a\8230"]+      gridWidth (imageToGrid img) `shouldBe` 2++    it "keeping the right half of a wide glyph renders an ellipsis" $ do+      let img = V.cropLeft 1 (V.string V.defAttr "a\30028")+      imageText img `shouldBe` ["\8230"]+      gridWidth (imageToGrid img) `shouldBe` 1++  describe "joins" $ do+    it "vertical join stacks rows" $ do+      let img = V.vertCat [V.string V.defAttr "ab", V.string red "xy"]+      imageText img `shouldBe` ["ab", "xy"]+      case gridRows (imageToGrid img) of+        [[s0], [s1]] -> do+          renderSpanAttr s0 `shouldBe` defaultFixed+          renderSpanAttr s1 `shouldBe` redFixed+        _ -> expectationFailure "expected two rows with one span each"++    it "horizontal join concatenates spans" $ do+      let img = V.horizCat [V.string red "ab", V.string blue "cd"]+      imageText img `shouldBe` ["abcd"]+      attrAt 0 0 (imageToGrid img) `shouldBe` Just redFixed+      attrAt 2 0 (imageToGrid img) `shouldBe` Just blueFixed++  describe "pictureToGrid" $ do+    it "translates blank backgrounds and content correctly" $ do+      let pic = V.picForImage (V.translate 2 1 (V.string red "x"))+          g = pictureToGrid (5, 3) pic+      gridWidth g `shouldBe` 5+      gridHeight g `shouldBe` 3+      map (concatMap (T.unpack . renderSpanText)) (gridRows g)+        `shouldBe` ["     ", "  x  ", "     "]+      attrAt 2 1 g `shouldBe` Just redFixed+      attrAt 0 1 g `shouldBe` Just defaultFixed++    it "overlapping layers: the first layer is topmost" $ do+      let pic = V.picForLayers [V.translate 2 0 (V.string red "AB"), V.string blue "CD"]+          g = pictureToGrid (4, 1) pic+      concatMap (T.unpack . renderSpanText) (concat (gridRows g)) `shouldBe` "CDAB"+      attrAt 0 0 g `shouldBe` Just blueFixed+      attrAt 2 0 g `shouldBe` Just redFixed++    it "pads short pictures with blank rows up to the requested height" $ do+      let g = pictureToGrid (4, 3) (V.picForImage (V.string V.defAttr "ab"))+      gridHeight g `shouldBe` 3+      [sum (map renderSpanColumns r) | r <- gridRows g] `shouldBe` [4, 4, 4]+      concatMap (T.unpack . renderSpanText) (concat (gridRows g)) `shouldBe` "ab          "++    it "normalizes an empty layer list instead of failing" $ do+      let pic = V.Picture {V.picLayers = [], V.picBackground = V.ClearBackground, V.picCursor = V.NoCursor}+          g = pictureToGrid (4, 2) pic+      gridWidth g `shouldBe` 4+      gridHeight g `shouldBe` 2+      [sum (map renderSpanColumns r) | r <- gridRows g] `shouldBe` [4, 4]++    it "clamps negative requested dimensions to zero" $ do+      let pic = V.picForImage (V.string V.defAttr "ab")+      pictureToGrid (-3, -2) pic `shouldBe` Grid 0 0 []++    it "zero-area region yields the requested dimensions and no rows" $ do+      let pic = V.picForImage (V.string V.defAttr "ab")+      pictureToGrid (0, 5) pic `shouldBe` Grid 0 5 []++  describe "attrAt" $ do+    it "reports the same attribute for both columns of a wide glyph" $ do+      let g = imageToGrid (V.horizCat [V.string red "a\30028", V.string blue "b"])+      attrAt 0 0 g `shouldBe` Just redFixed+      attrAt 1 0 g `shouldBe` Just redFixed+      attrAt 2 0 g `shouldBe` Just redFixed+      attrAt 3 0 g `shouldBe` Just blueFixed++    it "returns Nothing out of bounds" $ do+      let g = imageToGrid (V.string red "ab")+      attrAt 2 0 g `shouldBe` Nothing+      attrAt 0 1 g `shouldBe` Nothing+      attrAt (-1) 0 g `shouldBe` Nothing+      attrAt 0 (-1) g `shouldBe` Nothing++  describe "gridEquals" $ do+    it "returns Nothing for identical grids" $ do+      let g = imageToGrid (V.string red "hi")+      gridEquals g g `shouldBe` Nothing++    it "detects differing text" $ do+      gridEquals+        (imageToGrid (V.string V.defAttr "hi"))+        (imageToGrid (V.string V.defAttr "ho"))+        `shouldSatisfy` isJust++    it "detects differing widths" $ do+      gridEquals+        (imageToGrid (V.string V.defAttr "hi"))+        (imageToGrid (V.horizCat [V.string V.defAttr "hi", V.backgroundFill 1 1]))+        `shouldSatisfy` isJust++    it "detects differing color" $ do+      gridEquals+        (imageToGrid (V.string red "hi"))+        (imageToGrid (V.string blue "hi"))+        `shouldSatisfy` isJust++    it "detects differing URL" $ do+      gridEquals+        (imageToGrid (V.string (V.withURL V.defAttr "http://a") "hi"))+        (imageToGrid (V.string (V.withURL V.defAttr "http://b") "hi"))+        `shouldSatisfy` isJust++  describe "renderGrid" $ do+    it "serializes dimensions, escaped rows, and canonical spans" $ do+      let txt = renderGrid (imageToGrid (V.string red "a\30028b"))+      lines txt+        `shouldBe` [ "4x1"+                   , show "a\30028b"+                   , "--- spans ---"+                   , "0:0+4 text=" ++ show "a\30028b" ++ " attr=" ++ show redFixed+                   ]++    it "serializes default attributes too" $ do+      let txt = renderGrid (imageToGrid (V.string V.defAttr "x"))+      lines txt+        `shouldBe` [ "1x1"+                   , show "x"+                   , "--- spans ---"+                   , "0:0+1 text=" ++ show "x" ++ " attr=" ++ show defaultFixed+                   ]
+ test/Reflex/Vty/ThemeSpec.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Vty.ThemeSpec (spec) where++import Data.List (isInfixOf)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Reflex.Vty.Host+import Reflex.Vty.Style (Style, applyAttr, def, withForeground)+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), attrAt)+import Reflex.Vty.Theme+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Box (boxStatic, singleBoxStyle)+import Reflex.Vty.Widget.Input.Text (TextInput (..), textInput)+import Reflex.Vty.Widget.Split (splitH)+import Reflex.Vty.Widget.Text (fill)++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Text content of one row of a rendered grid.+rowText :: Grid -> Int -> String+rowText g y = T.unpack . T.concat . map renderSpanText $ gridRows g !! y++-- | The terminal default attribute (the starting point of resolution).+defaultAttr :: V.FixedAttr+defaultAttr = V.FixedAttr V.defaultStyleMask Nothing Nothing Nothing++-- | Effective foreground color at a cell, if any.+foreAt :: Int -> Int -> Grid -> Maybe (Maybe V.Color)+foreAt x y g = V.fixedForeColor <$> attrAt x y g++themeWithForeground :: V.Color -> Theme+themeWithForeground c = defTheme {_theme_default = withForeground c def}++-- | Magenta on one side, green on the other; the command switches the+-- first theme to blue.+magenta, blue, green :: V.Color+magenta = V.rgbColor 255 0 255+blue = V.rgbColor 0 0 255+green = V.rgbColor 0 255 0++----------------------------------------------------------------------------+-- Applications under test+----------------------------------------------------------------------------++-- | Two boxed text inputs under different local themes. Only the first+-- input is focused, so only it consumes key events. The command changes+-- the first pane's theme from magenta to blue; the second pane's theme+-- never changes.+twoThemeApp :: TestApp Bool (T.Text, T.Text)+twoThemeApp cmd = do+  theme1 <- holdDyn (themeWithForeground magenta) (themeWithForeground blue <$ cmd)+  (ti1, ti2) <-+    splitH+      (pure (`div` 2))+      (pure (True, False))+      (localTheme (\_ -> current theme1) (boxedInput))+      (localTheme (\_ -> pure (themeWithForeground green)) (boxedInput))+  pure ((,) <$> _textInput_value ti1 <*> _textInput_value ti2, never)+  where+    boxedInput = boxStatic singleBoxStyle (textInput def)++-- | One preset-themed widget: a filled box under the Dracula theme.+presetApp :: Theme -> TestApp () ()+presetApp th _cmd = do+  _ <- localTheme (\_ -> pure th) (boxStatic singleBoxStyle (fill (pure '.')))+  pure (pure (), never)++----------------------------------------------------------------------------+-- Spec+----------------------------------------------------------------------------++spec :: Spec+spec = describe "Reflex.Vty.Theme" $ do+  describe "Theme record and themeAttr" $ do+    it "defTheme's title style adds bold over any base attribute" $+      applyAttr (_theme_title defTheme) V.defAttr `shouldBe` V.withStyle V.defAttr V.bold++    it "themeAttr applies the default style to the terminal default" $ do+      -- The Behavior is pure. The initial sample gives the full result.+      let attr0 = _theme_default (themeWithForeground magenta)+      V.attrForeColor (applyAttr attr0 V.defAttr) `shouldBe` V.SetTo magenta++  describe "localTheme through the production host" $ do+    it "updates only the scoped subtree, in the frame that contains the command" $+      withApp defaultVtyAppConfig (20, 5) twoThemeApp $ \driver -> do+        -- Type into the focused left input.+        _ <- stepInput driver (V.EvKey (V.KChar 'h') [])+        fTyped <- stepInput driver (V.EvKey (V.KChar 'i') [])+        let gTyped = frameGrid fTyped+        -- Left border and text are magenta; right border is green.+        foreAt 0 0 gTyped `shouldBe` Just (Just magenta)+        foreAt 1 1 gTyped `shouldBe` Just (Just magenta)+        foreAt 10 0 gTyped `shouldBe` Just (Just green)+        rowText gTyped 1 `shouldSatisfy` isInfixOf "hi"+        frameObservation fTyped `shouldBe` ("hi", "")+        -- Switching only the first theme recolors exactly the first+        -- subtree in this very frame: no extra keypress involved.+        fSwitched <- stepCommand driver True+        let gSwitched = frameGrid fSwitched+        foreAt 0 0 gSwitched `shouldBe` Just (Just blue)+        foreAt 1 1 gSwitched `shouldBe` Just (Just blue)+        -- The sibling subtree is untouched.+        foreAt 10 0 gSwitched `shouldBe` Just (Just green)+        -- Both input values are intact.+        rowText gSwitched 1 `shouldSatisfy` isInfixOf "hi"+        frameObservation fSwitched `shouldBe` ("hi", "")+        stopApp driver++    it "isolates sibling subtrees with constant local themes" $+      withApp defaultVtyAppConfig (20, 5) twoThemeApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            let g = frameGrid f+            foreAt 0 0 g `shouldBe` Just (Just magenta)+            foreAt 10 0 g `shouldBe` Just (Just green)+            -- Both inputs start empty and stay distinct.+            frameObservation f `shouldBe` ("", "")+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++  describe "preset themes" $ do+    it "renders a dracula-themed widget with non-default attributes" $+      withApp defaultVtyAppConfig (20, 5) (presetApp draculaTheme) $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            let g = frameGrid f+            attrAt 0 0 g `shouldNotBe` Just defaultAttr+            foreAt 0 0 g `shouldNotBe` Nothing+            rowText g 0 `shouldSatisfy` isInfixOf "┌"+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++    it "renders a dark-themed widget with explicit foreground and background" $+      withApp defaultVtyAppConfig (20, 5) (presetApp darkTheme) $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            let g = frameGrid f+            -- darkTheme sets both a foreground and a background color+            -- without pinning the exact palette constants.+            attrAt 0 0 g `shouldNotBe` Just defaultAttr+            foreAt 0 0 g `shouldNotBe` Nothing+            foreAt 0 0 g `shouldNotBe` Just Nothing+            (attrAt 0 0 g >>= V.fixedBackColor) `shouldNotBe` Nothing+          [] -> expectationFailure "expected an initial frame"+        stopApp driver
+ test/Reflex/Vty/Widget/BoxSpec.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Vty.Widget.BoxSpec (spec) where++import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Data.Text.Zipper (TextAlignment (..))+import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..))+import Reflex.Vty.Widget (blank, tellImages)+import Reflex.Vty.Widget.Box+import Reflex.Vty.Widget.Input.Mouse+import Reflex.Vty.Widget.Text (text)++-- | The full text of one rendered row of a frame.+frameRow :: Frame o -> Int -> String+frameRow f y = case drop y (gridRows (frameGrid f)) of+  (r : _) -> T.unpack (T.concat (map renderSpanText r))+  [] -> ""++-- | The newest frame drawn so far (for a static app, the initial frame).+lastFrame :: AppDriver c o -> IO (Frame o)+lastFrame dr = last <$> driverFrames dr++----------------------------------------------------------------------------+-- Applications under test+----------------------------------------------------------------------------++-- | A full-screen single-style box containing the text \"hi\".+boxApp :: TestApp () ()+boxApp _cmd = do+  _ <- boxStatic singleBoxStyle (text (pure "hi"))+  pure (pure (), never)++-- | A full-screen titled box whose title alignment is driven by commands.+titleApp :: TestApp TextAlignment ()+titleApp cmd = do+  align <- holdDyn TextAlignment_Center cmd+  _ <- boxTitle (current align) (pure singleBoxStyle) (pure "Hi") blank+  pure (pure (), never)++-- | A full-screen titled box whose title is wider than the box.+clipTitleApp :: TestApp () ()+clipTitleApp _cmd = do+  _ <- boxTitle (pure TextAlignment_Left) (pure singleBoxStyle) (pure "ABCDEFGHIJKLM") blank+  pure (pure (), never)++-- | A full-screen box whose child records the region-relative coordinates+-- of left-button presses.+translateApp :: TestApp () (Int, Int)+translateApp _cmd = do+  pos <-+    box (pure singleBoxStyle) $ do+      md <- mouseDown V.BLeft+      holdDyn (-1, -1) (_mouseDown_coordinates <$> md)+  pure (pos, never)++-- | A full-screen box whose child tries to paint far beyond the box.+clipApp :: TestApp () ()+clipApp _cmd = do+  _ <-+    boxStatic singleBoxStyle $+      tellImages (pure [V.string V.defAttr (replicate 40 'X')])+  pure (pure (), never)++-- | A full-screen horizontal rule.+hRuleApp :: TestApp () ()+hRuleApp _cmd = do+  hRule singleBoxStyle+  pure (pure (), never)++----------------------------------------------------------------------------+-- Specs+----------------------------------------------------------------------------++spec :: Spec+spec = describe "Reflex.Vty.Widget.Box" $ do+  describe "alignText" $ do+    it "left-aligns by padding on the right" $ do+      alignText TextAlignment_Left "hi" '-' 5 `shouldBe` "hi---"++    it "right-aligns by padding on the left" $ do+      alignText TextAlignment_Right "hi" '-' 5 `shouldBe` "---hi"++    it "center-aligns with left bias for odd slack" $ do+      alignText TextAlignment_Center "hi" '-' 5 `shouldBe` "--hi-"++    it "center-aligns evenly for even slack" $ do+      alignText TextAlignment_Center "hi" '-' 6 `shouldBe` "--hi--"++    it "returns text unchanged when it fills the width" $ do+      alignText TextAlignment_Left "hello" '-' 3 `shouldBe` "hello"++    it "returns text unchanged when it exceeds the width" $ do+      alignText TextAlignment_Center "hello" '-' 2 `shouldBe` "hello"++    it "measures wide characters correctly" $ do+      alignText TextAlignment_Left "文" '-' 4 `shouldBe` "文--"++    it "handles empty text" $ do+      alignText TextAlignment_Center "" '-' 3 `shouldBe` "---"++  describe "centerText" $ do+    it "is a specialization of alignText" $ do+      centerText "hi" '-' 5 `shouldBe` alignText TextAlignment_Center "hi" '-' 5++  describe "boxStatic through the production host" $ do+    it "renders borders, inner padding, and the child content" $+      withApp defaultVtyAppConfig (12, 5) boxApp $ \dr -> do+        f0 <- lastFrame dr+        map (frameRow f0) [0 .. 4]+          `shouldBe` [ "┌──────────┐"+                     , "│hi        │"+                     , "│          │"+                     , "│          │"+                     , "└──────────┘"+                     ]+        gridWidth (frameGrid f0) `shouldBe` 12+        gridHeight (frameGrid f0) `shouldBe` 5+        stopApp dr++    it "handles 2-, 1-, 3-, and 0-cell dimensions" $+      withApp defaultVtyAppConfig (10, 4) boxApp $ \dr -> do+        f2 <- resizeApp dr (2, 2)+        frameRow f2 0 `shouldBe` "┌┐"+        frameRow f2 1 `shouldBe` "└┘"+        gridWidth (frameGrid f2) `shouldBe` 2+        f1 <- resizeApp dr (1, 2)+        frameRow f1 0 `shouldBe` " "+        frameRow f1 1 `shouldBe` " "+        f3 <- resizeApp dr (3, 1)+        frameRow f3 0 `shouldBe` " ─ "+        f0 <- resizeApp dr (0, 1)+        gridWidth (frameGrid f0) `shouldBe` 0+        stopApp dr++  describe "boxTitle through the production host" $ do+    it "renders all title alignments at a narrow width" $+      withApp defaultVtyAppConfig (8, 3) titleApp $ \dr -> do+        fCenter <- lastFrame dr+        frameRow fCenter 0 `shouldBe` "┌──Hi──┐"+        fLeft <- stepCommand dr TextAlignment_Left+        frameRow fLeft 0 `shouldBe` "┌Hi────┐"+        fRight <- stepCommand dr TextAlignment_Right+        frameRow fRight 0 `shouldBe` "┌────Hi┐"+        fCenterAgain <- stepCommand dr TextAlignment_Center+        frameRow fCenterAgain 0 `shouldBe` "┌──Hi──┐"+        stopApp dr++    it "clips a title wider than the box interior" $+      withApp defaultVtyAppConfig (8, 3) clipTitleApp $ \dr -> do+        f0 <- lastFrame dr+        frameRow f0 0 `shouldBe` "┌ABCDEF┐"+        stopApp dr++  describe "box through the production host" $ do+    it "translates clicks at screen coordinates to the inner coordinate system" $+      withApp defaultVtyAppConfig (10, 5) translateApp $ \dr -> do+        f0 <- lastFrame dr+        frameObservation f0 `shouldBe` (-1, -1)+        fClick <- stepInput dr (V.EvMouseDown 3 2 V.BLeft [])+        frameObservation fClick `shouldBe` (2, 1)+        fCorner <- stepInput dr (V.EvMouseDown 1 1 V.BLeft [])+        frameObservation fCorner `shouldBe` (0, 0)+        stopApp dr++    it "crops an oversized child image to the box interior" $+      withApp defaultVtyAppConfig (10, 4) clipApp $ \dr -> do+        f0 <- lastFrame dr+        frameRow f0 0 `shouldBe` "┌────────┐"+        frameRow f0 1 `shouldBe` "│XXXXXXXX│"+        frameRow f0 2 `shouldBe` "│        │"+        frameRow f0 3 `shouldBe` "└────────┘"+        gridWidth (frameGrid f0) `shouldBe` 10+        gridHeight (frameGrid f0) `shouldBe` 4+        stopApp dr++  describe "hRule through the production host" $ do+    it "fills its region and handles 2-, 1-, and 0-cell widths" $+      withApp defaultVtyAppConfig (6, 2) hRuleApp $ \dr -> do+        f0 <- lastFrame dr+        frameRow f0 0 `shouldBe` "──────"+        frameRow f0 1 `shouldBe` "──────"+        f2 <- resizeApp dr (2, 1)+        frameRow f2 0 `shouldBe` "──"+        f1 <- resizeApp dr (1, 1)+        frameRow f1 0 `shouldBe` "─"+        f0w <- resizeApp dr (0, 1)+        gridWidth (frameGrid f0w) `shouldBe` 0+        stopApp dr
+ test/Reflex/Vty/Widget/CursorSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.Widget.CursorSpec (spec) where++import qualified Graphics.Vty as V+import Reflex (never)+import Test.Hspec++import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Widget++spec :: Spec+spec = describe "Reflex.Vty.Widget cursor" $ do+  describe "defaultCursorState" $+    it "starts hidden with terminal-default style" $+      defaultCursorState `shouldBe` CursorState CursorHidden CursorStyleDefault (0, 0)++  describe "translateCursorState" $ do+    it "translates visible viewport-relative positions to absolute positions" $+      translateCursorState+        (Region 10 20 5 3)+        (CursorState CursorVisible CursorStyleBar (2, 1))+        `shouldBe` CursorState CursorVisible CursorStyleBar (12, 21)++    it "hides visible cursors outside the viewport" $+      translateCursorState+        (Region 10 20 5 3)+        (CursorState CursorVisible CursorStyleBlock (5, 1))+        `shouldBe` CursorState CursorHidden CursorStyleBlock (15, 21)++    it "translates hidden cursor positions without changing visibility" $+      translateCursorState+        (Region 10 20 5 3)+        (CursorState CursorHidden CursorStyleUnderline (7, 4))+        `shouldBe` CursorState CursorHidden CursorStyleUnderline (17, 24)++  describe "cursorStateToVtyCursor" $ do+    it "maps hidden cursor state to NoCursor" $+      cursorStateToVtyCursor (CursorState CursorHidden CursorStyleBlock (2, 3))+        `shouldBe` V.NoCursor++    it "maps visible cursor state to absolute terminal-cell coordinates" $+      -- reflex-vty coordinates are terminal cells. A visible cursor+      -- maps to 'V.AbsoluteCursor' (cell coordinates). It never maps+      -- to 'V.Cursor' (character offsets).+      cursorStateToVtyCursor (CursorState CursorVisible CursorStyleBlock (2, 3))+        `shouldBe` V.AbsoluteCursor 2 3++  describe "setCursor through the production host" $ do+    it "reports the cursor at the cell position after the wide glyph" $+      withApp defaultVtyAppConfig (20, 3) cursorApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> frameCursor f `shouldBe` V.AbsoluteCursor 3 0+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++  describe "ScreenMode" $ do+    it "has two constructors" $+      [ScreenNormal ..] `shouldBe` [ScreenNormal, ScreenAlternate]++    it "ScreenNormal /= ScreenAlternate" $+      ScreenNormal `shouldNotBe` ScreenAlternate++-- | A static row with one wide glyph. The terminal cursor sits three+-- cells from the left edge.+cursorApp :: TestApp () ()+cursorApp _cmd = do+  tellImages (pure [V.string V.defAttr "a\30028|"])+  setCursor (pure (CursorState CursorVisible CursorStyleDefault (3, 0)))+  pure (pure (), never)
+ test/Reflex/Vty/Widget/Input/TextSpec.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Behavior-covering specs for the text input widgets,+-- driven through the production host.+module Reflex.Vty.Widget.Input.TextSpec (spec) where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Data.Text.Zipper (fromText, left, textWidth, value)+import qualified Data.Text.Zipper as Z+import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..))+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Input.Text+import Reflex.Vty.Widget.Layout++spec :: Spec+spec = describe "Reflex.Vty.Widget.Input.Text" $ do+  describe "textInput" $ do+    it "types characters at the cursor" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        f1 <- stepInput driver (charKey 'a')+        let (v1, ls1, us1) = frameObservation f1+        v1 `shouldBe` "a"+        ls1 `shouldBe` 1+        us1 `shouldBe` ["a"]+        f2 <- stepInput driver (charKey 'b')+        frameObservation f2 `shouldBe` ("ab", 1, ["a", "ab"])+        gridRow (frameGrid f2) 0 `shouldBe` fullRow 20 "ab"+        stopApp driver++    it "backspace deletes left and delete deletes right" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        _ <- stepInput driver (charKey 'a')+        _ <- stepInput driver (charKey 'b')+        fBs <- stepInput driver (V.EvKey V.KBS [])+        let (v, _, _) = frameObservation fBs+        v `shouldBe` "a"+        _ <- stepInput driver (V.EvKey V.KHome [])+        fDel <- stepInput driver (V.EvKey V.KDel [])+        -- Home reports the (unchanged) value as a user-input+        -- occurrence because the zipper changed.+        frameObservation fDel `shouldBe` ("", 1, ["a", "ab", "a", "a", ""])+        gridRow (frameGrid fDel) 0 `shouldBe` fullRow 20 ""+        stopApp driver++    it "ctrl-u clears the input and ctrl-w deletes the previous word" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        typeStr driver "hello world"+        fW <- stepInput driver (ctrl 'w')+        let (vw, _, _) = frameObservation fW+        vw `shouldBe` "hello "+        fU <- stepInput driver (ctrl 'u')+        let (vu, lsu, usu) = frameObservation fU+        vu `shouldBe` ""+        lsu `shouldBe` 1+        usu `shouldSatisfy` ("" `elem`)+        gridRow (frameGrid fU) 0 `shouldBe` fullRow 20 ""+        stopApp driver++    it "left arrow moves the cursor within the line" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        typeStr driver "ab"+        _ <- stepInput driver (V.EvKey V.KLeft [])+        f <- stepInput driver (charKey 'X')+        let (v, _, _) = frameObservation f+        v `shouldBe` "aXb"+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "aXb"+        stopApp driver++    it "Enter does not insert a newline in a single-line input" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        typeStr driver "ab"+        _ <- stepInput driver (V.EvKey V.KEnter [])+        f <- stepInput driver (charKey 'c')+        let (v, ls, _) = frameObservation f+        v `shouldBe` "abc"+        ls `shouldBe` 1+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "abc"+        stopApp driver++    it "rejects Tab when acceptTab is False" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        _ <- stepInput driver (charKey 'a')+        _ <- stepInput driver (charKey 'b')+        fTab <- stepInput driver (V.EvKey (V.KChar '\t') [])+        let (v, _, us) = frameObservation fTab+        v `shouldBe` "ab"+        us `shouldBe` ["a", "ab"]+        f <- stepInput driver (charKey 'c')+        let (v', _, _) = frameObservation f+        v' `shouldBe` "abc"+        stopApp driver++    it "inserts a tab to the next tab stop when acceptTab is True" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" True) $ \driver -> do+        _ <- stepInput driver (charKey 'a')+        _ <- stepInput driver (charKey 'b')+        f <- stepInput driver (V.EvKey (V.KChar '\t') [])+        let (v, _, us) = frameObservation f+        v `shouldBe` "ab  "+        last us `shouldBe` "ab  "+        stopApp driver++    it "accepts UTF-8 paste including a wide character" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        f <- stepInput driver (V.EvPaste (TE.encodeUtf8 "hél世"))+        let (v, ls, us) = frameObservation f+        v `shouldBe` "hél世"+        ls `shouldBe` 1+        us `shouldBe` ["hél世"]+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "hél世"+        stopApp driver++    it "starts from the initial zipper with its cursor position" $+      withApp defaultVtyAppConfig (20, 3) (tiApp (left (fromText "abc")) False) $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f0 : _) -> do+            frameObservation f0 `shouldBe` ("abc", 1, [])+            gridRow (frameGrid f0) 0 `shouldBe` fullRow 20 "abc"+          [] -> expectationFailure "expected an initial frame"+        f <- stepInput driver (charKey 'X')+        let (v, _, _) = frameObservation f+        v `shouldBe` "abXc"+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "abXc"+        stopApp driver++    it "positions the cursor on click" $+      withApp defaultVtyAppConfig (20, 3) (tiApp (fromText "abcdef") False) $ \driver -> do+        fClick <- stepInput driver (V.EvMouseDown 3 0 V.BLeft [])+        let (vc, lsc, usc) = frameObservation fClick+        vc `shouldBe` "abcdef"+        lsc `shouldBe` 1+        usc `shouldBe` ["abcdef"]+        gridRow (frameGrid fClick) 0 `shouldBe` fullRow 20 "abcdef"+        f <- stepInput driver (charKey 'X')+        let (v, _, _) = frameObservation f+        v `shouldBe` "abcXdef"+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "abcXdef"+        stopApp driver++    it "masks the display while keeping the raw value" $+      withApp defaultVtyAppConfig (20, 3) maskApp $ \driver -> do+        typeStr driver "secret"+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            let (v, _, us) = frameObservation f+            v `shouldBe` "secret"+            last us `shouldBe` "secret"+            gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "******"+          [] -> expectationFailure "expected frames"+        stopApp driver++    it "scrolls horizontally-truncated content to keep the cursor visible" $+      withApp defaultVtyAppConfig (20, 1) (tiApp "" False) $ \driver -> do+        typeStr driver "abcdefghijklmnopqrstuvwxyz0123"+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            let (v, ls, _) = frameObservation f+            v `shouldBe` "abcdefghijklmnopqrstuvwxyz0123"+            ls `shouldBe` 2+            gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "uvwxyz0123"+          [] -> expectationFailure "expected frames"+        stopApp driver++    it "applies caller modification without emitting userInput" $+      withApp defaultVtyAppConfig (20, 3) (tiApp "" False) $ \driver -> do+        f <- stepCommand driver "SET"+        frameObservation f `shouldBe` ("SET", 1, [])+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "SET"+        stopApp driver++    it "applies modify after a simultaneous UI keypress, reporting only the UI result" $+      withApp defaultVtyAppConfig (20, 3) simApp $ \driver -> do+        f <- stepCommand driver ()+        frameObservation f `shouldBe` ("SET", 1, ["y"])+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "SET"+        stopApp driver++  describe "multilineTextInput" $ do+    it "Enter inserts a newline and counts display lines" $+      withApp defaultVtyAppConfig (20, 3) (mtiApp "" False) $ \driver -> do+        typeStr driver "ab"+        _ <- stepInput driver (V.EvKey V.KEnter [])+        f <- stepInput driver (charKey 'c')+        let (v, ls, _) = frameObservation f+        v `shouldBe` "ab\nc"+        ls `shouldBe` 2+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "ab"+        gridRow (frameGrid f) 1 `shouldBe` fullRow 20 "c"+        stopApp driver++    it "arrow keys move the cursor between lines" $+      withApp defaultVtyAppConfig (20, 3) (mtiApp (fromText "one\ntwo\nthree") False) $ \driver -> do+        _ <- stepInput driver (V.EvKey V.KUp [])+        fUp <- stepInput driver (charKey 'X')+        let (vu, _, _) = frameObservation fUp+        vu `shouldBe` "one\ntwoX\nthree"+        _ <- stepInput driver (V.EvKey V.KDown [])+        fDown <- stepInput driver (charKey 'Y')+        frameObservation fDown `shouldSatisfy` (\(v, ls, _) -> v == "one\ntwoX\nthreYe" && ls == 3)+        gridRow (frameGrid fDown) 1 `shouldBe` fullRow 20 "twoX"+        gridRow (frameGrid fDown) 2 `shouldBe` fullRow 20 "threYe"+        stopApp driver++    it "Home and End move to the start and end of the current line" $+      withApp defaultVtyAppConfig (20, 3) (mtiApp (fromText "one\ntwo\nthree") False) $ \driver -> do+        _ <- stepInput driver (V.EvKey V.KHome [])+        fHome <- stepInput driver (charKey 'X')+        let (vh, _, _) = frameObservation fHome+        vh `shouldBe` "one\ntwo\nXthree"+        gridRow (frameGrid fHome) 2 `shouldBe` fullRow 20 "Xthree"+        _ <- stepInput driver (V.EvKey V.KEnd [])+        fEnd <- stepInput driver (charKey 'Y')+        let (ve, _, _) = frameObservation fEnd+        ve `shouldBe` "one\ntwo\nXthreeY"+        stopApp driver++    it "PageUp and PageDown move by the viewport height" $+      withApp defaultVtyAppConfig (20, 3) (mtiApp (fromText "one\ntwo\nthree") False) $ \driver -> do+        _ <- stepInput driver (V.EvKey V.KPageUp [])+        fUp <- stepInput driver (charKey 'T')+        let (vt, _, _) = frameObservation fUp+        vt `shouldBe` "oneT\ntwo\nthree"+        gridRow (frameGrid fUp) 0 `shouldBe` fullRow 20 "oneT"+        _ <- stepInput driver (V.EvKey V.KPageDown [])+        fDown <- stepInput driver (charKey 'B')+        let (vb, ls, _) = frameObservation fDown+        vb `shouldBe` "oneT\ntwo\nthrBee"+        ls `shouldBe` 3+        stopApp driver++  describe "textInputTile" $ do+    it "sizes a column-oriented tile to its line count and adds lines with input" $+      withApp defaultVtyAppConfig (20, 5) tileColApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f0 : _) -> do+            frameObservation f0 `shouldBe` ("one\ntwo", 2)+            gridRow (frameGrid f0) 0 `shouldBe` fullRow 20 "one"+            gridRow (frameGrid f0) 1 `shouldBe` fullRow 20 "two"+            gridRow (frameGrid f0) 2 `shouldBe` fullRow 20 ""+          [] -> expectationFailure "expected an initial frame"+        -- Click the tile to focus it; keyboard input only reaches focused tiles.+        _ <- stepInput driver (V.EvMouseDown 0 0 V.BLeft [])+        fEnter <- stepInput driver (V.EvKey V.KEnter [])+        frameObservation fEnter `shouldBe` ("\none\ntwo", 3)+        f <- stepInput driver (charKey 'Z')+        -- The click at (0,0) left the cursor at the start of the+        -- document; Enter inserted a line there and 'Z' typed on the+        -- second logical line.+        frameObservation f `shouldBe` ("\nZone\ntwo", 3)+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 ""+        gridRow (frameGrid f) 1 `shouldBe` fullRow 20 "Zone"+        gridRow (frameGrid f) 2 `shouldBe` fullRow 20 "two"+        gridRow (frameGrid f) 3 `shouldBe` fullRow 20 ""+        stopApp driver++    it "sizes a row-oriented tile to the fallback width" $+      withApp defaultVtyAppConfig (20, 3) tileRowApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            frameObservation f `shouldBe` ("one two", 2)+            gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "one"+            gridRow (frameGrid f) 1 `shouldBe` fullRow 20 "two"+            gridRow (frameGrid f) 2 `shouldBe` fullRow 20 ""+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++-- | Build a single- or multiline input app whose command event sets the+-- value through '_textInputConfig_modify'.+inputApp+  :: (forall t m. TestWidget t m => TextInputConfig t -> m (TextInput t))+  -> Z.TextZipper+  -> Bool+  -> TestApp Text (Text, Int, [Text])+inputApp mk initial acceptTab cmd = do+  ti <-+    mk+      def+        { _textInputConfig_initialValue = initial+        , _textInputConfig_acceptTab = acceptTab+        , _textInputConfig_modify = const . fromText <$> cmd+        }+  userInputVals <- foldDyn (\x acc -> value x : acc) [] (_textInput_userInput ti)+  pure+    ( (,,) <$> _textInput_value ti <*> _textInput_lines ti <*> (reverse <$> userInputVals)+    , never+    )++tiApp, mtiApp :: Z.TextZipper -> Bool -> TestApp Text (Text, Int, [Text])+tiApp = inputApp textInput+mtiApp = inputApp multilineTextInput++-- | A masked single-line input: the raw value is observable, but every+-- character renders as @*@.+maskApp :: TestApp Text (Text, Int, [Text])+maskApp = inputApp (\c -> textInput c {_textInputConfig_display = pure (const '*')}) "" False++-- | Sends a UI 'y' keypress (injected into the input stream) and a+-- caller modification to @"SET"@ simultaneously, from one command.+simApp :: TestApp () (Text, Int, [Text])+simApp cmd = do+  let yKey = V.EvKey (V.KChar 'y') [] <$ cmd+  ti <-+    localInput (\i -> leftmost [i, yKey]) $+      textInput def {_textInputConfig_modify = const (fromText "SET") <$ cmd}+  userInputVals <- foldDyn (\x acc -> value x : acc) [] (_textInput_userInput ti)+  pure+    ( (,,) <$> _textInput_value ti <*> _textInput_lines ti <*> (reverse <$> userInputVals)+    , never+    )++-- | A column-oriented 'textInputTile' around a multiline input with two+-- lines.+tileColApp :: TestApp () (Text, Int)+tileColApp _cmd = do+  ti <-+    initManager_ $+      col $+        textInputTile+          (multilineTextInput def {_textInputConfig_initialValue = fromText "one\ntwo"})+          (pure 10)+  pure ((,) <$> _textInput_value ti <*> _textInput_lines ti, never)++-- | A row-oriented 'textInputTile' with fallback width 6 around a+-- multiline input.+tileRowApp :: TestApp () (Text, Int)+tileRowApp _cmd = do+  ti <-+    initManager_ $+      row $+        textInputTile+          (multilineTextInput def {_textInputConfig_initialValue = fromText "one two"})+          (pure 6)+  pure ((,) <$> _textInput_value ti <*> _textInput_lines ti, never)++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++charKey :: Char -> V.Event+charKey c = V.EvKey (V.KChar c) []++ctrl :: Char -> V.Event+ctrl c = V.EvKey (V.KChar c) [V.MCtrl]++-- | Type each character of the string into the app.+typeStr :: AppDriver c o -> String -> IO ()+typeStr driver = mapM_ (stepInput driver . charKey)++-- | The text of the @y@-th rendered row of a grid.+gridRow :: Grid -> Int -> String+gridRow g i = case drop i (rowStrings g) of+  (r : _) -> r+  [] -> ""++rowStrings :: Grid -> [String]+rowStrings = map (concatMap (T.unpack . renderSpanText)) . gridRows++-- | Pad a row string with trailing blanks to a full terminal row of the+-- given display width (wide characters count for their column width).+fullRow :: Int -> String -> String+fullRow w s = s ++ replicate (w - textWidth (T.pack s)) ' '
+ test/Reflex/Vty/Widget/InputSpec.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Behavior-covering specs for the input widgets in+-- "Reflex.Vty.Widget.Input", driven through the production host.+module Reflex.Vty.Widget.InputSpec (spec) where++import Control.Monad.Fix (MonadFix)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), attrAt)+import Reflex.Vty.Widget (input, localInput)+import Reflex.Vty.Widget.Input+import Reflex.Vty.Widget.Input.Mouse+import Reflex.Vty.Widget.Layout (fixed, initManager_, row, tabNavigation, tile)++-- | Terminal-default attribute: the baseline against which focus and+-- depressed styling is asserted on the rendered grid.+defaultAttr :: V.FixedAttr+defaultAttr = V.FixedAttr V.defaultStyleMask Nothing Nothing Nothing++-- | The full text of one rendered row of a frame.+frameRow :: Frame o -> Int -> String+frameRow f y = case drop y (gridRows (frameGrid f)) of+  (r : _) -> T.unpack (T.concat (map renderSpanText r))+  [] -> ""++-- | The newest frame drawn so far (for a static app, the initial frame).+lastFrame :: AppDriver c o -> IO (Frame o)+lastFrame dr = last <$> driverFrames dr++-- | Press and release the left button at screen coordinates.+clickAt :: AppDriver c o -> (Int, Int) -> IO (Frame o)+clickAt dr (x, y) = do+  _ <- stepInput dr (V.EvMouseDown x y V.BLeft [])+  stepInput dr (V.EvMouseUp x y (Just V.BLeft))++-- | Count occurrences of an event.+countEvents :: (Reflex t, MonadHold t m, MonadFix m) => Event t () -> m (Dynamic t Int)+countEvents e = foldDyn (\_ n -> n + 1) 0 e++-- | Expected screen row for two side-by-side 6-wide checkbox tiles on a+-- 20-wide terminal: the checkbox glyphs plus tile and screen padding.+checkboxRow :: Char -> Char -> String+checkboxRow a b =+  concat+    [ "["+    , [a]+    , "]"+    , replicate 3 ' '+    , "["+    , [b]+    , "]"+    , replicate 11 ' '+    ]++----------------------------------------------------------------------------+-- Applications under test+----------------------------------------------------------------------------++-- | Two 10x3 buttons side by side in focusable tiles. Observation: click+-- counts of the left and right button.+buttonApp :: TestApp () (Int, Int)+buttonApp _cmd = do+  (clickA, clickB) <- initManager_ $ do+    tabNavigation+    row $ do+      a <- tile (fixed (pure 10)) $ textButtonStatic def "OK"+      b <- tile (fixed (pure 10)) $ textButtonStatic def "NO"+      pure (a, b)+  countA <- countEvents clickA+  countB <- countEvents clickB+  pure (zipDynWith (,) countA countB, never)++-- | Two 6x1 checkboxes in focusable tiles. The command sets the value of+-- the left checkbox. Observation: (left, right) values.+checkboxApp :: TestApp () (Bool, Bool)+checkboxApp cmd = do+  (a, b) <- initManager_ $ do+    tabNavigation+    row $ do+      ca <- tile (fixed (pure 6)) $ checkbox (CheckboxConfig (pure checkboxStyleX) (False <$ cmd)) False+      cb <- tile (fixed (pure 6)) $ checkbox def False+      pure (ca, cb)+  pure (zipDynWith (,) a b, never)++-- | One checkbox that, on every command, simultaneously receives a+-- synthetic space keypress (through its input) and a @setValue True@.+-- Both are derived from the same command event, so they are+-- simultaneous; the UI toggle takes precedence. The checkbox starts+-- checked so the two outcomes are distinguishable.+precedenceApp :: TestApp () Bool+precedenceApp cmd = do+  v <-+    localInput (\orig -> leftmost [orig, V.EvKey (V.KChar ' ') [] <$ cmd]) $+      checkbox (CheckboxConfig (pure checkboxStyleX) (True <$ cmd)) True+  pure (v, never)++-- | A link with an 8-wide focusable tile. Observation: activation count+-- and the region-relative coordinates of the last mouse-up.+linkApp :: TestApp () (Int, (Int, Int))+linkApp _cmd = do+  clicks <-+    initManager_ . row . tile (fixed (pure 8)) $ do+      lu <- linkStatic "site"+      foldDyn (\u (n, _) -> (n + 1, _mouseUp_coordinates u)) (0, (0, 0)) lu+  pure (clicks, never)++----------------------------------------------------------------------------+-- Specs+----------------------------------------------------------------------------++spec :: Spec+spec = describe "Reflex.Vty.Widget.Input" $ do+  describe "button" $ do+    it "ignores keyboard activation while unfocused and activates on Enter once focused" $+      withApp defaultVtyAppConfig (24, 3) buttonApp $ \dr -> do+        f0 <- lastFrame dr+        take 20 (frameRow f0 0) `shouldBe` "┌────────┐┌────────┐"+        frameObservation f0 `shouldBe` (0, 0)+        fEnterUnfocused <- stepInput dr (V.EvKey V.KEnter [])+        frameObservation fEnterUnfocused `shouldBe` (0, 0)+        fTab <- stepInput dr (V.EvKey (V.KChar '\t') [])+        take 20 (frameRow fTab 0) `shouldBe` "┏━━━━━━━━┓┌────────┐"+        fEnter <- stepInput dr (V.EvKey V.KEnter [])+        frameObservation fEnter `shouldBe` (1, 0)+        fSpace <- stepInput dr (V.EvKey (V.KChar ' ') [])+        frameObservation fSpace `shouldBe` (1, 0)+        stopApp dr++    it "activates on a mouse click inside the button region and moves focus to the clicked button" $+      withApp defaultVtyAppConfig (24, 3) buttonApp $ \dr -> do+        _ <- stepInput dr (V.EvKey (V.KChar '\t') [])+        fLeft <- clickAt dr (5, 1)+        frameObservation fLeft `shouldBe` (1, 0)+        fRight <- clickAt dr (15, 1)+        frameObservation fRight `shouldBe` (1, 1)+        take 20 (frameRow fRight 0) `shouldBe` "┌────────┐┏━━━━━━━━┓"+        stopApp dr++    it "does not activate on a click outside every button region" $+      withApp defaultVtyAppConfig (24, 3) buttonApp $ \dr -> do+        _ <- stepInput dr (V.EvKey (V.KChar '\t') [])+        f0 <- lastFrame dr+        fOff <- clickAt dr (22, 1)+        frameObservation fOff `shouldBe` (0, 0)+        take 20 (frameRow fOff 0) `shouldBe` take 20 (frameRow f0 0)+        stopApp dr++  describe "checkbox" $ do+    it "reflects focus in the rendered attributes and toggles via the space key" $+      withApp defaultVtyAppConfig (20, 1) checkboxApp $ \dr -> do+        f0 <- lastFrame dr+        frameRow f0 0 `shouldBe` checkboxRow ' ' ' '+        frameObservation f0 `shouldBe` (False, False)+        attrAt 0 0 (frameGrid f0) `shouldBe` Just defaultAttr+        attrAt 6 0 (frameGrid f0) `shouldBe` Just defaultAttr+        fTab <- stepInput dr (V.EvKey (V.KChar '\t') [])+        -- The focused checkbox renders with a non-default (bold)+        -- attribute; the unfocused one stays at terminal defaults.+        attrAt 0 0 (frameGrid fTab) `shouldNotBe` Just defaultAttr+        attrAt 6 0 (frameGrid fTab) `shouldBe` Just defaultAttr+        attrAt 0 0 (frameGrid fTab) `shouldNotBe` attrAt 6 0 (frameGrid fTab)+        fSpace <- stepInput dr (V.EvKey (V.KChar ' ') [])+        frameObservation fSpace `shouldBe` (True, False)+        frameRow fSpace 0 `shouldBe` checkboxRow 'x' ' '+        fEnter <- stepInput dr (V.EvKey V.KEnter [])+        frameObservation fEnter `shouldBe` (True, False)+        stopApp dr++    it "toggles via a mouse click, shows depressed styling during the press, and focuses the clicked box" $+      withApp defaultVtyAppConfig (20, 1) checkboxApp $ \dr -> do+        f0 <- lastFrame dr+        frameObservation f0 `shouldBe` (False, False)+        fDown <- stepInput dr (V.EvMouseDown 7 0 V.BLeft [])+        frameObservation fDown `shouldBe` (False, False)+        frameRow fDown 0 `shouldBe` checkboxRow ' ' ' '+        attrAt 7 0 (frameGrid fDown) `shouldNotBe` Just defaultAttr+        fUp <- stepInput dr (V.EvMouseUp 7 0 (Just V.BLeft))+        frameObservation fUp `shouldBe` (False, True)+        frameRow fUp 0 `shouldBe` checkboxRow ' ' '\10003'+        -- Focus followed the click: right box now styled, left default.+        attrAt 6 0 (frameGrid fUp) `shouldNotBe` Just defaultAttr+        attrAt 0 0 (frameGrid fUp) `shouldBe` Just defaultAttr+        stopApp dr++    it "updates its value programmatically via _checkboxConfig_setValue" $+      withApp defaultVtyAppConfig (20, 1) checkboxApp $ \dr -> do+        _ <- stepInput dr (V.EvKey (V.KChar '\t') [])+        fSpace <- stepInput dr (V.EvKey (V.KChar ' ') [])+        frameObservation fSpace `shouldBe` (True, False)+        fSet <- stepCommand dr ()+        frameObservation fSet `shouldBe` (False, False)+        frameRow fSet 0 `shouldBe` checkboxRow ' ' ' '+        stopApp dr++    it "ignores Enter and clicks outside its region" $+      withApp defaultVtyAppConfig (20, 1) checkboxApp $ \dr -> do+        f0 <- lastFrame dr+        fEnter <- stepInput dr (V.EvKey V.KEnter [])+        frameObservation fEnter `shouldBe` (False, False)+        fOff <- clickAt dr (16, 0)+        frameObservation fOff `shouldBe` (False, False)+        frameRow fOff 0 `shouldBe` frameRow f0 0+        stopApp dr++    it "gives a simultaneous UI toggle precedence over _checkboxConfig_setValue" $+      withApp defaultVtyAppConfig (10, 1) precedenceApp $ \dr -> do+        f0 <- lastFrame dr+        frameObservation f0 `shouldBe` True+        take 3 (frameRow f0 0) `shouldBe` "[x]"+        f1 <- stepCommand dr ()+        frameObservation f1 `shouldBe` False+        take 3 (frameRow f1 0) `shouldBe` "[ ]"+        stopApp dr++  describe "link" $ do+    it "renders with link styling and activates on a click inside its region with region-relative coordinates" $+      withApp defaultVtyAppConfig (12, 1) linkApp $ \dr -> do+        f0 <- lastFrame dr+        take 4 (frameRow f0 0) `shouldBe` "site"+        frameObservation f0 `shouldBe` (0, (0, 0))+        attrAt 0 0 (frameGrid f0) `shouldNotBe` Just defaultAttr+        attrAt 0 0 (frameGrid f0) `shouldNotBe` attrAt 5 0 (frameGrid f0)+        fClick <- clickAt dr (3, 0)+        frameObservation fClick `shouldBe` (1, (3, 0))+        take 4 (frameRow fClick 0) `shouldBe` "site"+        stopApp dr++    it "does not activate on keyboard events" $+      withApp defaultVtyAppConfig (12, 1) linkApp $ \dr -> do+        fEnter <- stepInput dr (V.EvKey V.KEnter [])+        frameObservation fEnter `shouldBe` (0, (0, 0))+        fSpace <- stepInput dr (V.EvKey (V.KChar ' ') [])+        frameObservation fSpace `shouldBe` (0, (0, 0))+        stopApp dr++    it "does not activate on a click outside its region" $+      withApp defaultVtyAppConfig (12, 1) linkApp $ \dr -> do+        fClick <- clickAt dr (3, 0)+        frameObservation fClick `shouldBe` (1, (3, 0))+        fOff <- clickAt dr (10, 0)+        frameObservation fOff `shouldBe` (1, (3, 0))+        stopApp dr
+ test/Reflex/Vty/Widget/LayoutSpec.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Description: Pure layout-solver allocation semantics.+--+-- Expectations are independent literals and invariant properties; the+-- production allocation algorithm is never re-implemented here.+module Reflex.Vty.Widget.LayoutSpec (spec) where++import Control.Monad (forM_, replicateM)+import qualified Data.Map.Ordered as OM+import Test.Hspec+import Test.QuickCheck (Gen, choose, conjoin, counterexample, forAll, ioProperty, listOf, oneof, scale)++import Control.Monad.NodeId (NodeId, getNextNodeId, runNodeIdT)+import Reflex.Vty.Test.Generators (runPlanProperty)+import Reflex.Vty.Widget (Region (..))+import Reflex.Vty.Widget.Layout++-- | A row/column forest from main-axis constraints, using fresh node+-- identifiers from a real allocator. Returns the identifiers in+-- insertion order so tests can extract chunks by key (the underlying+-- map's traversal order is construction-dependent and must not be+-- relied on).+mkForest :: [Constraint] -> IO ([NodeId], LayoutForest (Constraint, Orientation))+mkForest cs = do+  ids <- runNodeIdT (replicateM (length cs) getNextNodeId)+  pure+    ( ids+    , fromListLF+        [ (nid, LayoutTree (c, Orientation_Row) mempty)+        | (nid, c) <- zip ids cs+        ]+    )++-- | The solved (offset, size) pairs of the direct children, in the+-- given key order.+childChunksIn+  :: Orientation+  -> Region+  -> [NodeId]+  -> LayoutTree (Region, Orientation)+  -> [(Int, Int)]+childChunksIn o parent ids = chunksInForest o parent ids . childrenLT++chunksInForest+  :: Orientation+  -> Region+  -> [NodeId]+  -> LayoutForest (Region, Orientation)+  -> [(Int, Int)]+chunksInForest o parent ids f =+  [ mainAxis o (fst (rootLT child))+  | i <- ids+  , Just child <- [lookupLF i f]+  ]+  where+    mainAxis orient r = case orient of+      Orientation_Row -> (_region_left r - _region_left parent, _region_width r)+      Orientation_Column -> (_region_top r - _region_top parent, _region_height r)++sizesOf :: [(Int, Int)] -> [Int]+sizesOf = map snd++spec :: Spec+spec = describe "Reflex.Vty.Widget.Layout (pure solver)" $ do+  describe "solve" $ do+    it "row width 12 with fixed 5, min 3, min 3 allocates 5/4/3" $ do+      (ids, forest) <- mkForest [Constraint_Fixed 5, Constraint_Min 3, Constraint_Min 3]+      let tree = solve Orientation_Row (Region 0 0 12 1) forest+      childChunksIn Orientation_Row (Region 0 0 12 1) ids tree `shouldBe` [(0, 5), (5, 4), (9, 3)]++    it "fixed-only children keep their sizes and ignore leftover space" $ do+      (ids, forest) <- mkForest [Constraint_Fixed 2, Constraint_Fixed 7]+      let tree = solve Orientation_Row (Region 0 0 20 1) forest+      childChunksIn Orientation_Row (Region 0 0 20 1) ids tree `shouldBe` [(0, 2), (2, 7)]++    it "an empty forest yields the root region with no children" $ do+      (_, forest) <- mkForest []+      let r = Region 3 4 10 10+          tree = solve Orientation_Column r forest+      rootLT tree `shouldBe` (r, Orientation_Column)+      length (OM.assocs (unLayoutForest (childrenLT tree))) `shouldBe` 0++    it "zero extent overflows deliberately with minimum sizes intact" $ do+      (ids, forest) <- mkForest [Constraint_Fixed 2, Constraint_Min 1]+      let tree = solve Orientation_Row (Region 0 0 0 1) forest+      sizesOf (childChunksIn Orientation_Row (Region 0 0 0 1) ids tree) `shouldBe` [2, 1]++    it "distributes remainders to the earliest stretchable children" $ do+      (ids, forest) <- mkForest [Constraint_Min 0, Constraint_Min 0, Constraint_Min 0]+      let tree = solve Orientation_Row (Region 0 0 10 1) forest+      childChunksIn Orientation_Row (Region 0 0 10 1) ids tree `shouldBe` [(0, 4), (4, 3), (7, 3)]++    it "nests orientations: a row child's column chunks its width" $ do+      (innerIds, innerForest) <- mkForest [Constraint_Min 1, Constraint_Min 1]+      [innerKey, lastKey] <- runNodeIdT (replicateM 2 getNextNodeId)+      let inner = LayoutTree (Constraint_Fixed 6, Orientation_Column) innerForest+          forest = fromListLF [(innerKey, inner), (lastKey, LayoutTree (Constraint_Min 0, Orientation_Row) mempty)]+          tree = solve Orientation_Row (Region 0 0 10 5) forest+          [rowChild0, rowChild1] = OM.assocs (unLayoutForest (childrenLT tree))+      -- The fixed 6-wide first child gets the column layout inside it.+      case lookupLF innerKey (childrenLT tree) of+        Just (LayoutTree (r0, _) innerSolved) -> do+          _region_left r0 `shouldBe` 0+          _region_width r0 `shouldBe` 6+          chunksInForest Orientation_Column r0 innerIds innerSolved+            `shouldBe` [(0, 3), (3, 2)]+        _ -> expectationFailure "expected the fixed column child"+      case lookupLF lastKey (childrenLT tree) of+        Just (LayoutTree (r1, _) _) -> do+          _region_left r1 `shouldBe` 6+          _region_width r1 `shouldBe` 4+        _ -> expectationFailure "expected the stretchable row child"++    it "preserves solver invariants on random constraint forests" $+      runPlanProperty $+        conjoin $+          map+            ( \o ->+                forAll ((,) <$> choose (0, 40) <*> scale (min 6) constraintList) $ \(extent, cs) -> ioProperty $ do+                  (ids, forest) <- mkForest cs+                  let region = case o of+                        Orientation_Row -> Region 0 0 extent 1+                        Orientation_Column -> Region 0 0 1 extent+                      tree = solve o region forest+                      chunks = childChunksIn o region ids tree+                      sizes = sizesOf chunks+                      offsets = map fst chunks+                      minTotal = sum [n | c <- cs, n <- [constraintMin c]]+                      numStretch = length [() | Constraint_Min _ <- cs]+                      fits = minTotal <= extent+                      expectedTotal+                        | not fits = minTotal -- deliberate overflow+                        | numStretch > 0 = extent -- stretch absorbs everything+                        | otherwise = minTotal -- fixed-only leaves leftover+                  pure $+                    counterexample+                      ( show o+                          ++ " extent "+                          ++ show extent+                          ++ " constraints "+                          ++ show cs+                          ++ " -> chunks "+                          ++ show chunks+                      )+                      ( length sizes == length cs+                          && and (zipWith (\c s -> s >= constraintMin c) cs sizes)+                          && and (zipWith (<=) offsets (drop 1 offsets))+                          && and (zipWith (\(_, s) next -> next - s >= 0) chunks (drop 1 offsets))+                          && sum sizes == expectedTotal+                      )+            )+            orientations++    it "column chunks advance top, row chunks advance left" $ do+      (ids, forest) <- mkForest [Constraint_Fixed 4, Constraint_Fixed 5]+      let parent = Region 2 3 10 9+          colTree = solve Orientation_Column parent forest+      childChunksIn Orientation_Column parent ids colTree `shouldBe` [(0, 4), (4, 5)]+      case map (\node -> lookupLF node (childrenLT colTree)) (take 1 ids) of+        [Just (LayoutTree (r0, _) _)] -> (_region_left r0, _region_top r0, _region_height r0) `shouldBe` (2, 3, 4)+        _ -> expectationFailure "expected the first column child"+  where+    orientations = [Orientation_Row, Orientation_Column]+    offsetPlus s next = next - s >= 0+    constraintMin c = case c of+      Constraint_Fixed n -> n+      Constraint_Min n -> n++-- | Bounded valid constraint lists (up to 6 children).+constraintList :: Gen [Constraint]+constraintList =+  scale (min 6) $+    listOf $+      oneof+        [ Constraint_Fixed <$> choose (0, 12)+        , Constraint_Min <$> choose (0, 12)+        ]
+ test/Reflex/Vty/Widget/MouseSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.Widget.MouseSpec (spec) where++import qualified Graphics.Vty as V+import Test.Hspec++import Reflex.Vty.Widget.Input.Mouse++-- | Replay a list of vty events through 'stepDrag', keeping the previous drag+-- state when an event is irrelevant (mirroring how 'drag' holds its state).+-- Returns the 'Drag' emitted for each relevant event, in order.+runDrag :: V.Button -> [V.Event] -> [Drag]+runDrag btn = go Nothing+  where+    go _ [] = []+    go prev (e : es) = case stepDrag btn prev e of+      Just d -> d : go (Just d) es+      Nothing -> go prev es++down :: Int -> Int -> V.Button -> V.Event+down x y b = V.EvMouseDown x y b []++up :: Int -> Int -> Maybe V.Button -> V.Event+up x y b = V.EvMouseUp x y b++spec :: Spec+spec = describe "Reflex.Vty.Widget.Input.Mouse" $ do+  describe "stepDrag" $ do+    it "starts a drag on the first matching mouse-down" $+      stepDrag V.BLeft Nothing (down 3 4 V.BLeft)+        `shouldBe` Just (Drag (3, 4) (3, 4) V.BLeft [] DragStart)++    it "ignores a mouse-down for a different button" $+      stepDrag V.BLeft Nothing (down 3 4 V.BRight) `shouldBe` Nothing++    it "ignores non-mouse events" $+      stepDrag V.BLeft Nothing (V.EvKey (V.KChar 'a') []) `shouldBe` Nothing++    it "continues as Dragging on subsequent moves, preserving the origin" $ do+      let start = Drag (3, 4) (3, 4) V.BLeft [] DragStart+      stepDrag V.BLeft (Just start) (down 5 6 V.BLeft)+        `shouldBe` Just (Drag (3, 4) (5, 6) V.BLeft [] Dragging)++    it "ends the drag on mouse-up (button specified)" $ do+      let dragging = Drag (3, 4) (5, 6) V.BLeft [] Dragging+      stepDrag V.BLeft (Just dragging) (up 7 8 (Just V.BLeft))+        `shouldBe` Just (Drag (3, 4) (7, 8) V.BLeft [] DragEnd)++    it "ends the drag on mouse-up (button unspecified)" $ do+      let dragging = Drag (3, 4) (5, 6) V.BLeft [] Dragging+      stepDrag V.BLeft (Just dragging) (up 7 8 Nothing)+        `shouldBe` Just (Drag (3, 4) (7, 8) V.BLeft [] DragEnd)++    it "ignores a stray mouse-up after the drag already ended" $ do+      let ended = Drag (3, 4) (7, 8) V.BLeft [] DragEnd+      stepDrag V.BLeft (Just ended) (up 9 9 (Just V.BLeft)) `shouldBe` Nothing++    it "starts a fresh drag on a mouse-down after the previous one ended" $ do+      let ended = Drag (3, 4) (7, 8) V.BLeft [] DragEnd+      stepDrag V.BLeft (Just ended) (down 1 1 V.BLeft)+        `shouldBe` Just (Drag (1, 1) (1, 1) V.BLeft [] DragStart)++    it "produces Start -> Dragging -> End across a full drag" $ do+      let ds = runDrag V.BLeft [down 1 1 V.BLeft, down 2 2 V.BLeft, down 3 3 V.BLeft, up 3 3 (Just V.BLeft)]+      map _drag_state ds `shouldBe` [DragStart, Dragging, Dragging, DragEnd]+      map _drag_from ds `shouldBe` replicate 4 (1, 1)+      _drag_to (last ds) `shouldBe` (3, 3)++    it "tracks two consecutive drags, each with its own Start and End" $ do+      let evs =+            [ down 1 1 V.BLeft+            , up 1 1 (Just V.BLeft)+            , down 5 5 V.BLeft+            , down 6 6 V.BLeft+            , up 6 6 Nothing+            ]+      map _drag_state (runDrag V.BLeft evs)+        `shouldBe` [DragStart, DragEnd, DragStart, Dragging, DragEnd]
+ test/Reflex/Vty/Widget/ScrollSpec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Vty.Widget.ScrollSpec (spec) where++import Control.Monad (forM_)+import qualified Graphics.Vty as V+import Test.Hspec++import Reflex.Vty.Test.Snapshot+import Reflex.Vty.Widget.Scroll+  ( ScrollPos (..)+  , ScrollbarVisibility (..)+  , scrollByLines+  , scrollToLine+  , scrollbarImages+  )++-- | Specified normalization of an already-clamped target line.+expectedPosFromClamped :: Int -> Int -> Int -> ScrollPos+expectedPosFromClamped total height line+  | total <= height = ScrollPos_Top+  | line <= 0 = ScrollPos_Top+  | line + height >= total = ScrollPos_Bottom+  | otherwise = ScrollPos_Line line++-- | Specified normalization of a raw (possibly out-of-range) request.+expectedPos :: Int -> Int -> Int -> ScrollPos+expectedPos total height req = expectedPosFromClamped total height (max 0 req)++spec :: Spec+spec = describe "Reflex.Vty.Widget.Scroll" $ do+  describe "scrollbarImages" $ do+    let attr = V.defAttr++    it "returns empty when hidden" $ do+      scrollbarImages ScrollbarHidden attr 10 50 0 20 `shouldBe` []++    it "returns empty when content fits viewport" $ do+      scrollbarImages ScrollbarAlways attr 10 5 0 20 `shouldBe` []++    it "returns empty when viewport too narrow" $ do+      scrollbarImages ScrollbarAlways attr 10 50 0 1 `shouldBe` []++    it "produces a thumb and gutter for ScrollbarAlways" $ do+      let imgs = scrollbarImages ScrollbarAlways attr 10 50 0 20+      length imgs `shouldBe` 2 -- gutter + thumb+    it "produces only a thumb for ScrollbarThumbOnly" $ do+      let imgs = scrollbarImages ScrollbarThumbOnly attr 10 50 0 20+      length imgs `shouldBe` 1 -- thumb only+    it "produces only a thumb for ScrollbarWhileScrolling" $ do+      let imgs = scrollbarImages ScrollbarWhileScrolling attr 10 50 0 20+      length imgs `shouldBe` 1 -- thumb only+    it "places thumb at top when scrollLine is 0" $ do+      let imgs = scrollbarImages ScrollbarThumbOnly attr 10 50 0 20+          rows = imageText (V.vertCat imgs)+          -- Thumb should be at the top of the rightmost column+          firstChar [] = ' '+          firstChar (c : _) = c+      case rows of+        (r : _) -> last r `shouldBe` '█'+        [] -> expectationFailure "expected at least one rendered row"+      case rows of+        (r1 : _) -> firstChar r1 `shouldBe` ' '+        [] -> expectationFailure "expected at least one rendered row"++    it "places thumb lower when scrolled down" $ do+      let imgsAtTop = scrollbarImages ScrollbarThumbOnly attr 10 50 0 20+          imgsScrolled = scrollbarImages ScrollbarThumbOnly attr 10 50 20 20+          topRow = imageText (V.vertCat imgsAtTop)+          scrolledRows = imageText (V.vertCat imgsScrolled)+      case (topRow, scrolledRows) of+        ((top : _), (scrolled : _)) -> do+          last top `shouldBe` '█'+          -- When scrolled, the first row should not have the thumb+          last scrolled `shouldSatisfy` (/= '█')+        _ -> expectationFailure "expected rendered rows"++  describe "scrollToLine" $ do+    it "normalizes every small-domain request exactly" $ do+      -- Exhaustive over totalLines 0..6, height 0..4, request -2..8,+      -- against the specified semantics: content that fits is Top;+      -- nonpositive requests are Top; requests at/past the last page+      -- are Bottom; anything else is the exact line.+      forM_ [(0 :: Int) .. 6] $ \total ->+        forM_ [0 .. 4] $ \height ->+          forM_ [(-2) .. 8] $ \req ->+            scrollToLine total height req+              `shouldBe` expectedPos total height req++  describe "scrollByLines" $ do+    it "clamps and normalizes relative movement from every starting form" $ do+      forM_ [ScrollPos_Top, ScrollPos_Bottom, ScrollPos_Line 0, ScrollPos_Line 2, ScrollPos_Line 5] $ \sp ->+        forM_ [(0 :: Int) .. 6] $ \total ->+          forM_ [0 .. 4] $ \height ->+            forM_ [(-3), (-1), 0, 1, 4] $ \delta -> do+              -- The starting line is used literally; stored positions+              -- are always normalized in production, so Top is 0 and+              -- Bottom is the last page.+              let start = case sp of+                    ScrollPos_Top -> 0+                    ScrollPos_Bottom -> total - height+                    ScrollPos_Line n -> n+                  target = min total (max 0 (start + delta))+              scrollByLines sp total height delta+                `shouldBe` (if total <= height then ScrollPos_Top else expectedPosFromClamped total height target)++    it "thumb size is proportional to viewport/total ratio" $ do+      let attr' = V.defAttr+          -- vpHeight=10, totalLines=100 → thumbLen = max 1 (100/100) = 1+          imgs1 = scrollbarImages ScrollbarThumbOnly attr' 10 100 0 20+          -- vpHeight=10, totalLines=20 → thumbLen = max 1 (100/20) = 5+          imgs2 = scrollbarImages ScrollbarThumbOnly attr' 10 20 0 20+          heightOf [] = 0+          heightOf (img : _) = V.imageHeight img+      heightOf imgs1 `shouldBe` 1+      heightOf imgs2 `shouldBe` 5
+ test/Reflex/Vty/Widget/SplitSpec.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Vty.Widget.SplitSpec (spec) where++import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec hiding (focus)++import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..))+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Split (splitH, splitV, splitVDrag)+import Reflex.Vty.Widget.Text (fill)++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Text content of one row of a rendered grid.+rowText :: Grid -> Int -> String+rowText g y = T.unpack . T.concat . map renderSpanText $ gridRows g !! y++-- | All row texts of a grid.+rows :: Grid -> [String]+rows g = map (T.unpack . T.concat . map renderSpanText) (gridRows g)++-- | Index of the divider row (the only row made entirely of '-').+dividerRow :: Grid -> Int+dividerRow g = case [y | (y, r) <- zip [0 ..] (rows g), all (== '-') r && not (null r)] of+  (y : _) -> y+  [] -> error "no divider row found"++replicateRow :: Int -> Char -> String+replicateRow w c = replicate w c++mouseDownAt :: Int -> Int -> V.Event+mouseDownAt x y = V.EvMouseDown x y V.BLeft []++mouseUpAt :: Int -> Int -> V.Event+mouseUpAt x y = V.EvMouseUp x y (Just V.BLeft)++-- | Drag the divider from one row to another at a fixed column.+dragDivider :: AppDriver c o -> Int -> Int -> IO (Frame o)+dragDivider driver fromY toY = do+  _ <- stepInput driver (mouseDownAt 0 fromY)+  stepInput driver (mouseUpAt 0 toY)++----------------------------------------------------------------------------+-- Applications under test+----------------------------------------------------------------------------++-- | A draggable vertical split: pane A and pane B each fill their region+-- with their letter and report focus; the divider fills its row with '-'.+dragSplitApp :: TestApp () (T.Text, T.Text)+dragSplitApp _cmd = do+  (a, b) <- splitVDrag (fill (pure '-')) (splitPane 'A') (splitPane 'B')+  pure ((,) <$> a <*> b, never)+  where+    splitPane c = do+      fill (pure c)+      foc <- focus+      pure (ffor foc $ \f -> T.pack [c, if f then '*' else '-'])++-- | A plain vertical split whose first pane takes a third of the height.+thirdSplitApp :: TestApp () ()+thirdSplitApp _cmd = do+  _ <- splitV (pure (`div` 3)) (pure (True, True)) (fill (pure 'X')) (fill (pure 'Y'))+  pure (pure (), never)++-- | A plain horizontal split whose first pane is 8 columns narrower+-- than the viewport.+hSplitApp :: TestApp () ()+hSplitApp _cmd = do+  _ <- splitH (pure (subtract 8)) (pure (True, True)) (fill (pure 'P')) (fill (pure 'Q'))+  pure (pure (), never)++-- | A vertical split with a nested horizontal split in the second pane.+nestedSplitApp :: TestApp () ()+nestedSplitApp _cmd = do+  _ <-+    splitV (pure (subtract 4)) (pure (True, True)) (fill (pure 'T')) $+      splitH (pure (`div` 2)) (pure (True, True)) (fill (pure 'L')) (fill (pure 'R'))+  pure (pure (), never)++----------------------------------------------------------------------------+-- Spec+----------------------------------------------------------------------------++spec :: Spec+spec = describe "Reflex.Vty.Widget.Split" $ do+  describe "splitVDrag through the production host" $ do+    it "starts with an even split, divider at half height" $+      withApp defaultVtyAppConfig (20, 10) dragSplitApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            rows (frameGrid f)+              `shouldBe` replicate 5 (replicateRow 20 'A') ++ [replicateRow 20 '-'] ++ replicate 4 (replicateRow 20 'B')+            dividerRow (frameGrid f) `shouldBe` 5+            frameObservation f `shouldBe` ("A*", "B-")+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++    it "moves the divider on drag and keeps the fraction on resize" $+      withApp defaultVtyAppConfig (20, 10) dragSplitApp $ \driver -> do+        -- Press on the divider itself: nothing moves yet.+        f1 <- stepInput driver (mouseDownAt 0 5)+        dividerRow (frameGrid f1) `shouldBe` 5+        -- Release on row 7: the divider moves to row 7.+        f2 <- stepInput driver (mouseUpAt 0 7)+        dividerRow (frameGrid f2) `shouldBe` 7+        rows (frameGrid f2)+          `shouldBe` replicate 7 (replicateRow 20 'A') ++ [replicateRow 20 '-'] ++ replicate 2 (replicateRow 20 'B')+        frameObservation f2 `shouldBe` ("A*", "B-")+        -- The user-chosen fraction (7/10) stays after a resize: 0.7 * 20 = 14.+        resizeApp driver (20, 20)+        fs <- driverFrames driver+        case reverse fs of+          (f3 : _) -> do+            dividerRow (frameGrid f3) `shouldBe` 14+            rows (frameGrid f3)+              `shouldBe` replicate 14 (replicateRow 20 'A') ++ [replicateRow 20 '-'] ++ replicate 5 (replicateRow 20 'B')+          [] -> expectationFailure "expected a frame after resize"+        stopApp driver++    it "supports repeated drags, each moving the divider again" $+      withApp defaultVtyAppConfig (20, 10) dragSplitApp $ \driver -> do+        f1 <- dragDivider driver 5 7+        dividerRow (frameGrid f1) `shouldBe` 7+        -- A second drag starts from the divider's new position.+        f2 <- dragDivider driver 7 2+        dividerRow (frameGrid f2) `shouldBe` 2+        rows (frameGrid f2)+          `shouldBe` replicate 2 (replicateRow 20 'A') ++ [replicateRow 20 '-'] ++ replicate 7 (replicateRow 20 'B')+        -- And a third drag back down.+        f3 <- dragDivider driver 2 9+        dividerRow (frameGrid f3) `shouldBe` 9+        stopApp driver++    it "ignores drags that do not start on the divider" $+      withApp defaultVtyAppConfig (20, 10) dragSplitApp $ \driver -> do+        -- Press inside pane A (row 0) and release inside pane B's area.+        f1 <- stepInput driver (mouseDownAt 0 0)+        dividerRow (frameGrid f1) `shouldBe` 5+        f2 <- stepInput driver (mouseUpAt 2 8)+        dividerRow (frameGrid f2) `shouldBe` 5+        rows (frameGrid f2)+          `shouldBe` replicate 5 (replicateRow 20 'A') ++ [replicateRow 20 '-'] ++ replicate 4 (replicateRow 20 'B')+        -- A click in pane A also leaves focus alone.+        frameObservation f2 `shouldBe` ("A*", "B-")+        stopApp driver++    it "clamps drags past the bottom edge and keeps extents nonnegative" $+      withApp defaultVtyAppConfig (20, 10) dragSplitApp $ \driver -> do+        f <- dragDivider driver 5 50+        let g = frameGrid f+        -- The divider is clamped to the last row; pane B gets zero height.+        dividerRow g `shouldBe` 9+        rows g `shouldBe` replicate 9 (replicateRow 20 'A') ++ [replicateRow 20 '-']+        -- The rendered grid itself never reports negative extents.+        gridWidth g `shouldBe` 20+        gridHeight g `shouldBe` 10+        length (gridRows g) `shouldBe` 10+        stopApp driver++    it "switches pane focus by clicking the panes" $+      withApp defaultVtyAppConfig (20, 10) dragSplitApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> frameObservation f0 `shouldBe` ("A*", "B-")+          [] -> expectationFailure "expected an initial frame"+        -- Click inside pane B (rows 6..9): focus moves to B.+        f1 <- stepInput driver (mouseDownAt 0 6)+        frameObservation f1 `shouldBe` ("A-", "B*")+        -- Release completes the click so pane A's mouse tracking resets.+        _ <- stepInput driver (mouseUpAt 0 6)+        -- Click inside pane A (rows 0..4): focus moves back.+        f2 <- stepInput driver (mouseDownAt 0 0)+        frameObservation f2 `shouldBe` ("A*", "B-")+        _ <- stepInput driver (mouseUpAt 0 0)+        stopApp driver++    it "works at a one-row height and splits evenly after a resize" $+      withApp defaultVtyAppConfig (20, 1) dragSplitApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> do+            -- The terminal has one row: the divider occupies that row.+            rows (frameGrid f0) `shouldBe` [replicateRow 20 '-']+            gridHeight (frameGrid f0) `shouldBe` 1+            frameObservation f0 `shouldBe` ("A*", "B-")+          [] -> expectationFailure "expected an initial frame"+        -- No user fraction exists yet, so the grown terminal halves evenly.+        resizeApp driver (20, 10)+        fs <- driverFrames driver+        case reverse fs of+          (f1 : _) -> do+            dividerRow (frameGrid f1) `shouldBe` 5+            rows (frameGrid f1)+              `shouldBe` replicate 5 (replicateRow 20 'A') ++ [replicateRow 20 '-'] ++ replicate 4 (replicateRow 20 'B')+          [] -> expectationFailure "expected a frame after resize"+        stopApp driver++  describe "splitV" $ do+    it "sizes the first pane with the given function and follows resizes" $+      withApp defaultVtyAppConfig (20, 10) thirdSplitApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            rows (frameGrid f)+              `shouldBe` replicate 3 (replicateRow 20 'X') ++ replicate 7 (replicateRow 20 'Y')+          [] -> expectationFailure "expected an initial frame"+        -- 16 div 3 = 5 rows for X.+        resizeApp driver (20, 16)+        fs' <- driverFrames driver+        case reverse fs' of+          (f : _) ->+            rows (frameGrid f)+              `shouldBe` replicate 5 (replicateRow 20 'X') ++ replicate 11 (replicateRow 20 'Y')+          [] -> expectationFailure "expected a frame after resize"+        stopApp driver++  describe "splitH" $ do+    it "sizes the left pane with the given function" $+      withApp defaultVtyAppConfig (20, 10) hSplitApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) ->+            rows (frameGrid f)+              `shouldBe` replicate 10 (replicate 12 'P' ++ replicate 8 'Q')+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++    it "manages a nested split inside one pane" $+      withApp defaultVtyAppConfig (20, 10) nestedSplitApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) ->+            rows (frameGrid f)+              `shouldBe` replicate 6 (replicateRow 20 'T')+                ++ replicate 4 (replicate 10 'L' ++ replicate 10 'R')+          [] -> expectationFailure "expected an initial frame"+        stopApp driver
+ test/Reflex/Vty/Widget/TextSpec.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Description: Behavior-covering specs for the text rendering widgets,+-- driven through the production host.+module Reflex.Vty.Widget.TextSpec (spec) where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Data.Text.Zipper (TextAlignment (..), textWidth)+import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), attrAt, imageText)+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Layout+import Reflex.Vty.Widget.Text++-- | Commands driving the dynamic inputs of the text widgets.+data TextCmd+  = SetText Text+  | SetFill Char+  deriving (Eq, Show)++spec :: Spec+spec = describe "Reflex.Vty.Widget.Text" $ do+  describe "rendered through the production host" $ do+    it "renders text, display, fill, and rich text in their layout rows" $+      withApp defaultVtyAppConfig (20, 7) textApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            frameObservation f `shouldBe` "alpha beta"+            gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "alpha beta"+            gridRow (frameGrid f) 1 `shouldBe` fullRow 20 ""+            gridRow (frameGrid f) 5 `shouldBe` fullRow 20 "10"+            gridRow (frameGrid f) 6 `shouldBe` replicate 20 '#'+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++    it "re-renders every row when the value changes via command" $+      withApp defaultVtyAppConfig (20, 7) textApp $ \driver -> do+        f <- stepCommand driver (SetText "wrap this longer line")+        frameObservation f `shouldBe` "wrap this longer line"+        gridRow (frameGrid f) 0 `shouldBe` fullRow 20 "wrap this longer"+        gridRow (frameGrid f) 1 `shouldBe` fullRow 20 "line"+        gridRow (frameGrid f) 5 `shouldBe` fullRow 20 "21"+        stopApp driver++    it "re-wraps to the new width on resize" $+      withApp defaultVtyAppConfig (20, 7) textApp $ \driver -> do+        _ <- stepCommand driver (SetText "wrap this longer line")+        f <- resizeApp driver (8, 7)+        frameObservation f `shouldBe` "wrap this longer line"+        gridRow (frameGrid f) 0 `shouldBe` fullRow 8 "wrap"+        gridRow (frameGrid f) 1 `shouldBe` fullRow 8 "this"+        gridRow (frameGrid f) 5 `shouldBe` fullRow 8 "21"+        gridRow (frameGrid f) 6 `shouldBe` replicate 8 '#'+        stopApp driver++    it "tracks a dynamic fill character" $+      withApp defaultVtyAppConfig (20, 7) textApp $ \driver -> do+        f <- stepCommand driver (SetFill 'x')+        gridRow (frameGrid f) 6 `shouldBe` replicate 20 'x'+        stopApp driver++    it "applies rich text attributes to the rendered cells" $+      withApp defaultVtyAppConfig (20, 7) textApp $ \driver -> do+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            let mAttr = attrAt 0 4 (frameGrid f)+            mAttr `shouldSatisfy` maybe False (\a -> V.hasStyle (V.fixedStyle a) V.bold)+            attrAt 0 5 (frameGrid f) `shouldSatisfy` maybe False (\a -> V.fixedStyle a == V.defaultStyleMask)+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++    it "renders center and right alignment as unpadded wrapped rows" $+      withApp defaultVtyAppConfig (20, 7) textApp $ \driver -> do+        -- wrapTextImage renders only the wrapped text of each line; the+        -- computed alignment offsets are not turned into padding.+        fs <- driverFrames driver+        case reverse fs of+          (f : _) -> do+            gridRow (frameGrid f) 2 `shouldBe` fullRow 20 "alpha beta"+            gridRow (frameGrid f) 3 `shouldBe` fullRow 20 "alpha beta"+            gridRow (frameGrid f) 2 `shouldBe` gridRow (frameGrid f) 0+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++  describe "wrapTextImage" $ do+    it "wraps words to the given width" $+      imageText (wrapTextImage TextAlignment_Left 8 V.defAttr "aaa bb ccc")+        `shouldBe` ["aaa bb", "ccc   "]++    it "splits on explicit newlines before wrapping" $+      imageText (wrapTextImage TextAlignment_Left 20 V.defAttr "a\nbb cc dd")+        `shouldBe` ["a       ", "bb cc dd"]++    it "accounts for wide characters when measuring width" $ do+      -- "世界" fills the 4-column width exactly; "ab" wraps to the+      -- second row and is padded out to the same width.+      let img = wrapTextImage TextAlignment_Left 4 V.defAttr "世界ab"+      imageText img `shouldBe` ["世界", "ab  "]+      V.imageWidth img `shouldBe` 4+      V.imageHeight img `shouldBe` 2++    it "renders alignment variants as the same wrapped rows" $ do+      let rows alignment = imageText (wrapTextImage alignment 6 V.defAttr "one two three")+      rows TextAlignment_Center `shouldBe` rows TextAlignment_Left+      rows TextAlignment_Right `shouldBe` rows TextAlignment_Left+      rows TextAlignment_Left `shouldBe` ["one  ", "two  ", "three"]++    it "returns no rows for a non-positive width" $+      imageText (wrapTextImage TextAlignment_Left 0 V.defAttr "abc") `shouldBe` []++-- | A stack of text widgets in fixed layout rows:+--+-- * rows 0-1: 'text' (wraps to two rows)+-- * row 2: 'textWithAlignment' centered+-- * row 3: 'textWithAlignment' right-aligned+-- * row 4: 'richText' with a bold attribute+-- * row 5: 'display' of the text length+-- * row 6: 'fill' with a dynamic character+textApp :: TestApp TextCmd Text+textApp cmd = do+  let setTexts = fforMaybe cmd $ \c -> case c of+        SetText t -> Just t+        SetFill _ -> Nothing+      setFills = fforMaybe cmd $ \c -> case c of+        SetFill ch -> Just ch+        SetText _ -> Nothing+  t <- holdDyn "alpha beta" setTexts+  fillChar <- holdDyn '#' setFills+  _ <- initManager_ $+    col $ do+      grout (fixed (pure 2)) $ text (current t)+      grout (fixed (pure 1)) $ textWithAlignment TextAlignment_Center (current t)+      grout (fixed (pure 1)) $ textWithAlignment TextAlignment_Right (current t)+      grout (fixed (pure 1)) $+        richText+          RichTextConfig {_richTextConfig_attributes = pure (V.withStyle V.defAttr V.bold)}+          (current t)+      grout (fixed (pure 1)) $ display (T.length <$> current t)+      grout (fixed (pure 1)) $ fill (current fillChar)+  pure (t, never)++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | The text of the @y@-th rendered row of a grid.+gridRow :: Grid -> Int -> String+gridRow g i = case drop i (rowStrings g) of+  (r : _) -> r+  [] -> ""++rowStrings :: Grid -> [String]+rowStrings = map (concatMap (T.unpack . renderSpanText)) . gridRows++-- | Pad a row string with trailing blanks to a full terminal row of the+-- given display width.+fullRow :: Int -> String -> String+fullRow w s = s ++ replicate (w - textWidth (T.pack s)) ' '
+ test/Reflex/Vty/WidgetSpec.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Vty.WidgetSpec (spec) where++import Data.List (isInfixOf, isPrefixOf)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+import Test.Hspec++import Reflex.Vty.Host+import Reflex.Vty.Test.AppHarness+import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), imageText)+import Reflex.Vty.Widget++-- | Visible text of each grid row (rows are padded to the grid width).+gridText :: Grid -> [String]+gridText g = map (T.unpack . T.concat . map renderSpanText) (gridRows g)++spec :: Spec+spec = describe "Reflex.Vty.Widget" $ do+  describe "key, keys, keyCombo, keyCombos" $ do+    it "match exact keys and modifier sets and reject mismatches" $+      withApp defaultVtyAppConfig (20, 6) keyApp $ \driver -> do+        f1 <- stepInput driver (V.EvKey (V.KChar 'a') [])+        frameObservation f1 `shouldBe` "key:a"+        map (take 5) (take 1 (gridText (frameGrid f1))) `shouldBe` ["key:a"]++        -- 'key' is modifier-less: 'a' with Shift must not produce an event.+        f2 <- stepInput driver (V.EvKey (V.KChar 'a') [V.MShift])+        frameObservation f2 `shouldBe` "key:a"+        map (take 5) (take 1 (gridText (frameGrid f2))) `shouldBe` ["key:a"]++        -- 'keys' matches each listed modifier-less key.+        f3 <- stepInput driver (V.EvKey (V.KChar 'x') [])+        frameObservation f3 `shouldBe` "keys:(KChar 'x',[])"+        f4 <- stepInput driver (V.EvKey (V.KChar 'y') [])+        frameObservation f4 `shouldBe` "keys:(KChar 'y',[])"+        f5 <- stepInput driver (V.EvKey (V.KChar 'y') [V.MMeta])+        frameObservation f5 `shouldBe` "keys:(KChar 'y',[])"++        -- 'keyCombo' requires the exact modifier set.+        f6 <- stepInput driver (V.EvKey (V.KChar 'c') [V.MShift])+        frameObservation f6 `shouldBe` "combo:shift-c"+        f7 <- stepInput driver (V.EvKey (V.KChar 'c') [])+        frameObservation f7 `shouldBe` "combo:shift-c"+        f8 <- stepInput driver (V.EvKey (V.KChar 'c') [V.MCtrl])+        frameObservation f8 `shouldBe` "combo:shift-c"++        -- 'keyCombos' matches any listed combination.+        f9 <- stepInput driver (V.EvKey (V.KChar 'd') [V.MCtrl])+        frameObservation f9 `shouldBe` "combos:(KChar 'd',[MCtrl])"+        f10 <- stepInput driver (V.EvKey V.KEnter [])+        frameObservation f10 `shouldBe` "combos:(KEnter,[])"+        f11 <- stepInput driver (V.EvKey V.KEnter [V.MShift])+        frameObservation f11 `shouldBe` "combos:(KEnter,[])"+        f12 <- stepInput driver (V.EvKey (V.KChar 'd') [])+        frameObservation f12 `shouldBe` "combos:(KEnter,[])"+        stopApp driver++  describe "filterKeys" $ do+    it "drops keys the predicate rejects and passes everything else through unchanged" $+      withApp defaultVtyAppConfig (20, 6) filterApp $ \driver -> do+        f1 <- stepInput driver (V.EvKey (V.KChar 'q') [])+        frameObservation f1 `shouldBe` ("none" :: T.Text, 0 :: Int)+        f2 <- stepInput driver (V.EvKey (V.KChar 'q') [V.MCtrl])+        frameObservation f2 `shouldBe` ("none", 0)+        -- A non-rejected key passes (with its modifiers).+        f3 <- stepInput driver (V.EvKey (V.KChar 'z') [V.MShift])+        frameObservation f3 `shouldBe` ("EvKey (KChar 'z') [MShift]", 1)+        -- Non-key events pass through unfiltered and unchanged. The+        -- root consumes EvResize itself. Paste is the non-key event a+        -- widget actually observes.+        f4 <- stepInput driver (V.EvPaste "hi")+        frameObservation f4 `shouldBe` ("EvPaste \"hi\"", 2)+        stopApp driver++  describe "gainedFocus and lostFocus" $ do+    it "extract terminal focus events from the input stream" $+      withApp defaultVtyAppConfig (20, 6) focusApp $ \driver -> do+        f1 <- stepInput driver V.EvGainedFocus+        frameObservation f1 `shouldBe` ("gained" :: T.Text)+        map (take 6) (take 1 (gridText (frameGrid f1))) `shouldBe` ["gained"]+        f2 <- stepInput driver V.EvLostFocus+        frameObservation f2 `shouldBe` "lost"+        map (take 4) (take 1 (gridText (frameGrid f2))) `shouldBe` ["lost"]+        -- Keys are not focus events.+        f3 <- stepInput driver (V.EvKey (V.KChar 'k') [])+        frameObservation f3 `shouldBe` "lost"+        stopApp driver++  describe "pane input semantics" $ do+    it "delivers keys only to the focused pane and renders each pane in its region" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> do+            let firstRows = take 1 (gridText (frameGrid f0))+            map (take 1) firstRows `shouldBe` ["L"]+            map (take 1 . drop 10) firstRows `shouldBe` ["R"]+            frameObservation f0+              `shouldBe` (("none", Nothing), ("none", Nothing))+          [] -> expectationFailure "expected an initial frame"+        f1 <- stepInput driver (V.EvKey (V.KChar 'a') [])+        frameObservation f1 `shouldBe` (("(KChar 'a',[])", Nothing), ("none", Nothing))+        stopApp driver++    it "includes the last column of a pane and hands the next column to its neighbor" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        -- The left pane's rightmost column (x = 9) is inside the left+        -- pane and outside the right one.+        f1 <- stepInput driver (V.EvMouseDown 9 2 V.BLeft [])+        frameObservation f1 `shouldBe` (("none", Just (9, 2)), ("none", Nothing))+        stopApp driver++    it "delivers a click on the neighbor pane's left edge to that neighbor" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        -- One column further (x = 10): exactly the right pane's origin,+        -- reported pane-locally as (0, 2) and invisible to the left pane.+        f1 <- stepInput driver (V.EvMouseDown 10 2 V.BLeft [])+        frameObservation f1 `shouldBe` (("none", Nothing), ("none", Just (0, 2)))+        stopApp driver++    it "drops clicks one past the region edge" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        -- One past the right pane's right edge (x = 20 of a 20-wide root).+        f1 <- stepInput driver (V.EvMouseDown 20 2 V.BLeft [])+        frameObservation f1 `shouldBe` (("none", Nothing), ("none", Nothing))+        stopApp driver++    it "reports drags that begin inside the pane and continue outside it" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        f1 <- stepInput driver (V.EvMouseDown 5 1 V.BLeft [])+        frameObservation f1 `shouldBe` (("none", Just (5, 1)), ("none", Nothing))+        -- Drag continues outside the left pane, into the right pane's area:+        -- still delivered to the tracking (left) pane, never to the right.+        f2 <- stepInput driver (V.EvMouseDown 15 1 V.BLeft [])+        frameObservation f2 `shouldBe` (("none", Just (15, 1)), ("none", Nothing))+        stopApp driver++    it "ignores drags that begin outside the pane even when they enter it" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        f1 <- stepInput driver (V.EvMouseDown 15 1 V.BLeft [])+        frameObservation f1 `shouldBe` (("none", Nothing), ("none", Just (5, 1)))+        -- Now the drag moves into the left pane. The left pane was not+        -- tracking, so it receives no input.+        f2 <- stepInput driver (V.EvMouseDown 5 1 V.BLeft [])+        frameObservation f2 `shouldBe` (("none", Nothing), ("none", Just (-5, 1)))+        stopApp driver++    it "drops buttonless mouse-up unless a drag is being tracked" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        f1 <- stepInput driver (V.EvMouseUp 5 1 Nothing)+        frameObservation f1 `shouldBe` (("none", Nothing), ("none", Nothing))+        -- After a tracked button-down, a buttonless up is delivered.+        _ <- stepInput driver (V.EvMouseDown 5 1 V.BLeft [])+        f3 <- stepInput driver (V.EvMouseUp 6 2 Nothing)+        frameObservation f3 `shouldBe` (("none", Just (6, 2)), ("none", Nothing))+        stopApp driver++    it "drops mouse-up for the wrong button and stops tracking afterwards" $+      withApp defaultVtyAppConfig (20, 6) panesApp $ \driver -> do+        _ <- stepInput driver (V.EvMouseDown 5 1 V.BLeft [])+        -- Up with the right button: not the tracked one, not delivered.+        f2 <- stepInput driver (V.EvMouseUp 7 3 (Just V.BRight))+        frameObservation f2 `shouldBe` (("none", Just (5, 1)), ("none", Nothing))+        -- Tracking has ended: even the correct button no longer produces+        -- an event.+        f3 <- stepInput driver (V.EvMouseUp 8 4 (Just V.BLeft))+        frameObservation f3 `shouldBe` (("none", Just (5, 1)), ("none", Nothing))+        stopApp driver++    it "keeps delivering keys through zero- and negative-width panes but renders nothing" $+      withApp defaultVtyAppConfig (20, 6) zeroPaneApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> do+            mapM_ (\row -> row `shouldBe` replicate 20 ' ') (gridText (frameGrid f0))+            frameObservation f0+              `shouldBe` (("none", Nothing), ("none", Nothing))+          [] -> expectationFailure "expected an initial frame"+        -- Key delivery depends on focus, not on region size.+        f1 <- stepInput driver (V.EvKey (V.KChar 'k') [])+        frameObservation f1+          `shouldBe` (("(KChar 'k',[])", Nothing), ("(KChar 'k',[])", Nothing))+        -- A click exactly on the zero-width pane's left edge is outside it.+        f2 <- stepInput driver (V.EvMouseDown 3 1 V.BLeft [])+        frameObservation f2+          `shouldBe` (("(KChar 'k',[])", Nothing), ("(KChar 'k',[])", Nothing))+        stopApp driver++  describe "pane coordinate translation" $ do+    it "agrees between translated mouse input and absolute cursor/image output" $+      withApp defaultVtyAppConfig (20, 6) cursorPaneApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> do+            -- The child image and cursor appear at the pane origin (5, 2).+            frameCursor f0 `shouldBe` V.AbsoluteCursor 5 2+            gridText (frameGrid f0) !! 2 !! 5 `shouldBe` 'X'+          [] -> expectationFailure "expected an initial frame"+        -- Clicking exactly on the rendered 'X' reports the pane-local+        -- origin, matching where the image and cursor were drawn.+        f1 <- stepInput driver (V.EvMouseDown 5 2 V.BLeft [])+        frameObservation f1 `shouldBe` (Just (0, 0) :: Maybe (Int, Int))+        f2 <- stepInput driver (V.EvMouseDown 7 3 V.BLeft [])+        frameObservation f2 `shouldBe` Just (2, 1)+        stopApp driver++    it "drops clicks entirely outside the pane when nothing is being tracked" $+      withApp defaultVtyAppConfig (20, 6) cursorPaneApp $ \driver -> do+        -- One column left of the pane, before any drag begins.+        f1 <- stepInput driver (V.EvMouseDown 4 2 V.BLeft [])+        frameObservation f1 `shouldBe` (Nothing :: Maybe (Int, Int))+        stopApp driver++  describe "withinImage" $ do+    it "crops to the region size" $+      imageText (withinImage (Region 0 0 3 2) (V.string V.defAttr "hello"))+        `shouldBe` ["hel"]++    it "clamps zero-size regions to an empty image" $+      V.imageWidth (withinImage (Region 0 0 0 5) (V.string V.defAttr "hello"))+        `shouldBe` 0++    it "treats negative sizes as zero" $+      V.imageWidth (withinImage (Region 0 0 (-1) 5) (V.string V.defAttr "hello"))+        `shouldBe` 0++    it "clips rendered output through the host, including zero and negative widths" $+      withApp defaultVtyAppConfig (20, 6) regionApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> take 1 (gridText (frameGrid f0)) `shouldBe` ["abcdefghij          "]+          [] -> expectationFailure "expected an initial frame"+        f1 <- stepCommand driver 4+        take 1 (gridText (frameGrid f1)) `shouldBe` ["abcd                "]+        f2 <- stepCommand driver 0+        take 1 (gridText (frameGrid f2)) `shouldBe` [replicate 20 ' ']+        -- Negative widths are clamped, not crashes.+        f3 <- stepCommand driver (-3)+        take 1 (gridText (frameGrid f3)) `shouldBe` [replicate 20 ' ']+        frameObservation f3 `shouldBe` ("-3" :: T.Text)+        stopApp driver++  describe "imagesInRegion and mapImages" $ do+    it "crop and translate child images into the given region" $+      withApp defaultVtyAppConfig (20, 6) clipApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> do+            let rows = gridText (frameGrid f0)+            rows !! 0 `shouldBe` replicate 20 ' '+            take 8 (rows !! 1) `shouldBe` "  abcdef"+          [] -> expectationFailure "expected an initial frame"+        f1 <- stepCommand driver 3+        take 5 (gridText (frameGrid f1) !! 1) `shouldBe` "  abc"+        f2 <- stepCommand driver 0+        gridText (frameGrid f2) !! 1 `shouldBe` replicate 20 ' '+        stopApp driver++  describe "localRegion and localLayoutRegion" $ do+    it "splits layout and viewport regions as requested" $+      withApp defaultVtyAppConfig (20, 6) layoutApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) ->+            frameObservation f0+              `shouldBe` ((Region 0 0 20 100, Region 0 0 20 6), Region 1 1 18 4)+          [] -> expectationFailure "expected an initial frame"+        stopApp driver++  describe "captureImages" $ do+    it "hides child images until re-emitted and keeps cursor and screen-mode requests" $+      withApp defaultVtyAppConfig (20, 6) captureApp $ \driver -> do+        fs0 <- driverFrames driver+        case reverse fs0 of+          (f0 : _) -> do+            frameObservation f0 `shouldBe` ("hidden" :: T.Text)+            frameCursor f0 `shouldBe` V.AbsoluteCursor 0 0+          [] -> expectationFailure "expected an initial frame"+        -- The alternate-screen request made inside the captured child+        -- must still reach the terminal.+        log0 <- driverOutputLog driver+        log0 `shouldSatisfy` any (isInfixOf "?1049h")+        -- Turning the marker on changes only the captured behavior: the+        -- marker must stay invisible, but the cursor must persist.+        f1 <- stepCommand driver 1+        frameObservation f1 `shouldBe` "shown"+        frameCursor f1 `shouldBe` V.AbsoluteCursor 0 0+        gridText (frameGrid f1) !! 0 `shouldBe` replicate 20 ' '+        -- Re-emitting draws exactly one correctly placed marker.+        f2 <- stepCommand driver 2+        frameObservation f2 `shouldBe` "reemitted"+        let rows = gridText (frameGrid f2)+        take 1 rows `shouldBe` ["MARK                "]+        concat rows `shouldSatisfy` (\s -> length (filter (== 'M') s) == 1)+        stopApp driver++------------------------------------------------------------------------------+-- Applications under test+------------------------------------------------------------------------------++-- | Records which key matcher fired last and renders the label.+keyApp :: TestApp () T.Text+keyApp _cmd = do+  aK <- key (V.KChar 'a')+  xyK <- keys [V.KChar 'x', V.KChar 'y']+  cCombo <- keyCombo (V.KChar 'c', [V.MShift])+  dCombos <-+    keyCombos (Set.fromList [(V.KChar 'd', [V.MCtrl]), (V.KEnter, [])])+  let hit =+        leftmost+          [ "key:a" <$ aK+          , (\k -> "keys:" <> T.pack (show k)) <$> xyK+          , "combo:shift-c" <$ cCombo+          , (\kc -> "combos:" <> T.pack (show kc)) <$> dCombos+          ]+  lastHit <- holdDyn "none" hit+  tellImages (fmap (\s -> [V.string V.defAttr (T.unpack s)]) (current lastHit))+  pure (lastHit, never)++-- | A child under 'filterKeys' that records every event it still receives.+filterApp :: TestApp () (T.Text, Int)+filterApp _cmd = do+  seen <- filterKeys (\(k, _ms) -> k /= V.KChar 'q') $ do+    inp <- input+    lastE <- holdDyn "none" (T.pack . show <$> inp)+    nSeen <- foldDyn (\_ c -> c + 1) (0 :: Int) inp+    pure ((,) <$> lastE <*> nSeen)+  pure (seen, never)++-- | Records terminal focus changes and renders them.+focusApp :: TestApp () T.Text+focusApp _cmd = do+  g <- gainedFocus+  l <- lostFocus+  d <- holdDyn "none" (leftmost ["gained" <$ g, "lost" <$ l])+  tellImages (fmap (\s -> [V.string V.defAttr (T.unpack s)]) (current d))+  pure (d, never)++-- | One pane child: last key, last mouse position (pane-local), and a+-- one-character marker at the pane origin.+paneChild+  :: (Reflex t, MonadHold t m, HasInput t m, HasImageWriter t m)+  => Char+  -> m (Dynamic t (T.Text, Maybe (Int, Int)))+paneChild c = do+  inp <- input+  k <- holdDyn "none" $ fforMaybe inp $ \case+    V.EvKey key' mods -> Just (T.pack (show (key', mods)))+    _ -> Nothing+  m <- holdDyn Nothing $ fforMaybe inp $ \case+    V.EvMouseDown x y _ _ -> Just (Just (x, y))+    V.EvMouseUp x y _ -> Just (Just (x, y))+    _ -> Nothing+  tellImages (pure [V.string V.defAttr [c]])+  pure ((,) <$> k <*> m)++-- | A focused left pane and an unfocused right pane, side by side.+panesApp :: TestApp () ((T.Text, Maybe (Int, Int)), (T.Text, Maybe (Int, Int)))+panesApp _cmd = do+  l <- pane (pure (Region 0 0 10 6)) (pure True) (paneChild 'L')+  r <- pane (pure (Region 10 0 10 6)) (pure False) (paneChild 'R')+  pure ((,) <$> l <*> r, never)++-- | Two focused but degenerate (zero- and negative-width) panes.+zeroPaneApp :: TestApp () ((T.Text, Maybe (Int, Int)), (T.Text, Maybe (Int, Int)))+zeroPaneApp _cmd = do+  z <- pane (pure (Region 3 1 0 2)) (pure True) (paneChild 'Z')+  n <- pane (pure (Region 3 1 (-2) 2)) (pure True) (paneChild 'N')+  pure ((,) <$> z <*> n, never)++-- | A pane whose child draws an 'X' at the pane origin and requests a+-- visible cursor there, reporting pane-local click coordinates.+cursorPaneApp :: TestApp () (Maybe (Int, Int))+cursorPaneApp _cmd = do+  m <- pane (pure (Region 5 2 10 3)) (pure True) $ do+    inp <- input+    clicks <- holdDyn Nothing $ fforMaybe inp $ \case+      V.EvMouseDown x y _ _ -> Just (Just (x, y))+      _ -> Nothing+    tellImages (pure [V.string V.defAttr "X"])+    setCursor (pure (CursorState CursorVisible CursorStyleDefault (0, 0)))+    pure clicks+  pure (m, never)++-- | Renders text clipped by 'withinImage' to a command-chosen width.+regionApp :: TestApp Int T.Text+regionApp cmd = do+  w <- holdDyn 20 cmd+  tellImages+    (fmap (\wi -> [withinImage (Region 0 0 wi 1) (V.string V.defAttr "abcdefghij")]) (current w))+  pure (T.pack . show <$> w, never)++-- | Child images cropped and translated by 'imagesInRegion' via+-- 'mapImages', with the region width driven by commands.+clipApp :: TestApp Int T.Text+clipApp cmd = do+  w <- holdDyn 6 cmd+  let reg = (\wi -> Region 2 1 wi 2) <$> w+  mapImages (imagesInRegion (current reg)) $+    tellImages (pure [V.string V.defAttr "abcdefghij"])+  pure (T.pack . show <$> w, never)++-- | Exercises 'localLayoutRegion' (layout inflated, viewport untouched)+-- and 'localRegion' (both shrink) and reports what the child observed.+layoutApp :: TestApp () ((Region, Region), Region)+layoutApp _cmd = do+  pair <- localLayoutRegion (fmap (\r -> r {_region_height = 100})) $ do+    a <- askRegion+    b <- askViewport+    pure ((,) <$> a <*> b)+  shrunk <- localRegion (fmap shrinkBy2) askRegion+  pure ((,) <$> pair <*> shrunk, never)+  where+    shrinkBy2 (Region l t w h) = Region (l + 1) (t + 1) (max 0 (w - 2)) (max 0 (h - 2))++-- | The child's images are captured: a marker drawn by the child only+-- appears once the parent re-emits the captured behavior. The child's+-- cursor and alternate-screen requests bypass the capture.+captureApp :: TestApp Int T.Text+captureApp cmd = do+  ((), captured) <- captureImages $ do+    markOn <- holdDyn False ((== (1 :: Int)) <$> cmd)+    tellImages (fmap (\b -> [V.string V.defAttr "MARK" | b]) (current markOn))+    setCursor (pure (CursorState CursorVisible CursorStyleDefault (0, 0)))+    enterAlternateScreen+  let again = ffilter (== (2 :: Int)) cmd+  reemit <- holdDyn [] (tag captured again)+  tellImages (current reemit)+  obs <-+    holdDyn+      "hidden"+      (leftmost ["shown" <$ ffilter (== (1 :: Int)) cmd, "reemitted" <$ again])+  pure (obs, never)
test/Spec.hs view
@@ -1,15 +1,92 @@--- hspec auto-discovery stuff--- does not work with current CircleCI image so instead we do it manually for now--- {-# OPTIONS_GHC -F -pgmF hspec-discover #-}-+-- Manual spec registration: this suite does not use hspec-discover+-- (see CONTRIBUTING.md). Register each new *Spec.hs module here and+-- in the test suite's other-modules in reflex-vty.cabal. +import System.Environment (lookupEnv) import Test.Hspec +import qualified Control.Monad.NodeIdSpec import qualified Data.Text.ZipperSpec+import qualified Reflex.Vty.CanvasSpec+import qualified Reflex.Vty.ColorProfileSpec+import qualified Reflex.Vty.ColorSpec+import qualified Reflex.Vty.CompositionSpec+import qualified Reflex.Vty.Host.SignalSpec+import qualified Reflex.Vty.Host.TriggerSpec+import qualified Reflex.Vty.HostSpec+import qualified Reflex.Vty.StyleJoinSpec+import qualified Reflex.Vty.StyleSpec+import qualified Reflex.Vty.Test.GoldenPolicySpec+import qualified Reflex.Vty.Test.GoldenSpec+import Reflex.Vty.Test.Snapshot (GoldenMode (..))+import qualified Reflex.Vty.Test.SnapshotSpec+import qualified Reflex.Vty.ThemeSpec+import qualified Reflex.Vty.Widget.BoxSpec+import qualified Reflex.Vty.Widget.CursorSpec+import qualified Reflex.Vty.Widget.Input.TextSpec+import qualified Reflex.Vty.Widget.InputSpec+import qualified Reflex.Vty.Widget.LayoutSpec+import qualified Reflex.Vty.Widget.MouseSpec+import qualified Reflex.Vty.Widget.ScrollSpec+import qualified Reflex.Vty.Widget.SplitSpec+import qualified Reflex.Vty.Widget.TextSpec+import qualified Reflex.Vty.WidgetSpec  main :: IO ()-main = hspec spec+main = do+  childMode <- lookupEnv "REFLEX_VTY_SIGNAL_CHILD"+  case childMode of+    -- Isolated signal-child processes run their scenario and exit+    -- before Hspec starts.+    Just _mode -> Reflex.Vty.Host.SignalSpec.runSignalChild+    Nothing -> do+      goldenMode <- goldenModeFromEnv+      hspec (spec goldenMode) -spec :: Spec-spec = do-  describe "Data.Text.ZipperSpec"     Data.Text.ZipperSpec.spec+-- | Read REFLEX_VTY_GOLDEN_UPDATE once at startup. An absent value or+-- @0@ selects checking. @1@ selects updating and is forbidden when+-- @CI=true@. Any other value is a configuration error.+goldenModeFromEnv :: IO GoldenMode+goldenModeFromEnv = do+  value <- lookupEnv "REFLEX_VTY_GOLDEN_UPDATE"+  ci <- lookupEnv "CI"+  case value of+    Nothing -> pure CheckGoldens+    Just "0" -> pure CheckGoldens+    Just "1"+      | ci == Just "true" ->+          errorWithoutStackTrace "REFLEX_VTY_GOLDEN_UPDATE=1 is not allowed when CI=true"+      | otherwise -> pure UpdateGoldens+    Just other ->+      errorWithoutStackTrace $+        "invalid REFLEX_VTY_GOLDEN_UPDATE value "+          ++ show other+          ++ ": expected it to be absent, 0, or 1"++spec :: GoldenMode -> Spec+spec goldenMode = do+  describe "Control.Monad.NodeIdSpec" Control.Monad.NodeIdSpec.spec+  describe "Data.Text.ZipperSpec" Data.Text.ZipperSpec.spec+  describe "Reflex.Vty.CanvasSpec" Reflex.Vty.CanvasSpec.spec+  describe "Reflex.Vty.ColorProfileSpec" Reflex.Vty.ColorProfileSpec.spec+  describe "Reflex.Vty.ColorSpec" Reflex.Vty.ColorSpec.spec+  describe "Reflex.Vty.Host.TriggerSpec" Reflex.Vty.Host.TriggerSpec.spec+  describe "Reflex.Vty.HostSpec" Reflex.Vty.HostSpec.spec+  describe "Reflex.Vty.StyleSpec" Reflex.Vty.StyleSpec.spec+  describe "Reflex.Vty.StyleJoinSpec" Reflex.Vty.StyleJoinSpec.spec+  describe "Reflex.Vty.Test.GoldenPolicySpec" Reflex.Vty.Test.GoldenPolicySpec.spec+  describe "Reflex.Vty.Test.SnapshotSpec" Reflex.Vty.Test.SnapshotSpec.spec+  describe "Reflex.Vty.Widget.BoxSpec" Reflex.Vty.Widget.BoxSpec.spec+  describe "Reflex.Vty.Widget.CursorSpec" Reflex.Vty.Widget.CursorSpec.spec+  describe "Reflex.Vty.Widget.LayoutSpec" Reflex.Vty.Widget.LayoutSpec.spec+  describe "Reflex.Vty.WidgetSpec" Reflex.Vty.WidgetSpec.spec+  describe "Reflex.Vty.Widget.InputSpec" Reflex.Vty.Widget.InputSpec.spec+  describe "Reflex.Vty.Widget.Input.TextSpec" Reflex.Vty.Widget.Input.TextSpec.spec+  describe "Reflex.Vty.Widget.TextSpec" Reflex.Vty.Widget.TextSpec.spec+  describe "Reflex.Vty.Widget.SplitSpec" Reflex.Vty.Widget.SplitSpec.spec+  describe "Reflex.Vty.ThemeSpec" Reflex.Vty.ThemeSpec.spec+  describe "Reflex.Vty.CompositionSpec" Reflex.Vty.CompositionSpec.spec+  describe "Reflex.Vty.Widget.MouseSpec" Reflex.Vty.Widget.MouseSpec.spec+  describe "Reflex.Vty.Widget.ScrollSpec" Reflex.Vty.Widget.ScrollSpec.spec+  describe "Reflex.Vty.Host.SignalSpec" Reflex.Vty.Host.SignalSpec.spec+  describe "Reflex.Vty.Test.GoldenSpec" (Reflex.Vty.Test.GoldenSpec.spec goldenMode)
+ test/coverage-baseline.tsv view
@@ -0,0 +1,21 @@+# reflex-vty coverage baseline	schema=1	ghc=9.12.3	opt=0+internal	Reflex.Vty.Host.Signal	52	59	0	0	1	2+internal	Reflex.Vty.Host.Trigger	126	224	0	0	2	2+main	Control.Monad.NodeId	41	74	0	0	0	0+main	Data.Text.Zipper	933	1010	23	30	86	99+main	Reflex.Vty	0	0	0	0	0	0+main	Reflex.Vty.Canvas	629	687	15	24	43	49+main	Reflex.Vty.Color	156	177	4	8	10	14+main	Reflex.Vty.ColorProfile	185	215	0	0	17	22+main	Reflex.Vty.Host	299	348	3	3	19	31+main	Reflex.Vty.Style	1306	1648	8	34	66	96+main	Reflex.Vty.Theme	40	300	0	0	0	0+main	Reflex.Vty.Widget	856	1380	7	13	34	46+main	Reflex.Vty.Widget.Box	277	305	2	3	7	7+main	Reflex.Vty.Widget.Input	157	169	3	3	6	8+main	Reflex.Vty.Widget.Input.Mouse	157	193	4	11	16	23+main	Reflex.Vty.Widget.Input.Text	298	305	4	5	30	31+main	Reflex.Vty.Widget.Layout	632	738	0	1	17	20+main	Reflex.Vty.Widget.Scroll	266	365	6	9	24	36+main	Reflex.Vty.Widget.Split	247	256	1	1	4	4+main	Reflex.Vty.Widget.Text	95	120	0	0	0	0
+ test/goldens/align_center.txt view
@@ -0,0 +1,4 @@+20x1+"       Center       "+--- spans ---+0:0+20 text="       Center       " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/align_left.txt view
@@ -0,0 +1,4 @@+20x1+"Left                "+--- spans ---+0:0+20 text="Left                " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/align_right.txt view
@@ -0,0 +1,4 @@+20x1+"               Right"+--- spans ---+0:0+20 text="               Right" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/border_ascii.txt view
@@ -0,0 +1,8 @@+5x3+"+---+"+"|Box|"+"+---+"+--- spans ---+0:0+5 text="+---+" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text="|Box|" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+5 text="+---+" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/border_double.txt view
@@ -0,0 +1,8 @@+5x3+"\9556\9552\9552\9552\9559"+"\9553Box\9553"+"\9562\9552\9552\9552\9565"+--- spans ---+0:0+5 text="\9556\9552\9552\9552\9559" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text="\9553Box\9553" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+5 text="\9562\9552\9552\9552\9565" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/border_rounded.txt view
@@ -0,0 +1,8 @@+5x3+"\9581\9472\9472\9472\9582"+"\9474Box\9474"+"\9584\9472\9472\9472\9583"+--- spans ---+0:0+5 text="\9581\9472\9472\9472\9582" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text="\9474Box\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+5 text="\9584\9472\9472\9472\9583" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/border_single.txt view
@@ -0,0 +1,8 @@+5x3+"\9484\9472\9472\9472\9488"+"\9474Box\9474"+"\9492\9472\9472\9472\9496"+--- spans ---+0:0+5 text="\9484\9472\9472\9472\9488" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text="\9474Box\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+5 text="\9492\9472\9472\9472\9496" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/border_thick.txt view
@@ -0,0 +1,8 @@+5x3+"\9487\9473\9473\9473\9491"+"\9475Box\9475"+"\9495\9473\9473\9473\9499"+--- spans ---+0:0+5 text="\9487\9473\9473\9473\9491" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text="\9475Box\9475" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+5 text="\9495\9473\9473\9473\9499" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/color_blue_bg.txt view
@@ -0,0 +1,4 @@+4x1+"Blue"+--- spans ---+0:0+4 text="Blue" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Just (ISOColor 4), fixedURL = Nothing}
+ test/goldens/color_red_fg.txt view
@@ -0,0 +1,4 @@+3x1+"Red"+--- spans ---+0:0+3 text="Red" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 1), fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/color_rgb.txt view
@@ -0,0 +1,4 @@+3x1+"RGB"+--- spans ---+0:0+3 text="RGB" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (RGBColor 147 32 8), fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/combined.txt view
@@ -0,0 +1,18 @@+14x5+"\9581\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9582"+"\9474            \9474"+"\9474  Combined  \9474"+"\9474            \9474"+"\9584\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9583"+--- spans ---+0:0+14 text="\9581\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9582" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+1:0+1 text="\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+1:1+12 text="            " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 10), fixedBackColor = Nothing, fixedURL = Nothing}+1:13+1 text="\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+2:0+1 text="\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+2:1+12 text="  Combined  " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 10), fixedBackColor = Nothing, fixedURL = Nothing}+2:13+1 text="\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+3:0+1 text="\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+3:1+12 text="            " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 10), fixedBackColor = Nothing, fixedURL = Nothing}+3:13+1 text="\9474" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}+4:0+14 text="\9584\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9583" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Just (ISOColor 13), fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/margin_1.txt view
@@ -0,0 +1,8 @@+3x3+"   "+" m "+"   "+--- spans ---+0:0+3 text="   " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+3 text=" m " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+3 text="   " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/multiline.txt view
@@ -0,0 +1,6 @@+5x2+"Hello"+"World"+--- spans ---+0:0+5 text="Hello" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text="World" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/padding_1.txt view
@@ -0,0 +1,8 @@+5x3+"     "+" pad "+"     "+--- spans ---+0:0+5 text="     " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+5 text=" pad " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+5 text="     " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/padding_2.txt view
@@ -0,0 +1,12 @@+7x5+"       "+"       "+"  pad  "+"       "+"       "+--- spans ---+0:0+7 text="       " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+1:0+7 text="       " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+2:0+7 text="  pad  " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+3:0+7 text="       " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}+4:0+7 text="       " attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/plain.txt view
@@ -0,0 +1,4 @@+5x1+"hello"+--- spans ---+0:0+5 text="hello" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/transform_bold.txt view
@@ -0,0 +1,4 @@+4x1+"Bold"+--- spans ---+0:0+4 text="Bold" attr=FixedAttr {fixedStyle = 32, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/transform_italic.txt view
@@ -0,0 +1,4 @@+6x1+"Italic"+--- spans ---+0:0+6 text="Italic" attr=FixedAttr {fixedStyle = 64, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/transform_reverse.txt view
@@ -0,0 +1,4 @@+3x1+"Rev"+--- spans ---+0:0+3 text="Rev" attr=FixedAttr {fixedStyle = 4, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/transform_underline.txt view
@@ -0,0 +1,4 @@+2x1+"UL"+--- spans ---+0:0+2 text="UL" attr=FixedAttr {fixedStyle = 2, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/goldens/wide_chars.txt view
@@ -0,0 +1,4 @@+4x1+"a\25991b"+--- spans ---+0:0+4 text="a\25991b" attr=FixedAttr {fixedStyle = 0, fixedForeColor = Nothing, fixedBackColor = Nothing, fixedURL = Nothing}
+ test/pty/Main.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Main+-- Description: PTY test driver for the 'mainWidget' entry point.+--+-- This executable runs @mainWidget@ applications in a PTY.+-- @test/pty_smoke.py@ controls the PTY.+-- The driver uses the real Vty instead of the test recorder.+-- It sends results and readiness messages through an inherited file descriptor.+-- @REFLEX_VTY_TEST_CONTROL_FD@ specifies this descriptor.+-- The driver does not display these messages in the UI.+--+-- Newline-delimited control protocol:+--+-- > READY+-- > VALUE <Haskell-show String>+-- > VIEWPORT <width> <height>+-- > SCROLL <first-visible-line> <visible-line-count>+-- > EXIT+--+-- Supported modes: @echo@, @pager@, @postbuild-exit@, @throw-after-start@.+module Main (main) where++import Control.Exception (ErrorCall (..), throwIO)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Default (def)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Reflex+  ( Behavior+  , Event+  , MonadSample (..)+  , PerformEvent+  , Performable+  , PostBuild+  , current+  , ffor+  , getPostBuild+  , leftmost+  , never+  , performEvent+  , performEvent_+  , sample+  , updated+  , zipDyn+  )+import System.Environment (getArgs, lookupEnv)+import System.Exit (exitFailure)+import System.IO (Handle, hFlush, hPutStrLn, hSetEncoding, stderr, utf8)+import System.Posix.IO (fdToHandle)+import System.Posix.Types (Fd (..))+import Text.Read (readMaybe)++import Reflex.Vty+  ( HasColorProfile+  , HasCursor+  , HasDisplayRegion (..)+  , HasFocusReader+  , HasImageWriter+  , HasInput+  , HasScreenMode+  , HasTheme+  , MonadVtyApp+  , ScrollPos (..)+  , Scrollable (..)+  , ctrlc+  , displayHeight+  , displayWidth+  , key+  , mainWidget+  , mouseScroll+  , scrollable+  , text+  , textInput+  , _scrollable_scrollPosition+  , _textInput_value+  )++-- | The total line count of the pager content.+-- Lines are short enough to prevent wrapping at all tested terminal widths.+-- The Python driver uses the same total line count.+pagerTotalLines :: Int+pagerTotalLines = 40++main :: IO ()+main = do+  mode <-+    getArgs >>= \case+      [m] | m `elem` modes -> pure m+      _ -> do+        hPutStrLn+          stderr+          ( "usage: reflex-vty-test-driver <mode>  (modes: "+              ++ unwords modes+              ++ "); control fd taken from REFLEX_VTY_TEST_CONTROL_FD"+          )+        exitFailure+  ctl <- openControlFd+  mainWidget def (driverWidget ctl mode)+  where+    modes = ["echo", "pager", "postbuild-exit", "throw-after-start"]++-- | Convert the inherited control file descriptor to a 'Handle'.+openControlFd :: IO Handle+openControlFd = do+  mf <- lookupEnv "REFLEX_VTY_TEST_CONTROL_FD"+  fd <- case mf >>= readMaybe of+    Nothing -> failWithoutFd+    Just fd -> pure (Fd fd)+  h <- fdToHandle fd+  hSetEncoding h utf8+  pure h+  where+    failWithoutFd = do+      hPutStrLn stderr "REFLEX_VTY_TEST_CONTROL_FD must name an inherited file descriptor"+      exitFailure++-- | Write one protocol line to the control channel and flush it.+ctlLine :: Handle -> String -> IO ()+ctlLine h msg = do+  hPutStrLn h msg+  hFlush h++-- | The widget run by 'mainWidget'. Reports READY and the root viewport on+-- the control channel, delegates mode-specific behaviour, and reports EXIT+-- on whichever shutdown event the mode produces.+driverWidget+  :: forall t m+   . ( MonadVtyApp t m+     , MonadIO m+     , HasImageWriter t m+     , HasDisplayRegion t m+     , HasFocusReader t m+     , HasInput t m+     , HasTheme t m+     , HasColorProfile t m+     , HasCursor t m+     , HasScreenMode t m+     )+  => Handle+  -> String+  -> m (Event t ())+driverWidget ctl mode = do+  pb <- getPostBuild+  ready <- performEvent $ ffor pb $ \_ -> liftIO (ctlLine ctl "READY")++  size <- zipDyn <$> displayWidth <*> displayHeight+  performEvent_ $ ffor (leftmost [() <$ updated size, pb]) $ \_ -> do+    (w, h') <- sample (current size)+    liftIO (ctlLine ctl ("VIEWPORT " ++ show w ++ " " ++ show h'))++  shutdown <- case mode of+    "echo" -> echoMode ctl+    "pager" -> pagerMode ctl pb+    "postbuild-exit" -> pure pb+    _ -> throwAfterStartMode ready++  performEvent_ $ ffor shutdown $ \_ -> liftIO (ctlLine ctl "EXIT")+  pure shutdown++-- | Report each change in the text input value as @VALUE <Haskell-show String>@.+-- Ctrl-C stops the widget.+echoMode+  :: forall t m+   . ( MonadVtyApp t m+     , MonadIO m+     , HasImageWriter t m+     , HasDisplayRegion t m+     , HasFocusReader t m+     , HasInput t m+     , HasTheme t m+     )+  => Handle+  -> m (Event t ())+echoMode ctl = do+  ti <- textInput def+  performEvent_ $ ffor (updated (_textInput_value ti)) $ \t ->+    liftIO (ctlLine ctl ("VALUE " ++ show (T.unpack t)))+  quit <- ctrlc+  pure (void quit)++-- | A scrollable text widget.+-- Arrow keys, mouse wheel events, and viewport changes produce @SCROLL <first-visible-line> <visible-line-count>@ reports.+-- Ctrl-C stops the widget.+pagerMode+  :: forall t m+   . ( MonadVtyApp t m+     , MonadIO m+     , HasImageWriter t m+     , HasDisplayRegion t m+     , HasFocusReader t m+     , HasInput t m+     , HasTheme t m+     )+  => Handle+  -> Event t ()+  -> m (Event t ())+pagerMode ctl pb = do+  let content :: T.Text+      content = T.intercalate "\n" (T.pack . pad3 <$> [1 .. pagerTotalLines])+      pad3 :: Int -> String+      pad3 n = let s = show n in replicate (3 - length s) '0' ++ s++  sc <- fmap fst $+    scrollable def $ do+      text (pure content)+      pure (never, ())++  kup <- key V.KUp+  kdown <- key V.KDown+  wheel <- mouseScroll+  dh <- displayHeight+  let reportTriggers :: Event t ()+      reportTriggers =+        leftmost+          [ void kup+          , void kdown+          , void wheel+          , pb+          , () <$ updated dh+          ]+      scrollPos :: Behavior t ScrollPos+      scrollPos = _scrollable_scrollPosition sc+      viewportHeight' :: Behavior t Int+      viewportHeight' = current dh++  performEvent_ $ ffor reportTriggers $ \_ -> do+    pos <- sample scrollPos+    h' <- sample viewportHeight'+    liftIO $+      ctlLine ctl $+        "SCROLL "+          ++ show (firstVisibleLine pos pagerTotalLines h')+          ++ " "+          ++ show (min pagerTotalLines h')+  quit <- ctrlc+  pure (void quit)++-- | Calculate the first visible line from the scroll position, total line count, and viewport height.+firstVisibleLine :: ScrollPos -> Int -> Int -> Int+firstVisibleLine pos total h = case pos of+  ScrollPos_Top -> 0+  ScrollPos_Line n -> n+  ScrollPos_Bottom -> max 0 (total - h)++-- | Raise an exception after the driver sends READY.+-- The host must restore the terminal and stop with a nonzero exit code.+throwAfterStartMode :: forall t m. (PostBuild t m, PerformEvent t m, MonadIO (Performable m)) => Event t () -> m (Event t ())+throwAfterStartMode pb = do+  performEvent_ $ ffor pb $ \_ ->+    liftIO $ throwIO (ErrorCall "reflex-vty-test-driver: requested failure (throw-after-start)")+  pure never
+ test/pty_smoke.py view
@@ -0,0 +1,448 @@+#!/usr/bin/env python3+"""PTY tests for reflex-vty-test-driver.++This script uses only the Python standard library.+It runs the driver from argument 1 in a new PTY.+Each process has separate HOME and XDG_CONFIG_HOME directories.+REFLEX_VTY_TEST_CONTROL_FD specifies the control file descriptor.+Each control message ends with a newline.+The tests check typed and pasted Unicode text, rendered output, and resize reports.+They also check pager scrolling with arrow keys and SGR wheel events.+Exit checks cover normal shutdown, signals, exceptions, and post-build shutdown.+The tests check termios restoration and terminal cleanup sequences.+Each process has a time limit. The script waits for child termination after failures.+"""++import fcntl+import os+import pty+import selectors+import shutil+import signal+import struct+import subprocess+import sys+import tempfile+import termios+import time++READ_TIMEOUT = 15.0  # Maximum seconds for each condition.+REAP_TIMEOUT = 10.0  # Maximum seconds for child termination.++INIT_SIZE = (24, 80)  # (rows, cols)+RESIZE_SIZE = (12, 40)++CLEANUP_CURSOR_SHOW = rb"\x1b\[\?25h"+# Cleanup must disable a mouse, paste, or alternate-screen mode.+# A cursor-show sequence alone is insufficient. Vty sends ?25l at startup.+CLEANUP_MODE_DISABLE = rb"\x1b\[\?(1000|1002|1003|1006|2004|1049)l"++ECHO_TYPED = "he\u0301"      # typed: h, e, U+0301 (combining acute)+ECHO_PASTED = "ab界e\u0301"  # paste includes both wide and combining characters+ECHO_FULL = ECHO_TYPED + ECHO_PASTED+++def hs_show(s):+    """Convert a Python string to the GHC `show` format for Haskell String.++    The format matches GHC 9.12.3. Printable ASCII characters do not change.+    Control characters use named escape sequences.+    Other code points use decimal escape sequences.+    A decimal escape has a "\\&" suffix if the next character is a decimal digit.+    """+    named = {+        "\\": "\\\\",+        '"': '\\"',+        "\a": "\\a",+        "\b": "\\b",+        "\f": "\\f",+        "\n": "\\n",+        "\r": "\\r",+        "\t": "\\t",+        "\v": "\\v",+    }+    out = ['"']+    after_numeric = False+    for ch in s:+        if after_numeric and ch.isdigit():+            out.append("\\&")+        after_numeric = False+        if ch in named:+            out.append(named[ch])+        elif 32 <= ord(ch) <= 126:+            out.append(ch)+        else:+            out.append("\\%d" % ord(ch))+            after_numeric = True+    out.append('"')+    return "".join(out)+++class Session:+    """One driver process in a new PTY with a time limit."""++    def __init__(self, binary, mode):+        self.home = tempfile.mkdtemp(prefix="reflex-vty-pty-")+        self.dir_home = os.path.join(self.home, "home")+        self.dir_xdg = os.path.join(self.home, "xdg")+        os.mkdir(self.dir_home)+        os.mkdir(self.dir_xdg)++        self.master, self.slave = pty.openpty()+        self.set_winsize(INIT_SIZE)++        # Save the initial attributes of the slave terminal.+        self.termios_before = termios.tcgetattr(self.slave)++        ctrl_r, ctrl_w = os.pipe()+        env = dict(os.environ)+        env.update(+            {+                "HOME": self.dir_home,+                "XDG_CONFIG_HOME": self.dir_xdg,+                "TERM": "xterm-256color",+                "LANG": "C.UTF-8",+                "LC_ALL": "C.UTF-8",+                "REFLEX_VTY_TEST_CONTROL_FD": str(ctrl_w),+            }+        )+        self.proc = subprocess.Popen(+            [binary, mode],+            stdin=self.slave,+            stdout=self.slave,+            stderr=self.slave,+            env=env,+            pass_fds=(ctrl_w,),+            start_new_session=True,+            close_fds=True,+        )+        os.close(ctrl_w)+        self.ctrl_r = ctrl_r++        self.output = b""+        self.control_buf = b""+        self.lines = []+        self.selector = selectors.DefaultSelector()+        self.selector.register(self.master, selectors.EVENT_READ, "pty")+        self.selector.register(self.ctrl_r, selectors.EVENT_READ, "ctrl")++    # -- terminal input and output ----------------------------------------++    def set_winsize(self, rows_cols):+        rows, cols = rows_cols+        winsize = struct.pack("HHHH", rows, cols, 0, 0)+        for fd in (self.slave, self.master):+            fcntl.ioctl(fd, termios.TIOCSWINSZ, winsize)++    def send(self, data):+        """Deliver input bytes to the child's terminal."""+        os.write(self.master, data)++    def sendline(self, data=b""):+        self.send(data + b"\r")++    def drain_once(self, timeout):+        for key, _ in self.selector.select(timeout):+            fd = key.fd+            try:+                chunk = os.read(fd, 65536)+            except OSError:+                chunk = b""+            if not chunk:+                self.selector.unregister(fd)+                continue+            if key.data == "pty":+                self.output += chunk+            else:+                self.control_buf += chunk+                while b"\n" in self.control_buf:+                    line, self.control_buf = self.control_buf.split(b"\n", 1)+                    self.lines.append(line.decode("utf-8", "replace"))++    def drain_available(self):+        """Read the remaining buffered bytes after the writer stops."""+        while self.selector.select(0):+            self.drain_once(0)++    def wait_for(self, pred, what, timeout=READ_TIMEOUT):+        """Read both channels until pred() is true or the time limit expires."""+        deadline = time.monotonic() + timeout+        while not pred():+            if self.proc.poll() is not None:+                # Read the remaining bytes from both channels before reporting failure.+                self.drain_available()+                if pred():+                    return+                self.fail(what + " (process exited with %r)" % self.returncode())+            remaining = deadline - time.monotonic()+            if remaining <= 0:+                self.fail(what)+            self.drain_once(min(remaining, 0.05))++    def wait_for_line(self, prefix, timeout=READ_TIMEOUT):+        self.wait_for(+            lambda: any(line.startswith(prefix) for line in self.lines),+            "timed out waiting for control line %r" % prefix,+            timeout,+        )+        return next(line for line in self.lines if line.startswith(prefix))++    def last_value(self):+        values = [line[len("VALUE ") :] for line in self.lines if line.startswith("VALUE ")]+        return values[-1] if values else None++    def returncode(self):+        return self.proc.returncode++    def fail(self, what):+        reap(self.proc)+        raise AssertionError(+            "%s\n-- control lines --\n%s\n-- pty output --\n%s"+            % (what, "\n".join(self.lines) or "(none)", self.output.decode("utf-8", "replace"))+        )++    # -- lifecycle --------------------------------------------------------++    def shutdown(self, expect_code=0):+        """Drain output while waiting so a full PTY cannot block shutdown."""+        deadline = time.monotonic() + REAP_TIMEOUT+        while self.proc.poll() is None:+            remaining = deadline - time.monotonic()+            if remaining <= 0:+                self.proc.kill()+                self.proc.wait(timeout=REAP_TIMEOUT)+                self.fail("shutdown timed out after %ss" % REAP_TIMEOUT)+            self.drain_once(min(remaining, 0.05))+        code = self.proc.returncode+        self.drain_available()+        if expect_code is not None and code != expect_code:+            self.fail("exit code %r, expected %r" % (code, expect_code))+        return code++    def close(self):+        if self.proc.returncode is None:+            reap_after_kill(self.proc)+        try:+            self.selector.close()+        except Exception:+            pass+        for fd in (self.master, self.slave, self.ctrl_r):+            try:+                os.close(fd)+            except OSError:+                pass+        shutil.rmtree(self.home, ignore_errors=True)++    def assert_termios_restored(self, context):+        now = termios.tcgetattr(self.slave)+        before = self.termios_before.copy()+        if sys.platform == "darwin":+            # XNU sets PENDIN when tcsetattr restores ICANON. It records+            # pending input reprocessing, not an application terminal mode.+            # Compare every configurable flag, speed, and control character.+            before[3] &= ~termios.PENDIN+            now[3] &= ~termios.PENDIN+        if now != before:+            raise AssertionError(+                "%s: termios not restored\nbefore=%r\nafter=%r"+                % (context, self.termios_before, now)+            )++    def assert_cleanup_escapes(self, context):+        import re++        if not re.search(CLEANUP_CURSOR_SHOW, self.output):+            raise AssertionError(+                "%s: cursor not re-shown on cleanup\n%s"+                % (context, self.output.decode("utf-8", "replace"))+            )+        if not re.search(CLEANUP_MODE_DISABLE, self.output):+            raise AssertionError(+                "%s: no terminal-mode disable escape in output\n%s"+                % (context, self.output.decode("utf-8", "replace"))+            )+++def reap(proc, expect_code=None):+    """Wait for child termination. Send SIGKILL if the time limit expires."""+    try:+        code = proc.wait(timeout=REAP_TIMEOUT)+    except subprocess.TimeoutExpired:+        proc.kill()+        code = proc.wait(timeout=REAP_TIMEOUT)+        if expect_code is not None:+            raise AssertionError(+                "had to SIGKILL after %ss; exit code %r, expected %r"+                % (REAP_TIMEOUT, code, expect_code)+            )+    if expect_code is not None and code != expect_code:+        raise AssertionError("exit code %r, expected %r" % (code, expect_code))+    return code+++def reap_after_kill(proc):+    try:+        reap(proc)+    except Exception:+        proc.kill()+        proc.wait(timeout=REAP_TIMEOUT)+        raise+++# -- tests ----------------------------------------------------------------+++def test_echo_and_resize(driver_bin):+    """Check typed text, pasted text, rendered output, and terminal resize."""+    s = Session(driver_bin, "echo")+    try:+        s.wait_for_line("READY")+        s.wait_for_line("VIEWPORT 80 24")++        # Resize the terminal. The root viewport must report the new size.+        s.set_winsize(RESIZE_SIZE)+        os.kill(s.proc.pid, signal.SIGWINCH)+        s.wait_for_line("VIEWPORT 40 12")++        # Type the base character before its combining character.+        s.send(ECHO_TYPED.encode("utf-8"))+        s.wait_for(+            lambda: s.last_value() == hs_show(ECHO_TYPED),+            "typed value not reported as %s" % hs_show(ECHO_TYPED),+        )++        # Add pasted text with a wide character after the typed text.+        s.send(b"\x1b[200~" + ECHO_PASTED.encode("utf-8") + b"\x1b[201~")+        s.wait_for(+            lambda: s.last_value() == hs_show(ECHO_FULL),+            "pasted value not reported as %s" % hs_show(ECHO_FULL),+        )++        # The terminal output must contain the typed and pasted text in UTF-8.+        # This includes the base character and its combining character.+        s.wait_for(+            lambda: ECHO_FULL.encode("utf-8") in s.output,+            "terminal did not render typed and pasted Unicode text",+        )++        s.send(b"\x03")  # Ctrl-C stops the echo widget.+        s.wait_for_line("EXIT")+        s.shutdown(expect_code=0)+        s.assert_termios_restored("echo normal exit")+        s.assert_cleanup_escapes("echo normal exit")+    finally:+        reap_after_kill(s.proc)+        s.close()+++def test_pager(driver_bin):+    """Arrow keys and SGR wheel events change the reported visible range."""+    s = Session(driver_bin, "pager")+    try:+        s.wait_for_line("READY")+        if s.wait_for_line("SCROLL") != "SCROLL 0 24":+            raise AssertionError("initial scroll %r" % [l for l in s.lines if l.startswith("SCROLL")])++        s.send(b"\x1b[B")  # down arrow+        s.wait_for_line("SCROLL 1 ")+        s.send(b"\x1b[<65;10;10M")  # SGR wheel down+        s.wait_for_line("SCROLL 2 ")+        s.send(b"\x1b[<64;10;10M")  # SGR wheel up+        scroll_lines = lambda: [l for l in s.lines if l.startswith("SCROLL")]+        s.wait_for(+            lambda: len(scroll_lines()) >= 4 and scroll_lines()[-1] == "SCROLL 1 24",+            "wheel-up did not return to SCROLL 1 (lines: %r)" % scroll_lines(),+        )++        s.send(b"\x03")+        s.wait_for_line("EXIT")+        s.shutdown(expect_code=0)+        s.assert_termios_restored("pager normal exit")+        s.assert_cleanup_escapes("pager normal exit")+    finally:+        reap_after_kill(s.proc)+        s.close()+++def test_sigterm(driver_bin):+    """The host restores termios and sends terminal cleanup sequences after SIGTERM."""+    s = Session(driver_bin, "echo")+    try:+        s.wait_for_line("READY")+        os.kill(s.proc.pid, signal.SIGTERM)+        code = s.shutdown(expect_code=0)+        s.assert_termios_restored("SIGTERM exit (code %r)" % code)+        s.assert_cleanup_escapes("SIGTERM exit")+    finally:+        reap_after_kill(s.proc)+        s.close()+++def test_postbuild_exit(driver_bin):+    """The host stops after post-build without input."""+    s = Session(driver_bin, "postbuild-exit")+    try:+        s.wait_for_line("READY")+        s.wait_for_line("EXIT")+        s.shutdown(expect_code=0)+        s.assert_termios_restored("postbuild-exit")+        if not s.lines:+            raise AssertionError("no control lines for postbuild-exit")+    finally:+        reap_after_kill(s.proc)+        s.close()+++def test_throw_after_start(driver_bin):+    """The host restores the terminal and returns a nonzero exit code after an exception."""+    s = Session(driver_bin, "throw-after-start")+    try:+        s.wait_for_line("READY")+        deadline = time.monotonic() + READ_TIMEOUT+        while s.proc.poll() is None:+            s.drain_once(min(deadline - time.monotonic(), 0.05))+            if time.monotonic() > deadline:+                s.fail("throw-after-start did not terminate")+        code = s.shutdown(expect_code=None)+        if code == 0:+            raise AssertionError("throw-after-start exited 0")+        s.assert_termios_restored("throw-after-start (code %r)" % code)+        s.assert_cleanup_escapes("throw-after-start")+    finally:+        reap_after_kill(s.proc)+        s.close()+++def main():+    if len(sys.argv) != 2:+        print("usage: pty_smoke.py <absolute-path-to-reflex-vty-test-driver>", file=sys.stderr)+        return 2+    driver_bin = os.path.abspath(sys.argv[1])+    if not (os.path.isfile(driver_bin) and os.access(driver_bin, os.X_OK)):+        print("not an executable: %s" % driver_bin, file=sys.stderr)+        return 2++    tests = [+        ("echo+resize+paste", test_echo_and_resize),+        ("pager", test_pager),+        ("sigterm", test_sigterm),+        ("postbuild-exit", test_postbuild_exit),+        ("throw-after-start", test_throw_after_start),+    ]+    failures = 0+    for name, fn in tests:+        try:+            fn(driver_bin)+            print("PASS %s" % name)+        except Exception as exc:+            failures += 1+            print("FAIL %s: %s" % (name, exc))+    if failures:+        print("%d of %d PTY smoke tests failed" % (failures, len(tests)))+        return 1+    print("all %d PTY smoke tests passed" % len(tests))+    return 0+++if __name__ == "__main__":+    sys.exit(main())