reflex-vty 1.2.0.0 → 1.3.0.0

raw patch · 70 files changed

+8492/−1358 lines, 70 filesdep +QuickCheckdep +processdep +vectordep ~bytestringdep ~data-defaultdep ~dependent-sumnew-component:exe:reflex-vty-test-driverPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, process, vector

Dependency ranges changed: bytestring, data-default, dependent-sum, exceptions, ordered-containers, stm, text, transformers, vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−2
• README.md +8/−0
• doc/qa.md +170/−0
• internal/Reflex/Vty/Host/Signal.hs +86/−0
• internal/Reflex/Vty/Host/Trigger.hs +235/−0
• reflex-vty.cabal +120/−38
• src/Data/Text/Zipper.hs +3/−5
• src/Reflex/Vty/Canvas.hs +317/−115
• src/Reflex/Vty/Host.hs +186/−140
• src/Reflex/Vty/Host/Signal.hs +0/−64
• src/Reflex/Vty/Host/Trigger.hs +0/−227
• src/Reflex/Vty/Widget.hs +15/−7
• src/Reflex/Vty/Widget/Input.hs +2/−2
• src/Reflex/Vty/Widget/Input/Text.hs +49/−19
• src/Reflex/Vty/Widget/Scroll.hs +7/−4
• src/Reflex/Vty/Widget/Split.hs +45/−14
• test/Control/Monad/NodeIdSpec.hs +29/−0
• test/Coverage.hs +899/−0
• test/Data/Text/ZipperSpec.hs +157/−1
• test/Reflex/Vty/CanvasSpec.hs +202/−78
• test/Reflex/Vty/ColorProfileSpec.hs +35/−0
• test/Reflex/Vty/ColorSpec.hs +35/−0
• test/Reflex/Vty/CompositionSpec.hs +621/−0
• test/Reflex/Vty/Host/SignalSpec.hs +293/−0
• test/Reflex/Vty/Host/TriggerSpec.hs +194/−0
• test/Reflex/Vty/HostSpec.hs +364/−148
• test/Reflex/Vty/StyleSpec.hs +36/−118
• test/Reflex/Vty/Test/AppHarness.hs +607/−0
• test/Reflex/Vty/Test/Generators.hs +143/−0
• test/Reflex/Vty/Test/GoldenPolicySpec.hs +93/−0
• test/Reflex/Vty/Test/GoldenSpec.hs +49/−44
• test/Reflex/Vty/Test/Snapshot.hs +272/−221
• test/Reflex/Vty/Test/SnapshotSpec.hs +202/−54
• test/Reflex/Vty/ThemeSpec.hs +158/−0
• test/Reflex/Vty/Widget/BoxSpec.hs +158/−1
• test/Reflex/Vty/Widget/CursorSpec.hs +27/−2
• test/Reflex/Vty/Widget/Input/TextSpec.hs +378/−0
• test/Reflex/Vty/Widget/InputSpec.hs +252/−0
• test/Reflex/Vty/Widget/LayoutSpec.hs +179/−0
• test/Reflex/Vty/Widget/MouseSpec.hs +0/−29
• test/Reflex/Vty/Widget/ScrollSpec.hs +67/−18
• test/Reflex/Vty/Widget/SplitSpec.hs +248/−0
• test/Reflex/Vty/Widget/TextSpec.hs +170/−0
• test/Reflex/Vty/WidgetSpec.hs +441/−0
• test/Spec.hs +61/−7
• test/coverage-baseline.tsv +21/−0
• test/goldens/align_center.txt +4/−0
• test/goldens/align_left.txt +4/−0
• test/goldens/align_right.txt +4/−0
• test/goldens/border_ascii.txt +8/−0
• test/goldens/border_double.txt +8/−0
• test/goldens/border_rounded.txt +8/−0
• test/goldens/border_single.txt +8/−0
• test/goldens/border_thick.txt +8/−0
• test/goldens/color_blue_bg.txt +4/−0
• test/goldens/color_red_fg.txt +4/−0
• test/goldens/color_rgb.txt +4/−0
• test/goldens/combined.txt +18/−0
• test/goldens/margin_1.txt +8/−0
• test/goldens/multiline.txt +6/−0
• test/goldens/padding_1.txt +8/−0
• test/goldens/padding_2.txt +12/−0
• test/goldens/plain.txt +4/−0
• test/goldens/transform_bold.txt +4/−0
• test/goldens/transform_italic.txt +4/−0
• test/goldens/transform_reverse.txt +4/−0
• test/goldens/transform_underline.txt +4/−0
• test/goldens/wide_chars.txt +4/−0
• test/pty/Main.hs +257/−0
• test/pty_smoke.py +448/−0

@@ -1,14 +1,25 @@ # Revision history for reflex-vty -## Unreleased/Next+## 1.3.0.0 -* 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.+* 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 

@@ -112,6 +112,14 @@ 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).

@@ -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.

@@ -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

@@ -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]

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: reflex-vty-version: 1.2.0.0+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>).@@ -15,8 +15,13 @@ build-type: Simple 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 tested-with:   GHC ==9.8.4 || ==9.10.1 || == 9.12.2@@ -25,7 +30,65 @@   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@@ -44,10 +107,9 @@                  , Reflex.Vty.Widget.Text                  , Data.Text.Zipper                  , Control.Monad.NodeId-  other-modules:  Reflex.Vty.Host.Signal-                , Reflex.Vty.Host.Trigger   build-depends:     base >= 4.10.0 && < 4.22,+    async >= 2.2.6 && < 2.3,     bimap >= 0.3.3 && < 0.6,     bytestring >= 0.12.1 && < 0.13,     containers >= 0.5.0 && < 0.8,@@ -66,49 +128,22 @@     ref-tf >= 0.4.0 && < 0.6,     reflex >= 0.9.2 && < 1,     time >= 1.8.0 && < 1.15,+    vector >= 0.12 && < 0.14,     vty >= 6.0 && < 6.7,-    vty-crossplatform >= 0.1 && < 0.6-  if !os(windows)-    build-depends: unix >= 2.7 && < 2.10+    vty-crossplatform >= 0.1 && < 0.6,+    reflex-vty:reflex-vty-internal   hs-source-dirs: src-  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  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@@ -152,6 +187,7 @@     TemplateHaskell     TupleSections     TypeApplications+    TypeOperators     TypeFamilies  executable examples@@ -207,35 +243,81 @@     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,+    QuickCheck >= 2.14 && < 2.16,     hspec >= 2.7 && < 2.12,     vty+  if !os(windows)+    build-depends: unix >= 2.7 && < 2.10   default-language: Haskell2010

@@ -17,7 +17,7 @@ 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.Unsafe@@ -233,12 +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)+splitAtWidth n t   | 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))+  | 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,

