nandi/jolt-native · core.clj

⑂ 6a3304ddddcc7d3e9486b470fea5933a1f81f8e8

core.clj · 284 lines · 9.3 KBClojure    Blame HistoryRaw
glimmer-cosmic: a libcosmic backend for glimmer (spike)   1(ns glimmer-cosmic.core
"The libcosmic backend for glimmer. Requiring this namespace installs it:
  (ns myapp
    (:require [glimmer.core :as ui]
              [glimmer-cosmic.core]))       ; installs this backend
  (defn -main [& _] (ui/run my-app :title \"myapp\"))
The tree half is glimmer-vidya's: node handles in a Rust arena, props written
across, handlers kept here and found by node id when an event comes back.
The loop half is inverted. libcosmic will not be driven a frame at a time —
it takes the main thread and keeps it until the window closes — so `run`
blocks the main thread there and the reconciler lives on a worker. The worker
is \"the UI thread\" as far as glimmer is concerned: `schedule` queues onto it,
handlers run on it, and at the end of each pass it commits, which is the only
moment libcosmic sees what changed."
(:require [glimmer.backend :as b]
          [glimmer-cosmic.ffi :as ffi]))
22;; Node id -> the :on-* props that node was last rendered with.
23(defonce ^:private handlers (atom {}))
25;; Work posted from other threads, run on the worker at the top of a pass.
26(defonce ^:private pending (atom []))
28(defonce ^:private quit-requested (atom false))
30;; --- props -------------------------------------------------------------------
31(def ^:private tag-orientation {:hbox "horizontal" :vbox "vertical"})
33(defn- handler-key? [k]
(let [s (name k)]
  (and (> (count s) 3) (= "on-" (subs s 0 3)))))
37(defn- set-prop! [node k v]
(let [key (name k)]
39
    (nil? v)     nil
    (true? v)    (ffi/node-set-bool! node key true)
    (false? v)   (ffi/node-set-bool! node key false)
    (number? v)  (ffi/node-set-num! node key (double v))
    (string? v)  (ffi/node-set-str! node key v)
    (keyword? v) (ffi/node-set-str! node key (name v))
    :else        (ffi/node-set-str! node key (str v)))))
48(defn- write-props!
"Replace a node's props with `props`, cleared first so a prop a re-render
stops setting is gone — and so the value libcosmic wrote back when someone
typed is overwritten by the component's own state."
[node tag props]
(ffi/node-clear-props! node)
(when-let [orientation (tag-orientation tag)]
  (when-not (contains? props :orientation)
    (ffi/node-set-str! node "orientation" orientation)))
(doseq [[k v] props]
  (when-not (handler-key? k)
    (set-prop! node k v)))
(swap! handlers assoc node
       (reduce (fn [acc [k v]]
                 (if (and (handler-key? k) (fn? v)) (assoc acc k v) acc))
               props))
67(defn- forget-dead-handlers! []
(swap! handlers
       (fn [m]
         (reduce (fn [acc [id hs]]
                   (if (ffi/node-exists? id) (assoc acc id hs) acc))
76;; --- the backend operations --------------------------------------------------
77(defn- create! [tag props]
(let [node (ffi/node-new (name tag))]
  (when (zero? node)
    (throw (ex-info "jolt-cosmic could not allocate a node" {:tag tag})))
  (write-props! node tag props)
82
84(defn- apply-props! [tag node props] (write-props! node tag props))
86(defn- append-child! [_parent-tag parent child]
(ffi/node-append! parent child)
90(defn- remove-child! [_parent-tag parent child]
(ffi/node-remove! parent child)
(forget-dead-handlers!)
95(defn- replace-child! [_parent-tag parent old-child new-child]
(ffi/node-replace! parent old-child new-child)
(forget-dead-handlers!)
100(defn- reorder-child! [_parent-tag parent child sibling]
(ffi/node-insert-after! parent child (or sibling 0))
104;; --- the worker --------------------------------------------------------------
105(defn- schedule
"glimmer.backend's :schedule. Queues `work` for the worker and wakes it, so a
`swap!` from anywhere re-renders on the next pass rather than the next
timeout."
109
(swap! pending conj work)
(ffi/wake!)
114(defn- drain! []
115
  (let [q @pending]
    (when (seq q)
      (if (compare-and-set! pending q [])
        (doseq [f q] (f))
        (recur))))))
122;; --- timers ------------------------------------------------------------------
123(defonce ^:private timers (atom {:next-id 0 :entries {}}))
125(defn- now-ms [] (System/currentTimeMillis))
127(defn- add-timer! [ms every? f]
(let [id (:next-id (swap! timers update :next-id inc))]
  (swap! timers assoc-in [:entries id]
         {:due (+ (now-ms) ms) :every (when every? ms) :f f})
  (ffi/wake!)
132
134(defn after!
"Run `f` on the worker in about `ms` milliseconds. Returns an id for
`cancel!`."
[ms f] (add-timer! ms false f))
139(defn every!
"Run `f` on the worker about every `ms` milliseconds until cancelled."
[ms f] (add-timer! ms true f))
143(defn cancel! [id] (swap! timers update :entries dissoc id) nil)
145(defn cancel-all! [] (swap! timers assoc :entries {}) nil)
147(defn- pump-timers! []
(let [t (now-ms)
      due (reduce (fn [acc [id e]] (if (<= (:due e) t) (conj acc [id e]) acc))
                  (:entries @timers))]
  (doseq [[id e] due]
    (if-let [period (:every e)]
      (swap! timers assoc-in [:entries id :due] (+ t period))
      (swap! timers update :entries dissoc id))
    ((:f e)))
157
159(defn- next-timeout
"How long the worker may sleep: until the nearest timer, capped so a quit or
an auto-quit deadline is noticed within a quarter second."
(let [dues (map :due (vals (:entries @timers)))]
  (if (seq dues)
    (max 0 (min 250 (- (apply min dues) (now-ms))))
168;; --- events ------------------------------------------------------------------
169(defn- dispatch-events! []
170
  (when (ffi/poll-event!)
    (let [node (ffi/event-node)
          kind (ffi/event-name)
          hs (get @handlers node)]
      (case kind
        "click"    (when-let [f (:on-click hs)] (f))
        "toggled"  (when-let [f (:on-toggled hs)] (f))
        "change"   (when-let [f (:on-change hs)] (f (ffi/event-text)))
        "activate" (when-let [f (:on-activate hs)] (f))
        nil))
    (recur))))
183;; --- running -----------------------------------------------------------------
184(defn- clear-children! [node]
185
  (when (pos? (ffi/node-child-count node))
    (ffi/node-remove! node (ffi/node-child-at node 0))
    (recur)))
(forget-dead-handlers!)
192(defn quit!
"Close the window; `run` returns once libcosmic has."
(reset! quit-requested true)
(ffi/quit!)
199(defn- work-loop
"The worker: sleep until something happens, then run queued work, handlers
and timers, and publish whatever they changed in one commit."
[started auto-quit-ms]
  (loop []
    (ffi/wait! (next-timeout))
    (drain!)
    (dispatch-events!)
    (pump-timers!)
    (ffi/commit!)
    (when (and auto-quit-ms (>= (- (now-ms) started) auto-quit-ms))
      (quit!))
    (when-not (ffi/should-close?)
      (recur)))
  (finally
    ;; A handler that throws takes the window with it, rather than leaving
    ;; one on screen that nothing is listening to.
    (ffi/quit!))))
219(defn- run!
"glimmer.backend's :run. Mounts the root component, starts the worker, and
blocks the calling thread — which must be the main thread — in libcosmic
until the window closes or `quit!` is called.
Options (on top of glimmer's own :title :width :height :auto-quit-ms):
  :mode   :system (default), :dark or :light"
[opts mount-root!]
(let [{:keys [title width height mode auto-quit-ms]
       :or {title "glimmer" width 900 height 640}} opts
      root (ffi/tree-root)
      started (now-ms)]
  (reset! quit-requested false)
  ;; Mounted here, before the loop, so it reconciles inline; the first commit
  ;; is what libcosmic opens with.
  (clear-children! root)
  (mount-root! root :window)
  (ffi/commit!)
  (reset! b/loop-running? true)
  (let [worker (future (work-loop started auto-quit-ms))
        status (ffi/run! width height title
                         (case mode
                           :dark ffi/dark-mode
                           :light ffi/light-mode
                           ffi/system-mode))]
244
      ;; Rethrows whatever ended the worker, on the thread that called run.
      @worker
      (finally
        (reset! b/loop-running? false)
        (cancel-all!)
        (reset! handlers {})))
    (when-not (zero? status)
      (throw (ex-info "jolt-cosmic's window did not run cleanly"
                      {:status status}))))))
255;; --- looking at what was rendered --------------------------------------------
256(defn dump-str
"The tree as it is in the arena — after the reconciler, before any commit —
as hiccup text."
([] (dump-str 0))
([node] (ffi/tree-dump node)))
262
([] (dump 0))
([node] (read-string (dump-str node))))
266(defn dump!
([] (dump! 0))
([node] (println (dump-str node)) nil))
270;; --- the backend -------------------------------------------------------------
271(def backend
{:name           :cosmic
 :create!        create!
 :apply-props!   apply-props!
 :append-child!  append-child!
 :remove-child!  remove-child!
 :replace-child! replace-child!
 :reorder-child! reorder-child!
 :schedule       schedule
 :run            run!})
282(defn install! [] (b/register! backend) nil)
284(defonce ^:private installed (do (install!) true))

glimmer-cosmic: a libcosmic backend for glimmer (spike) 6a3304d nandi 8d ago	1	(ns glimmer-cosmic.core
	2	"The libcosmic backend for glimmer. Requiring this namespace installs it:
	3
	4	(ns myapp
	5	(:require [glimmer.core :as ui]
	6	[glimmer-cosmic.core])) ; installs this backend
	7
	8	(defn -main [& _] (ui/run my-app :title \"myapp\"))
	9
	10	The tree half is glimmer-vidya's: node handles in a Rust arena, props written
	11	across, handlers kept here and found by node id when an event comes back.
	12
	13	The loop half is inverted. libcosmic will not be driven a frame at a time —
	14	it takes the main thread and keeps it until the window closes — so `run`
	15	blocks the main thread there and the reconciler lives on a worker. The worker
	16	is \"the UI thread\" as far as glimmer is concerned: `schedule` queues onto it,
	17	handlers run on it, and at the end of each pass it commits, which is the only
	18	moment libcosmic sees what changed."
	19	(:require [glimmer.backend :as b]
	20	[glimmer-cosmic.ffi :as ffi]))
	21
	22	;; Node id -> the :on-* props that node was last rendered with.
	23	(defonce ^:private handlers (atom {}))
	24
	25	;; Work posted from other threads, run on the worker at the top of a pass.
	26	(defonce ^:private pending (atom []))
	27
	28	(defonce ^:private quit-requested (atom false))
	29
	30	;; --- props -------------------------------------------------------------------
	31	(def ^:private tag-orientation {:hbox "horizontal" :vbox "vertical"})
	32
	33	(defn- handler-key? [k]
	34	(let [s (name k)]
	35	(and (> (count s) 3) (= "on-" (subs s 0 3)))))
	36
	37	(defn- set-prop! [node k v]
	38	(let [key (name k)]
	39	(cond
	40	(nil? v) nil
	41	(true? v) (ffi/node-set-bool! node key true)
	42	(false? v) (ffi/node-set-bool! node key false)
	43	(number? v) (ffi/node-set-num! node key (double v))
	44	(string? v) (ffi/node-set-str! node key v)
	45	(keyword? v) (ffi/node-set-str! node key (name v))
	46	:else (ffi/node-set-str! node key (str v)))))
	47
	48	(defn- write-props!
	49	"Replace a node's props with `props`, cleared first so a prop a re-render
	50	stops setting is gone — and so the value libcosmic wrote back when someone
	51	typed is overwritten by the component's own state."
	52	[node tag props]
	53	(ffi/node-clear-props! node)
	54	(when-let [orientation (tag-orientation tag)]
	55	(when-not (contains? props :orientation)
	56	(ffi/node-set-str! node "orientation" orientation)))
	57	(doseq [[k v] props]
	58	(when-not (handler-key? k)
	59	(set-prop! node k v)))
	60	(swap! handlers assoc node
	61	(reduce (fn [acc [k v]]
	62	(if (and (handler-key? k) (fn? v)) (assoc acc k v) acc))
	63	{}
	64	props))
65	nil)
66
67	(defn- forget-dead-handlers! []
68	(swap! handlers
69	(fn [m]
70	(reduce (fn [acc [id hs]]
71	(if (ffi/node-exists? id) (assoc acc id hs) acc))
72	{}
73	m)))
74	nil)
75
76	;; --- the backend operations --------------------------------------------------
77	(defn- create! [tag props]
78	(let [node (ffi/node-new (name tag))]
79	(when (zero? node)
80	(throw (ex-info "jolt-cosmic could not allocate a node" {:tag tag})))
81	(write-props! node tag props)
82	node))
83
84	(defn- apply-props! [tag node props] (write-props! node tag props))
85
86	(defn- append-child! [_parent-tag parent child]
87	(ffi/node-append! parent child)
88	nil)
89
90	(defn- remove-child! [_parent-tag parent child]
91	(ffi/node-remove! parent child)
92	(forget-dead-handlers!)
93	nil)
94
95	(defn- replace-child! [_parent-tag parent old-child new-child]
96	(ffi/node-replace! parent old-child new-child)
97	(forget-dead-handlers!)
98	nil)
99
100	(defn- reorder-child! [_parent-tag parent child sibling]
101	(ffi/node-insert-after! parent child (or sibling 0))
102	nil)
103
104	;; --- the worker --------------------------------------------------------------
105	(defn- schedule
106	"glimmer.backend's :schedule. Queues `work` for the worker and wakes it, so a
107	`swap!` from anywhere re-renders on the next pass rather than the next
108	timeout."
109	[work]
110	(swap! pending conj work)
111	(ffi/wake!)
112	nil)
113
114	(defn- drain! []
115	(loop []
116	(let [q @pending]
117	(when (seq q)
118	(if (compare-and-set! pending q [])
119	(doseq [f q] (f))
120	(recur))))))
121
122	;; --- timers ------------------------------------------------------------------
123	(defonce ^:private timers (atom {:next-id 0 :entries {}}))
124
125	(defn- now-ms [] (System/currentTimeMillis))
126
127	(defn- add-timer! [ms every? f]
128	(let [id (:next-id (swap! timers update :next-id inc))]
129	(swap! timers assoc-in [:entries id]
130	{:due (+ (now-ms) ms) :every (when every? ms) :f f})
131	(ffi/wake!)
132	id))
133
134	(defn after!
135	"Run `f` on the worker in about `ms` milliseconds. Returns an id for
136	`cancel!`."
137	[ms f] (add-timer! ms false f))
138
139	(defn every!
140	"Run `f` on the worker about every `ms` milliseconds until cancelled."
141	[ms f] (add-timer! ms true f))
142
143	(defn cancel! [id] (swap! timers update :entries dissoc id) nil)
144
145	(defn cancel-all! [] (swap! timers assoc :entries {}) nil)
146
147	(defn- pump-timers! []
148	(let [t (now-ms)
149	due (reduce (fn [acc [id e]] (if (<= (:due e) t) (conj acc [id e]) acc))
150	[]
151	(:entries @timers))]
152	(doseq [[id e] due]
153	(if-let [period (:every e)]
154	(swap! timers assoc-in [:entries id :due] (+ t period))
155	(swap! timers update :entries dissoc id))
156	((:f e)))
157	nil))
158
159	(defn- next-timeout
160	"How long the worker may sleep: until the nearest timer, capped so a quit or
161	an auto-quit deadline is noticed within a quarter second."
162	[]
163	(let [dues (map :due (vals (:entries @timers)))]
164	(if (seq dues)
165	(max 0 (min 250 (- (apply min dues) (now-ms))))
166	250)))
167
168	;; --- events ------------------------------------------------------------------
169	(defn- dispatch-events! []
170	(loop []
171	(when (ffi/poll-event!)
172	(let [node (ffi/event-node)
173	kind (ffi/event-name)
174	hs (get @handlers node)]
175	(case kind
176	"click" (when-let [f (:on-click hs)] (f))
177	"toggled" (when-let [f (:on-toggled hs)] (f))
178	"change" (when-let [f (:on-change hs)] (f (ffi/event-text)))
179	"activate" (when-let [f (:on-activate hs)] (f))
180	nil))
181	(recur))))
182
183	;; --- running -----------------------------------------------------------------
184	(defn- clear-children! [node]
185	(loop []
186	(when (pos? (ffi/node-child-count node))
187	(ffi/node-remove! node (ffi/node-child-at node 0))
188	(recur)))
189	(forget-dead-handlers!)
190	nil)
191
192	(defn quit!
193	"Close the window; `run` returns once libcosmic has."
194	[]
195	(reset! quit-requested true)
196	(ffi/quit!)
197	nil)
198
199	(defn- work-loop
200	"The worker: sleep until something happens, then run queued work, handlers
201	and timers, and publish whatever they changed in one commit."
202	[started auto-quit-ms]
203	(try
204	(loop []
205	(ffi/wait! (next-timeout))
206	(drain!)
207	(dispatch-events!)
208	(pump-timers!)
209	(ffi/commit!)
210	(when (and auto-quit-ms (>= (- (now-ms) started) auto-quit-ms))
211	(quit!))
212	(when-not (ffi/should-close?)
213	(recur)))
214	(finally
215	;; A handler that throws takes the window with it, rather than leaving
216	;; one on screen that nothing is listening to.
217	(ffi/quit!))))
218
219	(defn- run!
220	"glimmer.backend's :run. Mounts the root component, starts the worker, and
221	blocks the calling thread — which must be the main thread — in libcosmic
222	until the window closes or `quit!` is called.
223
224	Options (on top of glimmer's own :title :width :height :auto-quit-ms):
225	:mode :system (default), :dark or :light"
226	[opts mount-root!]
227	(let [{:keys [title width height mode auto-quit-ms]
228	:or {title "glimmer" width 900 height 640}} opts
229	root (ffi/tree-root)
230	started (now-ms)]
231	(reset! quit-requested false)
232	;; Mounted here, before the loop, so it reconciles inline; the first commit
233	;; is what libcosmic opens with.
234	(clear-children! root)
235	(mount-root! root :window)
236	(ffi/commit!)
237	(reset! b/loop-running? true)
238	(let [worker (future (work-loop started auto-quit-ms))
239	status (ffi/run! width height title
240	(case mode
241	:dark ffi/dark-mode
242	:light ffi/light-mode
243	ffi/system-mode))]
244	(try
245	;; Rethrows whatever ended the worker, on the thread that called run.
246	@worker
247	(finally
248	(reset! b/loop-running? false)
249	(cancel-all!)
250	(reset! handlers {})))
251	(when-not (zero? status)
252	(throw (ex-info "jolt-cosmic's window did not run cleanly"
253	{:status status}))))))
254
255	;; --- looking at what was rendered --------------------------------------------
256	(defn dump-str
257	"The tree as it is in the arena — after the reconciler, before any commit —
258	as hiccup text."
259	([] (dump-str 0))
260	([node] (ffi/tree-dump node)))
261
262	(defn dump
263	([] (dump 0))
264	([node] (read-string (dump-str node))))
265
266	(defn dump!
267	([] (dump! 0))
268	([node] (println (dump-str node)) nil))
269
270	;; --- the backend -------------------------------------------------------------
271	(def backend
272	{:name :cosmic
273	:create! create!
274	:apply-props! apply-props!
275	:append-child! append-child!
276	:remove-child! remove-child!
277	:replace-child! replace-child!
278	:reorder-child! reorder-child!
279	:schedule schedule
280	:run run!})
281
282	(defn install! [] (b/register! backend) nil)
283
284	(defonce ^:private installed (do (install!) true))