From 29bb3fa7ea0fb1133893925ee384c63d577b04db Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 17:41:52 +0200 Subject: [PATCH 01/11] tm-code-improvement-5wt Extract OverviewViews.fs (status-overview + scheduler footer) Relocate status-overview + scheduler-footer pure views into new src/Client/OverviewViews.fs (compiles before AppTypes, after CanvasState.fs). Move shared formatters stepStatusClassName/stepStatusText/relativeEventTime into Components.fs per spec Decision 7; App.fs keeps thin re-export aliases so card-side call sites stay untouched. Repoint App.fs view to OverviewViews.schedulerFooter. Pure relocation, no logic change. --- docs/spec/app-fs-view-extraction.md | 139 +++++++++++++++++++ docs/spec/future/app-fs-view-extraction.md | 4 +- src/Client/App.fs | 148 +-------------------- src/Client/Client.fsproj | 1 + src/Client/Components.fs | 27 ++++ src/Client/OverviewViews.fs | 122 +++++++++++++++++ 6 files changed, 298 insertions(+), 143 deletions(-) create mode 100644 docs/spec/app-fs-view-extraction.md create mode 100644 src/Client/OverviewViews.fs diff --git a/docs/spec/app-fs-view-extraction.md b/docs/spec/app-fs-view-extraction.md new file mode 100644 index 00000000..12138759 --- /dev/null +++ b/docs/spec/app-fs-view-extraction.md @@ -0,0 +1,139 @@ +# App.fs View Extraction + +Status: **Active** — design decided, ready for execution. Supersedes +`docs/spec/future/app-fs-view-extraction.md` (kept for provenance/sizing history). + +## Goals + +- Shrink `src/Client/App.fs` (currently **1685 lines**) by relocating its pure-render + view families into focused modules — **and make the architecture strictly better**, not + merely shorter. +- Replace the loose-parameter smell in the card views (`repoSection` takes **9 positional + args**) with explicit data/callback records. +- Promote the one feature that genuinely owns cohesive state + behavior (the mascot eyes) + into a proper vertical slice, mirroring the established canvas seam. +- Zero behavior change. The existing test/E2E suite stays green at every step; tests assert + on CSS classes and DOM structure, so identical render output proves correctness. + +## Decisions + +These were chosen deliberately (see *Per-family evidence* for why): + +1. **Evidence-driven hybrid, not one-size-fits-all.** Vertical-slice only where a feature + owns separable state+behavior (Mascot); props/callback records for render-over-shared-state + (Cards); plain pure-view extraction where there is no owned state at all (Overview). + Forcing sub-states onto Cards/Overview would invent leaky boundaries. +2. **Cards get `CardViewProps` + `CardCallbacks` records**, mirroring `CanvasPaneCallbacks`. + This is the central quality win: it kills the 9-arg signature, makes card data flow + explicit, and lets canvas slices ride along (which unblocks decision 5). +3. **Mascot becomes a vertical slice**: `MascotState` sub-state + `MascotView` + `MascotUpdate`, + exactly like `CanvasState`/`CanvasUpdate`/`CanvasPane`. `Tick`/`UserActivity` arm *bodies* + delegate to `MascotUpdate`; the arms stay in the root `update`. +4. **Flat `Msg` + single `update` are preserved.** No nested sub-`Msg`, no `Cmd.map` + sub-component split. Arm bodies move into `Update` modules; the `match` stays in + `App.fs`. This is consistent with the existing canvas decision (see `AppTypes.fs` header). +5. **Canvas card-view (Opportunity B) is included now.** Once cards take a props record, the + canvas-pane wiring lifts cleanly into `CanvasView.fs` in the same pass instead of + re-touching card signatures later. +6. **Sequencing**: Overview → Cards → Mascot → CanvasView. Overview first because it is the + smallest and proves the extraction seam; each step keeps the build and tests green. +7. **Shared status/time formatters live in `Components.fs`, not the view modules.** + `stepStatusClassName`, `stepStatusText`, and `relativeEventTime` are pure, Shared-only + formatters consumed by *both* the overview rows (Step 1) and the card / event-log views + (Steps 3–4). Because `OverviewViews.fs` compiles before `AppTypes` (and before + `CardViews.fs`), it cannot reach them where they previously sat in `App.fs`. Per the + "reuse, don't duplicate — check `Components.fs`" guidance, they were relocated into + `Components.fs` (which already hosts the sibling `relativeTime` / `cardTitle` formatters). + `App.fs` keeps thin `let x = Components.x` re-export aliases — the existing pattern it + already uses for `relativeTime`, `workMetricsView`, `cardTitle`, etc. — so card-side call + sites stay untouched and there is a single source of truth. + +### Why a vertical slice for Mascot but not Cards + +| Family (~size) | State owned | Msg / update owned | Disposition | +|---|---|---|---| +| **Cards** (~650 ln) | none exclusive — reads 8 shared fields (`EditorName`, `IsCompact`, `FocusedElement`, `BranchEvents`, `SyncPending`, `ActionCooldowns`, `Canvas.CanvasEvents`, `Canvas.CanvasPaneOpen`) | ~19 update arms, but they are **core app behavior** (sync/delete/archive/launch/resume); focus + keyboard nav (`FocusedElement`/`KeyPressed`) is **shared** with canvas & overview | **Pure view + `CardViewProps`/`CardCallbacks` records.** Behavior is not separable. | +| **Mascot** (~190 ln) | `EyeDirection`, `LastActivityTime`, `ActivityLevel` (exclusive) | `Tick`, `UserActivity` + activity subscriptions. Edge case: `Tick` also expires canvas events; `ActivityLevel` also drives refresh-poll cadence | **Vertical slice.** `Tick` stays in root update (shared) but delegates the activity recompute to `MascotUpdate`. | +| **Overview / footer** (~100 ln) | reads `SchedulerEvents`, `LatestByCategory`, `Repos` | **none** — zero dedicated arms | **Pure view**, plain params. | +| **Canvas card-view** (Opp B) | reads `Canvas.*` slices | update already extracted (`CanvasUpdate.fs`) | Lift pane wiring into `CanvasView.fs`. | + +## Expected Behavior + +- The dashboard renders byte-for-byte identically before and after — same DOM, same CSS + classes, same interactions. No user-visible change. +- `App.fs` is reduced to orchestration: `init`, the `update` `match` (with arm bodies + delegating to feature `*Update` modules), `appSubscriptions`, and the top-level `view` + wiring. Target: roughly half — about **800 lines**, down from **1685** (the six new modules + absorb the ~900 lines of relocated view/state/update code). +- The Fable client build succeeds and the full test suite (Unit + Fast + E2E) passes after + **each** task, not just at the end. + +## Technical Approach + +New modules and their compilation placement in `src/Client/Client.fsproj` +(before-`AppTypes` modules are pure and take slices/records; after-`AppTypes` modules +reference `Model`/`Msg`, like `CanvasUpdate.fs`): + +| New module | Compiles | Holds | +|---|---|---| +| `OverviewViews.fs` | before `AppTypes` | `statusOverviewRow`, `pinnedErrorEntry`, `schedulerFooter`, and path-prefix helpers (`knownCategories`, `categoryDisplayName`, `lastSepIndex`, `commonPathPrefix`, `stripPrefix`) | +| `CardViews.fs` | before `AppTypes` | `CardViewProps` + `CardCallbacks` records; all card render functions, action buttons, icons, badges, PR/sync/event-log helpers, `repoSection`, `repoSectionHeader`, skeletons; per-worktree `canvasEventEntry`/`canvasEventLog` (card-embedded) | +| `MascotState.fs` | before `AppTypes` (next to `CanvasState.fs`) | `MascotState` record (`EyeDirection`, `LastActivityTime`, `ActivityLevel`), `empty`, and pure helpers `computeActivityLevel`, `randomEyeDirection`, idle thresholds | +| `MascotView.fs` | before `AppTypes` | `viewEyeOpen`/`viewEyeRolledBack`/`viewEyeClosed`, taking a `MascotState` slice | +| `MascotUpdate.fs` | after `AppTypes` (next to `CanvasUpdate.fs`) | `Tick`/`UserActivity` activity-recompute bodies + the subscription helper | +| `CanvasView.fs` | after `CanvasUpdate.fs`, before `App.fs` | `focusedWorktreeCanvasDoc` + the canvas-pane wiring block (builds `CanvasPaneCallbacks`, computes focused unviewed/visited docs, calls `CanvasPane.view`) | + +Record shapes (illustrative — finalize during implementation): + +- `CardViewProps` = the read slice currently threaded as loose args (`EditorName`, `IsCompact`, + `FocusedElement`, `BranchEvents`, `SyncPending`, `ActionCooldowns`, `CanvasEvents`, + `CanvasPaneOpen`). No `Model` dependency — Shared/Navigation types only. +- `CardCallbacks` = the dispatch-derived actions cards trigger (terminal, editor, new-tab, + resume, delete, archive, sync, launch-action, focus, toggle-collapse, PR action). Plain + `… -> unit` functions — no `Msg` dependency. `App.fs` constructs both records in `view` + from `model` and `dispatch`. + +**Reuse, don't duplicate.** Before relocating helpers, check `Components.fs` and +`ActionButtons.fs` (already holds `noFocusProps`, `commentIcon`, `wrenchIcon`, `createPrIcon`) +and route through existing helpers; move shared icons there rather than copying. + +**Each task ends green.** Relocations are cut/paste + `open`/namespace adjustments plus the +`.fsproj` `` entry; no logic edits. Before marking a task done, run the per-step +green check: `npm run build` plus `dotnet test src/Tests/Tests.fsproj --filter "Category=Unit"` +and `--filter "Category=Fast"`. The heavier E2E suite (`--filter "Category=E2E"`) runs in the +final verify task. + +## Task Sequence + +1. `OverviewViews.fs` — pure relocation (proves the seam). +2. `CardViewProps` + `CardCallbacks` records — define them and refactor the **in-place** card + views + the `view` call site to use them (no file move yet). +3. Relocate card **leaf** helpers (icons, action buttons, badges, sync/event-log/PR helpers, + class/text/format helpers, `canvasEventEntry`/`canvasEventLog`) into `CardViews.fs`. +4. Relocate **composite** card views (`compactWorktreeCard`, `worktreeCard`, `renderCard`, + `repoSectionHeader`, `repoSection`, skeletons, `providerIcon`, `sortLabel`) into + `CardViews.fs` and wire `view` to call `CardViews.repoSection` with the records. +5. `MascotState.fs` — introduce the sub-state, embed as `Model.Mascot`, and repoint `init`, + `DataLoaded`, `Tick`, `UserActivity`, `appSubscriptions`, and the header to `model.Mascot.*`. +6. `MascotView.fs` + `MascotUpdate.fs` — move the eye views and the `Tick`/`UserActivity` + bodies; wire the header to `MascotView` and the arms to delegate to `MascotUpdate`. +7. `CanvasView.fs` — lift `focusedWorktreeCanvasDoc` + the canvas-pane wiring block out of + `view`. + +Tasks are chained (each blocks the next) to honor the order and to serialize edits to the +shared `App.fs`, avoiding self-conflicts. + +## Key Files + +- **Primary**: `src/Client/App.fs`, `src/Client/Client.fsproj`. +- **Referenced patterns**: `src/Client/CanvasState.fs`, `src/Client/CanvasUpdate.fs`, + `src/Client/CanvasPane.fs` (the vertical-slice + callback-record precedent), + `src/Client/AppTypes.fs` (root `Model`/`Msg`; flat-`Msg` decision). +- **Reuse targets**: `src/Client/Components.fs`, `src/Client/ActionButtons.fs`. + +## Provenance + +Activates and supersedes `docs/spec/future/app-fs-view-extraction.md`, which framed the same +work as deferred "Opportunity A" (pre-existing view bulk) and "Opportunity B" (canvas view +layer). This spec carries the design decisions (records, mascot slice, sequencing) that the +deferred note left open. diff --git a/docs/spec/future/app-fs-view-extraction.md b/docs/spec/future/app-fs-view-extraction.md index 107d991a..57d2d528 100644 --- a/docs/spec/future/app-fs-view-extraction.md +++ b/docs/spec/future/app-fs-view-extraction.md @@ -1,6 +1,8 @@ # App.fs View Extraction -Status: **Future / Deferred** — design only. NOT implemented on the canvas48 branch. +Status: **Activated** — see `docs/spec/app-fs-view-extraction.md` for the authoritative, +decided plan. This document is retained for provenance and the original sizing/opportunity +analysis (Opportunity A / B framing). Parent spec: `docs/spec/canvas-pane.md`. diff --git a/src/Client/App.fs b/src/Client/App.fs index 60862994..8ef4038c 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -760,32 +760,11 @@ let mainBehindWithSync dispatch (baseBranch: string) (wt: WorktreeStatus) (branc ] ] -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 stepStatusClassName = Components.stepStatusClassName + +let stepStatusText = Components.stepStatusText + +let relativeEventTime = Components.relativeEventTime let eventLogEntry (onFixTests: (unit -> unit) option) (onConfigureTests: (unit -> unit) option) (evt: CardEvent) = let isTestFailure = @@ -862,121 +841,6 @@ let canvasEventLog dispatch (scopedKey: string) (events: CanvasEvent list) = 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) @@ -1775,7 +1639,7 @@ let view model dispatch = 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)) ] - 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 diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index f6cdd0f5..2283c8c0 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -15,6 +15,7 @@ + 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/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)) + ] + ] + ] From 5171f8bfce2adc43957a645152f073247bc4a9e7 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 18:32:10 +0200 Subject: [PATCH 02/11] tm-code-improvement-y4u Add CardViewProps + CardCallbacks records (in-place card refactor) Introduce Msg-free CardViewProps (8-field model read-slice) and CardCallbacks records mirroring CanvasPaneCallbacks. Convert card leaf helpers and composite views (compactWorktreeCard/worktreeCard/renderCard/repoSectionHeader/repoSection) from raw dispatch to the records; build cardProps/cardCallbacks in view() and update the repoSection call site. Drop pre-existing dead args (renderCard repoId, worktreeCard canvasPaneOpen) and the archiveSection dispatch wrapper. Update spec Decisions with the leaf-helper-conversion note. --- docs/spec/app-fs-view-extraction.md | 18 +++ src/Client/App.fs | 211 ++++++++++++++++++---------- 2 files changed, 156 insertions(+), 73 deletions(-) diff --git a/docs/spec/app-fs-view-extraction.md b/docs/spec/app-fs-view-extraction.md index 12138759..6a609c8c 100644 --- a/docs/spec/app-fs-view-extraction.md +++ b/docs/spec/app-fs-view-extraction.md @@ -48,6 +48,24 @@ These were chosen deliberately (see *Per-family evidence* for why): already uses for `relativeTime`, `workMetricsView`, `cardTitle`, etc. — so card-side call sites stay untouched and there is a single source of truth. +### Leaf helpers take `CardCallbacks`, not `dispatch` (Step 2 implementation) + +To keep `CardViewProps`/`CardCallbacks` **Msg-free** (so they relocate ahead of `AppTypes` with +the card views in Steps 3–4), the card **leaf** helpers (`terminalButton`, `editorButton`, +`syncButton`, `eventLog`, `canvasEventEntry`, the PR badge/section helpers, etc.) were converted +from taking raw `dispatch` to taking the whole `callbacks: CardCallbacks` record — a 1:1 swap of a +single capability handle, but a strictly narrower one (it can only raise named card actions, not an +arbitrary `Msg`). The composite views (`compactWorktreeCard`/`worktreeCard`/`renderCard`/ +`repoSection`) then hold no `dispatch` at all. Consequences, all behavior-preserving: +- `terminalButton`'s `FocusSession`-vs-`OpenTerminal` choice moved into the `OpenTerminal` callback + lambda built in `view`; the button keeps only its title text. +- The `archiveSection dispatch` wrapper was removed; `repoSection` calls + `ArchiveViews.archiveSection callbacks.DispatchArchive` directly. +- Pre-existing dead args were dropped: `renderCard`'s `repoId` and `worktreeCard`'s `canvasPaneOpen` + (the model bool is still carried in `CardViewProps.CanvasPaneOpen` to preserve the 8-field shape). + +This makes Step 3 (leaf relocation) a pure file move with no further signature changes. + ### Why a vertical slice for Mascot but not Cards | Family (~size) | State owned | Msg / update owned | Disposition | diff --git a/src/Client/App.fs b/src/Client/App.fs index 8ef4038c..a79f3a9d 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -688,6 +688,48 @@ let beadsProgressBar (b: BeadsSummary) = ] ] +/// 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 [ @@ -709,7 +751,7 @@ let private providerDisplayName (provider: CodingToolProvider option) = | Some Copilot -> "Copilot" | None -> "Coding tool" -let syncButton dispatch (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = +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" @@ -725,7 +767,7 @@ let syncButton dispatch (baseBranch: string) (wt: WorktreeStatus) (branchEvents: Html.button [ prop.className "sync-cancel-btn" yield! noFocusProps - prop.onClick (fun e -> e.stopPropagation(); dispatch (CancelSync wt.Path)) + prop.onClick (fun e -> e.stopPropagation(); callbacks.CancelSync wt.Path) prop.text "Cancel" ] else @@ -733,12 +775,12 @@ let syncButton dispatch (baseBranch: string) (wt: WorktreeStatus) (branchEvents: 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.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 dispatch (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = +let mainBehindWithSync (callbacks: CardCallbacks) (baseBranch: string) (wt: WorktreeStatus) (branchEvents: CardEvent list) (isPending: bool) (scopedKey: string) = Html.div [ prop.className "main-behind-row" prop.children [ @@ -749,7 +791,7 @@ let mainBehindWithSync dispatch (baseBranch: string) (wt: WorktreeStatus) (branc prop.className "dirty-warning" prop.text "uncommitted changes" ] - else syncButton dispatch baseBranch wt branchEvents isPending scopedKey + else syncButton callbacks baseBranch wt branchEvents isPending scopedKey Html.span [ prop.className "git-commit-msg" prop.children [ @@ -803,28 +845,28 @@ let eventLogEntry (onFixTests: (unit -> unit) option) (onConfigureTests: (unit - ] ] -let eventLog dispatch (cooldowns: Set) (wtPath: WorktreePath) (hasTestFailureLog: bool) (events: CardEvent list) = +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 () -> dispatch (LaunchAction (wtPath, FixTests))) + else Some (fun () -> callbacks.LaunchAction wtPath FixTests) let onConfigureTests = if cooldowns.Contains wtPath then None - else Some (fun () -> dispatch (LaunchAction (wtPath, ConfigureTests))) + else Some (fun () -> callbacks.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 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() - dispatch (OpenCanvasDoc (scopedKey, evt.Filename))) + 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} " ] @@ -832,13 +874,13 @@ let canvasEventEntry dispatch (scopedKey: string) (evt: CanvasEvent) = ] ] -let canvasEventLog dispatch (scopedKey: string) (events: CanvasEvent list) = +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 dispatch scopedKey)) + prop.children (evts |> List.map (canvasEventEntry callbacks scopedKey)) ] let abbreviatePipelineName (repoName: string) (name: string) = @@ -894,14 +936,13 @@ let buildBadge (repoName: string) (build: BuildInfo) = | None -> () ] -let terminalButton dispatch (wt: WorktreeStatus) = - let action = if wt.HasActiveSession then FocusSession wt.Path else OpenTerminal wt.Path +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(); dispatch action) + prop.onClick (fun e -> e.stopPropagation(); callbacks.OpenTerminal wt) prop.text ">" ] @@ -917,21 +958,21 @@ let editorIcon () = ] ] -let editorButton dispatch editorName (wt: WorktreeStatus) = +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(); dispatch (OpenEditor wt.Path)) + prop.onClick (fun e -> e.stopPropagation(); callbacks.OpenEditor wt) prop.children [ editorIcon () ] ] -let newTabButton dispatch (wt: WorktreeStatus) = +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(); dispatch (OpenNewTab wt.Path)) + prop.onClick (fun e -> e.stopPropagation(); callbacks.OpenNewTab wt) prop.text "+" ] @@ -946,12 +987,12 @@ let resumeIcon () = ] ] -let resumeButton dispatch (wt: WorktreeStatus) = +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(); dispatch (ResumeSession wt.Path)) + prop.onClick (fun e -> e.stopPropagation(); callbacks.ResumeSession wt) prop.children [ resumeIcon () ] ] @@ -975,23 +1016,23 @@ let binIcon () = ] ] -let deleteButton dispatch scopedKey (wt: WorktreeStatus) = +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() - dispatch (ConfirmDeleteWorktree scopedKey)) + callbacks.DeleteWorktree scopedKey) prop.children [ binIcon () ] ] -let archiveButton dispatch scopedKey (wt: WorktreeStatus) = +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(); dispatch (ConfirmArchiveWorktree scopedKey)) + prop.onClick (fun e -> e.stopPropagation(); callbacks.ArchiveWorktree scopedKey) prop.children [ ArchiveViews.archiveIcon ] ] @@ -1009,18 +1050,18 @@ let conflictIcon () = ] ] -let prActionButton dispatch (cooldowns: Set) (wt: WorktreeStatus) (action: ActionKind) (title: string) (icon: ReactElement) = +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 dispatch (LaunchAction (wt.Path, action))) + prop.onClick (fun e -> e.stopPropagation(); if not onCooldown then callbacks.LaunchAction wt.Path action) prop.children [ icon ] ] -let prBadgeContent dispatch (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) (pr: PrInfo) = +let prBadgeContent (callbacks: CardCallbacks) (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) (pr: PrInfo) = React.fragment [ if pr.IsMerged then Interop.createElement "a" [ @@ -1048,36 +1089,36 @@ let prBadgeContent dispatch (cooldowns: Set) (wt: WorktreeStatus) prop.text ($"{unresolved}/{total} threads") ] if unresolved > 0 then - prActionButton dispatch cooldowns wt (FixPr pr.Url) "Fix PR comments" commentIcon + 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 dispatch cooldowns wt (FixBuild url) "Fix build" wrenchIcon + | Some url -> prActionButton callbacks cooldowns wt (FixBuild url) "Fix build" wrenchIcon | None -> () ]) ] -let prSection dispatch (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = +let prSection (callbacks: CardCallbacks) (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = match wt.Pr with | NoPr -> Html.none - | HasPr pr -> prBadgeContent dispatch cooldowns wt repoName pr + | HasPr pr -> prBadgeContent callbacks cooldowns wt repoName pr -let prRow dispatch (cooldowns: Set) (wt: WorktreeStatus) (repoName: string) = +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 dispatch cooldowns wt CreatePr "Create PR" createPrIcon + prActionButton callbacks cooldowns wt CreatePr "Create PR" createPrIcon ] ] | HasPr pr, _ -> Html.div [ prop.className "pr-row" - prop.children [ prBadgeContent dispatch cooldowns wt repoName pr ] + prop.children [ prBadgeContent callbacks cooldowns wt repoName pr ] ] let workMetricsView = Components.workMetricsView @@ -1085,13 +1126,13 @@ 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 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 _ -> dispatch (SetFocus (Some (Card scopedKey)))) + prop.onClick (fun _ -> callbacks.FocusCard scopedKey) prop.children [ Html.div [ prop.className "card-header" @@ -1105,12 +1146,12 @@ let compactWorktreeCard dispatch editorName (repoName: string) (baseBranch: stri ] ] 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 + 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 [ @@ -1118,13 +1159,13 @@ let compactWorktreeCard dispatch editorName (repoName: string) (baseBranch: stri prop.children [ if beadsTotal wt.Beads > 0 then beadsCounts "beads-inline" wt.Beads mainBehindIndicator baseBranch wt.MainBehindCount - prSection dispatch cooldowns wt repoName + prSection callbacks props.ActionCooldowns 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 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)) @@ -1132,7 +1173,7 @@ let worktreeCard dispatch editorName (repoName: string) (baseBranch: string) (co Html.div [ prop.key (WorktreePath.value wt.Path) prop.className className - prop.onClick (fun _ -> dispatch (SetFocus (Some (Card scopedKey)))) + prop.onClick (fun _ -> callbacks.FocusCard scopedKey) prop.children [ Html.div [ prop.className "card-body" @@ -1148,12 +1189,12 @@ let worktreeCard dispatch editorName (repoName: string) (baseBranch: string) (co 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 + 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 ] ] @@ -1166,9 +1207,9 @@ let worktreeCard dispatch editorName (repoName: string) (baseBranch: string) (co ] ] - mainBehindWithSync dispatch baseBranch wt branchEvents isPending scopedKey + mainBehindWithSync callbacks baseBranch wt branchEvents isPending scopedKey - prRow dispatch cooldowns wt repoName + prRow callbacks props.ActionCooldowns wt repoName ] ] @@ -1187,23 +1228,21 @@ let worktreeCard dispatch editorName (repoName: string) (baseBranch: string) (co ] | None -> () - eventLog dispatch cooldowns wt.Path wt.HasTestFailureLog branchEvents - canvasEventLog dispatch scopedKey canvasEvents + eventLog callbacks props.ActionCooldowns wt.Path wt.HasTestFailureLog branchEvents + canvasEventLog callbacks 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 renderCard (props: CardViewProps) (callbacks: CardCallbacks) (repoName: string) (baseBranch: string) (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 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 [ @@ -1425,14 +1464,14 @@ let providerIcon (provider: RepoProvider option) = prop.children [ icon (0, 0, 18, 18) azdoPath ] ] -let repoSectionHeader dispatch (focusedElement: FocusTarget option) (repo: RepoModel) = +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 _ -> dispatch (ToggleCollapse repo.RepoId)) + 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 ] @@ -1450,27 +1489,27 @@ let repoSectionHeader dispatch (focusedElement: FocusTarget option) (repo: RepoM Html.button [ prop.className "create-wt-btn" prop.title "Create worktree" - prop.onClick (fun e -> e.stopPropagation(); dispatch (ModalMsg (CreateWorktreeModal.OpenCreateWorktree repo.RepoId))) + prop.onClick (fun e -> e.stopPropagation(); callbacks.CreateWorktree repo.RepoId) prop.text "+" ] ] ] -let repoSection dispatch editorName isCompact (focusedElement: FocusTarget option) (branchEvents: Map) (syncPending: Set) (cooldowns: Set) (canvasEvents: Map) (canvasPaneOpen: bool) (repo: RepoModel) = +let repoSection (props: CardViewProps) (callbacks: CardCallbacks) (repo: RepoModel) = Html.div [ prop.key (RepoId.value repo.RepoId) prop.className "repo-section" prop.children [ - repoSectionHeader dispatch focusedElement repo + 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 dispatch editorName isCompact focusedElement (RepoId.value repo.RepoId) repo.Name repo.BaseBranch branchEvents syncPending cooldowns canvasEvents canvasPaneOpen)) + prop.children (repo.Worktrees |> List.map (renderCard props callbacks repo.Name repo.BaseBranch)) ] - archiveSection dispatch repo.ArchivedWorktrees + ArchiveViews.archiveSection callbacks.DispatchArchive repo.ArchivedWorktrees ] ] @@ -1613,6 +1652,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 @@ -1636,7 +1701,7 @@ 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)) ] OverviewViews.schedulerFooter model.Repos model.SchedulerEvents model.LatestByCategory From eb02fa2273de82a4ebc126085edda930eb434403 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 19:06:44 +0200 Subject: [PATCH 03/11] tm-code-improvement-txs Relocate card leaf helpers/icons/badges into CardViews.fs Created src/Client/CardViews.fs (module CardViews) holding the CardViewProps/ CardCallbacks records plus all card leaf helpers moved verbatim from App.fs: icons, action buttons, beads/build badges, sync helpers, event-log and PR helpers, class/text/format helpers, and canvasEventEntry/canvasEventLog. CardViews.fs compiles before AppTypes.fs. App.fs adds 'open CardViews' and drops the now-dead stepStatusClassName/stepStatusText aliases. Composite card views intentionally remain in App.fs for Step 4. --- src/Client/App.fs | 501 +------------------------------------- src/Client/CardViews.fs | 504 +++++++++++++++++++++++++++++++++++++++ src/Client/Client.fsproj | 1 + 3 files changed, 506 insertions(+), 500 deletions(-) create mode 100644 src/Client/CardViews.fs diff --git a/src/Client/App.fs b/src/Client/App.fs index a79f3a9d..45100ce9 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 () = @@ -619,508 +620,8 @@ let appSubscriptions (model: Model) : Sub = 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)) ] - ] - ] - ] - -/// 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 stepStatusClassName = Components.stepStatusClassName - -let stepStatusText = Components.stepStatusText - let relativeEventTime = Components.relativeEventTime -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 workMetricsView = Components.workMetricsView let workMetricsItems = Components.workMetricsItems let FitOrHide = Components.FitOrHide diff --git a/src/Client/CardViews.fs b/src/Client/CardViews.fs new file mode 100644 index 00000000..c053a576 --- /dev/null +++ b/src/Client/CardViews.fs @@ -0,0 +1,504 @@ +module CardViews + +open Shared +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 ] + ] diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index 2283c8c0..12cc9c4d 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -16,6 +16,7 @@ + From 3ee0158da5a6a46b0038d8bf596c716e8dcb39c6 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 19:37:52 +0200 Subject: [PATCH 04/11] tm-code-improvement-vx8 Relocate composite card views into CardViews.fs and wire view() Move 10 composite card defs (canResumeSession, compactWorktreeCard, worktreeCard, renderCard, skeletonCard/skeletonGrid, sortLabel, providerIcon, repoSectionHeader, repoSection) verbatim from App.fs into CardViews.fs; drop 6 now-dead Components aliases. view() call sites resolve via existing 'open CardViews'. --- src/Client/App.fs | 239 ---------------------------------------- src/Client/CardViews.fs | 231 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 231 insertions(+), 239 deletions(-) diff --git a/src/Client/App.fs b/src/Client/App.fs index 45100ce9..51d3a3af 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -82,12 +82,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 @@ -618,160 +612,6 @@ let appSubscriptions (model: Model) : Sub = else subs -let relativeTime = Components.relativeTime - -let relativeEventTime = Components.relativeEventTime - -let workMetricsView = Components.workMetricsView -let workMetricsItems = Components.workMetricsItems -let FitOrHide = Components.FitOrHide -let cardTitle = Components.cardTitle - -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 viewEyeOpen (pupilColor: string) (activity: ActivityLevel) (dx: float, dy: float) = Svg.svg [ svg.className "eye-logo" @@ -935,85 +775,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 (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 - ] - ] - let barColor (pct: float) = if pct >= 80.0 then "#f38ba8" elif pct >= 50.0 then "#f9e2af" diff --git a/src/Client/CardViews.fs b/src/Client/CardViews.fs index c053a576..fe43b355 100644 --- a/src/Client/CardViews.fs +++ b/src/Client/CardViews.fs @@ -1,6 +1,7 @@ module CardViews open Shared +open Shared.EventUtils open Navigation open Feliz open Components @@ -502,3 +503,233 @@ let prRow (callbacks: CardCallbacks) (cooldowns: Set) (wt: Worktre 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 + ] + ] From 0b838545d7d5c884b1997a36d22b66b2f235cf62 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 20:03:52 +0200 Subject: [PATCH 05/11] tm-code-improvement-7t6 Extract MascotState.fs sub-state (reshape Model.Mascot) Introduce MascotState sub-state (EyeDirection/LastActivityTime/ActivityLevel + empty, randomEyeDirection, computeActivityLevel, idle thresholds) compiled before AppTypes. Embed as Model.Mascot (drop the 3 flat fields) and repoint init/DataLoaded/Tick/UserActivity/appSubscriptions/header to model.Mascot.*. Update 4 test Model literals/reads (CanvasAwareness, ConfirmModal, CreateWorktree, IdleDetection). --- src/Client/App.fs | 43 ++++++++-------------------- src/Client/AppTypes.fs | 4 +-- src/Client/Client.fsproj | 1 + src/Client/MascotState.fs | 47 +++++++++++++++++++++++++++++++ src/Tests/CanvasAwarenessTests.fs | 20 ++++++------- src/Tests/ConfirmModalTests.fs | 4 +-- src/Tests/CreateWorktreeTests.fs | 4 +-- src/Tests/IdleDetectionTests.fs | 16 +++++------ 8 files changed, 79 insertions(+), 60 deletions(-) create mode 100644 src/Client/MascotState.fs diff --git a/src/Client/App.fs b/src/Client/App.fs index 51d3a3af..734614a5 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -38,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 @@ -46,18 +45,10 @@ let init () = DeployBranch = None SystemMetrics = None ActionCooldowns = Set.empty - LastActivityTime = Fable.Core.JS.Constructors.Date.now () - ActivityLevel = ActivityLevel.Active + Mascot = { MascotState.empty with LastActivityTime = Fable.Core.JS.Constructors.Date.now () } 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 @@ -99,17 +90,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) -> @@ -153,7 +133,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.Mascot.LastActivityTime > MascotState.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. @@ -191,7 +171,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 @@ -282,11 +262,11 @@ 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 + let newLevel = MascotState.computeActivityLevel model.Mascot.LastActivityTime now let expiredEvents = expireCanvasEvents (System.DateTimeOffset.FromUnixTimeMilliseconds(int64 now)) model.Canvas.CanvasEvents let reportCmd = - if newLevel <> model.ActivityLevel then + if newLevel <> model.Mascot.ActivityLevel then Cmd.OfAsync.attempt worktreeApi.Value.reportActivity newLevel (fun _ -> NoOp) else Cmd.none @@ -295,11 +275,11 @@ let update msg model = // 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 Mascot = { model.Mascot with ActivityLevel = newLevel }; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, Cmd.batch [ fetchWorktrees (); fetchSyncStatus (); reportCmd ] | UserActivity now -> - let wasActive = model.ActivityLevel = ActivityLevel.Active + let wasActive = model.Mascot.ActivityLevel = ActivityLevel.Active let wakeUpCmd = if not wasActive then @@ -311,8 +291,7 @@ let update msg model = Cmd.none { model with - LastActivityTime = now - ActivityLevel = ActivityLevel.Active }, + Mascot = { model.Mascot with LastActivityTime = now; ActivityLevel = ActivityLevel.Active } }, wakeUpCmd | StartSync (path, key) -> @@ -562,12 +541,12 @@ let update msg model = let appSubscriptions (model: Model) : Sub = let pollingIntervalMs = - match model.ActivityLevel with + match model.Mascot.ActivityLevel with | ActivityLevel.Active | ActivityLevel.Idle -> 1000 | ActivityLevel.DeepIdle -> 15000 let activityLevelKey = - match model.ActivityLevel with + match model.Mascot.ActivityLevel with | ActivityLevel.Active -> "active" | ActivityLevel.Idle -> "idle" | ActivityLevel.DeepIdle -> "deep-idle" @@ -848,7 +827,7 @@ let viewAppHeader model dispatch = if model.HasError then viewEyeRolledBack () elif hasAnyActive model.Repos then let pupilColor = if hasAnyWaiting model.Repos then "#f9e2af" else "#1a1b2e" - viewEyeOpen pupilColor model.ActivityLevel model.EyeDirection + viewEyeOpen pupilColor model.Mascot.ActivityLevel model.Mascot.EyeDirection else viewEyeClosed () ] ] diff --git a/src/Client/AppTypes.fs b/src/Client/AppTypes.fs index 3ffc40be..581854c9 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,7 @@ type Model = DeployBranch: string option SystemMetrics: SystemMetrics option ActionCooldowns: Set - LastActivityTime: float - ActivityLevel: ActivityLevel + Mascot: MascotState.MascotState Canvas: CanvasState.CanvasState } type Msg = diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index 12cc9c4d..d074065e 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -15,6 +15,7 @@ + diff --git a/src/Client/MascotState.fs b/src/Client/MascotState.fs new file mode 100644 index 00000000..4dc8a133 --- /dev/null +++ b/src/Client/MascotState.fs @@ -0,0 +1,47 @@ +module MascotState + +open Shared + +/// The mascot eyes' slice of the dashboard model. Grouped out of App.Model so the +/// mascot's owned state (gaze direction + activity tracking) and its pure helpers live +/// together, away from core worktree/repo concerns (mirrors how CanvasState nests the +/// canvas pane's state into Model). +type MascotState = + { EyeDirection: float * float + LastActivityTime: float + ActivityLevel: ActivityLevel } + +/// Initial mascot state: eyes centered, 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, the same +/// hazard that made worktreeApi lazy — see AppTypes.fs). +let empty : MascotState = + { EyeDirection = (0.0, 0.0) + LastActivityTime = 0.0 + ActivityLevel = ActivityLevel.Active } + +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) + +/// 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/Tests/CanvasAwarenessTests.fs b/src/Tests/CanvasAwarenessTests.fs index 7df2ded4..e16b4806 100644 --- a/src/Tests/CanvasAwarenessTests.fs +++ b/src/Tests/CanvasAwarenessTests.fs @@ -67,15 +67,13 @@ 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 + Mascot = MascotState.empty Canvas = CanvasState.empty } /// Calls update and returns the model, ignoring the Cmd. Tolerates the @@ -330,13 +328,13 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = 0.0 + Mascot = { defaultModel.Mascot 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.Mascot.LastActivityTime > MascotState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -353,13 +351,13 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = 0.0 + Mascot = { defaultModel.Mascot 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.Mascot.LastActivityTime > MascotState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -377,11 +375,11 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = jsNow - 10_000.0 // 10s ago, well within 60s threshold + Mascot = { defaultModel.Mascot 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.Mascot.LastActivityTime > MascotState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -397,12 +395,12 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - LastActivityTime = 0.0 + Mascot = { defaultModel.Mascot 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.Mascot.LastActivityTime > MascotState.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..33f81074 100644 --- a/src/Tests/ConfirmModalTests.fs +++ b/src/Tests/ConfirmModalTests.fs @@ -53,15 +53,13 @@ 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 + 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..02611571 100644 --- a/src/Tests/CreateWorktreeTests.fs +++ b/src/Tests/CreateWorktreeTests.fs @@ -26,15 +26,13 @@ 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 + 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..966b72f8 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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.computeActivityLevel (nowMs - 3_600_000.0) nowMs, Is.EqualTo(ActivityLevel.DeepIdle)) From 80159f835e47fb496c8bb074a4d8827fa468cc78 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 20:28:16 +0200 Subject: [PATCH 06/11] tm-code-improvement-8ic Extract MascotView.fs + MascotUpdate.fs (mascot slice) MascotView.fs (before AppTypes): viewEyeOpen reshaped to take a MascotState slice; viewEyeRolledBack/viewEyeClosed verbatim. Header wired to MascotView.*. MascotUpdate.fs (after CanvasUpdate.fs): tickActivity + userActivity arm bodies and the activityDetection subscription. Root update delegates (flat Msg kept; Tick stays in root for canvas-event expiry + poll). appSubscriptions points to MascotUpdate.activityDetection. Behavior-preserving extraction. --- src/Client/App.fs | 202 ++----------------------------------- src/Client/Client.fsproj | 2 + src/Client/MascotUpdate.fs | 68 +++++++++++++ src/Client/MascotView.fs | 163 ++++++++++++++++++++++++++++++ 4 files changed, 242 insertions(+), 193 deletions(-) create mode 100644 src/Client/MascotUpdate.fs create mode 100644 src/Client/MascotView.fs diff --git a/src/Client/App.fs b/src/Client/App.fs index 734614a5..f2052206 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -262,37 +262,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 = MascotState.computeActivityLevel model.Mascot.LastActivityTime now + // Tick stays in the root update because it also expires canvas events and drives the + // worktree/sync poll; only the mascot activity-recompute delegates to MascotUpdate. + let mascot, reportCmd = MascotUpdate.tickActivity now model.Mascot let expiredEvents = expireCanvasEvents (System.DateTimeOffset.FromUnixTimeMilliseconds(int64 now)) model.Canvas.CanvasEvents - let reportCmd = - if newLevel <> model.Mascot.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 Mascot = { model.Mascot with ActivityLevel = newLevel }; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, + { model with Mascot = mascot; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, Cmd.batch [ fetchWorktrees (); fetchSyncStatus (); reportCmd ] - | UserActivity now -> - let wasActive = model.Mascot.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 - Mascot = { model.Mascot with LastActivityTime = now; ActivityLevel = ActivityLevel.Active } }, - wakeUpCmd + | UserActivity now -> MascotUpdate.userActivity now model | StartSync (path, key) -> let syntheticEvent = @@ -563,27 +545,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" ], MascotUpdate.activityDetection [ "canvas-messages" ], CanvasUpdate.messageListener ] if hasSyncRunning model.BranchEvents then @@ -591,154 +555,6 @@ let appSubscriptions (model: Model) : Sub = else subs -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 -> @@ -824,11 +640,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.Mascot.ActivityLevel model.Mascot.EyeDirection - else viewEyeClosed () + MascotView.viewEyeOpen pupilColor model.Mascot + else MascotView.viewEyeClosed () ] ] Html.div [ diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index d074065e..7fde994f 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -16,10 +16,12 @@ + + diff --git a/src/Client/MascotUpdate.fs b/src/Client/MascotUpdate.fs new file mode 100644 index 00000000..6cd12e84 --- /dev/null +++ b/src/Client/MascotUpdate.fs @@ -0,0 +1,68 @@ +module MascotUpdate + +// Mascot update-arm bodies plus the activity-detection subscription, extracted from `App.fs`. +// Mirrors `CanvasUpdate.fs`: this is 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 +// mascot activity-recompute lifts here. Compiled after `AppTypes.fs` (which holds `Model`/`Msg`) +// and before `App.fs`. See docs/spec/app-fs-view-extraction.md. + +open Shared +open Elmish +open Browser +open AppTypes + +/// `Tick` activity-recompute: derive the mascot's new `ActivityLevel` from the elapsed idle time +/// and emit a presence report only when it actually changed. Returns the updated mascot 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) (mascot: MascotState.MascotState) : MascotState.MascotState * Cmd = + let newLevel = MascotState.computeActivityLevel mascot.LastActivityTime now + + let reportCmd = + if newLevel <> mascot.ActivityLevel then + Cmd.OfAsync.attempt worktreeApi.Value.reportActivity newLevel (fun _ -> NoOp) + else + Cmd.none + + { mascot 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.Mascot.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 + Mascot = { model.Mascot 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 mascot's entry in `appSubscriptions`. +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)) } diff --git a/src/Client/MascotView.fs b/src/Client/MascotView.fs new file mode 100644 index 00000000..19245e5a --- /dev/null +++ b/src/Client/MascotView.fs @@ -0,0 +1,163 @@ +module MascotView + +// The mascot eye SVGs, extracted from `App.fs`. Pure render functions over the mascot's own +// `MascotState` slice (gaze direction + activity level) so the eyes' view sits next to their +// state and update (`MascotState.fs`/`MascotUpdate.fs`), mirroring the canvas slice. Compiled +// before `AppTypes.fs`, so these depend only on `Shared`/`Feliz` and the `MascotState` record — +// never on `Model`/`Msg`. See docs/spec/app-fs-view-extraction.md. + +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 and the half/closed lid overlay come from the +/// `MascotState` slice's `EyeDirection` and `ActivityLevel`. +let viewEyeOpen (pupilColor: string) (mascot: MascotState.MascotState) = + let (dx, dy) = mascot.EyeDirection + let activity = mascot.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 + ] + ] + ] From fe9f27375addb997ea794a9ab9d5024324a03d82 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 19 Jun 2026 20:53:52 +0200 Subject: [PATCH 07/11] tm-code-improvement-3ay Extract CanvasView.fs (canvas-pane wiring, Opportunity B) Move focusedWorktreeCanvasDoc + the canvas-pane wiring block out of App.fs's view into a new CanvasView.fs module exposing view(model, dispatch). Registered in Client.fsproj after MascotUpdate.fs, before App.fs. App.fs 847->794 lines; pure mechanical relocation, no behavior change. --- src/Client/App.fs | 55 +--------------------------- src/Client/CanvasView.fs | 77 ++++++++++++++++++++++++++++++++++++++++ src/Client/Client.fsproj | 1 + 3 files changed, 79 insertions(+), 54 deletions(-) create mode 100644 src/Client/CanvasView.fs diff --git a/src/Client/App.fs b/src/Client/App.fs index f2052206..3d3dc2ac 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -580,14 +580,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" @@ -768,53 +760,8 @@ let view model 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 } - 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/CanvasView.fs b/src/Client/CanvasView.fs new file mode 100644 index 00000000..6991925d --- /dev/null +++ b/src/Client/CanvasView.fs @@ -0,0 +1,77 @@ +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. See +// docs/spec/app-fs-view-extraction.md. + +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/Client.fsproj b/src/Client/Client.fsproj index 7fde994f..4cfccb6d 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -22,6 +22,7 @@ + From 6bf0c909a33bde54138aa10ab46fcf9ec74edb4f Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 22 Jun 2026 09:29:30 +0200 Subject: [PATCH 08/11] Fix immutability rule (let mutable over ref) and delete one-off extraction specs - review/rules/immutability.md: never recommend or use a ref cell to dodge the rule; let mutable is the sanctioned mechanism when mutation is justified, and must carry an inline comment explaining why an immutable solution doesn't fit. - MascotUpdate.fs: document the throttle-closure let mutable (per user-idle-detection). - Delete docs/spec/app-fs-view-extraction.md and its future/ companion (red-flag one-off -extraction filenames; feature complete). Strip dangling spec refs from CanvasView/MascotView/MascotUpdate headers and fix the dead link in canvas-pane.md. --- docs/spec/app-fs-view-extraction.md | 157 --------------------- docs/spec/canvas-pane.md | 2 +- docs/spec/future/app-fs-view-extraction.md | 139 ------------------ review/rules/immutability.md | 21 ++- src/Client/CanvasView.fs | 3 +- src/Client/MascotUpdate.fs | 5 +- src/Client/MascotView.fs | 2 +- 7 files changed, 26 insertions(+), 303 deletions(-) delete mode 100644 docs/spec/app-fs-view-extraction.md delete mode 100644 docs/spec/future/app-fs-view-extraction.md diff --git a/docs/spec/app-fs-view-extraction.md b/docs/spec/app-fs-view-extraction.md deleted file mode 100644 index 6a609c8c..00000000 --- a/docs/spec/app-fs-view-extraction.md +++ /dev/null @@ -1,157 +0,0 @@ -# App.fs View Extraction - -Status: **Active** — design decided, ready for execution. Supersedes -`docs/spec/future/app-fs-view-extraction.md` (kept for provenance/sizing history). - -## Goals - -- Shrink `src/Client/App.fs` (currently **1685 lines**) by relocating its pure-render - view families into focused modules — **and make the architecture strictly better**, not - merely shorter. -- Replace the loose-parameter smell in the card views (`repoSection` takes **9 positional - args**) with explicit data/callback records. -- Promote the one feature that genuinely owns cohesive state + behavior (the mascot eyes) - into a proper vertical slice, mirroring the established canvas seam. -- Zero behavior change. The existing test/E2E suite stays green at every step; tests assert - on CSS classes and DOM structure, so identical render output proves correctness. - -## Decisions - -These were chosen deliberately (see *Per-family evidence* for why): - -1. **Evidence-driven hybrid, not one-size-fits-all.** Vertical-slice only where a feature - owns separable state+behavior (Mascot); props/callback records for render-over-shared-state - (Cards); plain pure-view extraction where there is no owned state at all (Overview). - Forcing sub-states onto Cards/Overview would invent leaky boundaries. -2. **Cards get `CardViewProps` + `CardCallbacks` records**, mirroring `CanvasPaneCallbacks`. - This is the central quality win: it kills the 9-arg signature, makes card data flow - explicit, and lets canvas slices ride along (which unblocks decision 5). -3. **Mascot becomes a vertical slice**: `MascotState` sub-state + `MascotView` + `MascotUpdate`, - exactly like `CanvasState`/`CanvasUpdate`/`CanvasPane`. `Tick`/`UserActivity` arm *bodies* - delegate to `MascotUpdate`; the arms stay in the root `update`. -4. **Flat `Msg` + single `update` are preserved.** No nested sub-`Msg`, no `Cmd.map` - sub-component split. Arm bodies move into `Update` modules; the `match` stays in - `App.fs`. This is consistent with the existing canvas decision (see `AppTypes.fs` header). -5. **Canvas card-view (Opportunity B) is included now.** Once cards take a props record, the - canvas-pane wiring lifts cleanly into `CanvasView.fs` in the same pass instead of - re-touching card signatures later. -6. **Sequencing**: Overview → Cards → Mascot → CanvasView. Overview first because it is the - smallest and proves the extraction seam; each step keeps the build and tests green. -7. **Shared status/time formatters live in `Components.fs`, not the view modules.** - `stepStatusClassName`, `stepStatusText`, and `relativeEventTime` are pure, Shared-only - formatters consumed by *both* the overview rows (Step 1) and the card / event-log views - (Steps 3–4). Because `OverviewViews.fs` compiles before `AppTypes` (and before - `CardViews.fs`), it cannot reach them where they previously sat in `App.fs`. Per the - "reuse, don't duplicate — check `Components.fs`" guidance, they were relocated into - `Components.fs` (which already hosts the sibling `relativeTime` / `cardTitle` formatters). - `App.fs` keeps thin `let x = Components.x` re-export aliases — the existing pattern it - already uses for `relativeTime`, `workMetricsView`, `cardTitle`, etc. — so card-side call - sites stay untouched and there is a single source of truth. - -### Leaf helpers take `CardCallbacks`, not `dispatch` (Step 2 implementation) - -To keep `CardViewProps`/`CardCallbacks` **Msg-free** (so they relocate ahead of `AppTypes` with -the card views in Steps 3–4), the card **leaf** helpers (`terminalButton`, `editorButton`, -`syncButton`, `eventLog`, `canvasEventEntry`, the PR badge/section helpers, etc.) were converted -from taking raw `dispatch` to taking the whole `callbacks: CardCallbacks` record — a 1:1 swap of a -single capability handle, but a strictly narrower one (it can only raise named card actions, not an -arbitrary `Msg`). The composite views (`compactWorktreeCard`/`worktreeCard`/`renderCard`/ -`repoSection`) then hold no `dispatch` at all. Consequences, all behavior-preserving: -- `terminalButton`'s `FocusSession`-vs-`OpenTerminal` choice moved into the `OpenTerminal` callback - lambda built in `view`; the button keeps only its title text. -- The `archiveSection dispatch` wrapper was removed; `repoSection` calls - `ArchiveViews.archiveSection callbacks.DispatchArchive` directly. -- Pre-existing dead args were dropped: `renderCard`'s `repoId` and `worktreeCard`'s `canvasPaneOpen` - (the model bool is still carried in `CardViewProps.CanvasPaneOpen` to preserve the 8-field shape). - -This makes Step 3 (leaf relocation) a pure file move with no further signature changes. - -### Why a vertical slice for Mascot but not Cards - -| Family (~size) | State owned | Msg / update owned | Disposition | -|---|---|---|---| -| **Cards** (~650 ln) | none exclusive — reads 8 shared fields (`EditorName`, `IsCompact`, `FocusedElement`, `BranchEvents`, `SyncPending`, `ActionCooldowns`, `Canvas.CanvasEvents`, `Canvas.CanvasPaneOpen`) | ~19 update arms, but they are **core app behavior** (sync/delete/archive/launch/resume); focus + keyboard nav (`FocusedElement`/`KeyPressed`) is **shared** with canvas & overview | **Pure view + `CardViewProps`/`CardCallbacks` records.** Behavior is not separable. | -| **Mascot** (~190 ln) | `EyeDirection`, `LastActivityTime`, `ActivityLevel` (exclusive) | `Tick`, `UserActivity` + activity subscriptions. Edge case: `Tick` also expires canvas events; `ActivityLevel` also drives refresh-poll cadence | **Vertical slice.** `Tick` stays in root update (shared) but delegates the activity recompute to `MascotUpdate`. | -| **Overview / footer** (~100 ln) | reads `SchedulerEvents`, `LatestByCategory`, `Repos` | **none** — zero dedicated arms | **Pure view**, plain params. | -| **Canvas card-view** (Opp B) | reads `Canvas.*` slices | update already extracted (`CanvasUpdate.fs`) | Lift pane wiring into `CanvasView.fs`. | - -## Expected Behavior - -- The dashboard renders byte-for-byte identically before and after — same DOM, same CSS - classes, same interactions. No user-visible change. -- `App.fs` is reduced to orchestration: `init`, the `update` `match` (with arm bodies - delegating to feature `*Update` modules), `appSubscriptions`, and the top-level `view` - wiring. Target: roughly half — about **800 lines**, down from **1685** (the six new modules - absorb the ~900 lines of relocated view/state/update code). -- The Fable client build succeeds and the full test suite (Unit + Fast + E2E) passes after - **each** task, not just at the end. - -## Technical Approach - -New modules and their compilation placement in `src/Client/Client.fsproj` -(before-`AppTypes` modules are pure and take slices/records; after-`AppTypes` modules -reference `Model`/`Msg`, like `CanvasUpdate.fs`): - -| New module | Compiles | Holds | -|---|---|---| -| `OverviewViews.fs` | before `AppTypes` | `statusOverviewRow`, `pinnedErrorEntry`, `schedulerFooter`, and path-prefix helpers (`knownCategories`, `categoryDisplayName`, `lastSepIndex`, `commonPathPrefix`, `stripPrefix`) | -| `CardViews.fs` | before `AppTypes` | `CardViewProps` + `CardCallbacks` records; all card render functions, action buttons, icons, badges, PR/sync/event-log helpers, `repoSection`, `repoSectionHeader`, skeletons; per-worktree `canvasEventEntry`/`canvasEventLog` (card-embedded) | -| `MascotState.fs` | before `AppTypes` (next to `CanvasState.fs`) | `MascotState` record (`EyeDirection`, `LastActivityTime`, `ActivityLevel`), `empty`, and pure helpers `computeActivityLevel`, `randomEyeDirection`, idle thresholds | -| `MascotView.fs` | before `AppTypes` | `viewEyeOpen`/`viewEyeRolledBack`/`viewEyeClosed`, taking a `MascotState` slice | -| `MascotUpdate.fs` | after `AppTypes` (next to `CanvasUpdate.fs`) | `Tick`/`UserActivity` activity-recompute bodies + the subscription helper | -| `CanvasView.fs` | after `CanvasUpdate.fs`, before `App.fs` | `focusedWorktreeCanvasDoc` + the canvas-pane wiring block (builds `CanvasPaneCallbacks`, computes focused unviewed/visited docs, calls `CanvasPane.view`) | - -Record shapes (illustrative — finalize during implementation): - -- `CardViewProps` = the read slice currently threaded as loose args (`EditorName`, `IsCompact`, - `FocusedElement`, `BranchEvents`, `SyncPending`, `ActionCooldowns`, `CanvasEvents`, - `CanvasPaneOpen`). No `Model` dependency — Shared/Navigation types only. -- `CardCallbacks` = the dispatch-derived actions cards trigger (terminal, editor, new-tab, - resume, delete, archive, sync, launch-action, focus, toggle-collapse, PR action). Plain - `… -> unit` functions — no `Msg` dependency. `App.fs` constructs both records in `view` - from `model` and `dispatch`. - -**Reuse, don't duplicate.** Before relocating helpers, check `Components.fs` and -`ActionButtons.fs` (already holds `noFocusProps`, `commentIcon`, `wrenchIcon`, `createPrIcon`) -and route through existing helpers; move shared icons there rather than copying. - -**Each task ends green.** Relocations are cut/paste + `open`/namespace adjustments plus the -`.fsproj` `` entry; no logic edits. Before marking a task done, run the per-step -green check: `npm run build` plus `dotnet test src/Tests/Tests.fsproj --filter "Category=Unit"` -and `--filter "Category=Fast"`. The heavier E2E suite (`--filter "Category=E2E"`) runs in the -final verify task. - -## Task Sequence - -1. `OverviewViews.fs` — pure relocation (proves the seam). -2. `CardViewProps` + `CardCallbacks` records — define them and refactor the **in-place** card - views + the `view` call site to use them (no file move yet). -3. Relocate card **leaf** helpers (icons, action buttons, badges, sync/event-log/PR helpers, - class/text/format helpers, `canvasEventEntry`/`canvasEventLog`) into `CardViews.fs`. -4. Relocate **composite** card views (`compactWorktreeCard`, `worktreeCard`, `renderCard`, - `repoSectionHeader`, `repoSection`, skeletons, `providerIcon`, `sortLabel`) into - `CardViews.fs` and wire `view` to call `CardViews.repoSection` with the records. -5. `MascotState.fs` — introduce the sub-state, embed as `Model.Mascot`, and repoint `init`, - `DataLoaded`, `Tick`, `UserActivity`, `appSubscriptions`, and the header to `model.Mascot.*`. -6. `MascotView.fs` + `MascotUpdate.fs` — move the eye views and the `Tick`/`UserActivity` - bodies; wire the header to `MascotView` and the arms to delegate to `MascotUpdate`. -7. `CanvasView.fs` — lift `focusedWorktreeCanvasDoc` + the canvas-pane wiring block out of - `view`. - -Tasks are chained (each blocks the next) to honor the order and to serialize edits to the -shared `App.fs`, avoiding self-conflicts. - -## Key Files - -- **Primary**: `src/Client/App.fs`, `src/Client/Client.fsproj`. -- **Referenced patterns**: `src/Client/CanvasState.fs`, `src/Client/CanvasUpdate.fs`, - `src/Client/CanvasPane.fs` (the vertical-slice + callback-record precedent), - `src/Client/AppTypes.fs` (root `Model`/`Msg`; flat-`Msg` decision). -- **Reuse targets**: `src/Client/Components.fs`, `src/Client/ActionButtons.fs`. - -## Provenance - -Activates and supersedes `docs/spec/future/app-fs-view-extraction.md`, which framed the same -work as deferred "Opportunity A" (pre-existing view bulk) and "Opportunity B" (canvas view -layer). This spec carries the design decisions (records, mascot slice, sequencing) that the -deferred note left open. diff --git a/docs/spec/canvas-pane.md b/docs/spec/canvas-pane.md index 1a6ceabe..98bf7cbb 100644 --- a/docs/spec/canvas-pane.md +++ b/docs/spec/canvas-pane.md @@ -196,7 +196,7 @@ Three layers of state preservation: - **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. +- **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/future/app-fs-view-extraction.md b/docs/spec/future/app-fs-view-extraction.md deleted file mode 100644 index 57d2d528..00000000 --- a/docs/spec/future/app-fs-view-extraction.md +++ /dev/null @@ -1,139 +0,0 @@ -# App.fs View Extraction - -Status: **Activated** — see `docs/spec/app-fs-view-extraction.md` for the authoritative, -decided plan. This document is retained for provenance and the original sizing/opportunity -analysis (Opportunity A / B framing). - -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/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/CanvasView.fs b/src/Client/CanvasView.fs index 6991925d..c599af3e 100644 --- a/src/Client/CanvasView.fs +++ b/src/Client/CanvasView.fs @@ -5,8 +5,7 @@ module CanvasView // 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. See -// docs/spec/app-fs-view-extraction.md. +// `CanvasView.view model dispatch` in place of the inlined block. open Shared open Navigation diff --git a/src/Client/MascotUpdate.fs b/src/Client/MascotUpdate.fs index 6cd12e84..765586d1 100644 --- a/src/Client/MascotUpdate.fs +++ b/src/Client/MascotUpdate.fs @@ -5,7 +5,7 @@ module MascotUpdate // `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 // mascot activity-recompute lifts here. Compiled after `AppTypes.fs` (which holds `Model`/`Msg`) -// and before `App.fs`. See docs/spec/app-fs-view-extraction.md. +// and before `App.fs`. open Shared open Elmish @@ -50,6 +50,9 @@ let userActivity (now: float) (model: Model) : Model * Cmd = /// (mousemove/keydown/click/scroll), throttled to once per 5s, and removes its listeners on /// dispose. Mirrors `CanvasUpdate.messageListener` as the mascot's 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 diff --git a/src/Client/MascotView.fs b/src/Client/MascotView.fs index 19245e5a..6addeaf6 100644 --- a/src/Client/MascotView.fs +++ b/src/Client/MascotView.fs @@ -4,7 +4,7 @@ module MascotView // `MascotState` slice (gaze direction + activity level) so the eyes' view sits next to their // state and update (`MascotState.fs`/`MascotUpdate.fs`), mirroring the canvas slice. Compiled // before `AppTypes.fs`, so these depend only on `Shared`/`Feliz` and the `MascotState` record — -// never on `Model`/`Msg`. See docs/spec/app-fs-view-extraction.md. +// never on `Model`/`Msg`. open Shared open Feliz From 7f223722b11c374c109e33862436a9180b50faa0 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 22 Jun 2026 11:10:51 +0200 Subject: [PATCH 09/11] Split activity state from mascot Move idle detection and activity updates into ActivityState and ActivityUpdate. Keep mascot state to gaze only and pass observed ActivityLevel into the eye view. Repoint tests and remove MascotUpdate. --- src/Client/ActivityState.fs | 36 +++++++++++++++++ .../{MascotUpdate.fs => ActivityUpdate.fs} | 36 ++++++++--------- src/Client/App.fs | 21 +++++----- src/Client/AppTypes.fs | 1 + src/Client/Client.fsproj | 3 +- src/Client/MascotState.fs | 39 +++---------------- src/Client/MascotView.fs | 18 ++++----- src/Tests/CanvasAwarenessTests.fs | 17 ++++---- src/Tests/ConfirmModalTests.fs | 1 + src/Tests/CreateWorktreeTests.fs | 1 + src/Tests/IdleDetectionTests.fs | 16 ++++---- 11 files changed, 101 insertions(+), 88 deletions(-) create mode 100644 src/Client/ActivityState.fs rename src/Client/{MascotUpdate.fs => ActivityUpdate.fs} (57%) 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/MascotUpdate.fs b/src/Client/ActivityUpdate.fs similarity index 57% rename from src/Client/MascotUpdate.fs rename to src/Client/ActivityUpdate.fs index 765586d1..af01c832 100644 --- a/src/Client/MascotUpdate.fs +++ b/src/Client/ActivityUpdate.fs @@ -1,37 +1,37 @@ -module MascotUpdate +module ActivityUpdate -// Mascot update-arm bodies plus the activity-detection subscription, extracted from `App.fs`. -// Mirrors `CanvasUpdate.fs`: this is 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 -// mascot activity-recompute lifts here. Compiled after `AppTypes.fs` (which holds `Model`/`Msg`) -// and before `App.fs`. +// 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 mascot's new `ActivityLevel` from the elapsed idle time -/// and emit a presence report only when it actually changed. Returns the updated mascot 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) (mascot: MascotState.MascotState) : MascotState.MascotState * Cmd = - let newLevel = MascotState.computeActivityLevel mascot.LastActivityTime now +/// `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 <> mascot.ActivityLevel then + if newLevel <> activity.ActivityLevel then Cmd.OfAsync.attempt worktreeApi.Value.reportActivity newLevel (fun _ -> NoOp) else Cmd.none - { mascot with ActivityLevel = newLevel }, reportCmd + { 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.Mascot.ActivityLevel = ActivityLevel.Active + let wasActive = model.Activity.ActivityLevel = ActivityLevel.Active let wakeUpCmd = if not wasActive then @@ -43,12 +43,12 @@ let userActivity (now: float) (model: Model) : Model * Cmd = Cmd.none { model with - Mascot = { model.Mascot with LastActivityTime = now; ActivityLevel = ActivityLevel.Active } }, + 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 mascot's entry in `appSubscriptions`. +/// 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 diff --git a/src/Client/App.fs b/src/Client/App.fs index 3d3dc2ac..ed59de46 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -45,7 +45,8 @@ let init () = DeployBranch = None SystemMetrics = None ActionCooldowns = Set.empty - Mascot = { MascotState.empty with LastActivityTime = Fable.Core.JS.Constructors.Date.now () } + 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 ] @@ -133,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.Mascot.LastActivityTime > MascotState.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. @@ -263,18 +264,18 @@ let update msg model = | Tick now -> // Tick stays in the root update because it also expires canvas events and drives the - // worktree/sync poll; only the mascot activity-recompute delegates to MascotUpdate. - let mascot, reportCmd = MascotUpdate.tickActivity now model.Mascot + // 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 // 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 Mascot = mascot; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, + { model with Activity = activity; Canvas = { model.Canvas with CanvasEvents = expiredEvents } }, Cmd.batch [ fetchWorktrees (); fetchSyncStatus (); reportCmd ] - | UserActivity now -> MascotUpdate.userActivity now model + | UserActivity now -> ActivityUpdate.userActivity now model | StartSync (path, key) -> let syntheticEvent = @@ -523,12 +524,12 @@ let update msg model = let appSubscriptions (model: Model) : Sub = let pollingIntervalMs = - match model.Mascot.ActivityLevel with + match model.Activity.ActivityLevel with | ActivityLevel.Active | ActivityLevel.Idle -> 1000 | ActivityLevel.DeepIdle -> 15000 let activityLevelKey = - match model.Mascot.ActivityLevel with + match model.Activity.ActivityLevel with | ActivityLevel.Active -> "active" | ActivityLevel.Idle -> "idle" | ActivityLevel.DeepIdle -> "deep-idle" @@ -547,7 +548,7 @@ let appSubscriptions (model: Model) : Sub = let subs = [ [ "polling"; activityLevelKey ], worktreePolling - [ "activity" ], MascotUpdate.activityDetection + [ "activity" ], ActivityUpdate.activityDetection [ "canvas-messages" ], CanvasUpdate.messageListener ] if hasSyncRunning model.BranchEvents then @@ -635,7 +636,7 @@ let viewAppHeader model dispatch = if model.HasError then MascotView.viewEyeRolledBack () elif hasAnyActive model.Repos then let pupilColor = if hasAnyWaiting model.Repos then "#f9e2af" else "#1a1b2e" - MascotView.viewEyeOpen pupilColor model.Mascot + MascotView.viewEyeOpen pupilColor model.Activity.ActivityLevel model.Mascot.EyeDirection else MascotView.viewEyeClosed () ] ] diff --git a/src/Client/AppTypes.fs b/src/Client/AppTypes.fs index 581854c9..d16ee3b0 100644 --- a/src/Client/AppTypes.fs +++ b/src/Client/AppTypes.fs @@ -32,6 +32,7 @@ type Model = DeployBranch: string option SystemMetrics: SystemMetrics option ActionCooldowns: Set + Activity: ActivityState.ActivityState Mascot: MascotState.MascotState Canvas: CanvasState.CanvasState } diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index 4cfccb6d..6852c1ad 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -17,11 +17,12 @@ + - + diff --git a/src/Client/MascotState.fs b/src/Client/MascotState.fs index 4dc8a133..480bf710 100644 --- a/src/Client/MascotState.fs +++ b/src/Client/MascotState.fs @@ -1,24 +1,14 @@ module MascotState -open Shared - -/// The mascot eyes' slice of the dashboard model. Grouped out of App.Model so the -/// mascot's owned state (gaze direction + activity tracking) and its pure helpers live -/// together, away from core worktree/repo concerns (mirrors how CanvasState nests the -/// canvas pane's state into Model). +/// 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 - LastActivityTime: float - ActivityLevel: ActivityLevel } + { EyeDirection: float * float } -/// Initial mascot state: eyes centered, 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, the same -/// hazard that made worktreeApi lazy — see AppTypes.fs). let empty : MascotState = - { EyeDirection = (0.0, 0.0) - LastActivityTime = 0.0 - ActivityLevel = ActivityLevel.Active } + { EyeDirection = (0.0, 0.0) } let private rng = System.Random() @@ -28,20 +18,3 @@ let randomEyeDirection () = let dx = rng.NextDouble() * 3.0 - 1.5 let dy = rng.NextDouble() * 2.0 - 1.0 (dx, dy) - -/// 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/MascotView.fs b/src/Client/MascotView.fs index 6addeaf6..e8194867 100644 --- a/src/Client/MascotView.fs +++ b/src/Client/MascotView.fs @@ -1,20 +1,18 @@ module MascotView -// The mascot eye SVGs, extracted from `App.fs`. Pure render functions over the mascot's own -// `MascotState` slice (gaze direction + activity level) so the eyes' view sits next to their -// state and update (`MascotState.fs`/`MascotUpdate.fs`), mirroring the canvas slice. Compiled -// before `AppTypes.fs`, so these depend only on `Shared`/`Feliz` and the `MascotState` record — -// never on `Model`/`Msg`. +// 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 and the half/closed lid overlay come from the -/// `MascotState` slice's `EyeDirection` and `ActivityLevel`. -let viewEyeOpen (pupilColor: string) (mascot: MascotState.MascotState) = - let (dx, dy) = mascot.EyeDirection - let activity = mascot.ActivityLevel +/// 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) diff --git a/src/Tests/CanvasAwarenessTests.fs b/src/Tests/CanvasAwarenessTests.fs index e16b4806..8d6455f2 100644 --- a/src/Tests/CanvasAwarenessTests.fs +++ b/src/Tests/CanvasAwarenessTests.fs @@ -73,6 +73,7 @@ let private defaultModel : Model = DeletedPaths = Set.empty EditorName = "VS Code" ActionCooldowns = Set.empty + Activity = ActivityState.empty Mascot = MascotState.empty Canvas = CanvasState.empty } @@ -328,13 +329,13 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - Mascot = { defaultModel.Mascot with 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.Mascot.LastActivityTime > MascotState.autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -351,13 +352,13 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - Mascot = { defaultModel.Mascot with 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.Mascot.LastActivityTime > MascotState.autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -375,11 +376,11 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - Mascot = { defaultModel.Mascot with 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.Mascot.LastActivityTime > MascotState.autoDisplayIdleMs + let isIdle = jsNow - model.Activity.LastActivityTime > ActivityState.autoDisplayIdleMs let target = if isIdle && not (List.isEmpty changedDocs) then findMostRecentChangedDoc repos changedDocs @@ -395,12 +396,12 @@ type AutoDisplayIdleLogicTests() = let model = { defaultModel with Repos = repos - Mascot = { defaultModel.Mascot with 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.Mascot.LastActivityTime > MascotState.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 33f81074..78be0881 100644 --- a/src/Tests/ConfirmModalTests.fs +++ b/src/Tests/ConfirmModalTests.fs @@ -59,6 +59,7 @@ let private defaultModel : Model = DeletedPaths = Set.empty EditorName = "VS Code" ActionCooldowns = Set.empty + 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/CreateWorktreeTests.fs b/src/Tests/CreateWorktreeTests.fs index 02611571..20d594d1 100644 --- a/src/Tests/CreateWorktreeTests.fs +++ b/src/Tests/CreateWorktreeTests.fs @@ -32,6 +32,7 @@ let private defaultModel : Model = DeletedPaths = Set.empty EditorName = "VS Code" ActionCooldowns = Set.empty + Activity = ActivityState.empty Mascot = MascotState.empty Canvas = CanvasState.empty } diff --git a/src/Tests/IdleDetectionTests.fs b/src/Tests/IdleDetectionTests.fs index 966b72f8..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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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(MascotState.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)) From 3e69f78ccfcc3d0bff35dc92aec0e19596093ca8 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 22 Jun 2026 15:38:29 +0200 Subject: [PATCH 10/11] Refresh specs to new module layout; add code-improvements backlog After the App.fs view extraction + activity/mascot SoC split, several specs still pointed at old App.fs locations. Update their Key Files tables / module references (canvas-pane, user-idle-detection, worktree-monitor, resume-last-session, contextual-actions) to the new modules (ActivityState/ActivityUpdate, CardViews, OverviewViews, MascotState/MascotView, CanvasView). Behavior text unchanged. Add docs/spec/future/code-improvements.md: a running backlog of improvement candidates plus the worktree -> /bd-plan -> /bd-execute -> PR workflow. --- docs/spec/canvas-pane.md | 5 ++- docs/spec/contextual-actions.md | 3 +- docs/spec/future/code-improvements.md | 57 +++++++++++++++++++++++++++ docs/spec/resume-last-session.md | 5 ++- docs/spec/user-idle-detection.md | 6 +-- docs/spec/worktree-monitor.md | 7 +++- 6 files changed, 74 insertions(+), 9 deletions(-) create mode 100644 docs/spec/future/code-improvements.md diff --git a/docs/spec/canvas-pane.md b/docs/spec/canvas-pane.md index 98bf7cbb..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,7 +196,7 @@ 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`. +- **`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/code-improvements.md b/docs/spec/future/code-improvements.md new file mode 100644 index 00000000..f8354b9c --- /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` 1685 → 705 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 | From 5b94c210fe93d0707f914a29e0ed8cc0c3a10bd2 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 22 Jun 2026 17:02:33 +0200 Subject: [PATCH 11/11] Correct App.fs line-count figure (1861 -> 795, not 1685 -> 705) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The reported figures came from PowerShell's Measure-Object -Line, which undercounts blank lines (~10% here). The authoritative count ((Get-Content).Count) is 1861 on main and 795 now — a 1066-line (57%) reduction. Caught in PR review. --- docs/spec/future/code-improvements.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/spec/future/code-improvements.md b/docs/spec/future/code-improvements.md index f8354b9c..1d128e52 100644 --- a/docs/spec/future/code-improvements.md +++ b/docs/spec/future/code-improvements.md @@ -44,7 +44,7 @@ its own worktree. This file is the entry point; detailed designs live in their o ## Done -- **App.fs view extraction** — `src/Client/App.fs` 1685 → 705 lines. Extracted +- **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`.