@@ -1,17 +1,28 @@ -- | -- Module: Reflex.Vty.Canvas--- Description: Per-cell compositing with transparency+-- Description: Per-glyph compositing with transparency ----- A 'Canvas' is a 2D grid of @Maybe (Char, Attr)@ cells where 'Nothing'--- means transparent. This allows compositing visual layers with--- per-cell transparency — something 'V.Image' cannot do.+-- 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@@ -21,156 +32,347 @@   , canvasToImage   ) where -import Data.List (foldl')+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.Image.Internal (Image (BGFill, Crop, EmptyImage, HorizJoin, HorizText, VertJoin))+import Graphics.Vty.DisplayAttributes (fixDisplayAttr)+import qualified Graphics.Vty.PictureToSpans as PTS+import Graphics.Vty.Span (SpanOp (RowEnd, Skip, TextSpan)) --- | A 2D grid of cells. Cells not in the 'Map' are transparent--- ('Nothing'). The 'Map' is keyed by @(x, y)@ where @(0,0)@ is the--- top-left corner.+-- | 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) (Char, V.Attr))+  , 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 cell at @(x, y)@. Returns 'Nothing' for transparent cells.-canvasCellAt :: Int -> Int -> Canvas -> Maybe (Char, V.Attr)-canvasCellAt x y (Canvas _ _ cells) = Map.lookup (x, y) cells+-- | 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)@.--- Transparent cells in the source do not overwrite the destination.--- Cells outside the destination bounds are clipped.+-- 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 =-  dst {canvasCells = foldl' insert (canvasCells dst) visibleCells}+placeCanvas dx dy src dst = Canvas dw dh (Map.unions (map row [0 .. dh - 1]))   where-    insert m (pos, cell) = Map.insert pos cell m-    visibleCells =-      [ ((dx + sx, dy + sy), cell)-      | ((sx, sy), cell) <- Map.toList (canvasCells src)-      , dx + sx >= 0-      , dy + sy >= 0-      , dx + sx < canvasWidth dst-      , dy + sy < canvasHeight dst-      ]+    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; cells that--- move outside bounds are lost, and newly empty cells are transparent.+-- | 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 =-  src {canvasCells = Map.mapKeys (\(x, y) -> (x + dx, y + dy)) clipped}-  where-    clipped = Map.filterWithKey keep (canvasCells src)-    keep (x, y) _ =-      x + dx >= 0-        && y + dy >= 0-        && x + dx < canvasWidth src-        && y + dy < canvasHeight src+  placeCanvas dx dy src (blankCanvas (canvasWidth src) (canvasHeight src)) --- | Stack canvases in z-order (last = topmost). All canvases must have--- the same dimensions; later canvases overlay earlier ones.+-- | 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) = foldl' (\dst src -> placeCanvas 0 0 src dst) c cs+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 ---------------------------------------------------------------------------- --- | An attr with all fields 'KeepCurrent', used for transparent cells--- when converting to an 'Image'.-transparentAttr :: V.Attr-transparentAttr =+-- | 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 = V.KeepCurrent-    , V.attrForeColor = V.KeepCurrent-    , V.attrBackColor = V.KeepCurrent-    , V.attrURL = V.KeepCurrent+    { 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'. Every cell in the--- image becomes a concrete @(Char, Attr)@ in the canvas; there are no--- transparent cells.-imageToCanvas :: Image -> Canvas-imageToCanvas img =-  Canvas-    { canvasWidth = V.imageWidth img-    , canvasHeight = V.imageHeight img-    , canvasCells = walkImage img 0 0 Map.empty-    }+-- | 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) --- | Convert a 'Canvas' to a vty 'Image'. Transparent cells (not in the--- 'Map') are rendered as spaces with 'transparentAttr' (KeepCurrent),--- allowing underlying vty layers to show through.-canvasToImage :: Canvas -> Image-canvasToImage (Canvas w h cells)-  | w <= 0 || h <= 0 = EmptyImage-  | otherwise = V.vertCat (map renderRow [0 .. h - 1])+-- | 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-    renderRow y = V.horizCat (map (uncurry V.text') (rowRuns y))-    rowRuns y = mergeRuns [0 .. w - 1]-      where-        cellAt x = Map.findWithDefault (' ', transparentAttr) (x, y) cells-        mergeRuns [] = []-        mergeRuns (x : xs) = go (cellAt x) [fst (cellAt x)] xs-        go (_, attr) chars (x : xs)-          | attr == snd (cellAt x) = go (cellAt x) (fst (cellAt x) : chars) xs-          | otherwise = (attr, T.pack (reverse chars)) : mergeRuns (x : xs)-        go (_, attr) chars [] = [(attr, T.pack (reverse chars))]+    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" -------------------------------------------------------------------------------- Internal: Image tree walker-----------------------------------------------------------------------------+-- | 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) -type CellMap = Map (Int, Int) (Char, V.Attr)+-- | 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]) -walkImage :: Image -> Int -> Int -> CellMap -> CellMap-walkImage img x y acc =-  case img of-    HorizText attr displayText _ _ ->-      placeText attr (TL.unpack displayText) x y acc-    HorizJoin partLeft partRight _ _ ->-      let acc' = walkImage partLeft x y acc-      in walkImage partRight (x + V.imageWidth partLeft) y acc'-    VertJoin partTop partBottom _ _ ->-      let acc' = walkImage partTop x y acc-      in walkImage partBottom x (y + V.imageHeight partTop) acc'-    BGFill outputWidth outputHeight ->-      foldl'-        (\m (dx, dy) -> Map.insertWith (\_ old -> old) (x + dx, y + dy) (' ', V.defAttr) m)-        acc-        [(dx, dy) | dx <- [0 .. outputWidth - 1], dy <- [0 .. outputHeight - 1]]-    Crop croppedImage leftSkip topSkip outputWidth outputHeight ->-      let innerCells = walkImage croppedImage 0 0 Map.empty-          visible =-            [ ((x + kx - leftSkip, y + ky - topSkip), cell)-            | ((kx, ky), cell) <- Map.toList innerCells-            , kx >= leftSkip-            , kx < leftSkip + outputWidth-            , ky >= topSkip-            , ky < topSkip + outputHeight-            ]-      in foldl' (\m (pos, cell) -> Map.insert pos cell m) acc visible-    EmptyImage -> acc+-- | One horizontal piece of an output row: attributed text or a+-- transparent gap.+data RowPart = TextRun (V.Attr, T.Text) | Gap !Int -placeText :: V.Attr -> String -> Int -> Int -> CellMap -> CellMap-placeText attr chars x y =-  go chars 0+-- | 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-    go [] _ acc = acc-    go (c : cs) dx acc =-      let w = wcwidth c-      in if w <= 0-           then go cs dx acc-           else go cs (dx + w) (Map.insert (x + dx, y) (c, attr) acc)+    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

@@ -19,10 +19,10 @@   , VtyEvent   ) where -import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.Async (AsyncCancelled, async, cancel, link, waitCatch) import Control.Concurrent.STM (atomically)-import Control.Exception (onException)-import Control.Monad (forM, forM_, forever)+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 (MonadIO, liftIO)@@ -31,7 +31,7 @@ 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 Graphics.Vty (DisplayRegion) import qualified Graphics.Vty as V@@ -130,6 +130,18 @@ 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   :: VtyAppConfig   -- ^ Host configuration (event-queue capacity, etc.). Use@@ -139,157 +151,191 @@   -> (forall t m. VtyApp t m)   -- ^ A functional reactive vty application.   -> IO ()-runVtyAppWithHandle cfg 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+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'. -    -- Create the "post-build" event and associated trigger. This event fires-    -- once, when the application starts.-    (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef+          -- 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 an 'Event' for OS signals.-    (signalEvent, signalTriggerRef) <- newEventWithTriggerRef+          -- Create the "post-build" event and associated trigger. This event fires+          -- once, when the application starts.+          (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef -    -- A bounded, closeable queue into which external triggers write their-    -- pending invocations. Boundedness gives us backpressure (a producer that-    -- fires faster than the host can process has its @fire@ block when the-    -- queue is full), which bounds memory without dropping occurrences. The-    -- guest runs in 'BoundedTriggerT' below so that its 'TriggerEvent'-    -- methods (and hence 'Reflex.performEventAsync') route writes through-    -- this queue.-    pending <--      liftIO $-        newBoundedEventQueue (fromIntegral (max 1 (_vtyConfig_eventQueueCapacity cfg)))+          -- Create an 'Event' for OS signals.+          (signalEvent, signalTriggerRef) <- newEventWithTriggerRef -    displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty+          displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty -    -- 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.-        flip runPostBuildT postBuild $ -- Allows the guest app to access to-        -- a "post-build" 'Event'-          flip runBoundedTriggerT pending $ -- Allows the guest app to create new-          -- events and triggers; writes route-          -- through the bounded queue above so-          -- that hot producers backpressure-          -- instead of leaking.-            vtyGuest displayRegion0 vtyEvent signalEvent-    -- The guest app is provided the-    -- initial display region, an-    -- 'Event' of vty inputs, and an-    -- 'Event' of OS signals.+          -- 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. SIGINT, SIGTERM, and SIGHUP from the-    -- host also trigger shutdown.-    let sigShutdown = () <$ ffilter (\s -> s == AppSignal_Interrupt || s == AppSignal_Terminate || s == AppSignal_Hangup) signalEvent-    shutdown <- subscribeEvent $ leftmost [_vtyResult_shutdown vtyResult, sigShutdown]+          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. (Like all external-      -- triggers, this is subject to backpressure if the queue is full; in-      -- practice input never saturates it.)-      atomically $ writeBoundedEventQueue pending [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) -    -- Install OS signal handlers.-    liftIO $ installAppSignalHandlers $ \appSignal ->-      atomically $ writeBoundedEventQueue pending [EventTriggerRef signalTriggerRef :=> TriggerInvocation appSignal (return ())]+              -- 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 -    -- 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 $ 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.-          let fireUntilShutdown [] = return False-              fireUntilShutdown (b : bs) = do-                stops <--                  fireEventTriggerRefs fc b $-                    readEvent shutdown >>= \case-                      Nothing -> return False-                      Just _ -> return True-                if or stops then return True else fireUntilShutdown bs-          stop <- fireUntilShutdown batches-          if stop-            then liftIO $ do-              -- If we received a shutdown 'Event', close the queue first so-              -- any producer blocked on a full queue is released, then stop-              -- reading input, restore the primary screen, and shut vty down.-              closeBoundedEventQueue pending-              killThread nextEventThread-              setScreenMode (V.outputIface vty) ScreenNormal-              V.shutdown vty-            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.+    -- 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

@@ -1,64 +0,0 @@-{-# LANGUAGE CPP #-}---- |--- Module: Reflex.Vty.Host.Signal--- Description: Cross-platform OS signal handling for reflex-vty.-module Reflex.Vty.Host.Signal-  ( AppSignal (..)-  , installAppSignalHandlers-  ) where--import Foreign.C.Types (CInt)--#if defined(mingw32_HOST_OS)-import Control.Monad (void)-import qualified GHC.ConsoleHandler as Console-#else-import Control.Monad (forM_)-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 can be shoved into the 'AppSignal_Platform' escape hatch.-data AppSignal-  = AppSignal_Interrupt-  | AppSignal_Terminate-  | AppSignal_Hangup-  | AppSignal_Platform CInt-  deriving (Eq, Show)---- | Install handlers for OS signals-installAppSignalHandlers :: (AppSignal -> IO ()) -> IO ()--#if defined(mingw32_HOST_OS)---- via 'GHC.ConsoleHandler'-installAppSignalHandlers fire =-  void $ Console.installHandler $ Console.Catch (fire . toAppSignal)-  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: terminal going away.-      Console.Logoff -> AppSignal_Hangup -- user logging off: session going away.-      Console.Shutdown -> AppSignal_Terminate -- system shutting down: clean termination.--#else--installAppSignalHandlers fire =-  forM_ signals $ \(sig, appSignal) ->-    installHandler sig (Catch (fire appSignal)) Nothing-  where-    signals =-      [ (sigINT, AppSignal_Interrupt)-      , (sigTERM, AppSignal_Terminate)-      , (sigHUP, AppSignal_Hangup)-      ]--#endif

@@ -1,227 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# 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 drop-in--- 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, so a producer that fires faster than the host can--- process is throttled (its @fire@ callback blocks when the queue is full)--- rather than allowed to exhaust memory. Because the producer's own write--- blocks, no event occurrences are dropped.------ The queue is also closeable: on shutdown the host closes it, which releases--- any producer currently blocked on a full queue.-module Reflex.Vty.Host.Trigger-  ( -- * Bounded event queue-    BoundedEventQueue-  , 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---   (backpressure to the producer).--- * Once closed, writes return immediately without enqueueing, so 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. Becomes a no-op once the--- queue is closed (so a producer blocked here unblocks on shutdown).-writeBoundedEventQueue :: BoundedEventQueue t -> Batch t -> STM ()-writeBoundedEventQueue q batch =-  -- If there is room, write. Otherwise retry until there is room /or/ the-  -- queue is closed (in which case silently drop).-  writeTBQueue (_beqQueue q) batch `orElse` void (readTMVar (_beqClosed q))---- | 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 that multiple--- occurrences of the same trigger that landed in the same drain are preserved--- (Reflex collapses simultaneous same-trigger firings, so 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--- drop-in replacement for @TriggerEventT@ (same instance set); only its--- 'TriggerEvent' instance differs, routing 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]

@@ -439,7 +439,10 @@ -- | Convert reflex-vty cursor state to vty's picture cursor. cursorStateToVtyCursor :: CursorState -> V.Cursor cursorStateToVtyCursor (CursorState CursorHidden _ _) = V.NoCursor-cursorStateToVtyCursor (CursorState CursorVisible _ (x, y)) = V.Cursor x y+-- 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)@@ -1087,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@@ -1099,11 +1102,16 @@   -- ^ 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 

@@ -9,7 +9,7 @@ import Control.Monad (join) import Control.Monad.Fix (MonadFix) import Data.Default (Default (..))-import Data.List (foldl')+import qualified Data.List as List import Data.Text (Text) import qualified Graphics.Vty as V import Reflex@@ -164,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 ())

@@ -6,7 +6,6 @@   , def   ) where -import Control.Monad (join) import Control.Monad.Fix (MonadFix) import Data.Default (Default (..)) import Data.Function ((&))@@ -17,7 +16,7 @@ import Reflex  import Data.Text.Zipper-import Reflex.Vty.Style (applyAttr)+import Reflex.Vty.Style (Style, applyAttr) import Reflex.Vty.Theme (Theme (..)) import Reflex.Vty.Widget import Reflex.Vty.Widget.Input.Mouse@@ -93,8 +92,6 @@   dw <- viewportWidth   bt <- themeAttr   th <- theme-  attr0 <- sample bt-  cursorStyle0 <- sample (fmap _theme_textInputCursor th)   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@@ -124,18 +121,24 @@             ]       click <- mouseDown V.BLeft -      let toCursorAttrs attr = applyAttr cursorStyle0 attr-          rowInputDyn =-            (,,)+      -- 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-          toDisplayLines attr (w, s, x) =-            let c = if x then toCursorAttrs attr else attr-            in displayLinesWithAlignment (_textInputConfig_alignment cfg) w attr c s-      attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)-      let rows = ffor2 attrDyn rowInputDyn toDisplayLines-          img = images . _displayLines_spans <$> rows+          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)@@ -144,7 +147,7 @@             | 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+      tellImages $ (\imgs st -> (: []) . V.vertCat $ drop st imgs) <$> img <*> scrollTop   return $     TextInput       { _textInput_value = value <$> v@@ -152,6 +155,12 @@       , _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)@@ -174,18 +183,39 @@ -- | 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]

