| Write dvui's shape in jolt, on SDL3, with no shared object 109c7e4 Veronika Winters 10d ago | 1 | (ns glimmer-jvui.tests |
| 2 | "Every check here runs headless: no window, no SDL, no font, no display. |
| 3 | |
| 4 | jvui takes its measurer as a function, so the whole stack — glimmer's |
| 5 | reconciler, this backend's walk, jvui's layout and event routing — can be |
| 6 | driven with a stub that says eight pixels a character. `jolt test`." |
| 7 | (:require [glimmer.ratom :as ra] |
| Make a list follow what arrives in it 95540ef nandi 9d ago | 8 | [jvui.widgets :as w] |
| Write dvui's shape in jolt, on SDL3, with no shared object 109c7e4 Veronika Winters 10d ago | 9 | [glimmer.core :as gui] |
| 10 | [glimmer-jvui.core :as jv] |
| 11 | [jvui.core :as c])) |
| 12 | |
| 13 | (def ^:private failures (atom 0)) |
| 14 | |
| 15 | (defn- check! [ok? msg] |
| 16 | (when-not ok? |
| 17 | (swap! failures inc) |
| 18 | (println " FAIL:" msg))) |
| 19 | |
| 20 | (defn- ctx [] |
| 21 | (c/context {:size [400 300] |
| 22 | :measure (fn [s _] [(* 8.0 (count s)) 16.0]) |
| 23 | :line-height (fn [_] 16.0)})) |
| 24 | |
| 25 | (defn- walk [n] (cons n (mapcat walk (:children @n)))) |
| 26 | (defn- tagged [root tag] (first (filter #(= tag (:tag @%)) (walk root)))) |
| 27 | (defn- labels [root] |
| 28 | (map #(str (:label (:props @%))) |
| 29 | (filter #(= :label (:tag @%)) (walk root)))) |
| 30 | |
| 31 | (defn- centre |
| 32 | "The middle of the rectangle jvui gave this node on the last walk." |
| 33 | [n] |
| 34 | (let [[x y w h] (:rect @n)] [(+ x (/ w 2.0)) (+ y (/ h 2.0))])) |
| 35 | |
| 36 | (defn- click-at [x y] |
| 37 | [{:kind :motion :x x :y y} |
| 38 | {:kind :mouse-down :x x :y y :button 1 :clicks 1} |
| 39 | {:kind :mouse-up :x x :y y :button 1}]) |
| 40 | |
| 41 | ;; --- the reconciler reaches the backend -------------------------------------- |
| 42 | |
| 43 | (def ^:private clicks (ra/atom 0)) |
| 44 | (def ^:private on? (ra/atom false)) |
| 45 | |
| 46 | (defn- app [] |
| 47 | [:card {} |
| 48 | [:title {:label "Counter"}] |
| 49 | [:label {:label (str "Count: " (ra/deref clicks))}] |
| 50 | [:button {:label "+1" :kind :primary :on-click #(ra/swap! clicks inc)}] |
| 51 | [:checkbox {:label "loud" :checked (ra/deref on?) |
| 52 | :on-change #(ra/reset! on? %)}]]) |
| 53 | |
| 54 | (defn- check-tree! [] |
| 55 | (let [root (jv/root-node)] |
| 56 | (gui/mount root :page [app]) |
| 57 | (check! (some? (tagged root :card)) "the reconciler built a card") |
| 58 | (check! (some? (tagged root :button)) "and a button") |
| 59 | (check! (some #{"Count: 0"} (labels root)) |
| 60 | "and a label that read the ratom"))) |
| 61 | |
| 62 | (defn- check-walk-places-widgets! [] |
| 63 | (let [root (jv/root-node) cx (ctx)] |
| 64 | (gui/mount root :page [app]) |
| 65 | (jv/render-once root cx) |
| 66 | (let [placed (vals (:data @cx)) |
| 67 | card (first (filter #(and (:rect %) (> (first (:min-size % [0 0])) 100)) |
| 68 | placed))] |
| 69 | (check! (some? card) "the walk placed a container with a rectangle") |
| 70 | (check! (every? (fn [[_ _ w h]] (and (>= w 0) (>= h 0))) |
| 71 | (keep :rect placed)) |
| 72 | "and no rectangle came out negative")))) |
| 73 | |
| 74 | ;; --- a click goes all the way round ------------------------------------------ |
| 75 | |
| 76 | (defn- check-click-fires-the-handler! [] |
| 77 | (let [root (jv/root-node) cx (ctx)] |
| 78 | (ra/reset! clicks 0) |
| 79 | (gui/mount root :page [app]) |
| 80 | (jv/render-once root cx) |
| 81 | (jv/render-once root cx) |
| 82 | (let [before (ra/deref clicks) |
| 83 | [bx by] (centre (tagged root :button))] |
| 84 | (jv/render-once root cx (click-at bx by)) |
| 85 | (check! (= (inc before) (ra/deref clicks)) |
| 86 | (str "the click reached :on-click (" before " -> " |
| 87 | (ra/deref clicks) ")")) |
| 88 | (jv/render-once root cx) |
| 89 | (check! (some #{(str "Count: " (ra/deref clicks))} (labels root)) |
| 90 | "and the reactive re-render reached the tree")))) |
| 91 | |
| 92 | (defn- check-press-alone-is-not-a-click! [] |
| 93 | (let [root (jv/root-node) cx (ctx)] |
| 94 | (ra/reset! clicks 0) |
| 95 | (gui/mount root :page [app]) |
| 96 | (jv/render-once root cx) |
| 97 | (jv/render-once root cx) |
| 98 | (let [[bx by] (centre (tagged root :button))] |
| 99 | (jv/render-once root cx [{:kind :motion :x bx :y by} |
| 100 | {:kind :mouse-down :x bx :y by :button 1 :clicks 1}])) |
| 101 | (check! (zero? (ra/deref clicks)) "a press alone must not fire the handler") |
| 102 | (jv/render-once root cx [{:kind :motion :x 390 :y 290} |
| 103 | {:kind :mouse-up :x 390 :y 290 :button 1}]) |
| 104 | (check! (zero? (ra/deref clicks)) "and releasing off it must not either"))) |
| 105 | |
| 106 | ;; --- identity follows the node, not its index -------------------------------- |
| 107 | |
| 108 | (defn- check-reorder-keeps-identity! [] |
| 109 | ;; The reason every node carries a serial as its jvui key. Render a list, |
| 110 | ;; reorder it, and the ids the walk hands out must travel with the nodes. |
| 111 | (let [root (jv/root-node) cx (ctx) |
| 112 | items (ra/atom [:a :b :c]) |
| 113 | list-app (fn [] |
| 114 | (into [:vbox {}] |
| 115 | (for [k (ra/deref items)] |
| 116 | ^{:key k} [:button {:label (name k)}]))) |
| 117 | ids (fn [] (into {} (map (fn [n] [(:label (:props @n)) (:key @n)]) |
| 118 | (filter #(= :button (:tag @%)) (walk root)))))] |
| 119 | (gui/mount root :page [list-app]) |
| 120 | (jv/render-once root cx) |
| 121 | (let [before (ids)] |
| 122 | (ra/reset! items [:c :a :b]) |
| 123 | (jv/render-once root cx) |
| 124 | (let [after (ids)] |
| 125 | (check! (= 3 (count after)) "the list still has three buttons") |
| 126 | (check! (= (get before "a") (get after "a")) |
| 127 | "a keyed node keeps its jvui key across a reorder") |
| 128 | (check! (= (get before "c") (get after "c")) |
| 129 | "including the one that moved to the front"))))) |
| 130 | |
| 131 | ;; --- the vocabulary ---------------------------------------------------------- |
| 132 | |
| 133 | (defn- check-unknown-tag-is-a-container! [] |
| 134 | (let [root (jv/root-node) cx (ctx)] |
| 135 | (gui/mount root :page [(fn [] [:flerb {} [:label {:label "inside"}]])]) |
| 136 | (jv/render-once root cx) |
| 137 | (check! (some #{"inside"} (labels root)) |
| 138 | "an unknown tag shows its contents rather than raising"))) |
| 139 | |
| 140 | (defn- check-entry-round-trips! [] |
| 141 | (let [root (jv/root-node) cx (ctx) |
| 142 | text (ra/atom "")] |
| 143 | (gui/mount root :page |
| 144 | [(fn [] [:entry {:value (ra/deref text) |
| 145 | :on-change #(ra/reset! text %)}])]) |
| 146 | (jv/render-once root cx) |
| 147 | (let [[ex ey] (centre (tagged root :entry))] |
| 148 | (jv/render-once root cx (click-at ex ey))) ; take focus |
| 149 | (jv/render-once root cx [{:kind :text :text "hi"}]) |
| 150 | (check! (= "hi" (ra/deref text)) |
| 151 | (str "typed text reached :on-change: " (pr-str (ra/deref text)))))) |
| 152 | |
| Report Enter from a field, and take its width request c03a752 nandi 9d ago | 153 | (defn- check-enter-sends! [] |
| 154 | ;; Enter is the one key a field must not swallow. frq sends its message |
| 155 | ;; on it, so a compose box that accepted text and never reported Enter |
| 156 | ;; would take a message and have no way to say it was finished — typing |
| 157 | ;; works, sending does not, and nothing looks broken. |
| 158 | (let [root (jv/root-node) cx (ctx) |
| 159 | text (ra/atom "hello") |
| 160 | sent (ra/atom nil)] |
| 161 | (gui/mount root :page |
| 162 | [(fn [] [:entry {:value (ra/deref text) |
| 163 | :on-change #(ra/reset! text %) |
| Fire :on-activate with nothing, wrap a row, and break a word that cannot fit 2271a91 nandi 9d ago | 164 | ;; A THUNK, which is what frq's handlers |
| 165 | ;; are: s/send-draft! takes no arguments |
| 166 | ;; and the text is already the caller's |
| 167 | ;; from :on-change. |
| 168 | :on-activate #(ra/reset! sent (ra/deref text))}])]) |
| Report Enter from a field, and take its width request c03a752 nandi 9d ago | 169 | (jv/render-once root cx) |
| 170 | (let [[ex ey] (centre (tagged root :entry))] |
| 171 | (jv/render-once root cx (click-at ex ey))) ; take focus |
| 172 | (jv/render-once root cx [{:kind :key-down :key :return}]) |
| 173 | (check! (= "hello" (ra/deref sent)) |
| 174 | (str "Enter reached :on-activate: " (pr-str (ra/deref sent)))))) |
| 175 | |
| Make a list follow what arrives in it 95540ef nandi 9d ago | 176 | (defn- label-node [root text] |
| 177 | (first (filter #(and (= :label (:tag @%)) (= text (str (:label (:props @%))))) |
| 178 | (walk root)))) |
| 179 | |
| Let a container fill its parent, and report "end" as the word e72d7b0 nandi 9d ago | 180 | (defn- check-rows-do-not-stretch! [] |
| 181 | ;; Every box shrink-wrapping its children is how frq's chat column came |
| 182 | ;; out a couple of hundred points wide in a five-hundred-point window, |
| 183 | ;; with every message wrapped to match and the scrollbar stranded in the |
| 184 | ;; middle of the screen. A container fills its parent's cross axis. |
| 185 | ;; |
| 186 | ;; And a ROW's children must NOT: :cross rather than :horizontal is what |
| 187 | ;; keeps a line of buttons from stretching to fill the window. |
| 188 | (let [root (jv/root-node) cx (ctx)] ; a 400-wide context |
| 189 | (gui/mount root :page |
| 190 | [(fn [] [:vbox {:key :outer} |
| 191 | [:vbox {:key :inner} [:label {:label "hi"}]] |
| 192 | [:hbox {:key :row} [:button {:label "a"}] |
| 193 | [:button {:label "b"}]]])]) |
| 194 | (dotimes [_ 3] (jv/render-once root cx)) |
| 195 | ;; Only tags that register for events carry a rect here, so the |
| 196 | ;; filling half is checked by pixel in props-check — a card paints a |
| 197 | ;; background and a screenshot can measure it. What CAN be asserted |
| 198 | ;; from the tree is the half that would regress silently. |
| 199 | (let [buttons (filter #(and (= :button (:tag @%)) (:rect @%)) (walk root))] |
| 200 | (check! (every? #(< (nth (:rect @%) 2) 120.0) buttons) |
| 201 | (str "and buttons in a row do not stretch: " |
| 202 | (pr-str (map #(nth (:rect @%) 2) buttons))))))) |
| 203 | |
| Make a list follow what arrives in it 95540ef nandi 9d ago | 204 | (defn- check-scroll-sticks! [] |
| 205 | ;; A chat that does not follow new messages is the difference between a |
| 206 | ;; window you read and one you drag. |
| 207 | ;; |
| 208 | ;; Asserted on GEOMETRY and not on which labels exist: every line is in |
| 209 | ;; the tree whether or not it is on screen, so `labels` cannot tell a |
| 210 | ;; stuck list from a pinned one. What tells them apart is where the last |
| 211 | ;; line was PUT — inside the viewport, or far below it. |
| 212 | (let [root (jv/root-node) cx (ctx) |
| 213 | n (ra/atom 3)] |
| 214 | (gui/mount root :page |
| 215 | [(fn [] [:scroll {:height 60 :scroll-key "chat" :stick-to-bottom true} |
| 216 | (into [:vbox {}] |
| 217 | (for [i (range (ra/deref n))] |
| 218 | [:label {:key i :label (str "line " i)}]))])]) |
| 219 | (dotimes [_ 3] (jv/render-once root cx)) |
| 220 | (ra/reset! n 40) |
| 221 | (dotimes [_ 3] (jv/render-once root cx)) |
| 222 | ;; Forty lines of sixteen in a sixty-tall viewport leaves a long way |
| 223 | ;; to scroll. A stuck list is at the far end of it; a pinned one is |
| 224 | ;; still at zero. |
| 225 | (let [off (w/scroll-offset "chat")] |
| 226 | (check! (and off (> off 100.0)) |
| 227 | (str "a stuck list followed its content: offset=" off)) |
| 228 | ;; And it must STOP following once the reader has moved, or they can |
| 229 | ;; never read anything but the newest line. |
| 230 | ;; The mouse has to be OVER the list: a wheel is delivered to |
| 231 | ;; whatever is under the pointer, and the pointer only moves on a |
| 232 | ;; motion event. |
| 233 | (jv/render-once root cx [{:kind :motion :x 20 :y 30}]) |
| 234 | (dotimes [_ 4] |
| 235 | (jv/render-once root cx [{:kind :motion :x 20 :y 30} |
| 236 | {:kind :wheel :x 20 :y 30 :dy 3}])) |
| 237 | (let [off2 (w/scroll-offset "chat")] |
| 238 | (check! (and off2 (< off2 off)) |
| 239 | (str "and let go when the reader scrolled up: " off " -> " off2)))))) |
| 240 | |
| Write dvui's shape in jolt, on SDL3, with no shared object 109c7e4 Veronika Winters 10d ago | 241 | (defn- check-checkbox-round-trips! [] |
| 242 | (let [root (jv/root-node) cx (ctx)] |
| 243 | (ra/reset! on? false) |
| 244 | (gui/mount root :page [app]) |
| 245 | (jv/render-once root cx) |
| 246 | (jv/render-once root cx) |
| 247 | (let [[bx by] (centre (tagged root :checkbox))] |
| 248 | (jv/render-once root cx (click-at bx by))) |
| 249 | (check! (true? (ra/deref on?)) |
| 250 | (str "the checkbox reached :on-change: " (ra/deref on?))))) |
| 251 | |
| 252 | ;; --- runner ------------------------------------------------------------------ |
| 253 | |
| 254 | (def ^:private checks |
| 255 | [["the reconciler builds a tree" check-tree!] |
| 256 | ["the walk places widgets" check-walk-places-widgets!] |
| 257 | ["a click fires the handler" check-click-fires-the-handler!] |
| 258 | ["a press alone does not" check-press-alone-is-not-a-click!] |
| 259 | ["a reorder keeps identity" check-reorder-keeps-identity!] |
| 260 | ["an unknown tag is a container" check-unknown-tag-is-a-container!] |
| Let a container fill its parent, and report "end" as the word e72d7b0 nandi 9d ago | 261 | ["a row does not stretch" check-rows-do-not-stretch!] |
| Make a list follow what arrives in it 95540ef nandi 9d ago | 262 | ["a list sticks to the end" check-scroll-sticks!] |
| Report Enter from a field, and take its width request c03a752 nandi 9d ago | 263 | ["Enter sends" check-enter-sends!] |
| Write dvui's shape in jolt, on SDL3, with no shared object 109c7e4 Veronika Winters 10d ago | 264 | ["an entry round-trips" check-entry-round-trips!] |
| 265 | ["a checkbox round-trips" check-checkbox-round-trips!]]) |
| 266 | |
| 267 | (defn -main [& _] |
| 268 | (doseq [[name f] checks] |
| 269 | (println "-" name) |
| 270 | (f)) |
| 271 | (if (zero? @failures) |
| 272 | (println "\nall" (count checks) "checks passed") |
| 273 | (do (println "\n" @failures "failed") (System/exit 1)))) |