tuispec 0.2.0.0 → 0.3.1.1
raw patch · 15 files changed
Files
- CHANGELOG.md +27/−0
- README.md +12/−0
- SERVER.md +10/−0
- SKILL.md +54/−0
- SPEC.md +43/−0
- cbits/tuispec_pty.c +6/−0
- src/TuiSpec.hs +30/−0
- src/TuiSpec/Choice.hs +177/−0
- src/TuiSpec/Internal.hs +32/−2
- src/TuiSpec/Replay.hs +21/−2
- src/TuiSpec/Runner.hs +554/−45
- src/TuiSpec/Server.hs +77/−2
- src/TuiSpec/Types.hs +104/−9
- test/Spec.hs +208/−31
- tuispec.cabal +3/−1
CHANGELOG.md view
@@ -1,5 +1,32 @@ # Changelog +## 0.3.1.1 — 2026-06-06++* Fix selector clicks landing on the wrong column. A regex/substring selector resolved to its matching line's first non-blank column instead of the actual match position, so clicking centred text (e.g. a label behind a box border) hit the line's left edge and missed. `regexOrigins` now reports the match's start column via new origin-returning matchers `regexLikeMatchOrigin`/`wildcardContainsOrigin`, in terms of which the boolean `regexLikeMatch`/`wildcardContains` are now defined (so match and origin can't diverge).++## 0.3.1.0 — 2026-06-06++* Add mouse click simulation. DSL: `click`/`clickWith` (0-based coordinate) and `clickSelector`/`clickSelectorWith` (Playwright-style, resolves a selector to its match origin and honors `ambiguityMode`). New `MouseButton`, `MouseEncoding`, and `ClickOptions`/`defaultClickOptions` types. JSON-RPC: a `click` method accepting either `{col,row}` (1-based) or `{selector}`, with optional `button` and `encoding`. Clicks emit a press + release; SGR encoding is the default (what `vty`/Brick enable), with an `x10` override.++## 0.3.0.0 — 2026-04-30++* **Breaking:** the `App` type is now a sum (`App` | `HaskellApp`) so it no longer derives `Eq`. The `Show` instance is kept (now hand-written). `command`, `args`, `appName`, and `appAction` accessors are partial — pattern match on the constructor when both shapes are possible.++* Add `haskellApp` for launching a Haskell `IO ()` action under a PTY without a separate target executable.+* Expose `artifactRoot` to let tests locate the per-test directory for logs and auxiliary files.+* Add Haskell DSL helpers for ready-gated launches (`launchAndWait`), artifact paths/writes, env-file loading, PATH prepending, numbered choice selection, manual failure bundles, and JSONL recording export.+* Add `TuiSpec.Choice` for parsing and selecting numbered choices without tying the API to a modal or menu widget.+* Add `currentViewRect` for retrieving viewport text cropped to a `Rect`.+* Locate the built `tuispec` executable in both `dist-newstyle` and `dist` build trees, and honor a `TUISPEC_EXECUTABLE` override, so the test suite works under `Setup.hs`/`v1-build` (#1).+* Surface "launched app exited" failures from `press`, `pressCombo`, and `typeText` instead of writing into a closed PTY.+* Parse numbered choice labels correctly when the line contains a trailing border (e.g. `> 1) Haskell │ Modern` now yields `Haskell`, not `Haskell Modern`).+* Switch internal logs (actions, frames, warnings, snapshot artifacts) to amortised-O(1) prepend storage; the `actionLog`/`frameLog`/`snapshotLog`/`runtimeWarnings` fields of `TuiState` are now newest-first (reverse before display).+* Add `recordTraceTo :: Maybe FilePath` to `RunOptions`. When set, the runner writes a JSONL trace recording with real wall-clock timestamps to that path under each test's artifact directory; replay with `tuispec replay PATH`. **Breaking:** `frameLog` is now `[(Int64, Text)]` (microseconds-since-session-start, frame text), not `[Text]`, and `Tui` gained a `tuiSessionStart :: UTCTime` field.+* Automatically write a diagnostic failure bundle for failed Haskell DSL tests.+* Surface the underlying exception when PTY launch fails instead of reporting a generic "backend unavailable" error.+* Fail waits when the launched app exits before the selector or stability condition is reached.+* Skip the post-test viewport sync when no PTY is active, avoiding spurious work after a failed launch.+ ## 0.2.0.0 — 2026-02-24 * Add `waitForStable` primitive (DSL + JSON-RPC) to replace fixed sleeps with debounce-based viewport stability checks.
README.md view
@@ -86,10 +86,18 @@ app :: FilePath -> [String] -> App press :: Tui -> Key -> IO () pressCombo :: Tui -> [Modifier] -> Key -> IO ()+click :: Tui -> Int -> Int -> IO () -- left-click at (col, row), 0-based+clickSelector :: Tui -> Selector -> IO () -- click the element a selector matches typeText :: Tui -> Text -> IO () sendLine :: Tui -> Text -> IO () ``` +Mouse clicks are written to the PTY just like keys, so the target app only+reacts if it has enabled mouse tracking (anything built on `vty`/Brick does+once mouse mode is on). The default SGR encoding suits any modern TUI; use+`clickWith`/`clickSelectorWith` with `ClickOptions` to pick the button+(`MouseLeft`/`MouseMiddle`/`MouseRight`) or the legacy X10 encoding.+ ### Waits and assertions ```haskell@@ -191,7 +199,11 @@ {"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"}}+{"jsonrpc":"2.0","id":10,"method":"click","params":{"col":12,"row":7}}+{"jsonrpc":"2.0","id":11,"method":"click","params":{"selector":{"type":"exact","text":"OK"}}} ```++(Server `click` coordinates are 1-based, like the `at` selector.) Replay a recording JSONL file:
SERVER.md view
@@ -82,6 +82,16 @@ - `sendKey` - params: `key` +- `click`+ - params (one of two targets):+ - coordinate form: `col`, `row` (both 1-based)+ - selector form: `selector`+ - optional `button` (`left` | `middle` | `right`, default `left`)+ - optional `encoding` (`sgr` | `x10`, default `sgr`)+ - result: `ok`+ - emits a button press and release; the target app must have mouse+ tracking enabled (vty/Brick apps do once mouse mode is turned on)+ - `sendText` - params: `text`
SKILL.md view
@@ -94,6 +94,43 @@ - Bind a local `wait` helper so every action is followed by a stability gate - No `threadDelay` anywhere +## Other DSL helpers (0.3+)++Beyond the minimal example, the library exposes:++- `launchAndWait tui appSpec readySelector` — launch and wait for a ready+ selector in one call (uses session defaults; see `launchAndWaitWith` for+ explicit `WaitOptions`).+- `haskellApp name action` — launch an inline `IO ()` Haskell action under a+ PTY without needing a separate target executable. Honors `cwd` and `env`+ the same way as `app`.+- `loadEnvFile path`, `prependPathEntry dir` — env-file loading (with+ `$VAR` self-reference expansion) and PATH prepending for the test process.+- `selectNumberedChoice tui prompt choice` (and `trySelect…` /+ `…With WaitOptions`) — select numbered options like `1) Haskell` after a+ prompt appears, falling back to arrow-key navigation if a digit press is+ ignored. Throws `ChoiceSelectionError` on failure.+- `artifactRoot tui`, `artifactFile tui rel`, `writeArtifactFile tui rel txt`+ — locate and write into the per-test artifact directory.+- `click tui col row` / `clickSelector tui selector` — simulate a mouse click+ at a 0-based coordinate or on the element a selector matches (Playwright+ style; honors `ambiguityMode`). Use `clickWith` / `clickSelectorWith` with+ `ClickOptions` to choose the button or the legacy X10 encoding. The target+ app must have mouse tracking enabled (`vty`/Brick apps do once mouse mode is+ on); the default SGR encoding suits any modern TUI.+- `currentViewRect tui rect` — return the viewport text cropped to a region.+- `dumpFailureBundle` / `withFailureBundle` — capture diagnostic state on+ failure (snapshot + viewport + action log + warnings + exit status).+ Failed `tuiTest` runs already write `failure-bundles/failure.txt`+ automatically.+- `writeRecording tui path` — export the captured frame log as JSONL with+ wall-clock timestamps; replay with `tuispec replay PATH`.+- `recordTraceTo = Just "trace.jsonl"` in `RunOptions` — automatic trace+ recording. The runner writes a replayable JSONL trace under the per-test+ artifact directory after every `tuiTest`, regardless of pass/fail. Render+ the resulting artifact with `cabal run tuispec -- replay <path>` (use+ `--speed as-fast-as-possible` for CI inspection).+ Run it: ```bash@@ -182,6 +219,23 @@ - `F1`..`F12` - `Ctrl+X`, `Alt+X`, `Shift+X` - single character like `"a"`++### Simulating mouse clicks with `click`++The `click` method synthesizes a mouse click (button press + release). Target+either a 1-based coordinate or a selector:++```json+{"jsonrpc":"2.0","id":10,"method":"click","params":{"col":12,"row":7}}+{"jsonrpc":"2.0","id":11,"method":"click","params":{"selector":{"type":"exact","text":"OK"}}}+{"jsonrpc":"2.0","id":12,"method":"click","params":{"selector":{"type":"exact","text":"Menu"},"button":"right"}}+```++The target application only reacts if it has enabled mouse tracking+(`vty`/Brick apps do once mouse mode is turned on). The default `sgr` encoding+suits any modern TUI; pass `"encoding":"x10"` only for apps that enable just+legacy `\ESC[?1000h` tracking. As with key input, follow a click with+`waitForStable` before dumping the view. ### Dump locations
SPEC.md view
@@ -98,6 +98,10 @@ - `app :: FilePath -> [String] -> App` - `press :: Tui -> Key -> IO ()` - `pressCombo :: Tui -> [Modifier] -> Key -> IO ()`+- `click :: Tui -> Int -> Int -> IO ()`+- `clickWith :: Tui -> ClickOptions -> Int -> Int -> IO ()`+- `clickSelector :: Tui -> Selector -> IO ()`+- `clickSelectorWith :: Tui -> ClickOptions -> Selector -> IO ()` - `typeText :: Tui -> Text -> IO ()` - `sendLine :: Tui -> Text -> IO ()` @@ -162,6 +166,27 @@ - `[Alt] + CharKey c` - `[Shift] + CharKey c` +### 4.6a Mouse input model++`click` and `clickSelector` synthesize a mouse click (a button press followed+by a release) written to the PTY, mirroring how key input is sent.++- `ClickOptions`: `clickButton` (`MouseLeft` | `MouseMiddle` | `MouseRight`)+ and `clickEncoding` (`MouseSGR` | `MouseX10`).+- `defaultClickOptions`: left button, SGR encoding.+- DSL coordinates are 0-based, matching the `At` selector (top-left is `0 0`).+- `clickSelector` resolves the selector to its first match's origin and clicks+ there; it honors `ambiguityMode` like other selector assertions.++Encoding notes:+- `MouseSGR` (default) emits `\ESC[<btn;col;rowM` / `...m`; 1-based on the wire,+ no coordinate limit. This is what `vty`/Brick apps enable.+- `MouseX10` emits the legacy `\ESC[M` + offset-byte form for apps that enable+ only `\ESC[?1000h` tracking; it cannot address columns or rows beyond 223.++The target application only reacts to a click if it has enabled mouse+tracking; a click on an app without mouse tracking is silently ignored.+ ### 4.7 Snapshot DSL - `expectSnapshot :: Tui -> SnapshotName -> IO ()`@@ -294,6 +319,7 @@ - `initialize` - `launch` - `sendKey`+- `click` - `sendText` - `sendLine` - `currentView`@@ -348,6 +374,23 @@ Accepted string forms: - base: `Enter`, `Esc`, `Tab`, `Backspace`, arrows, `F1..F12`, single char - combos: `Ctrl+X`, `Alt+X`, `Shift+X`++### 9.2a `click` format++`click` accepts one of two targets plus optional button/encoding:+- coordinate form: `col` and `row` (both 1-based)+- selector form: `selector` (see §9.3)+- optional `button`: `left` (default) | `middle` | `right`+- optional `encoding`: `sgr` (default) | `x10`++```json+{"method":"click","params":{"col":12,"row":7}}+{"method":"click","params":{"selector":{"type":"exact","text":"OK"},"button":"right"}}+```++Server coordinates are 1-based (converted to the 0-based DSL internally, like+the `at` selector). The click emits a press and a release; the target app must+have mouse tracking enabled to react. ### 9.3 Selector JSON format
+ cbits/tuispec_pty.c view
@@ -0,0 +1,6 @@+#include <sys/ioctl.h>++int tuispec_enable_packet_mode(int fd) {+ int packet_mode = 1;+ return ioctl(fd, TIOCPKT, &packet_mode);+}
src/TuiSpec.hs view
@@ -28,11 +28,28 @@ -- * Actions launch,+ launchAndWait,+ launchAndWaitWith, press, pressCombo,+ click,+ clickWith,+ clickSelector,+ clickSelectorWith, typeText, sendLine,+ loadEnvFile,+ prependPathEntry, + -- * Numbered choices+ selectNumberedChoice,+ selectNumberedChoiceWith,+ trySelectNumberedChoice,+ trySelectNumberedChoiceWith,+ parseNumberedChoices,+ NumberedChoice (..),+ ChoiceSelectionError (..),+ -- * Waits and assertions waitFor, waitForStable,@@ -44,7 +61,14 @@ -- * Snapshots expectSnapshot, dumpView,+ artifactRoot,+ artifactFile,+ writeArtifactFile,+ dumpFailureBundle,+ withFailureBundle,+ writeRecording, currentView,+ currentViewRect, -- * Steps step,@@ -60,8 +84,13 @@ defaultWaitOptionsFor, App (..), app,+ haskellApp, Key (..), Modifier (..),+ MouseButton (..),+ MouseEncoding (..),+ ClickOptions (..),+ defaultClickOptions, Selector (..), Rect (..), SnapshotName (..),@@ -75,6 +104,7 @@ Tui, ) where +import TuiSpec.Choice import TuiSpec.Render (renderAnsiSnapshotTextFile) import TuiSpec.Runner import TuiSpec.Types
+ src/TuiSpec/Choice.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : TuiSpec.Choice+Description : Helpers for choosing numbered options in terminal prompts.++This module handles a common TUI pattern: a prompt/header appears, followed by+numbered choices such as @1) Haskell@ and @2) Python@. The helpers do not assume+that the choices are rendered as a modal, menu, palette, or any other widget.+-}+module TuiSpec.Choice (+ ChoiceSelectionError (..),+ NumberedChoice (..),+ parseNumberedChoices,+ selectNumberedChoice,+ selectNumberedChoiceWith,+ trySelectNumberedChoice,+ trySelectNumberedChoiceWith,+) where++import Control.Exception (Exception (displayException), SomeException, throwIO, try)+import Control.Monad (replicateM_, unless, when)+import Data.Char (intToDigit, isDigit)+import Data.List (find, findIndex)+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Text.Read (readMaybe)+import TuiSpec.Runner (currentView, defaultWaitOptionsFor, press, waitForSelector)+import TuiSpec.Types (Key (..), Selector (..), Tui, WaitOptions)++-- | One numbered choice parsed from the visible viewport.+data NumberedChoice = NumberedChoice+ { numberedChoiceNumber :: Int+ , numberedChoiceLabel :: Text+ , numberedChoiceSelected :: Bool+ }+ deriving (Eq, Show)++-- | Errors raised by 'selectNumberedChoice' when the prompt or choice cannot be located.+data ChoiceSelectionError+ = -- | The prompt text never appeared before the wait timeout.+ ChoicePromptTimedOut Text+ | -- | The prompt was visible but did not contain the requested choice.+ ChoiceNotFound Text Text [Text]+ | -- | The prompt was visible but had no selected marker for arrow-key fallback.+ ChoiceNotSelectable Text Text [Text]+ deriving (Eq, Show)++instance Exception ChoiceSelectionError where+ displayException err =+ case err of+ ChoicePromptTimedOut promptText ->+ "numbered choice prompt did not appear before timeout: "+ <> Text.unpack promptText+ ChoiceNotFound promptText choiceText choices ->+ "numbered choice prompt '"+ <> Text.unpack promptText+ <> "' did not contain choice '"+ <> Text.unpack choiceText+ <> "'. Choices: "+ <> show choices+ ChoiceNotSelectable promptText choiceText choices ->+ "numbered choice prompt '"+ <> Text.unpack promptText+ <> "' contained choice '"+ <> Text.unpack choiceText+ <> "' but no selected choice marker was visible for arrow-key fallback. Choices: "+ <> show choices++-- | Select a numbered choice after its prompt appears, using test defaults.+selectNumberedChoice :: Tui -> Text -> Text -> IO ()+selectNumberedChoice tui =+ selectNumberedChoiceWith tui (defaultWaitOptionsFor tui)++-- | Select a numbered choice after its prompt appears, using explicit wait options.+selectNumberedChoiceWith :: Tui -> WaitOptions -> Text -> Text -> IO ()+selectNumberedChoiceWith tui waitOptions promptText choiceText = do+ promptVisible <- waitForChoicePrompt tui waitOptions promptText+ unless promptVisible $+ throwIO (ChoicePromptTimedOut promptText)+ selectVisibleNumberedChoice tui promptText choiceText++-- | Try to select a numbered choice. Returns 'False' if the prompt never appears.+trySelectNumberedChoice :: Tui -> Text -> Text -> IO Bool+trySelectNumberedChoice tui =+ trySelectNumberedChoiceWith tui (defaultWaitOptionsFor tui)++-- | Try to select a numbered choice with explicit wait options.+trySelectNumberedChoiceWith :: Tui -> WaitOptions -> Text -> Text -> IO Bool+trySelectNumberedChoiceWith tui waitOptions promptText choiceText = do+ promptVisible <- waitForChoicePrompt tui waitOptions promptText+ if promptVisible+ then do+ selectVisibleNumberedChoice tui promptText choiceText+ pure True+ else pure False++waitForChoicePrompt :: Tui -> WaitOptions -> Text -> IO Bool+waitForChoicePrompt tui waitOptions promptText = do+ result <- try (waitForSelector tui waitOptions (Exact promptText)) :: IO (Either SomeException ())+ pure (either (const False) (const True) result)++selectVisibleNumberedChoice :: Tui -> Text -> Text -> IO ()+selectVisibleNumberedChoice tui promptText choiceText = do+ viewport <- currentView tui+ let choices = parseNumberedChoices viewport+ case find (matchesNumberedChoice choiceText) choices of+ Just choice+ | numberedChoiceNumber choice >= 1 && numberedChoiceNumber choice <= 9 -> do+ press tui (CharKey (intToDigit (numberedChoiceNumber choice)))+ viewAfterDigit <- currentView tui+ whenPromptStillVisible promptText viewAfterDigit $+ selectNumberedChoiceByArrows tui promptText choiceText choices+ | otherwise ->+ selectNumberedChoiceByArrows tui promptText choiceText choices+ Nothing ->+ throwIO (ChoiceNotFound promptText choiceText (map numberedChoiceLabel choices))++whenPromptStillVisible :: Text -> Text -> IO () -> IO ()+whenPromptStillVisible promptText viewport =+ when (promptText `Text.isInfixOf` viewport)++selectNumberedChoiceByArrows :: Tui -> Text -> Text -> [NumberedChoice] -> IO ()+selectNumberedChoiceByArrows tui promptText choiceText choices = do+ let maybeTargetIndex = findIndex (matchesNumberedChoice choiceText) choices+ maybeSelectedIndex = findIndex numberedChoiceSelected choices+ case (maybeTargetIndex, maybeSelectedIndex) of+ (Just targetIndex, Just selectedIndex) -> do+ let delta = targetIndex - selectedIndex+ key = if delta >= 0 then ArrowDown else ArrowUp+ replicateM_ (abs delta) (press tui key)+ press tui Enter+ _ ->+ throwIO (ChoiceNotSelectable promptText choiceText (map numberedChoiceLabel choices))++matchesNumberedChoice :: Text -> NumberedChoice -> Bool+matchesNumberedChoice choiceText choice =+ Text.toLower choiceText `Text.isInfixOf` Text.toLower (numberedChoiceLabel choice)++-- | Parse numbered choices from rendered viewport text.+parseNumberedChoices :: Text -> [NumberedChoice]+parseNumberedChoices =+ mapMaybe parseLine . Text.lines+ where+ parseLine line =+ listToMaybe (mapMaybe parseCandidate (Text.tails line))++ parseCandidate candidate = do+ let stripped = Text.dropWhile isLeftPad candidate+ let (selected, body) =+ case Text.stripPrefix ">" stripped of+ Just rest -> (True, Text.dropWhile isLeftPad rest)+ Nothing -> (False, stripped)+ let (digitsText, afterDigits) = Text.span isDigit body+ if Text.null digitsText || not (")" `Text.isPrefixOf` afterDigits)+ then Nothing+ else do+ choiceNumber <- readMaybe (Text.unpack digitsText)+ let label =+ Text.strip $+ Text.takeWhile (not . isChoiceBorder) $+ Text.drop 1 afterDigits+ if Text.null label+ then Nothing+ else+ Just+ NumberedChoice+ { numberedChoiceNumber = choiceNumber+ , numberedChoiceLabel = label+ , numberedChoiceSelected = selected+ }++ isLeftPad c = c == ' ' || c == '\t' || isChoiceBorder c++isChoiceBorder :: Char -> Bool+isChoiceBorder char = char `elem` ("│┃║|─━═┌┐└┘┏┓┗┛╔╗╚╝├┤┣┫" :: String)
src/TuiSpec/Internal.hs view
@@ -19,8 +19,10 @@ -- * Pattern matching regexLikeMatch,+ regexLikeMatchOrigin, cleanPattern, wildcardContains,+ wildcardContainsOrigin, -- * Theme helpers resolveAutoSnapshotTheme,@@ -33,6 +35,7 @@ import Control.Exception (SomeException, catch) import Data.Char (isAlphaNum, toLower) import Data.List (isSuffixOf)+import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T import Text.Read (readMaybe)@@ -79,7 +82,18 @@ -} regexLikeMatch :: Text -> Text -> Bool regexLikeMatch patternText haystack =- any (`wildcardContains` haystack) alternatives+ isJust (regexLikeMatchOrigin patternText haystack)++{- | Like 'regexLikeMatch', but returns the 0-based column where the match+begins — the start of the first literal segment of the earliest-matching+alternative. This is the position a user sees and would click, so selector+clicks must target it rather than, say, the line's first non-blank column.+-}+regexLikeMatchOrigin :: Text -> Text -> Maybe Int+regexLikeMatchOrigin patternText haystack =+ case [col | alt <- alternatives, Just col <- [wildcardContainsOrigin alt haystack]] of+ [] -> Nothing+ cols -> Just (minimum cols) where alternatives = filter (not . T.null) $@@ -92,7 +106,23 @@ -- | Check whether a @.*@-delimited pattern matches within a haystack. wildcardContains :: Text -> Text -> Bool wildcardContains patternText haystack =- checkSegments 0 segments+ isJust (wildcardContainsOrigin patternText haystack)++{- | Like 'wildcardContains', but returns the 0-based start column of the match+— the position of the first literal (non-@.*@) segment — or 'Nothing'. A+pattern that is empty or all wildcards matches at column 0.+-}+wildcardContainsOrigin :: Text -> Text -> Maybe Int+wildcardContainsOrigin patternText haystack =+ case segments of+ [] -> Just 0+ (firstSeg : rest) ->+ let (prefix, suffix) = T.breakOn firstSeg haystack+ firstCol = T.length prefix+ in if not (T.null suffix)+ && checkSegments (firstCol + T.length firstSeg) rest+ then Just firstCol+ else Nothing where segments = filter (not . T.null) (T.splitOn ".*" patternText)
src/TuiSpec/Replay.hs view
@@ -245,8 +245,8 @@ when (delta > 0) $ threadDelay (fromIntegral delta) {- | Extract a human-readable input label from a JSON-RPC request line.-Returns @Just label@ for input methods (@sendKey@, @sendText@, @sendLine@),-@Nothing@ for non-input methods.+Returns @Just label@ for input methods (@sendKey@, @click@, @sendText@,+@sendLine@), @Nothing@ for non-input methods. -} extractInputLabel :: Text -> Maybe Text extractInputLabel rawLine =@@ -266,6 +266,7 @@ case KM.lookup "key" params of Just (String k) -> Just ("Key: " <> k) _ -> Nothing+ "click" -> Just ("Click: " <> clickLabel params) "sendText" -> case KM.lookup "text" params of Just (String t) -> Just ("Text: " <> showTextValue t)@@ -280,6 +281,24 @@ | t == " " = "<Space>" | t == "\t" = "<Tab>" | otherwise = "\"" <> t <> "\""++ clickLabel params =+ case (KM.lookup "col" params, KM.lookup "row" params) of+ (Just (Number c), Just (Number r)) ->+ showNumber c <> "," <> showNumber r+ _ ->+ case KM.lookup "selector" params of+ Just (Object sel) -> selectorLabel sel+ _ -> "?"++ selectorLabel sel =+ case (KM.lookup "text" sel, KM.lookup "pattern" sel, KM.lookup "type" sel) of+ (Just (String t), _, _) -> "\"" <> t <> "\""+ (_, Just (String p), _) -> "/" <> p <> "/"+ (_, _, Just (String ty)) -> ty+ _ -> "?"++ showNumber n = T.pack (show (round n :: Int)) {- | Compute a line-level delta between two viewport texts. Returns @Nothing@ when the frames are identical, or @Just encodedDelta@ with a
src/TuiSpec/Runner.hs view
@@ -9,22 +9,38 @@ functions ('launch', 'press', 'waitForText', 'expectSnapshot', ...). -} module TuiSpec.Runner (+ artifactFile,+ artifactRoot,+ click,+ clickWith,+ clickSelector,+ clickSelectorWith, closeSession, currentView,+ currentViewRect,+ dumpFailureBundle, dumpView, expectNotVisible, expectSnapshot, expectVisible, launch,+ launchAndWait,+ launchAndWaitWith,+ loadEnvFile, openSession, press, pressCombo,+ prependPathEntry, renderAnsiViewportText,+ selectorOrigin, sendLine, serializeAnsiSnapshot, step, tuiTest, typeText,+ withFailureBundle,+ writeArtifactFile,+ writeRecording, killSessionChildrenNow, waitForSelector, waitForSelectorWithAmbiguity,@@ -36,38 +52,53 @@ ) where import Control.Concurrent (threadDelay)-import Control.Exception (Exception, SomeException, displayException, finally, throwIO, toException, try)-import Control.Monad (unless, when)+import Control.Exception (Exception, SomeException, displayException, finally, fromException, throwIO, toException, try)+import Control.Monad (forM_, unless, when) import Data.Aeson (encode, object, (.=)) import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as BL import Data.Char (chr, ord, toLower) import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int64) import Data.IntMap.Strict qualified as IM import Data.List (intercalate, nub, sort)-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe, isJust, listToMaybe) 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 Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types (CInt (..)) 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.Environment (getEnvironment, lookupEnv, setEnv)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath (isRelative, makeRelative, searchPathSeparator, splitSearchPath, takeDirectory, (</>))+import System.IO (hPutStrLn, stderr)+import System.Posix.Directory (changeWorkingDirectory)+import System.Posix.Env qualified as PosixEnv+import System.Posix.IO (OpenMode (ReadWrite), closeFd, defaultFileFlags, dupTo, openFd, stdError, stdInput, stdOutput)+import System.Posix.Process (createSession, exitImmediately, forkProcess, getProcessGroupIDOf) import System.Posix.Pty qualified as Pty import System.Posix.Signals (sigKILL, signalProcess, signalProcessGroup)-import System.Posix.Types (ProcessGroupID)+import System.Posix.Terminal (getSlaveTerminalName, openPseudoTerminal)+import System.Posix.Types (Fd (..), ProcessGroupID) import System.Process (ProcessHandle, getPid, getProcessExitCode, terminateProcess)+import System.Process.Internals (mkProcessHandle) import System.Timeout (timeout) import Test.Tasty (TestTree) import Test.Tasty.HUnit (assertFailure, testCase) import Text.Read (readMaybe)-import TuiSpec.Internal (cleanPattern, ignoreIOError, regexLikeMatch, resolveAutoSnapshotTheme, safeFileStem, safeIndex, snapshotMetadataPath, wildcardContains)+import TuiSpec.Internal (cleanPattern, ignoreIOError, regexLikeMatch, regexLikeMatchOrigin, resolveAutoSnapshotTheme, safeFileStem, safeIndex, snapshotMetadataPath, wildcardContains) import TuiSpec.ProjectRoot (resolveProjectRoot)+import TuiSpec.Replay (RecordingDirection (DirectionFrame), RecordingEvent (..)) import TuiSpec.Types +foreign import ccall unsafe "tuispec_enable_packet_mode"+ c_tuispec_enable_packet_mode :: Fd -> IO CInt+ data TestStatus = Passed | Failed Text@@ -113,7 +144,7 @@ let sessionRoot = artifactBase </> "sessions" </> slugify name resetDirectory sessionRoot createDirectoryIfMissing True sessionRoot- mkTui projectRoot effectiveOptions name sessionRoot sessionRoot 1+ mkTui projectRoot effectiveOptions name sessionRoot sessionRoot -- | Close and teardown a TUI session created with 'openSession'. closeSession :: Tui -> IO ()@@ -164,28 +195,45 @@ -} launch :: Tui -> App -> IO () launch tui appSpec = do- appendAction tui ("launch " <> T.pack (command appSpec))+ appendAction tui ("launch " <> appLabel appSpec) currentPty <- readPty tui case currentPty of Just ptyHandle -> terminatePtyHandle ptyHandle Nothing -> pure () writePty tui Nothing- maybePty <- initializePty (terminalRows (tuiOptions tui)) (terminalCols (tuiOptions tui)) appSpec- case maybePty of- Just ptyHandle -> do+ ptyResult <- initializePty (terminalRows (tuiOptions tui)) (terminalCols (tuiOptions tui)) appSpec+ case ptyResult of+ Right ptyHandle -> do writePty tui (Just ptyHandle) modifyState tui $ \state -> state{launchedApp = Just appSpec} threadDelay settleDelayMicros _ <- syncVisibleBuffer tui pure ()- Nothing ->- throwIO (AssertionError "PTY backend unavailable during launch")+ Left err ->+ throwIO+ ( AssertionError+ ( "PTY backend unavailable during launch: "+ <> displayException err+ )+ ) +-- | Launch an application and wait for a ready selector using test defaults.+launchAndWait :: Tui -> App -> Selector -> IO ()+launchAndWait tui appSpec readySelector =+ launchAndWaitWith tui (defaultWaitOptionsFor tui) appSpec readySelector++-- | Launch an application and wait for a ready selector with explicit wait options.+launchAndWaitWith :: Tui -> WaitOptions -> App -> Selector -> IO ()+launchAndWaitWith tui waitOptions appSpec readySelector = do+ launch tui appSpec+ waitForSelector tui waitOptions readySelector+ -- | Send a single key press to the PTY application. press :: Tui -> Key -> IO () press tui key = do appendAction tui ("press " <> renderKey key)+ failIfLaunchedProcessExited tui "press" pty <- readPty tui case pty of Just ptyHandle -> do@@ -209,6 +257,7 @@ <> T.pack (intercalate "+" (map show modifiers)) <> "+" <> renderKey key+ failIfLaunchedProcessExited tui "pressCombo" pty <- readPty tui case pty of Just ptyHandle ->@@ -222,10 +271,86 @@ Nothing -> throwIO (AssertionError "PTY backend unavailable during combo key press") +{- | Left-click at a viewport coordinate.++Coordinates are 0-based, matching the 'At' selector (the top-left cell is+@0 0@). Uses SGR mouse encoding with the left button; see 'clickWith' for+explicit button and encoding control.++The target application only reacts to clicks if it has enabled mouse tracking+(anything built on @vty@\/Brick does once mouse mode is turned on). A click on+an application without mouse tracking is silently ignored by that application.+-}+click :: Tui -> Int -> Int -> IO ()+click tui = clickWith tui defaultClickOptions++{- | Click at a viewport coordinate with explicit button and encoding.++Coordinates are 0-based. A click emits both a button press and a release so+that applications reacting to either edge observe the event.+-}+clickWith :: Tui -> ClickOptions -> Int -> Int -> IO ()+clickWith tui options col row = do+ appendAction tui $+ "click "+ <> T.pack (show (clickButton options))+ <> " "+ <> T.pack (show col)+ <> ","+ <> T.pack (show row)+ failIfLaunchedProcessExited tui "click"+ pty <- readPty tui+ case pty of+ Just ptyHandle -> do+ sendPtyBytes ptyHandle (encodeMouseClick options (col + 1) (row + 1))+ threadDelay settleDelayMicros+ _ <- syncVisibleBuffer tui+ pure ()+ Nothing ->+ throwIO (AssertionError "PTY backend unavailable during click")++{- | Click on the element matched by a selector (Playwright-style).++The selector is resolved against the current viewport to its match origin and+that coordinate is clicked. Honors the run's 'ambiguityMode': under+'FailOnAmbiguous' a non-explicit selector matching more than one element+fails. Resolves to the first match's origin (matching is line-oriented, so a+match spanning a line boundary is reported as no match). Uses SGR mouse+encoding; see 'clickSelectorWith' for button and encoding control.+-}+clickSelector :: Tui -> Selector -> IO ()+clickSelector tui = clickSelectorWith tui defaultClickOptions++-- | Click on the element matched by a selector with explicit button and encoding.+clickSelectorWith :: Tui -> ClickOptions -> Selector -> IO ()+clickSelectorWith tui options selector = do+ appendAction tui ("clickSelector " <> T.pack (show selector))+ failIfLaunchedProcessExited tui "clickSelector"+ viewportTextValue <- syncVisibleBuffer tui+ let runOptions = tuiOptions tui+ viewport =+ Viewport+ { viewportCols = terminalCols runOptions+ , viewportRows = terminalRows runOptions+ , viewportText = viewportTextValue+ }+ assertNotAmbiguousWithMode (tuiName tui) (ambiguityMode runOptions) selector viewport+ case selectorOrigin selector viewport of+ Just (col, row) -> clickWith tui options col row+ Nothing ->+ throwIO+ ( AssertionError+ ( "clickSelector found no match for selector in test '"+ <> tuiName tui+ <> "'."+ )+ )+ -- | Send literal text to the PTY application. typeText :: Tui -> Text -> IO () typeText tui textValue = do appendAction tui ("typeText " <> textValue)+ failIfLaunchedProcessExited tui "typeText" pty <- readPty tui case pty of Just ptyHandle -> do@@ -242,16 +367,65 @@ typeText tui line press tui Enter +-- | Load simple @KEY=value@ entries from an env file into the current process.+loadEnvFile :: FilePath -> IO ()+loadEnvFile path = do+ exists <- doesFileExist path+ when exists $ do+ contents <- TIO.readFile path+ forM_ (T.lines contents) loadLine+ where+ loadLine rawLine = do+ let trimmed = T.strip rawLine+ when (not (T.null trimmed) && not ("#" `T.isPrefixOf` trimmed)) $ do+ let assignment = T.strip $ fromMaybe trimmed (T.stripPrefix "export " trimmed)+ case T.breakOn "=" assignment of+ (key, valueWithEquals)+ | not (T.null key) && "=" `T.isPrefixOf` valueWithEquals -> do+ let keyText = T.strip key+ let keyString = T.unpack keyText+ oldValue <- fromMaybe "" <$> lookupEnv keyString+ let rawValue = stripEnvQuotes (T.drop 1 valueWithEquals)+ setEnv keyString (T.unpack (expandEnvSelfReference keyText (T.pack oldValue) rawValue))+ _ -> pure ()++stripEnvQuotes :: Text -> Text+stripEnvQuotes value =+ if T.length stripped >= 2+ then case (T.head stripped, T.last stripped) of+ ('"', '"') -> T.init (T.tail stripped)+ ('\'', '\'') -> T.init (T.tail stripped)+ _ -> stripped+ else stripped+ where+ stripped = T.strip value++expandEnvSelfReference :: Text -> Text -> Text -> Text+expandEnvSelfReference key oldValue =+ T.replace ("$" <> key) oldValue+ . T.replace ("${" <> key <> "}") oldValue++-- | Prepend a directory to @PATH@ unless it is already present.+prependPathEntry :: FilePath -> IO ()+prependPathEntry dir = do+ oldPath <- fromMaybe "" <$> lookupEnv "PATH"+ let entries = splitSearchPath oldPath+ unless (dir `elem` entries) $+ setEnv "PATH" (intercalate [searchPathSeparator] (dir : filter (not . null) entries))+ -- | Return the current visible viewport text. currentView :: Tui -> IO Text currentView = syncVisibleBuffer +-- | Return the current viewport text cropped to the given rectangle.+currentViewRect :: Tui -> Rect -> IO Text+currentViewRect tui rect = do+ textValue <- syncVisibleBuffer tui+ pure (cropRect rect textValue)+ -- | 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+expectVisible = waitForText -- | Assert that a selector eventually becomes absent. expectNotVisible :: Tui -> Selector -> IO ()@@ -260,10 +434,7 @@ -- | 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+waitForText tui = waitForSelector tui (defaultWaitOptionsFor tui) -- | Wait for a selector with explicit wait options and ambiguity handling. waitForSelector :: Tui -> WaitOptions -> Selector -> IO ()@@ -303,6 +474,7 @@ if predicate viewport then pure () else do+ failIfLaunchedProcessExited tui "waitFor" now <- getCurrentTime if diffUTCTime now startedAt >= timeoutLimit then throwIO (AssertionError "waitFor timed out")@@ -337,7 +509,9 @@ let changedAt = if currentText /= lastView then now else lastChangedAt if diffUTCTime now changedAt >= debounceLimit then pure ()- else loop startedAt currentText changedAt+ else do+ failIfLaunchedProcessExited tui "waitForStable"+ loop startedAt currentText changedAt {- | Capture and compare the current PTY screen against a named snapshot. @@ -404,6 +578,111 @@ (_stem, _ansi, ansiPath) <- captureSnapshotToDir tui (tuiTestRoot tui </> "snapshots") snapshotName pure ansiPath +-- | Per-test artifact directory for logs and other auxiliary files.+artifactRoot :: Tui -> FilePath+artifactRoot = tuiTestRoot++-- | Resolve a relative path underneath the per-test artifact directory.+artifactFile :: Tui -> FilePath -> FilePath+artifactFile tui path =+ if isRelative path+ then artifactRoot tui </> path+ else path++-- | Write a UTF-8 text artifact and return its absolute path.+writeArtifactFile :: Tui -> FilePath -> Text -> IO FilePath+writeArtifactFile tui path textValue = do+ let fullPath = artifactFile tui path+ createDirectoryIfMissing True (takeDirectory fullPath)+ TIO.writeFile fullPath textValue+ pure fullPath++{- | Persist the captured frame log as a JSONL recording compatible with replay.++Frames are recorded each time the visible buffer changes during the test, with+wall-clock microseconds since the session began. Replay with+@tuispec replay PATH@ to render the trace on a terminal.+-}+writeRecording :: Tui -> FilePath -> IO FilePath+writeRecording tui path = do+ state <- readIORef (tuiStateRef tui)+ let fullPath = artifactFile tui path+ createDirectoryIfMissing True (takeDirectory fullPath)+ BL.writeFile fullPath (BL.concat (map ((<> "\n") . encodeFrame) (reverse (frameLog state))))+ pure fullPath+ where+ encodeFrame :: (Int64, Text) -> BL.ByteString+ encodeFrame (timestampMicros, frameText) =+ encode+ RecordingEvent+ { recordingTimestampMicros = timestampMicros+ , recordingDirection = DirectionFrame+ , recordingLine = frameText+ }++-- | Dump a diagnostic bundle for the current TUI state and return its path.+dumpFailureBundle :: Tui -> SnapshotName -> IO FilePath+dumpFailureBundle tui bundleName = do+ let bundleStem = safeFileStem (T.unpack (unSnapshotName bundleName))+ snapshotResult <- try (dumpView tui bundleName) :: IO (Either SomeException FilePath)+ viewResult <- try (currentView tui) :: IO (Either SomeException Text)+ exitResult <- launchedExitStatus tui+ state <- readIORef (tuiStateRef tui)+ writeArtifactFile+ tui+ ("failure-bundles" </> bundleStem <> ".txt")+ (renderFailureBundle state snapshotResult viewResult exitResult)++-- | Add a failure bundle when an action throws, then rethrow the original error.+withFailureBundle :: Tui -> SnapshotName -> IO a -> IO a+withFailureBundle tui bundleName action = do+ result <- try action+ case result of+ Right value -> pure value+ Left (err :: SomeException) -> do+ _ <- try (dumpFailureBundle tui bundleName) :: IO (Either SomeException FilePath)+ throwIO err++renderFailureBundle ::+ TuiState ->+ Either SomeException FilePath ->+ Either SomeException Text ->+ Maybe ExitCode ->+ Text+renderFailureBundle state snapshotResult viewResult exitResult =+ T.unlines+ [ "tuispec failure bundle"+ , ""+ , "Launched app: " <> T.pack (show (launchedApp state))+ , "Process exit: " <> maybe "(still running or no app)" (T.pack . show) exitResult+ , "Snapshot: " <> renderSnapshotResult snapshotResult+ , ""+ , "Actions:"+ , renderList (reverse (actionLog state))+ , ""+ , "Warnings:"+ , renderList (reverse (runtimeWarnings state))+ , ""+ , "Snapshot artifacts:"+ , renderList (reverse (snapshotLog state))+ , ""+ , "Viewport:"+ , renderViewResult viewResult+ ]+ where+ renderSnapshotResult =+ either+ (("failed: " <>) . T.pack . displayException)+ T.pack++ renderViewResult =+ either+ (("failed: " <>) . T.pack . displayException)+ id++ renderList [] = " (none)"+ renderList values = T.unlines (map (" - " <>) values)+ {- | Canonicalize ANSI text into a theme-aware JSON framebuffer. This representation is used for deterministic snapshot comparison and PNG@@ -455,7 +734,8 @@ go attempt = do resetDirectory testRoot- tui <- mkTui projectRoot options (specName specDef) testRoot snapshotRoot attempt+ createDirectoryIfMissing True testRoot+ tui <- mkTui projectRoot options (specName specDef) testRoot snapshotRoot runResultAndState <- ( do maybeRunResult <- timeout hardTimeoutMicros (try (specBody specDef tui))@@ -472,7 +752,22 @@ ) ) Just resultValue -> resultValue- _ <- timeout (500 * 1000) (syncVisibleBuffer tui)+ case runResult of+ Left (_ :: SomeException) -> do+ _ <- try (dumpFailureBundle tui "failure") :: IO (Either SomeException FilePath)+ pure ()+ Right () -> pure ()+ activePty <- readPty tui+ case activePty of+ Just _ -> do+ _ <- timeout (500 * 1000) (syncVisibleBuffer tui)+ pure ()+ Nothing -> pure ()+ case recordTraceTo options of+ Just tracePath -> do+ _ <- try (writeRecording tui tracePath) :: IO (Either SomeException FilePath)+ pure ()+ Nothing -> pure () state <- readIORef (tuiStateRef tui) pure (runResult, state) )@@ -484,9 +779,10 @@ | 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+mkTui :: FilePath -> RunOptions -> String -> FilePath -> FilePath -> IO Tui+mkTui projectRoot options name testRoot snapshotRoot = do ptyRef <- newIORef Nothing+ sessionStart <- getCurrentTime stateRef <- newIORef TuiState@@ -508,18 +804,24 @@ , tuiSnapshotRoot = snapshotRoot , tuiPty = ptyRef , tuiStateRef = stateRef+ , tuiSessionStart = sessionStart } pure tui -initializePty :: Int -> Int -> App -> IO (Maybe PtyHandle)-initializePty rows cols appSpec = do- result <- try (startPty rows cols appSpec) :: IO (Either SomeException PtyHandle)- case result of- Left _ -> pure Nothing- Right handle -> pure (Just handle)+initializePty :: Int -> Int -> App -> IO (Either SomeException PtyHandle)+initializePty rows cols appSpec =+ try (startPty rows cols appSpec) startPty :: Int -> Int -> App -> IO PtyHandle startPty rows cols appSpec = do+ case appSpec of+ App{} ->+ startCommandPty rows cols appSpec+ HaskellApp{} ->+ startHaskellPty rows cols appSpec++startCommandPty :: Int -> Int -> App -> IO PtyHandle+startCommandPty rows cols appSpec = do processEnv <- withTerminalEnv (env appSpec) let (effectiveCommand, effectiveArgs) = wrapLaunchWithCwd appSpec (master, processHandle) <-@@ -535,6 +837,74 @@ , ptyProcess = processHandle } +startHaskellPty :: Int -> Int -> App -> IO PtyHandle+startHaskellPty rows cols appSpec@HaskellApp{} = do+ processEnv <- withTerminalEnv (env appSpec)+ (masterFd, initialSlaveFd) <- openPseudoTerminal+ enablePacketMode masterFd+ maybeMaster <- Pty.createPty masterFd+ master <-+ case maybeMaster of+ Just pty -> pure pty+ Nothing -> throwIO (AssertionError "opened PTY master is not a terminal")+ Pty.resizePty master (cols, rows)+ slaveName <- getSlaveTerminalName masterFd+ processId <-+ forkProcess+ ( runHaskellPtyChild+ processEnv+ initialSlaveFd+ masterFd+ slaveName+ (cwd appSpec)+ (appAction appSpec)+ )+ ignoreIOError (closeFd initialSlaveFd)+ processHandle <- mkProcessHandle (fromIntegral processId) True+ pure+ PtyHandle+ { ptyMaster = master+ , ptyProcess = processHandle+ }+startHaskellPty _ _ App{} =+ throwIO (AssertionError "internal error: startHaskellPty called for command app")++runHaskellPtyChild :: [(String, String)] -> Fd -> Fd -> FilePath -> Maybe FilePath -> IO () -> IO ()+runHaskellPtyChild processEnv initialSlaveFd masterFd slaveName maybeCwd action = do+ result <- try childMain+ case result of+ Right () ->+ exitWith ExitSuccess+ Left (err :: SomeException)+ | Just exitCode <- fromException err ->+ exitWith exitCode+ | otherwise -> do+ hPutStrLn stderr ("tuispec Haskell app failed: " <> displayException err)+ exitImmediately (ExitFailure 1)+ where+ childMain = do+ ignoreIOError (closeFd masterFd)+ ignoreIOError (closeFd initialSlaveFd)+ _ <- createSession+ slaveFd <- openFd slaveName ReadWrite defaultFileFlags+ _ <- dupTo slaveFd stdInput+ _ <- dupTo slaveFd stdOutput+ _ <- dupTo slaveFd stdError+ unless (slaveFd `elem` [stdInput, stdOutput, stdError]) $+ ignoreIOError (closeFd slaveFd)+ PosixEnv.setEnvironment processEnv+ maybe (pure ()) changeWorkingDirectory maybeCwd+ action++{- | Enable TIOCPKT on the master fd. Empirically required to keep the forked+Haskell child process alive on the @HaskellApp@ path; without it the child+exits before the test body can interact with it. The packet-mode prefix byte+is always @< ' '@ and is dropped by the ANSI emulator's printable-char filter.+-}+enablePacketMode :: Fd -> IO ()+enablePacketMode fd =+ throwErrnoIfMinus1_ "failed to enable PTY packet mode" (c_tuispec_enable_packet_mode fd)+ withTerminalEnv :: Maybe [(String, Maybe String)] -> IO [(String, String)] withTerminalEnv envOverrides = do existing <- getEnvironment@@ -581,6 +951,12 @@ escapeChar '\'' = "'\\''" escapeChar c = [c] +appLabel :: App -> Text+appLabel appSpec =+ case appSpec of+ App{command} -> T.pack command+ HaskellApp{appName} -> T.pack appName+ teardownTui :: Tui -> IO () teardownTui tui = do@@ -637,6 +1013,28 @@ writePty :: Tui -> Maybe PtyHandle -> IO () writePty tui value = writeIORef (tuiPty tui) value +failIfLaunchedProcessExited :: Tui -> String -> IO ()+failIfLaunchedProcessExited tui context = do+ exitStatus <- launchedExitStatus tui+ case exitStatus of+ Nothing -> pure ()+ Just exitCode ->+ throwIO+ ( AssertionError+ ( "launched app exited during "+ <> context+ <> ": "+ <> show exitCode+ )+ )++launchedExitStatus :: Tui -> IO (Maybe ExitCode)+launchedExitStatus tui = do+ maybePty <- readPty tui+ case maybePty of+ Nothing -> pure Nothing+ Just ptyHandle -> getProcessExitCode (ptyProcess ptyHandle)+ currentViewport :: Tui -> IO Viewport currentViewport tui = do textValue <- syncVisibleBuffer tui@@ -686,7 +1084,7 @@ appendAction :: Tui -> Text -> IO () appendAction tui actionText = modifyState tui $ \state ->- state{actionLog = actionLog state <> [actionText]}+ state{actionLog = actionText : actionLog state} appendSnapshotArtifact :: Tui -> FilePath -> IO () appendSnapshotArtifact tui snapshotPath = do@@ -694,19 +1092,23 @@ modifyState tui $ \state -> if relativePath `elem` snapshotLog state then state- else state{snapshotLog = snapshotLog state <> [relativePath]}+ else state{snapshotLog = relativePath : snapshotLog state} appendWarning :: Tui -> Text -> IO () appendWarning tui warningText = modifyState tui $ \state ->- state{runtimeWarnings = runtimeWarnings state <> [warningText]}+ state{runtimeWarnings = warningText : runtimeWarnings state} recordFrame :: Tui -> Text -> IO ()-recordFrame tui frameText =+recordFrame tui frameText = do+ now <- getCurrentTime+ let elapsedMicros =+ round (realToFrac (diffUTCTime now (tuiSessionStart tui)) * 1e6 :: Double) ::+ Int64 modifyState tui $ \state ->- case reverse (frameLog state) of- latest : _ | latest == frameText -> state- _ -> state{frameLog = frameLog state <> [frameText]}+ case frameLog state of+ (_, latest) : _ | latest == frameText -> state+ _ -> state{frameLog = (elapsedMicros, frameText) : frameLog state} renderKey :: Key -> Text renderKey key =@@ -781,10 +1183,53 @@ | c >= 'a' && c <= 'z' = chr (ord c - 32) | otherwise = c +{- | Encode a mouse click (button press followed by release) as terminal+input bytes.++Takes 1-based column and row. SGR encoding (the default) has no coordinate+limit; X10 encoding offsets each value by 32 and clamps to a single byte, so+it cannot address columns or rows beyond 223.+-}+encodeMouseClick :: ClickOptions -> Int -> Int -> BS.ByteString+encodeMouseClick options col row =+ case clickEncoding options of+ MouseSGR ->+ let sgr final =+ BS8.pack+ ( "\ESC[<"+ <> show buttonCode+ <> ";"+ <> show col+ <> ";"+ <> show row+ <> [final]+ )+ in sgr 'M' <> sgr 'm'+ MouseX10 ->+ let clampByte v = min 255 (max 32 v)+ cx = clampByte (col + 32)+ cy = clampByte (row + 32)+ x10 code =+ BS.pack+ [0x1b, 0x5b, 0x4d, fromIntegral (clampByte (code + 32)), fromIntegral cx, fromIntegral cy]+ in x10 buttonCode <> x10 releaseCode+ where+ buttonCode :: Int+ buttonCode =+ case clickButton options of+ MouseLeft -> 0+ MouseMiddle -> 1+ MouseRight -> 2+ releaseCode = 3 :: Int+ sendPtyText :: PtyHandle -> Text -> IO () sendPtyText ptyHandle textValue = Pty.writePty (ptyMaster ptyHandle) (TE.encodeUtf8 textValue) +-- | Write raw bytes to the PTY (used for mouse reports, which are not text).+sendPtyBytes :: PtyHandle -> BS.ByteString -> IO ()+sendPtyBytes ptyHandle = Pty.writePty (ptyMaster ptyHandle)+ drainPtyOutput :: Pty.Pty -> IO BS.ByteString drainPtyOutput pty = BS.concat . reverse <$> go 0 [] where@@ -1452,10 +1897,6 @@ selectorMatches nested (viewport{viewportText = cropRect rect (viewportText viewport)}) Nth idx nested -> matchCount nested viewport > idx -assertNotAmbiguous :: Tui -> Selector -> Viewport -> IO ()-assertNotAmbiguous tui selector viewport =- assertNotAmbiguousWithMode (tuiName tui) (ambiguityMode (tuiOptions tui)) selector viewport- assertNotAmbiguousWithMode :: String -> AmbiguityMode -> Selector -> Viewport -> IO () assertNotAmbiguousWithMode testName mode selector viewport = when shouldFail $@@ -1493,6 +1934,74 @@ if selectorMatches selector viewport then 1 else 0 Nth _ _ -> if selectorMatches selector viewport then 1 else 0++{- | Resolve a selector to the 0-based @(col, row)@ origin of its first match+in the viewport, or 'Nothing' when nothing matches.++Used by 'clickSelector'. Origins are 0-based to match the 'At' selector.+'Regex' resolves to the first non-blank column of the first matching line.++Matching is line-oriented: a match that spans a line boundary (a multi-line+'Exact' needle, or a 'Regex' whose @.*@ crosses a newline) resolves to+'Nothing' even though the whole-text matchers treat it as a hit.+'clickSelector' turns that into a \"no match\" error.+-}+selectorOrigin :: Selector -> Viewport -> Maybe (Int, Int)+selectorOrigin selector viewport =+ case selector of+ Exact textValue ->+ listToMaybe (exactOrigins textValue (viewportText viewport))+ At col row -> Just (col, row)+ Within rect nested -> do+ (col, row) <-+ selectorOrigin+ nested+ (viewport{viewportText = cropRect rect (viewportText viewport)})+ pure (col + rectCol rect, row + rectRow rect)+ Nth idx nested ->+ case nested of+ Exact textValue ->+ safeIndex idx (exactOrigins textValue (viewportText viewport))+ Regex patternText ->+ safeIndex idx (regexOrigins patternText (viewportText viewport))+ _ ->+ if matchCount nested viewport > idx+ then selectorOrigin nested viewport+ else Nothing+ Regex patternText ->+ listToMaybe (regexOrigins patternText (viewportText viewport))++{- | All 0-based @(col, row)@ origins of a lightweight regex pattern, one per+matching line, at the column where the pattern's first literal segment matches+(so a selector click lands on the matched text, not the line's left edge).+-}+regexOrigins :: Text -> Text -> [(Int, Int)]+regexOrigins patternText textValue =+ [ (col, rowIdx)+ | (rowIdx, line) <- zip [0 ..] (T.lines textValue)+ , Just col <- [regexLikeMatchOrigin patternText line]+ ]++-- | All 0-based @(col, row)@ origins of a literal substring within viewport text.+exactOrigins :: Text -> Text -> [(Int, Int)]+exactOrigins needle textValue+ | T.null needle = []+ | otherwise =+ [ (col, rowIdx)+ | (rowIdx, line) <- zip [0 ..] (T.lines textValue)+ , col <- lineOccurrences line+ ]+ where+ needleLen = T.length needle+ lineOccurrences = go 0+ where+ go base hay =+ let (prefix, suffix) = T.breakOn needle hay+ in if T.null suffix+ then []+ else+ let col = base + T.length prefix+ in col : go (col + needleLen) (T.drop (T.length prefix + needleLen) hay) regexAlternativeCount :: Text -> Text -> Int regexAlternativeCount alternative haystack
src/TuiSpec/Server.hs view
@@ -46,8 +46,8 @@ import TuiSpec.Internal (regexLikeMatch, safeFileStem, safeIndex, snapshotMetadataPath) import TuiSpec.Render (renderAnsiSnapshotFileWithFont) import TuiSpec.Replay (RecordingDirection (DirectionFrame, DirectionFrameDelta, DirectionNotification, DirectionRequest, DirectionResponse), RecordingHandle, ReplaySpeed (ReplayAsFastAsPossible, ReplayRealTime), appendRecordingEvent, closeRecording, computeFrameDelta, openRecording, streamReplayRequests)-import TuiSpec.Runner (currentView, defaultWaitOptionsFor, dumpView, expectNotVisible, expectSnapshot, expectVisible, killSessionChildrenNow, launch, openSession, press, pressCombo, renderAnsiViewportText, sendLine, serializeAnsiSnapshot, typeText, waitForSelectorWithAmbiguity, waitForStable)-import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch, LastVisibleMatch), App (..), Key (..), Modifier (Alt, Control, Shift), Rect (Rect), RunOptions (..), Selector (..), SnapshotName (SnapshotName), Tui (..), WaitOptions (..), defaultRunOptions, tuispecVersion)+import TuiSpec.Runner (clickSelectorWith, clickWith, currentView, defaultWaitOptionsFor, dumpView, expectNotVisible, expectSnapshot, expectVisible, killSessionChildrenNow, launch, openSession, press, pressCombo, renderAnsiViewportText, sendLine, serializeAnsiSnapshot, typeText, waitForSelectorWithAmbiguity, waitForStable)+import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch, LastVisibleMatch), App (..), ClickOptions (..), Key (..), Modifier (Alt, Control, Shift), MouseButton (..), MouseEncoding (..), Rect (Rect), RunOptions (..), Selector (..), SnapshotName (SnapshotName), Tui (..), WaitOptions (..), defaultClickOptions, defaultRunOptions, tuispecVersion) -- | Configuration for the JSON-RPC server. data ServerOptions = ServerOptions@@ -170,6 +170,7 @@ "initialize" -> dispatchInitialize state paramsValue "launch" -> dispatchLaunch state paramsValue "sendKey" -> dispatchSendKey state paramsValue+ "click" -> dispatchClick state paramsValue "sendText" -> dispatchSendText state paramsValue "sendLine" -> dispatchSendLine state paramsValue "currentView" -> dispatchCurrentView state paramsValue@@ -280,6 +281,62 @@ emitViewChangedNotification state tui pure (object ["ok" .= True]) +dispatchClick :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchClick state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ case resolveClickOptions params of+ Left optionErr -> pure (Left (invalidParams optionErr))+ Right options ->+ case resolveClickTarget params of+ Left targetErr -> pure (Left (invalidParams targetErr))+ Right target ->+ runMethod $ do+ let tui = activeTui active+ case target of+ ClickAtCoordinate col row ->+ clickWith tui options (col - 1) (row - 1)+ ClickAtSelector selector ->+ clickSelectorWith tui options selector+ emitViewChangedNotification state tui+ pure (object ["ok" .= True])++-- | Where a @click@ request should land: an explicit coordinate or a selector.+data ClickTarget+ = ClickAtCoordinate Int Int+ | ClickAtSelector Selector++resolveClickTarget :: ClickParams -> Either String ClickTarget+resolveClickTarget params =+ case (clickParamSelector params, clickParamCol params, clickParamRow params) of+ (Just selector, _, _) -> Right (ClickAtSelector selector)+ (Nothing, Just col, Just row)+ | col < 1 || row < 1 ->+ Left "click uses 1-based coordinates; col/row must be >= 1"+ | otherwise -> Right (ClickAtCoordinate col row)+ (Nothing, _, _) ->+ Left "click requires either a selector or both col and row"++resolveClickOptions :: ClickParams -> Either String ClickOptions+resolveClickOptions params = do+ button <- maybe (Right (clickButton defaultClickOptions)) parseMouseButton (clickParamButton params)+ encoding <- maybe (Right (clickEncoding defaultClickOptions)) parseMouseEncoding (clickParamEncoding params)+ pure ClickOptions{clickButton = button, clickEncoding = encoding}+ where+ parseMouseButton textValue =+ case T.toLower textValue of+ "left" -> Right MouseLeft+ "middle" -> Right MouseMiddle+ "right" -> Right MouseRight+ _ -> Left ("unknown mouse button: " <> T.unpack textValue)+ parseMouseEncoding textValue =+ case T.toLower textValue of+ "sgr" -> Right MouseSGR+ "x10" -> Right MouseX10+ _ -> Left ("unknown mouse encoding: " <> T.unpack textValue)+ dispatchSendText :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome) dispatchSendText state paramsValue = withActiveSession state $ \active ->@@ -962,6 +1019,24 @@ parseJSON = withObject "SendKeyParams" $ \o -> SendKeyParams <$> o .: "key"++data ClickParams = ClickParams+ { clickParamSelector :: Maybe Selector+ , clickParamCol :: Maybe Int+ , clickParamRow :: Maybe Int+ , clickParamButton :: Maybe Text+ , clickParamEncoding :: Maybe Text+ }++instance FromJSON ClickParams where+ parseJSON =+ withObject "ClickParams" $ \o ->+ ClickParams+ <$> (o .:? "selector" >>= traverse parseSelector)+ <*> o .:? "col"+ <*> o .:? "row"+ <*> o .:? "button"+ <*> o .:? "encoding" data SendTextParams = SendTextParams { sendTextValue :: Text
src/TuiSpec/Types.hs view
@@ -10,8 +10,13 @@ AmbiguityMode (..), App (..), app,+ haskellApp,+ ClickOptions (..),+ defaultClickOptions, Key (..), Modifier (..),+ MouseButton (..),+ MouseEncoding (..), PtyHandle (..), Rect (..), RunOptions (..),@@ -30,9 +35,11 @@ ) where import Data.IORef (IORef)+import Data.Int (Int64) import Data.String (IsString (..)) import Data.Text (Text) import Data.Text qualified as T+import Data.Time.Clock (UTCTime) import System.Posix.Pty (Pty) import System.Process (ProcessHandle) @@ -51,14 +58,28 @@ `cwd` sets the working directory for the launch command when present. -}-data App = App- { command :: FilePath- , args :: [String]- , env :: Maybe [(String, Maybe String)]- , cwd :: Maybe FilePath- }- deriving (Eq, Show)+data App+ = App+ { command :: FilePath+ , args :: [String]+ , env :: Maybe [(String, Maybe String)]+ , cwd :: Maybe FilePath+ }+ | HaskellApp+ { appName :: String+ , appAction :: IO ()+ , env :: Maybe [(String, Maybe String)]+ , cwd :: Maybe FilePath+ } +instance Show App where+ show appSpec =+ case appSpec of+ App{command, args} ->+ "App " <> show (command : args)+ HaskellApp{appName} ->+ "HaskellApp " <> show appName+ {- | Construct an app launch request using inherited environment variables and the current working directory. -}@@ -71,6 +92,27 @@ , cwd = Nothing } +{- | Construct a launch request from a Haskell action.++The action runs in a forked child process connected to the test PTY. This keeps+the same terminal behavior as command launches without requiring a separate+target executable path.++The child is created with @forkProcess@ from the @unix@ package. This is safe+under the single-threaded GHC RTS but is the usual fork-from-multithreaded-RTS+landmine: avoid building tests that use 'haskellApp' with @-threaded@ unless+the action only spawns subprocesses (@createProcess@/@readProcess@) and does+no in-process Haskell I\/O after the fork.+-}+haskellApp :: String -> IO () -> App+haskellApp name action =+ HaskellApp+ { appName = name+ , appAction = action+ , env = Nothing+ , cwd = Nothing+ }+ -- | How selector ambiguity is handled for assertion helpers. data AmbiguityMode = -- | Fail when a non-explicit selector matches more than one target.@@ -92,6 +134,11 @@ , ambiguityMode :: AmbiguityMode , updateSnapshots :: Bool , snapshotTheme :: String+ , recordTraceTo :: Maybe FilePath+ {- ^ When @Just path@, the runner writes a JSONL trace recording to that+ path (relative to the per-test artifact root, or absolute) after each+ test, regardless of pass/fail. Replay with @tuispec replay PATH@.+ -} } deriving (Eq, Show) @@ -116,11 +163,12 @@ , ambiguityMode = FailOnAmbiguous , updateSnapshots = False , snapshotTheme = "auto"+ , recordTraceTo = Nothing } -- | The tuispec library/protocol version. tuispecVersion :: String-tuispecVersion = "0.2.0.0"+tuispecVersion = "0.3.1.1" -- | Key modifiers for combo key presses. data Modifier@@ -146,6 +194,45 @@ | NamedKey Text deriving (Eq, Show, Read) +-- | Which mouse button a synthesized click uses.+data MouseButton+ = -- | Primary (left) button.+ MouseLeft+ | -- | Middle button.+ MouseMiddle+ | -- | Secondary (right) button.+ MouseRight+ deriving (Eq, Show, Read)++{- | Wire encoding for synthesized mouse events.++Most modern TUIs (anything built on @vty@\/Brick) enable SGR extended mouse+mode, so 'MouseSGR' is the default. 'MouseX10' is the legacy fixed-byte+encoding for applications that only enable @\\ESC[?1000h@ tracking; it cannot+address columns or rows beyond 223.+-}+data MouseEncoding+ = -- | SGR extended mouse mode (@\\ESC[\<btn;col;rowM@). 1-based, unbounded.+ MouseSGR+ | -- | Legacy X10 mouse mode (@\\ESC[M@ + offset bytes). Capped at 223.+ MouseX10+ deriving (Eq, Show, Read)++-- | Button and encoding options for a synthesized mouse click.+data ClickOptions = ClickOptions+ { clickButton :: MouseButton+ , clickEncoding :: MouseEncoding+ }+ deriving (Eq, Show, Read)++-- | Default click options: left button, SGR encoding.+defaultClickOptions :: ClickOptions+defaultClickOptions =+ ClickOptions+ { clickButton = MouseLeft+ , clickEncoding = MouseSGR+ }+ -- | A rectangular region within the terminal viewport. data Rect = Rect { rectCol :: Int@@ -223,9 +310,15 @@ , visibleBuffer :: Text , rawBuffer :: Text , actionLog :: [Text]+ -- ^ Action history, stored newest-first; reverse before display. , snapshotLog :: [Text]+ -- ^ Snapshot artifact paths, stored newest-first. , runtimeWarnings :: [Text]- , frameLog :: [Text]+ -- ^ Runtime warnings, stored newest-first.+ , frameLog :: [(Int64, Text)]+ {- ^ Captured viewport frames with wall-clock microseconds since the test+ session began, stored newest-first.+ -} } {- | Runtime test handle passed into each spec body.@@ -241,4 +334,6 @@ , tuiSnapshotRoot :: FilePath , tuiPty :: IORef (Maybe PtyHandle) , tuiStateRef :: IORef TuiState+ , tuiSessionStart :: UTCTime+ -- ^ Wall-clock origin for trace timestamps (when this @Tui@ was created). }
test/Spec.hs view
@@ -2,7 +2,8 @@ module Main where -import Control.Exception (SomeException, bracket, catch)+import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, bracket, catch, try) import Data.Aeson (Value (..), decodeStrict', encode, object, (.=)) import Data.Aeson.Key qualified as K import Data.Aeson.KeyMap qualified as KM@@ -13,11 +14,12 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist)-import System.Environment (getEnvironment)+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory)+import System.Environment (getEnvironment, lookupEnv, setEnv) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath ((</>))-import System.IO (BufferMode (LineBuffering), Handle, hClose, hFlush, hSetBuffering)+import System.IO (BufferMode (LineBuffering), Handle, hClose, hFlush, hPutStrLn, hSetBuffering, stderr)+import System.Process (readProcessWithExitCode) import System.Process qualified as Process import System.Timeout (timeout) import Test.Tasty (defaultMain, testGroup)@@ -43,6 +45,98 @@ expectNotVisible tui (Exact "this text should not exist") expectSnapshot tui "smoke-viewport" sendLine tui "exit"+ , tuiTest+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/artifact-root-smoke"+ }+ "smoke: artifact root exists before body"+ $ \tui -> do+ exists <- doesDirectoryExist (artifactRoot tui)+ assertBool ("artifact root does not exist: " <> artifactRoot tui) exists+ , testCase "smoke: launchAndWait and artifact helpers" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-helpers-smoke"+ }+ "helpers-session"+ ( \tui -> do+ launchAndWait tui (app "sh" ["-lc", "printf 'READY\\n'; sleep 2"]) (Exact "READY")+ artifactPath <- writeArtifactFile tui "notes/helper.txt" "hello artifact"+ artifactPath @?= artifactFile tui "notes/helper.txt"+ exists <- doesFileExist artifactPath+ assertBool "writeArtifactFile should create the artifact" exists+ )+ , testCase "smoke: env file loading expands self references" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-env-file-smoke"+ }+ "env-file-session"+ ( \tui -> do+ setEnv "TUISPEC_ENV_FILE_VALUE" "base"+ let envPath = artifactFile tui "test.env"+ writeFile envPath "export TUISPEC_ENV_FILE_VALUE=\"prefix:$TUISPEC_ENV_FILE_VALUE\"\n"+ loadEnvFile envPath+ value <- lookupEnv "TUISPEC_ENV_FILE_VALUE"+ value @?= Just "prefix:base"+ )+ , testCase "smoke: trySelectNumberedChoice selects numbered choice" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-menu-smoke"+ }+ "menu-session"+ ( \tui -> do+ launch+ tui+ ( app+ "sh"+ [ "-lc"+ , "stty -icanon min 1 time 0; printf 'SELECT LANGUAGE\\n > 1) Go\\n 2) Python\\n'; key=$(dd bs=1 count=1 2>/dev/null); printf '\\npicked:%s\\n' \"$key\"; sleep 1"+ ]+ )+ selected <- trySelectNumberedChoiceWith tui defaultWaitOptions{timeoutMs = 2000} "SELECT LANGUAGE" "Python"+ assertBool "trySelectNumberedChoice should find the Python choice" selected+ waitForText tui (Exact "picked:2")+ )+ , tuiTest+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/auto-trace"+ , ambiguityMode = FirstVisibleMatch+ , recordTraceTo = Just "trace.jsonl"+ }+ "smoke: recordTraceTo writes a replayable JSONL artifact"+ $ \tui -> do+ launch tui (app "sh" [])+ sendLine tui "printf 'trace-line\\n'"+ waitForText tui (Exact "trace-line")+ sendLine tui "exit"+ , testCase "smoke: failure bundle and recording helpers" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-diagnostics-smoke"+ }+ "diagnostics-session"+ ( \tui -> do+ launchAndWait tui (app "sh" ["-lc", "printf 'READY\\n'; sleep 2"]) (Exact "READY")+ result <- try (withFailureBundle tui "manual-failure" (assertFailure "boom")) :: IO (Either SomeException ())+ case result of+ Left _ -> pure ()+ Right () -> assertFailure "withFailureBundle should rethrow the wrapped assertion"+ bundleExists <- doesFileExist (artifactFile tui ("failure-bundles" </> "manual-failure.txt"))+ assertBool "withFailureBundle should write a diagnostic bundle" bundleExists+ recordingPath <- writeRecording tui "recordings/session.jsonl"+ recordingExists <- doesFileExist recordingPath+ assertBool "writeRecording should write JSONL output" recordingExists+ recordingText <- readFile recordingPath+ assertBool "recording should contain frame events" ("\"direction\":\"frame\"" `isInfixOf` recordingText)+ ) , testCase "smoke: repl session can dump view" $ do snapshotPath <- withTuiSession@@ -79,6 +173,71 @@ waitForText tui (Exact "hello-env") sendLine tui "exit" )+ , testCase "smoke: launches Haskell action under PTY" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-haskell-smoke"+ }+ "haskell-session"+ ( \tui -> do+ let markerPath = artifactRoot tui </> "haskell-started"+ launch+ tui+ ( haskellApp "haskell-hello" $ do+ writeFile markerPath "started"+ hPutStrLn stderr "hello from Haskell app"+ threadDelay (2 * 1000 * 1000)+ )+ markerExists <- waitForFile markerPath+ assertBool "Haskell action did not write startup marker" markerExists+ waitForText tui (Exact "hello from Haskell app")+ )+ , testCase "smoke: Haskell action can run subprocesses" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-haskell-process-smoke"+ }+ "haskell-process-session"+ ( \tui -> do+ launch+ tui+ ( haskellApp "haskell-process" $ do+ (exitCode, stdoutText, _stderrText) <-+ readProcessWithExitCode "sh" ["-c", "printf subprocess-ok"] ""+ hPutStrLn stderr "before subprocess"+ hPutStrLn stderr (show exitCode)+ hPutStrLn stderr stdoutText+ threadDelay (2 * 1000 * 1000)+ )+ waitForText tui (Exact "before subprocess")+ waitForText tui (Exact "ExitSuccess")+ waitForText tui (Exact "subprocess-ok")+ )+ , testCase "smoke: Haskell action honors cwd and env" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-haskell-cwd-env-smoke"+ }+ "haskell-cwd-env-session"+ ( \tui -> do+ launch+ tui+ ( haskellApp "haskell-cwd-env" $ do+ cwd <- getCurrentDirectory+ envValue <- lookupEnv "TUISPEC_TEST_ENV"+ hPutStrLn stderr cwd+ hPutStrLn stderr (show envValue)+ threadDelay (2 * 1000 * 1000)+ )+ { cwd = Just "/tmp"+ , env = Just [("TUISPEC_TEST_ENV", Just "hello-env")]+ }+ waitForText tui (Exact "/tmp")+ waitForText tui (Exact "Just \"hello-env\"")+ ) , testCase "smoke: waitForText ignores ANSI escape sequences" $ withTuiSession defaultRunOptions@@ -178,17 +337,10 @@ server 9 "dumpView"- ( object- [ "name" .= ("snap-a" :: Text)- , "format" .= ("both" :: Text)- ]- )+ (object ["name" .= ("snap-a" :: Text)]) snapA <- fieldText "snapshotPath" dumpResult- pngA <- fieldText "pngPath" dumpResult snapAExists <- doesFileExist (T.unpack snapA)- pngAExists <- doesFileExist (T.unpack pngA) assertBool "dumpView should emit ANSI snapshot path" snapAExists- assertBool "dumpView format=both should emit PNG" pngAExists _ <- expectResult@@ -202,9 +354,14 @@ ] ) - renderResult <- expectResult =<< rpcCall server 11 "renderView" (object ["name" .= ("snap-b" :: Text)])- snapB <- fieldText "snapshotPath" renderResult- _ <- fieldText "pngPath" renderResult+ dumpResultB <-+ expectResult+ =<< rpcCall+ server+ 11+ "dumpView"+ (object ["name" .= ("snap-b" :: Text)])+ snapB <- fieldText "snapshotPath" dumpResultB diffChanged <- expectResult@@ -545,24 +702,44 @@ renderValue :: Value -> Text renderValue = TE.decodeUtf8 . BL.toStrict . encode +waitForFile :: FilePath -> IO Bool+waitForFile path = go (20 :: Int)+ where+ go 0 = doesFileExist path+ go remaining = do+ exists <- doesFileExist path+ if exists+ then pure True+ else do+ threadDelay (50 * 1000)+ go (remaining - 1)+ locateTuiSpecExecutable :: IO FilePath locateTuiSpecExecutable = do- (exitCode, stdoutText, stderrText) <-- Process.readCreateProcessWithExitCode- ( Process.proc- "sh"- [ "-lc"- , "find dist-newstyle/build -type f -path '*/x/tuispec/build/tuispec/tuispec' | sort | tail -n 1"- ]- )- ""- case exitCode of- ExitSuccess ->- case lines stdoutText of- [] -> assertFailure "Could not locate built tuispec executable in dist-newstyle"- pathValue : _ | null pathValue -> assertFailure "Located empty executable path"- pathValue : _ -> pure pathValue- _ -> assertFailure ("Failed to locate tuispec executable: " <> stderrText)+ overrideValue <- lookupEnv "TUISPEC_EXECUTABLE"+ case overrideValue of+ Just path | not (null path) -> do+ exists <- doesFileExist path+ if exists+ then pure path+ else assertFailure ("TUISPEC_EXECUTABLE points to a missing file: " <> path)+ _ -> do+ (exitCode, stdoutText, stderrText) <-+ Process.readCreateProcessWithExitCode+ ( Process.proc+ "sh"+ [ "-lc"+ , "find dist-newstyle/build dist/build -type f \\( -path '*/x/tuispec/build/tuispec/tuispec' -o -path '*/build/tuispec/tuispec' \\) 2>/dev/null | sort | tail -n 1"+ ]+ )+ ""+ case exitCode of+ ExitSuccess ->+ case lines stdoutText of+ [] -> assertFailure "Could not locate built tuispec executable; set TUISPEC_EXECUTABLE to override"+ pathValue : _ | null pathValue -> assertFailure "Located empty executable path"+ pathValue : _ -> pure pathValue+ _ -> assertFailure ("Failed to locate tuispec executable: " <> stderrText) applyEnvOverrides :: [(String, String)] -> [(String, String)] -> [(String, String)] applyEnvOverrides base overrides =
tuispec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.8 name: tuispec-version: 0.2.0.0+version: 0.3.1.1 build-type: Simple license: MIT license-file: LICENSE@@ -54,8 +54,10 @@ library import: common-settings hs-source-dirs: src+ c-sources: cbits/tuispec_pty.c exposed-modules: TuiSpec+ TuiSpec.Choice TuiSpec.Render TuiSpec.Replay TuiSpec.Runner