@@ -5,7 +5,7 @@ import Control.Monad.IO.Class import Data.Default import Data.Functor (void)-import Data.List (foldl')+import qualified Data.List as List import qualified Graphics.Vty as V import Reflex @@ -110,7 +110,7 @@       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 = foldl' max 0 . fmap V.imageHeight <$> imgs+      let sz = List.foldl' max 0 . fmap V.imageHeight <$> imgs       lineIndex <-         foldDynMaybe ($) startingPos $           leftmost@@ -157,7 +157,10 @@     calculateTranslation height scrollPos totalLines = case scrollPos of       ScrollPos_Bottom -> max 0 (totalLines - height)       ScrollPos_Top -> 0-      ScrollPos_Line n -> max 0 n+      -- 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@@ -180,7 +183,7 @@ scrollToLine totalLines height newPos =   if     | totalLines <= height -> ScrollPos_Top-    | newPos == 0 -> ScrollPos_Top+    | newPos <= 0 -> ScrollPos_Top     | newPos + height >= totalLines -> ScrollPos_Bottom     | otherwise -> ScrollPos_Line newPos 

@@ -21,21 +21,52 @@ splitVDrag wS wA wB = do   dh <- viewportHeight   dw <- viewportWidth-  h0 <- sample $ current dh -- TODO   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) _ _ st) ->-              if splitterY == fromY then Just (toY, st == DragEnd) 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)+  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

