diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/SKILL.md b/SKILL.md --- a/SKILL.md +++ b/SKILL.md @@ -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 ` (use + `--speed as-fast-as-possible` for CI inspection). + Run it: ```bash diff --git a/cbits/tuispec_pty.c b/cbits/tuispec_pty.c new file mode 100644 --- /dev/null +++ b/cbits/tuispec_pty.c @@ -0,0 +1,6 @@ +#include + +int tuispec_enable_packet_mode(int fd) { + int packet_mode = 1; + return ioctl(fd, TIOCPKT, &packet_mode); +} diff --git a/src/TuiSpec.hs b/src/TuiSpec.hs --- a/src/TuiSpec.hs +++ b/src/TuiSpec.hs @@ -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 diff --git a/src/TuiSpec/Choice.hs b/src/TuiSpec/Choice.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Choice.hs @@ -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) diff --git a/src/TuiSpec/Runner.hs b/src/TuiSpec/Runner.hs --- a/src/TuiSpec/Runner.hs +++ b/src/TuiSpec/Runner.hs @@ -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 = diff --git a/src/TuiSpec/Types.hs b/src/TuiSpec/Types.hs --- a/src/TuiSpec/Types.hs +++ b/src/TuiSpec/Types.hs @@ -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). } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 = diff --git a/tuispec.cabal b/tuispec.cabal --- a/tuispec.cabal +++ b/tuispec.cabal @@ -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