tuispec 0.2.0.0 → 0.3.0.0
raw patch · 9 files changed
+887/−84 lines, 9 files
Files
- CHANGELOG.md +19/−0
- SKILL.md +31/−0
- cbits/tuispec_pty.c +6/−0
- src/TuiSpec.hs +22/−0
- src/TuiSpec/Choice.hs +177/−0
- src/TuiSpec/Runner.hs +360/−43
- src/TuiSpec/Types.hs +61/−9
- test/Spec.hs +208/−31
- tuispec.cabal +3/−1
CHANGELOG.md view
@@ -1,5 +1,24 @@ # Changelog +## 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.
SKILL.md view
@@ -94,6 +94,37 @@ - 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.+- `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
+ 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,24 @@ -- * Actions launch,+ launchAndWait,+ launchAndWaitWith, press, pressCombo, typeText, sendLine,+ loadEnvFile,+ prependPathEntry, + -- * Numbered choices+ selectNumberedChoice,+ selectNumberedChoiceWith,+ trySelectNumberedChoice,+ trySelectNumberedChoiceWith,+ parseNumberedChoices,+ NumberedChoice (..),+ ChoiceSelectionError (..),+ -- * Waits and assertions waitFor, waitForStable,@@ -44,7 +57,14 @@ -- * Snapshots expectSnapshot, dumpView,+ artifactRoot,+ artifactFile,+ writeArtifactFile,+ dumpFailureBundle,+ withFailureBundle,+ writeRecording, currentView,+ currentViewRect, -- * Steps step,@@ -60,6 +80,7 @@ defaultWaitOptionsFor, App (..), app,+ haskellApp, Key (..), Modifier (..), Selector (..),@@ -75,6 +96,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/Runner.hs view
@@ -9,22 +9,33 @@ functions ('launch', 'press', 'waitForText', 'expectSnapshot', ...). -} module TuiSpec.Runner (+ artifactFile,+ artifactRoot, closeSession, currentView,+ currentViewRect,+ dumpFailureBundle, dumpView, expectNotVisible, expectSnapshot, expectVisible, launch,+ launchAndWait,+ launchAndWaitWith,+ loadEnvFile, openSession, press, pressCombo,+ prependPathEntry, renderAnsiViewportText, sendLine, serializeAnsiSnapshot, step, tuiTest, typeText,+ withFailureBundle,+ writeArtifactFile,+ writeRecording, killSessionChildrenNow, waitForSelector, waitForSelectorWithAmbiguity,@@ -36,13 +47,14 @@ ) 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.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)@@ -52,22 +64,35 @@ 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.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 +138,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 +189,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 +251,7 @@ <> T.pack (intercalate "+" (map show modifiers)) <> "+" <> renderKey key+ failIfLaunchedProcessExited tui "pressCombo" pty <- readPty tui case pty of Just ptyHandle ->@@ -226,6 +269,7 @@ 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 +286,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 +353,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 +393,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 +428,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 +497,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 +653,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 +671,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 +698,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 +723,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 +756,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 +870,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 +932,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 +1003,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 +1011,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 =@@ -1451,10 +1772,6 @@ 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 =- assertNotAmbiguousWithMode (tuiName tui) (ambiguityMode (tuiOptions tui)) selector viewport assertNotAmbiguousWithMode :: String -> AmbiguityMode -> Selector -> Viewport -> IO () assertNotAmbiguousWithMode testName mode selector viewport =
src/TuiSpec/Types.hs view
@@ -10,6 +10,7 @@ AmbiguityMode (..), App (..), app,+ haskellApp, Key (..), Modifier (..), PtyHandle (..),@@ -30,9 +31,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 +54,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 +88,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 +130,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 +159,12 @@ , ambiguityMode = FailOnAmbiguous , updateSnapshots = False , snapshotTheme = "auto"+ , recordTraceTo = Nothing } -- | The tuispec library/protocol version. tuispecVersion :: String-tuispecVersion = "0.2.0.0"+tuispecVersion = "0.3.0.0" -- | Key modifiers for combo key presses. data Modifier@@ -223,9 +267,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 +291,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.0.0 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