@@ -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)

@@ -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

@@ -5,12 +5,21 @@   ) where  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 Reflex.Vty.Test.Generators+  ( EditOp (..)+  , genEditScript+  , genMixedWidthText+  , runPlanProperty+  )  someSentence :: T.Text someSentence = "12345 1234 12"@@ -126,4 +135,151 @@         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++    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++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++-- | 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)))

@@ -2,106 +2,230 @@  module Reflex.Vty.CanvasSpec (spec) where -import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map+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-  let red = V.withForeColor V.defAttr (V.ISOColor 1)-      blue = V.withForeColor V.defAttr (V.ISOColor 4)-      fromList = Map.fromList :: [((Int, Int), (Char, V.Attr))] -> Map (Int, Int) (Char, V.Attr)-   describe "blankCanvas" $ do-    it "creates a transparent canvas" $ do-      let c = blankCanvas 5 3-      canvasWidth c `shouldBe` 5-      canvasHeight c `shouldBe` 3-      canvasCells c `shouldBe` mempty--    it "cellAt returns Nothing for blank" $ 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 cells" $ do-      let dst = blankCanvas 5 3-          src = Canvas 2 1 (fromList [((0, 0), ('X', red))])-          result = placeCanvas 1 0 src dst-      canvasCellAt 1 0 result `shouldBe` Just ('X', red)+    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 "transparent source cells don't overwrite" $ do-      let dst = Canvas 3 1 (fromList [((0, 0), ('A', blue))])-          src = blankCanvas 3 1-          result = placeCanvas 0 0 src dst-      canvasCellAt 0 0 result `shouldBe` Just ('A', blue)+    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 cells outside destination bounds" $ do-      let dst = blankCanvas 3 3-          src = Canvas 2 1 (fromList [((0, 0), ('X', red))])-          result = placeCanvas 5 5 src dst-      canvasCells result `shouldBe` mempty+    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 "] -  describe "translate" $ do-    it "shifts cells by offset" $ do-      let c = Canvas 5 5 (fromList [((0, 0), ('X', red))])-          result = translate 2 3 c-      canvasCellAt 2 3 result `shouldBe` Just ('X', red)-      canvasCellAt 0 0 result `shouldBe` Nothing+    it "drops width-one glyphs wholly outside" $ do+      let c = translate (-1) 0 (imageToCanvas (V.string V.defAttr "ab"))+      canvasText c `shouldBe` ["b "] -    it "drops cells that move outside bounds" $ do-      let c = Canvas 3 3 (fromList [((0, 0), ('X', red))])-          result = translate 5 0 c-      canvasCells result `shouldBe` mempty+    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 -  describe "stack" $ do-    it "later canvases overlay earlier ones" $ do-      let bottom = Canvas 3 1 (fromList [((0, 0), ('A', red))])-          top = Canvas 3 1 (fromList [((0, 0), ('B', blue))])-          result = stack [bottom, top]-      canvasCellAt 0 0 result `shouldBe` Just ('B', blue)+    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 "transparent cells in top layer show bottom" $ do-      let bottom = Canvas 3 1 (fromList [((0, 0), ('A', red))])-          top = Canvas 3 1 (fromList [((1, 0), ('B', blue))])-          result = stack [bottom, top]-      canvasCellAt 0 0 result `shouldBe` Just ('A', red)-      canvasCellAt 1 0 result `shouldBe` Just ('B', blue)+    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 "empty list returns blank" $ do-      let result = stack []-      canvasWidth result `shouldBe` 0+    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` ["  "] -  describe "imageToCanvas" $ do-    it "converts plain text" $ do-      let img = V.text' red "AB"-          c = imageToCanvas img+    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 0 0 c `shouldBe` Just ('A', red)-      canvasCellAt 1 0 c `shouldBe` Just ('B', red)+      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 "converts charFill" $ do-      let img = V.charFill red 'X' 3 2-          c = imageToCanvas img-      canvasWidth c `shouldBe` 3-      canvasHeight c `shouldBe` 2-      canvasCellAt 0 0 c `shouldBe` Just ('X', red)-      canvasCellAt 2 1 c `shouldBe` Just ('X', red)+    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"] -  describe "canvasToImage" $ do-    it "round-trips through imageToCanvas for opaque content" $ do-      let img = V.text' red "Hello"-          c = imageToCanvas img-          img' = canvasToImage c-      V.imageWidth img' `shouldBe` 5-      V.imageHeight img' `shouldBe` 1+    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 "preserves dimensions for transparent canvas" $ do-      let c = blankCanvas 4 2-          img = canvasToImage c-      V.imageWidth img `shouldBe` 4-      V.imageHeight img `shouldBe` 2+    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)

