diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0.0 — 2026-02-23 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,218 @@ +# tuispec + +[![Hackage](https://img.shields.io/hackage/v/tuispec.svg)](https://hackage.haskell.org/package/tuispec) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](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`: + +![Board snapshot (IoskeleyMono, light theme)](doc/example-board-ioskeley-light.png) +![Dashboard snapshot (IoskeleyMono, dark theme)](doc/example-dashboard-ioskeley-dark.png) + +## 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/.ansi.txt` +- **Per-run**: `artifacts/tests/my-test/snapshots/.ansi.txt` + +Render any ANSI snapshot to PNG: + +```bash +cabal run tuispec -- render artifacts/tests/my-test/snapshots/.ansi.txt +``` + +Specify an explicit font file: + +```bash +cabal run tuispec -- render --font /path/to/YourMono.ttf artifacts/tests/my-test/snapshots/.ansi.txt +``` + +Render visible plain text: + +```bash +cabal run tuispec -- render-text artifacts/tests/my-test/snapshots/.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 diff --git a/SERVER.md b/SERVER.md new file mode 100644 --- /dev/null +++ b/SERVER.md @@ -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/.ansi.txt` +- `X/sessions/foo/snapshots/.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 diff --git a/SKILL.md b/SKILL.md new file mode 100644 --- /dev/null +++ b/SKILL.md @@ -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 `.ansi.txt` + `.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/.ansi.txt` +- `artifacts/server/sessions/demo/snapshots/.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 +``` diff --git a/SPEC.md b/SPEC.md new file mode 100644 --- /dev/null +++ b/SPEC.md @@ -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//` +- 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: +- `.ansi.txt` +- `.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/.ansi.txt` + - `artifacts/tests/my-test/snapshots/.meta.json` + +- baseline snapshots: + - `artifacts/snapshots/my-test/.ansi.txt` + - `artifacts/snapshots/my-test/.meta.json` + +For ad-hoc sessions (`withTuiSession "session-name"`): +- `artifacts/sessions/session-name/snapshots/.ansi.txt` +- `artifacts/sessions/session-name/snapshots/.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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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" diff --git a/doc/example-board-ioskeley-light.png b/doc/example-board-ioskeley-light.png new file mode 100644 Binary files /dev/null and b/doc/example-board-ioskeley-light.png differ diff --git a/doc/example-dashboard-ioskeley-dark.png b/doc/example-dashboard-ioskeley-dark.png new file mode 100644 Binary files /dev/null and b/doc/example-dashboard-ioskeley-dark.png differ diff --git a/src/TuiSpec.hs b/src/TuiSpec.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec.hs @@ -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 diff --git a/src/TuiSpec/ProjectRoot.hs b/src/TuiSpec/ProjectRoot.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/ProjectRoot.hs @@ -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) diff --git a/src/TuiSpec/Render.hs b/src/TuiSpec/Render.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Render.hs @@ -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 () diff --git a/src/TuiSpec/Runner.hs b/src/TuiSpec/Runner.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Runner.hs @@ -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//snapshots/.ansi.txt@ +- baseline: @artifacts/snapshots//.ansi.txt@ +- metadata for both paths: @.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 () diff --git a/src/TuiSpec/Server.hs b/src/TuiSpec/Server.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Server.hs @@ -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 diff --git a/src/TuiSpec/Types.hs b/src/TuiSpec/Types.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Types.hs @@ -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 + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/tuispec.cabal b/tuispec.cabal new file mode 100644 --- /dev/null +++ b/tuispec.cabal @@ -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,