Skip to content

chore: audit cleanup leftovers — generate-views/node->hiccup splits + tests #14

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
avanelsas merged 3 commits into from
Apr 30, 2026
Merged

chore: audit cleanup leftovers — generate-views/node->hiccup splits + tests #14

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
683a101
Tests for cheat-sheet/group-rows + command-palette pure helpers
avanelsas Apr 30, 2026
9bb9b47
Decompose generate-views: extract view-context data bundle
avanelsas Apr 30, 2026
fb65e63
Decompose node->hiccup-with-events into walk + emit helpers
avanelsas Apr 30, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
225 changes: 138 additions & 87 deletions src/bareforge/export/cljs_project.cljs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 `(<ns>.views/<ns>)` 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
Expand All @@ -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)
Expand All @@ -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))]
Expand All @@ -499,23 +523,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-<event>` 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 `(<ns>.views/<ns>)` call.
- Template sub-groups → a `(for [p (rf/query [<sub>])] ...)`
loop, where `<sub>` 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)
Expand Down Expand Up @@ -628,10 +644,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
Expand All @@ -641,6 +653,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-<event>` 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 `(<ns>.views/<ns>)` call.
- Template sub-groups → a `(for [p (rf/query [<sub>])] ...)`
loop, where `<sub>` 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"
Expand Down
5 changes: 3 additions & 2 deletions src/bareforge/ui/cheat_sheet.cljs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
17 changes: 13 additions & 4 deletions src/bareforge/ui/command_palette.cljs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand All @@ -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"
Expand Down Expand Up @@ -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
Expand Down
48 changes: 48 additions & 0 deletions test/bareforge/ui/cheat_sheet_test.cljs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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"))))
Loading
Loading