@@ -3,6 +3,7 @@  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@@ -59,3 +60,37 @@       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

@@ -4,8 +4,10 @@  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@@ -90,3 +92,36 @@       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

@@ -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

@@ -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

@@ -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

@@ -1,186 +1,402 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- |--- Description: Host event-channel regression + backpressure tests.+-- 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.Monad (forever, replicateM_, void)+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 (IORef, modifyIORef', newIORef, readIORef)+import Data.IORef+import Data.List (isInfixOf) import qualified Graphics.Vty as V-import Graphics.Vty.Attributes.Color (ColorMode (..)) 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-  ( VtyApp-  , VtyResult (..)-  , defaultVtyAppConfig-  , runVtyAppWithHandle+import Reflex.Vty.Test.AppHarness+  ( RecordingVtyConfig (..)+  , defaultRecordingVtyConfig+  , recordingLogHistory+  , recordingReleaseGate+  , recordingVty+  , runHostAsync   ) -------------------------------------------------------------------------------- Constants--------------------------------------------------------------------------------- | Burst size for the regression test: large enough that the old--- one-batch-per-frame host loop would not reach the shutdown request within--- 'shutdownTimeout' (it would need one redraw per item).+-- | Burst for the drain regression: far beyond what a+-- one-redraw-per-batch loop could finish inside 'defaultDeadline'. burstN :: Int burstN = 10000 --- | Burst size for the occurrence-preservation test. Deliberately far larger--- than the default queue capacity (4096) so that backpressure provably engages--- and the producer is throttled rather than able to dump everything at once.+-- | Occurrence-preservation burst, deliberately far beyond the queue+-- capacity used in that test so backpressure provably engages. overloadN :: Int overloadN = 50000 --- | Time the host is allowed to take. The fixed host drains the whole burst in--- a single frame, so this is ample; the old host (one batch per frame) would--- need @burstN * redrawDelay@ microseconds and time out.-shutdownTimeout :: Int-shutdownTimeout = 6 * 1000000+-- | Deadlines (microseconds).+defaultDeadline :: Int+defaultDeadline = 10 * 1000000 --- | Generous timeout for the occurrence-preservation test: under backpressure--- the producer is throttled to the host's processing rate, so @overloadN@--- ticks take a little while to drain.-overloadTimeout :: Int-overloadTimeout = 30 * 1000000+slowDeadline :: Int+slowDeadline = 30 * 1000000 --- | Per-redraw delay modelled by the mock vty. Simulates the cost of a real--- 'V.update'.-redrawDelay :: Int-redrawDelay = 2000+-- | 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 each frame and does not leak (regression)" $ do-      vty <- mockVty (\_ -> threadDelay redrawDelay)-      result <- timeout shutdownTimeout $ runVtyAppWithHandle defaultVtyAppConfig vty guest-      -- The host must shut down within the timeout. With the old loop it would-      -- stall behind @burstN@ backlogged batches (one redraw each) and time out.-      result `shouldBe` Just ()+    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-      -- A producer firing faster than the host can process must be backpressured-      -- (no dropped occurrences) rather than allowed to exhaust memory.       counter <- newIORef (0 :: Int)-      vty <- mockVty (\_ -> threadDelay redrawDelay)-      result <- timeout overloadTimeout $ runVtyAppWithHandle defaultVtyAppConfig vty (countingGuest counter)-      result `shouldBe` Just ()-      final <- readIORef counter-      -- Every one of the @overloadN@ ticks must be counted: backpressure throttles-      -- the producer but never drops an occurrence.-      final `shouldBe` overloadN+      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 -------------------------------------------------------------------------------- Guests-----------------------------------------------------------------------------+    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) --- | Fires a burst of events into the FRP network (exactly the pattern that--- backed up the host's event channel) and then requests shutdown. Both the--- ticks and the shutdown request travel through the same 'TriggerEvent'--- channel, so the only way the host reaches shutdown promptly is by draining--- the whole channel each frame.-guest :: VtyApp t m-guest _region _input _sigs = do-  setupE <- getPostBuild-  (tickE, fireTick) <- newTriggerEvent-  (shutdownE, fireShutdown) <- newTriggerEvent-  -- Subscribe to the ticks so each occurrence does real work in the network.-  _d <- holdDyn (0 :: Int) tickE-  performEvent_ $-    ffor setupE $ \() ->-      liftIO $-        void $-          forkIO $ do-            replicateM_ burstN (fireTick (0 :: Int))-            fireShutdown ()-  return $-    VtyResult-      { _vtyResult_picture = pure (V.picForImage V.emptyImage)-      , _vtyResult_shutdown = shutdownE-      }+    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) --- | Like 'guest' but increments an 'IORef' on every tick occurrence, so the--- test can assert that no occurrences were dropped under backpressure.-countingGuest :: IORef Int -> (forall t m. VtyApp t m)-countingGuest counter _region _input _sigs = do-  setupE <- getPostBuild-  (tickE, fireTick) <- newTriggerEvent-  (shutdownE, fireShutdown) <- newTriggerEvent-  performEvent_ $ ffor tickE $ \_ -> liftIO $ modifyIORef' counter (+ 1)-  performEvent_ $-    ffor setupE $ \() ->-      liftIO $-        void $-          forkIO $ do-            replicateM_ overloadN (fireTick (0 :: Int))-            fireShutdown ()-  return $-    VtyResult-      { _vtyResult_picture = pure (V.picForImage V.emptyImage)-      , _vtyResult_shutdown = shutdownE-      }+    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 -------------------------------------------------------------------------------- Mock vty (no real terminal)-----------------------------------------------------------------------------+    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 --- | A 'V.Vty' whose 'update' action runs the given @IO@ (to model redraw--- cost) and whose 'nextEvent' blocks forever; the network is driven entirely--- via 'TriggerEvent'. Only the fields the host actually touches are real;--- the rest are never forced (the mock's @update@ never dereferences the--- unused 'V.Output' fields).-mockVty :: (V.Picture -> IO ()) -> IO V.Vty-mockVty updateAction = do-  out <- mockOutput-  pure-    V.Vty-      { V.update = updateAction-      , V.nextEvent = forever (threadDelay 1000000)-      , V.nextEventNonblocking = pure Nothing-      , V.inputIface = mockInput-      , V.outputIface = out-      , V.refresh = pure ()-      , V.shutdown = pure ()-      , V.isShutdown = pure False-      }+      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 -mockInput :: V.Input-mockInput =-  V.Input-    { V.eventChannel = error "mockInput: eventChannel unused"-    , V.shutdownInput = pure ()-    , V.restoreInputState = pure ()-    , V.inputLogMsg = \_ -> pure ()-    }+      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 -mockOutput :: IO V.Output-mockOutput =-  pure-    V.Output-      { V.terminalID = "mock"-      , V.releaseTerminal = pure ()-      , V.reserveDisplay = pure ()-      , V.releaseDisplay = pure ()-      , V.setDisplayBounds = \_ -> pure ()-      , V.displayBounds = pure (80, 24)-      , V.outputByteBuffer = \_ -> pure ()-      , V.supportsCursorVisibility = True-      , V.supportsMode = const False-      , V.setMode = \_ _ -> pure ()-      , V.getModeStatus = \_ -> pure False-      , V.assumedStateRef = error "mockOutput: assumedStateRef unused"-      , V.mkDisplayContext = \_ _ -> error "mockOutput: mkDisplayContext unused"-      , V.ringTerminalBell = pure ()-      , V.supportsBell = pure True-      , V.supportsItalics = pure True-      , V.supportsStrikethrough = pure True-      , V.outputColorMode = FullColor-      , V.setOutputWindowTitle = \_ -> pure ()-      }+      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

@@ -10,52 +10,10 @@ 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 "def" $ do-    it "has no foreground" $-      _style_foreground def `shouldBe` Nothing-    it "has no border" $-      _style_border def `shouldBe` Nothing-    it "has zero padding" $-      _style_padding def `shouldBe` Padding 0 0 0 0-    it "has zero margin" $-      _style_margin def `shouldBe` Margin 0 0 0 0--  describe "per-side setters" $ do-    it "withPaddingTop sets only top" $ do-      let s = withPaddingTop 3 def-      _padding_top (_style_padding s) `shouldBe` 3-      _padding_right (_style_padding s) `shouldBe` 0-    it "withPaddingRight sets only right" $ do-      let s = withPaddingRight 2 def-      _padding_right (_style_padding s) `shouldBe` 2-      _padding_top (_style_padding s) `shouldBe` 0-    it "withPaddingBottom sets only bottom" $ do-      let s = withPaddingBottom 4 def-      _padding_bottom (_style_padding s) `shouldBe` 4-    it "withPaddingLeft sets only left" $ do-      let s = withPaddingLeft 1 def-      _padding_left (_style_padding s) `shouldBe` 1-    it "withMarginTop sets only top" $ do-      let s = withMarginTop 2 def-      _margin_top (_style_margin s) `shouldBe` 2-      _margin_right (_style_margin s) `shouldBe` 0-    it "withMarginLeft sets only left" $ do-      let s = withMarginLeft 3 def-      _margin_left (_style_margin s) `shouldBe` 3-    it "withBorderTop enables only top toggle" $ do-      let s = withBorderTop True def-      _style_borderTop s `shouldBe` Just True-      _style_borderBottom s `shouldBe` Nothing-    it "withBorderForeground sets border color" $ do-      let s = withBorderForeground red def-      _style_borderForeground s `shouldBe` Just red-    it "withBorderBackground sets border bg" $ do-      let s = withBorderBackground blue def-      _style_borderBackground s `shouldBe` Just blue-   describe "inherit" $ do     let parent = withForeground red . withBold . withWidth 10 $ def     it "keeps the child's foreground when set" $ do@@ -130,81 +88,6 @@           result = mergeAttr base overlay       V.attrForeColor result `shouldBe` V.SetTo red -  describe "border style presets" $ do-    it "singleBorder has all sides and corners" $ do-      all-        (isJust . ($ singleBorder))-        [ _border_top-        , _border_bottom-        , _border_left-        , _border_right-        , _border_topLeft-        , _border_topRight-        , _border_bottomLeft-        , _border_bottomRight-        ]-        `shouldBe` True-    it "noBorder has no sides or corners" $ do-      any-        (isJust . ($ noBorder))-        [ _border_top-        , _border_bottom-        , _border_left-        , _border_right-        , _border_topLeft-        , _border_topRight-        , _border_bottomLeft-        , _border_bottomRight-        ]-        `shouldBe` False-    it "markdownBorder has sides but no corners" $ do-      let b = markdownBorder-      _border_top b `shouldSatisfy` isJust-      _border_topLeft b `shouldBe` Nothing-    it "roundedBorder has all sides and corners" $ do-      all-        (isJust . ($ roundedBorder))-        [ _border_top-        , _border_bottom-        , _border_left-        , _border_right-        , _border_topLeft-        , _border_topRight-        , _border_bottomLeft-        , _border_bottomRight-        ]-        `shouldBe` True-    it "thickBorder has all sides and corners" $ do-      all-        (isJust . ($ thickBorder))-        [ _border_top-        , _border_bottom-        , _border_left-        , _border_right-        , _border_topLeft-        , _border_topRight-        , _border_bottomLeft-        , _border_bottomRight-        ]-        `shouldBe` True-    it "doubleBorder has all sides and corners" $ do-      all-        (isJust . ($ doubleBorder))-        [ _border_top-        , _border_bottom-        , _border_left-        , _border_right-        , _border_topLeft-        , _border_topRight-        , _border_bottomLeft-        , _border_bottomRight-        ]-        `shouldBe` True-    it "asciiBorder uses ASCII characters" $ do-      _border_top asciiBorder `shouldBe` Just '-'-      _border_left asciiBorder `shouldBe` Just '|'-      _border_topLeft asciiBorder `shouldBe` Just '+'-   describe "render" $ do     it "produces a non-empty image for plain text" $ do       let img = render def "hello"@@ -313,3 +196,38 @@       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"

@@ -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

@@ -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)

