tuispec (empty) → 0.1.0.0
raw patch · 17 files changed
+4346/−0 lines, 17 filesdep +aesondep +basedep +bytestringbinary-added
Dependencies added: aeson, base, bytestring, containers, directory, filepath, jsonrpc, optparse-applicative, posix-pty, process, tasty, tasty-hunit, text, time, tuispec, unix
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- README.md +218/−0
- SERVER.md +215/−0
- SKILL.md +172/−0
- SPEC.md +314/−0
- app/Main.hs +248/−0
- doc/example-board-ioskeley-light.png binary
- doc/example-dashboard-ioskeley-dark.png binary
- src/TuiSpec.hs +76/−0
- src/TuiSpec/ProjectRoot.hs +47/−0
- src/TuiSpec/Render.hs +262/−0
- src/TuiSpec/Runner.hs +1662/−0
- src/TuiSpec/Server.hs +746/−0
- src/TuiSpec/Types.hs +212/−0
- test/Spec.hs +45/−0
- tuispec.cabal +103/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0 — 2026-02-23++* Initial release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Matthias Pall Gissurarson++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,218 @@+# tuispec++[](https://hackage.haskell.org/package/tuispec)+[](LICENSE)++Playwright-like black-box testing for terminal UIs over PTY.++`tuispec` is a Haskell library that lets you write reliable TUI tests as normal+Haskell programs. Interact with any terminal application via PTY — send+keystrokes, wait for text, and capture snapshots — without instrumenting the+target app.++## Example output++Snapshots captured from the included [Brick demo app](example/app/Main.hs)+using `tuispec`:+++++## Features++- **PTY transport** — tests interact with real terminal apps over PTY+- **Per-test isolation** — fresh PTY process per test, no shared state+- **Snapshot assertions** — baseline comparison with ANSI text + PNG artifacts+- **Text selectors** — `Exact`, `Regex`, `At`, `Within`, `Nth`+- **`tasty` integration** — tests are regular `tasty` test trees+- **JSON-RPC server** — agentic orchestration of TUIs via `tuispec server`+- **REPL sessions** — ad-hoc exploration with `withTuiSession`++## Quick start++Add `tuispec` to your `build-depends` and write a test:++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Test.Tasty (defaultMain, testGroup)+import TuiSpec++main :: IO ()+main =+ defaultMain $ testGroup "demo"+ [ tuiTest defaultRunOptions "counter" $ \tui -> do+ launch tui (App "my-tui" [])+ waitForText tui (Exact "Ready")+ press tui (CharKey '+')+ expectSnapshot tui "counter-updated"+ press tui (CharKey 'q')+ ]+```++Run:++```bash+cabal test+```++## Building from source++```bash+cabal build+```++Run root smoke tests:++```bash+cabal test+```++Run the Brick demo integration suite:++```bash+cd example+cabal test+```++## DSL overview++### Actions++```haskell+launch :: Tui -> App -> IO ()+press :: Tui -> Key -> IO ()+pressCombo :: Tui -> [Modifier] -> Key -> IO ()+typeText :: Tui -> Text -> IO ()+sendLine :: Tui -> Text -> IO ()+```++### Waits and assertions++```haskell+waitForText :: Tui -> Selector -> IO ()+expectVisible :: Tui -> Selector -> IO ()+expectNotVisible :: Tui -> Selector -> IO ()+expectSnapshot :: Tui -> SnapshotName -> IO ()+dumpView :: Tui -> SnapshotName -> IO FilePath+```++### Selectors++```haskell+Exact Text -- exact substring match+Regex Text -- lightweight regex (|, .*, literal parens stripped)+At Int Int -- position-based (col, row)+Within Rect Selector -- restrict to a rectangle+Nth Int Selector -- pick the Nth match+```++### Keys++Named keys: `Enter`, `Esc`, `Tab`, `Backspace`, arrows, `FunctionKey 1..12`++Character keys: `CharKey c`, `Ctrl c`, `AltKey c`++Combos: `pressCombo [Control] (CharKey 'c')`++## Snapshots++For a test named `my test` (slug: `my-test`) with `artifactsDir = "artifacts"`:++- **Baselines**: `artifacts/snapshots/my-test/<snapshot>.ansi.txt`+- **Per-run**: `artifacts/tests/my-test/snapshots/<snapshot>.ansi.txt`++Render any ANSI snapshot to PNG:++```bash+cabal run tuispec -- render artifacts/tests/my-test/snapshots/<snapshot>.ansi.txt+```++Specify an explicit font file:++```bash+cabal run tuispec -- render --font /path/to/YourMono.ttf artifacts/tests/my-test/snapshots/<snapshot>.ansi.txt+```++Render visible plain text:++```bash+cabal run tuispec -- render-text artifacts/tests/my-test/snapshots/<snapshot>.ansi.txt+```++## JSON-RPC server++```bash+cabal run tuispec -- server --artifact-dir artifacts/server+```++Newline-delimited JSON-RPC 2.0 on stdin/stdout for agentic orchestration of+TUIs. See [SERVER.md](SERVER.md) for the full protocol reference.++Ping example:++```bash+printf '%s\n' \+ '{"jsonrpc":"2.0","id":1,"method":"server.ping","params":{}}' \+ | cabal run tuispec -- server --artifact-dir artifacts/server+```++End-to-end session example:++```bash+cat <<'JSON' | cabal run tuispec -- server --artifact-dir artifacts/server+{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"name":"rpc-demo","terminalCols":134,"terminalRows":40}}+{"jsonrpc":"2.0","id":2,"method":"launch","params":{"command":"sh","args":[]}}+{"jsonrpc":"2.0","id":3,"method":"sendLine","params":{"text":"printf 'hello from rpc\\n'"}}+{"jsonrpc":"2.0","id":4,"method":"waitForText","params":{"selector":{"type":"exact","text":"hello from rpc"}}}+{"jsonrpc":"2.0","id":5,"method":"dumpView","params":{"name":"after-hello"}}+{"jsonrpc":"2.0","id":6,"method":"server.shutdown","params":{}}+JSON+```++Input examples:++```json+{"jsonrpc":"2.0","id":7,"method":"sendKey","params":{"key":"+"}}+{"jsonrpc":"2.0","id":8,"method":"sendKey","params":{"key":"Ctrl+C"}}+{"jsonrpc":"2.0","id":9,"method":"sendText","params":{"text":"hello"}}+```++## REPL-style sessions++For ad-hoc exploration outside `tasty`:++```haskell+withTuiSession defaultRunOptions "demo" $ \tui -> do+ launch tui (App "sh" [])+ sendLine tui "echo hello"+ _ <- dumpView tui "step-1"+ pure ()+```++## Configuration++`RunOptions` fields (all overridable via environment variables):++| Field | Default | Env var |+|---|---|---|+| `timeoutSeconds` | `5` | `TUISPEC_TIMEOUT_SECONDS` |+| `retries` | `0` | `TUISPEC_RETRIES` |+| `stepRetries` | `0` | `TUISPEC_STEP_RETRIES` |+| `terminalCols` | `134` | `TUISPEC_TERMINAL_COLS` |+| `terminalRows` | `40` | `TUISPEC_TERMINAL_ROWS` |+| `artifactsDir` | `"artifacts"` | `TUISPEC_ARTIFACTS_DIR` |+| `updateSnapshots` | `False` | `TUISPEC_UPDATE_SNAPSHOTS` |+| `ambiguityMode` | `FailOnAmbiguous` | `TUISPEC_AMBIGUITY_MODE` |+| `snapshotTheme` | `"auto"` | `TUISPEC_SNAPSHOT_THEME` |++## Requirements++- GHC 9.12++- Linux terminal environment (PTY-based)+- `python3` with Pillow for PNG rendering+- a host monospace TTF/TTC font (or pass `--font`, or `TUISPEC_FONT_PATH`)++## License++[MIT](LICENSE) — Matthias Pall Gissurarson
+ SERVER.md view
@@ -0,0 +1,215 @@+# `tuispec server` Reference++This document describes the implemented `tuispec server` JSON-RPC behavior.++## Goals++- Add `tuispec server` for interactive TUI orchestration over stdin/stdout.+- Speak JSON-RPC 2.0 using the Hackage package `jsonrpc` (module `JSONRPC`).+- Support one active PTY-backed session per server process.+- Expose methods matching the DSL surface so agents can drive TUIs interactively.+- Use `--artifact-dir` as the base output path for dumped views and metadata.++## Transport++- Framing: newline-delimited JSON objects (one JSON-RPC message per line).+- Input: stdin.+- Output: stdout.+- Mode: request/response for v1 (no server notifications).++## Dependency++- Add dependency: `jsonrpc` (package `jsonrpc`, module `JSONRPC`).+- Use protocol types/constants from `JSONRPC`:+ - `JSONRPCRequest`+ - `JSONRPCResponse`+ - `JSONRPCError`+ - `JSONRPCErrorInfo`+ - `RequestId`+ - `rPC_VERSION`+ - `pARSE_ERROR`+ - `iNVALID_REQUEST`+ - `mETHOD_NOT_FOUND`+ - `iNVALID_PARAMS`+ - `iNTERNAL_ERROR`++## CLI++Add command:++```bash+tuispec server --artifact-dir PATH [--cols N] [--rows N] [--timeout-seconds N] [--ambiguity-mode fail|first-visible]+```++Defaults:++- `cols = 134`+- `rows = 40`+- `timeout-seconds = 5`+- `ambiguity-mode = fail`++## Session Model++- Single active session at a time.+- Explicit session initialization method:+ - `initialize`+- Any non-lifecycle method requires an active session.++## Method Surface++### Lifecycle++- `initialize`+ - params:+ - `name` (optional, default `"session"`)+ - optional run overrides:+ - `timeoutSeconds`+ - `terminalCols`+ - `terminalRows`+ - `ambiguityMode`+ - `snapshotTheme`+ - `updateSnapshots`+ - result:+ - `sessionName`+ - `artifactRoot`+ - `rows`+ - `cols`++### Orchestration++- `launch`+ - params:+ - `command`+ - `args`++- `sendKey`+ - params:+ - `key` (string)+ - accepted forms:+ - `Enter`, `Esc`, `Tab`, `Backspace`+ - `ArrowUp`, `ArrowDown`, `ArrowLeft`, `ArrowRight`+ - `F1`..`F12`+ - `Ctrl+X`, `Alt+X`+ - single char like `"a"`++- `sendText`+ - params:+ - `text`++- `sendLine`+ - params:+ - `text`++- `currentView`+ - result:+ - `text`+ - `rows`+ - `cols`++- `dumpView`+ - params:+ - `name`+ - result:+ - `snapshotPath`+ - `metaPath`++### Assertions / waits++- `expectVisible`+ - params:+ - `selector`++- `expectNotVisible`+ - params:+ - `selector`++- `waitForText`+ - params:+ - `selector`+ - optional `timeoutMs`+ - optional `pollIntervalMs`++- `expectSnapshot`+ - params:+ - `name`+ - result:+ - `ok`+ - plus snapshot paths where available++### Server utility++- `server.ping`+ - result:+ - `pong: true`+ - `version`++- `server.shutdown`+ - result:+ - `shuttingDown: true`+ - then hard-shutdown:+ - send `SIGKILL` to active child process group+ - exit process immediately (no graceful wait)++## Signal behavior++- On `SIGHUP`, server does hard-shutdown:+ - send `SIGKILL` to active child process group+ - exit immediately++## Selector Encoding++Use tagged object format:++- exact:+ - `{"type":"exact","text":"Ready"}`+- regex:+ - `{"type":"regex","pattern":"Ready|Done"}`+- at:+ - `{"type":"at","col":10,"row":2}`+- within:+ - `{"type":"within","rect":{"col":0,"row":0,"width":40,"height":10},"selector":{...}}`+- nth:+ - `{"type":"nth","index":1,"selector":{...}}`++## Error Contract++JSON-RPC errors:++- parse failures: `pARSE_ERROR`+- invalid request: `iNVALID_REQUEST`+- unknown method: `mETHOD_NOT_FOUND`+- bad params: `iNVALID_PARAMS`+- internal failures: `iNTERNAL_ERROR`++Server-domain error codes:++- `-32001` `NoActiveSession`+- `-32002` `SessionAlreadyStarted`+- `-32004` `MethodFailed`++Error `data` should include:++- `kind`+- `details`+- optional `hint`++## Artifact Layout++With `--artifact-dir X` and session `foo`:++- `X/sessions/foo/snapshots/<name>.ansi.txt`+- `X/sessions/foo/snapshots/<name>.meta.json`++`dumpView` writes only run artifacts. +`expectSnapshot` keeps existing DSL baseline semantics unless changed later.++## Validation++- Build/tests:+ - `cabal build`+ - `cabal test`+ - `(cd example && cabal test)`+- Manual server smoke:+ - start `tuispec server`+ - send `initialize`, `launch`, `sendKey`, `dumpView`, `server.shutdown`+ - verify artifact files and response payloads
+ SKILL.md view
@@ -0,0 +1,172 @@+# REPL Workflow Skill for `tuispec`++This skill explains how to use `tuispec` as a REPL-like driver for TUIs:++1. launch a TUI+2. send commands/keys+3. periodically dump current view snapshots+4. render those snapshots as text/PNG++## What was added for REPL ergonomics++Use these APIs from `TuiSpec`:++- `withTuiSession`:+ creates an ad-hoc PTY session outside `tasty`+- `sendLine`:+ sends text + `Enter`+- `currentView`:+ returns current visible viewport text+- `dumpView`:+ writes the current screen to `<name>.ansi.txt` + `<name>.meta.json`++Relevant implementation:++- `src/TuiSpec/Runner.hs`+- `src/TuiSpec/Render.hs`++## Minimal REPL script++Create a Haskell program (for example `scratch/ReplDemo.hs`):++```haskell+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (threadDelay)+import TuiSpec++main :: IO ()+main =+ withTuiSession+ defaultRunOptions+ { artifactsDir = "artifacts/repl"+ , terminalCols = 134+ , terminalRows = 40+ }+ "demo-session"+ $ \tui -> do+ launch tui (App "sh" ["-lc", "tui-demo"])++ _ <- dumpView tui "00-initial"++ press tui (CharKey 'b')+ _ <- dumpView tui "01-board"++ sendLine tui "/help"+ _ <- dumpView tui "02-help"++ view <- currentView tui+ putStrLn "Current viewport:"+ putStrLn (take 1000 (show view))++ -- optional short settle pause between interactions+ threadDelay (150 * 1000)++ press tui (CharKey 'q')+```++Run it:++```bash+cabal run runghc -- -isrc scratch/ReplDemo.hs+```++## Where dumps go++For session name `demo-session` and `artifactsDir = artifacts/repl`:++- `artifacts/repl/sessions/demo-session/snapshots/00-initial.ansi.txt`+- `artifacts/repl/sessions/demo-session/snapshots/00-initial.meta.json`+- `artifacts/repl/sessions/demo-session/snapshots/01-board.ansi.txt`+- `...`++## Render dumps while iterating++Render to PNG:++```bash+cabal run tuispec -- render artifacts/repl/sessions/demo-session/snapshots/01-board.ansi.txt+```++Render to visible plain text:++```bash+cabal run tuispec -- render-text artifacts/repl/sessions/demo-session/snapshots/01-board.ansi.txt+```++Both commands auto-read rows/cols from `.meta.json`.++## Practical loop++1. run your REPL script+2. inspect generated `.txt`/`.png`+3. tweak interactions+4. run again++`withTuiSession` resets the session output directory each run, keeping artifact output simple and deterministic.++## JSONRPC server workflow++You can also orchestrate a TUI from an external client using:++```bash+cabal run tuispec -- server --artifact-dir artifacts/server+```++### Request format++- Send one JSON-RPC request per line on stdin.+- Read one JSON-RPC response per line on stdout.++### Shutdown semantics++- `server.shutdown` is a hard shutdown:+ - kills active TUI child process group with `SIGKILL`+ - exits server immediately (no graceful wait)+- On `SIGHUP`, the server does the same hard shutdown behavior:+ - `SIGKILL` to active child process group+ - immediate process exit++### Example session++Start server:++```bash+cabal run tuispec -- server --artifact-dir artifacts/server+```++Then send requests like:++```json+{"jsonrpc":"2.0","id":1,"method":"initialize","params":{"name":"demo"}}+{"jsonrpc":"2.0","id":2,"method":"launch","params":{"command":"sh","args":["-lc","tui-demo"]}}+{"jsonrpc":"2.0","id":3,"method":"sendKey","params":{"key":"ArrowDown"}}+{"jsonrpc":"2.0","id":4,"method":"sendKey","params":{"key":"Enter"}}+{"jsonrpc":"2.0","id":5,"method":"dumpView","params":{"name":"after-enter"}}+{"jsonrpc":"2.0","id":6,"method":"currentView","params":null}+{"jsonrpc":"2.0","id":7,"method":"server.shutdown","params":null}+```++### Supported key strings for `sendKey`++- `Enter`, `Esc`, `Tab`, `Backspace`+- `ArrowUp`, `ArrowDown`, `ArrowLeft`, `ArrowRight`+- `F1`..`F12`+- `Ctrl+X`, `Alt+X`, `Shift+X`+- single character like `"a"`++### Dump locations++For `initialize` name `demo`:++- `artifacts/server/sessions/demo/snapshots/<name>.ansi.txt`+- `artifacts/server/sessions/demo/snapshots/<name>.meta.json`++### Rendering dumped views++```bash+cabal run tuispec -- render artifacts/server/sessions/demo/snapshots/after-enter.ansi.txt+cabal run tuispec -- render-text artifacts/server/sessions/demo/snapshots/after-enter.ansi.txt+```
+ SPEC.md view
@@ -0,0 +1,314 @@+# tuispec Specification++Last updated: 2026-02-23+Status: current implementation++## 1. Purpose++`tuispec` is a Haskell framework for black-box testing of terminal UIs (TUIs) over PTY.++Primary goals:+- let developers write reliable TUI tests as normal Haskell programs+- make tests agent-friendly (explicit actions, explicit waits, deterministic artifacts)+- keep transport generic (no framework instrumentation inside the target app)++## 2. Platform and Scope++In scope:+- Linux terminal environments+- PTY-backed app execution+- single viewport per test/session+- text assertions and snapshots (`.ansi.txt` + metadata, optional PNG rendering)+- `tasty` integration (`tuiTest`)+- ad-hoc session mode (`withTuiSession`) for REPL-like workflows+- JSON-RPC server for interactive orchestration (`tuispec server`)++Out of scope:+- Windows/macOS support+- browser/web UI for reports+- multi-pane orchestration+- in-process hooks into TUI frameworks++## 3. Core Model++Main public modules:+- `TuiSpec`+- `TuiSpec.Types`+- `TuiSpec.Runner`+- `TuiSpec.Render`++Key data types:+- `RunOptions`: runtime and artifact behavior+- `App`: target command + args+- `Key` / `Modifier`: input model+- `Selector`: viewport query model+- `WaitOptions`: polling behavior+- `SnapshotName`: typed snapshot id+- `Tui`: runtime handle passed to DSL actions++Default `RunOptions`:+- `timeoutSeconds = 5`+- `retries = 0`+- `stepRetries = 0`+- `terminalCols = 134`+- `terminalRows = 40`+- `artifactsDir = "artifacts"`+- `ambiguityMode = FailOnAmbiguous`+- `updateSnapshots = False`+- `snapshotTheme = "auto"`++## 4. DSL Language (Shallow Haskell DSL)++### 4.1 Test DSL style++Tests are plain Haskell code, usually with `tasty`:++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Test.Tasty (defaultMain, testGroup)+import TuiSpec++main :: IO ()+main =+ defaultMain $ testGroup "suite"+ [ tuiTest defaultRunOptions "counter" $ \tui -> do+ launch tui (App "my-tui" [])+ waitForText tui (Exact "Ready")+ press tui (CharKey '+')+ expectSnapshot tui "counter-updated"+ ]+```++### 4.2 Session DSL (non-`tasty`)++Use `withTuiSession` for interactive scripts/tools:++```haskell+withTuiSession defaultRunOptions "demo" $ \tui -> do+ launch tui (App "sh" [])+ sendLine tui "echo hello"+ _ <- dumpView tui "hello"+ pure ()+```++### 4.3 Actions++- `launch :: Tui -> App -> IO ()`+- `press :: Tui -> Key -> IO ()`+- `pressCombo :: Tui -> [Modifier] -> Key -> IO ()`+- `typeText :: Tui -> Text -> IO ()`+- `sendLine :: Tui -> Text -> IO ()`++`launch` replaces any currently running app for that `Tui` handle.++### 4.4 Waits and assertions++- `waitFor :: Tui -> WaitOptions -> (Viewport -> Bool) -> IO ()`+- `waitForText :: Tui -> Selector -> IO ()`+- `waitForSelector :: Tui -> WaitOptions -> Selector -> IO ()`+- `expectVisible :: Tui -> Selector -> IO ()`+- `expectNotVisible :: Tui -> Selector -> IO ()`++Behavior:+- polling-based+- default poll interval: `100ms`+- `waitForText` / `expectVisible` use `timeoutSeconds` from `RunOptions`+- ambiguity checking runs after positive selector match++### 4.5 Selector language++`Selector` constructors:+- `Exact Text`+- `Regex Text`+- `At Int Int`+- `Within Rect Selector`+- `Nth Int Selector`++`Regex` semantics are intentionally lightweight, not full PCRE:+- supports alternation via `|`+- supports wildcard segmenting via `.*`+- strips literal `(` and `)` during matching++Ambiguity mode:+- `FailOnAmbiguous`: fail if selector has multiple matches (except explicit `At`/`Nth`)+- `FirstVisibleMatch`: tolerate multiple matches++### 4.6 Input key model++`Key` supports:+- named keys: `Enter`, `Esc`, `Tab`, `Backspace`+- arrows: `ArrowUp`, `ArrowDown`, `ArrowLeft`, `ArrowRight`+- function keys: `FunctionKey 1..12`+- char-oriented keys: `CharKey c`, `Ctrl c`, `AltKey c`, `NamedKey text`++`pressCombo` supports current mappings:+- `[Control] + CharKey c`+- `[Alt] + CharKey c`+- `[Shift] + CharKey c`++### 4.7 Snapshot DSL++- `expectSnapshot :: Tui -> SnapshotName -> IO ()`+- `dumpView :: Tui -> SnapshotName -> IO FilePath`++`expectSnapshot`:+- captures current ANSI buffer into test artifacts+- compares against baseline in `artifacts/snapshots/<test-slug>/`+- creates baseline when missing or when `updateSnapshots = True`++`dumpView`:+- captures only run artifact (no baseline compare)+- used for exploratory workflows and server orchestration++Both produce:+- `<name>.ansi.txt`+- `<name>.meta.json` (`rows`, `cols`)++## 5. Retry and Timeout Semantics++Test-level retry:+- `retries` in `RunOptions` means `retries + 1` attempts+- each attempt gets clean test artifact directory state++Step-level retry:+- `step :: StepOptions -> String -> IO a -> IO a`+- `stepMaxRetries` and `stepRetryDelayMs`++Hard test timeout:+- each test body is wrapped with `timeoutSeconds`++## 6. Environment Overrides++`RunOptions` can be overridden by env vars:+- `TUISPEC_TIMEOUT_SECONDS`+- `TUISPEC_RETRIES`+- `TUISPEC_STEP_RETRIES`+- `TUISPEC_TERMINAL_COLS`+- `TUISPEC_TERMINAL_ROWS`+- `TUISPEC_ARTIFACTS_DIR`+- `TUISPEC_UPDATE_SNAPSHOTS`+- `TUISPEC_AMBIGUITY_MODE` (`fail|first|first-visible`)+- `TUISPEC_SNAPSHOT_THEME`++Root/path helpers:+- `TUISPEC_PROJECT_ROOT` overrides project root detection++Theme auto-resolution:+- when theme is `auto`, background is inferred from `COLORFGBG` when available+- fallback is dark (`pty-default-dark`)++## 7. Artifact Layout++For test slug `my-test` under `artifactsDir`:++- test attempt snapshots:+ - `artifacts/tests/my-test/snapshots/<snapshot>.ansi.txt`+ - `artifacts/tests/my-test/snapshots/<snapshot>.meta.json`++- baseline snapshots:+ - `artifacts/snapshots/my-test/<snapshot>.ansi.txt`+ - `artifacts/snapshots/my-test/<snapshot>.meta.json`++For ad-hoc sessions (`withTuiSession "session-name"`):+- `artifacts/sessions/session-name/snapshots/<snapshot>.ansi.txt`+- `artifacts/sessions/session-name/snapshots/<snapshot>.meta.json`++Console summary includes snapshot artifact paths on test completion.++## 8. Rendering++CLI command: `tuispec render`+- input: ANSI snapshot (`.ansi.txt`)+- output: PNG+- metadata (`rows`, `cols`) auto-loaded from adjacent `.meta.json`+- optional overrides: `--rows`, `--cols`, `--theme`, `--font`++CLI command: `tuispec render-text`+- input: ANSI snapshot+- output: visible viewport text+- same metadata and optional size overrides++PNG renderer implementation details:+- uses `python3` + Pillow+- resolves font in this order:+ - `--font`+ - `TUISPEC_FONT_PATH`+ - built-in system fallback font paths++## 9. JSON-RPC Server++CLI command:++```bash+tuispec server --artifact-dir PATH [--cols N] [--rows N] [--timeout-seconds N] [--ambiguity-mode fail|first-visible]+```++Transport:+- newline-delimited JSON-RPC 2.0 on stdin/stdout++Session model:+- one active session at a time+- initialize with `initialize`+- all non-initialize methods require an active session++Methods:+- `initialize`+- `launch`+- `sendKey`+- `sendText`+- `sendLine`+- `currentView`+- `dumpView`+- `expectSnapshot`+- `waitForText`+- `expectVisible`+- `expectNotVisible`+- `server.ping`+- `server.shutdown`++Server error codes:+- JSON-RPC standard: parse / invalid request / method not found / invalid params+- server domain:+ - `-32001` no active session+ - `-32002` session already started+ - `-32004` method failed++### 9.1 `sendKey` format++Accepted string forms:+- base: `Enter`, `Esc`, `Tab`, `Backspace`, arrows, `F1..F12`, single char+- combos: `Ctrl+X`, `Alt+X`, `Shift+X`++### 9.2 Selector JSON format++```json+{"type":"exact","text":"Ready"}+{"type":"regex","pattern":"Ready|Done"}+{"type":"at","col":10,"row":2}+{"type":"within","rect":{"col":0,"row":0,"width":40,"height":10},"selector":{"type":"exact","text":"Ready"}}+{"type":"nth","index":1,"selector":{"type":"exact","text":"Task"}}+```++### 9.3 Shutdown semantics++`server.shutdown`:+- sends `SIGKILL` to active child process group+- exits server immediately+- does not wait for graceful teardown++`SIGHUP` handling:+- same behavior as hard shutdown (`SIGKILL` + immediate exit)++## 10. Test Runner Contract++- `tuiTest` is the canonical integration point for `tasty`+- tests are black-box: interaction only via PTY I/O and visible viewport state+- tests are isolated by fresh PTY launch lifecycle per test+- framework remains generic to any TUI binary runnable from shell++## 11. Related docs++- `README.md`: usage overview and quick-start+- `SKILL.md`: REPL and server operator workflow+- `SERVER.md`: server protocol reference
+ app/Main.hs view
@@ -0,0 +1,248 @@+module Main where++import Data.List (isSuffixOf)+import Options.Applicative+import Text.Read (readMaybe)+import TuiSpec.Render (renderAnsiSnapshotFileWithFont, renderAnsiSnapshotTextFile)+import TuiSpec.Server qualified as Server+import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch))++data Command+ = Render RenderOptions+ | RenderText RenderTextOptions+ | Server ServerOptions++data RenderOptions = RenderOptions+ { inputPath :: FilePath+ , outputPath :: Maybe FilePath+ , themeName :: Maybe String+ , fontPath :: Maybe FilePath+ , cols :: Maybe Int+ , rows :: Maybe Int+ }++data RenderTextOptions = RenderTextOptions+ { textInputPath :: FilePath+ , textOutputPath :: Maybe FilePath+ , textCols :: Maybe Int+ , textRows :: Maybe Int+ }++data ServerOptions = ServerOptions+ { artifactDir :: FilePath+ , serverCols :: Int+ , serverRows :: Int+ , timeoutSeconds :: Int+ , ambiguity :: AmbiguityMode+ }++main :: IO ()+main = do+ parsedCommand <- execParser commandParserInfo+ runCommand parsedCommand++runCommand :: Command -> IO ()+runCommand parsedCommand =+ case parsedCommand of+ Render options -> do+ let outPath = maybe (defaultOutputPath (inputPath options)) id (outputPath options)+ renderAnsiSnapshotFileWithFont (fontPath options) (rows options) (cols options) (themeName options) (inputPath options) outPath+ putStrLn ("Rendered " <> outPath)+ RenderText options -> do+ let outPath = maybe (defaultTextOutputPath (textInputPath options)) id (textOutputPath options)+ renderAnsiSnapshotTextFile (textRows options) (textCols options) (textInputPath options) outPath+ putStrLn ("Rendered " <> outPath)+ Server options ->+ Server.runServer+ Server.ServerOptions+ { Server.serverArtifactsDir = artifactDir options+ , Server.serverTerminalCols = serverCols options+ , Server.serverTerminalRows = serverRows options+ , Server.serverTimeoutSeconds = timeoutSeconds options+ , Server.serverAmbiguityMode = ambiguity options+ }++commandParserInfo :: ParserInfo Command+commandParserInfo =+ info+ (parseCommand <**> helper)+ ( fullDesc+ <> progDesc "Render ANSI snapshot artifacts to PNG"+ <> header "tuispec"+ )++parseCommand :: Parser Command+parseCommand =+ hsubparser+ ( command+ "render"+ ( info+ (Render <$> parseRenderOptions)+ (progDesc "Render a .ansi.txt snapshot file")+ )+ <> command+ "render-text"+ ( info+ (RenderText <$> parseRenderTextOptions)+ (progDesc "Render visible plain text from a .ansi.txt snapshot file using terminal emulation")+ )+ <> command+ "server"+ ( info+ (Server <$> parseServerOptions)+ (progDesc "Run JSON-RPC server on stdin/stdout for interactive TUI orchestration")+ )+ )++parseRenderOptions :: Parser RenderOptions+parseRenderOptions =+ RenderOptions+ <$> argument+ str+ ( metavar "SNAPSHOT_ANSI_TXT"+ <> help "Path to snapshot ANSI file"+ )+ <*> optional+ ( strOption+ ( long "out"+ <> metavar "OUTPUT_PNG"+ <> help "Output PNG path"+ )+ )+ <*> optional+ ( strOption+ ( long "theme"+ <> metavar "THEME"+ <> help "Theme override: auto|dark|light (default: metadata, then auto)"+ )+ )+ <*> optional+ ( strOption+ ( long "font"+ <> metavar "FONT_PATH"+ <> help "TTF/TTC font path override for PNG rendering (default: system fallback fonts)"+ )+ )+ <*> optional+ ( option+ positiveIntReader+ ( long "cols"+ <> metavar "N"+ <> help "Viewport columns override (default: metadata, then 134)"+ )+ )+ <*> optional+ ( option+ positiveIntReader+ ( long "rows"+ <> metavar "N"+ <> help "Viewport rows override (default: metadata, then 40)"+ )+ )++parseRenderTextOptions :: Parser RenderTextOptions+parseRenderTextOptions =+ RenderTextOptions+ <$> argument+ str+ ( metavar "SNAPSHOT_ANSI_TXT"+ <> help "Path to snapshot ANSI file"+ )+ <*> optional+ ( strOption+ ( long "out"+ <> metavar "OUTPUT_TXT"+ <> help "Output plain text path"+ )+ )+ <*> optional+ ( option+ positiveIntReader+ ( long "cols"+ <> metavar "N"+ <> help "Viewport columns override (default: metadata, then 134)"+ )+ )+ <*> optional+ ( option+ positiveIntReader+ ( long "rows"+ <> metavar "N"+ <> help "Viewport rows override (default: metadata, then 40)"+ )+ )++parseServerOptions :: Parser ServerOptions+parseServerOptions =+ ServerOptions+ <$> strOption+ ( long "artifact-dir"+ <> metavar "PATH"+ <> help "Artifacts directory base path for server sessions"+ )+ <*> option+ positiveIntReader+ ( long "cols"+ <> metavar "N"+ <> help "Default terminal columns"+ <> value 134+ <> showDefault+ )+ <*> option+ positiveIntReader+ ( long "rows"+ <> metavar "N"+ <> help "Default terminal rows"+ <> value 40+ <> showDefault+ )+ <*> option+ positiveIntReader+ ( long "timeout-seconds"+ <> metavar "N"+ <> help "Default timeout seconds"+ <> value 5+ <> showDefault+ )+ <*> option+ ambiguityModeReader+ ( long "ambiguity-mode"+ <> metavar "MODE"+ <> help "Default ambiguity mode: fail|first-visible"+ <> value FailOnAmbiguous+ <> showDefaultWith renderAmbiguityMode+ )++positiveIntReader :: ReadM Int+positiveIntReader =+ eitherReader $ \raw ->+ case readMaybe raw :: Maybe Int of+ Just parsed | parsed > 0 -> Right parsed+ _ -> Left "Expected a positive integer"++ambiguityModeReader :: ReadM AmbiguityMode+ambiguityModeReader =+ eitherReader $ \raw ->+ case raw of+ "fail" -> Right FailOnAmbiguous+ "first-visible" -> Right FirstVisibleMatch+ "first" -> Right FirstVisibleMatch+ _ -> Left "Expected ambiguity mode: fail|first-visible"++renderAmbiguityMode :: AmbiguityMode -> String+renderAmbiguityMode mode =+ case mode of+ FailOnAmbiguous -> "fail"+ FirstVisibleMatch -> "first-visible"++defaultOutputPath :: FilePath -> FilePath+defaultOutputPath input =+ if ".ansi.txt" `isSuffixOf` input+ then take (length input - length (".ansi.txt" :: String)) input <> ".png"+ else input <> ".png"++defaultTextOutputPath :: FilePath -> FilePath+defaultTextOutputPath input =+ if ".ansi.txt" `isSuffixOf` input+ then take (length input - length (".ansi.txt" :: String)) input <> ".txt"+ else input <> ".txt"
+ doc/example-board-ioskeley-light.png view
binary file changed (absent → 21333 bytes)
+ doc/example-dashboard-ioskeley-dark.png view
binary file changed (absent → 18664 bytes)
+ src/TuiSpec.hs view
@@ -0,0 +1,76 @@+{- |+Module : TuiSpec+Description : Public API for black-box TUI testing over PTY.++This is the primary entry point for test programs. Import this module+to get the full testing DSL:++@+import TuiSpec++main :: IO ()+main =+ defaultMain $ testGroup "demo"+ [ tuiTest defaultRunOptions "my test" $ \\tui -> do+ launch tui (App "my-app" [])+ waitForText tui (Exact "Ready")+ press tui (CharKey 'q')+ ]+@++For advanced integrations (JSON-RPC server, session management), import+"TuiSpec.Runner" and "TuiSpec.Types" directly.+-}+module TuiSpec (+ -- * Test entry point+ tuiTest,+ withTuiSession,++ -- * Actions+ launch,+ press,+ pressCombo,+ typeText,+ sendLine,++ -- * Waits and assertions+ waitFor,+ waitForText,+ waitForSelector,+ expectVisible,+ expectNotVisible,++ -- * Snapshots+ expectSnapshot,+ dumpView,+ currentView,++ -- * Steps+ step,++ -- * Rendering+ renderAnsiViewportText,+ renderAnsiSnapshotTextFile,++ -- * Configuration types+ RunOptions (..),+ defaultRunOptions,+ App (..),+ Key (..),+ Modifier (..),+ Selector (..),+ Rect (..),+ SnapshotName (..),+ AmbiguityMode (..),+ WaitOptions (..),+ StepOptions (..),+ defaultStepOptions,+ Viewport (..),++ -- * Runtime handle (opaque)+ Tui,+) where++import TuiSpec.Render (renderAnsiSnapshotTextFile)+import TuiSpec.Runner+import TuiSpec.Types
+ src/TuiSpec/ProjectRoot.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : TuiSpec.ProjectRoot+Description : Shared helpers for resolving the active project root.+-}+module TuiSpec.ProjectRoot (+ resolveProjectRoot,+) where++import Control.Exception (SomeException, catch)+import Data.List (isSuffixOf)+import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory)+import System.Environment (lookupEnv)+import System.FilePath (takeDirectory, (</>))++resolveProjectRoot :: IO FilePath+resolveProjectRoot = do+ projectRootOverride <- lookupEnv "TUISPEC_PROJECT_ROOT"+ case projectRootOverride of+ Just override -> canonicalizePath override+ Nothing -> do+ cwd <- getCurrentDirectory+ locateProjectRoot cwd++locateProjectRoot :: FilePath -> IO FilePath+locateProjectRoot startDir = do+ absoluteStart <- canonicalizePath startDir+ go absoluteStart absoluteStart+ where+ go startRoot currentDir = do+ markerPresent <- hasProjectMarker currentDir+ if markerPresent+ then pure currentDir+ else do+ let parentDir = takeDirectory currentDir+ if parentDir == currentDir+ then pure startRoot+ else go startRoot parentDir++hasProjectMarker :: FilePath -> IO Bool+hasProjectMarker dir = do+ hasGit <- doesDirectoryExist (dir </> ".git")+ hasCabalProject <- doesFileExist (dir </> "cabal.project")+ entries <- listDirectory dir `catch` \(_ :: SomeException) -> pure []+ let hasCabalFile = any (".cabal" `isSuffixOf`) entries+ pure (hasGit || hasCabalProject || hasCabalFile)
+ src/TuiSpec/Render.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : TuiSpec.Render+Description : Render snapshot ANSI artifacts as PNG or plain text.++Both render paths auto-detect viewport size from adjacent @.meta.json@+files produced by 'TuiSpec.Runner.expectSnapshot'. Explicit CLI overrides+can still be supplied when needed.+-}+module TuiSpec.Render (+ renderAnsiSnapshotFile,+ renderAnsiSnapshotFileWithFont,+ renderAnsiSnapshotTextFile,+) where++import Control.Applicative ((<|>))+import Control.Exception (SomeException, catch, throwIO)+import Data.Aeson (FromJSON (parseJSON), eitherDecode, withObject, (.:))+import Data.ByteString.Lazy qualified as BL+import Data.Char (toLower)+import Data.List (intercalate, isSuffixOf)+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)+import System.Environment (lookupEnv)+import System.Exit (ExitCode (ExitSuccess))+import System.FilePath (takeDirectory)+import System.IO (hClose, openTempFile)+import System.Process (proc, readCreateProcessWithExitCode)+import Text.Read (readMaybe)+import TuiSpec.Runner (renderAnsiViewportText, serializeAnsiSnapshot)+import TuiSpec.Types (defaultRunOptions, terminalCols, terminalRows)++{- | Render an ANSI snapshot file to PNG.++Size resolution order for rows/cols:++1. explicit overrides+2. adjacent @.meta.json@+3. 'defaultRunOptions'++Theme is rendering-only and defaults to @auto@ when omitted.+-}+renderAnsiSnapshotFile :: Maybe Int -> Maybe Int -> Maybe String -> FilePath -> FilePath -> IO ()+renderAnsiSnapshotFile rowOverride colOverride themeOverride ansiPath outPath = do+ renderAnsiSnapshotFileWithFont Nothing rowOverride colOverride themeOverride ansiPath outPath++renderAnsiSnapshotFileWithFont :: Maybe FilePath -> Maybe Int -> Maybe Int -> Maybe String -> FilePath -> FilePath -> IO ()+renderAnsiSnapshotFileWithFont maybeFontPath rowOverride colOverride themeOverride ansiPath outPath = do+ ansiText <- TIO.readFile ansiPath+ (rows, cols, effectiveTheme) <- resolveRenderOptions rowOverride colOverride themeOverride ansiPath+ let payload = serializeAnsiSnapshot rows cols effectiveTheme ansiText+ fontPath <- resolveFontPath maybeFontPath+ createDirectoryIfMissing True (takeDirectory outPath)+ (tmpInPath, tmpHandle) <- openTempFile (takeDirectory outPath) "snapshot-styled-"+ TIO.hPutStr tmpHandle (T.pack payload)+ hClose tmpHandle+ let args = ["-c", pythonStyledRenderScript, tmpInPath, outPath, fontPath]+ result <- readCreateProcessWithExitCode (proc "python3" args) ""+ ignoreIOError (removeFile tmpInPath)+ case result of+ (ExitSuccess, _, _) -> pure ()+ (_, _, stderrText) ->+ throwIO+ (userError ("Failed to render styled PNG (python3 + Pillow required in PATH). " <> stderrText))++{- | Render an ANSI snapshot file to visible plain text.++This replays ANSI into the same emulator used by snapshot comparison and+therefore preserves terminal layout semantics better than naive escape+stripping.+-}+renderAnsiSnapshotTextFile :: Maybe Int -> Maybe Int -> FilePath -> FilePath -> IO ()+renderAnsiSnapshotTextFile rowOverride colOverride ansiPath outPath = do+ ansiText <- TIO.readFile ansiPath+ (rows, cols, _theme) <- resolveRenderOptions rowOverride colOverride Nothing ansiPath+ createDirectoryIfMissing True (takeDirectory outPath)+ TIO.writeFile outPath (renderAnsiViewportText rows cols ansiText)++resolveRenderOptions :: Maybe Int -> Maybe Int -> Maybe String -> FilePath -> IO (Int, Int, String)+resolveRenderOptions rowOverride colOverride themeOverride ansiPath = do+ metadata <- loadSnapshotMetadata ansiPath+ colorFgBgValue <- lookupEnv "COLORFGBG"+ let fallbackRows = terminalRows defaultRunOptions+ let fallbackCols = terminalCols defaultRunOptions+ let metadataRowsValue = metadataRows <$> metadata+ let metadataColsValue = metadataCols <$> metadata+ let rows =+ fromMaybe fallbackRows $+ case rowOverride of+ Just value -> Just value+ Nothing -> metadataRowsValue+ let cols =+ fromMaybe fallbackCols $+ case colOverride of+ Just value -> Just value+ Nothing -> metadataColsValue+ let requestedTheme = fromMaybe "auto" themeOverride+ let effectiveTheme = resolveAutoSnapshotTheme requestedTheme colorFgBgValue+ pure (rows, cols, effectiveTheme)++data SnapshotMetadata = SnapshotMetadata+ { metadataRows :: Int+ , metadataCols :: Int+ }++instance FromJSON SnapshotMetadata where+ parseJSON =+ withObject "SnapshotMetadata" $ \objectValue ->+ SnapshotMetadata+ <$> objectValue .: "rows"+ <*> objectValue .: "cols"++loadSnapshotMetadata :: FilePath -> IO (Maybe SnapshotMetadata)+loadSnapshotMetadata ansiPath = do+ let metadataPath = snapshotMetadataPath ansiPath+ exists <- doesFileExist metadataPath+ if not exists+ then pure Nothing+ else do+ metadataBytes <- BL.readFile metadataPath+ pure $+ case eitherDecode metadataBytes of+ Left _ -> Nothing+ Right metadataValue+ | metadataRows metadataValue > 0+ && metadataCols metadataValue > 0 ->+ Just metadataValue+ Right _ -> Nothing++snapshotMetadataPath :: FilePath -> FilePath+snapshotMetadataPath ansiPath =+ if ".ansi.txt" `isSuffixOf` ansiPath+ then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"+ else ansiPath <> ".meta.json"++pythonStyledRenderScript :: String+pythonStyledRenderScript =+ unlines+ [ "import json"+ , "import sys"+ , "from PIL import Image, ImageDraw, ImageFont"+ , "inp, out = sys.argv[1], sys.argv[2]"+ , "font_path = sys.argv[3]"+ , "font = ImageFont.truetype(font_path, 12)"+ , "with open(inp, 'r', encoding='utf-8', errors='replace') as f:"+ , " payload = json.load(f)"+ , "rows = payload['rows']"+ , "cols = payload['cols']"+ , "cells = payload['cells']"+ , "default_bg = tuple(payload.get('defaultBg', (13, 17, 23)))"+ , "probe = font.getbbox('Hg')"+ , "line_h = max(1, (probe[3] - probe[1]) + 2)"+ , "cell_w = max(1, (font.getbbox('W')[2] - font.getbbox('W')[0]))"+ , "padding_x = 1"+ , "padding_y = 1"+ , "width = max(1, cols * cell_w + (padding_x * 2))"+ , "height = max(1, rows * line_h + (padding_y * 2))"+ , "img = Image.new('RGB', (width, height), default_bg)"+ , "draw = ImageDraw.Draw(img)"+ , "y = padding_y"+ , "for row_idx in range(rows):"+ , " x = padding_x"+ , " row = cells[row_idx] if row_idx < len(cells) else []"+ , " for col_idx in range(cols):"+ , " cell = row[col_idx] if col_idx < len(row) else [32, payload.get('defaultFg', [229, 229, 229]), list(default_bg)]"+ , " if len(cell) != 3:"+ , " continue"+ , " ch = chr(cell[0])"+ , " fg = tuple(cell[1])"+ , " bg = tuple(cell[2])"+ , " rect = (x, y, x + cell_w, y + line_h)"+ , " draw.rectangle(rect, fill=bg)"+ , " draw.text((x, y), ch, fill=fg, font=font)"+ , " x += cell_w"+ , " y += line_h"+ , "img.save(out, 'PNG')"+ ]++resolveFontPath :: Maybe FilePath -> IO FilePath+resolveFontPath maybeFontPath = do+ envFont <- lookupEnv "TUISPEC_FONT_PATH"+ case maybeFontPath <|> envFont of+ Just pathValue -> do+ exists <- doesFileExist pathValue+ if exists+ then pure pathValue+ else+ throwIO+ ( userError+ ( "Font not found at "+ <> pathValue+ <> ". Pass --font PATH or set TUISPEC_FONT_PATH to a valid file."+ )+ )+ Nothing -> do+ maybeFont <- findFirstExistingPath defaultFallbackFontPaths+ case maybeFont of+ Just fontPath -> pure fontPath+ Nothing ->+ throwIO+ ( userError+ ( "Font not found. Looked for: "+ <> intercalate ", " defaultFallbackFontPaths+ <> ". Pass --font PATH or set TUISPEC_FONT_PATH to override."+ )+ )++findFirstExistingPath :: [FilePath] -> IO (Maybe FilePath)+findFirstExistingPath paths =+ case paths of+ [] -> pure Nothing+ candidate : rest -> do+ exists <- doesFileExist candidate+ if exists+ then pure (Just candidate)+ else findFirstExistingPath rest++defaultFallbackFontPaths :: [FilePath]+defaultFallbackFontPaths =+ [ "/usr/share/fonts/truetype/dejavu/DejaVuSansMono.ttf"+ , "/usr/share/fonts/dejavu/DejaVuSansMono.ttf"+ , "/usr/share/fonts/TTF/DejaVuSansMono.ttf"+ , "/usr/share/fonts/truetype/liberation2/LiberationMono-Regular.ttf"+ , "/usr/share/fonts/liberation/LiberationMono-Regular.ttf"+ , "/System/Library/Fonts/Menlo.ttc"+ , "/Library/Fonts/Menlo.ttc"+ ]++resolveAutoSnapshotTheme :: String -> Maybe String -> String+resolveAutoSnapshotTheme requestedTheme colorFgBgValue =+ case map toLower requestedTheme of+ "auto" ->+ case detectTerminalBackground colorFgBgValue of+ Just "light" -> "pty-default-light"+ _ -> "pty-default-dark"+ _ -> requestedTheme++detectTerminalBackground :: Maybe String -> Maybe String+detectTerminalBackground colorFgBgValue =+ case colorFgBgValue >>= parseBgIndex of+ Just bgIndex | bgIndex >= 7 -> Just "light"+ Just _ -> Just "dark"+ Nothing -> Nothing+ where+ parseBgIndex raw =+ case reverse (splitOn ';' raw) of+ [] -> Nothing+ lastPart : _ -> (readMaybe lastPart :: Maybe Int)++ splitOn _ [] = [""]+ splitOn delimiter input =+ case break (== delimiter) input of+ (headPart, []) -> [headPart]+ (headPart, _ : rest) -> headPart : splitOn delimiter rest++ignoreIOError :: IO () -> IO ()+ignoreIOError action =+ action `catch` \(_ :: SomeException) -> pure ()
+ src/TuiSpec/Runner.hs view
@@ -0,0 +1,1662 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : TuiSpec.Runner+Description : PTY-backed runner and assertion helpers for TUI tests.++Most users interact with this module through 'tuiTest' and the action/assertion+functions ('launch', 'press', 'waitForText', 'expectSnapshot', ...).+-}+module TuiSpec.Runner (+ closeSession,+ currentView,+ dumpView,+ expectNotVisible,+ expectSnapshot,+ expectVisible,+ launch,+ openSession,+ press,+ pressCombo,+ renderAnsiViewportText,+ sendLine,+ serializeAnsiSnapshot,+ step,+ tuiTest,+ typeText,+ killSessionChildrenNow,+ waitForSelector,+ defaultWaitOptionsFor,+ withTuiSession,+ waitFor,+ waitForText,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception, SomeException, catch, displayException, finally, throwIO, toException, try)+import Control.Monad (unless, void, when)+import Data.Aeson (encode, object, (.=))+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Char (chr, isAlphaNum, ord, toLower)+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.IntMap.Strict qualified as IM+import Data.List (intercalate, isSuffixOf, nub, sort)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.Encoding.Error qualified as TEE+import Data.Text.IO qualified as TIO+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removePathForcibly)+import System.Environment (getEnvironment, lookupEnv)+import System.FilePath (isRelative, makeRelative, (</>))+import System.Posix.Process (getProcessGroupIDOf)+import System.Posix.Pty qualified as Pty+import System.Posix.Signals (sigKILL, signalProcess, signalProcessGroup)+import System.Posix.Types (ProcessGroupID)+import System.Process (getPid, terminateProcess, waitForProcess)+import System.Timeout (timeout)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertFailure, testCase)+import Text.Read (readMaybe)+import TuiSpec.ProjectRoot (resolveProjectRoot)+import TuiSpec.Types++data TestStatus+ = Passed+ | Failed Text+ deriving (Eq, Show)++newtype AssertionError = AssertionError String+ deriving (Show)++instance Exception AssertionError++data StepFailure = StepFailure+ { stepLabel :: String+ , stepAttempts :: Int+ , stepCause :: String+ }+ deriving (Show)++instance Exception StepFailure++settleDelayMicros :: Int+settleDelayMicros = 80 * 1000++{- | Run an ad-hoc PTY session outside @tasty@.++This is useful for REPL-like exploration workflows where you want to:++- launch a TUI once+- drive it with input primitives+- dump intermediate views without snapshot assertions+-}+withTuiSession :: RunOptions -> String -> (Tui -> IO a) -> IO a+withTuiSession options name body = do+ tui <- openSession options name+ body tui `finally` closeSession tui++-- | Open an isolated ad-hoc session TUI handle for interactive orchestration.+openSession :: RunOptions -> String -> IO Tui+openSession options name = do+ envOptions <- applyEnvOverrides options+ projectRoot <- resolveProjectRoot+ artifactBase <- resolveArtifactsBaseDir projectRoot (artifactsDir envOptions)+ let effectiveOptions = envOptions{artifactsDir = artifactBase}+ let sessionRoot = artifactBase </> "sessions" </> slugify name+ resetDirectory sessionRoot+ createDirectoryIfMissing True sessionRoot+ mkTui projectRoot effectiveOptions name sessionRoot sessionRoot 1++-- | Close and teardown a TUI session created with 'openSession'.+closeSession :: Tui -> IO ()+closeSession = teardownTui++-- | Kill the active PTY process group with SIGKILL and return immediately.+killSessionChildrenNow :: Tui -> IO ()+killSessionChildrenNow tui = do+ pty <- readPty tui+ case pty of+ Just ptyHandle -> killPtyProcessGroupNow ptyHandle+ Nothing -> pure ()++{- | Build a @tasty@ 'TestTree' from a TUI spec body.++Each test runs in isolation, with a fresh PTY process and per-test artifacts.+-}+tuiTest :: RunOptions -> String -> (Tui -> IO ()) -> TestTree+tuiTest options name body =+ testCase name $ do+ envOptions <- applyEnvOverrides options+ projectRoot <- resolveProjectRoot+ artifactBase <- resolveArtifactsBaseDir projectRoot (artifactsDir envOptions)+ let effectiveOptions = envOptions{artifactsDir = artifactBase}+ let slug = slugify name+ let testRoot = artifactBase </> "tests" </> slug+ let snapshotRoot = artifactBase </> "snapshots" </> slug+ (status, finalState, attempts) <-+ executeWithRetries projectRoot effectiveOptions (Spec name body) testRoot snapshotRoot+ printTuiTestSummary projectRoot name status attempts testRoot finalState+ case status of+ Passed -> pure ()+ Failed err -> do+ let snapshotEntries = renderSnapshotEntries finalState+ let artifactDetails =+ if snapshotEntries == " (none)\n"+ then ""+ else+ "\n\nArtifacts: "+ <> makeRelative projectRoot testRoot+ <> "\nSnapshots:\n"+ <> snapshotEntries+ assertFailure (T.unpack err <> artifactDetails)++{- | Launch an application in a fresh PTY for the current test.++If an app is already running for the test, it is terminated first.+-}+launch :: Tui -> App -> IO ()+launch tui app = do+ appendAction tui ("launch " <> T.pack (command app))+ currentPty <- readPty tui+ case currentPty of+ Just ptyHandle ->+ terminatePtyHandle ptyHandle+ Nothing -> pure ()+ writePty tui Nothing+ maybePty <- initializePty (terminalRows (tuiOptions tui)) (terminalCols (tuiOptions tui)) app+ case maybePty of+ Just ptyHandle -> do+ writePty tui (Just ptyHandle)+ modifyState tui $ \state -> state{launchedApp = Just app}+ threadDelay settleDelayMicros+ _ <- syncVisibleBuffer tui+ pure ()+ Nothing ->+ throwIO (AssertionError "PTY backend unavailable during launch")++-- | Send a single key press to the PTY application.+press :: Tui -> Key -> IO ()+press tui key = do+ appendAction tui ("press " <> renderKey key)+ pty <- readPty tui+ case pty of+ Just ptyHandle -> do+ case keyToPtyText key of+ Just keyBytes -> sendPtyText ptyHandle keyBytes+ Nothing -> pure ()+ threadDelay settleDelayMicros+ _ <- syncVisibleBuffer tui+ pure ()+ Nothing ->+ throwIO (AssertionError "PTY backend unavailable during key press")++{- | Send a modified key press (for example @Ctrl+C@) to the PTY application.++Unsupported combos fall back to a plain 'press'.+-}+pressCombo :: Tui -> [Modifier] -> Key -> IO ()+pressCombo tui modifiers key = do+ appendAction tui $+ "pressCombo "+ <> T.pack (intercalate "+" (map show modifiers))+ <> "+"+ <> renderKey key+ pty <- readPty tui+ case pty of+ Just ptyHandle ->+ case comboToPtyText modifiers key of+ Just token -> do+ sendPtyText ptyHandle token+ threadDelay settleDelayMicros+ _ <- syncVisibleBuffer tui+ pure ()+ Nothing -> press tui key+ Nothing ->+ throwIO (AssertionError "PTY backend unavailable during combo key press")++-- | Send literal text to the PTY application.+typeText :: Tui -> Text -> IO ()+typeText tui textValue = do+ appendAction tui ("typeText " <> textValue)+ pty <- readPty tui+ case pty of+ Just ptyHandle -> do+ sendPtyText ptyHandle textValue+ threadDelay settleDelayMicros+ _ <- syncVisibleBuffer tui+ pure ()+ Nothing ->+ throwIO (AssertionError "PTY backend unavailable during typeText")++-- | Send a line of text followed by @Enter@.+sendLine :: Tui -> Text -> IO ()+sendLine tui line = do+ typeText tui line+ press tui Enter++-- | Return the current visible viewport text.+currentView :: Tui -> IO Text+currentView = syncVisibleBuffer++-- | Assert that a selector eventually becomes visible.+expectVisible :: Tui -> Selector -> IO ()+expectVisible tui selector = do+ waitFor tui (defaultWaitOptionsFor tui) (selectorMatches selector)+ viewport <- currentViewport tui+ assertNotAmbiguous tui selector viewport++-- | Assert that a selector eventually becomes absent.+expectNotVisible :: Tui -> Selector -> IO ()+expectNotVisible tui selector =+ waitFor tui (defaultWaitOptionsFor tui) (not . selectorMatches selector)++-- | Wait for selector text and apply ambiguity checks.+waitForText :: Tui -> Selector -> IO ()+waitForText tui selector = do+ waitFor tui (defaultWaitOptionsFor tui) (selectorMatches selector)+ viewport <- currentViewport tui+ assertNotAmbiguous tui selector viewport++-- | Wait for a selector with explicit wait options and ambiguity handling.+waitForSelector :: Tui -> WaitOptions -> Selector -> IO ()+waitForSelector tui waitOptions selector = do+ waitFor tui waitOptions (selectorMatches selector)+ viewport <- currentViewport tui+ assertNotAmbiguous tui selector viewport++defaultWaitOptionsFor :: Tui -> WaitOptions+defaultWaitOptionsFor tui =+ defaultWaitOptions+ { timeoutMs = timeoutSeconds (tuiOptions tui) * 1000+ }++-- | Poll until a viewport predicate succeeds or timeout is reached.+waitFor :: Tui -> WaitOptions -> (Viewport -> Bool) -> IO ()+waitFor tui waitOptions predicate = do+ start <- getCurrentTime+ loop start+ where+ timeoutLimit = fromIntegral (timeoutMs waitOptions) / 1000 :: NominalDiffTime++ loop :: UTCTime -> IO ()+ loop startedAt = do+ viewport <- currentViewport tui+ if predicate viewport+ then pure ()+ else do+ now <- getCurrentTime+ if diffUTCTime now startedAt >= timeoutLimit+ then throwIO (AssertionError "waitFor timed out")+ else do+ threadDelay (pollIntervalMs waitOptions * 1000)+ loop startedAt++{- | Capture and compare the current PTY screen against a named snapshot.++Writes:++- per-run capture: @artifacts/tests/<test>/snapshots/<name>.ansi.txt@+- baseline: @artifacts/snapshots/<test>/<name>.ansi.txt@+- metadata for both paths: @<name>.meta.json@ (rows/cols)+-}+expectSnapshot :: Tui -> SnapshotName -> IO ()+expectSnapshot tui snapshotName = do+ let requestedTheme = snapshotTheme (tuiOptions tui)+ when (not (isKnownSnapshotTheme requestedTheme)) $+ appendWarning+ tui+ ( "Unknown snapshot theme '"+ <> T.pack requestedTheme+ <> "', using "+ <> T.pack (snapshotThemeName defaultSnapshotTheme)+ <> "."+ )+ (snapshotStem, actualAnsi, actualAnsiPath) <- captureSnapshotToDir tui (tuiTestRoot tui </> "snapshots") snapshotName+ let rows = terminalRows (tuiOptions tui)+ let cols = terminalCols (tuiOptions tui)+ let baselineDir = tuiSnapshotRoot tui+ createDirectoryIfMissing True baselineDir++ let baselineAnsiPath = baselineDir </> (snapshotStem <> ".ansi.txt")+ let baselineMetaPath = snapshotMetadataPath baselineAnsiPath++ baselineExists <- doesFileExist baselineAnsiPath+ if updateSnapshots (tuiOptions tui) || not baselineExists+ then do+ TIO.writeFile baselineAnsiPath actualAnsi+ writeSnapshotMetadata baselineMetaPath rows cols+ appendSnapshotArtifact tui baselineAnsiPath+ else do+ baselineAnsi <- TIO.readFile baselineAnsiPath+ let baselineCanonical = serializeAnsiSnapshot rows cols requestedTheme baselineAnsi+ let actualCanonical = serializeAnsiSnapshot rows cols requestedTheme actualAnsi+ if baselineCanonical == actualCanonical+ then do+ appendSnapshotArtifact tui baselineAnsiPath+ else+ throwIO $+ AssertionError+ ( "Snapshot mismatch for '"+ <> snapshotStem+ <> "'. Compare "+ <> baselineAnsiPath+ <> " and "+ <> actualAnsiPath+ <> ". Render with: tuispec render "+ <> actualAnsiPath+ )++{- | Persist the current PTY view as an ANSI snapshot artifact.++This writes only to the active run directory and does not compare against a+baseline, making it suitable for iterative REPL-style exploration.+-}+dumpView :: Tui -> SnapshotName -> IO FilePath+dumpView tui snapshotName = do+ (_stem, _ansi, ansiPath) <- captureSnapshotToDir tui (tuiTestRoot tui </> "snapshots") snapshotName+ pure ansiPath++{- | Canonicalize ANSI text into a theme-aware JSON framebuffer.++This representation is used for deterministic snapshot comparison and PNG+rendering.+-}+serializeAnsiSnapshot :: Int -> Int -> String -> Text -> String+serializeAnsiSnapshot rows cols requestedTheme ansiText =+ let resolvedTheme = resolveSnapshotTheme requestedTheme+ emuState =+ emulateAnsi+ (emptyEmuState rows cols)+ (T.unpack ansiText)+ in serializeSnapshot resolvedTheme emuState++-- | Retry a logical test step according to @StepOptions@.+step :: StepOptions -> String -> IO a -> IO a+step options label action = go 0+ where+ maxAttempts = max 1 (stepMaxRetries options + 1)++ go attempts = do+ result <- try action+ case result of+ Right value -> pure value+ Left (err :: SomeException)+ | attempts + 1 < maxAttempts -> do+ when (stepRetryDelayMs options > 0) $+ threadDelay (stepRetryDelayMs options * 1000)+ go (attempts + 1)+ | otherwise ->+ throwIO $+ StepFailure+ { stepLabel = label+ , stepAttempts = attempts + 1+ , stepCause = displayException err+ }++executeWithRetries ::+ FilePath ->+ RunOptions ->+ Spec ->+ FilePath ->+ FilePath ->+ IO (TestStatus, TuiState, Int)+executeWithRetries projectRoot options specDef testRoot snapshotRoot = go 1+ where+ maxAttempts = max 1 (retries options + 1)+ hardTimeoutMicros = max 1 (timeoutSeconds options) * 1000 * 1000++ go attempt = do+ resetDirectory testRoot+ tui <- mkTui projectRoot options (specName specDef) testRoot snapshotRoot attempt+ runResultAndState <-+ ( do+ maybeRunResult <- timeout hardTimeoutMicros (try (specBody specDef tui))+ let runResult =+ case maybeRunResult of+ Nothing ->+ Left+ ( toException+ ( AssertionError+ ( "test timed out after "+ <> show (timeoutSeconds options)+ <> "s"+ )+ )+ )+ Just resultValue -> resultValue+ _ <- timeout (500 * 1000) (syncVisibleBuffer tui)+ state <- readIORef (tuiStateRef tui)+ pure (runResult, state)+ )+ `finally` teardownTui tui+ let (runResult, state) = runResultAndState+ case runResult of+ Right () -> pure (Passed, state, attempt)+ Left (err :: SomeException)+ | attempt < maxAttempts -> go (attempt + 1)+ | otherwise -> pure (Failed (T.pack (displayException err)), state, attempt)++mkTui :: FilePath -> RunOptions -> String -> FilePath -> FilePath -> Int -> IO Tui+mkTui projectRoot options name testRoot snapshotRoot _attempt = do+ ptyRef <- newIORef Nothing+ stateRef <-+ newIORef+ TuiState+ { launchedApp = Nothing+ , visibleBuffer = ""+ , rawBuffer = ""+ , actionLog = []+ , snapshotLog = []+ , runtimeWarnings = []+ , frameLog = []+ }+ tui <-+ pure+ Tui+ { tuiName = name+ , tuiOptions = options+ , tuiRootDir = projectRoot+ , tuiTestRoot = testRoot+ , tuiSnapshotRoot = snapshotRoot+ , tuiPty = ptyRef+ , tuiStateRef = stateRef+ }+ pure tui++initializePty :: Int -> Int -> App -> IO (Maybe PtyHandle)+initializePty rows cols app = do+ result <- try (startPty rows cols app) :: IO (Either SomeException PtyHandle)+ case result of+ Left _ -> pure Nothing+ Right handle -> pure (Just handle)++startPty :: Int -> Int -> App -> IO PtyHandle+startPty rows cols app = do+ processEnv <- withTerminalEnv+ (master, processHandle) <-+ Pty.spawnWithPty+ (Just processEnv)+ True+ (command app)+ (args app)+ (cols, rows)+ pure+ PtyHandle+ { ptyMaster = master+ , ptyProcess = processHandle+ }++withTerminalEnv :: IO [(String, String)]+withTerminalEnv = do+ existing <- getEnvironment+ pure (overrideEnv "TERM" "xterm-256color" existing)+ where+ overrideEnv key value pairs =+ (key, value) : filter ((/= key) . fst) pairs++teardownTui :: Tui -> IO ()+teardownTui tui =+ do+ pty <- readPty tui+ case pty of+ Just ptyHandle ->+ terminatePtyHandle ptyHandle+ _ -> pure ()+ writePty tui Nothing++terminatePtyHandle :: PtyHandle -> IO ()+terminatePtyHandle ptyHandle = do+ _ <- timeout (500 * 1000) (ignoreIOError (terminateProcess (ptyProcess ptyHandle)))+ waitResult <- timeout (500 * 1000) (ignoreIOError (void (waitForProcess (ptyProcess ptyHandle))))+ case waitResult of+ Just () ->+ pure ()+ Nothing -> do+ killPtyProcessGroupNow ptyHandle+ _ <- timeout (500 * 1000) (ignoreIOError (void (waitForProcess (ptyProcess ptyHandle))))+ pure ()+ _ <- timeout (500 * 1000) (ignoreIOError (Pty.closePty (ptyMaster ptyHandle)))+ pure ()++killPtyProcessGroupNow :: PtyHandle -> IO ()+killPtyProcessGroupNow ptyHandle = do+ maybePid <- getPid (ptyProcess ptyHandle)+ case maybePid of+ Nothing -> pure ()+ Just pid -> do+ maybeGroup <- try (getProcessGroupIDOf pid) :: IO (Either SomeException ProcessGroupID)+ case maybeGroup of+ Right groupId ->+ ignoreIOError (signalProcessGroup sigKILL groupId)+ Left _ ->+ ignoreIOError (signalProcess sigKILL pid)++readPty :: Tui -> IO (Maybe PtyHandle)+readPty tui = readIORef (tuiPty tui)++writePty :: Tui -> Maybe PtyHandle -> IO ()+writePty tui value = writeIORef (tuiPty tui) value++currentViewport :: Tui -> IO Viewport+currentViewport tui = do+ textValue <- syncVisibleBuffer tui+ pure+ Viewport+ { viewportCols = terminalCols (tuiOptions tui)+ , viewportRows = terminalRows (tuiOptions tui)+ , viewportText = textValue+ }++syncVisibleBuffer :: Tui -> IO Text+syncVisibleBuffer tui = do+ maybePty <- readPty tui+ case maybePty of+ Just ptyHandle -> do+ maybeChunk <- timeout (250 * 1000) (try (drainPtyOutput (ptyMaster ptyHandle)) :: IO (Either SomeException BS.ByteString))+ combinedBytes <-+ case maybeChunk of+ Nothing -> do+ appendWarning tui "pty read timed out during viewport sync"+ pure BS.empty+ Just (Left outErr) -> do+ appendWarning tui ("failed to read pty output: " <> T.pack (displayException outErr))+ pure BS.empty+ Just (Right outBytes) ->+ pure outBytes+ if BS.null combinedBytes+ then visibleBuffer <$> readIORef (tuiStateRef tui)+ else do+ let textChunk = TE.decodeUtf8With TEE.lenientDecode combinedBytes+ state <- readIORef (tuiStateRef tui)+ let nextRaw = rawBuffer state <> textChunk+ let nextVisible =+ renderAnsiViewportText+ (terminalRows (tuiOptions tui))+ (terminalCols (tuiOptions tui))+ nextRaw+ modifyState tui $ \st -> st{rawBuffer = nextRaw, visibleBuffer = nextVisible}+ recordFrame tui nextVisible+ pure nextVisible+ Nothing ->+ throwIO (AssertionError "PTY backend unavailable during viewport sync")++modifyState :: Tui -> (TuiState -> TuiState) -> IO ()+modifyState tui updateFn = modifyIORef' (tuiStateRef tui) updateFn++appendAction :: Tui -> Text -> IO ()+appendAction tui actionText =+ modifyState tui $ \state ->+ state{actionLog = actionLog state <> [actionText]}++appendSnapshotArtifact :: Tui -> FilePath -> IO ()+appendSnapshotArtifact tui snapshotPath = do+ let relativePath = T.pack (makeRelative (tuiRootDir tui) snapshotPath)+ modifyState tui $ \state ->+ if relativePath `elem` snapshotLog state+ then state+ else state{snapshotLog = snapshotLog state <> [relativePath]}++appendWarning :: Tui -> Text -> IO ()+appendWarning tui warningText =+ modifyState tui $ \state ->+ state{runtimeWarnings = runtimeWarnings state <> [warningText]}++recordFrame :: Tui -> Text -> IO ()+recordFrame tui frameText =+ modifyState tui $ \state ->+ case reverse (frameLog state) of+ latest : _ | latest == frameText -> state+ _ -> state{frameLog = frameLog state <> [frameText]}++renderKey :: Key -> Text+renderKey key =+ case key of+ Enter -> "Enter"+ Esc -> "Esc"+ Tab -> "Tab"+ Backspace -> "Backspace"+ ArrowUp -> "ArrowUp"+ ArrowDown -> "ArrowDown"+ ArrowLeft -> "ArrowLeft"+ ArrowRight -> "ArrowRight"+ Ctrl c -> "Ctrl+" <> T.singleton c+ AltKey c -> "Alt+" <> T.singleton c+ FunctionKey n -> "F" <> T.pack (show n)+ CharKey c -> T.singleton c+ NamedKey name -> name++keyToPtyText :: Key -> Maybe Text+keyToPtyText key =+ case key of+ Enter -> Just "\r"+ Esc -> Just "\ESC"+ Tab -> Just "\t"+ Backspace -> Just "\DEL"+ ArrowUp -> Just "\ESC[A"+ ArrowDown -> Just "\ESC[B"+ ArrowRight -> Just "\ESC[C"+ ArrowLeft -> Just "\ESC[D"+ Ctrl c -> controlChar c+ AltKey c -> Just ("\ESC" <> T.singleton c)+ FunctionKey n -> functionKeySeq n+ CharKey c -> Just (T.singleton c)+ NamedKey value -> Just value+ where+ controlChar c =+ let lowered = toLower c+ in if lowered >= 'a' && lowered <= 'z'+ then Just (T.singleton (chr (ord lowered - ord 'a' + 1)))+ else Nothing++ functionKeySeq n =+ case n of+ 1 -> Just "\ESCOP"+ 2 -> Just "\ESCOQ"+ 3 -> Just "\ESCOR"+ 4 -> Just "\ESCOS"+ 5 -> Just "\ESC[15~"+ 6 -> Just "\ESC[17~"+ 7 -> Just "\ESC[18~"+ 8 -> Just "\ESC[19~"+ 9 -> Just "\ESC[20~"+ 10 -> Just "\ESC[21~"+ 11 -> Just "\ESC[23~"+ 12 -> Just "\ESC[24~"+ _ -> Nothing++comboToPtyText :: [Modifier] -> Key -> Maybe Text+comboToPtyText modifiers key+ | null modifiers = keyToPtyText key+ | otherwise =+ case (modifiers, key) of+ ([Control], CharKey c) ->+ keyToPtyText (Ctrl c)+ ([Alt], CharKey c) ->+ keyToPtyText (AltKey c)+ ([Shift], CharKey c) ->+ keyToPtyText (CharKey (toUpperAscii c))+ _ -> Nothing+ where+ toUpperAscii c+ | c >= 'a' && c <= 'z' = chr (ord c - 32)+ | otherwise = c++sendPtyText :: PtyHandle -> Text -> IO ()+sendPtyText ptyHandle textValue =+ Pty.writePty (ptyMaster ptyHandle) (TE.encodeUtf8 textValue)++drainPtyOutput :: Pty.Pty -> IO BS.ByteString+drainPtyOutput pty = BS.concat . reverse <$> go 0 []+ where+ -- Keep each sync bounded so a constantly-redrawing TUI cannot stall the runner.+ maxDrainChunks :: Int+ maxDrainChunks = 256++ waitChunkMicros :: Int+ waitChunkMicros = 15 * 1000++ go chunkCount acc+ | chunkCount >= maxDrainChunks = pure acc+ | otherwise = do+ ready <- timeout waitChunkMicros (Pty.threadWaitReadPty pty)+ case ready of+ Nothing -> pure acc+ Just () -> do+ next <- Pty.tryReadPty pty+ case next of+ Right chunk+ | not (BS.null chunk) ->+ go (chunkCount + 1) (chunk : acc)+ _ ->+ pure acc++data EmuColor = EmuColor Int Int Int++data EmuCellStyle = EmuCellStyle+ { cellFg :: Maybe EmuColor+ , cellBg :: Maybe EmuColor+ , cellBold :: Bool+ , cellDim :: Bool+ , cellReverse :: Bool+ }++data EmuCell = EmuCell+ { cellValue :: Char+ , cellStyle :: EmuCellStyle+ }++data EmuState = EmuState+ { emuRows :: Int+ , emuCols :: Int+ , emuCursorRow :: Int+ , emuCursorCol :: Int+ , emuSavedCursor :: Maybe (Int, Int)+ , emuStateStyle :: EmuCellStyle+ , emuCells :: IM.IntMap EmuCell+ }++data SnapshotTheme = PtyDefaultDark | PtyDefaultLight+ deriving (Eq, Show)++data ThemePalette = ThemePalette+ { paletteDefaultBg :: EmuColor+ , paletteDefaultFg :: EmuColor+ , paletteAnsi16 :: [EmuColor]+ }++data SnapshotStyledCell = SnapshotStyledCell+ { styledChar :: Char+ , styledFgColor :: EmuColor+ , styledBgColor :: EmuColor+ }++type SnapshotStyledRow = [SnapshotStyledCell]++defaultCellStyle :: EmuCellStyle+defaultCellStyle =+ EmuCellStyle+ { cellFg = Nothing+ , cellBg = Nothing+ , cellBold = False+ , cellDim = False+ , cellReverse = False+ }++emptyEmuState :: Int -> Int -> EmuState+emptyEmuState rows cols =+ EmuState+ { emuRows = max 1 rows+ , emuCols = max 1 cols+ , emuCursorRow = 0+ , emuCursorCol = 0+ , emuSavedCursor = Nothing+ , emuStateStyle = defaultCellStyle+ , emuCells = IM.empty+ }++defaultSnapshotTheme :: SnapshotTheme+defaultSnapshotTheme = PtyDefaultDark++resolveSnapshotTheme :: String -> SnapshotTheme+resolveSnapshotTheme value =+ if isKnownSnapshotTheme value+ then parseSnapshotTheme value+ else defaultSnapshotTheme++parseSnapshotTheme :: String -> SnapshotTheme+parseSnapshotTheme value =+ case map toLower value of+ "pty-default-dark" -> PtyDefaultDark+ "dark" -> PtyDefaultDark+ "auto" -> defaultSnapshotTheme+ "pty-default-light" -> PtyDefaultLight+ "light" -> PtyDefaultLight+ -- Backward compatibility for previously used labels.+ "github-dark-high-contrast" -> PtyDefaultDark+ "github-light-high-contrast" -> PtyDefaultLight+ _ -> PtyDefaultDark++isKnownSnapshotTheme :: String -> Bool+isKnownSnapshotTheme value =+ case map toLower value of+ "pty-default-dark" -> True+ "dark" -> True+ "auto" -> True+ "pty-default-light" -> True+ "light" -> True+ "github-dark-high-contrast" -> True+ "github-light-high-contrast" -> True+ _ -> False++themePalette :: SnapshotTheme -> ThemePalette+themePalette PtyDefaultDark =+ ThemePalette+ { paletteDefaultBg = EmuColor 0 0 0+ , paletteDefaultFg = EmuColor 229 229 229+ , paletteAnsi16 =+ [ EmuColor 0 0 0+ , EmuColor 205 0 0+ , EmuColor 0 205 0+ , EmuColor 205 205 0+ , EmuColor 0 0 238+ , EmuColor 205 0 205+ , EmuColor 0 205 205+ , EmuColor 229 229 229+ , EmuColor 127 127 127+ , EmuColor 255 0 0+ , EmuColor 0 255 0+ , EmuColor 255 255 0+ , EmuColor 92 92 255+ , EmuColor 255 0 255+ , EmuColor 0 255 255+ , EmuColor 255 255 255+ ]+ }+themePalette PtyDefaultLight =+ ThemePalette+ { paletteDefaultBg = EmuColor 255 255 255+ , paletteDefaultFg = EmuColor 0 0 0+ , paletteAnsi16 =+ [ EmuColor 0 0 0+ , EmuColor 205 0 0+ , EmuColor 0 205 0+ , EmuColor 205 205 0+ , EmuColor 0 0 238+ , EmuColor 205 0 205+ , EmuColor 0 205 205+ , EmuColor 229 229 229+ , EmuColor 127 127 127+ , EmuColor 255 0 0+ , EmuColor 0 255 0+ , EmuColor 255 255 0+ , EmuColor 92 92 255+ , EmuColor 255 0 255+ , EmuColor 0 255 255+ , EmuColor 255 255 255+ ]+ }++{- | Convert ANSI terminal output into the visible viewport text.++This is primarily used by 'tuispec render-text' and snapshot assertions.+-}+renderAnsiViewportText :: Int -> Int -> Text -> Text+renderAnsiViewportText rows cols rawText =+ renderEmuState (emulateAnsi (emptyEmuState rows cols) (T.unpack rawText))++snapshotStyledRows :: SnapshotTheme -> EmuState -> [SnapshotStyledRow]+snapshotStyledRows theme stateValue =+ [ [ snapshotCell row col | col <- [0 .. emuCols stateValue - 1]+ ]+ | row <- [0 .. emuRows stateValue - 1]+ ]+ where+ snapshotCell rowValue colValue =+ maybe+ (defaultStyledCell theme)+ (snapshotCellFromEmuCell theme)+ (IM.lookup (cellIndex stateValue rowValue colValue) (emuCells stateValue))++snapshotCellFromEmuCell :: SnapshotTheme -> EmuCell -> SnapshotStyledCell+snapshotCellFromEmuCell theme emuCell =+ SnapshotStyledCell+ { styledChar = cellValue emuCell+ , styledFgColor = resolveCellFg theme (cellStyle emuCell)+ , styledBgColor = resolveCellBg theme (cellStyle emuCell)+ }++defaultStyledCell :: SnapshotTheme -> SnapshotStyledCell+defaultStyledCell theme =+ let palette = themePalette theme+ in SnapshotStyledCell+ { styledChar = ' '+ , styledFgColor = paletteDefaultFg palette+ , styledBgColor = paletteDefaultBg palette+ }++resolveCellFg :: SnapshotTheme -> EmuCellStyle -> EmuColor+resolveCellFg theme styleValue =+ if cellReverse styleValue+ then fromMaybe (paletteDefaultBg palette) (cellBg styleValue)+ else fromMaybe (paletteDefaultFg palette) (cellFg styleValue)+ where+ palette = themePalette theme++resolveCellBg :: SnapshotTheme -> EmuCellStyle -> EmuColor+resolveCellBg theme styleValue =+ if cellReverse styleValue+ then fromMaybe (paletteDefaultFg palette) (cellFg styleValue)+ else fromMaybe (paletteDefaultBg palette) (cellBg styleValue)+ where+ palette = themePalette theme++emulateAnsi :: EmuState -> String -> EmuState+emulateAnsi stateValue input =+ case input of+ [] -> stateValue+ '\ESC' : '[' : rest ->+ let (payload, remaining) = span (not . isCsiFinal) rest+ in case remaining of+ [] -> stateValue+ finalChar : tailChars ->+ emulateAnsi (applyCsi stateValue payload finalChar) tailChars+ '\ESC' : ']' : rest ->+ emulateAnsi stateValue (dropOsc rest)+ '\ESC' : '7' : rest ->+ emulateAnsi (stateValue{emuSavedCursor = Just (emuCursorRow stateValue, emuCursorCol stateValue)}) rest+ '\ESC' : '8' : rest ->+ emulateAnsi (restoreCursor stateValue) rest+ '\ESC' : 'c' : rest ->+ emulateAnsi (clearScreen (setCursor 0 0 stateValue)) rest+ -- Character set designation escapes (for example ESC ( B) are metadata;+ -- consume them so they do not leak literal bytes into the viewport.+ '\ESC' : '(' : _ : rest ->+ emulateAnsi stateValue rest+ '\ESC' : ')' : _ : rest ->+ emulateAnsi stateValue rest+ '\ESC' : '*' : _ : rest ->+ emulateAnsi stateValue rest+ '\ESC' : '+' : _ : rest ->+ emulateAnsi stateValue rest+ '\ESC' : '-' : _ : rest ->+ emulateAnsi stateValue rest+ '\ESC' : '.' : _ : rest ->+ emulateAnsi stateValue rest+ '\ESC' : _ : rest ->+ emulateAnsi stateValue rest+ '\r' : rest ->+ emulateAnsi (stateValue{emuCursorCol = 0}) rest+ '\n' : rest ->+ emulateAnsi (stateValue{emuCursorRow = clampRow stateValue (emuCursorRow stateValue + 1)}) rest+ '\b' : rest ->+ emulateAnsi (stateValue{emuCursorCol = clampCol stateValue (emuCursorCol stateValue - 1)}) rest+ '\t' : rest ->+ let nextTabStop = ((emuCursorCol stateValue `div` 8) + 1) * 8+ in emulateAnsi (stateValue{emuCursorCol = clampCol stateValue nextTabStop}) rest+ charValue : rest+ | charValue >= ' ' ->+ emulateAnsi (writeCharAtCursor stateValue charValue) rest+ | otherwise ->+ emulateAnsi stateValue rest+ where+ isCsiFinal c = c >= '@' && c <= '~'++dropOsc :: String -> String+dropOsc value =+ case value of+ [] -> []+ '\a' : rest -> rest+ '\ESC' : '\\' : rest -> rest+ _ : rest -> dropOsc rest++applyCsi :: EmuState -> String -> Char -> EmuState+applyCsi stateValue payload finalChar =+ let (isPrivate, paramText) =+ case payload of+ '?' : rest -> (True, rest)+ _ -> (False, payload)+ params = parseCsiParams paramText+ paramAt idx defaultValue = fromMaybe defaultValue (safeIndex idx params)+ modeValue = paramAt 0 0+ amount = max 1 (paramAt 0 1)+ in case finalChar of+ 'm' ->+ applySgr stateValue params+ 'H' ->+ setCursor (paramAt 0 1 - 1) (paramAt 1 1 - 1) stateValue+ 'f' ->+ setCursor (paramAt 0 1 - 1) (paramAt 1 1 - 1) stateValue+ 'A' ->+ stateValue{emuCursorRow = clampRow stateValue (emuCursorRow stateValue - amount)}+ 'B' ->+ stateValue{emuCursorRow = clampRow stateValue (emuCursorRow stateValue + amount)}+ 'C' ->+ stateValue{emuCursorCol = clampCol stateValue (emuCursorCol stateValue + amount)}+ 'D' ->+ stateValue{emuCursorCol = clampCol stateValue (emuCursorCol stateValue - amount)}+ 'G' ->+ stateValue{emuCursorCol = clampCol stateValue (paramAt 0 1 - 1)}+ 'd' ->+ stateValue{emuCursorRow = clampRow stateValue (paramAt 0 1 - 1)}+ 'E' ->+ stateValue+ { emuCursorRow = clampRow stateValue (emuCursorRow stateValue + amount)+ , emuCursorCol = 0+ }+ 'F' ->+ stateValue+ { emuCursorRow = clampRow stateValue (emuCursorRow stateValue - amount)+ , emuCursorCol = 0+ }+ 'J' ->+ clearScreenByMode stateValue modeValue+ 'K' ->+ clearLine stateValue modeValue+ 's' ->+ stateValue{emuSavedCursor = Just (emuCursorRow stateValue, emuCursorCol stateValue)}+ 'u' ->+ restoreCursor stateValue+ 'h' ->+ if isPrivate && 1049 `elem` params+ then clearScreen (setCursor 0 0 stateValue)+ else stateValue+ 'l' ->+ if isPrivate && 1049 `elem` params+ then clearScreen (setCursor 0 0 stateValue)+ else stateValue+ _ -> stateValue++applySgr :: EmuState -> [Int] -> EmuState+applySgr stateValue params =+ applySgrParams stateValue (if null params then [0] else params)+ where+ applySgrParams stateAcc [] = stateAcc+ applySgrParams stateAcc (param : rest) =+ case param of+ 0 ->+ applySgrParams+ (stateAcc{emuStateStyle = defaultCellStyle})+ rest+ 1 ->+ applySgrParams+ (stateAcc{emuStateStyle = (emuStateStyle stateAcc){cellBold = True}})+ rest+ 2 ->+ applySgrParams+ (stateAcc{emuStateStyle = (emuStateStyle stateAcc){cellDim = True}})+ rest+ 22 ->+ applySgrParams+ (stateAcc{emuStateStyle = (emuStateStyle stateAcc){cellBold = False, cellDim = False}})+ rest+ 7 ->+ applySgrParams+ (stateAcc{emuStateStyle = (emuStateStyle stateAcc){cellReverse = True}})+ rest+ 27 ->+ applySgrParams+ (stateAcc{emuStateStyle = (emuStateStyle stateAcc){cellReverse = False}})+ rest+ 39 -> applySgrParams (clearCellForeground stateAcc) rest+ 49 -> applySgrParams (clearCellBackground stateAcc) rest+ x+ | x >= 30 && x <= 37 ->+ applySgrParams (setCellForeground stateAcc (mapBasicColor (x - 30))) rest+ x+ | x >= 90 && x <= 97 ->+ applySgrParams (setCellForeground stateAcc (mapBasicColor (x - 90 + 8))) rest+ x+ | x >= 40 && x <= 47 ->+ applySgrParams (setCellBackground stateAcc (mapBasicColor (x - 40))) rest+ x+ | x >= 100 && x <= 107 ->+ applySgrParams (setCellBackground stateAcc (mapBasicColor (x - 100 + 8))) rest+ 38 ->+ let (nextState, remaining) = parseDynamicColor setCellForeground stateAcc rest+ in applySgrParams nextState remaining+ 48 ->+ let (nextState, remaining) = parseDynamicColor setCellBackground stateAcc rest+ in applySgrParams nextState remaining+ _ -> applySgrParams stateAcc rest+ where+ clearCellForeground stateNext =+ stateNext{emuStateStyle = (emuStateStyle stateNext){cellFg = Nothing}}+ clearCellBackground stateNext =+ stateNext{emuStateStyle = (emuStateStyle stateNext){cellBg = Nothing}}+ setCellForeground stateNext color =+ stateNext{emuStateStyle = (emuStateStyle stateNext){cellFg = Just color}}+ setCellBackground stateNext color =+ stateNext{emuStateStyle = (emuStateStyle stateNext){cellBg = Just color}}++ parseDynamicColor setFn stateNext values =+ case values of+ [] -> (stateNext, [])+ mode : restValues ->+ if mode == 2 && length restValues >= 3+ then+ let r = colorSafe (restValues !! 0)+ g = colorSafe (restValues !! 1)+ b = colorSafe (restValues !! 2)+ in (setFn stateNext (EmuColor r g b), drop 3 restValues)+ else case (mode, restValues) of+ (5, colorValue : tailValues) ->+ (setFn stateNext (colorFromCode (colorSafe colorValue)), tailValues)+ _ ->+ (stateNext, restValues)++ colorSafe value = max 0 (min 255 value)++ mapBasicColor code+ | code >= 0 && code < 16 =+ fromMaybe+ (EmuColor 0 0 0)+ (safeIndex code (paletteAnsi16 (themePalette defaultSnapshotTheme)))+ | otherwise = EmuColor 0 0 0++ colorFromCode value =+ EmuColor r g b+ where+ (r, g, b) = ansiColorFromCode value++ansiColorFromCode :: Int -> (Int, Int, Int)+ansiColorFromCode value+ | value >= 0 && value < 16 =+ let EmuColor rValue gValue bValue =+ fromMaybe (EmuColor 0 0 0) (safeIndex value (paletteAnsi16 (themePalette defaultSnapshotTheme)))+ in (rValue, gValue, bValue)+ | value >= 16 && value <= 231 =+ let level v = (v * 51)+ rValue = level ((value - 16) `div` 36)+ gValue = level (((value - 16) `div` 6) `mod` 6)+ bValue = level ((value - 16) `mod` 6)+ in (rValue, gValue, bValue)+ | value >= 232 && value <= 255 =+ let gray = 8 + (value - 232) * 10+ in (gray, gray, gray)+ | otherwise = (0, 0, 0)+parseCsiParams :: String -> [Int]+parseCsiParams value =+ case splitOnSemicolon value of+ [] -> [0]+ parts -> map parsePart parts+ where+ parsePart "" = 0+ parsePart part = fromMaybe 0 (readMaybe part)++splitOnSemicolon :: String -> [String]+splitOnSemicolon value =+ case break (== ';') value of+ (headPart, []) -> [headPart]+ (headPart, _ : rest) -> headPart : splitOnSemicolon rest++setCursor :: Int -> Int -> EmuState -> EmuState+setCursor rowValue colValue stateValue =+ stateValue+ { emuCursorRow = clampRow stateValue rowValue+ , emuCursorCol = clampCol stateValue colValue+ }++restoreCursor :: EmuState -> EmuState+restoreCursor stateValue =+ case emuSavedCursor stateValue of+ Nothing -> stateValue+ Just (rowValue, colValue) ->+ setCursor rowValue colValue stateValue++clearScreen :: EmuState -> EmuState+clearScreen stateValue = stateValue{emuCells = IM.empty}++clearScreenByMode :: EmuState -> Int -> EmuState+clearScreenByMode stateValue modeValue =+ case modeValue of+ 1 ->+ deleteCellRange stateValue 0 endIndex+ 2 ->+ clearScreen stateValue+ 3 ->+ clearScreen stateValue+ _ ->+ deleteCellRange stateValue startIndex lastIndex+ where+ rowValue = emuCursorRow stateValue+ colValue = emuCursorCol stateValue+ cols = emuCols stateValue+ rows = emuRows stateValue+ startIndex = cellIndex stateValue rowValue colValue+ endIndex = cellIndex stateValue rowValue colValue+ lastIndex = rows * cols - 1++deleteCellRange :: EmuState -> Int -> Int -> EmuState+deleteCellRange stateValue startIndex endIndex =+ if endIndex < startIndex+ then stateValue+ else+ stateValue+ { emuCells =+ foldl'+ (flip IM.delete)+ (emuCells stateValue)+ [startIndex .. endIndex]+ }++clearLine :: EmuState -> Int -> EmuState+clearLine stateValue modeValue =+ stateValue{emuCells = foldl' (flip IM.delete) (emuCells stateValue) lineIndexes}+ where+ rowValue = emuCursorRow stateValue+ colValue = emuCursorCol stateValue+ cols = emuCols stateValue+ indexesFor rangeStart rangeEnd =+ [ cellIndex stateValue rowValue col+ | col <- [rangeStart .. rangeEnd]+ ]+ lineIndexes =+ case modeValue of+ 1 -> indexesFor 0 colValue+ 2 -> indexesFor 0 (cols - 1)+ _ -> indexesFor colValue (cols - 1)++writeCharAtCursor :: EmuState -> Char -> EmuState+writeCharAtCursor stateValue charValue =+ advanceCursor $+ if not (inBounds stateValue rowValue colValue)+ then stateValue+ else+ let indexValue = cellIndex stateValue rowValue colValue+ newCell =+ EmuCell+ { cellValue = charValue+ , cellStyle = emuStateStyle stateValue+ }+ nextCells =+ IM.insert indexValue newCell (emuCells stateValue)+ in stateValue{emuCells = nextCells}+ where+ rowValue = emuCursorRow stateValue+ colValue = emuCursorCol stateValue++ advanceCursor st =+ let nextCol = emuCursorCol st + 1+ in if nextCol >= emuCols st+ then+ st+ { emuCursorCol = 0+ , emuCursorRow = clampRow st (emuCursorRow st + 1)+ }+ else st{emuCursorCol = nextCol}++inBounds :: EmuState -> Int -> Int -> Bool+inBounds stateValue rowValue colValue =+ rowValue >= 0+ && colValue >= 0+ && rowValue < emuRows stateValue+ && colValue < emuCols stateValue++clampRow :: EmuState -> Int -> Int+clampRow stateValue rowValue =+ max 0 (min (emuRows stateValue - 1) rowValue)++clampCol :: EmuState -> Int -> Int+clampCol stateValue colValue =+ max 0 (min (emuCols stateValue - 1) colValue)++cellIndex :: EmuState -> Int -> Int -> Int+cellIndex stateValue rowValue colValue =+ rowValue * emuCols stateValue + colValue++renderEmuState :: EmuState -> Text+renderEmuState stateValue =+ T.intercalate "\n" (map renderRow [0 .. emuRows stateValue - 1])+ where+ renderRow rowValue =+ T.dropWhileEnd (== ' ') $+ T.pack+ [ maybe ' ' (cellValue) (IM.lookup (cellIndex stateValue rowValue colValue) (emuCells stateValue))+ | colValue <- [0 .. emuCols stateValue - 1]+ ]++serializeSnapshot :: SnapshotTheme -> EmuState -> String+serializeSnapshot theme stateValue =+ "{"+ <> "\"theme\":\""+ <> snapshotThemeName theme+ <> "\","+ <> "\"defaultFg\":"+ <> colorJson (paletteDefaultFg (themePalette theme))+ <> ","+ <> "\"defaultBg\":"+ <> colorJson (paletteDefaultBg (themePalette theme))+ <> ","+ <> "\"rows\":"+ <> show (emuRows stateValue)+ <> ","+ <> "\"cols\":"+ <> show (emuCols stateValue)+ <> ","+ <> "\"cells\":["+ <> intercalate "," (map serializeSnapshotRow (snapshotStyledRows theme stateValue))+ <> "]}"+ where+ serializeSnapshotRow rowValue =+ "["+ <> intercalate "," (map serializeSnapshotCell rowValue)+ <> "]"++ serializeSnapshotCell cellValue =+ "["+ <> intercalate+ ","+ [ show (ord (styledChar cellValue))+ , colorJson (styledFgColor cellValue)+ , colorJson (styledBgColor cellValue)+ ]+ <> "]"++ colorJson colorValue =+ let EmuColor rValue gValue bValue = colorValue+ in "["+ <> intercalate "," (map show [rValue, gValue, bValue])+ <> "]"++snapshotThemeName :: SnapshotTheme -> String+snapshotThemeName PtyDefaultDark = "pty-default-dark"+snapshotThemeName PtyDefaultLight = "pty-default-light"++selectorMatches :: Selector -> Viewport -> Bool+selectorMatches selector viewport =+ case selector of+ Exact textValue -> textValue `T.isInfixOf` viewportText viewport+ Regex patternText -> regexLikeMatch patternText (viewportText viewport)+ At col row ->+ case charAt col row (viewportText viewport) of+ Nothing -> False+ Just c -> c /= ' '+ Within rect nested ->+ selectorMatches nested (viewport{viewportText = cropRect rect (viewportText viewport)})+ Nth idx nested -> matchCount nested viewport > idx++assertNotAmbiguous :: Tui -> Selector -> Viewport -> IO ()+assertNotAmbiguous tui selector viewport =+ when shouldFail $+ throwIO $+ AssertionError+ ( "Ambiguous selector for test '"+ <> tuiName tui+ <> "'; matched "+ <> show totalMatches+ <> " elements."+ )+ where+ totalMatches = matchCount selector viewport+ mode = ambiguityMode (tuiOptions tui)+ shouldFail =+ mode == FailOnAmbiguous+ && totalMatches > 1+ && not (isExplicit selector)++ isExplicit sel =+ case sel of+ At _ _ -> True+ Nth _ _ -> True+ _ -> False++matchCount :: Selector -> Viewport -> Int+matchCount selector viewport =+ case selector of+ Exact textValue -> occurrenceCount textValue (viewportText viewport)+ Regex patternText ->+ let alternatives = filter (not . T.null) (map cleanPattern (T.splitOn "|" patternText))+ in sum (map (\alt -> regexAlternativeCount alt (viewportText viewport)) alternatives)+ At _ _ ->+ if selectorMatches selector viewport then 1 else 0+ Within _ _ ->+ if selectorMatches selector viewport then 1 else 0+ Nth _ _ ->+ if selectorMatches selector viewport then 1 else 0++regexAlternativeCount :: Text -> Text -> Int+regexAlternativeCount alternative haystack+ | ".*" `T.isInfixOf` alternative =+ if wildcardContains alternative haystack then 1 else 0+ | otherwise = occurrenceCount alternative haystack++regexLikeMatch :: Text -> Text -> Bool+regexLikeMatch patternText haystack =+ any (`wildcardContains` haystack) alternatives+ where+ alternatives =+ filter (not . T.null) $+ map cleanPattern (T.splitOn "|" patternText)++cleanPattern :: Text -> Text+cleanPattern = T.filter (`notElem` ("()" :: String))++wildcardContains :: Text -> Text -> Bool+wildcardContains patternText haystack =+ checkSegments 0 segments+ where+ segments = filter (not . T.null) (T.splitOn ".*" patternText)++ checkSegments :: Int -> [Text] -> Bool+ checkSegments _ [] = True+ checkSegments fromIdx (segment : rest) =+ let remaining = T.drop fromIdx haystack+ (prefix, suffix) = T.breakOn segment remaining+ in if T.null suffix+ then False+ else+ let nextStart = fromIdx + T.length prefix + T.length segment+ in checkSegments nextStart rest++occurrenceCount :: Text -> Text -> Int+occurrenceCount needle haystack+ | T.null needle = 0+ | otherwise = go 0 haystack+ where+ go count value =+ let (_, after) = T.breakOn needle value+ in if T.null after+ then count+ else go (count + 1) (T.drop (T.length needle) after)++charAt :: Int -> Int -> Text -> Maybe Char+charAt col row textValue+ | col < 0 || row < 0 = Nothing+ | otherwise = do+ line <- safeIndex row (T.lines textValue)+ safeTextIndex col line++cropRect :: Rect -> Text -> Text+cropRect rect textValue =+ T.intercalate "\n" croppedLines+ where+ linesInViewport = T.lines textValue+ y = rectRow rect+ h = rectHeight rect+ x = rectCol rect+ w = rectWidth rect+ selectedRows = take h (drop y linesInViewport)+ croppedLines = map (T.take w . T.drop x) selectedRows++safeIndex :: Int -> [a] -> Maybe a+safeIndex indexValue values+ | indexValue < 0 = Nothing+ | otherwise = go indexValue values+ where+ go _ [] = Nothing+ go 0 (x : _) = Just x+ go n (_ : xs) = go (n - 1) xs++safeTextIndex :: Int -> Text -> Maybe Char+safeTextIndex indexValue textValue+ | indexValue < 0 = Nothing+ | indexValue >= T.length textValue = Nothing+ | otherwise = Just (T.index textValue indexValue)++resolveArtifactsBaseDir :: FilePath -> FilePath -> IO FilePath+resolveArtifactsBaseDir projectRoot value = do+ let basePath =+ if isRelative value+ then projectRoot </> value+ else value+ createDirectoryIfMissing True basePath+ canonicalizePath basePath++printTuiTestSummary ::+ FilePath ->+ String ->+ TestStatus ->+ Int ->+ FilePath ->+ TuiState ->+ IO ()+printTuiTestSummary projectRoot name status attempts testRoot state = do+ let snapshotPaths = sort (nub (map T.unpack (snapshotLog state)))+ let statusLabel =+ case status of+ Passed -> "PASS"+ Failed _ -> "FAIL"+ putStrLn+ ( "[tuispec] "+ <> statusLabel+ <> " "+ <> name+ <> " (attempts="+ <> show attempts+ <> ")"+ )+ unless (null snapshotPaths) $+ do+ putStrLn ("[tuispec] artifacts: " <> makeRelative projectRoot testRoot)+ putStrLn ("[tuispec] snapshots:\n" <> renderSnapshotEntries state)++renderSnapshotEntries :: TuiState -> String+renderSnapshotEntries state =+ case nub (map T.unpack (snapshotLog state)) of+ [] -> " (none)\n"+ paths ->+ concatMap (\path -> " - " <> path <> "\n") (sort paths)++resetDirectory :: FilePath -> IO ()+resetDirectory dir = do+ exists <- doesDirectoryExist dir+ when exists (removePathForcibly dir)++safeFileStem :: String -> String+safeFileStem input =+ let lowered = map toLower input+ normalized = map normalize lowered+ compact = collapseDashes normalized+ trimmed = trimDashes compact+ in if null trimmed then "snapshot" else trimmed+ where+ normalize c+ | isAlphaNum c = c+ | otherwise = '-'++ collapseDashes [] = []+ collapseDashes ('-' : '-' : rest) = collapseDashes ('-' : rest)+ collapseDashes (c : rest) = c : collapseDashes rest++ trimDashes = reverse . dropWhile (== '-') . reverse . dropWhile (== '-')++slugify :: String -> String+slugify = safeFileStem++snapshotMetadataPath :: FilePath -> FilePath+snapshotMetadataPath ansiPath =+ if ".ansi.txt" `isSuffixOf` ansiPath+ then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"+ else ansiPath <> ".meta.json"++writeSnapshotMetadata :: FilePath -> Int -> Int -> IO ()+writeSnapshotMetadata metaPath rows cols =+ BL.writeFile+ metaPath+ ( encode+ ( object+ [ "rows" .= rows+ , "cols" .= cols+ ]+ )+ )++captureSnapshotToDir :: Tui -> FilePath -> SnapshotName -> IO (String, Text, FilePath)+captureSnapshotToDir tui targetDir snapshotName = do+ when (T.null (unSnapshotName snapshotName)) $+ throwIO (AssertionError "snapshot name cannot be empty")+ _ <- syncVisibleBuffer tui+ state <- readIORef (tuiStateRef tui)+ let actualAnsi = rawBuffer state+ let rows = terminalRows (tuiOptions tui)+ let cols = terminalCols (tuiOptions tui)+ let snapshotStem = safeFileStem (T.unpack (unSnapshotName snapshotName))+ createDirectoryIfMissing True targetDir+ let ansiPath = targetDir </> (snapshotStem <> ".ansi.txt")+ let metaPath = snapshotMetadataPath ansiPath+ TIO.writeFile ansiPath actualAnsi+ writeSnapshotMetadata metaPath rows cols+ appendSnapshotArtifact tui ansiPath+ pure (snapshotStem, actualAnsi, ansiPath)++applyEnvOverrides :: RunOptions -> IO RunOptions+applyEnvOverrides options = do+ timeoutValue <- envInt "TUISPEC_TIMEOUT_SECONDS"+ retriesValue <- envInt "TUISPEC_RETRIES"+ stepRetriesValue <- envInt "TUISPEC_STEP_RETRIES"+ colsValue <- envInt "TUISPEC_TERMINAL_COLS"+ rowsValue <- envInt "TUISPEC_TERMINAL_ROWS"+ artifactsValue <- lookupEnv "TUISPEC_ARTIFACTS_DIR"+ updateValue <- envBool "TUISPEC_UPDATE_SNAPSHOTS"+ ambiguityValue <- envAmbiguity "TUISPEC_AMBIGUITY_MODE"+ snapshotThemeValue <- lookupEnv "TUISPEC_SNAPSHOT_THEME"+ colorFgBgValue <- lookupEnv "COLORFGBG"+ let requestedTheme = fromMaybeString (snapshotTheme options) snapshotThemeValue+ effectiveTheme = resolveAutoSnapshotTheme requestedTheme colorFgBgValue+ pure+ options+ { timeoutSeconds = fromMaybeInt (timeoutSeconds options) timeoutValue+ , retries = fromMaybeInt (retries options) retriesValue+ , stepRetries = fromMaybeInt (stepRetries options) stepRetriesValue+ , terminalCols = fromMaybeInt (terminalCols options) colsValue+ , terminalRows = fromMaybeInt (terminalRows options) rowsValue+ , artifactsDir = fromMaybeString (artifactsDir options) artifactsValue+ , updateSnapshots = fromMaybeBool (updateSnapshots options) updateValue+ , ambiguityMode = fromMaybeAmbiguity (ambiguityMode options) ambiguityValue+ , snapshotTheme = effectiveTheme+ }+ where+ fromMaybeInt fallback maybeValue = maybe fallback id maybeValue+ fromMaybeBool fallback maybeValue = maybe fallback id maybeValue+ fromMaybeString fallback maybeValue = maybe fallback id maybeValue+ fromMaybeAmbiguity fallback maybeValue = maybe fallback id maybeValue++envInt :: String -> IO (Maybe Int)+envInt key = do+ value <- lookupEnv key+ pure (value >>= readMaybe)++envBool :: String -> IO (Maybe Bool)+envBool key = do+ value <- lookupEnv key+ pure (value >>= parseBool)+ where+ parseBool raw =+ case map toLower raw of+ "1" -> Just True+ "true" -> Just True+ "yes" -> Just True+ "on" -> Just True+ "0" -> Just False+ "false" -> Just False+ "no" -> Just False+ "off" -> Just False+ _ -> Nothing++envAmbiguity :: String -> IO (Maybe AmbiguityMode)+envAmbiguity key = do+ value <- lookupEnv key+ pure (value >>= parseAmbiguity)+ where+ parseAmbiguity raw =+ case map toLower raw of+ "fail" -> Just FailOnAmbiguous+ "first" -> Just FirstVisibleMatch+ "first-visible" -> Just FirstVisibleMatch+ _ -> Nothing++resolveAutoSnapshotTheme :: String -> Maybe String -> String+resolveAutoSnapshotTheme requestedTheme colorFgBgValue =+ case map toLower requestedTheme of+ "auto" ->+ case detectTerminalBackground colorFgBgValue of+ Just "light" -> "pty-default-light"+ _ -> "pty-default-dark"+ _ -> requestedTheme++detectTerminalBackground :: Maybe String -> Maybe String+detectTerminalBackground colorFgBgValue =+ case colorFgBgValue >>= parseBgIndex of+ Just bgIndex | bgIndex >= 7 -> Just "light"+ Just _ -> Just "dark"+ Nothing -> Nothing+ where+ parseBgIndex raw =+ case reverse (splitOn ';' raw) of+ [] -> Nothing+ lastPart : _ -> (readMaybe lastPart :: Maybe Int)++ splitOn _ [] = [""]+ splitOn delimiter input =+ case break (== delimiter) input of+ (headPart, []) -> [headPart]+ (headPart, _ : rest) -> headPart : splitOn delimiter rest++ignoreIOError :: IO () -> IO ()+ignoreIOError action =+ action `catch` \(_ :: SomeException) -> pure ()
+ src/TuiSpec/Server.hs view
@@ -0,0 +1,746 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : TuiSpec.Server+Description : JSON-RPC 2.0 server for interactive TUI orchestration.++Runs a newline-delimited JSON-RPC server on stdin\/stdout, allowing+external tools to drive TUI sessions programmatically.+-}+module TuiSpec.Server (+ ServerOptions (..),+ runServer,+) where++import Control.Exception (SomeException, displayException, finally, try)+import Control.Monad (when)+import Data.Aeson (FromJSON (parseJSON), Result (Error, Success), Value (Null, Object), eitherDecodeStrict', encode, fromJSON, object, withObject, (.:), (.:?), (.=))+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types qualified as AesonTypes+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy.Char8 qualified as BL8+import Data.Char (isAlphaNum, toLower)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (isSuffixOf)+import Data.Text (Text)+import Data.Text qualified as T+import JSONRPC qualified as RPC+import System.Directory (doesFileExist)+import System.Exit (ExitCode (ExitSuccess))+import System.FilePath ((</>))+import System.IO (hFlush, stdin, stdout)+import System.IO.Error (isEOFError, tryIOError)+import System.Posix.Process (exitImmediately)+import System.Posix.Signals (Handler (Catch), installHandler, sigHUP)+import TuiSpec.Runner (currentView, defaultWaitOptionsFor, dumpView, expectNotVisible, expectSnapshot, expectVisible, killSessionChildrenNow, launch, openSession, press, pressCombo, sendLine, typeText, waitForSelector)+import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch), App (App), Key (..), Modifier (Alt, Control, Shift), Rect (Rect), RunOptions (..), Selector (..), SnapshotName (SnapshotName), Tui (..), WaitOptions (..), defaultRunOptions)++-- | Configuration for the JSON-RPC server.+data ServerOptions = ServerOptions+ { serverArtifactsDir :: FilePath+ -- ^ Base directory for session artifacts.+ , serverTerminalCols :: Int+ -- ^ Default terminal columns for launched sessions.+ , serverTerminalRows :: Int+ -- ^ Default terminal rows for launched sessions.+ , serverTimeoutSeconds :: Int+ -- ^ Default timeout for wait operations.+ , serverAmbiguityMode :: AmbiguityMode+ -- ^ Default ambiguity mode for selector assertions.+ }+ deriving (Eq, Show)++data ActiveSession = ActiveSession+ { activeTui :: Tui+ }++data ServerState = ServerState+ { stateOptions :: ServerOptions+ , stateActiveSession :: IORef (Maybe ActiveSession)+ }++data DispatchOutcome+ = Continue Value+ | Shutdown Value++data RpcFailure = RpcFailure+ { failureCode :: Int+ , failureMessage :: Text+ , failureData :: Maybe Value+ }++-- | Run the JSON-RPC server, reading requests from stdin and writing responses to stdout.+runServer :: ServerOptions -> IO ()+runServer options = do+ sessionRef <- newIORef Nothing+ let state = ServerState{stateOptions = options, stateActiveSession = sessionRef}+ _ <- installHandler sigHUP (Catch (handleSighup state)) Nothing+ loop state `finally` killActiveChildrenNow state+ where+ handleSighup state = do+ killActiveChildrenNow state+ exitImmediately ExitSuccess++ loop state = do+ lineResult <- tryIOError (BS8.hGetLine stdin)+ case lineResult of+ Left ioErr+ | isEOFError ioErr -> pure ()+ | otherwise -> pure ()+ Right line ->+ if BS.null line+ then loop state+ else do+ shouldContinue <- handleLine state line+ when shouldContinue (loop state)++handleLine :: ServerState -> BS.ByteString -> IO Bool+handleLine state line =+ case eitherDecodeStrict' line :: Either String RPC.JSONRPCRequest of+ Left parseErr -> do+ writeErrorResponse (RPC.RequestId Null) (parseError parseErr)+ Right request ->+ case validateRequestVersion request of+ Left err -> do+ writeErrorResponse (requestId request) err+ Right () -> do+ outcome <- dispatchRequest state request+ case outcome of+ Left err ->+ writeErrorResponse (requestId request) err+ Right (Continue resultValue) ->+ writeSuccessResponse (requestId request) resultValue+ Right (Shutdown resultValue) -> do+ _ <- writeSuccessResponse (requestId request) resultValue+ pure False++validateRequestVersion :: RPC.JSONRPCRequest -> Either RpcFailure ()+validateRequestVersion request =+ if requestVersion request == RPC.rPC_VERSION+ then Right ()+ else Left (invalidRequest "Expected jsonrpc field to equal \"2.0\"")++dispatchRequest :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchRequest state request =+ case requestMethod request of+ "initialize" -> dispatchInitialize state request+ "launch" -> dispatchLaunch state request+ "sendKey" -> dispatchSendKey state request+ "sendText" -> dispatchSendText state request+ "sendLine" -> dispatchSendLine state request+ "currentView" -> dispatchCurrentView state request+ "dumpView" -> dispatchDumpView state request+ "expectSnapshot" -> dispatchExpectSnapshot state request+ "waitForText" -> dispatchWaitForText state request+ "expectVisible" -> dispatchExpectVisible state request+ "expectNotVisible" -> dispatchExpectNotVisible state request+ "server.ping" -> dispatchPing request+ "server.shutdown" -> dispatchShutdown state request+ unknownMethod ->+ pure $+ Left+ ( RpcFailure+ { failureCode = RPC.mETHOD_NOT_FOUND+ , failureMessage = "Method not found"+ , failureData = Just (object ["method" .= unknownMethod])+ }+ )++dispatchInitialize :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchInitialize state request = do+ existing <- readIORef (stateActiveSession state)+ case existing of+ Just _ ->+ pure (Left sessionAlreadyStartedError)+ Nothing ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params -> do+ let sessionName = T.unpack (T.strip (fromMaybeText "session" (startName params)))+ if null sessionName+ then pure (Left (invalidParams "session name cannot be empty"))+ else do+ case resolveAmbiguityOverride (startAmbiguityMode params) of+ Left ambiguityErr ->+ pure (Left (invalidParams ambiguityErr))+ Right ambiguityOverride -> do+ let runOptions = applyStartParams (stateOptions state) params ambiguityOverride+ sessionResult <- try (openSession runOptions sessionName) :: IO (Either SomeException Tui)+ case sessionResult of+ Left err ->+ pure (Left (methodFailed (displayException err)))+ Right tui -> do+ writeIORef (stateActiveSession state) (Just (ActiveSession tui))+ pure $+ Right $+ Continue+ ( object+ [ "sessionName" .= sessionName+ , "artifactRoot" .= tuiTestRoot tui+ , "rows" .= terminalRows (tuiOptions tui)+ , "cols" .= terminalCols (tuiOptions tui)+ ]+ )++dispatchLaunch :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchLaunch state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ launch (activeTui active) (App (launchCommand params) (launchArgs params))+ >> pure (object ["ok" .= True])++dispatchSendKey :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchSendKey state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ case parseSendKey (sendKeyValue params) of+ Left keyErr -> pure (Left (invalidParams keyErr))+ Right (modifiers, keyValue) ->+ runMethod $+ do+ if null modifiers+ then press (activeTui active) keyValue+ else pressCombo (activeTui active) modifiers keyValue+ pure (object ["ok" .= True])++dispatchSendText :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchSendText state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ typeText (activeTui active) (sendTextValue params)+ >> pure (object ["ok" .= True])++dispatchSendLine :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchSendLine state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ sendLine (activeTui active) (sendLineValue params)+ >> pure (object ["ok" .= True])++dispatchCurrentView :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchCurrentView state request =+ withActiveSession state $ \active ->+ case requireNoParams request of+ Left err -> pure (Left err)+ Right () ->+ runMethod $ do+ textValue <- currentView (activeTui active)+ let options = tuiOptions (activeTui active)+ pure+ ( object+ [ "text" .= textValue+ , "rows" .= terminalRows options+ , "cols" .= terminalCols options+ ]+ )++dispatchDumpView :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchDumpView state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ ansiPath <- dumpView (activeTui active) (SnapshotName (dumpName params))+ pure+ ( object+ [ "snapshotPath" .= ansiPath+ , "metaPath" .= snapshotMetaPath ansiPath+ ]+ )++dispatchExpectSnapshot :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchExpectSnapshot state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let snapshotText = expectSnapshotNameValue params+ let snapshotStem = safeSnapshotStem (T.unpack snapshotText)+ let tui = activeTui active+ let actualPath = tuiTestRoot tui </> "snapshots" </> (snapshotStem <> ".ansi.txt")+ let baselinePath = tuiSnapshotRoot tui </> (snapshotStem <> ".ansi.txt")+ expectSnapshot tui (SnapshotName snapshotText)+ baselineExists <- doesFileExist baselinePath+ pure+ ( object+ [ "ok" .= True+ , "actualPath" .= actualPath+ , "baselinePath" .= baselinePath+ , "baselineExists" .= baselineExists+ ]+ )++dispatchWaitForText :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchWaitForText state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ let defaults = defaultWaitOptionsFor tui+ let mergedWaitOptions =+ defaults+ { timeoutMs = maybe (timeoutMs defaults) id (waitTimeoutMs params)+ , pollIntervalMs = maybe (pollIntervalMs defaults) id (waitPollIntervalMs params)+ }+ waitForSelector tui mergedWaitOptions (waitSelector params)+ pure (object ["ok" .= True])++dispatchExpectVisible :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchExpectVisible state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ expectVisible (activeTui active) (selectorValue params)+ >> pure (object ["ok" .= True])++dispatchExpectNotVisible :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchExpectNotVisible state request =+ withActiveSession state $ \active ->+ case decodeParams request of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ expectNotVisible (activeTui active) (selectorValue params)+ >> pure (object ["ok" .= True])++dispatchPing :: RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchPing request =+ case requireNoParams request of+ Left err -> pure (Left err)+ Right () ->+ pure+ ( Right+ ( Continue+ ( object+ [ "pong" .= True+ , "version" .= ("0.1.0.0" :: String)+ ]+ )+ )+ )++dispatchShutdown :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)+dispatchShutdown state request =+ case requireNoParams request of+ Left err -> pure (Left err)+ Right () -> do+ killActiveChildrenNow state+ pure+ ( Right+ ( Shutdown+ ( object+ [ "shuttingDown" .= True+ ]+ )+ )+ )++withActiveSession :: ServerState -> (ActiveSession -> IO (Either RpcFailure DispatchOutcome)) -> IO (Either RpcFailure DispatchOutcome)+withActiveSession state action = do+ maybeActive <- readIORef (stateActiveSession state)+ case maybeActive of+ Nothing -> pure (Left noActiveSessionError)+ Just active -> action active++killActiveChildrenNow :: ServerState -> IO ()+killActiveChildrenNow state = do+ maybeActive <- readIORef (stateActiveSession state)+ case maybeActive of+ Nothing -> pure ()+ Just active -> killSessionChildrenNow (activeTui active)++runMethod :: IO Value -> IO (Either RpcFailure DispatchOutcome)+runMethod action = do+ result <- try action :: IO (Either SomeException Value)+ pure $+ case result of+ Left err -> Left (methodFailed (displayException err))+ Right value -> Right (Continue value)++writeSuccessResponse :: RPC.RequestId -> Value -> IO Bool+writeSuccessResponse reqId resultValue =+ writeJsonLine+ ( encode+ (RPC.JSONRPCResponse RPC.rPC_VERSION reqId resultValue)+ )++writeErrorResponse :: RPC.RequestId -> RpcFailure -> IO Bool+writeErrorResponse reqId failure =+ writeJsonLine+ ( encode+ ( RPC.JSONRPCError+ RPC.rPC_VERSION+ reqId+ (RPC.JSONRPCErrorInfo (failureCode failure) (failureMessage failure) (failureData failure))+ )+ )++writeJsonLine :: BL8.ByteString -> IO Bool+writeJsonLine bytes = do+ writeResult <-+ tryIOError $ do+ BL8.hPutStr stdout bytes+ BL8.hPutStr stdout "\n"+ hFlush stdout+ pure $+ case writeResult of+ Left _ -> False+ Right () -> True++decodeParams :: (FromJSON a) => RPC.JSONRPCRequest -> Either RpcFailure a+decodeParams request =+ case fromJSON (requestParams request) of+ Error err -> Left (invalidParams err)+ Success value -> Right value++requireNoParams :: RPC.JSONRPCRequest -> Either RpcFailure ()+requireNoParams request =+ case requestParams request of+ Null -> Right ()+ Object keyMap+ | KM.null keyMap -> Right ()+ _ -> Left (invalidParams "expected params to be null or empty object")++invalidRequest :: String -> RpcFailure+invalidRequest details =+ RpcFailure+ { failureCode = RPC.iNVALID_REQUEST+ , failureMessage = "Invalid request"+ , failureData = Just (object ["details" .= details])+ }++invalidParams :: String -> RpcFailure+invalidParams details =+ RpcFailure+ { failureCode = RPC.iNVALID_PARAMS+ , failureMessage = "Invalid params"+ , failureData = Just (object ["details" .= details])+ }++parseError :: String -> RpcFailure+parseError details =+ RpcFailure+ { failureCode = RPC.pARSE_ERROR+ , failureMessage = "Parse error"+ , failureData = Just (object ["details" .= details])+ }++methodFailed :: String -> RpcFailure+methodFailed details =+ RpcFailure+ { failureCode = -32004+ , failureMessage = "Method failed"+ , failureData = Just (object ["details" .= details])+ }++noActiveSessionError :: RpcFailure+noActiveSessionError =+ RpcFailure+ { failureCode = -32001+ , failureMessage = "No active session"+ , failureData = Nothing+ }++sessionAlreadyStartedError :: RpcFailure+sessionAlreadyStartedError =+ RpcFailure+ { failureCode = -32002+ , failureMessage = "Session already started"+ , failureData = Nothing+ }++data StartParams = StartParams+ { startName :: Maybe Text+ , startTimeoutSeconds :: Maybe Int+ , startTerminalCols :: Maybe Int+ , startTerminalRows :: Maybe Int+ , startAmbiguityMode :: Maybe Text+ , startSnapshotTheme :: Maybe Text+ , startUpdateSnapshots :: Maybe Bool+ }++instance FromJSON StartParams where+ parseJSON value =+ case value of+ Null -> pure defaultStartParams+ _ ->+ withObject "StartParams" parseObject value+ where+ parseObject o =+ StartParams+ <$> o .:? "name"+ <*> o .:? "timeoutSeconds"+ <*> o .:? "terminalCols"+ <*> o .:? "terminalRows"+ <*> o .:? "ambiguityMode"+ <*> o .:? "snapshotTheme"+ <*> o .:? "updateSnapshots"++defaultStartParams :: StartParams+defaultStartParams =+ StartParams+ { startName = Nothing+ , startTimeoutSeconds = Nothing+ , startTerminalCols = Nothing+ , startTerminalRows = Nothing+ , startAmbiguityMode = Nothing+ , startSnapshotTheme = Nothing+ , startUpdateSnapshots = Nothing+ }++data LaunchParams = LaunchParams+ { launchCommand :: FilePath+ , launchArgs :: [String]+ }++instance FromJSON LaunchParams where+ parseJSON =+ withObject "LaunchParams" $ \o ->+ LaunchParams+ <$> o .: "command"+ <*> o .:? "args" AesonTypes..!= []++data SendKeyParams = SendKeyParams+ { sendKeyValue :: Text+ }++instance FromJSON SendKeyParams where+ parseJSON =+ withObject "SendKeyParams" $ \o ->+ SendKeyParams <$> o .: "key"++data SendTextParams = SendTextParams+ { sendTextValue :: Text+ }++instance FromJSON SendTextParams where+ parseJSON =+ withObject "SendTextParams" $ \o ->+ SendTextParams <$> o .: "text"++data SendLineParams = SendLineParams+ { sendLineValue :: Text+ }++instance FromJSON SendLineParams where+ parseJSON =+ withObject "SendLineParams" $ \o ->+ SendLineParams <$> o .: "text"++data DumpViewParams = DumpViewParams+ { dumpName :: Text+ }++instance FromJSON DumpViewParams where+ parseJSON =+ withObject "DumpViewParams" $ \o ->+ DumpViewParams <$> o .: "name"++data ExpectSnapshotParams = ExpectSnapshotParams+ { expectSnapshotNameValue :: Text+ }++instance FromJSON ExpectSnapshotParams where+ parseJSON =+ withObject "ExpectSnapshotParams" $ \o ->+ ExpectSnapshotParams <$> o .: "name"++data SelectorParams = SelectorParams+ { selectorValue :: Selector+ }++instance FromJSON SelectorParams where+ parseJSON =+ withObject "SelectorParams" $ \o ->+ SelectorParams <$> (o .: "selector" >>= parseSelector)++data WaitForTextParams = WaitForTextParams+ { waitSelector :: Selector+ , waitTimeoutMs :: Maybe Int+ , waitPollIntervalMs :: Maybe Int+ }++instance FromJSON WaitForTextParams where+ parseJSON =+ withObject "WaitForTextParams" $ \o ->+ WaitForTextParams+ <$> (o .: "selector" >>= parseSelector)+ <*> o .:? "timeoutMs"+ <*> o .:? "pollIntervalMs"++parseSelector :: Value -> AesonTypes.Parser Selector+parseSelector =+ withObject "Selector" $ \o -> do+ selectorType <- (T.toLower <$> (o .: "type" :: AesonTypes.Parser Text))+ case selectorType of+ "exact" -> Exact <$> o .: "text"+ "regex" -> Regex <$> o .: "pattern"+ "at" -> At <$> o .: "col" <*> o .: "row"+ "within" -> do+ rectValue <- o .: "rect" >>= parseRect+ nested <- o .: "selector" >>= parseSelector+ pure (Within rectValue nested)+ "nth" -> Nth <$> o .: "index" <*> (o .: "selector" >>= parseSelector)+ _ -> fail ("unknown selector type: " <> T.unpack selectorType)++parseRect :: Value -> AesonTypes.Parser Rect+parseRect =+ withObject "Rect" $ \o ->+ Rect+ <$> o .: "col"+ <*> o .: "row"+ <*> o .: "width"+ <*> o .: "height"++requestId :: RPC.JSONRPCRequest -> RPC.RequestId+requestId (RPC.JSONRPCRequest _ reqId _ _) = reqId++requestVersion :: RPC.JSONRPCRequest -> Text+requestVersion (RPC.JSONRPCRequest version _ _ _) = version++requestMethod :: RPC.JSONRPCRequest -> Text+requestMethod (RPC.JSONRPCRequest _ _ methodName _) = methodName++requestParams :: RPC.JSONRPCRequest -> Value+requestParams (RPC.JSONRPCRequest _ _ _ paramsValue) = paramsValue++applyStartParams :: ServerOptions -> StartParams -> Maybe AmbiguityMode -> RunOptions+applyStartParams options params ambiguityOverride =+ defaultRunOptions+ { timeoutSeconds = maybe (serverTimeoutSeconds options) id (startTimeoutSeconds params)+ , terminalCols = maybe (serverTerminalCols options) id (startTerminalCols params)+ , terminalRows = maybe (serverTerminalRows options) id (startTerminalRows params)+ , artifactsDir = serverArtifactsDir options+ , ambiguityMode = maybe (serverAmbiguityMode options) id ambiguityOverride+ , updateSnapshots = maybe False id (startUpdateSnapshots params)+ , snapshotTheme = maybe "auto" T.unpack (startSnapshotTheme params)+ }++resolveAmbiguityOverride :: Maybe Text -> Either String (Maybe AmbiguityMode)+resolveAmbiguityOverride maybeRaw =+ case maybeRaw of+ Nothing -> Right Nothing+ Just raw ->+ case parseAmbiguityMode raw of+ Just mode -> Right (Just mode)+ Nothing ->+ Left "ambiguityMode must be one of: fail, first, first-visible"++parseAmbiguityMode :: Text -> Maybe AmbiguityMode+parseAmbiguityMode raw =+ case map toLower (T.unpack (T.strip raw)) of+ "fail" -> Just FailOnAmbiguous+ "first" -> Just FirstVisibleMatch+ "first-visible" -> Just FirstVisibleMatch+ _ -> Nothing++parseSendKey :: Text -> Either String ([Modifier], Key)+parseSendKey rawKey =+ if trimmed == "+"+ then (,) [] <$> parseBaseKey trimmed+ else case T.breakOn "+" trimmed of+ (_, "") ->+ (,) [] <$> parseBaseKey trimmed+ (modifierText, remainder) ->+ do+ modifier <- parseModifier (T.strip modifierText)+ keyValue <- parseModifiedKey (T.strip (T.drop 1 remainder))+ pure ([modifier], keyValue)+ where+ trimmed = T.strip rawKey++ parseModifier textValue =+ case map toLower (T.unpack textValue) of+ "ctrl" -> Right Control+ "control" -> Right Control+ "alt" -> Right Alt+ "shift" -> Right Shift+ _ -> Left ("unknown modifier: " <> T.unpack textValue)++ parseModifiedKey textValue =+ case T.unpack textValue of+ [charValue] -> Right (CharKey charValue)+ _ -> Left "modified keys must use a single character (for example Ctrl+C)"++parseBaseKey :: Text -> Either String Key+parseBaseKey keyText =+ let lowered = map toLower (T.unpack (T.strip keyText))+ in case lowered of+ "enter" -> Right Enter+ "esc" -> Right Esc+ "escape" -> Right Esc+ "tab" -> Right Tab+ "backspace" -> Right Backspace+ "arrowup" -> Right ArrowUp+ "arrowdown" -> Right ArrowDown+ "arrowleft" -> Right ArrowLeft+ "arrowright" -> Right ArrowRight+ "space" -> Right (CharKey ' ')+ _ ->+ case parseFunctionKey lowered of+ Just functionNumber -> Right (FunctionKey functionNumber)+ Nothing ->+ case T.unpack (T.strip keyText) of+ [charValue] -> Right (CharKey charValue)+ _ -> Left ("unknown key: " <> T.unpack keyText)++parseFunctionKey :: String -> Maybe Int+parseFunctionKey lowered =+ case lowered of+ 'f' : digits+ | all isDigitAscii digits ->+ case reads digits of+ [(value, "")]+ | value >= 1 && value <= 12 -> Just value+ _ -> Nothing+ _ -> Nothing+ where+ isDigitAscii c = c >= '0' && c <= '9'++snapshotMetaPath :: FilePath -> FilePath+snapshotMetaPath ansiPath =+ if ".ansi.txt" `isSuffixOf` ansiPath+ then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"+ else ansiPath <> ".meta.json"++safeSnapshotStem :: String -> String+safeSnapshotStem input =+ let lowered = map toLower input+ normalized = map normalize lowered+ compact = collapseDashes normalized+ trimmed = trimDashes compact+ in if null trimmed then "snapshot" else trimmed+ where+ normalize c+ | isAlphaNum c = c+ | otherwise = '-'++ collapseDashes [] = []+ collapseDashes ('-' : '-' : rest) = collapseDashes ('-' : rest)+ collapseDashes (c : rest) = c : collapseDashes rest++ trimDashes = reverse . dropWhile (== '-') . reverse . dropWhile (== '-')++fromMaybeText :: Text -> Maybe Text -> Text+fromMaybeText fallback maybeValue =+ case maybeValue of+ Just value -> value+ Nothing -> fallback
+ src/TuiSpec/Types.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Module : TuiSpec.Types+Description : Core types for TUI test specs, selectors, and runtime options.++These types are the public DSL surface used by test programs.+-}+module TuiSpec.Types (+ AmbiguityMode (..),+ App (..),+ Key (..),+ Modifier (..),+ PtyHandle (..),+ Rect (..),+ RunOptions (..),+ Selector (..),+ SnapshotName (..),+ Spec (..),+ StepOptions (..),+ Tui (..),+ TuiState (..),+ Viewport (..),+ WaitOptions (..),+ defaultRunOptions,+ defaultStepOptions,+ defaultWaitOptions,+) where++import Data.IORef (IORef)+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T+import System.Posix.Pty (Pty)+import System.Process (ProcessHandle)++-- | A single test specification: name + executable body.+data Spec = Spec+ { specName :: String+ , specBody :: Tui -> IO ()+ }++-- | The command to launch inside the PTY.+data App = App+ { command :: FilePath+ , args :: [String]+ }+ deriving (Eq, Show)++-- | How selector ambiguity is handled for assertion helpers.+data AmbiguityMode+ = FailOnAmbiguous+ | FirstVisibleMatch+ deriving (Eq, Show, Read)++-- | Runtime options for a @tuiTest@ execution.+data RunOptions = RunOptions+ { timeoutSeconds :: Int+ , retries :: Int+ , stepRetries :: Int+ , terminalCols :: Int+ , terminalRows :: Int+ , artifactsDir :: FilePath+ , ambiguityMode :: AmbiguityMode+ , updateSnapshots :: Bool+ , snapshotTheme :: String+ }+ deriving (Eq, Show)++{- | Sensible defaults for local and CI runs.++Defaults:++- timeout: 5s+- retries: 0+- viewport: 134x40+- artifacts dir: @artifacts@+-}+defaultRunOptions :: RunOptions+defaultRunOptions =+ RunOptions+ { timeoutSeconds = 5+ , retries = 0+ , stepRetries = 0+ , terminalCols = 134+ , terminalRows = 40+ , artifactsDir = "artifacts"+ , ambiguityMode = FailOnAmbiguous+ , updateSnapshots = False+ , snapshotTheme = "auto"+ }++-- | Key modifiers for combo key presses.+data Modifier+ = Control+ | Alt+ | Shift+ deriving (Eq, Show, Read)++-- | Input key model used by @press@ and @pressCombo@.+data Key+ = Enter+ | Esc+ | Tab+ | Backspace+ | ArrowUp+ | ArrowDown+ | ArrowLeft+ | ArrowRight+ | Ctrl Char+ | AltKey Char+ | FunctionKey Int+ | CharKey Char+ | NamedKey Text+ deriving (Eq, Show, Read)++-- | A rectangular region within the terminal viewport.+data Rect = Rect+ { rectCol :: Int+ , rectRow :: Int+ , rectWidth :: Int+ , rectHeight :: Int+ }+ deriving (Eq, Show, Read)++-- | Selector language used by visibility and text assertions.+data Selector+ = Exact Text+ | Regex Text+ | At Int Int+ | Within Rect Selector+ | Nth Int Selector+ deriving (Eq, Show, Read)++-- | Polling behavior for @waitFor@.+data WaitOptions = WaitOptions+ { timeoutMs :: Int+ , pollIntervalMs :: Int+ }+ deriving (Eq, Show, Read)++-- | Default wait behavior: 30s timeout with 100ms polling.+defaultWaitOptions :: WaitOptions+defaultWaitOptions =+ WaitOptions+ { timeoutMs = 30000+ , pollIntervalMs = 100+ }++-- | Strongly-typed snapshot identifier.+newtype SnapshotName = SnapshotName+ { unSnapshotName :: Text+ }+ deriving (Eq, Ord, Show)++instance IsString SnapshotName where+ fromString = SnapshotName . T.pack++-- | Retry behavior for a single logical test step.+data StepOptions = StepOptions+ { stepMaxRetries :: Int+ , stepRetryDelayMs :: Int+ }+ deriving (Eq, Show, Read)++-- | Default step retries: no retries, no delay.+defaultStepOptions :: StepOptions+defaultStepOptions =+ StepOptions+ { stepMaxRetries = 0+ , stepRetryDelayMs = 0+ }++-- | The current terminal viewport text plus dimensions.+data Viewport = Viewport+ { viewportCols :: Int+ , viewportRows :: Int+ , viewportText :: Text+ }+ deriving (Eq, Show)++-- | Handle to the child process and PTY master descriptor.+data PtyHandle = PtyHandle+ { ptyMaster :: Pty+ , ptyProcess :: ProcessHandle+ }++-- | Mutable runtime state tracked while a test executes.+data TuiState = TuiState+ { launchedApp :: Maybe App+ , visibleBuffer :: Text+ , rawBuffer :: Text+ , actionLog :: [Text]+ , snapshotLog :: [Text]+ , runtimeWarnings :: [Text]+ , frameLog :: [Text]+ }++{- | Runtime test handle passed into each spec body.++This is intentionally opaque in normal test usage, even though+record fields are exported for advanced integrations.+-}+data Tui = Tui+ { tuiName :: String+ , tuiOptions :: RunOptions+ , tuiRootDir :: FilePath+ , tuiTestRoot :: FilePath+ , tuiSnapshotRoot :: FilePath+ , tuiPty :: IORef (Maybe PtyHandle)+ , tuiStateRef :: IORef TuiState+ }
+ test/Spec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import System.Directory (doesFileExist)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)+import TuiSpec++main :: IO ()+main =+ defaultMain $+ testGroup+ "tuispec"+ [ tuiTest+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/smoke"+ , ambiguityMode = FirstVisibleMatch+ }+ "smoke: text appears in viewport"+ $ \tui -> do+ launch tui (App "sh" [])+ sendLine tui "printf 'hello from tuispec\\n'"+ waitForText tui (Exact "hello from tuispec")+ expectNotVisible tui (Exact "this text should not exist")+ expectSnapshot tui "smoke-viewport"+ sendLine tui "exit"+ , testCase "smoke: repl session can dump view" $ do+ snapshotPath <-+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-smoke"+ }+ "session"+ $ \tui -> do+ launch tui (App "sh" [])+ sendLine tui "printf 'hello from repl session\\n'"+ snapshotPath <- dumpView tui "repl-view"+ sendLine tui "exit"+ pure snapshotPath+ exists <- doesFileExist snapshotPath+ assertBool "dumpView should write an ansi snapshot file" exists+ ]
+ tuispec.cabal view
@@ -0,0 +1,103 @@+cabal-version: 3.8+name: tuispec+version: 0.1.0.0+build-type: Simple+license: MIT+license-file: LICENSE+author: Matthias Pall Gissurarson+maintainer: mpg@mpg.is+copyright: 2026 Matthias Pall Gissurarson+synopsis: Playwright-like black-box testing for terminal UIs over PTY+description:+ @tuispec@ is a Haskell framework for black-box testing of terminal user+ interfaces (TUIs) over PTY.+ .+ It provides a Playwright-inspired DSL for launching apps, sending+ keystrokes, waiting for text, and capturing snapshots (ANSI text + PNG).+ .+ Tests are regular compiled Haskell programs using @tasty@ with per-test+ isolation via fresh PTY processes. The framework is generic to any TUI+ binary runnable from a shell, with no instrumentation required inside the+ target app.+ .+ Features include:+ .+ * PTY transport with per-test isolation+ * Text selectors (@Exact@, @Regex@, @At@, @Within@, @Nth@)+ * Keypress and text input actions+ * Snapshot assertions with ANSI text + PNG artifacts+ * Configurable retry, timeout, and ambiguity modes+ * JSON-RPC server for interactive orchestration+ * REPL-style session mode for ad-hoc exploration++category: Testing+homepage: https://github.com/Tritlo/tuispec+bug-reports: https://github.com/Tritlo/tuispec/issues+tested-with: ghc ==9.12.2+extra-doc-files:+ CHANGELOG.md+ README.md+ SERVER.md+ SKILL.md+ SPEC.md+ doc/example-dashboard-ioskeley-dark.png+ doc/example-board-ioskeley-light.png++source-repository head+ type: git+ location: https://github.com/Tritlo/tuispec.git++common common-settings+ default-language: GHC2021+ ghc-options: -Wall++library+ import: common-settings+ hs-source-dirs: src+ exposed-modules:+ TuiSpec+ TuiSpec.Render+ TuiSpec.Runner+ TuiSpec.Server+ TuiSpec.Types++ other-modules:+ TuiSpec.ProjectRoot++ build-depends:+ aeson >=2.0 && <2.3,+ base >=4.16 && <5,+ bytestring >=0.11 && <0.13,+ containers >=0.6 && <0.8,+ directory >=1.3 && <1.4,+ filepath >=1.4 && <1.6,+ jsonrpc >=0.2 && <0.3,+ posix-pty >=0.2 && <0.3,+ process >=1.6 && <1.7,+ tasty >=1.4 && <1.6,+ tasty-hunit >=0.10 && <0.11,+ text >=1.2 && <2.2,+ time >=1.9 && <1.15,+ unix >=2.8 && <2.9,++executable tuispec+ import: common-settings+ hs-source-dirs: app+ main-is: Main.hs+ build-depends:+ base >=4.16 && <5,+ optparse-applicative >=0.18 && <0.20,+ tuispec,++test-suite tuispec-smoke+ import: common-settings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ base >=4.16 && <5,+ directory >=1.3 && <1.4,+ tasty >=1.4 && <1.6,+ tasty-hunit >=0.10 && <0.11,+ text >=1.2 && <2.2,+ tuispec,