diff --git a/docs/spec/canvas-pane.md b/docs/spec/canvas-pane.md index 1a6ceabe..8f611b72 100644 --- a/docs/spec/canvas-pane.md +++ b/docs/spec/canvas-pane.md @@ -167,10 +167,11 @@ Three layers of state preservation: | File | Purpose | |---|---| | `src/Shared/Types.fs` | Shared canvas domain types (incl. `CanvasDocKind` + `CanvasDocKind.classify`), API methods, bridge liveness, send results, pane position | -| `src/Client/App.fs` | Elmish `init`/`update` logic and views for awareness, auto-display, routing, archive, and launch actions (the `Model`/`Msg` types and shared plumbing live in `AppTypes.fs`; the canvas model slice in `CanvasState.fs`; the canvas `update`-arm bodies in `CanvasUpdate.fs` — each canvas arm here is a one-line delegation) | +| `src/Client/App.fs` | Elmish `init`/`update` logic and the top-level `view` wiring (the `Model`/`Msg` types and shared plumbing live in `AppTypes.fs`; the canvas model slice in `CanvasState.fs`; the canvas `update`-arm bodies in `CanvasUpdate.fs`; the canvas pane view wiring in `CanvasView.fs` — each canvas arm here is a one-line delegation) | | `src/Client/AppTypes.fs` | Foundation module: the Elmish `Model` + `Msg` types plus shared plumbing (`worktreeApi` lazy proxy, `findWorktree`, `saveCollapsedReposCmd`) used by both `App.fs` and the canvas update arms. Compiled after `CanvasState.fs` and before `CanvasUpdate.fs`/`App.fs` so canvas update logic can be lifted out of `App.fs` without a cyclic reference. Type relocation only — `update` stays a single function in `App.fs`. | | `src/Client/CanvasUpdate.fs` | Canvas `update`-arm bodies extracted from `App.fs` (Toggle/SetPosition/Select/Open/Archive(+Result)/Navigate/MessageReceived/SendResult/Dismiss/LaunchCanvasSession/Morph*), the shared canvas helpers (`activeVisibleDoc`, `isKnownCanvasDoc`, `markVisibleDocCmd`), and the `messageListener` subscription glue. App.fs delegates one arm → one function. Compiled after `AppTypes.fs` and before `App.fs`. Body extraction only — `update` stays one function (no sub-`Msg`/`Cmd.map`). | | `src/Client/CanvasState.fs` | Canvas pane model slice — the `CanvasState` record (compiled before `App.fs`, nested as `Model.Canvas`) plus pure helpers `touchVisitedDoc`, `canvasDocKind`, `activeVisibleDoc`, `markVisibleDocCmd`, and the `MaxLiveIframes` cap | +| `src/Client/CanvasView.fs` | Canvas pane view wiring extracted from `App.fs`'s `view`: `focusedWorktreeCanvasDoc` plus the block that builds `CanvasPaneCallbacks` and renders `CanvasPane.view`. Compiled after `CanvasUpdate.fs`, before `App.fs`. | | `src/Client/CanvasPane.fs` | Pane layout, overview, tab bar, liveness dot, iframe, banners, and message listener | | `src/Client/Navigation.fs` | `CanvasSendState` DU | | `src/Client/CanvasAwareness.fs` | Pure helpers for doc awareness: seeding viewed hashes, unviewed detection, canvas events, auto-display | @@ -195,8 +196,8 @@ Three layers of state preservation: - **Per-doc author routing** — docs persist ownership by `sessionId`, canvas messages route to the selected doc's owner session, and liveness/resume operate per doc instead of per-worktree. - **Two canvas doc kinds** — `CanvasDoc.Kind` (`AgentDoc | SystemView`, classified by filename in `CanvasScanner`) gates the session-document machinery. A `SystemView` (currently only the beads dashboard) opts out of liveness, Start-session, the message bridge, morph, content-hash awareness, and archiving, and gets a distinct far-left `.canvas-system-tab` affordance instead of a normal doc tab. This makes the misfit states unrepresentable rather than emergent from `OwnerSessionId = None`. - **Tab switch lazy morph** — when switching to a previously hidden iframe, unconditionally dispatch `MorphActiveDoc` so the morph controller fetches fresh content. If the content hasn't changed, idiomorph diffs to zero changes (no-op). This avoids tracking per-iframe content hashes while keeping hidden iframes up to date. -- **`Model`+`Msg` lifted into `AppTypes.fs`** — the Elmish `Model` and `Msg` types, plus the shared plumbing the canvas update arms need (`worktreeApi`, `findWorktree`, `saveCollapsedReposCmd`), live in `src/Client/AppTypes.fs` (compiled after `CanvasState.fs`, before `CanvasUpdate.fs`/`App.fs`). This is a pure type/value relocation that creates a compile-order seam: the canvas update arms are extracted into `CanvasUpdate.fs` (compiled between `AppTypes.fs` and `App.fs`) without a cyclic reference, while `update` remains a single function in `App.fs` (no sub-`Msg`/`Cmd.map` split). Consumers that previously reached these via `open App` (three test files) add `open AppTypes`; nothing references them by `App.`-qualified name except `App.computeActivityLevel`, which stays in `App.fs`. -- **Canvas `update` arms extracted into `CanvasUpdate.fs`** — the canvas `update`-arm bodies (`ToggleCanvasPane`, `SetCanvasPosition`, `SelectCanvasDoc`, `OpenCanvasDoc`, `ArchiveCanvasDoc`, `ArchiveCanvasDocResult`, `NavigateCanvasDoc`, `CanvasMessageReceived`, `CanvasSendResult`, `DismissCanvasMessageError`, `LaunchCanvasSession`, `MorphActiveDoc`, `MorphComplete`), the shared canvas helpers (`activeVisibleDoc`, `isKnownCanvasDoc`, `markVisibleDocCmd`), and the `messageListener` subscription glue move to `src/Client/CanvasUpdate.fs` (compiled after `AppTypes.fs`, before `App.fs`). Each canvas arm in `App.fs` is now a one-line delegation (`| ToggleCanvasPane -> CanvasUpdate.toggleCanvasPane model`). This is **body extraction**, not a `Cmd.map` sub-component split: `update` stays a single function over the flat `Msg`, and each helper takes the whole `Model` and returns `Model * Cmd` (data-last `model` parameter). `FocusOverviewCard` stays inline in `App.fs` — it is an overview-card focus arm, not a doc/morph/archive arm, and is outside the moved set. The `isKnownCanvasDoc` consumer in the tests adds `open CanvasUpdate`. Realized line counts: `App.fs` 2015 → 1861 (canvas update logic, ~150 lines, removed); it does **not** reach `main` size (1635) because the canvas **view** code (`canvasEventEntry`, `canvasEventLog`, `focusedWorktreeCanvasDoc`, and the pane-view dispatch wiring) and the canvas params threaded through `worktreeCard`/`renderCard`/`repoSection` remain — a separate view extraction deferred to `docs/spec/future/app-fs-view-extraction.md`. The stale "~430 lines / main size" estimate in the original task conflated this deferred view extraction with the update-arm extraction; only the update arms are in scope here. The structural gate (each canvas arm is a one-line delegation; bodies live in `CanvasUpdate.fs`) is what proves the extraction. +- **`Model`+`Msg` lifted into `AppTypes.fs`** — the Elmish `Model` and `Msg` types, plus the shared plumbing the canvas update arms need (`worktreeApi`, `findWorktree`, `saveCollapsedReposCmd`), live in `src/Client/AppTypes.fs` (compiled after `CanvasState.fs`, before `CanvasUpdate.fs`/`App.fs`). This is a pure type/value relocation that creates a compile-order seam: the canvas update arms are extracted into `CanvasUpdate.fs` (compiled between `AppTypes.fs` and `App.fs`) without a cyclic reference, while `update` remains a single function in `App.fs` (no sub-`Msg`/`Cmd.map` split). Consumers that previously reached these via `open App` (three test files) add `open AppTypes`; nothing references them by `App.`-qualified name (the activity helper once at `App.computeActivityLevel` now lives in `ActivityState.fs`). +- **Canvas `update` arms extracted into `CanvasUpdate.fs`** — the canvas `update`-arm bodies (`ToggleCanvasPane`, `SetCanvasPosition`, `SelectCanvasDoc`, `OpenCanvasDoc`, `ArchiveCanvasDoc`, `ArchiveCanvasDocResult`, `NavigateCanvasDoc`, `CanvasMessageReceived`, `CanvasSendResult`, `DismissCanvasMessageError`, `LaunchCanvasSession`, `MorphActiveDoc`, `MorphComplete`), the shared canvas helpers (`activeVisibleDoc`, `isKnownCanvasDoc`, `markVisibleDocCmd`), and the `messageListener` subscription glue move to `src/Client/CanvasUpdate.fs` (compiled after `AppTypes.fs`, before `App.fs`). Each canvas arm in `App.fs` is now a one-line delegation (`| ToggleCanvasPane -> CanvasUpdate.toggleCanvasPane model`). This is **body extraction**, not a `Cmd.map` sub-component split: `update` stays a single function over the flat `Msg`, and each helper takes the whole `Model` and returns `Model * Cmd` (data-last `model` parameter). `FocusOverviewCard` stays inline in `App.fs` — it is an overview-card focus arm, not a doc/morph/archive arm, and is outside the moved set. The `isKnownCanvasDoc` consumer in the tests adds `open CanvasUpdate`. Realized line counts: `App.fs` 2015 → 1861 (canvas update logic, ~150 lines, removed); it does **not** reach `main` size (1635) because the canvas **view** code (`canvasEventEntry`, `canvasEventLog`, `focusedWorktreeCanvasDoc`, and the pane-view dispatch wiring) and the canvas params threaded through `worktreeCard`/`renderCard`/`repoSection` remain — a separate view extraction, since completed. The stale "~430 lines / main size" estimate in the original task conflated this deferred view extraction with the update-arm extraction; only the update arms are in scope here. The structural gate (each canvas arm is a one-line delegation; bodies live in `CanvasUpdate.fs`) is what proves the extraction. - **Canvas model slice as a nested record** — the canvas Model-field group is extracted as a nested record `Canvas: CanvasState.CanvasState` on `App.Model` (mirroring the existing `CreateModal`/`ConfirmModal` nesting precedent). The four pure helpers (`touchVisitedDoc`, `canvasDocKind`, `activeVisibleDoc`, `markVisibleDocCmd`) plus the `MaxLiveIframes` literal live in `src/Client/CanvasState.fs` (compiled before `App.fs`); they take pure slices (`repos`/`focused`/`activeCanvasDoc`) rather than the whole `Model`, and `markVisibleDocCmd` is parameterized over the message constructor so the module needs no concrete `Msg` type. Thin `App.fs` wrappers keep `update` call sites unchanged. This is field-path nesting only — **not** the larger `Cmd.map` sub-component split (no sub-`Msg`/sub-`update`; `update` stays one function), which is out of scope. - **Cross-platform canvas doc path** — `CanvasPrompt.continueWorking` (`src/Shared/Types.fs`) builds the canvas-session launch path with forward slashes (`{worktree}/.agents/canvas/{filename}`), which resolve correctly on Windows, Linux, and macOS. `System.IO.Path.Combine` is deliberately not used because `src/Shared` is Fable-compiled to JavaScript and cannot reference `System.IO`. diff --git a/docs/spec/contextual-actions.md b/docs/spec/contextual-actions.md index 2a247694..ed88b012 100644 --- a/docs/spec/contextual-actions.md +++ b/docs/spec/contextual-actions.md @@ -78,7 +78,8 @@ Action button rendering functions take `dispatch`, `wt: WorktreeStatus`, and con | `src/Shared/Types.fs` | Add `launchAction` to `IWorktreeApi` | | `src/Server/SessionManager.fs` | Extend `openNewTabInWindow` with optional command, add `LaunchAction` message | | `src/Server/WorktreeApi.fs` | Wire `launchAction` endpoint with provider-aware command construction | -| `src/Client/App.fs` | Add `LaunchAction` msg, action button rendering functions, integrate into PR row and build badges | +| `src/Client/App.fs` | Add `LaunchAction` msg + update arm | +| `src/Client/CardViews.fs` | Action button rendering functions, integrated into PR row and build badges | | `src/Client/index.html` | CSS for action button styles | ## Related Specs diff --git a/docs/spec/future/app-fs-view-extraction.md b/docs/spec/future/app-fs-view-extraction.md deleted file mode 100644 index 107d991a..00000000 --- a/docs/spec/future/app-fs-view-extraction.md +++ /dev/null @@ -1,137 +0,0 @@ -# App.fs View Extraction - -Status: **Future / Deferred** — design only. NOT implemented on the canvas48 branch. - -Parent spec: `docs/spec/canvas-pane.md`. - -## Why this doc exists - -`src/Client/App.fs` is large, and there are **two independent** view-extraction -opportunities that are easy to conflate. This note separates them so future work -attributes each one correctly — and so that neither is treated as a blocker for the -canvas48 merge. - -It also **preserves the durable App.fs note** that lived as item #2 in -`docs/spec/future/canvas-bridge-pre-existing-fixes.md`, which is being retired (task -`tm-canvas48-wld1`). See *Provenance* below — nothing durable is lost by that deletion. - -## Sizing (verified) - -| Measurement (`src/Client/App.fs`) | `main` | canvas48 head | -|-----------------------------------|-------:|--------------:| -| Total lines | 1489 | 1685 | -| `canvas` references | **0** | ~200 | - -The key fact: **most of App.fs's bulk predates this branch and is unrelated to canvas.** -On `main` the file is already ~1489 lines with **zero** canvas references. - -## Opportunity A — Pre-existing view bulk (already on `main`; NOT this branch's growth) - -**This is the primary point of this document.** - -On `main`, App.fs is dominated by three pure-render view families that have **nothing to -do with canvas** and predate the canvas work. Approximate sizes on `main`: - -- **Worktree-card views — "CardView", ~650 lines.** - `compactWorktreeCard`, `worktreeCard`, `renderCard`, plus their button/badge/section - helpers: `terminalButton`, `editorButton`, `resumeButton`, `deleteButton`, - `archiveButton`, `prActionButton`, `prBadgeContent`, `prSection`, `prRow`, `syncButton`, - `mainBehindWithSync`, `buildBadge`, `beadsProgressBar`, `eventLogEntry`, `eventLog`. -- **Mascot eye views — "MascotView", ~190 lines.** - `viewEyeOpen` / `viewEyeRolledBack` / `viewEyeClosed` (the ~150-line trio at - `App.fs:1254–1401` on `main`) plus `randomEyeDirection` and the `computeActivityLevel` - plumbing that drives the eyes. -- **Status-overview / scheduler-footer views — "OverviewView", ~100 lines.** - `statusOverviewRow`, `pinnedErrorEntry`, `schedulerFooter`, plus the path-prefix helpers - they depend on (`knownCategories`, `categoryDisplayName`, `commonPathPrefix`, - `stripPrefix`). - -Together these are **~900+ lines** of pre-existing view code. They: - -- carry **zero** canvas references, -- exist verbatim on `main`, -- are therefore **not part of canvas48's growth** and must not be attributed to it - (canvas refs in App.fs: **0 on `main`** → ~200 on head — all of that delta is the - canvas feature, none of it is these families). - -They are the **largest** App.fs extraction opportunity, but they are **deferred**: they are -orthogonal to the canvas feature, they are pure render code, and extracting them on this -branch would balloon the diff for no functional gain. - -### Suggested approach (Opportunity A) - -- Lift each family into its own client module, compiled before `App.fs` - (e.g. `CardViews.fs`, `MascotView.fs`, `OverviewViews.fs`). -- Each function takes pure slices + `dispatch` and returns `ReactElement`; `App.fs` keeps - only the top-level `view` wiring. -- Purely structural; tests should stay green with no edits beyond `open`/namespace - adjustments. - -## Opportunity B — This branch's canvas view layer (layer 2) - -The canvas48 branch grew App.fs in two layers: - -1. **Canvas `update` logic** (the canvas `Msg` arm bodies + shared helpers + subscription - glue) — **already extracted**: `Model`/`Msg` → `AppTypes.fs` (task `tm-canvas48-aaxl`), - and the canvas `update`-arm bodies/helpers → `CanvasUpdate.fs` (task `tm-canvas48-wfgx`), - with canvas state in `CanvasState.fs`. Each canvas `update` arm in `App.fs` is now a - one-line delegation, and `update` remains a single function (no `Cmd.map` split). -2. **Canvas view code** — **deliberately left in `App.fs`** and the remaining canvas bulk. - This is why App.fs lands above `main` size after the update-arm extraction rather than - back at `main` size: the two layers were conflated in the original sizing estimate. - -Candidate scope (what would move): - -- `canvasEventEntry` / `canvasEventLog` — per-worktree canvas event list rendering. -- `focusedWorktreeCanvasDoc` — resolves the focused worktree's active - `(WorktreeStatus, CanvasDoc)` for the pane (uses `CanvasUpdate.activeVisibleDoc`). -- The canvas-pane block inside the top-level `view` — building `CanvasPaneCallbacks` - (`onOverviewClick`, `onOverviewDocClick`, `archiveCanvasDoc`, `launchCanvasSession`), - `focusedUnviewedFilenames`, and the call into `CanvasPane.view`. -- The canvas parameters threaded through `worktreeCard` / `renderCard` / `repoSection` - (`canvasEvents: Map`, `canvasPaneOpen: bool`). - -Why deferred (not done with the update arms): - -- The canvas view bulk is **interleaved with the (pre-existing) card views** from - Opportunity A, so it cannot be lifted wholesale into a canvas module. `worktreeCard`, - `renderCard`, and `repoSection` are the generic card views; they merely take extra - `canvasEvents` / `canvasPaneOpen` parameters. A clean split needs a small view-model or - callback bundle — a design step of its own. -- It is **pure render code with no behavior change**, so it is the lowest-risk thing to - defer and the easiest to extract later in isolation. -- Keeping the two extractions separate keeps each change reviewable: the update-arm move is - verified structurally (each arm is a one-line delegation), independent of view churn. - -### Suggested approach (Opportunity B) - -- A `CanvasView.fs` (compiled after `CanvasUpdate.fs`, before `App.fs`) holds the - canvas-specific render functions, taking pure slices + a `dispatch`/callback bundle rather - than the whole `Model`, mirroring the `CanvasState.fs` / `CanvasUpdate.fs` seam already - established. -- Thread canvas data into the card views via a small record (e.g. a `CanvasCardSlice`) - instead of loose extra parameters, so the card signatures stop carrying canvas-shaped - arguments. -- Keep `update` and the top-level `view` wiring in `App.fs`; this remains view-body - relocation, not an Elmish sub-component split. - -> Note: doing **B alone barely dents App.fs size** — most of the bulk is **Opportunity A**. -> Meaningful size reduction comes from extracting the pre-existing card/mascot/overview -> views, not from the canvas slice. - -## Out of scope (both opportunities) - -- No `Cmd.map` / sub-`Msg` / sub-`update` split. The flat `Msg` and single `update` function - are intentional (see `docs/spec/canvas-pane.md` Decisions). -- No behavior change. These are structure-only refactors; tests should stay green with no - edits beyond `open`/namespace adjustments. - -## Provenance - -This document supersedes the App.fs note (**item #2, "App.fs has grown past the file-size -limit"**) from `docs/spec/future/canvas-bridge-pre-existing-fixes.md` (retired by task -`tm-canvas48-wld1`). That note -attributed the size to "~162 canvas references" mixed into App.fs. That framing is corrected -here: on `main`, App.fs has **0** canvas references — the size is **pre-existing view code** -(Opportunity A), and the canvas additions (Opportunity B) are a separate, smaller layer whose -non-view portion has already been extracted. No durable content is lost by deleting that doc. diff --git a/docs/spec/future/code-improvements.md b/docs/spec/future/code-improvements.md new file mode 100644 index 00000000..1d128e52 --- /dev/null +++ b/docs/spec/future/code-improvements.md @@ -0,0 +1,57 @@ +# Code Improvements — Running Backlog + +A living index of code-quality improvements for this repo, plus the repeatable loop for +doing one at a time. Each improvement is a focused, behavior-preserving change shipped from +its own worktree. This file is the entry point; detailed designs live in their own spec. + +## The loop (one improvement per worktree) + +1. **New worktree off `main`** — e.g. `git worktree add ..\tm- -b main` (or the + `tm`/treemon worktree tooling). One improvement per branch keeps diffs reviewable. +2. **Pick the top candidate** below, or investigate a new one. For anything with a design + fork, write a canvas decision doc (`.agents/canvas/*.html`) and let the user choose before + planning. +3. **`/bd-plan`** the work — produces a spec under `docs/spec/`, a beads feature + sequenced + tasks, a focused-review gate, and a verification task. +4. **`/bd-execute`** — runs each task through executor + reviewer, then the focused-review + quality gate, then the verify task (build + Unit + Fast + E2E + structure). +5. **Open a PR** (`github` skill). **Keep docs honest in the same PR**: if you moved code, + update the `Key Files` tables / module references in any affected spec, and update this + backlog (move the item to *Done*). + +## Conventions + +- **Behavior-preserving by default.** Refactors must keep the build and the full suite green + (Unit + Fast + E2E); E2E asserts on DOM/CSS so identical render proves correctness. +- **Don't let specs rot.** When code moves between modules, the specs that point at it + (their `Key Files` tables, `### Client-Side (…)` headers) must be updated in the same PR. + Spec drift after a refactor is itself a tracked defect — see the *Process* candidate below. +- **Evidence-driven scope.** Prefer the simplest split the code supports; don't invent module + boundaries the behavior doesn't justify (see the App.fs extraction's hybrid approach). + +## Candidates (prioritized) + +| # | Improvement | Detail / spec | Status | +|---|---|---|---| +| 1 | **Strong-typed paths** — an `AbsolutePath` type to kill path-comparison bugs at construction time | `docs/spec/future/strong-typed-paths.md` | Deferred (cost/benefit) | +| 2 | **Port management** — centralize/derive the dev/prod/canvas/vite port assignments | `docs/spec/future/port-management.md` | Idea | +| 3 | **Canvas roadmap items** — follow-on canvas-pane enhancements | `docs/spec/future/canvas-roadmap.md` | Idea | +| 4 | **Process: guard against spec drift** — a lightweight check (or review rule) that flags `Key Files` references to moved/renamed modules so docs can't silently rot after refactors | — | Idea | +| 5 | **Survey other large modules** — apply the same view/state/update extraction lens to the next-largest files (server-side `RefreshScheduler.fs`, `WorktreeApi.fs`, etc.) if they mix concerns | — | Idea (needs investigation) | + +> Add new candidates here as they surface (often from focused-review findings). Keep the list +> honest: remove ones that turn out not to be worth it, and record why in the relevant spec. + +## Done + +- **App.fs view extraction** — `src/Client/App.fs` 1861 → 795 lines. Extracted + `OverviewViews.fs`, `CardViews.fs` (with `CardViewProps`/`CardCallbacks` records), + `MascotState.fs`/`MascotView.fs`, and `CanvasView.fs`; flat `Msg` + single `update` + preserved. Branch `code-improvement`. +- **Activity / mascot separation of concerns** — split user-activity / idle-detection state + out of the mascot into a dedicated `ActivityState.fs` + `ActivityUpdate.fs` slice; the + mascot is now a pure gaze-and-eyes widget that *observes* `ActivityLevel`. See + `docs/spec/user-idle-detection.md`. +- **Review-rule fix** — `review/rules/immutability.md` now forbids using a `ref` cell to dodge + the rule (`let mutable` is the sanctioned, comment-justified mechanism when mutation is + truly required). diff --git a/docs/spec/resume-last-session.md b/docs/spec/resume-last-session.md index 6c0b4fcd..bd77f76e 100644 --- a/docs/spec/resume-last-session.md +++ b/docs/spec/resume-last-session.md @@ -74,7 +74,7 @@ Reuses the existing `launchSession` flow (spawn tracked terminal with command) New `Msg` variant: `ResumeSession of WorktreePath` -Button rendering function `resumeButton` in `App.fs`: +Button rendering function `resumeButton` in `CardViews.fs`: - Connector/plug SVG icon - CSS class: `resume-btn` - Tooltip: "Resume last session (R)" @@ -121,7 +121,8 @@ Minimal styling for `.resume-btn` — matches existing button styles (`.terminal | `src/Server/CodingToolStatus.fs` | Provides `getLastSessionId` | | `src/Server/CodingToolCli.fs` | Unified CLI invocation builder — `Resume` mode handles the resume command | | `src/Server/WorktreeApi.fs` | Wire `resumeSession` endpoint | -| `src/Client/App.fs` | Add `ResumeSession` msg, `resumeButton`, `canResumeSession`, keyboard shortcut | +| `src/Client/App.fs` | Add `ResumeSession` msg + update arm, keyboard shortcut | +| `src/Client/CardViews.fs` | `resumeButton` rendering, `canResumeSession` | | `src/Client/index.html` | CSS for `.resume-btn` | ## Related Specs diff --git a/docs/spec/user-idle-detection.md b/docs/spec/user-idle-detection.md index 5901721a..370a5d89 100644 --- a/docs/spec/user-idle-detection.md +++ b/docs/spec/user-idle-detection.md @@ -47,11 +47,11 @@ When transitioning from Idle/DeepIdle → Active, the client immediately dispatc New `ActivityLevel` DU: `Active | Idle | DeepIdle`. New `reportActivity: ActivityLevel -> Async` method on `IWorktreeApi`. -### Client-Side (`src/Client/App.fs`) +### Client-Side (`src/Client/ActivityState.fs` + `ActivityUpdate.fs`) -Elmish subscription registers DOM event listeners (mousemove, keydown, click, scroll). Throttled to dispatch `UserActivity` at most once per 5s — the throttle uses a mutable timestamp inside the subscription closure (Elmish's designated impure boundary, same pattern as `setInterval`). The Model stays fully immutable with `LastActivityTime: float` and `ActivityLevel: ActivityLevel`. +The `activityDetection` Elmish subscription registers DOM event listeners (mousemove, keydown, click, scroll). Throttled to dispatch `UserActivity` at most once per 5s — the throttle uses a mutable timestamp inside the subscription closure (Elmish's designated impure boundary, same pattern as `setInterval`). The state is the immutable `ActivityState` slice (`ActivityState.fs`) — `LastActivityTime: float` and `ActivityLevel: ActivityLevel` — nested on the Model as `Model.Activity`; the subscription and the `Tick`/`UserActivity` arm bodies live in `ActivityUpdate.fs` (both extracted from `App.fs`). -`computeActivityLevel` is a pure function: compares `Date.now() - lastActivity` against 3min/15min thresholds. +`ActivityState.computeActivityLevel` is a pure function: compares `Date.now() - lastActivity` against 3min/15min thresholds. `pollingSubscription` includes activity level in its key so Elmish tears down and recreates the interval on transitions. Active/Idle = 1s, DeepIdle = 15s. diff --git a/docs/spec/worktree-monitor.md b/docs/spec/worktree-monitor.md index c7be2114..d9c7af18 100644 --- a/docs/spec/worktree-monitor.md +++ b/docs/spec/worktree-monitor.md @@ -227,7 +227,12 @@ After the burst, `lastRuns` is pre-populated and the normal sequential loop take | `src/Server/SyncEngine.fs` | Branch sync pipeline, provider-aware conflict resolution | | `src/Server/SessionManager.fs` | MailboxProcessor session agent, spawn/focus/kill, persistence | | `src/Server/Win32.fs` | P/Invoke: EnumWindows, SetForegroundWindow, WM_CLOSE | -| `src/Client/App.fs` | Elmish MVU app, repo sections, card rendering | +| `src/Client/App.fs` | Elmish MVU app: `init`, the `update` `match`, `appSubscriptions`, top-level `view` wiring | +| `src/Client/CardViews.fs` | Worktree card rendering (cards, action buttons, badges, PR/sync/event-log helpers, `repoSection`) via `CardViewProps`/`CardCallbacks` records | +| `src/Client/OverviewViews.fs` | Status-overview row + scheduler footer rendering | +| `src/Client/MascotState.fs` / `MascotView.fs` | Mascot eyes: gaze slice + eye SVG render (observes `ActivityLevel`) | +| `src/Client/ActivityState.fs` / `ActivityUpdate.fs` | User-activity / idle-detection: state slice + `Tick`/`UserActivity` bodies + activity subscription | +| `src/Client/CanvasView.fs` | Canvas pane view wiring (`CanvasPane.view` callbacks/slices) | | `src/Client/Navigation.fs` | Keyboard navigation: spatial arrow keys, key bindings | | `src/Tests/fixtures/` | Captured AzDo, GitHub, Copilot, and Claude session data for offline parsing/replay tests | diff --git a/review/rules/immutability.md b/review/rules/immutability.md index a2ae40b2..b50845e2 100644 --- a/review/rules/immutability.md +++ b/review/rules/immutability.md @@ -12,18 +12,27 @@ All bindings must be immutable; never mutate collections passed as arguments. Mutable state is the root of most bugs. Immutable data makes data flow explicit, eliminates side effects, and makes code easier to reason about. ## Requirements -- No `let mutable` bindings +- No `let mutable` bindings in ordinary code - Never pass collections into functions to be mutated — return new collections instead - Prefer immutable data structures (records, DUs, lists) over mutable ones (ResizeArray, Dictionary) -- If mutable state is absolutely required (e.g. MailboxProcessor internals, NUnit `[]`/`[]` lifecycle fields), it must be explicitly isolated and documented +- If mutable state is genuinely unavoidable (e.g. a throttle/`setInterval` timestamp confined to an Elmish subscription closure, MailboxProcessor internals, NUnit `[]`/`[]` lifecycle fields), use `let mutable` isolated to the narrowest possible scope **and add an inline comment justifying why an immutable solution doesn't fit**. A justified, scoped, commented `let mutable` is compliant — do not flag it. + +## Use `let mutable`, never `ref`, when mutation is justified +A `ref` cell is **not** more immutable than `let mutable` — it is the identical mutation with worse ergonomics (a heap-allocated cell plus `:=`/`.Value` noise). Never recommend or write a `ref` cell to "satisfy" this rule, and never rewrite an existing `let mutable` into a `ref`. The only question this rule asks is *"is the mutation justified and scoped?"* — never *"which mutation syntax?"*. When the answer is yes, a `let mutable` carrying a justifying comment is the correct and final form. ## Wrong ```fsharp +// Unjustified module-level mutable in ordinary code let mutable count = 0 let increment () = count <- count + 1 +// Mutating a collection passed in as an argument let addToList (items: ResizeArray) name = items.Add(name) + +// `ref` cell used to dodge the rule — same mutation, worse ergonomics, still wrong +let lastTime = ref (Date.now ()) +let onEvent () = lastTime := Date.now () ``` ## Correct @@ -32,4 +41,12 @@ let increment count = count + 1 let addToList items name = name :: items + +// Justified, closure-scoped `let mutable` — the impure boundary is documented inline, +// so it is compliant. `let mutable`, never a `ref` cell. +let activityDetection dispatch = + // Throttle timestamp confined to this subscription closure (Elmish's designated impure + // boundary, same as setInterval); an immutable version would re-add listeners per event. + let mutable lastDispatch = Date.now () + ... ``` diff --git a/src/Client/ActivityState.fs b/src/Client/ActivityState.fs new file mode 100644 index 00000000..d02e19ba --- /dev/null +++ b/src/Client/ActivityState.fs @@ -0,0 +1,36 @@ +module ActivityState + +open Shared + +/// The user-activity / idle-detection slice of the dashboard model: the timestamp of the last +/// user interaction and the derived ActivityLevel. Owned here (not on the Mascot) because this +/// state drives the refresh-poll cadence, server presence reporting, and the canvas auto-display +/// idle gate — the mascot eyes are only one *observer* of ActivityLevel. See +/// docs/spec/user-idle-detection.md. +type ActivityState = + { LastActivityTime: float + ActivityLevel: ActivityLevel } + +/// Initial activity state: presence Active. The live first-load timestamp is stamped in App.init +/// via Date.now (); kept 0.0 here so this value carries no Fable runtime call at module load +/// (which would trip the .NET test host's static initializer — see AppTypes.fs worktreeApi). +let empty : ActivityState = + { LastActivityTime = 0.0 + ActivityLevel = ActivityLevel.Active } + +/// Idle thresholds in ms since the last user activity. idleThresholdMs / deepIdleThresholdMs +/// bucket the elapsed time into the ActivityLevel that drives presence reporting and the +/// refresh-poll cadence; autoDisplayIdleMs is the shorter idle window after which a changed +/// agent doc may auto-steal focus into the canvas. +let idleThresholdMs = 180_000.0 +let deepIdleThresholdMs = 900_000.0 +let autoDisplayIdleMs = 60_000.0 + +/// Activity level from elapsed idle time: +/// Active (< idleThresholdMs) -> Idle (< deepIdleThresholdMs) -> DeepIdle. +let computeActivityLevel (lastActivityTime: float) (now: float) = + let elapsed = now - lastActivityTime + + if elapsed < idleThresholdMs then ActivityLevel.Active + elif elapsed < deepIdleThresholdMs then ActivityLevel.Idle + else ActivityLevel.DeepIdle diff --git a/src/Client/ActivityUpdate.fs b/src/Client/ActivityUpdate.fs new file mode 100644 index 00000000..af01c832 --- /dev/null +++ b/src/Client/ActivityUpdate.fs @@ -0,0 +1,71 @@ +module ActivityUpdate + +// User-activity / idle-detection update-arm bodies plus the activity-detection subscription, +// extracted from `App.fs`. Mirrors `CanvasUpdate.fs`: body extraction only — the root `update` +// keeps the flat `match` and delegates to these functions (no sub-`Msg`/`Cmd.map` split). `Tick` +// stays in the root arm because it also expires canvas events and drives the worktree/sync poll; +// only its activity-recompute lifts here. Compiled after `AppTypes.fs` (which holds `Model`/`Msg`) +// and before `App.fs`. See docs/spec/user-idle-detection.md. + +open Shared +open Elmish +open Browser +open AppTypes + +/// `Tick` activity-recompute: derive the new `ActivityLevel` from the elapsed idle time and emit a +/// presence report only when it actually changed. Returns the updated activity slice and that +/// `Cmd`; the root `Tick` arm threads the slice into the model alongside its canvas-event expiry +/// and poll fetches (the reason `Tick` does not delegate wholesale). +let tickActivity (now: float) (activity: ActivityState.ActivityState) : ActivityState.ActivityState * Cmd = + let newLevel = ActivityState.computeActivityLevel activity.LastActivityTime now + + let reportCmd = + if newLevel <> activity.ActivityLevel then + Cmd.OfAsync.attempt worktreeApi.Value.reportActivity newLevel (fun _ -> NoOp) + else + Cmd.none + + { activity with ActivityLevel = newLevel }, reportCmd + +/// `UserActivity` arm body: stamp the latest activity time and force the level back to `Active`. +/// Only when waking from a non-`Active` level does it kick an immediate `Tick` + presence report, +/// so the poll cadence and server presence resync without waiting for the next interval. +let userActivity (now: float) (model: Model) : Model * Cmd = + let wasActive = model.Activity.ActivityLevel = ActivityLevel.Active + + let wakeUpCmd = + if not wasActive then + Cmd.batch [ + Cmd.ofMsg (Tick now) + Cmd.OfAsync.attempt worktreeApi.Value.reportActivity ActivityLevel.Active (fun _ -> NoOp) + ] + else + Cmd.none + + { model with + Activity = { model.Activity with LastActivityTime = now; ActivityLevel = ActivityLevel.Active } }, + wakeUpCmd + +/// Activity-detection subscription: dispatches `UserActivity` on user input +/// (mousemove/keydown/click/scroll), throttled to once per 5s, and removes its listeners on +/// dispose. Mirrors `CanvasUpdate.messageListener` as the activity entry in `appSubscriptions`. +let activityDetection (dispatch: Dispatch) = + // Throttle timestamp confined to this subscription closure — Elmish's designated impure + // boundary (same pattern as setInterval). An immutable alternative would have to re-register + // the DOM listeners on every event; `let mutable` (never a ref cell) is the right tool here. + let mutable lastDispatchTime = Fable.Core.JS.Constructors.Date.now () + let throttleMs = 5000.0 + + let handler = + fun (_: Browser.Types.Event) -> + let now = Fable.Core.JS.Constructors.Date.now () + if now - lastDispatchTime >= throttleMs then + lastDispatchTime <- now + dispatch (UserActivity now) + + let events = [| "mousemove"; "keydown"; "click"; "scroll" |] + events |> Array.iter (fun evt -> Dom.document.addEventListener (evt, handler)) + + { new System.IDisposable with + member _.Dispose() = + events |> Array.iter (fun evt -> Dom.document.removeEventListener (evt, handler)) } diff --git a/src/Client/App.fs b/src/Client/App.fs index 60862994..ed59de46 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -10,6 +10,7 @@ open Browser open Fable.Core.JsInterop open ActionButtons open CanvasAwareness +open CardViews open AppTypes let fetchWorktrees () = @@ -37,7 +38,6 @@ let init () = SyncPending = Set.empty AppVersion = None EditorName = "VS Code" - EyeDirection = (0.0, 0.0) FocusedElement = None CreateModal = CreateWorktreeModal.Closed ConfirmModal = ConfirmModal.NoConfirm @@ -45,18 +45,11 @@ let init () = DeployBranch = None SystemMetrics = None ActionCooldowns = Set.empty - LastActivityTime = Fable.Core.JS.Constructors.Date.now () - ActivityLevel = ActivityLevel.Active + Activity = { ActivityState.empty with LastActivityTime = Fable.Core.JS.Constructors.Date.now () } + Mascot = MascotState.empty Canvas = CanvasState.empty }, Cmd.batch [ fetchWorktrees (); fetchSyncStatus (); Cmd.OfAsync.attempt worktreeApi.Value.reportActivity ActivityLevel.Active (fun _ -> NoOp); Cmd.OfAsync.perform worktreeApi.Value.loadLastViewedHashes () LoadLastViewedHashes ] -let rng = System.Random() - -let randomEyeDirection () = - let dx = rng.NextDouble() * 3.0 - 1.5 - let dy = rng.NextDouble() * 2.0 - 1.0 - (dx, dy) - let filterDeletedPaths (deleted: Set) (repos: RepoModel list) = if Set.isEmpty deleted then repos else @@ -81,12 +74,6 @@ let removeWorktreeByPath (path: WorktreePath) (model: Model) = DeletedPaths = markDeleted path model.DeletedPaths } { updatedModel with FocusedElement = adjustFocusForVisibility updatedModel.Repos updatedModel.FocusedElement } -let canResumeSession (wt: WorktreeStatus) = - not wt.HasActiveSession - && wt.LastUserMessage.IsSome - && wt.CodingTool <> Working - && wt.CodingTool <> WaitingForUser - let terminalAction (wt: WorktreeStatus) = if wt.HasActiveSession then FocusSession wt.Path else OpenTerminal wt.Path @@ -104,17 +91,6 @@ let keyBinding (focused: FocusTarget) (key: string) (model: Model) : Msg option | RepoHeader repoId, "+" -> Some (ModalMsg (CreateWorktreeModal.OpenCreateWorktree repoId)) | _ -> None -let idleThresholdMs = 180_000.0 -let deepIdleThresholdMs = 900_000.0 -let autoDisplayIdleMs = 60_000.0 - -let computeActivityLevel (lastActivityTime: float) (now: float) = - let elapsed = now - lastActivityTime - - if elapsed < idleThresholdMs then ActivityLevel.Active - elif elapsed < deepIdleThresholdMs then ActivityLevel.Idle - else ActivityLevel.DeepIdle - let update msg model = match msg with | DataLoaded (response, now) -> @@ -158,7 +134,7 @@ let update msg model = if isFirstLoad then [] else detectChangedCanvasDocs now model.Canvas.PreviousCanvasHashes currentCanvasHashes let now = now.ToUnixTimeMilliseconds() |> float - let isIdle = now - model.LastActivityTime > autoDisplayIdleMs + let isIdle = now - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs // Idle auto-display only focus-steals for AgentDoc changes. A SystemView (beads // dashboard) is server-generated and self-refreshing, so its data churn must not // hijack focus; filter it out of the candidates before picking the most recent. @@ -196,7 +172,7 @@ let update msg model = LatestByCategory = response.LatestByCategory AppVersion = Some response.AppVersion EditorName = response.EditorName - EyeDirection = randomEyeDirection () + Mascot = { model.Mascot with EyeDirection = MascotState.randomEyeDirection () } DeletedPaths = stillPending DeployBranch = response.DeployBranch SystemMetrics = response.SystemMetrics @@ -287,38 +263,19 @@ let update msg model = model, Cmd.OfAsync.attempt worktreeApi.Value.openEditor path (fun _ -> Tick(Fable.Core.JS.Constructors.Date.now ())) | Tick now -> - let newLevel = computeActivityLevel model.LastActivityTime now + // Tick stays in the root update because it also expires canvas events and drives the + // worktree/sync poll; only the activity-recompute delegates to ActivityUpdate. + let activity, reportCmd = ActivityUpdate.tickActivity now model.Activity let expiredEvents = expireCanvasEvents (System.DateTimeOffset.FromUnixTimeMilliseconds(int64 now)) model.Canvas.CanvasEvents - let reportCmd = - if newLevel <> model.ActivityLevel then - Cmd.OfAsync.attempt worktreeApi.Value.reportActivity newLevel (fun _ -> NoOp) - else - Cmd.none - // A queued canvas message is honestly pending, not failed: it is delivered to the // server-side queue and drained when a session registers. Never flip Waiting -> Failed on // a wall-clock timer. The delivery signal (an agent doc content-hash change) clears it to // Idle in DataLoaded; absent that, it persists until the user dismisses it. - { model with ActivityLevel = newLevel; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, + { model with Activity = activity; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, Cmd.batch [ fetchWorktrees (); fetchSyncStatus (); reportCmd ] - | UserActivity now -> - let wasActive = model.ActivityLevel = ActivityLevel.Active - - let wakeUpCmd = - if not wasActive then - Cmd.batch [ - Cmd.ofMsg (Tick now) - Cmd.OfAsync.attempt worktreeApi.Value.reportActivity ActivityLevel.Active (fun _ -> NoOp) - ] - else - Cmd.none - - { model with - LastActivityTime = now - ActivityLevel = ActivityLevel.Active }, - wakeUpCmd + | UserActivity now -> ActivityUpdate.userActivity now model | StartSync (path, key) -> let syntheticEvent = @@ -567,12 +524,12 @@ let update msg model = let appSubscriptions (model: Model) : Sub = let pollingIntervalMs = - match model.ActivityLevel with + match model.Activity.ActivityLevel with | ActivityLevel.Active | ActivityLevel.Idle -> 1000 | ActivityLevel.DeepIdle -> 15000 let activityLevelKey = - match model.ActivityLevel with + match model.Activity.ActivityLevel with | ActivityLevel.Active -> "active" | ActivityLevel.Idle -> "idle" | ActivityLevel.DeepIdle -> "deep-idle" @@ -589,27 +546,9 @@ let appSubscriptions (model: Model) : Sub = { new System.IDisposable with member _.Dispose() = Fable.Core.JS.clearInterval intervalId } - let activityDetection (dispatch: Dispatch) = - let mutable lastDispatchTime = Fable.Core.JS.Constructors.Date.now () - let throttleMs = 5000.0 - - let handler = - fun (_: Browser.Types.Event) -> - let now = Fable.Core.JS.Constructors.Date.now () - if now - lastDispatchTime >= throttleMs then - lastDispatchTime <- now - dispatch (UserActivity now) - - let events = [| "mousemove"; "keydown"; "click"; "scroll" |] - events |> Array.iter (fun evt -> Dom.document.addEventListener (evt, handler)) - - { new System.IDisposable with - member _.Dispose() = - events |> Array.iter (fun evt -> Dom.document.removeEventListener (evt, handler)) } - let subs = [ [ "polling"; activityLevelKey ], worktreePolling - [ "activity" ], activityDetection + [ "activity" ], ActivityUpdate.activityDetection [ "canvas-messages" ], CanvasUpdate.messageListener ] if hasSyncRunning model.BranchEvents then @@ -617,905 +556,6 @@ let appSubscriptions (model: Model) : Sub = else subs -let relativeTime = Components.relativeTime - -let ctClassName = - function - | Working -> "working" - | WaitingForUser -> "waiting" - | Done -> "done" - | Idle -> "idle" - -let ctTooltip = - function - | Working -> "Working" - | WaitingForUser -> "Waiting for user" - | Done -> "Done" - | Idle -> "Idle" - -let isMerged (wt: WorktreeStatus) = - match wt.Pr with - | HasPr pr -> pr.IsMerged - | NoPr -> false - -let cardClassName (wt: WorktreeStatus) = - let ct = ctClassName wt.CodingTool - let session = if wt.HasActiveSession then " has-session" else "" - if isMerged wt then $"wt-card ct-{ct} merged{session}" else $"wt-card ct-{ct}{session}" - -let beadsTotal (b: BeadsSummary) = b.Open + b.InProgress + b.Blocked + b.Closed - -let segmentPct count total = - match total with - | 0 -> 0.0 - | _ -> (float count * 100.0) / float total - -let beadsCounts (className: string) (b: BeadsSummary) = - Html.span [ - prop.className className - prop.children [ - Html.span [ prop.className "beads-open"; prop.text (string b.Open) ] - Html.span [ prop.className "beads-sep"; prop.text "/" ] - Html.span [ prop.className "beads-inprogress"; prop.text (string b.InProgress) ] - Html.span [ prop.className "beads-sep"; prop.text "/" ] - Html.span [ prop.className "beads-blocked"; prop.text (string b.Blocked) ] - Html.span [ prop.className "beads-sep"; prop.text "/" ] - Html.span [ prop.className "beads-closed"; prop.text (string b.Closed) ] - ] - ] - -let beadsProgressBar (b: BeadsSummary) = - let total = beadsTotal b - Html.div [ - prop.className "progress-bar" - prop.children [ - Html.div [ - prop.className "progress-segment seg-open" - prop.style [ style.width (length.percent (segmentPct b.Open total)) ] - ] - Html.div [ - prop.className "progress-segment seg-inprogress" - prop.style [ style.width (length.percent (segmentPct b.InProgress total)) ] - ] - Html.div [ - prop.className "progress-segment seg-blocked" - prop.style [ style.width (length.percent (segmentPct b.Blocked total)) ] - ] - Html.div [ - prop.className "progress-segment seg-closed" - prop.style [ style.width (length.percent (segmentPct b.Closed total)) ] - ] - ] - ] - -let mainBehindIndicator (baseBranch: string) (count: int) = - if count = 0 then - Html.span [ - prop.className "main-behind up-to-date" - prop.text "up to date" - ] - else - Html.span [ - prop.className (if count > 20 then "main-behind behind-warning" else "main-behind") - prop.text ($"{count} behind {baseBranch}") - ] - -let isBranchSyncing (events: CardEvent list) = - events |> List.exists (fun e -> e.Status = Some StepStatus.Running) - -let private providerDisplayName (provider: CodingToolProvider option) = - match provider with - | Some Claude -> "Claude" - | Some Copilot -> "Copilot" - | None -> "Coding tool" - -let syncButton dispatch (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = - if isPending then - Html.button [ - prop.className "sync-starting-btn" - prop.disabled true - yield! noFocusProps - prop.text "Sync starting" - ] - else - let syncing = isBranchSyncing branchEvents - let codingToolBusy = wt.CodingTool = Working || wt.CodingTool = WaitingForUser - let disabled = syncing || codingToolBusy - if syncing then - Html.button [ - prop.className "sync-cancel-btn" - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (CancelSync wt.Path)) - prop.text "Cancel" - ] - else - Html.button [ - prop.className (if disabled then "sync-btn disabled" else "sync-btn") - prop.disabled disabled - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (StartSync (wt.Path, scopedKey))) - prop.title (if codingToolBusy then $"{providerDisplayName wt.CodingToolProvider} is active" else $"Sync with {baseBranch} (S)") - prop.text "Sync" - ] - -let mainBehindWithSync dispatch (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = - Html.div [ - prop.className "main-behind-row" - prop.children [ - mainBehindIndicator baseBranch wt.MainBehindCount - if wt.MainBehindCount > 0 then - if wt.IsDirty then - Html.span [ - prop.className "dirty-warning" - prop.text "uncommitted changes" - ] - else syncButton dispatch baseBranch wt branchEvents isPending scopedKey - Html.span [ - prop.className "git-commit-msg" - prop.children [ - Html.text wt.LastCommitMessage - Html.span [ prop.className "commit-time"; prop.text (relativeTime System.DateTimeOffset.Now wt.LastCommitTime) ] - ] - ] - ] - ] - -let stepStatusClassName (status: StepStatus option) = - match status with - | Some StepStatus.Running -> "event-status running" - | Some StepStatus.Succeeded -> "event-status success" - | Some (StepStatus.Failed _) -> "event-status failed" - | Some StepStatus.Cancelled -> "event-status cancelled" - | Some StepStatus.NotConfigured -> "event-status not-configured" - | Some StepStatus.Pending -> "event-status" - | None -> "event-status" - -let stepStatusText (status: StepStatus option) = - match status with - | Some StepStatus.Running -> "running" - | Some StepStatus.Succeeded -> "success" - | Some (StepStatus.Failed msg) -> match msg with "" -> "failed" | _ -> $"failed: {msg}" - | Some StepStatus.Cancelled -> "cancelled" - | Some StepStatus.NotConfigured -> "not configured" - | _ -> "" - -let relativeEventTime (dt: System.DateTimeOffset) = - let diff = System.DateTimeOffset.Now - dt - match diff with - | d when d.TotalSeconds < 60.0 -> $"{int d.TotalSeconds |> max 0}s ago" - | d when d.TotalMinutes < 60.0 -> $"{int d.TotalMinutes}m ago" - | d when d.TotalHours < 24.0 -> $"{int d.TotalHours}h ago" - | d -> $"{int d.TotalDays}d ago" - -let eventLogEntry (onFixTests: (unit -> unit) option) (onConfigureTests: (unit -> unit) option) (evt: CardEvent) = - let isTestFailure = - evt.Source = EventSource.Test && (match evt.Status with Some (StepStatus.Failed _) -> true | _ -> false) - let isTestNotConfigured = - evt.Source = EventSource.Test && evt.Status = Some StepStatus.NotConfigured - let isClickable = (isTestFailure && onFixTests.IsSome) || (isTestNotConfigured && onConfigureTests.IsSome) - Html.div [ - prop.className "event-entry" - prop.children [ - Html.span [ prop.className "event-time"; prop.text (relativeEventTime evt.Timestamp) ] - Html.span [ prop.className "event-source"; prop.text evt.Source ] - Html.span [ prop.className "event-message"; prop.text evt.Message ] - match evt.Status with - | Some _ -> - Html.span [ - prop.className ( - if isClickable - then stepStatusClassName evt.Status + " clickable" - else stepStatusClassName evt.Status) - prop.text (stepStatusText evt.Status) - if isTestFailure then - match onFixTests with - | Some handler -> - prop.title "Click to fix with coding tool" - prop.onClick (fun e -> e.stopPropagation(); handler()) - | None -> () - elif isTestNotConfigured then - match onConfigureTests with - | Some handler -> - prop.title "Click to configure test command" - prop.onClick (fun e -> e.stopPropagation(); handler()) - | None -> () - ] - | None -> Html.none - ] - ] - -let eventLog dispatch (cooldowns: Set) (wtPath: WorktreePath) (hasTestFailureLog: bool) (events: CardEvent list) = - match events with - | [] -> Html.none - | evts -> - let onFixTests = - if not hasTestFailureLog || cooldowns.Contains wtPath then None - else Some (fun () -> dispatch (LaunchAction (wtPath, FixTests))) - let onConfigureTests = - if cooldowns.Contains wtPath then None - else Some (fun () -> dispatch (LaunchAction (wtPath, ConfigureTests))) - Html.div [ - prop.className "event-log" - prop.children (evts |> List.map (eventLogEntry onFixTests onConfigureTests)) - ] - -let canvasEventEntry dispatch (scopedKey: string) (evt: CanvasEvent) = - let verb = match evt.Kind with NewDoc -> "published" | UpdatedDoc -> "updated" - Html.div [ - prop.className "event-entry canvas-event" - prop.onClick (fun e -> - e.stopPropagation() - dispatch (OpenCanvasDoc (scopedKey, evt.Filename))) - prop.children [ - Html.span [ prop.className "event-time"; prop.text (relativeEventTime evt.Timestamp) ] - Html.span [ prop.className "event-message"; prop.text $"{verb} " ] - Html.span [ prop.className "event-source"; prop.text evt.Filename ] - ] - ] - -let canvasEventLog dispatch (scopedKey: string) (events: CanvasEvent list) = - match events with - | [] -> Html.none - | evts -> - Html.div [ - prop.className "event-log" - prop.children (evts |> List.map (canvasEventEntry dispatch scopedKey)) - ] - -let knownCategories = - [ "WorktreeList"; "GitRefresh"; "BeadsRefresh"; "CodingToolRefresh"; "PrFetch"; "GitFetch" ] - -let categoryDisplayName = - function - | "WorktreeList" -> "Worktree \u2630" - | "GitRefresh" -> "Git \u21BB" - | "BeadsRefresh" -> "Beads \u21BB" - | "CodingToolRefresh" -> "Agent \u21BB" - | "PrFetch" -> "PR \u2913" - | "GitFetch" -> "Git \u2913" - | other -> other - -let private lastSepIndex (s: string) = - max (s.LastIndexOf('/')) (s.LastIndexOf('\\')) - -let commonPathPrefix (paths: string list) = - match paths with - | [] -> "" - | [ single ] -> - match lastSepIndex single with - | -1 -> "" - | i -> single[..i] - | first :: rest -> - let prefixLen = - rest |> List.fold (fun len path -> - let maxLen = min len path.Length - let rec findMismatch i = - if i >= maxLen then maxLen - elif System.Char.ToLowerInvariant first[i] = System.Char.ToLowerInvariant path[i] then findMismatch (i + 1) - else i - findMismatch 0) first.Length - let prefix = first[..prefixLen - 1] - match lastSepIndex prefix with - | -1 -> "" - | i -> prefix[..i] - -let stripPrefix (prefix: string) (target: string) = - if prefix.Length > 0 && target.Length >= prefix.Length - && target[..prefix.Length - 1].ToLowerInvariant() = prefix.ToLowerInvariant() - then target[prefix.Length..] - else target - -let statusOverviewRow (prefix: string) (latestBySource: Map) (category: string) = - let label = categoryDisplayName category - match Map.tryFind category latestBySource with - | None -> - Html.div [ - prop.className "status-row pending" - prop.children [ - Html.span [ prop.className "status-category"; prop.text label ] - Html.span [ prop.className "status-target" ] - Html.span [ prop.className "status-duration" ] - Html.span [ prop.className "status-time" ] - Html.span [ prop.className "status-badge pending"; prop.text "pending" ] - ] - ] - | Some evt -> - let target = extractBranchName evt.Message |> Option.defaultValue "" |> stripPrefix prefix - Html.div [ - prop.className "status-row" - prop.children [ - Html.span [ prop.className "status-category"; prop.text label ] - Html.span [ prop.className "status-target"; prop.text target ] - match evt.Duration with - | Some d -> Html.span [ prop.className "status-duration"; prop.text $"%.1f{d.TotalSeconds}s" ] - | None -> Html.span [ prop.className "status-duration" ] - Html.span [ prop.className "status-time"; prop.text (relativeEventTime evt.Timestamp) ] - match evt.Status with - | Some _ -> - Html.span [ - prop.className (stepStatusClassName evt.Status) - prop.text (stepStatusText evt.Status) - ] - | None -> Html.none - ] - ] - -let pinnedErrorEntry (prefix: string) (evt: CardEvent) = - Html.div [ - prop.className "event-entry pinned-error" - prop.children [ - Html.span [ prop.className "event-time"; prop.text (relativeEventTime evt.Timestamp) ] - Html.span [ prop.className "event-source"; prop.text evt.Source ] - Html.span [ prop.className "event-message"; prop.text (stripPrefix prefix evt.Message) ] - match evt.Status with - | Some _ -> - Html.span [ - prop.className (stepStatusClassName evt.Status) - prop.text (stepStatusText evt.Status) - ] - | None -> Html.none - ] - ] - -let schedulerFooter (repos: RepoModel list) (events: CardEvent list) (latestByCategory: Map) = - let prefix = repos |> List.map (fun r -> RepoId.value r.RepoId) |> commonPathPrefix - let errors = pinnedErrors events - Html.div [ - prop.className "scheduler-footer" - prop.children [ - match errors with - | [] -> Html.none - | errs -> - Html.div [ - prop.className "pinned-errors" - prop.children (errs |> List.map (pinnedErrorEntry prefix)) - ] - Html.div [ - prop.className "status-overview" - prop.children (knownCategories |> List.map (statusOverviewRow prefix latestByCategory)) - ] - ] - ] - -let abbreviatePipelineName (repoName: string) (name: string) = - let stripped = - if name.Length >= repoName.Length && name.StartsWith(repoName, System.StringComparison.OrdinalIgnoreCase) - then name[repoName.Length..].TrimStart() - else name - if stripped.EndsWith(" - pr", System.StringComparison.OrdinalIgnoreCase) - then stripped[..stripped.Length-6].TrimEnd() - else stripped - -let buildBadge (repoName: string) (build: BuildInfo) = - let statusText = - match build.Status with - | Building -> "Building" - | Succeeded -> "Passed" - | Failed -> "Failed" - | PartiallySucceeded -> "Partial" - | Canceled -> "Canceled" - let abbreviated = abbreviatePipelineName repoName build.Name - let text = - match build.Failure with - | Some f -> $"{f.StepName}: {statusText}" - | None -> if abbreviated = "" then statusText else $"{abbreviated}: {statusText}" - let className = - match build.Status with - | Building -> "build-badge building" - | Succeeded -> "build-badge succeeded" - | Failed -> "build-badge failed" - | PartiallySucceeded -> "build-badge partial" - | Canceled -> "build-badge canceled" - let tooltip = - match build.Failure with - | Some f when f.Log.Length > 0 -> Some f.Log - | _ -> None - match build.Url with - | Some url -> - Interop.createElement "a" [ - prop.className className - prop.text text - prop.href url - prop.target "_blank" - match tooltip with - | Some t -> prop.title t - | None -> () - ] - | None -> - Html.span [ - prop.className className - prop.text text - match tooltip with - | Some t -> prop.title t - | None -> () - ] - -let terminalButton dispatch (wt: WorktreeStatus) = - let action = if wt.HasActiveSession then FocusSession wt.Path else OpenTerminal wt.Path - let title = if wt.HasActiveSession then "Focus session window (Enter)" else "Open terminal (Enter)" - Html.button [ - prop.className "terminal-btn" - prop.title title - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch action) - prop.text ">" - ] - -let editorIcon () = - Svg.svg [ - svg.className "btn-icon" - svg.viewBox (0, 0, 16, 16) - svg.fill "currentColor" - svg.children [ - Svg.path [ svg.d "M5.002 10L12 3l2 2-7 7H5z" ] - Svg.path [ svg.d "M1.094 0C.525 0 0 .503 0 1.063v13.874C0 15.498.525 16 1.094 16h10.812c.558 0 1.074-.485 1.094-1.031V8l-2 2v4H2V2h5l2 2 1.531-1.531L8.344.344A1.12 1.12 0 007.563 0z" ] - Svg.path [ svg.d "M14.19 1.011a.513.513 0 00-.364.152l-1.162 1.16 2.004 2.005 1.163-1.162a.514.514 0 000-.728l-1.277-1.275a.514.514 0 00-.364-.152z" ] - ] - ] - -let editorButton dispatch editorName (wt: WorktreeStatus) = - Html.button [ - prop.className "editor-btn" - prop.title $"Open in {editorName} (E)" - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (OpenEditor wt.Path)) - prop.children [ editorIcon () ] - ] - -let newTabButton dispatch (wt: WorktreeStatus) = - Html.button [ - prop.className "new-tab-btn" - prop.title "Open new tab in tracked window (+)" - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (OpenNewTab wt.Path)) - prop.text "+" - ] - -let resumeIcon () = - Svg.svg [ - svg.className "btn-icon" - svg.viewBox (0, 0, 48, 48) - svg.fill "currentColor" - svg.children [ - Svg.path [ svg.d "M25.6,25.6,22.2,29,19,25.8l3.4-3.4a2,2,0,0,0-2.8-2.8L16.2,23l-1.3-1.3a1.9,1.9,0,0,0-2.8,0l-3,3a9.8,9.8,0,0,0-3,7,9.1,9.1,0,0,0,1.8,5.6L4.6,40.6a1.9,1.9,0,0,0,0,2.8,1.9,1.9,0,0,0,2.8,0l3.2-3.2a10.1,10.1,0,0,0,5.9,1.9,10.2,10.2,0,0,0,7.1-2.9l3-3a2,2,0,0,0,.6-1.4,1.7,1.7,0,0,0-.6-1.4L25,31.8l3.4-3.4a2,2,0,0,0-2.8-2.8Z" ] - Svg.path [ svg.d "M43.4,4.6a1.9,1.9,0,0,0-2.8,0L37.2,8a10,10,0,0,0-13,.9l-3,3a2,2,0,0,0-.6,1.4,1.7,1.7,0,0,0,.6,1.4L32.9,26.4a1.9,1.9,0,0,0,2.8,0l3-2.9a9.9,9.9,0,0,0,2.9-7.1A10.4,10.4,0,0,0,40,10.9l3.4-3.5A1.9,1.9,0,0,0,43.4,4.6Z" ] - ] - ] - -let resumeButton dispatch (wt: WorktreeStatus) = - Html.button [ - prop.className "resume-btn" - prop.title "Resume last session (R)" - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (ResumeSession wt.Path)) - prop.children [ resumeIcon () ] - ] - -let binIcon () = - Svg.svg [ - svg.className "btn-icon" - svg.viewBox (0, 0, 24, 24) - svg.fill "none" - svg.stroke "currentColor" - svg.custom ("strokeWidth", "1.5") - svg.custom ("strokeLinecap", "round") - svg.children [ - Svg.path [ svg.d "M20.5001 6H3.5" ] - Svg.path [ svg.d "M9.5 11L10 16" ] - Svg.path [ svg.d "M14.5 11L14 16" ] - Svg.path [ - svg.d "M6.5 6C6.55588 6 6.58382 6 6.60915 5.99936C7.43259 5.97849 8.15902 5.45491 8.43922 4.68032C8.44784 4.65649 8.45667 4.62999 8.47434 4.57697L8.57143 4.28571C8.65431 4.03708 8.69575 3.91276 8.75071 3.8072C8.97001 3.38607 9.37574 3.09364 9.84461 3.01877C9.96213 3 10.0932 3 10.3553 3H13.6447C13.9068 3 14.0379 3 14.1554 3.01877C14.6243 3.09364 15.03 3.38607 15.2493 3.8072C15.3043 3.91276 15.3457 4.03708 15.4286 4.28571L15.5257 4.57697C15.5433 4.62992 15.5522 4.65651 15.5608 4.68032C15.841 5.45491 16.5674 5.97849 17.3909 5.99936C17.4162 6 17.4441 6 17.5 6" - svg.custom ("strokeLinecap", "butt") - ] - Svg.path [ svg.d "M18.3735 15.3991C18.1965 18.054 18.108 19.3815 17.243 20.1907C16.378 21 15.0476 21 12.3868 21H11.6134C8.9526 21 7.6222 21 6.75719 20.1907C5.89218 19.3815 5.80368 18.054 5.62669 15.3991L5.16675 8.5M18.8334 8.5L18.6334 11.5" ] - ] - ] - -let deleteButton dispatch scopedKey (wt: WorktreeStatus) = - Html.button [ - prop.className "delete-btn" - prop.title "Remove worktree (Del)" - yield! noFocusProps - prop.onClick (fun e -> - e.stopPropagation() - dispatch (ConfirmDeleteWorktree scopedKey)) - prop.children [ binIcon () ] - ] - -let archiveButton dispatch scopedKey (wt: WorktreeStatus) = - Html.button [ - prop.className "archive-btn" - prop.title "Archive worktree (A)" - yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (ConfirmArchiveWorktree scopedKey)) - prop.children [ ArchiveViews.archiveIcon ] - ] - -let conflictIcon () = - Svg.svg [ - svg.className "conflict-icon" - svg.viewBox (0, 0, 1920, 1920) - svg.custom ("role", "img") - svg.children [ - Svg.title "Merge conflicts" - Svg.path [ - svg.d "m1359.36 1279.51-79.85 79.85L960 1039.85l-319.398 319.51-79.85-79.85L880.152 960 560.753 640.602l79.85-79.85L960 880.152l319.51-319.398 79.85 79.85L1039.85 960l319.51 319.51ZM960 0C430.645 0 0 430.645 0 960s430.645 960 960 960 960-430.645 960-960S1489.355 0 960 0Z" - svg.custom ("fillRule", "evenodd") - ] - ] - ] - -let prActionButton dispatch (cooldowns: Set) (wt: WorktreeStatus) (action: ActionKind) (title: string) (icon: ReactElement) = - let onCooldown = cooldowns.Contains wt.Path - Html.button [ - prop.className (if onCooldown then "action-btn disabled" else "action-btn") - prop.disabled onCooldown - yield! noFocusProps - prop.title (if onCooldown then "Action already triggered" else title) - prop.onClick (fun e -> e.stopPropagation(); if not onCooldown then dispatch (LaunchAction (wt.Path, action))) - prop.children [ icon ] - ] - -let prBadgeContent dispatch (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) (pr: PrInfo) = - React.fragment [ - if pr.IsMerged then - Interop.createElement "a" [ - prop.className "pr-badge merged" - prop.title pr.Title - prop.href pr.Url - prop.target "_blank" - prop.text "Merged" - ] - else - Interop.createElement "a" [ - prop.className (if pr.IsDraft then "pr-badge draft" else "pr-badge") - prop.title pr.Title - prop.href pr.Url - prop.target "_blank" - prop.children [ - Html.text $"PR #{pr.Id}" - if pr.HasConflicts then conflictIcon () - ] - ] - match pr.Comments with - | WithResolution (unresolved, total) when total > 0 -> - Html.span [ - prop.className (if unresolved = 0 then "thread-badge dimmed" else "thread-badge") - prop.text ($"{unresolved}/{total} threads") - ] - if unresolved > 0 then - prActionButton dispatch cooldowns wt (FixPr pr.Url) "Fix PR comments" commentIcon - | _ -> () - yield! pr.Builds |> List.collect (fun build -> [ - buildBadge repoName build - if build.Status = Failed then - match build.Url with - | Some url -> prActionButton dispatch cooldowns wt (FixBuild url) "Fix build" wrenchIcon - | None -> () - ]) - ] - -let prSection dispatch (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = - match wt.Pr with - | NoPr -> Html.none - | HasPr pr -> prBadgeContent dispatch cooldowns wt repoName pr - -let prRow dispatch (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = - match wt.Pr, wt.Branch with - | NoPr, ("main" | "master") -> Html.none - | NoPr, _ -> - Html.div [ - prop.className "pr-row" - prop.children [ - prActionButton dispatch cooldowns wt CreatePr "Create PR" createPrIcon - ] - ] - | HasPr pr, _ -> - Html.div [ - prop.className "pr-row" - prop.children [ prBadgeContent dispatch cooldowns wt repoName pr ] - ] - -let workMetricsView = Components.workMetricsView -let workMetricsItems = Components.workMetricsItems -let FitOrHide = Components.FitOrHide -let cardTitle = Components.cardTitle - -let compactWorktreeCard dispatch editorName (repoName: string) (baseBranch: string) (cooldowns: Set) (scopedKey: string) (isFocused: bool) (wt: WorktreeStatus) = - let baseClass = cardClassName wt + " compact" - let className = if isFocused then baseClass + " focused" else baseClass - Html.div [ - prop.key (WorktreePath.value wt.Path) - prop.className className - prop.onClick (fun _ -> dispatch (SetFocus (Some (Card scopedKey)))) - prop.children [ - Html.div [ - prop.className "card-header" - prop.children [ - Html.div [ - prop.className "header-info" - prop.children [ - Html.span [ prop.className ($"ct-dot {ctClassName wt.CodingTool}"); prop.title (ctTooltip wt.CodingTool) ] - Html.span [ prop.className "branch-name"; prop.text (cardTitle wt) ] - FitOrHide (workMetricsItems wt.WorkMetrics) - ] - ] - Html.span [ prop.className "commit-time"; prop.text (relativeTime System.DateTimeOffset.Now wt.LastCommitTime) ] - terminalButton dispatch wt - if wt.HasActiveSession then newTabButton dispatch wt - if canResumeSession wt then resumeButton dispatch wt - editorButton dispatch editorName wt - archiveButton dispatch scopedKey wt - if not wt.IsMainWorktree then deleteButton dispatch scopedKey wt - ] - ] - Html.div [ - prop.className "compact-detail" - prop.children [ - if beadsTotal wt.Beads > 0 then beadsCounts "beads-inline" wt.Beads - mainBehindIndicator baseBranch wt.MainBehindCount - prSection dispatch cooldowns wt repoName - ] - ] - ] - ] - -let worktreeCard dispatch editorName (repoName: string) (baseBranch: string) (cooldowns: Set) (branchEvents: CardEvent list) (canvasEvents: CanvasEvent list) (canvasPaneOpen: bool) (isPending: bool) (scopedKey: string) (isFocused: bool) (wt: WorktreeStatus) = - let baseClass = cardClassName wt - let className = if isFocused then baseClass + " focused" else baseClass - let hasContent = wt.LastUserMessage.IsSome || (not (List.isEmpty branchEvents)) || (not (List.isEmpty canvasEvents)) - let footerClass = if hasContent then "card-footer has-content" else "card-footer" - Html.div [ - prop.key (WorktreePath.value wt.Path) - prop.className className - prop.onClick (fun _ -> dispatch (SetFocus (Some (Card scopedKey)))) - prop.children [ - Html.div [ - prop.className "card-body" - prop.children [ - Html.div [ - prop.className "card-header" - prop.children [ - Html.div [ - prop.className "header-info" - prop.children [ - Html.span [ prop.className ($"ct-dot {ctClassName wt.CodingTool}"); prop.title (ctTooltip wt.CodingTool) ] - Html.span [ prop.className "branch-name"; prop.text (cardTitle wt) ] - FitOrHide (workMetricsItems wt.WorkMetrics) - ] - ] - terminalButton dispatch wt - if wt.HasActiveSession then newTabButton dispatch wt - if canResumeSession wt then resumeButton dispatch wt - editorButton dispatch editorName wt - archiveButton dispatch scopedKey wt - if not wt.IsMainWorktree then deleteButton dispatch scopedKey wt - ] - ] - - if beadsTotal wt.Beads > 0 then - Html.div [ - prop.className "beads-row" - prop.children [ - beadsCounts "beads-counts" wt.Beads - beadsProgressBar wt.Beads - ] - ] - - mainBehindWithSync dispatch baseBranch wt branchEvents isPending scopedKey - - prRow dispatch cooldowns wt repoName - ] - ] - - Html.div [ - prop.className footerClass - prop.children [ - if List.isEmpty canvasEvents then - match wt.LastUserMessage with - | Some (prompt, ts) -> - Html.div [ - prop.className "user-prompt" - prop.children [ - Html.span [ prop.className "event-time"; prop.text (relativeEventTime ts) ] - Html.span [ prop.text prompt ] - ] - ] - | None -> () - - eventLog dispatch cooldowns wt.Path wt.HasTestFailureLog branchEvents - canvasEventLog dispatch scopedKey canvasEvents - ] - ] - ] - ] - -let renderCard dispatch editorName isCompact (focusedElement: FocusTarget option) repoId repoName baseBranch (branchEvents: Map) (syncPending: Set) (cooldowns: Set) (canvasEvents: Map) (canvasPaneOpen: bool) (wt: WorktreeStatus) = - let scopedKey = WorktreePath.value wt.Path - let events = branchEvents |> Map.tryFind scopedKey |> Option.defaultValue [] - let cvEvents = canvasEvents |> Map.tryFind scopedKey |> Option.defaultValue [] - let isPending = syncPending |> Set.contains scopedKey - let isFocused = focusedElement = Some (Card scopedKey) - if isCompact then compactWorktreeCard dispatch editorName repoName baseBranch cooldowns scopedKey isFocused wt - else worktreeCard dispatch editorName repoName baseBranch cooldowns events cvEvents canvasPaneOpen isPending scopedKey isFocused wt - -let archiveSection dispatch = ArchiveViews.archiveSection (ArchiveMsg >> dispatch) - -let skeletonCard () = - Html.div [ - prop.className "wt-card skeleton" - prop.children [ - Html.div [ - prop.className "card-header" - prop.children [ - Html.span [ prop.className "skeleton-dot" ] - Html.span [ prop.className "skeleton-bar skeleton-branch" ] - ] - ] - Html.div [ prop.className "skeleton-bar skeleton-commit" ] - Html.div [ prop.className "skeleton-bar skeleton-beads" ] - ] - ] - -let skeletonGrid () = - Html.div [ - prop.className "card-grid" - prop.children (List.init 6 (fun _ -> skeletonCard ())) - ] - -let sortLabel = - function - | ByName -> "A-Z" - | ByActivity -> "Recent" - -let viewEyeOpen (pupilColor: string) (activity: ActivityLevel) (dx: float, dy: float) = - Svg.svg [ - svg.className "eye-logo" - svg.viewBox (-2, -2, 44, 24) - svg.children [ - Svg.path [ - svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 20 20 20 Q10 20 2 10 Z" - svg.fill "#e8e8e8" - svg.stroke "#56b6c2" - svg.strokeWidth 2.5 - ] - Svg.g [ - svg.className "eye-iris" - svg.custom ("transform", $"translate({dx}, {dy})") - svg.children [ - Svg.circle [ - svg.cx 20 - svg.cy 10 - svg.r 9 - svg.fill "#1a1b2e" - ] - Svg.circle [ - svg.cx 20 - svg.cy 10 - svg.r 6 - svg.fill "#56b6c2" - ] - Svg.circle [ - svg.cx 20 - svg.cy 10 - svg.r 3 - svg.fill pupilColor - ] - ] - ] - Svg.circle [ - svg.cx 23 - svg.cy 5 - svg.r 2 - svg.fill "rgba(255, 255, 255, 0.8)" - ] - match activity with - | ActivityLevel.Idle -> - Svg.path [ - svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 4 20 5 Q10 4 2 10 Z" - svg.fill "#b0b0b0" - ] - Svg.path [ - svg.d "M2 10 Q10 4 20 5 Q30 4 38 10" - svg.fill "none" - svg.stroke "#56b6c2" - svg.strokeWidth 2.0 - ] - | ActivityLevel.DeepIdle -> - Svg.path [ - svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 9 20 12 Q10 9 2 10 Z" - svg.fill "#b0b0b0" - ] - Svg.path [ - svg.d "M2 10 Q10 9 20 12 Q30 9 38 10" - svg.fill "none" - svg.stroke "#56b6c2" - svg.strokeWidth 2.0 - ] - | ActivityLevel.Active -> () - ] - ] - -let viewEyeRolledBack () = - Svg.svg [ - svg.className "eye-logo" - svg.viewBox (-2, -2, 44, 24) - svg.children [ - Svg.defs [ - Svg.clipPath [ - svg.id "eye-shape" - svg.children [ - Svg.path [ - svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 20 20 20 Q10 20 2 10 Z" - ] - ] - ] - ] - Svg.path [ - svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 20 20 20 Q10 20 2 10 Z" - svg.fill "#e8e8e8" - svg.stroke "#56b6c2" - svg.strokeWidth 2.5 - ] - Svg.g [ - svg.custom ("clipPath", "url(#eye-shape)") - svg.children [ - Svg.g [ - svg.custom ("transform", "translate(0, -9)") - svg.children [ - Svg.circle [ - svg.cx 20 - svg.cy 10 - svg.r 9 - svg.fill "#1a1b2e" - ] - Svg.circle [ - svg.cx 20 - svg.cy 10 - svg.r 6 - svg.fill "#888" - ] - Svg.circle [ - svg.cx 20 - svg.cy 10 - svg.r 3 - svg.fill "#1a1b2e" - ] - ] - ] - ] - ] - Svg.circle [ - svg.cx 23 - svg.cy 5 - svg.r 2 - svg.fill "rgba(255, 255, 255, 0.8)" - ] - ] - ] - -let viewEyeClosed () = - Svg.svg [ - svg.className "eye-logo eye-closed" - svg.viewBox (-2, -2, 44, 24) - svg.children [ - Svg.path [ - svg.d "M2 10 Q10 4 20 4 Q30 4 38 10 Q30 16 20 16 Q10 16 2 10 Z" - svg.fill "#e8e8e8" - svg.stroke "#56b6c2" - svg.strokeWidth 2.5 - ] - Svg.line [ - svg.x1 4 - svg.y1 10 - svg.x2 36 - svg.y2 10 - svg.stroke "#56b6c2" - svg.strokeWidth 2.0 - ] - ] - ] - let hasAnyActive (repos: RepoModel list) = repos |> List.exists (fun r -> r.Worktrees |> List.exists (fun wt -> @@ -1531,85 +571,6 @@ let anyRepoReady (repos: RepoModel list) = let allWorktreesEmpty (repos: RepoModel list) = repos |> List.forall _.Worktrees.IsEmpty -let providerIcon (provider: RepoProvider option) = - let icon viewBox (svgPath: string) = - Svg.svg [ - svg.className "provider-icon" - svg.viewBox viewBox - svg.children [ Svg.path [ svg.d svgPath; svg.fill "currentColor" ] ] - ] - - let githubPath = "M12 .297c-6.63 0-12 5.373-12 12 0 5.303 3.438 9.8 8.205 11.385.6.113.82-.258.82-.577 0-.285-.01-1.04-.015-2.04-3.338.724-4.042-1.61-4.042-1.61C4.422 18.07 3.633 17.7 3.633 17.7c-1.087-.744.084-.729.084-.729 1.205.084 1.838 1.236 1.838 1.236 1.07 1.835 2.809 1.305 3.495.998.108-.776.417-1.305.76-1.605-2.665-.3-5.466-1.332-5.466-5.93 0-1.31.465-2.38 1.235-3.22-.135-.303-.54-1.523.105-3.176 0 0 1.005-.322 3.3 1.23.96-.267 1.98-.399 3-.405 1.02.006 2.04.138 3 .405 2.28-1.552 3.285-1.23 3.285-1.23.645 1.653.24 2.873.12 3.176.765.84 1.23 1.91 1.23 3.22 0 4.61-2.805 5.625-5.475 5.92.42.36.81 1.096.81 2.22 0 1.606-.015 2.896-.015 3.286 0 .315.21.69.825.57C20.565 22.092 24 17.592 24 12.297c0-6.627-5.373-12-12-12" - let azdoPath = "M17 4v9.74l-4 3.28-6.2-2.26V17l-3.51-4.59 10.23.8V4.44zm-3.41.49L7.85 1v2.29L2.58 4.84 1 6.87v4.61l2.26 1V6.57z" - - match provider with - | None | Some UnknownProvider -> Html.none - | Some(GitHubProvider url) -> - Html.a [ - prop.className "provider-link" - prop.href url - prop.target "_blank" - prop.onClick (fun e -> e.stopPropagation()) - prop.children [ icon (0, 0, 24, 24) githubPath ] - ] - | Some(AzDoProvider url) -> - Html.a [ - prop.className "provider-link" - prop.href url - prop.target "_blank" - prop.onClick (fun e -> e.stopPropagation()) - prop.children [ icon (0, 0, 18, 18) azdoPath ] - ] - -let repoSectionHeader dispatch (focusedElement: FocusTarget option) (repo: RepoModel) = - let arrow = if repo.IsCollapsed then "\u25B6" else "\u25BC" - let isFocused = focusedElement = Some (RepoHeader repo.RepoId) - let baseClass = if repo.IsCollapsed then "repo-header collapsed" else "repo-header" - let className = if isFocused then baseClass + " focused" else baseClass - Html.div [ - prop.className className - prop.onClick (fun _ -> dispatch (ToggleCollapse repo.RepoId)) - prop.children [ - Html.span [ prop.className "collapse-arrow"; prop.text arrow ] - Html.span [ prop.className "repo-name"; prop.text repo.Name ] - providerIcon repo.Provider - if repo.BaseBranch <> "main" then - Html.span [ prop.className "deploy-branch"; prop.text repo.BaseBranch ] - if repo.IsCollapsed then - Html.span [ - prop.className "repo-ct-dots" - prop.children ( - repo.Worktrees - |> List.map (fun wt -> - Html.span [ prop.className ($"ct-dot {ctClassName wt.CodingTool}"); prop.title (ctTooltip wt.CodingTool) ])) - ] - Html.button [ - prop.className "create-wt-btn" - prop.title "Create worktree" - prop.onClick (fun e -> e.stopPropagation(); dispatch (ModalMsg (CreateWorktreeModal.OpenCreateWorktree repo.RepoId))) - prop.text "+" - ] - ] - ] - -let repoSection dispatch editorName isCompact (focusedElement: FocusTarget option) (branchEvents: Map) (syncPending: Set) (cooldowns: Set) (canvasEvents: Map) (canvasPaneOpen: bool) (repo: RepoModel) = - Html.div [ - prop.key (RepoId.value repo.RepoId) - prop.className "repo-section" - prop.children [ - repoSectionHeader dispatch focusedElement repo - if not repo.IsCollapsed then - if not repo.IsReady && repo.Worktrees.IsEmpty then - skeletonGrid () - else - Html.div [ - prop.className "card-grid" - prop.children (repo.Worktrees |> List.map (renderCard dispatch editorName isCompact focusedElement (RepoId.value repo.RepoId) repo.Name repo.BaseBranch branchEvents syncPending cooldowns canvasEvents canvasPaneOpen)) - ] - archiveSection dispatch repo.ArchivedWorktrees - ] - ] - let barColor (pct: float) = if pct >= 80.0 then "#f38ba8" elif pct >= 50.0 then "#f9e2af" @@ -1620,14 +581,6 @@ let labelColor (pct: float) = elif pct >= 50.0 then Some "#f9e2af" else None -let focusedWorktreeCanvasDoc (model: Model) = - CanvasUpdate.activeVisibleDoc model - |> Option.bind (fun (scopedKey, filename) -> - findWorktree scopedKey model - |> Option.bind (fun wt -> - wt.CanvasDocs |> List.tryFind (fun d -> d.Filename = filename) - |> Option.map (fun d -> wt, d))) - let viewMetricBar (pct: float) (label: string) = Html.div [ prop.className "metric-bar-row" @@ -1680,11 +633,11 @@ let viewAppHeader model dispatch = Html.div [ prop.className "header-center" prop.children [ - if model.HasError then viewEyeRolledBack () + if model.HasError then MascotView.viewEyeRolledBack () elif hasAnyActive model.Repos then let pupilColor = if hasAnyWaiting model.Repos then "#f9e2af" else "#1a1b2e" - viewEyeOpen pupilColor model.ActivityLevel model.EyeDirection - else viewEyeClosed () + MascotView.viewEyeOpen pupilColor model.Activity.ActivityLevel model.Mascot.EyeDirection + else MascotView.viewEyeClosed () ] ] Html.div [ @@ -1749,6 +702,32 @@ let view model dispatch = | true -> $"app-layout canvas-open {canvasPositionClass}" | false -> "app-layout" + let cardProps: CardViewProps = + { EditorName = model.EditorName + IsCompact = model.IsCompact + FocusedElement = model.FocusedElement + BranchEvents = model.BranchEvents + SyncPending = model.SyncPending + ActionCooldowns = model.ActionCooldowns + CanvasEvents = model.Canvas.CanvasEvents + CanvasPaneOpen = model.Canvas.CanvasPaneOpen } + + let cardCallbacks: CardCallbacks = + { FocusCard = fun key -> dispatch (SetFocus (Some (Card key))) + ToggleRepo = fun repoId -> dispatch (ToggleCollapse repoId) + CreateWorktree = fun repoId -> dispatch (ModalMsg (CreateWorktreeModal.OpenCreateWorktree repoId)) + OpenTerminal = fun wt -> dispatch (if wt.HasActiveSession then FocusSession wt.Path else OpenTerminal wt.Path) + OpenEditor = fun wt -> dispatch (OpenEditor wt.Path) + OpenNewTab = fun wt -> dispatch (OpenNewTab wt.Path) + ResumeSession = fun wt -> dispatch (ResumeSession wt.Path) + DeleteWorktree = fun key -> dispatch (ConfirmDeleteWorktree key) + ArchiveWorktree = fun key -> dispatch (ConfirmArchiveWorktree key) + StartSync = fun path key -> dispatch (StartSync (path, key)) + CancelSync = fun path -> dispatch (CancelSync path) + LaunchAction = fun path action -> dispatch (LaunchAction (path, action)) + OpenCanvasDoc = fun key filename -> dispatch (OpenCanvasDoc (key, filename)) + DispatchArchive = ArchiveMsg >> dispatch } + let dashboardEl = Html.div [ prop.className dashboardClass @@ -1772,63 +751,18 @@ let view model dispatch = else Html.div [ prop.className "repo-list" - prop.children (model.Repos |> List.map (repoSection dispatch model.EditorName model.IsCompact model.FocusedElement model.BranchEvents model.SyncPending model.ActionCooldowns model.Canvas.CanvasEvents model.Canvas.CanvasPaneOpen)) + prop.children (model.Repos |> List.map (repoSection cardProps cardCallbacks)) ] - schedulerFooter model.Repos model.SchedulerEvents model.LatestByCategory + OverviewViews.schedulerFooter model.Repos model.SchedulerEvents model.LatestByCategory CreateWorktreeModal.view (ModalMsg >> dispatch) model.CreateModal ConfirmModal.view (ConfirmMsg >> dispatch) model.ConfirmModal ] ] - let selectCanvasDoc filename = - match model.FocusedElement with - | Some (Card scopedKey) -> dispatch (SelectCanvasDoc (scopedKey, filename)) - | _ -> () - - let onOverviewClick scopedKey = - dispatch (FocusOverviewCard scopedKey) - - let onOverviewDocClick scopedKey filename = - dispatch (OpenCanvasDoc (scopedKey, filename)) - - let archiveCanvasDoc filename = - match model.FocusedElement with - | Some (Card scopedKey) -> dispatch (ArchiveCanvasDoc (scopedKey, filename)) - | _ -> () - - let launchCanvasSession () = - match model.FocusedElement with - | Some (Card scopedKey) -> dispatch (LaunchCanvasSession scopedKey) - | _ -> () - - let focusedUnviewedFilenames = - match model.FocusedElement with - | Some (Card scopedKey) -> - unviewedDocsByScopedKey model.Repos model.Canvas.LastViewedHashes - |> Map.tryFind scopedKey - |> Option.defaultValue [] - |> Set.ofList - | _ -> Set.empty - - let focusedVisitedDocs = - match model.FocusedElement with - | Some (Card scopedKey) -> - model.Canvas.VisitedCanvasDocs |> Map.tryFind scopedKey |> Option.defaultValue [] - | _ -> [] - - let canvasCallbacks: CanvasPane.CanvasPaneCallbacks = - { SetPosition = SetCanvasPosition >> dispatch - SelectDoc = selectCanvasDoc - OnOverviewClick = onOverviewClick - OnOverviewDocClick = onOverviewDocClick - ArchiveDoc = archiveCanvasDoc - DismissError = (fun () -> dispatch DismissCanvasMessageError) - LaunchSession = launchCanvasSession } - let canvasEl = - CanvasPane.view model.Canvas.CanvasPaneOpen model.Canvas.CanvasPosition (focusedWorktreeCanvasDoc model) model.Repos model.Canvas.CanvasSendState model.Canvas.BridgeLiveness focusedUnviewedFilenames focusedVisitedDocs canvasCallbacks + CanvasView.view model dispatch let children = match model.Canvas.CanvasPosition with diff --git a/src/Client/AppTypes.fs b/src/Client/AppTypes.fs index 3ffc40be..d16ee3b0 100644 --- a/src/Client/AppTypes.fs +++ b/src/Client/AppTypes.fs @@ -25,7 +25,6 @@ type Model = SyncPending: Set AppVersion: string option EditorName: string - EyeDirection: float * float FocusedElement: FocusTarget option CreateModal: CreateWorktreeModal.ModalState ConfirmModal: ConfirmModal.ConfirmModal @@ -33,8 +32,8 @@ type Model = DeployBranch: string option SystemMetrics: SystemMetrics option ActionCooldowns: Set - LastActivityTime: float - ActivityLevel: ActivityLevel + Activity: ActivityState.ActivityState + Mascot: MascotState.MascotState Canvas: CanvasState.CanvasState } type Msg = diff --git a/src/Client/CanvasView.fs b/src/Client/CanvasView.fs new file mode 100644 index 00000000..c599af3e --- /dev/null +++ b/src/Client/CanvasView.fs @@ -0,0 +1,76 @@ +module CanvasView + +// The canvas-pane wiring, extracted from `App.fs`'s `view`. Builds the `CanvasPaneCallbacks` +// from `dispatch`, resolves the focused worktree's active doc plus its unviewed/visited slices +// from the model, and calls `CanvasPane.view` to render the pane element. This is the view-layer +// companion to `CanvasUpdate.fs` (whose `activeVisibleDoc` it reuses): pure render wiring, no +// `update` logic. Compiled after `CanvasUpdate.fs` and before `App.fs`, whose `view` now calls +// `CanvasView.view model dispatch` in place of the inlined block. + +open Shared +open Navigation +open Elmish +open CanvasAwareness +open AppTypes + +/// Resolve the focused worktree and its active CanvasDoc (the doc the pane renders). Returns +/// `None` when there is no focused card, no active doc, or the active filename no longer names a +/// real doc of the worktree. +let focusedWorktreeCanvasDoc (model: Model) = + CanvasUpdate.activeVisibleDoc model + |> Option.bind (fun (scopedKey, filename) -> + findWorktree scopedKey model + |> Option.bind (fun wt -> + wt.CanvasDocs |> List.tryFind (fun d -> d.Filename = filename) + |> Option.map (fun d -> wt, d))) + +/// Build the canvas-pane element: derive the focused worktree's doc / unviewed / visited slices +/// from the model, assemble the `CanvasPaneCallbacks` from `dispatch`, and hand them to +/// `CanvasPane.view`. `App.fs`'s `view` calls this for its `canvasEl`. +let view (model: Model) (dispatch: Dispatch) = + let selectCanvasDoc filename = + match model.FocusedElement with + | Some (Card scopedKey) -> dispatch (SelectCanvasDoc (scopedKey, filename)) + | _ -> () + + let onOverviewClick scopedKey = + dispatch (FocusOverviewCard scopedKey) + + let onOverviewDocClick scopedKey filename = + dispatch (OpenCanvasDoc (scopedKey, filename)) + + let archiveCanvasDoc filename = + match model.FocusedElement with + | Some (Card scopedKey) -> dispatch (ArchiveCanvasDoc (scopedKey, filename)) + | _ -> () + + let launchCanvasSession () = + match model.FocusedElement with + | Some (Card scopedKey) -> dispatch (LaunchCanvasSession scopedKey) + | _ -> () + + let focusedUnviewedFilenames = + match model.FocusedElement with + | Some (Card scopedKey) -> + unviewedDocsByScopedKey model.Repos model.Canvas.LastViewedHashes + |> Map.tryFind scopedKey + |> Option.defaultValue [] + |> Set.ofList + | _ -> Set.empty + + let focusedVisitedDocs = + match model.FocusedElement with + | Some (Card scopedKey) -> + model.Canvas.VisitedCanvasDocs |> Map.tryFind scopedKey |> Option.defaultValue [] + | _ -> [] + + let canvasCallbacks: CanvasPane.CanvasPaneCallbacks = + { SetPosition = SetCanvasPosition >> dispatch + SelectDoc = selectCanvasDoc + OnOverviewClick = onOverviewClick + OnOverviewDocClick = onOverviewDocClick + ArchiveDoc = archiveCanvasDoc + DismissError = (fun () -> dispatch DismissCanvasMessageError) + LaunchSession = launchCanvasSession } + + CanvasPane.view model.Canvas.CanvasPaneOpen model.Canvas.CanvasPosition (focusedWorktreeCanvasDoc model) model.Repos model.Canvas.CanvasSendState model.Canvas.BridgeLiveness focusedUnviewedFilenames focusedVisitedDocs canvasCallbacks diff --git a/src/Client/CardViews.fs b/src/Client/CardViews.fs new file mode 100644 index 00000000..fe43b355 --- /dev/null +++ b/src/Client/CardViews.fs @@ -0,0 +1,735 @@ +module CardViews + +open Shared +open Shared.EventUtils +open Navigation +open Feliz +open Components +open ActionButtons +open CanvasAwareness + +let ctClassName = + function + | Working -> "working" + | WaitingForUser -> "waiting" + | Done -> "done" + | Idle -> "idle" + +let ctTooltip = + function + | Working -> "Working" + | WaitingForUser -> "Waiting for user" + | Done -> "Done" + | Idle -> "Idle" + +let isMerged (wt: WorktreeStatus) = + match wt.Pr with + | HasPr pr -> pr.IsMerged + | NoPr -> false + +let cardClassName (wt: WorktreeStatus) = + let ct = ctClassName wt.CodingTool + let session = if wt.HasActiveSession then " has-session" else "" + if isMerged wt then $"wt-card ct-{ct} merged{session}" else $"wt-card ct-{ct}{session}" + +let beadsTotal (b: BeadsSummary) = b.Open + b.InProgress + b.Blocked + b.Closed + +let segmentPct count total = + match total with + | 0 -> 0.0 + | _ -> (float count * 100.0) / float total + +let beadsCounts (className: string) (b: BeadsSummary) = + Html.span [ + prop.className className + prop.children [ + Html.span [ prop.className "beads-open"; prop.text (string b.Open) ] + Html.span [ prop.className "beads-sep"; prop.text "/" ] + Html.span [ prop.className "beads-inprogress"; prop.text (string b.InProgress) ] + Html.span [ prop.className "beads-sep"; prop.text "/" ] + Html.span [ prop.className "beads-blocked"; prop.text (string b.Blocked) ] + Html.span [ prop.className "beads-sep"; prop.text "/" ] + Html.span [ prop.className "beads-closed"; prop.text (string b.Closed) ] + ] + ] + +let beadsProgressBar (b: BeadsSummary) = + let total = beadsTotal b + Html.div [ + prop.className "progress-bar" + prop.children [ + Html.div [ + prop.className "progress-segment seg-open" + prop.style [ style.width (length.percent (segmentPct b.Open total)) ] + ] + Html.div [ + prop.className "progress-segment seg-inprogress" + prop.style [ style.width (length.percent (segmentPct b.InProgress total)) ] + ] + Html.div [ + prop.className "progress-segment seg-blocked" + prop.style [ style.width (length.percent (segmentPct b.Blocked total)) ] + ] + Html.div [ + prop.className "progress-segment seg-closed" + prop.style [ style.width (length.percent (segmentPct b.Closed total)) ] + ] + ] + ] + +/// The model read-slice the card views render over. Bundles the eight values that were +/// previously threaded as loose positional args through repoSection/renderCard/worktreeCard +/// (repoSection alone took nine), so a silent argument transposition can no longer compile. +/// References only Shared/Navigation/CanvasAwareness types — no Model/Msg dependency — so this +/// record can later move ahead of AppTypes alongside the card views. +type CardViewProps = + { EditorName: string + IsCompact: bool + FocusedElement: FocusTarget option + BranchEvents: Map + SyncPending: Set + ActionCooldowns: Set + CanvasEvents: Map + /// Currently unread by the card views; kept as part of the model read-slice — it + /// formalizes the previously dead `canvasPaneOpen` arg that was threaded through renderCard. + CanvasPaneOpen: bool } + +/// The dispatch-derived actions the card views raise back to the host, mirroring +/// CanvasPaneCallbacks. Every field is a plain `… -> unit` function — no Msg dependency — so the +/// card views invoke named card actions instead of holding raw `dispatch`, and App.fs builds the +/// record from `dispatch` in `view`. This is a strictly narrower capability than the old +/// `dispatch` (which could send any Msg); leaf helpers take this whole record in its place. +type CardCallbacks = + { FocusCard: string -> unit + ToggleRepo: RepoId -> unit + CreateWorktree: RepoId -> unit + /// Primary terminal action: focuses the active session when one exists, else opens a terminal. + /// Intent-named (not a 1:1 Msg mirror) — do not "simplify" to always dispatch OpenTerminal. + OpenTerminal: WorktreeStatus -> unit + OpenEditor: WorktreeStatus -> unit + OpenNewTab: WorktreeStatus -> unit + ResumeSession: WorktreeStatus -> unit + /// Raises the delete *confirmation* (ConfirmDeleteWorktree), not an immediate delete. + DeleteWorktree: string -> unit + /// Raises the archive *confirmation* (ConfirmArchiveWorktree), not an immediate archive. + ArchiveWorktree: string -> unit + StartSync: WorktreePath -> string -> unit + CancelSync: WorktreePath -> unit + LaunchAction: WorktreePath -> ActionKind -> unit + OpenCanvasDoc: string -> string -> unit + DispatchArchive: ArchiveViews.Msg -> unit } + +let mainBehindIndicator (baseBranch: string) (count: int) = + if count = 0 then + Html.span [ + prop.className "main-behind up-to-date" + prop.text "up to date" + ] + else + Html.span [ + prop.className (if count > 20 then "main-behind behind-warning" else "main-behind") + prop.text ($"{count} behind {baseBranch}") + ] + +let isBranchSyncing (events: CardEvent list) = + events |> List.exists (fun e -> e.Status = Some StepStatus.Running) + +let private providerDisplayName (provider: CodingToolProvider option) = + match provider with + | Some Claude -> "Claude" + | Some Copilot -> "Copilot" + | None -> "Coding tool" + +let syncButton (callbacks: CardCallbacks) (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = + if isPending then + Html.button [ + prop.className "sync-starting-btn" + prop.disabled true + yield! noFocusProps + prop.text "Sync starting" + ] + else + let syncing = isBranchSyncing branchEvents + let codingToolBusy = wt.CodingTool = Working || wt.CodingTool = WaitingForUser + let disabled = syncing || codingToolBusy + if syncing then + Html.button [ + prop.className "sync-cancel-btn" + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.CancelSync wt.Path) + prop.text "Cancel" + ] + else + Html.button [ + prop.className (if disabled then "sync-btn disabled" else "sync-btn") + prop.disabled disabled + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.StartSync wt.Path scopedKey) + prop.title (if codingToolBusy then $"{providerDisplayName wt.CodingToolProvider} is active" else $"Sync with {baseBranch} (S)") + prop.text "Sync" + ] + +let mainBehindWithSync (callbacks: CardCallbacks) (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = + Html.div [ + prop.className "main-behind-row" + prop.children [ + mainBehindIndicator baseBranch wt.MainBehindCount + if wt.MainBehindCount > 0 then + if wt.IsDirty then + Html.span [ + prop.className "dirty-warning" + prop.text "uncommitted changes" + ] + else syncButton callbacks baseBranch wt branchEvents isPending scopedKey + Html.span [ + prop.className "git-commit-msg" + prop.children [ + Html.text wt.LastCommitMessage + Html.span [ prop.className "commit-time"; prop.text (relativeTime System.DateTimeOffset.Now wt.LastCommitTime) ] + ] + ] + ] + ] + +let eventLogEntry (onFixTests: (unit -> unit) option) (onConfigureTests: (unit -> unit) option) (evt: CardEvent) = + let isTestFailure = + evt.Source = EventSource.Test && (match evt.Status with Some (StepStatus.Failed _) -> true | _ -> false) + let isTestNotConfigured = + evt.Source = EventSource.Test && evt.Status = Some StepStatus.NotConfigured + let isClickable = (isTestFailure && onFixTests.IsSome) || (isTestNotConfigured && onConfigureTests.IsSome) + Html.div [ + prop.className "event-entry" + prop.children [ + Html.span [ prop.className "event-time"; prop.text (relativeEventTime evt.Timestamp) ] + Html.span [ prop.className "event-source"; prop.text evt.Source ] + Html.span [ prop.className "event-message"; prop.text evt.Message ] + match evt.Status with + | Some _ -> + Html.span [ + prop.className ( + if isClickable + then stepStatusClassName evt.Status + " clickable" + else stepStatusClassName evt.Status) + prop.text (stepStatusText evt.Status) + if isTestFailure then + match onFixTests with + | Some handler -> + prop.title "Click to fix with coding tool" + prop.onClick (fun e -> e.stopPropagation(); handler()) + | None -> () + elif isTestNotConfigured then + match onConfigureTests with + | Some handler -> + prop.title "Click to configure test command" + prop.onClick (fun e -> e.stopPropagation(); handler()) + | None -> () + ] + | None -> Html.none + ] + ] + +let eventLog (callbacks: CardCallbacks) (cooldowns: Set) (wtPath: WorktreePath) (hasTestFailureLog: bool) (events: CardEvent list) = + match events with + | [] -> Html.none + | evts -> + let onFixTests = + if not hasTestFailureLog || cooldowns.Contains wtPath then None + else Some (fun () -> callbacks.LaunchAction wtPath FixTests) + let onConfigureTests = + if cooldowns.Contains wtPath then None + else Some (fun () -> callbacks.LaunchAction wtPath ConfigureTests) + Html.div [ + prop.className "event-log" + prop.children (evts |> List.map (eventLogEntry onFixTests onConfigureTests)) + ] + +let canvasEventEntry (callbacks: CardCallbacks) (scopedKey: string) (evt: CanvasEvent) = + let verb = match evt.Kind with NewDoc -> "published" | UpdatedDoc -> "updated" + Html.div [ + prop.className "event-entry canvas-event" + prop.onClick (fun e -> + e.stopPropagation() + callbacks.OpenCanvasDoc scopedKey evt.Filename) + prop.children [ + Html.span [ prop.className "event-time"; prop.text (relativeEventTime evt.Timestamp) ] + Html.span [ prop.className "event-message"; prop.text $"{verb} " ] + Html.span [ prop.className "event-source"; prop.text evt.Filename ] + ] + ] + +let canvasEventLog (callbacks: CardCallbacks) (scopedKey: string) (events: CanvasEvent list) = + match events with + | [] -> Html.none + | evts -> + Html.div [ + prop.className "event-log" + prop.children (evts |> List.map (canvasEventEntry callbacks scopedKey)) + ] + +let abbreviatePipelineName (repoName: string) (name: string) = + let stripped = + if name.Length >= repoName.Length && name.StartsWith(repoName, System.StringComparison.OrdinalIgnoreCase) + then name[repoName.Length..].TrimStart() + else name + if stripped.EndsWith(" - pr", System.StringComparison.OrdinalIgnoreCase) + then stripped[..stripped.Length-6].TrimEnd() + else stripped + +let buildBadge (repoName: string) (build: BuildInfo) = + let statusText = + match build.Status with + | Building -> "Building" + | Succeeded -> "Passed" + | Failed -> "Failed" + | PartiallySucceeded -> "Partial" + | Canceled -> "Canceled" + let abbreviated = abbreviatePipelineName repoName build.Name + let text = + match build.Failure with + | Some f -> $"{f.StepName}: {statusText}" + | None -> if abbreviated = "" then statusText else $"{abbreviated}: {statusText}" + let className = + match build.Status with + | Building -> "build-badge building" + | Succeeded -> "build-badge succeeded" + | Failed -> "build-badge failed" + | PartiallySucceeded -> "build-badge partial" + | Canceled -> "build-badge canceled" + let tooltip = + match build.Failure with + | Some f when f.Log.Length > 0 -> Some f.Log + | _ -> None + match build.Url with + | Some url -> + Interop.createElement "a" [ + prop.className className + prop.text text + prop.href url + prop.target "_blank" + match tooltip with + | Some t -> prop.title t + | None -> () + ] + | None -> + Html.span [ + prop.className className + prop.text text + match tooltip with + | Some t -> prop.title t + | None -> () + ] + +let terminalButton (callbacks: CardCallbacks) (wt: WorktreeStatus) = + let title = if wt.HasActiveSession then "Focus session window (Enter)" else "Open terminal (Enter)" + Html.button [ + prop.className "terminal-btn" + prop.title title + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.OpenTerminal wt) + prop.text ">" + ] + +let editorIcon () = + Svg.svg [ + svg.className "btn-icon" + svg.viewBox (0, 0, 16, 16) + svg.fill "currentColor" + svg.children [ + Svg.path [ svg.d "M5.002 10L12 3l2 2-7 7H5z" ] + Svg.path [ svg.d "M1.094 0C.525 0 0 .503 0 1.063v13.874C0 15.498.525 16 1.094 16h10.812c.558 0 1.074-.485 1.094-1.031V8l-2 2v4H2V2h5l2 2 1.531-1.531L8.344.344A1.12 1.12 0 007.563 0z" ] + Svg.path [ svg.d "M14.19 1.011a.513.513 0 00-.364.152l-1.162 1.16 2.004 2.005 1.163-1.162a.514.514 0 000-.728l-1.277-1.275a.514.514 0 00-.364-.152z" ] + ] + ] + +let editorButton (callbacks: CardCallbacks) editorName (wt: WorktreeStatus) = + Html.button [ + prop.className "editor-btn" + prop.title $"Open in {editorName} (E)" + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.OpenEditor wt) + prop.children [ editorIcon () ] + ] + +let newTabButton (callbacks: CardCallbacks) (wt: WorktreeStatus) = + Html.button [ + prop.className "new-tab-btn" + prop.title "Open new tab in tracked window (+)" + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.OpenNewTab wt) + prop.text "+" + ] + +let resumeIcon () = + Svg.svg [ + svg.className "btn-icon" + svg.viewBox (0, 0, 48, 48) + svg.fill "currentColor" + svg.children [ + Svg.path [ svg.d "M25.6,25.6,22.2,29,19,25.8l3.4-3.4a2,2,0,0,0-2.8-2.8L16.2,23l-1.3-1.3a1.9,1.9,0,0,0-2.8,0l-3,3a9.8,9.8,0,0,0-3,7,9.1,9.1,0,0,0,1.8,5.6L4.6,40.6a1.9,1.9,0,0,0,0,2.8,1.9,1.9,0,0,0,2.8,0l3.2-3.2a10.1,10.1,0,0,0,5.9,1.9,10.2,10.2,0,0,0,7.1-2.9l3-3a2,2,0,0,0,.6-1.4,1.7,1.7,0,0,0-.6-1.4L25,31.8l3.4-3.4a2,2,0,0,0-2.8-2.8Z" ] + Svg.path [ svg.d "M43.4,4.6a1.9,1.9,0,0,0-2.8,0L37.2,8a10,10,0,0,0-13,.9l-3,3a2,2,0,0,0-.6,1.4,1.7,1.7,0,0,0,.6,1.4L32.9,26.4a1.9,1.9,0,0,0,2.8,0l3-2.9a9.9,9.9,0,0,0,2.9-7.1A10.4,10.4,0,0,0,40,10.9l3.4-3.5A1.9,1.9,0,0,0,43.4,4.6Z" ] + ] + ] + +let resumeButton (callbacks: CardCallbacks) (wt: WorktreeStatus) = + Html.button [ + prop.className "resume-btn" + prop.title "Resume last session (R)" + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.ResumeSession wt) + prop.children [ resumeIcon () ] + ] + +let binIcon () = + Svg.svg [ + svg.className "btn-icon" + svg.viewBox (0, 0, 24, 24) + svg.fill "none" + svg.stroke "currentColor" + svg.custom ("strokeWidth", "1.5") + svg.custom ("strokeLinecap", "round") + svg.children [ + Svg.path [ svg.d "M20.5001 6H3.5" ] + Svg.path [ svg.d "M9.5 11L10 16" ] + Svg.path [ svg.d "M14.5 11L14 16" ] + Svg.path [ + svg.d "M6.5 6C6.55588 6 6.58382 6 6.60915 5.99936C7.43259 5.97849 8.15902 5.45491 8.43922 4.68032C8.44784 4.65649 8.45667 4.62999 8.47434 4.57697L8.57143 4.28571C8.65431 4.03708 8.69575 3.91276 8.75071 3.8072C8.97001 3.38607 9.37574 3.09364 9.84461 3.01877C9.96213 3 10.0932 3 10.3553 3H13.6447C13.9068 3 14.0379 3 14.1554 3.01877C14.6243 3.09364 15.03 3.38607 15.2493 3.8072C15.3043 3.91276 15.3457 4.03708 15.4286 4.28571L15.5257 4.57697C15.5433 4.62992 15.5522 4.65651 15.5608 4.68032C15.841 5.45491 16.5674 5.97849 17.3909 5.99936C17.4162 6 17.4441 6 17.5 6" + svg.custom ("strokeLinecap", "butt") + ] + Svg.path [ svg.d "M18.3735 15.3991C18.1965 18.054 18.108 19.3815 17.243 20.1907C16.378 21 15.0476 21 12.3868 21H11.6134C8.9526 21 7.6222 21 6.75719 20.1907C5.89218 19.3815 5.80368 18.054 5.62669 15.3991L5.16675 8.5M18.8334 8.5L18.6334 11.5" ] + ] + ] + +let deleteButton (callbacks: CardCallbacks) scopedKey (wt: WorktreeStatus) = + Html.button [ + prop.className "delete-btn" + prop.title "Remove worktree (Del)" + yield! noFocusProps + prop.onClick (fun e -> + e.stopPropagation() + callbacks.DeleteWorktree scopedKey) + prop.children [ binIcon () ] + ] + +let archiveButton (callbacks: CardCallbacks) scopedKey (wt: WorktreeStatus) = + Html.button [ + prop.className "archive-btn" + prop.title "Archive worktree (A)" + yield! noFocusProps + prop.onClick (fun e -> e.stopPropagation(); callbacks.ArchiveWorktree scopedKey) + prop.children [ ArchiveViews.archiveIcon ] + ] + +let conflictIcon () = + Svg.svg [ + svg.className "conflict-icon" + svg.viewBox (0, 0, 1920, 1920) + svg.custom ("role", "img") + svg.children [ + Svg.title "Merge conflicts" + Svg.path [ + svg.d "m1359.36 1279.51-79.85 79.85L960 1039.85l-319.398 319.51-79.85-79.85L880.152 960 560.753 640.602l79.85-79.85L960 880.152l319.51-319.398 79.85 79.85L1039.85 960l319.51 319.51ZM960 0C430.645 0 0 430.645 0 960s430.645 960 960 960 960-430.645 960-960S1489.355 0 960 0Z" + svg.custom ("fillRule", "evenodd") + ] + ] + ] + +let prActionButton (callbacks: CardCallbacks) (cooldowns: Set) (wt: WorktreeStatus) (action: ActionKind) (title: string) (icon: ReactElement) = + let onCooldown = cooldowns.Contains wt.Path + Html.button [ + prop.className (if onCooldown then "action-btn disabled" else "action-btn") + prop.disabled onCooldown + yield! noFocusProps + prop.title (if onCooldown then "Action already triggered" else title) + prop.onClick (fun e -> e.stopPropagation(); if not onCooldown then callbacks.LaunchAction wt.Path action) + prop.children [ icon ] + ] + +let prBadgeContent (callbacks: CardCallbacks) (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) (pr: PrInfo) = + React.fragment [ + if pr.IsMerged then + Interop.createElement "a" [ + prop.className "pr-badge merged" + prop.title pr.Title + prop.href pr.Url + prop.target "_blank" + prop.text "Merged" + ] + else + Interop.createElement "a" [ + prop.className (if pr.IsDraft then "pr-badge draft" else "pr-badge") + prop.title pr.Title + prop.href pr.Url + prop.target "_blank" + prop.children [ + Html.text $"PR #{pr.Id}" + if pr.HasConflicts then conflictIcon () + ] + ] + match pr.Comments with + | WithResolution (unresolved, total) when total > 0 -> + Html.span [ + prop.className (if unresolved = 0 then "thread-badge dimmed" else "thread-badge") + prop.text ($"{unresolved}/{total} threads") + ] + if unresolved > 0 then + prActionButton callbacks cooldowns wt (FixPr pr.Url) "Fix PR comments" commentIcon + | _ -> () + yield! pr.Builds |> List.collect (fun build -> [ + buildBadge repoName build + if build.Status = Failed then + match build.Url with + | Some url -> prActionButton callbacks cooldowns wt (FixBuild url) "Fix build" wrenchIcon + | None -> () + ]) + ] + +let prSection (callbacks: CardCallbacks) (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = + match wt.Pr with + | NoPr -> Html.none + | HasPr pr -> prBadgeContent callbacks cooldowns wt repoName pr + +let prRow (callbacks: CardCallbacks) (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = + match wt.Pr, wt.Branch with + | NoPr, ("main" | "master") -> Html.none + | NoPr, _ -> + Html.div [ + prop.className "pr-row" + prop.children [ + prActionButton callbacks cooldowns wt CreatePr "Create PR" createPrIcon + ] + ] + | HasPr pr, _ -> + Html.div [ + prop.className "pr-row" + prop.children [ prBadgeContent callbacks cooldowns wt repoName pr ] + ] + +let canResumeSession (wt: WorktreeStatus) = + not wt.HasActiveSession + && wt.LastUserMessage.IsSome + && wt.CodingTool <> Working + && wt.CodingTool <> WaitingForUser + +let compactWorktreeCard (props: CardViewProps) (callbacks: CardCallbacks) (repoName: string) (baseBranch: string) (scopedKey: string) (isFocused: bool) (wt: WorktreeStatus) = + let baseClass = cardClassName wt + " compact" + let className = if isFocused then baseClass + " focused" else baseClass + Html.div [ + prop.key (WorktreePath.value wt.Path) + prop.className className + prop.onClick (fun _ -> callbacks.FocusCard scopedKey) + prop.children [ + Html.div [ + prop.className "card-header" + prop.children [ + Html.div [ + prop.className "header-info" + prop.children [ + Html.span [ prop.className ($"ct-dot {ctClassName wt.CodingTool}"); prop.title (ctTooltip wt.CodingTool) ] + Html.span [ prop.className "branch-name"; prop.text (cardTitle wt) ] + FitOrHide (workMetricsItems wt.WorkMetrics) + ] + ] + Html.span [ prop.className "commit-time"; prop.text (relativeTime System.DateTimeOffset.Now wt.LastCommitTime) ] + terminalButton callbacks wt + if wt.HasActiveSession then newTabButton callbacks wt + if canResumeSession wt then resumeButton callbacks wt + editorButton callbacks props.EditorName wt + archiveButton callbacks scopedKey wt + if not wt.IsMainWorktree then deleteButton callbacks scopedKey wt + ] + ] + Html.div [ + prop.className "compact-detail" + prop.children [ + if beadsTotal wt.Beads > 0 then beadsCounts "beads-inline" wt.Beads + mainBehindIndicator baseBranch wt.MainBehindCount + prSection callbacks props.ActionCooldowns wt repoName + ] + ] + ] + ] + +let worktreeCard (props: CardViewProps) (callbacks: CardCallbacks) (repoName: string) (baseBranch: string) (branchEvents: CardEvent list) (canvasEvents: CanvasEvent list) (isPending: bool) (scopedKey: string) (isFocused: bool) (wt: WorktreeStatus) = + let baseClass = cardClassName wt + let className = if isFocused then baseClass + " focused" else baseClass + let hasContent = wt.LastUserMessage.IsSome || (not (List.isEmpty branchEvents)) || (not (List.isEmpty canvasEvents)) + let footerClass = if hasContent then "card-footer has-content" else "card-footer" + Html.div [ + prop.key (WorktreePath.value wt.Path) + prop.className className + prop.onClick (fun _ -> callbacks.FocusCard scopedKey) + prop.children [ + Html.div [ + prop.className "card-body" + prop.children [ + Html.div [ + prop.className "card-header" + prop.children [ + Html.div [ + prop.className "header-info" + prop.children [ + Html.span [ prop.className ($"ct-dot {ctClassName wt.CodingTool}"); prop.title (ctTooltip wt.CodingTool) ] + Html.span [ prop.className "branch-name"; prop.text (cardTitle wt) ] + FitOrHide (workMetricsItems wt.WorkMetrics) + ] + ] + terminalButton callbacks wt + if wt.HasActiveSession then newTabButton callbacks wt + if canResumeSession wt then resumeButton callbacks wt + editorButton callbacks props.EditorName wt + archiveButton callbacks scopedKey wt + if not wt.IsMainWorktree then deleteButton callbacks scopedKey wt + ] + ] + + if beadsTotal wt.Beads > 0 then + Html.div [ + prop.className "beads-row" + prop.children [ + beadsCounts "beads-counts" wt.Beads + beadsProgressBar wt.Beads + ] + ] + + mainBehindWithSync callbacks baseBranch wt branchEvents isPending scopedKey + + prRow callbacks props.ActionCooldowns wt repoName + ] + ] + + Html.div [ + prop.className footerClass + prop.children [ + if List.isEmpty canvasEvents then + match wt.LastUserMessage with + | Some (prompt, ts) -> + Html.div [ + prop.className "user-prompt" + prop.children [ + Html.span [ prop.className "event-time"; prop.text (relativeEventTime ts) ] + Html.span [ prop.text prompt ] + ] + ] + | None -> () + + eventLog callbacks props.ActionCooldowns wt.Path wt.HasTestFailureLog branchEvents + canvasEventLog callbacks scopedKey canvasEvents + ] + ] + ] + ] + +let renderCard (props: CardViewProps) (callbacks: CardCallbacks) (repoName: string) (baseBranch: string) (wt: WorktreeStatus) = + let scopedKey = WorktreePath.value wt.Path + let events = props.BranchEvents |> Map.tryFind scopedKey |> Option.defaultValue [] + let cvEvents = props.CanvasEvents |> Map.tryFind scopedKey |> Option.defaultValue [] + let isPending = props.SyncPending |> Set.contains scopedKey + let isFocused = props.FocusedElement = Some (Card scopedKey) + if props.IsCompact then compactWorktreeCard props callbacks repoName baseBranch scopedKey isFocused wt + else worktreeCard props callbacks repoName baseBranch events cvEvents isPending scopedKey isFocused wt + +let skeletonCard () = + Html.div [ + prop.className "wt-card skeleton" + prop.children [ + Html.div [ + prop.className "card-header" + prop.children [ + Html.span [ prop.className "skeleton-dot" ] + Html.span [ prop.className "skeleton-bar skeleton-branch" ] + ] + ] + Html.div [ prop.className "skeleton-bar skeleton-commit" ] + Html.div [ prop.className "skeleton-bar skeleton-beads" ] + ] + ] + +let skeletonGrid () = + Html.div [ + prop.className "card-grid" + prop.children (List.init 6 (fun _ -> skeletonCard ())) + ] + +let sortLabel = + function + | ByName -> "A-Z" + | ByActivity -> "Recent" + +let providerIcon (provider: RepoProvider option) = + let icon viewBox (svgPath: string) = + Svg.svg [ + svg.className "provider-icon" + svg.viewBox viewBox + svg.children [ Svg.path [ svg.d svgPath; svg.fill "currentColor" ] ] + ] + + let githubPath = "M12 .297c-6.63 0-12 5.373-12 12 0 5.303 3.438 9.8 8.205 11.385.6.113.82-.258.82-.577 0-.285-.01-1.04-.015-2.04-3.338.724-4.042-1.61-4.042-1.61C4.422 18.07 3.633 17.7 3.633 17.7c-1.087-.744.084-.729.084-.729 1.205.084 1.838 1.236 1.838 1.236 1.07 1.835 2.809 1.305 3.495.998.108-.776.417-1.305.76-1.605-2.665-.3-5.466-1.332-5.466-5.93 0-1.31.465-2.38 1.235-3.22-.135-.303-.54-1.523.105-3.176 0 0 1.005-.322 3.3 1.23.96-.267 1.98-.399 3-.405 1.02.006 2.04.138 3 .405 2.28-1.552 3.285-1.23 3.285-1.23.645 1.653.24 2.873.12 3.176.765.84 1.23 1.91 1.23 3.22 0 4.61-2.805 5.625-5.475 5.92.42.36.81 1.096.81 2.22 0 1.606-.015 2.896-.015 3.286 0 .315.21.69.825.57C20.565 22.092 24 17.592 24 12.297c0-6.627-5.373-12-12-12" + let azdoPath = "M17 4v9.74l-4 3.28-6.2-2.26V17l-3.51-4.59 10.23.8V4.44zm-3.41.49L7.85 1v2.29L2.58 4.84 1 6.87v4.61l2.26 1V6.57z" + + match provider with + | None | Some UnknownProvider -> Html.none + | Some(GitHubProvider url) -> + Html.a [ + prop.className "provider-link" + prop.href url + prop.target "_blank" + prop.onClick (fun e -> e.stopPropagation()) + prop.children [ icon (0, 0, 24, 24) githubPath ] + ] + | Some(AzDoProvider url) -> + Html.a [ + prop.className "provider-link" + prop.href url + prop.target "_blank" + prop.onClick (fun e -> e.stopPropagation()) + prop.children [ icon (0, 0, 18, 18) azdoPath ] + ] + +let repoSectionHeader (callbacks: CardCallbacks) (focusedElement: FocusTarget option) (repo: RepoModel) = + let arrow = if repo.IsCollapsed then "\u25B6" else "\u25BC" + let isFocused = focusedElement = Some (RepoHeader repo.RepoId) + let baseClass = if repo.IsCollapsed then "repo-header collapsed" else "repo-header" + let className = if isFocused then baseClass + " focused" else baseClass + Html.div [ + prop.className className + prop.onClick (fun _ -> callbacks.ToggleRepo repo.RepoId) + prop.children [ + Html.span [ prop.className "collapse-arrow"; prop.text arrow ] + Html.span [ prop.className "repo-name"; prop.text repo.Name ] + providerIcon repo.Provider + if repo.BaseBranch <> "main" then + Html.span [ prop.className "deploy-branch"; prop.text repo.BaseBranch ] + if repo.IsCollapsed then + Html.span [ + prop.className "repo-ct-dots" + prop.children ( + repo.Worktrees + |> List.map (fun wt -> + Html.span [ prop.className ($"ct-dot {ctClassName wt.CodingTool}"); prop.title (ctTooltip wt.CodingTool) ])) + ] + Html.button [ + prop.className "create-wt-btn" + prop.title "Create worktree" + prop.onClick (fun e -> e.stopPropagation(); callbacks.CreateWorktree repo.RepoId) + prop.text "+" + ] + ] + ] + +let repoSection (props: CardViewProps) (callbacks: CardCallbacks) (repo: RepoModel) = + Html.div [ + prop.key (RepoId.value repo.RepoId) + prop.className "repo-section" + prop.children [ + repoSectionHeader callbacks props.FocusedElement repo + if not repo.IsCollapsed then + if not repo.IsReady && repo.Worktrees.IsEmpty then + skeletonGrid () + else + Html.div [ + prop.className "card-grid" + prop.children (repo.Worktrees |> List.map (renderCard props callbacks repo.Name repo.BaseBranch)) + ] + ArchiveViews.archiveSection callbacks.DispatchArchive repo.ArchivedWorktrees + ] + ] diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index f6cdd0f5..6852c1ad 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -15,8 +15,15 @@ + + + + + + + diff --git a/src/Client/Components.fs b/src/Client/Components.fs index dd152e87..8645cc7d 100644 --- a/src/Client/Components.fs +++ b/src/Client/Components.fs @@ -17,6 +17,33 @@ let cardTitle (wt: WorktreeStatus) = if wt.Branch = WorktreeStatus.DetachedBranchName then WorktreePath.displayName wt.Path else wt.Branch +let stepStatusClassName (status: StepStatus option) = + match status with + | Some StepStatus.Running -> "event-status running" + | Some StepStatus.Succeeded -> "event-status success" + | Some (StepStatus.Failed _) -> "event-status failed" + | Some StepStatus.Cancelled -> "event-status cancelled" + | Some StepStatus.NotConfigured -> "event-status not-configured" + | Some StepStatus.Pending -> "event-status" + | None -> "event-status" + +let stepStatusText (status: StepStatus option) = + match status with + | Some StepStatus.Running -> "running" + | Some StepStatus.Succeeded -> "success" + | Some (StepStatus.Failed msg) -> match msg with "" -> "failed" | _ -> $"failed: {msg}" + | Some StepStatus.Cancelled -> "cancelled" + | Some StepStatus.NotConfigured -> "not configured" + | _ -> "" + +let relativeEventTime (dt: System.DateTimeOffset) = + let diff = System.DateTimeOffset.Now - dt + match diff with + | d when d.TotalSeconds < 60.0 -> $"{int d.TotalSeconds |> max 0}s ago" + | d when d.TotalMinutes < 60.0 -> $"{int d.TotalMinutes}m ago" + | d when d.TotalHours < 24.0 -> $"{int d.TotalHours}h ago" + | d -> $"{int d.TotalDays}d ago" + // ResizeObserver interop [] let private createResizeObserver (callback: obj -> unit) : obj = jsNative diff --git a/src/Client/MascotState.fs b/src/Client/MascotState.fs new file mode 100644 index 00000000..480bf710 --- /dev/null +++ b/src/Client/MascotState.fs @@ -0,0 +1,20 @@ +module MascotState + +/// The mascot eyes' slice of the dashboard model: just the gaze direction. The activity/idle +/// state that used to live here moved to `ActivityState` (it drives polling/telemetry/canvas, not +/// the eyes); the eyes merely *observe* `ActivityLevel`. Mirrors how `CanvasState` nests a +/// feature's state into `Model`. +type MascotState = + { EyeDirection: float * float } + +let empty : MascotState = + { EyeDirection = (0.0, 0.0) } + +let private rng = System.Random() + +/// A small random gaze offset (dx in [-1.5, 1.5], dy in [-1.0, 1.0]), re-rolled on each +/// data refresh so the eyes subtly drift around. +let randomEyeDirection () = + let dx = rng.NextDouble() * 3.0 - 1.5 + let dy = rng.NextDouble() * 2.0 - 1.0 + (dx, dy) diff --git a/src/Client/MascotView.fs b/src/Client/MascotView.fs new file mode 100644 index 00000000..e8194867 --- /dev/null +++ b/src/Client/MascotView.fs @@ -0,0 +1,161 @@ +module MascotView + +// The mascot eye SVGs, extracted from `App.fs`. Pure render functions where gaze comes from +// the mascot's `EyeDirection`, while the lid overlay comes from the observed `ActivityLevel`. +// Compiled before `AppTypes.fs`, so these depend only on `Shared`/`Feliz` — never on `Model`/`Msg`. + +open Shared +open Feliz + +/// Open, awake eye. `pupilColor` is derived by the header from worktree state (waiting vs not), +/// so it stays a separate argument; gaze offset comes from the mascot's `EyeDirection`, and the +/// half/closed lid overlay comes from the observed `ActivityLevel`. +let viewEyeOpen (pupilColor: string) (activityLevel: ActivityLevel) (eyeDirection: float * float) = + let (dx, dy) = eyeDirection + let activity = activityLevel + Svg.svg [ + svg.className "eye-logo" + svg.viewBox (-2, -2, 44, 24) + svg.children [ + Svg.path [ + svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 20 20 20 Q10 20 2 10 Z" + svg.fill "#e8e8e8" + svg.stroke "#56b6c2" + svg.strokeWidth 2.5 + ] + Svg.g [ + svg.className "eye-iris" + svg.custom ("transform", $"translate({dx}, {dy})") + svg.children [ + Svg.circle [ + svg.cx 20 + svg.cy 10 + svg.r 9 + svg.fill "#1a1b2e" + ] + Svg.circle [ + svg.cx 20 + svg.cy 10 + svg.r 6 + svg.fill "#56b6c2" + ] + Svg.circle [ + svg.cx 20 + svg.cy 10 + svg.r 3 + svg.fill pupilColor + ] + ] + ] + Svg.circle [ + svg.cx 23 + svg.cy 5 + svg.r 2 + svg.fill "rgba(255, 255, 255, 0.8)" + ] + match activity with + | ActivityLevel.Idle -> + Svg.path [ + svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 4 20 5 Q10 4 2 10 Z" + svg.fill "#b0b0b0" + ] + Svg.path [ + svg.d "M2 10 Q10 4 20 5 Q30 4 38 10" + svg.fill "none" + svg.stroke "#56b6c2" + svg.strokeWidth 2.0 + ] + | ActivityLevel.DeepIdle -> + Svg.path [ + svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 9 20 12 Q10 9 2 10 Z" + svg.fill "#b0b0b0" + ] + Svg.path [ + svg.d "M2 10 Q10 9 20 12 Q30 9 38 10" + svg.fill "none" + svg.stroke "#56b6c2" + svg.strokeWidth 2.0 + ] + | ActivityLevel.Active -> () + ] + ] + +let viewEyeRolledBack () = + Svg.svg [ + svg.className "eye-logo" + svg.viewBox (-2, -2, 44, 24) + svg.children [ + Svg.defs [ + Svg.clipPath [ + svg.id "eye-shape" + svg.children [ + Svg.path [ + svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 20 20 20 Q10 20 2 10 Z" + ] + ] + ] + ] + Svg.path [ + svg.d "M2 10 Q10 0 20 0 Q30 0 38 10 Q30 20 20 20 Q10 20 2 10 Z" + svg.fill "#e8e8e8" + svg.stroke "#56b6c2" + svg.strokeWidth 2.5 + ] + Svg.g [ + svg.custom ("clipPath", "url(#eye-shape)") + svg.children [ + Svg.g [ + svg.custom ("transform", "translate(0, -9)") + svg.children [ + Svg.circle [ + svg.cx 20 + svg.cy 10 + svg.r 9 + svg.fill "#1a1b2e" + ] + Svg.circle [ + svg.cx 20 + svg.cy 10 + svg.r 6 + svg.fill "#888" + ] + Svg.circle [ + svg.cx 20 + svg.cy 10 + svg.r 3 + svg.fill "#1a1b2e" + ] + ] + ] + ] + ] + Svg.circle [ + svg.cx 23 + svg.cy 5 + svg.r 2 + svg.fill "rgba(255, 255, 255, 0.8)" + ] + ] + ] + +let viewEyeClosed () = + Svg.svg [ + svg.className "eye-logo eye-closed" + svg.viewBox (-2, -2, 44, 24) + svg.children [ + Svg.path [ + svg.d "M2 10 Q10 4 20 4 Q30 4 38 10 Q30 16 20 16 Q10 16 2 10 Z" + svg.fill "#e8e8e8" + svg.stroke "#56b6c2" + svg.strokeWidth 2.5 + ] + Svg.line [ + svg.x1 4 + svg.y1 10 + svg.x2 36 + svg.y2 10 + svg.stroke "#56b6c2" + svg.strokeWidth 2.0 + ] + ] + ] diff --git a/src/Client/OverviewViews.fs b/src/Client/OverviewViews.fs new file mode 100644 index 00000000..65c8e338 --- /dev/null +++ b/src/Client/OverviewViews.fs @@ -0,0 +1,122 @@ +module OverviewViews + +open Shared +open Shared.EventUtils +open Navigation +open Feliz +open Components + +let knownCategories = + [ "WorktreeList"; "GitRefresh"; "BeadsRefresh"; "CodingToolRefresh"; "PrFetch"; "GitFetch" ] + +let categoryDisplayName = + function + | "WorktreeList" -> "Worktree \u2630" + | "GitRefresh" -> "Git \u21BB" + | "BeadsRefresh" -> "Beads \u21BB" + | "CodingToolRefresh" -> "Agent \u21BB" + | "PrFetch" -> "PR \u2913" + | "GitFetch" -> "Git \u2913" + | other -> other + +let private lastSepIndex (s: string) = + max (s.LastIndexOf('/')) (s.LastIndexOf('\\')) + +let commonPathPrefix (paths: string list) = + match paths with + | [] -> "" + | [ single ] -> + match lastSepIndex single with + | -1 -> "" + | i -> single[..i] + | first :: rest -> + let prefixLen = + rest |> List.fold (fun len path -> + let maxLen = min len path.Length + let rec findMismatch i = + if i >= maxLen then maxLen + elif System.Char.ToLowerInvariant first[i] = System.Char.ToLowerInvariant path[i] then findMismatch (i + 1) + else i + findMismatch 0) first.Length + let prefix = first[..prefixLen - 1] + match lastSepIndex prefix with + | -1 -> "" + | i -> prefix[..i] + +let stripPrefix (prefix: string) (target: string) = + if prefix.Length > 0 && target.Length >= prefix.Length + && target[..prefix.Length - 1].ToLowerInvariant() = prefix.ToLowerInvariant() + then target[prefix.Length..] + else target + +let statusOverviewRow (prefix: string) (latestBySource: Map) (category: string) = + let label = categoryDisplayName category + match Map.tryFind category latestBySource with + | None -> + Html.div [ + prop.className "status-row pending" + prop.children [ + Html.span [ prop.className "status-category"; prop.text label ] + Html.span [ prop.className "status-target" ] + Html.span [ prop.className "status-duration" ] + Html.span [ prop.className "status-time" ] + Html.span [ prop.className "status-badge pending"; prop.text "pending" ] + ] + ] + | Some evt -> + let target = extractBranchName evt.Message |> Option.defaultValue "" |> stripPrefix prefix + Html.div [ + prop.className "status-row" + prop.children [ + Html.span [ prop.className "status-category"; prop.text label ] + Html.span [ prop.className "status-target"; prop.text target ] + match evt.Duration with + | Some d -> Html.span [ prop.className "status-duration"; prop.text $"%.1f{d.TotalSeconds}s" ] + | None -> Html.span [ prop.className "status-duration" ] + Html.span [ prop.className "status-time"; prop.text (relativeEventTime evt.Timestamp) ] + match evt.Status with + | Some _ -> + Html.span [ + prop.className (stepStatusClassName evt.Status) + prop.text (stepStatusText evt.Status) + ] + | None -> Html.none + ] + ] + +let pinnedErrorEntry (prefix: string) (evt: CardEvent) = + Html.div [ + prop.className "event-entry pinned-error" + prop.children [ + Html.span [ prop.className "event-time"; prop.text (relativeEventTime evt.Timestamp) ] + Html.span [ prop.className "event-source"; prop.text evt.Source ] + Html.span [ prop.className "event-message"; prop.text (stripPrefix prefix evt.Message) ] + match evt.Status with + | Some _ -> + Html.span [ + prop.className (stepStatusClassName evt.Status) + prop.text (stepStatusText evt.Status) + ] + | None -> Html.none + ] + ] + +let schedulerFooter (repos: RepoModel list) (events: CardEvent list) (latestByCategory: Map) = + let prefix = repos |> List.map (fun r -> RepoId.value r.RepoId) |> commonPathPrefix + let errors = pinnedErrors events + Html.div [ + prop.className "scheduler-footer" + prop.children [ + match errors with + | [] -> Html.none + | errs -> + Html.div [ + prop.className "pinned-errors" + prop.children (errs |> List.map (pinnedErrorEntry prefix)) + ] + Html.div [ + prop.className "status-overview" + prop.children (knownCategories |> List.map (statusOverviewRow prefix latestByCategory)) + ] + ] + ] diff --git a/src/Tests/CanvasAwarenessTests.fs b/src/Tests/CanvasAwarenessTests.fs index 7df2ded4..8d6455f2 100644 --- a/src/Tests/CanvasAwarenessTests.fs +++ b/src/Tests/CanvasAwarenessTests.fs @@ -67,15 +67,14 @@ let private defaultModel : Model = AppVersion = Some "1.0" DeployBranch = None SystemMetrics = None - EyeDirection = (0.0, 0.0) FocusedElement = None CreateModal = CreateWorktreeModal.Closed ConfirmModal = ConfirmModal.NoConfirm DeletedPaths = Set.empty EditorName = "VS Code" ActionCooldowns = Set.empty - LastActivityTime = 0.0 - ActivityLevel = ActivityLevel.Active + Activity = ActivityState.empty + Mascot = MascotState.empty Canvas = CanvasState.empty } /// Calls update and returns the model, ignoring the Cmd. Tolerates the @@ -330,13 +329,13 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = 0.0 + Activity = { defaultModel.Activity with LastActivityTime = 0.0 } Canvas = { defaultModel.Canvas with PreviousCanvasHashes = Map.empty; CanvasPaneOpen = false } } let currentHashes = canvasHashesByScopedKey repos let changedDocs = detectChangedCanvasDocs DateTimeOffset.UtcNow model.Canvas.PreviousCanvasHashes currentHashes let jsNow = 120_000.0 // 120s since epoch — well past 60s idle threshold - let isIdle = jsNow - model.LastActivityTime > autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -353,13 +352,13 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = 0.0 + Activity = { defaultModel.Activity with LastActivityTime = 0.0 } Canvas = { defaultModel.Canvas with PreviousCanvasHashes = previousHashes; CanvasPaneOpen = false } } let currentHashes = canvasHashesByScopedKey repos let changedDocs = detectChangedCanvasDocs DateTimeOffset.UtcNow model.Canvas.PreviousCanvasHashes currentHashes let jsNow = 120_000.0 - let isIdle = jsNow - model.LastActivityTime > autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -377,11 +376,11 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = jsNow - 10_000.0 // 10s ago, well within 60s threshold + Activity = { defaultModel.Activity with LastActivityTime = jsNow - 10_000.0 } // 10s ago, well within 60s threshold Canvas = { defaultModel.Canvas with PreviousCanvasHashes = Map.empty } } let changedDocs = detectChangedCanvasDocs DateTimeOffset.UtcNow model.Canvas.PreviousCanvasHashes currentHashes - let isIdle = jsNow - model.LastActivityTime > autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -397,12 +396,12 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = 0.0 + Activity = { defaultModel.Activity with LastActivityTime = 0.0 } Canvas = { defaultModel.Canvas with PreviousCanvasHashes = currentHashes } } let changedDocs = detectChangedCanvasDocs DateTimeOffset.UtcNow model.Canvas.PreviousCanvasHashes currentHashes let jsNow = 120_000.0 - let isIdle = jsNow - model.LastActivityTime > autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs diff --git a/src/Tests/ConfirmModalTests.fs b/src/Tests/ConfirmModalTests.fs index 2486cd96..78be0881 100644 --- a/src/Tests/ConfirmModalTests.fs +++ b/src/Tests/ConfirmModalTests.fs @@ -53,15 +53,14 @@ let private defaultModel : Model = AppVersion = Some "1.0" DeployBranch = None SystemMetrics = None - EyeDirection = (0.0, 0.0) FocusedElement = None CreateModal = CreateWorktreeModal.Closed ConfirmModal = ConfirmModal.NoConfirm DeletedPaths = Set.empty EditorName = "VS Code" ActionCooldowns = Set.empty - LastActivityTime = 0.0 - ActivityLevel = ActivityLevel.Active + Activity = ActivityState.empty + Mascot = MascotState.empty Canvas = CanvasState.empty } /// Calls update and returns the model, ignoring the Cmd. Handles the case where /// Fable.Remoting.Client proxy initialization fails in .NET by catching the proxy diff --git a/src/Tests/CreateWorktreeTests.fs b/src/Tests/CreateWorktreeTests.fs index 16e3ce54..20d594d1 100644 --- a/src/Tests/CreateWorktreeTests.fs +++ b/src/Tests/CreateWorktreeTests.fs @@ -26,15 +26,14 @@ let private defaultModel : Model = AppVersion = Some "1.0" DeployBranch = None SystemMetrics = None - EyeDirection = (0.0, 0.0) FocusedElement = None CreateModal = Modal.Closed ConfirmModal = ConfirmModal.NoConfirm DeletedPaths = Set.empty EditorName = "VS Code" ActionCooldowns = Set.empty - LastActivityTime = 0.0 - ActivityLevel = ActivityLevel.Active + Activity = ActivityState.empty + Mascot = MascotState.empty Canvas = CanvasState.empty } /// Calls update and returns the model, ignoring the Cmd. Handles the case where diff --git a/src/Tests/IdleDetectionTests.fs b/src/Tests/IdleDetectionTests.fs index 5163809a..b3231d96 100644 --- a/src/Tests/IdleDetectionTests.fs +++ b/src/Tests/IdleDetectionTests.fs @@ -195,32 +195,32 @@ type ComputeActivityLevelTests() = [] member _.``Recent activity (0 elapsed) returns Active``() = - Assert.That(App.computeActivityLevel nowMs nowMs, Is.EqualTo(ActivityLevel.Active)) + Assert.That(ActivityState.computeActivityLevel nowMs nowMs, Is.EqualTo(ActivityLevel.Active)) [] member _.``Activity 30s ago returns Active``() = - Assert.That(App.computeActivityLevel (nowMs - 30_000.0) nowMs, Is.EqualTo(ActivityLevel.Active)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 30_000.0) nowMs, Is.EqualTo(ActivityLevel.Active)) [] member _.``Activity 2m59.999s ago returns Active``() = - Assert.That(App.computeActivityLevel (nowMs - 179_999.0) nowMs, Is.EqualTo(ActivityLevel.Active)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 179_999.0) nowMs, Is.EqualTo(ActivityLevel.Active)) [] member _.``Activity exactly 3 min ago returns Idle``() = - Assert.That(App.computeActivityLevel (nowMs - 180_000.0) nowMs, Is.EqualTo(ActivityLevel.Idle)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 180_000.0) nowMs, Is.EqualTo(ActivityLevel.Idle)) [] member _.``Activity 5 min ago returns Idle``() = - Assert.That(App.computeActivityLevel (nowMs - 300_000.0) nowMs, Is.EqualTo(ActivityLevel.Idle)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 300_000.0) nowMs, Is.EqualTo(ActivityLevel.Idle)) [] member _.``Activity 14m59s ago returns Idle``() = - Assert.That(App.computeActivityLevel (nowMs - 899_999.0) nowMs, Is.EqualTo(ActivityLevel.Idle)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 899_999.0) nowMs, Is.EqualTo(ActivityLevel.Idle)) [] member _.``Activity exactly 15 min ago returns DeepIdle``() = - Assert.That(App.computeActivityLevel (nowMs - 900_000.0) nowMs, Is.EqualTo(ActivityLevel.DeepIdle)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 900_000.0) nowMs, Is.EqualTo(ActivityLevel.DeepIdle)) [] member _.``Activity 1 hour ago returns DeepIdle``() = - Assert.That(App.computeActivityLevel (nowMs - 3_600_000.0) nowMs, Is.EqualTo(ActivityLevel.DeepIdle)) + Assert.That(ActivityState.computeActivityLevel (nowMs - 3_600_000.0) nowMs, Is.EqualTo(ActivityLevel.DeepIdle))