@@ -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")

@@ -2,63 +2,68 @@  module Reflex.Vty.Test.GoldenSpec (spec) where +import System.FilePath ((</>)) import Test.Hspec  import Reflex.Vty.Style import Reflex.Vty.Test.Snapshot -spec :: Spec-spec = describe "Golden snapshots" $ do-  -- Borders-  golden "border_single" $ render (withBorder singleBorder def) "Box"-  golden "border_rounded" $ render (withBorder roundedBorder def) "Box"-  golden "border_thick" $ render (withBorder thickBorder def) "Box"-  golden "border_double" $ render (withBorder doubleBorder def) "Box"-  golden "border_ascii" $ render (withBorder asciiBorder def) "Box"+goldenDir :: FilePath+goldenDir = "test" </> "goldens" -  -- Padding & Margin-  golden "padding_1" $ render (withPadding 1 1 1 1 def) "pad"-  golden "padding_2" $ render (withPadding 2 2 2 2 def) "pad"-  golden "margin_1" $ render (withMargin 1 1 1 1 def) "m"+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" -  -- Colors-  golden "color_red_fg" $ render (withForeground red def) "Red"-  golden "color_blue_bg" $ render (withBackground blue def) "Blue"-  golden "color_rgb" $ render (withForeground (rgbColor 200 100 50) def) "RGB"+      -- 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" -  -- Transforms-  golden "transform_bold" $ render (withBold def) "Bold"-  golden "transform_italic" $ render (withItalic def) "Italic"-  golden "transform_underline" $ render (withUnderline UnderlineSingle def) "UL"-  golden "transform_reverse" $ render (withReverse def) "Rev"+      -- 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" -  -- Alignment-  golden "align_left" $ render (withAlignH HAlignLeft . withWidth 20 $ def) "Left"-  golden "align_center" $ render (withAlignH HAlignCenter . withWidth 20 $ def) "Center"-  golden "align_right" $ render (withAlignH HAlignRight . withWidth 20 $ def) "Right"+      -- 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" -  -- Combined-  golden "combined" $-    render-      ( withBorder roundedBorder-          . withPadding 1 2 1 2-          . withForeground brightGreen-          . withBorderForeground brightMagenta-          $ def-      )-      "Combined"+      -- 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" -  -- Multi-line-  golden "multiline" $ render def "Hello\nWorld"+      -- Combined+      golden mode "combined" $+        render+          ( withBorder roundedBorder+              . withPadding 1 2 1 2+              . withForeground brightGreen+              . withBorderForeground brightMagenta+              $ def+          )+          "Combined" -  -- Wide chars-  golden "wide_chars" $ render def "a文b"+      -- Multi-line+      golden mode "multiline" $ render def "Hello\nWorld" -  -- Plain text (baseline)-  golden "plain" $ render def "hello"-  where-    golden name img =+      -- 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 name $+        assertGolden mode goldenDir name $           renderGrid $             imageToGrid img

