nandi/jolt-native · core.clj

⑂ main

core.clj · 317 lines · 10.6 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))
Paint the rest of frq's tags in glimmer-cosmic   180          ;; The two edges of a hover, as glimmer-vidya sends them: once when
        ;; the pointer comes onto the widget and once when it leaves.
        "hover"    (when-let [f (:on-hover hs)] (f))
        "unhover"  (when-let [f (:on-unhover hs)] (f))
Hold typed text over a stale commit, and paste a picture into an entry   184          ;; Ctrl+V on a clipboard with no text on it. What is on it instead is
        ;; the caller's to find out, with `clipboard-image-png!`.
        "paste-empty" (when-let [f (:on-paste-empty hs)] (f))
glimmer-cosmic: a libcosmic backend for glimmer (spike)   187          nil))
    (recur))))
190;; --- running -----------------------------------------------------------------
191(defn- clear-children! [node]
192
  (when (pos? (ffi/node-child-count node))
    (ffi/node-remove! node (ffi/node-child-at node 0))
    (recur)))
(forget-dead-handlers!)
199(defn quit!
"Close the window; `run` returns once libcosmic has."
(reset! quit-requested true)
(ffi/quit!)
206(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!))))
226(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))]
251
      ;; 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}))))))
262;; --- looking at what was rendered --------------------------------------------
263(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)))
269
([] (dump 0))
([node] (read-string (dump-str node))))
273(defn dump!
([] (dump! 0))
([node] (println (dump-str node)) nil))
277;; --- the backend -------------------------------------------------------------
Report the window size, open the portal chooser, and colour emoji   278;; --- the window and the desktop ------------------------------------------------
279(defn window-size
"The window's size in points, [width height]: the size asked for until it
has opened, and what libcosmic reports after that."
[(ffi/window-width) (ffi/window-height)])
285(defn pick-image!
"Open the desktop's picture chooser. True when it was asked for; the choice
is collected with `picked-image!`, since the chooser answers when the person
using it does."
(ffi/pick-image!))
292(defn picked-image!
"Write the chosen picture to `path` as PNG. True once, when one was chosen."
294
(ffi/picked-image! path))
Hold typed text over a stale commit, and paste a picture into an entry   297(defn clipboard-image-png!
"Write the picture on the clipboard to `path` as PNG. True when there was
one — as found by the Ctrl+V that fired the `:entry`'s `:on-paste-empty`,
since libcosmic reads its clipboard on its own thread, not on demand."
301
(ffi/clipboard-image-png! path))
glimmer-cosmic: a libcosmic backend for glimmer (spike)   304(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!})
315(defn install! [] (b/register! backend) nil)
317(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))
Paint the rest of frq's tags in glimmer-cosmic 7703c75 nandi 8d ago	180	;; The two edges of a hover, as glimmer-vidya sends them: once when
	181	;; the pointer comes onto the widget and once when it leaves.
	182	"hover" (when-let [f (:on-hover hs)] (f))
	183	"unhover" (when-let [f (:on-unhover hs)] (f))
Hold typed text over a stale commit, and paste a picture into an entry 1ee075a nandi 8d ago	184	;; Ctrl+V on a clipboard with no text on it. What is on it instead is
	185	;; the caller's to find out, with `clipboard-image-png!`.
	186	"paste-empty" (when-let [f (:on-paste-empty hs)] (f))
