From 683a101068593c4cc0078be3dad83a086e7ce4e8 Mon Sep 17 00:00:00 2001 From: vanelsas <58037137+avanelsas@users.noreply.github.com> Date: Thu, 30 Apr 2026 11:10:02 +0200 Subject: [PATCH 1/3] Tests for cheat-sheet/group-rows + command-palette pure helpers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds unit coverage for the v0.2.0 modules that landed without test files. Pure helpers only — modal mounting, focus management, and the x-command-palette wiring stay browser-only and out of unit scope. cheat-sheet: - group-rows promoted from defn- to defn so tests can pin its output without going through the modal lifecycle. - 5 tests cover empty info, single category, declared-order preservation, dropped-empty-category, and a smoke test against the live shortcut-info / category-labels data. command-palette: - curated-commands, wrap-commands, ->item promoted to defn. - ->item: 3 tests cover field projection, synthetic id format, keywords-default-to-empty-string. - curated-commands: 3 tests cover shape, label uniqueness, group whitelist. - wrap-commands: 2 tests cover shape and label-references-tag. Test count moves 571 → 584 (13 new tests, 40 new assertions). Gates green. Co-Authored-By: Claude Opus 4.7 (1M context) --- src/bareforge/ui/cheat_sheet.cljs | 5 +- src/bareforge/ui/command_palette.cljs | 17 ++++-- test/bareforge/ui/cheat_sheet_test.cljs | 48 +++++++++++++++ test/bareforge/ui/command_palette_test.cljs | 65 +++++++++++++++++++++ 4 files changed, 129 insertions(+), 6 deletions(-) create mode 100644 test/bareforge/ui/cheat_sheet_test.cljs create mode 100644 test/bareforge/ui/command_palette_test.cljs diff --git a/src/bareforge/ui/cheat_sheet.cljs b/src/bareforge/ui/cheat_sheet.cljs index 528bad6..f03d0d5 100644 --- a/src/bareforge/ui/cheat_sheet.cljs +++ b/src/bareforge/ui/cheat_sheet.cljs @@ -39,10 +39,11 @@ (cons (typography "overline" label) (mapv row-el entries)))) -(defn- group-rows +(defn group-rows "Pure: split shortcut-info into ordered category groups. Returns `[[label-string entries] …]` matching `category-labels`' - ordering, dropping empty groups." + ordering, dropping empty groups. Public so unit tests can pin + the grouping shape without going through the modal lifecycle." [info categories] (let [by-cat (group-by :category info)] (->> categories diff --git a/src/bareforge/ui/command_palette.cljs b/src/bareforge/ui/command_palette.cljs index ce298a1..ca7b94d 100644 --- a/src/bareforge/ui/command_palette.cljs +++ b/src/bareforge/ui/command_palette.cljs @@ -52,7 +52,11 @@ palette accept the same set." ["x-container" "x-grid" "x-card" "x-navbar"]) -(defn- wrap-commands [] +(defn wrap-commands + "One entry per `wrap-tags` tag. Public so unit tests can pin the + shape (count, fields, callable `:run!`) without spinning up the + modal lifecycle." + [] (mapv (fn [tag] {:label (str "Wrap selection in " tag) :group "Selection" @@ -75,7 +79,11 @@ :run! #(palette/insert-at-selection! tag)})) (registry/all-tags))) -(defn- curated-commands [] +(defn curated-commands + "Static short-list shown when the query is empty. Public so unit + tests can assert the shape (label / group / run! present, no + duplicate labels) without going through the modal." + [] [{:label "Save project" :group "File" :keywords "save" :run! pf/save!} {:label "Open project…" :group "File" :keywords "open load" @@ -124,11 +132,12 @@ (or (some-> (js/document.getElementById "app") .-parentNode) js/document.body)) -(defn- ->item +(defn ->item "Pure: project a Clojure command map into the JS shape `x-command-palette` consumes. The synthetic `id` is the index string; `keywords` flow through the component's filter so labels - stay short while typed terms resolve broadly." + stay short while typed terms resolve broadly. Public so unit + tests can pin the field mapping." [i {:keys [label group keywords]}] #js {:id (str "cmd-" i) :label label diff --git a/test/bareforge/ui/cheat_sheet_test.cljs b/test/bareforge/ui/cheat_sheet_test.cljs new file mode 100644 index 0000000..a377bc9 --- /dev/null +++ b/test/bareforge/ui/cheat_sheet_test.cljs @@ -0,0 +1,48 @@ +(ns bareforge.ui.cheat-sheet-test + (:require [cljs.test :refer [deftest is testing]] + [bareforge.ui.cheat-sheet :as cheat-sheet] + [bareforge.ui.shortcuts :as sh])) + +(def ^:private fake-categories + [[:editing "Editing"] + [:selection "Selection"] + [:navigation "Navigation"] + [:view "View"]]) + +(deftest group-rows-empty-info + (is (= [] (cheat-sheet/group-rows [] fake-categories)) + "no entries → no groups")) + +(deftest group-rows-single-category + (let [info [{:category :editing :keys "X" :label "x"} + {:category :editing :keys "Y" :label "y"}] + out (cheat-sheet/group-rows info fake-categories)] + (is (= 1 (count out))) + (is (= "Editing" (-> out first first))) + (is (= 2 (count (-> out first second)))))) + +(deftest group-rows-preserves-category-order + (testing "output order matches category-labels order, even when + input entries land in a different order" + (let [info [{:category :view :keys "?" :label "help"} + {:category :navigation :keys "Esc" :label "deselect"} + {:category :editing :keys "Cmd+Z" :label "undo"}] + out (cheat-sheet/group-rows info fake-categories)] + (is (= ["Editing" "Navigation" "View"] + (mapv first out)) + ":selection drops out (no entries); the rest follow declared order")))) + +(deftest group-rows-drops-empty-categories + (let [info [{:category :editing :keys "Cmd+Z" :label "undo"}] + out (cheat-sheet/group-rows info fake-categories)] + (is (= 1 (count out))) + (is (= "Editing" (-> out first first))))) + +(deftest group-rows-against-real-shortcut-info + (testing "the live shortcut-info renders with no missing + categories or empty groups" + (let [out (cheat-sheet/group-rows sh/shortcut-info sh/category-labels)] + (is (pos? (count out))) + (is (every? string? (mapv first out))) + (is (every? (fn [[_ entries]] (pos? (count entries))) out) + "no group should appear with zero entries")))) diff --git a/test/bareforge/ui/command_palette_test.cljs b/test/bareforge/ui/command_palette_test.cljs new file mode 100644 index 0000000..c4cda71 --- /dev/null +++ b/test/bareforge/ui/command_palette_test.cljs @@ -0,0 +1,65 @@ +(ns bareforge.ui.command-palette-test + (:require [cljs.test :refer [deftest is testing]] + [bareforge.ui.command-palette :as cp])) + +;; --- ->item ------------------------------------------------------------- + +(deftest ->item-projects-fields + (let [out (cp/->item 0 {:label "Save project" + :group "File" + :keywords "save" + :run! (constantly nil)})] + (is (= "cmd-0" (.-id out))) + (is (= "Save project" (.-label out))) + (is (= "File" (.-group out))) + (is (= "save" (.-keywords out))))) + +(deftest ->item-uses-index-as-synthetic-id + (testing "synthetic id format is stable so the select-event id + can index back into the run-by-id map" + (is (= "cmd-7" (.-id (cp/->item 7 {:label "x"})))))) + +(deftest ->item-keywords-default-to-empty-string + (testing "missing :keywords becomes an empty string so the + x-command-palette filter doesn't trip on null" + (let [out (cp/->item 0 {:label "x" :group "g"})] + (is (= "" (.-keywords out)))))) + +;; --- curated-commands --------------------------------------------------- + +(deftest curated-commands-shape + (let [cmds (cp/curated-commands)] + (is (pos? (count cmds)) "curated list is non-empty") + (is (every? :label cmds)) + (is (every? :group cmds)) + (is (every? #(fn? (:run! %)) cmds) + "every command's :run! is callable"))) + +(deftest curated-commands-no-duplicate-labels + (let [labels (mapv :label (cp/curated-commands))] + (is (= (count labels) (count (distinct labels))) + "labels are unique within the curated list"))) + +(deftest curated-commands-only-known-groups + (testing "curated entries land in one of the four declared + groups so the palette's category headings stay + consistent" + (let [allowed #{"File" "View" "Selection"}] + (doseq [c (cp/curated-commands)] + (is (contains? allowed (:group c)) + (str "command " (:label c) " has unknown group " + (:group c))))))) + +;; --- wrap-commands ------------------------------------------------------ + +(deftest wrap-commands-shape + (let [cmds (cp/wrap-commands)] + (is (pos? (count cmds))) + (is (every? :label cmds)) + (is (every? #(= "Selection" (:group %)) cmds)) + (is (every? #(fn? (:run! %)) cmds)))) + +(deftest wrap-commands-label-references-tag + (testing "every wrap entry's label embeds the wrap target tag" + (doseq [c (cp/wrap-commands)] + (is (re-find #"Wrap selection in x-" (:label c)))))) From 9bb9b47fc6163228f588c1b2ee11ef6c10377791 Mon Sep 17 00:00:00 2001 From: vanelsas <58037137+avanelsas@users.noreply.github.com> Date: Thu, 30 Apr 2026 11:12:31 +0200 Subject: [PATCH 2/3] Decompose generate-views: extract view-context data bundle MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit generate-views was 161 lines mixing data derivation (sub-groups, read fields, payload fields, four kinds of aliases, function signature, ns-clause requires) with output formatting (the file string). The audit's recipe — the same one already applied to generate-core — was to split data assembly from orchestration. view-context (private, ~140 lines) does the assembly and returns a known-shape map: :fn-name :ns-path :fn-sig :require-entries :hiccup-ctx :node :root-slot :let-fields :field->owner :has-let? generate-views shrinks to ~45 lines: destructures the bundle, builds the ns-clause string, threads has-let?/let-fields/ hiccup-ctx into the body string, returns the file content. The data assembly is still big — every derived datum is needed exactly once and they cross-reference enough that further splitting would multiply argument lists. The split's value is that the orchestrator is now a readable sequence of steps without 25 derived locals in scope. cljs_project_test.cljs's parity tests are the safety net; all 584 tests still pass (0 failures), 0 release-build warnings, 0 lint warnings. Co-Authored-By: Claude Opus 4.7 (1M context) --- src/bareforge/export/cljs_project.cljs | 69 ++++++++++++++++++-------- 1 file changed, 48 insertions(+), 21 deletions(-) diff --git a/src/bareforge/export/cljs_project.cljs b/src/bareforge/export/cljs_project.cljs index 3677400..5c7e0d8 100644 --- a/src/bareforge/export/cljs_project.cljs +++ b/src/bareforge/export/cljs_project.cljs @@ -499,23 +499,15 @@ (def ^:private find-sub-groups em/find-sub-groups) -(defn- generate-views - "Generate the views.cljs content for a group using hiccup. - - A template group's view takes the record as a single arg and - destructures its fully-qualified keys. A stateful group's view - takes no arg; it `rf/query`s every field it reads via attribute - bindings or trigger payloads. - - Triggers emit `:on-` handlers that dispatch an action by - its fully qualified action-ref keyword. The view's :require list - includes every sub/action/db/child-views ns it actually touches. - - Sub-groups are rendered two ways: - - Singleton sub-groups → a plain `(.views/)` call. - - Template sub-groups → a `(for [p (rf/query [])] ...)` - loop, where `` comes from `:source-sub` (explicit) or - `:source-field` (resolved via the field-owner index)." +(defn- view-context + "Pure: derive every datum `generate-views` needs to emit a view + file for `group`. Returns a bundle map: `:fn-name :ns-path + :fn-sig :require-entries :hiccup-ctx :node :root-slot + :let-fields :field->owner :has-let?`. Splitting this out keeps + `generate-views` itself a thin orchestrator over a known-shape + data bundle — the data assembly is large enough to read as a + small program of its own, and the formatting step is easier to + audit when it stops sharing scope with 25 derived locals." [doc group all-groups app-ns] (let [node (m/get-node doc (:id group)) fn-name (:ns-name group) @@ -628,10 +620,6 @@ (str "[" app-ns "." a " :as " a "]")) (for [sg (distinct (map :ns-name sub-groups))] (str "[" app-ns "." sg ".views :as " sg ".views]")))) - ns-clause (if (seq require-entries) - (str "(ns " ns-path "\n" - " (:require " (str/join "\n " require-entries) "))\n") - (str "(ns " ns-path ")\n")) hiccup-ctx {:doc doc :field->sym field->sym :sub-group-ids sub-group-ids @@ -641,6 +629,45 @@ :tmpl-record-sym tmpl-record-sym :name->ns name->ns :own-ns-name own-ns-name}] + {:fn-name fn-name + :ns-path ns-path + :fn-sig fn-sig + :require-entries require-entries + :hiccup-ctx hiccup-ctx + :node node + :root-slot root-slot + :let-fields let-fields + :field->owner field->owner + :has-let? (boolean has-let?)})) + +(defn- generate-views + "Generate the views.cljs content for a group using hiccup. + + A template group's view takes the record as a single arg and + destructures its fully-qualified keys. A stateful group's view + takes no arg; it `rf/query`s every field it reads via attribute + bindings or trigger payloads. + + Triggers emit `:on-` handlers that dispatch an action by + its fully qualified action-ref keyword. The view's :require list + includes every sub/action/db/child-views ns it actually touches. + + Sub-groups are rendered two ways: + - Singleton sub-groups → a plain `(.views/)` call. + - Template sub-groups → a `(for [p (rf/query [])] ...)` + loop, where `` comes from `:source-sub` (explicit) or + `:source-field` (resolved via the field-owner index). + + Data assembly lives in `view-context`; this fn formats the file + string from that bundle." + [doc group all-groups app-ns] + (let [{:keys [fn-name ns-path fn-sig require-entries hiccup-ctx + node root-slot let-fields field->owner has-let?]} + (view-context doc group all-groups app-ns) + ns-clause (if (seq require-entries) + (str "(ns " ns-path "\n" + " (:require " (str/join "\n " require-entries) "))\n") + (str "(ns " ns-path ")\n"))] (str ns-clause "\n" "(defn " fn-name " " fn-sig "\n" From fb65e6367b498e3d159b10b0ff615a2d9a04a322 Mon Sep 17 00:00:00 2001 From: vanelsas <58037137+avanelsas@users.noreply.github.com> Date: Thu, 30 Apr 2026 11:14:52 +0200 Subject: [PATCH 3/3] Decompose node->hiccup-with-events into walk + emit helpers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit node->hiccup-with-events was 123 lines doing four jobs at once: build the props map, resolve text from text-field or :text, walk the children across slots with sub-group / template dispatch, and assemble the final hiccup string. The children walk was the gnarliest part — 50 lines of nested cond + let inside a reduce. emit-sub-group-child (~40 lines) renders one sub-group child: either a singleton view call or a template iteration. Returns [rendered-or-nil rendered-tpls'] so the caller can dedupe templates within a parent slot — the first encounter renders, later ones return nil so a parent with N seed-backed clones still emits one iteration. walk-slotted-children (~29 lines) is the reduce-over-slots loop; sub-group children dispatch through emit-sub-group-child, non-group children recurse via node->hiccup-with-events. node->hiccup-with-events shrinks to ~77 lines and reads as props → text → children → output assembly, four single-purpose steps. The recursive cycle (node->hiccup-with-events ↔ walk-slotted-children) is bridged by a forward `declare`. cljs_project parity tests are the safety net; 584 tests still pass, 0 release-build warnings, 0 lint warnings, formatting clean. Co-Authored-By: Claude Opus 4.7 (1M context) --- src/bareforge/export/cljs_project.cljs | 156 ++++++++++++++----------- 1 file changed, 90 insertions(+), 66 deletions(-) diff --git a/src/bareforge/export/cljs_project.cljs b/src/bareforge/export/cljs_project.cljs index 5c7e0d8..9b90d68 100644 --- a/src/bareforge/export/cljs_project.cljs +++ b/src/bareforge/export/cljs_project.cljs @@ -376,6 +376,76 @@ (declare stateful-host-for-template) +(declare node->hiccup-with-events) + +(defn- emit-sub-group-child + "Render one sub-group child of a node into its hiccup string. + Returns `[rendered-or-nil rendered-tpls']` so the caller can + dedupe templates within a parent slot — the first encounter + of a template sub-group renders its iteration call; later + encounters return nil so a parent with N seed-backed clones + still emits one iteration. Singleton sub-groups return the + plain `(.views/)` call." + [ctx child gname tpl? rendered-tpls kid-pad] + (let [{:keys [doc all-groups field-owner-ns-map]} ctx] + (cond + (and tpl? (contains? rendered-tpls gname)) + [nil rendered-tpls] + + tpl? + (let [;; Fall back to the (single) collection field that + ;; points at this template when the instance has no + ;; explicit :source-field / :source-sub set. Lets the + ;; user declare a collection + name the template + ;; without also having to manually wire the + ;; 'Rendered from' source in the inspector. + fallback (when (and (nil? (:source-sub child)) + (nil? (:source-field child))) + (stateful-host-for-template + doc all-groups gname)) + src-field (or (:source-field child) + (when fallback (keyword (:field-name fallback)))) + field-ns (or (get field-owner-ns-map (:source-field child)) + (when fallback (:ns-name fallback)))] + [(collection-iteration-call gname kid-pad + (:source-sub child) + src-field + field-ns) + (conj rendered-tpls gname)]) + + :else + [(kid-pad (str "(" gname ".views/" gname ")")) + rendered-tpls]))) + +(defn- walk-slotted-children + "Render every child of `node` across all its slots. Sub-group + children dispatch to `emit-sub-group-child`; non-group children + recurse via `node->hiccup-with-events`. Returns a vector of + hiccup strings in document order, with template-group + iterations deduped per slot." + [ctx node depth] + (let [{:keys [sub-group-ids all-groups template-groups]} ctx + sub-set (set sub-group-ids) + kid-pad (fn [s] (indent (+ depth 1) s))] + (first + (reduce + (fn [[acc rendered-tpls] [sname child]] + (if (contains? sub-set (:id child)) + (let [g (first (filter #(some #{(:id child)} (:instance-ids %)) + all-groups)) + gname (:ns-name g) + tpl? (contains? template-groups gname) + [rendered tpls'] + (emit-sub-group-child ctx child gname tpl? + rendered-tpls kid-pad)] + [(cond-> acc rendered (conj rendered)) tpls']) + [(conj acc (node->hiccup-with-events ctx child sname (+ depth 1))) + rendered-tpls])) + [[] #{}] + (for [[sname kids] (m/slot-entries node) + child kids] + [sname child]))))) + (defn- node->hiccup-with-events "Like node->hiccup but also adds :on-* handlers for event triggers and honours `:text-field` on nodes by emitting a local symbol when @@ -400,13 +470,16 @@ resolve a binding's `:owner`) :own-ns-name — enclosing view's group ns-name; default owner for write bindings with no `:owner` - and no field-owner match" - [{:keys [doc field->sym sub-group-ids all-groups template-groups - field-owner-ns-map tmpl-record-sym name->ns own-ns-name] + and no field-owner match + + Children walking + sub-group dispatch live in + `walk-slotted-children` / `emit-sub-group-child`; this fn + handles props + text + final output assembly." + [{:keys [field->sym tmpl-record-sym field-owner-ns-map name->ns own-ns-name] :as ctx} node slot-name depth] - (let [tag (str ":" (:tag node)) - base-props (node->prop-strings node slot-name) + (let [tag (str ":" (:tag node)) + base-props (node->prop-strings node slot-name) event-props (for [t (:events node)] (trigger->event-prop t field->sym tmpl-record-sym)) write-props (for [[k {:keys [field direction owner]}] (:bindings node) @@ -418,67 +491,18 @@ (:tag node) k field owner-ns)] :when prop] prop) - props (format-props-map (concat base-props event-props write-props) - (:tag node) depth) - tf (:text-field node) - text (cond - (and tf (contains? field->sym tf)) - (get field->sym tf) - - (and (:text node) (not= "" (:text node))) - (str "\"" (h2h/escape-cljs-str (:text node)) "\"")) - inner-html (:inner-html node) - pad (fn [s] (indent depth s)) - kid-pad (fn [s] (indent (+ depth 1) s)) - children - (first - (reduce - (fn [[acc rendered-tpls] [sname child]] - (if (contains? (set sub-group-ids) (:id child)) - (let [g (first (filter #(some #{(:id child)} - (:instance-ids %)) - all-groups)) - gname (:ns-name g) - tpl? (contains? template-groups gname)] - (cond - (and tpl? (contains? rendered-tpls gname)) - [acc rendered-tpls] - - tpl? - (let [;; Fall back to the (single) collection field that - ;; points at this template when the instance has no - ;; explicit :source-field / :source-sub set. Lets the - ;; user declare a collection + name the template - ;; without also having to manually wire the - ;; 'Rendered from' source in the inspector. - fallback (when (and (nil? (:source-sub child)) - (nil? (:source-field child))) - (stateful-host-for-template - doc all-groups gname)) - src-field (or (:source-field child) - (when fallback - (keyword (:field-name fallback)))) - field-ns (or (get field-owner-ns-map - (:source-field child)) - (when fallback (:ns-name fallback)))] - [(conj acc (collection-iteration-call - gname kid-pad - (:source-sub child) - src-field - field-ns)) - (conj rendered-tpls gname)]) - - :else - [(conj acc - (kid-pad (str "(" gname ".views/" gname ")"))) - rendered-tpls])) - [(conj acc - (node->hiccup-with-events ctx child sname (+ depth 1))) - rendered-tpls])) - [[] #{}] - (for [[sname kids] (m/slot-entries node) - child kids] - [sname child])))] + props (format-props-map (concat base-props event-props write-props) + (:tag node) depth) + tf (:text-field node) + text (cond + (and tf (contains? field->sym tf)) + (get field->sym tf) + + (and (:text node) (not= "" (:text node))) + (str "\"" (h2h/escape-cljs-str (:text node)) "\"")) + inner-html (:inner-html node) + pad (fn [s] (indent depth s)) + children (walk-slotted-children ctx node depth)] (cond inner-html (let [inner-hiccup (h2h/html->hiccup-str inner-html (+ depth 1))]