@@ -1,265 +1,316 @@+{-# LANGUAGE ScopedTypeVariables #-}+ -- |--- Description: Rendering snapshot harness for testing vty Image output ----- Converts a 'V.Image' into a 2D grid of cells, each carrying the display--- character and its 'V.Attr'. This lets tests assert on rendered output--- without a real terminal — useful for golden-file comparison and precise--- cell-level checks.+-- 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'): ----- > 4x3--- > ┌──┐--- > │hi│--- > └──┘--- > --- attrs ------ > 1,1 'h' fg=red style=bold+-- > 4x1+-- > "a\30028b"+-- > --- spans ---+-- > 0:0+4 text="a\30028b" attr=FixedAttr {fixedStyle = 0, ...} ----- The text grid is always shown. The @--- attrs ---@ section appears only--- when at least one cell has an explicit ('SetTo') attribute, keeping--- goldens clean for unstyled output.+-- 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-  ( Cell (..)-  , Grid+  ( 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 Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map+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 Graphics.Text.Width (wcwidth)+import qualified Data.Vector as Vec import qualified Graphics.Vty as V-import Graphics.Vty.Image.Internal (Image (BGFill, Crop, EmptyImage, HorizJoin, HorizText, VertJoin))+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, shouldBe)+import Test.Hspec (Expectation, expectationFailure, shouldBe) --- | A single rendered cell: the display character and its vty attribute.-data Cell = Cell-  { cellChar :: !Char-  , cellAttr :: !V.Attr+-- | 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 grid is a list of rows (top-to-bottom), each a list of cells (left-to-right).-type Grid = [[Cell]]---- | Render a vty 'Image' to a 'Grid'. The grid dimensions match--- 'V.imageWidth' × 'V.imageHeight'. Any cell not explicitly written by--- the image (e.g. gaps in a sparse layout) defaults to a space with--- 'V.defAttr'.-imageToGrid :: Image -> Grid-imageToGrid img =-  let w = V.imageWidth img-      h = V.imageHeight img-      cells = walkImage img 0 0 Map.empty-  in [ [ Map.findWithDefault blankCell (x, y) cells-       | x <- [0 .. max 0 (w - 1)]-       ]-     | y <- [0 .. max 0 (h - 1)]-     ]-  where-    blankCell = Cell ' ' V.defAttr+-- | 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) --- | Extract just the visible text from an image, one string per row.--- Useful for quick visual inspection in test failures.-imageText :: Image -> [String]-imageText img = map (map cellChar) (imageToGrid img)+-- | Terminal default attributes; the starting point of attribute+-- resolution on each row.+defaultFixedAttr :: V.FixedAttr+defaultFixedAttr = V.FixedAttr V.defaultStyleMask Nothing Nothing Nothing --- | Pretty-print a grid for debugging or golden-file comparison.--- Format:------ @--- <width>x<height>--- <text grid, one row per line>--- --- attrs ---           -- only if any cell has explicit attrs--- <row>,<col> '<char>' <formatted attrs>--- @------ Only cells with at least one 'V.SetTo' attribute appear in the attrs--- section. Cells with pure 'V.Default' or 'V.KeepCurrent' attrs are--- omitted, keeping goldens clean for unstyled output.-renderGrid :: Grid -> String-renderGrid grid =-  unlines (header : textRows) ++ attrsSection+-- | 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-    h = length grid-    w = case grid of-      [] -> 0-      r : _ -> length r-    header = show w ++ "x" ++ show h-    textRows = map (map cellChar) grid-    explicitCells =-      [ (row, col, c)-      | (row, line) <- zip [0 ..] grid-      , (col, c) <- zip [0 ..] line-      , hasExplicitAttr (cellAttr c)-      ]-    attrsSection-      | null explicitCells = ""-      | otherwise =-          unlines $-            "--- attrs ---"-              : [ show row ++ "," ++ show col ++ " '" ++ [cellChar c] ++ "' " ++ showAttr (cellAttr c)-                | (row, col, c) <- explicitCells-                ]+    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] --- | True if any field of the attr is 'V.SetTo' (i.e. explicitly set).-hasExplicitAttr :: V.Attr -> Bool-hasExplicitAttr a =-  isSetTo (V.attrStyle a)-    || isSetTo (V.attrForeColor a)-    || isSetTo (V.attrBackColor a)-    || isSetTo (V.attrURL a)+-- | 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-    isSetTo (V.SetTo _) = True-    isSetTo _ = False+    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" --- | Check whether two grids are equal. Returns 'Nothing' if they match,--- or a description of the first differing cell.-gridEquals :: Grid -> Grid -> Maybe String-gridEquals a b-  | length a /= length b = Just $ "row count: " ++ show (length a) ++ " vs " ++ show (length b)-  | otherwise = go 0 a b+-- | 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-    go _ [] [] = Nothing-    go row (ra : ras) (rb : rbs)-      | length ra /= length rb =-          Just $ "row " ++ show row ++ " width: " ++ show (length ra) ++ " vs " ++ show (length rb)-      | otherwise =-          case findCellDiff row 0 ra rb of-            Just d -> Just d-            Nothing -> go (row + 1) ras rbs-    findCellDiff _ _ [] [] = Nothing-    findCellDiff row col (ca : cas) (cb : cbs)-      | ca /= cb =-          Just $-            "cell ("-              ++ show (row, col)-              ++ "): '"-              ++ [cellChar ca]-              ++ "' "-              ++ showAttr (cellAttr ca)-              ++ " vs '"-              ++ [cellChar cb]-              ++ "' "-              ++ showAttr (cellAttr cb)-      | otherwise = findCellDiff row (col + 1) cas cbs+    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] -------------------------------------------------------------------------------- Internal: tree walker-----------------------------------------------------------------------------+-- | 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 -type CellMap = Map (Int, Int) Cell+-- | 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) -walkImage :: Image -> Int -> Int -> CellMap -> CellMap-walkImage img x y acc =-  case img of-    HorizText attr displayText _ _ ->-      let chars = TL.unpack displayText-      in placeText attr chars x y acc-    HorizJoin partLeft partRight _ _ ->-      let acc' = walkImage partLeft x y acc-      in walkImage partRight (x + V.imageWidth partLeft) y acc'-    VertJoin partTop partBottom _ _ ->-      let acc' = walkImage partTop x y acc-      in walkImage partBottom x (y + V.imageHeight partTop) acc'-    BGFill outputWidth outputHeight ->-      foldl'-        (\m (dx, dy) -> Map.insertWith (\_ old -> old) (x + dx, y + dy) blank m)-        acc-        [ (dx, dy)-        | dx <- [0 .. outputWidth - 1]-        , dy <- [0 .. outputHeight - 1]-        ]-      where-        blank = Cell ' ' V.defAttr-    Crop croppedImage leftSkip topSkip outputWidth outputHeight ->-      let innerCells = walkImage croppedImage 0 0 Map.empty-          visible =-            [ ( (x + kx - leftSkip, y + ky - topSkip)-              , cell-              )-            | ((kx, ky), cell) <- Map.toList innerCells-            , kx >= leftSkip-            , kx < leftSkip + outputWidth-            , ky >= topSkip-            , ky < topSkip + outputHeight-            ]-      in foldl' (\m (pos, cell) -> Map.insert pos cell m) acc visible-    EmptyImage -> acc+-- | 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)) -placeText :: V.Attr -> String -> Int -> Int -> CellMap -> CellMap-placeText attr chars x y =-  go chars 0+-- | 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 [] _ acc = acc-    go (c : cs) dx acc =-      let w = wcwidth c-      in if w <= 0-           then go cs dx acc-           else-             go cs (dx + w) $-               Map.insert (x + dx, y) (Cell c attr) acc+    go _ [] = Nothing+    go col (s : ss)+      | x < col + renderSpanColumns s = Just (renderSpanAttr s)+      | otherwise = go (col + renderSpanColumns s) ss -------------------------------------------------------------------------------- Internal: attr serialization-----------------------------------------------------------------------------+-- | 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 -showAttr :: V.Attr -> String-showAttr a =-  concat-    [ "fg="-    , showMD V.attrForeColor-    , " bg="-    , showMD V.attrBackColor-    , " style="-    , showStyle-    , " url="-    , showMD V.attrURL-    ]+-- | 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-    showMD f = case f a of-      V.Default -> "default"-      V.KeepCurrent -> "keep"-      V.SetTo v -> show v-    styleMask = V.styleMask a-    showStyle =-      let styles =-            [ ("bold", V.bold)-            , ("underline", V.underline)-            , ("reverse", V.reverseVideo)-            , ("blink", V.blink)-            , ("dim", V.dim)-            , ("italic", V.italic)-            , ("strikethrough", V.strikethrough)-            ]-          active = [name | (name, s) <- styles, V.hasStyle styleMask s]-      in if null active then "none" else unwords active+    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 ---------------------------------------------------------------------------- --- | Directory where golden files are stored.-goldenDir :: FilePath-goldenDir = "test" </> "goldens"+-- | 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) --- | Compare actual output against a golden file. If the file doesn't--- exist yet, it is created (first-run golden creation). If it exists but--- differs, the test fails with a unified diff.-assertGolden :: String -> String -> Expectation-assertGolden name actual = do-  let path = goldenDir </> name <.> "txt"-  createDirectoryIfMissing True goldenDir-  exists <- doesFileExist path-  if not exists-    then writeFile path actual-    else do-      expected <- readFile path-      actual `shouldBe` expected+-- | 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

@@ -2,76 +2,224 @@  module Reflex.Vty.Test.SnapshotSpec (spec) where -import Data.List (isInfixOf)+import Data.Maybe (isJust)+import qualified Data.Text as T import qualified Graphics.Vty as V import Test.Hspec -import Reflex.Vty.Style-  ( Color-  , Style-  , def-  , render-  , singleBorder-  , withBorder-  , withForeground-  )-import qualified Reflex.Vty.Style as Style (red) 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 "renders plain text as a single row" $ do-      let img = render def "hello"-          grid = imageToGrid img-      length grid `shouldBe` 1-      case grid of-        [row] -> map cellChar row `shouldBe` "hello"-        _ -> expectationFailure "expected exactly one row"+    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 multi-line text with correct rows" $ do-      let img = render def "ab\ncd"-          grid = imageToGrid img-      length grid `shouldBe` 2-      map cellChar (grid !! 0) `shouldBe` "ab"-      map cellChar (grid !! 1) `shouldBe` "cd"+    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 "preserves attributes from the style" $ do-      let img = render (withForeground Style.red def) "X"-          grid = imageToGrid img-      case grid of-        ((c : _) : _) -> V.attrForeColor (cellAttr c) `shouldBe` V.SetTo Style.red-        _ -> expectationFailure "expected at least one cell"+    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 "renders borders as box-drawing characters" $ do-      let img = render (withBorder singleBorder def) "hi"-          grid = imageToGrid img-      case grid of-        (topRow : _) -> do-          map cellChar topRow `shouldStartWith` "\9484" -- ┌-          last (map cellChar topRow) `shouldBe` '\9488' -- ┐-        [] -> expectationFailure "expected at least one row"+    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" -  describe "imageText" $ do-    it "extracts text content from image" $ do-      let img = render def "hello"-      imageText img `shouldBe` ["hello"]+    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 "handles multi-line content" $ do-      let img = render def "foo\nbar"-      imageText img `shouldBe` ["foo", "bar"]+    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 grid = imageToGrid $ render def "hi"-      gridEquals grid grid `shouldBe` Nothing+      let g = imageToGrid (V.string red "hi")+      gridEquals g g `shouldBe` Nothing -    it "reports mismatched cells" $ do-      let g1 = imageToGrid $ render def "hi"-          g2 = imageToGrid $ render def "ho"-      gridEquals g1 g2 `shouldSatisfy` (/= 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 "includes text representation" $ do-      let txt = renderGrid $ imageToGrid $ render def "X"-      txt `shouldSatisfy` ("X" `isInfixOf`)+    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+                   ]

@@ -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

@@ -1,13 +1,85 @@+{-# 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.Widget.Box (alignText, centerText)+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@@ -38,3 +110,88 @@   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