glimmer-cosmic: a libcosmic backend for glimmer (spike) 6a3304d nandi 8d ago	187	nil))
	188	(recur))))
	189
	190	;; --- running -----------------------------------------------------------------
	191	(defn- clear-children! [node]
	192	(loop []
	193	(when (pos? (ffi/node-child-count node))
	194	(ffi/node-remove! node (ffi/node-child-at node 0))
	195	(recur)))
	196	(forget-dead-handlers!)
	197	nil)
	198
	199	(defn quit!
	200	"Close the window; `run` returns once libcosmic has."
	201	[]
	202	(reset! quit-requested true)
	203	(ffi/quit!)
	204	nil)
	205
	206	(defn- work-loop
	207	"The worker: sleep until something happens, then run queued work, handlers
	208	and timers, and publish whatever they changed in one commit."
	209	[started auto-quit-ms]
	210	(try
	211	(loop []
	212	(ffi/wait! (next-timeout))
	213	(drain!)
	214	(dispatch-events!)
	215	(pump-timers!)
	216	(ffi/commit!)
	217	(when (and auto-quit-ms (>= (- (now-ms) started) auto-quit-ms))
	218	(quit!))
	219	(when-not (ffi/should-close?)
	220	(recur)))
	221	(finally
	222	;; A handler that throws takes the window with it, rather than leaving
	223	;; one on screen that nothing is listening to.
	224	(ffi/quit!))))
	225
	226	(defn- run!
	227	"glimmer.backend's :run. Mounts the root component, starts the worker, and
	228	blocks the calling thread — which must be the main thread — in libcosmic
	229	until the window closes or `quit!` is called.
	230
	231	Options (on top of glimmer's own :title :width :height :auto-quit-ms):
	232	:mode :system (default), :dark or :light"
	233	[opts mount-root!]
	234	(let [{:keys [title width height mode auto-quit-ms]
	235	:or {title "glimmer" width 900 height 640}} opts
	236	root (ffi/tree-root)
	237	started (now-ms)]
	238	(reset! quit-requested false)
	239	;; Mounted here, before the loop, so it reconciles inline; the first commit
	240	;; is what libcosmic opens with.
	241	(clear-children! root)
	242	(mount-root! root :window)
	243	(ffi/commit!)
	244	(reset! b/loop-running? true)
	245	(let [worker (future (work-loop started auto-quit-ms))
	246	status (ffi/run! width height title
	247	(case mode
	248	:dark ffi/dark-mode
	249	:light ffi/light-mode
	250	ffi/system-mode))]
251	(try
252	;; Rethrows whatever ended the worker, on the thread that called run.
253	@worker
254	(finally
255	(reset! b/loop-running? false)
256	(cancel-all!)
257	(reset! handlers {})))
258	(when-not (zero? status)
259	(throw (ex-info "jolt-cosmic's window did not run cleanly"
260	{:status status}))))))
261
262	;; --- looking at what was rendered --------------------------------------------
263	(defn dump-str
264	"The tree as it is in the arena — after the reconciler, before any commit —
265	as hiccup text."
266	([] (dump-str 0))
267	([node] (ffi/tree-dump node)))
268
269	(defn dump
270	([] (dump 0))
271	([node] (read-string (dump-str node))))
272
273	(defn dump!
274	([] (dump! 0))
275	([node] (println (dump-str node)) nil))
276
277	;; --- the backend -------------------------------------------------------------
Report the window size, open the portal chooser, and colour emoji 71cdc87 nandi 8d ago	278	;; --- the window and the desktop ------------------------------------------------
	279	(defn window-size
	280	"The window's size in points, [width height]: the size asked for until it
	281	has opened, and what libcosmic reports after that."
	282	[]
	283	[(ffi/window-width) (ffi/window-height)])
	284
	285	(defn pick-image!
	286	"Open the desktop's picture chooser. True when it was asked for; the choice
	287	is collected with `picked-image!`, since the chooser answers when the person
	288	using it does."
	289	[]
	290	(ffi/pick-image!))
	291
	292	(defn picked-image!
	293	"Write the chosen picture to `path` as PNG. True once, when one was chosen."
	294	[path]
	295	(ffi/picked-image! path))
	296
Hold typed text over a stale commit, and paste a picture into an entry 1ee075a nandi 8d ago	297	(defn clipboard-image-png!
	298	"Write the picture on the clipboard to `path` as PNG. True when there was
	299	one — as found by the Ctrl+V that fired the `:entry`'s `:on-paste-empty`,
	300	since libcosmic reads its clipboard on its own thread, not on demand."
	301	[path]
	302	(ffi/clipboard-image-png! path))
	303
glimmer-cosmic: a libcosmic backend for glimmer (spike) 6a3304d nandi 8d ago	304	(def backend
	305	{:name :cosmic
	306	:create! create!
	307	:apply-props! apply-props!
	308	:append-child! append-child!
	309	:remove-child! remove-child!
	310	:replace-child! replace-child!
	311	:reorder-child! reorder-child!
	312	:schedule schedule
	313	:run run!})
	314
	315	(defn install! [] (b/register! backend) nil)
	316
	317	(defonce ^:private installed (do (install!) true))