From 4f482823142bcc7db971180ec80ca4e5096e91c141cc945bf1b4f49129635d23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= Date: Sun, 25 Oct 2026 17:02:02 +0100 Subject: [PATCH] Commands and subscriptions, and gui-update MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit gui-update is a plain function, so it cannot wait. It returns the work to do as values. A command is an (Event %m), synced in a fiber of its own, whose answer is the next message. A subscription is a source of messages that the model asks for: after each update the app starts the new ones and cancels the ones that are gone, by key. every sends a message on a timer, and subscription takes a source of one's own. The fibers belong to the app's scope and post their messages to the UI thread, so gui-update and view only run there. Closing the window cancels them. The prelude's path macros already use the name update, hence gui-update. 🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8) Co-Authored-By: eca-agent --- Readme.org | 76 +++++++++++--- examples/counter.bjo | 15 +-- examples/stopwatch.bjo | 55 ++++++++++ src/app.bjo | 230 ++++++++++++++++++++++++++++++++++------- tests/app.bjo | 21 ++-- tests/effects.bjo | 130 +++++++++++++++++++++++ 6 files changed, 460 insertions(+), 67 deletions(-) create mode 100644 examples/stopwatch.bjo create mode 100644 tests/effects.bjo diff --git a/Readme.org b/Readme.org index 181c3cd..07e4100 100644 --- a/Readme.org +++ b/Readme.org @@ -1,7 +1,7 @@ #+TITLE: bjogui -Desktop programs in Bjolang, written as a model, an ~update~ and a ~view~, and -shown with [[https://avaloniaui.net][Avalonia]]. +Desktop programs in Bjolang, written as a model, a ~gui-update~ and a ~view~, +and shown with [[https://avaloniaui.net][Avalonia]]. #+BEGIN_SRC scheme (import (bjogui view)) @@ -9,9 +9,9 @@ shown with [[https://avaloniaui.net][Avalonia]]. (type (: Msg (Union Inc Dec))) -(: update (-> Msg int int)) -(defun (update msg n) - (match msg (Inc (+ n 1)) (Dec (- n 1)))) +(: gui-update (-> Msg int (Tuple int (List (Event Msg))))) +(defun (gui-update msg n) + (next (match msg (Inc (+ n 1)) (Dec (- n 1))))) (: view (-> int (View Msg))) (defun (view n) @@ -21,7 +21,7 @@ shown with [[https://avaloniaui.net][Avalonia]]. (button "+" Inc))) (defun (main) - (run-app 0 update view #:title "Counter")) + (run-app 0 gui-update view #:title "Counter")) #+END_SRC A program never names an Avalonia type. A view is a Bjolang value, an event @@ -30,7 +30,7 @@ is a message, and the controls are made and changed by the package. * How it works An event finds its message in the view its control was last given. -~update~ makes the next model from the message, and ~view~ makes the next +~gui-update~ makes the next model from the message, and ~view~ makes the next view. The next view is compared with the last one, control by control, and only what differs is changed. So a control keeps its focus, its caret and its scroll position when the model changes. @@ -57,14 +57,59 @@ They take keywords where they apply: ~#:size~ (the font size of a text), children of a column or a row), ~#:enabled~ and ~#:placeholder~. A size of zero, the default, leaves the size to the control. +* Work: commands and subscriptions + +~gui-update~ is a plain function, so it cannot wait, and the compiler says so +if it tries. Work is a value it returns, and the app runs it. + +A *command* is an ~(Event %m)~: an event whose answer is a message. ~(next m +command ...)~ is the next model and the commands to start; ~(next m)~ is the +model alone. The app syncs each command in a fiber of its own and gives its +message to ~gui-update~. Any event will do: a ~timeout~, a ~blocking~ call, a +channel, a ~choose~ of several. + +#+BEGIN_SRC scheme +(Load (next (record-set m (loading #t)) + (wrap (blocking (fun () (file-read-text path))) Loaded))) +#+END_SRC + +A *subscription* is a source of messages that runs while the model asks for +it. ~subscriptions~ gives the list for a model. After each update the app +starts those that are new and cancels those that are gone; the others keep +running. A subscription is known by its key. + +- ~(every duration msg)~ sends ~msg~ each time ~duration~ has passed. +- ~(subscription key next-event)~ is a source of your own: ~next-event~ gives + the event of the next message, and is called again after each one. + ~(subscription "jobs" (fun () (wrap (chan-recv jobs) Got)))~ sends what + comes on a channel. + +#+BEGIN_SRC scheme +(: subscriptions (-> Model (List (Sub Msg)))) +(defun (subscriptions m) + (if (.running m) (list (every (milliseconds 100) Tick)) '())) +#+END_SRC + +The fibers belong to the app. They post their messages to the UI thread, so +~gui-update~ and ~view~ always run there. When the window is closed they are +cancelled, and the program ends. + * Running: (bjogui app) -- ~(run-app init update view #:title #:width #:height)~ opens a window and - runs until it is closed. -- ~(start-app init update view on-root)~ makes the controls with no window, - and gives ~on-root~ the control to show. ~app-dispatch!~ sends a message, - ~app-model~ reads the model, and ~app-control-at~ finds a control by its - path of child indices. ~tests/app.bjo~ uses these to drive an app through +- ~(run-app init gui-update view #:subscriptions #:title #:width #:height)~ + opens a window and runs until it is closed. +- ~(start-app init gui-update view on-root #:subscriptions)~ makes the controls + with no window, and gives ~on-root~ the control to show. Its fibers belong + to the scope it is started in. + - ~app-dispatch!~ gives a message on the UI thread, and ~app-send!~ from any + thread. + - ~app-run-pending!~ runs what fibers have posted, where no loop of + Avalonia's does. + - ~app-stop!~ cancels the subscriptions and drops later messages. + - ~app-model~ reads the model, and ~app-control-at~ finds a control by its + path of child indices. + + ~tests/app.bjo~ and ~tests/effects.bjo~ use these to drive an app through its real controls. * Requirements @@ -77,12 +122,13 @@ zero, the default, leaves the size to the control. * Tests #+BEGIN_SRC sh -bjo run tests/app.bjo # prints "bjogui ok" +bjo run tests/app.bjo # prints "bjogui ok" +bjo run tests/effects.bjo # prints "bjogui effects ok" bjo run examples/counter.bjo +bjo run examples/stopwatch.bjo #+END_SRC * Not yet - Keyed children, for lists whose items move. -- Messages from fibers and timers, for work that is not a click. - More controls: lists, grids, images, scroll views, menus. diff --git a/examples/counter.bjo b/examples/counter.bjo index ca968fb..e72db7a 100644 --- a/examples/counter.bjo +++ b/examples/counter.bjo @@ -13,12 +13,13 @@ (type (: Msg (Union Inc Dec (: Typed string)))) (type (: Model (Record (: count int) (: name string)))) -(: update (-> Msg Model Model)) -(defun (update msg m) - (match msg - (Inc (record-set m (count (+ (.count m) 1)))) - (Dec (record-set m (count (- (.count m) 1)))) - ((Typed s) (record-set m (name s))))) +(: gui-update (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m) + (next + (match msg + (Inc (record-set m (count (+ (.count m) 1)))) + (Dec (record-set m (count (- (.count m) 1)))) + ((Typed s) (record-set m (name s)))))) (: view (-> Model (View Msg))) (defun (view m) @@ -31,4 +32,4 @@ (button "+" Inc #:width 40.0)))) (defun (main) - (run-app (Model (count 0) (name "")) update view #:title "Counter" #:width 320.0 #:height 200.0)) + (run-app (Model (count 0) (name "")) gui-update view #:title "Counter" #:width 320.0 #:height 200.0)) diff --git a/examples/stopwatch.bjo b/examples/stopwatch.bjo new file mode 100644 index 0000000..6ff45a5 --- /dev/null +++ b/examples/stopwatch.bjo @@ -0,0 +1,55 @@ +;; This Source Code Form is subject to the terms of the Mozilla Public +;; License, v. 2.0. If a copy of the MPL was not distributed with this +;; file, You can obtain one at http://mozilla.org/MPL/2.0/. + +;; bjogui/examples/stopwatch.bjo — a subscription and a command. +;; +;; bjo run examples/stopwatch.bjo +;; +;; The stopwatch ticks while it runs: `subscriptions` asks for a tick only +;; then, so stopping it stops the fiber. "Lap" saves the time after a pause, +;; to show a command: the pause runs in a fiber, and the window does not wait +;; for it. + +(import (std prelude)) +(import (bjogui view)) +(import (bjogui app)) + +(type (: Msg (Union Toggle Tick Reset Lap (: Saved int)))) +(type (: Model (Record (: tenths int) (: running bool) (: saving bool) (: laps (List int))))) + +(: gui-update (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m) + (match msg + (Toggle (next (record-set m (running (not (.running m)))))) + (Tick (next (record-set m (tenths (+ (.tenths m) 1))))) + (Reset (next (record-set m (tenths 0) (laps '())))) + ;; The time is taken now, and saved half a second later. + (Lap (next (record-set m (saving #t)) + (wrap (timeout (milliseconds 500)) (fun (_) (Saved (.tenths m)))))) + ((Saved t) (next (record-set m (saving #f) (laps (cons t (.laps m)))))))) + +(: subscriptions (-> Model (List (Sub Msg)))) +(defun (subscriptions m) + (if (.running m) (list (every (milliseconds 100) Tick)) '())) + +(: (-> int string)) +(defun (show tenths) + #"${(/ tenths 10)}.${(% tenths 10)} s") + +(: view (-> Model (View Msg))) +(defun (view m) + (column #:spacing 8.0 #:margin 16.0 + (text (show (.tenths m)) #:size 32.0) + (row #:spacing 8.0 + (button (if (.running m) "Stop" "Start") Toggle #:width 80.0) + (button "Lap" Lap #:enabled (not (.saving m)) #:width 80.0) + (button "Reset" Reset #:width 80.0)) + (apply column (vec->array (vec-map (fun (t) (text #"lap: ${(show t)}")) + (list->vec (.laps m))))))) + +(defun (main) + (run-app (Model (tenths 0) (running #f) (saving #f) (laps '())) + gui-update view + #:subscriptions subscriptions + #:title "Stopwatch" #:width 320.0 #:height 300.0)) diff --git a/src/app.bjo b/src/app.bjo index b906b54..10f8215 100644 --- a/src/app.bjo +++ b/src/app.bjo @@ -4,24 +4,34 @@ ;; bjogui/src/app.bjo — the module (bjogui app). ;; -;; Runs a program written as a model, an `update` and a `view`, in an Avalonia -;; window. Every Avalonia name stays in this module: what it exports takes -;; and gives Bjolang values, and a control only as an opaque `Control`. +;; Runs a program written as a model, a `gui-update` and a `view`, in an +;; Avalonia window. Every Avalonia name stays in this module: what it exports +;; takes and gives Bjolang values, and a control only as an opaque `Control`. ;; ;; The loop: an event finds its message in the view the control was last -;; given. `update` makes the next model from it, and `view` the next view. +;; given. `gui-update` makes the next model from it, and `view` the next view. ;; The next view is compared with the last one, control by control, and only ;; what differs is changed. So a control keeps its focus, its caret and its ;; scroll position when the model changes. ;; +;; `gui-update` does no work of its own: it is a plain function, so it cannot +;; wait. Work is a value it returns. A command is an `(Event %m)`: the app +;; syncs it in a fiber, and gives the message it answers to `gui-update`. A +;; subscription is a source of messages that runs as long as the model asks +;; for it: after each update the app starts the subscriptions that are new +;; and stops those that are gone. +;; ;; Every control is made with plain constructors and changed with ;; `AvaloniaObject.SetValue`, so no Avalonia class is subclassed. (export - App Live Control - run-app + App Live Control Sub + run-app next + ;; Subscriptions. + every subscription ;; For tests and for hosts of their own: an app with no window. - start-app app-dispatch! app-model app-control app-control-at) + start-app app-dispatch! app-send! app-stop! app-run-pending! + app-model app-control app-control-at) (import (std prelude)) (import (std interop)) @@ -67,7 +77,10 @@ (AppBuilder (: Avalonia.AppBuilder)) (ILifetime (: Avalonia.Controls.ApplicationLifetimes.IApplicationLifetime)) (Lifetime (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime - (-> Lifetime)))) + (-> Lifetime))) + (Dispatcher (: Avalonia.Threading.Dispatcher)) + (UiPriority (: Avalonia.Threading.DispatcherPriority)) + ((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation))) (import/extern ;; Properties, as the objects `SetValue` takes. @@ -108,6 +121,13 @@ (panel-children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get)) (clr-string (: System.Convert.ToString (-> string ClrString))) + ;; The UI thread. Controls may be touched only there, so a message from a + ;; fiber is posted to it. + (ui-dispatcher (: Avalonia.Threading.Dispatcher.UIThread #:get)) + (ui-thread? (: Avalonia.Threading.Dispatcher.CheckAccess (-> Dispatcher bool))) + (ui-post (: Avalonia.Threading.Dispatcher.InvokeAsync (-> Dispatcher (-> Unit) (DispatcherOp Unit)))) + (ui-run-jobs (: Avalonia.Threading.Dispatcher.RunJobs (-> Dispatcher (Nullable UiPriority) void))) + ;; The window and the application. (configure (: Avalonia.AppBuilder.Configure (-> (-> Application) AppBuilder))) (use-platform-detect (: Avalonia.AppBuilderDesktopExtensions.UsePlatformDetect @@ -226,17 +246,66 @@ (: view (View %m) #:mutable) (: children (MutableVec (Live %m)))))) +;; --------------------------------------------------------------------------- +;; Commands and subscriptions +;; --------------------------------------------------------------------------- + +;; A source of messages that runs while the model asks for it. `key` says +;; which one it is: after an update, a subscription whose key was there before +;; keeps running, and is not started again. +;; +;; `next-event` gives the event of the next message. A fiber of the +;; subscription's own calls it, syncs the event, sends the message, and calls +;; it again. The fiber is cancelled at that `sync` when the key is gone, and +;; when the app stops. +(type (: (Sub %m) #:opaque (Record (: key string) + (: next-event (-> (Event %m)))))) + +;; A subscription to a source of your own: `(subscription "jobs" (fun () +;; (chan-recv jobs)))` sends each value that comes on a channel. Two +;; subscriptions with the same key are one: the first is the one that runs. +(: subscription (-> string (-> (Event %m)) (Sub %m))) +(defun (subscription key next-event) + (Sub (key key) (next-event next-event))) + +;; Sends `msg` each time `d` has passed. The time is counted from the last +;; message, so a slow update makes the next one later and they do not queue +;; up. +(: every (-> Duration %m (Sub %m)) (where (Written %m))) +(defun (every d msg) + (Sub (key #"every ${(duration-ticks d)} ${(written msg)}") + (next-event (fun () (wrap (timeout d) (fun (_) msg)))))) + +;; The next model, and the commands to run. `(next m)` is the model alone. +(: next (-> %model #:rest (Event %m) (Tuple %model (List (Event %m))))) +(defun (next m #:rest commands) + (Tuple m (->list commands))) + +;; --------------------------------------------------------------------------- +;; The app +;; --------------------------------------------------------------------------- + ;; A running program. ;; ;; `patching` is true while the controls are being changed. A control that ;; is changed raises its own events, such as a text input whose text is set, ;; and those are not the user's: they are dropped. -(type (: (App %model %m) #:opaque (Record (: model %model #:mutable) - (: update (-> %m %model %model)) - (: view (-> %model (View %m))) - (: root (Option (Live %m)) #:mutable) - (: patching bool #:mutable) - (: on-root (-> Control void))))) +;; +;; `home` is the scope the app's fibers belong to. A message can arrive from +;; Avalonia on a thread with no scope, so each update is run in it. +;; `subs` holds each running subscription's key, and the scope it runs in, so +;; that one can be cancelled and the others not. +(type (: (App %model %m) #:opaque + (Record (: model %model #:mutable) + (: gui-update (-> %m %model (Tuple %model (List (Event %m))))) + (: view (-> %model (View %m))) + (: subscriptions (-> %model (List (Sub %m)))) + (: root (Option (Live %m)) #:mutable) + (: patching bool #:mutable) + (: stopped bool #:mutable) + (: home Scope) + (: subs (List (Tuple string Scope)) #:mutable) + (: on-root (-> Control void))))) (: (-> (App %model %m) %model)) (defun (app-model app) (.model app)) @@ -261,29 +330,110 @@ ((Some live) (walk live path)) (None (raise (cast Exception (InvalidOperation. "the app has no view")))))) -;; Makes the next model from `msg`, and shows its view. +;; Makes the next model from `msg`, shows its view, starts its commands, and +;; starts and stops subscriptions. Only on the UI thread; from anywhere else, +;; use `app-send!`. A stopped app drops the message. (: (-> (App %model %m) %m void)) (defun (app-dispatch! app msg) - (record-set! app (model ((.update app) msg (.model app)))) - (render! app)) + (unless (.stopped app) + (def (Tuple model commands) ((.gui-update app) msg (.model app))) + (record-set! app (model model)) + (step! app commands))) + +;; Gives `msg` to the app from any thread. Off the UI thread it is posted to +;; the UI thread, and runs there after the messages posted before it. +(: (-> (App %model %m) %m void)) +(defun (app-send! app msg) + (if (ui-thread? ui-dispatcher) + (app-dispatch! app msg) + (post! app msg))) + +;; Posts `msg` to the UI thread. What a fiber does: it is never on the UI +;; thread, and it must not run an update itself. +(: (-> (App %model %m) %m void)) +(defun (post! app msg) + (ignore (ui-post ui-dispatcher (fun () (app-dispatch! app msg) unit)))) + +;; Runs the messages that fibers have posted to the UI thread, now. For a test +;; or a host with no window, where no loop of Avalonia's runs them. +(: (-> (App %model %m) void)) +(defun (app-run-pending! app) + (ui-run-jobs ui-dispatcher (clr-default))) + +;; Stops the app: its subscriptions are cancelled, and later messages are +;; dropped. A command that is still running is cancelled when the scope the +;; app was started in ends. +(: (-> (App %model %m) void)) +(defun (app-stop! app) + (record-set! app (stopped #t)) + (loop (:for (Tuple _ scope) (.subs app)) (:do (stop-scope! scope))) + (record-set! app (subs '()))) + +(: (-> (App %model %m) (List (Event %m)) void)) +(defun (step! app commands) + (render! app) + (in-scope (.home app) + (loop (:for command commands) + (:do (spawn/daemon (run-command app command))))) + (sync-subs! app)) + +(: (-bjo-> (App %model %m) (Event %m) void)) +(defbjo (run-command app command) + (post! app (sync command))) + +(: (-bjo-> (App %model %m) (-> (Event %m)) void)) +(defbjo (run-sub app next-event) + (let go () + (post! app (sync (next-event))) + (go))) + +;; Cancels a subscription's scope, and so its fiber. The scope is not closed: +;; closing waits, and nothing is owned in it to release. +(: (-> Scope void)) +(defun (stop-scope! scope) + (scope-cancel! scope (Requested "the subscription is gone"))) + +;; Starts a subscription in a scope of its own, inside the app's, so that it +;; can be cancelled alone. +(: (-> (App %model %m) (Sub %m) Scope)) +(defun (start-sub! app sub) + (in-scope (.home app) + (def scope (scope-open! 0)) + (in-scope scope + (spawn/daemon (run-sub app (.next-event sub)))) + scope)) + +(: (-> (App %model %m) void)) +(defun (sync-subs! app) + (def wanted ((.subscriptions app) (.model app))) + (defun (wanted? key) (any? (fun (sub) (= (.key sub) key)) wanted)) + (def/mutable kept '()) + (loop (:for (Tuple key scope) (.subs app)) + (:do (if (wanted? key) + (set! kept (cons (Tuple key scope) kept)) + (stop-scope! scope)))) + (loop (:for sub wanted) + (:when (not (any? (fun (t) (= (fst t) (.key sub))) kept))) + (:do (set! kept (cons (Tuple (.key sub) (start-sub! app sub)) kept)))) + (record-set! app (subs kept))) (: (-> (App %model %m) void)) (defun (render! app) - (def next ((.view app) (.model app))) + (def next-view ((.view app) (.model app))) (record-set! app (patching #t)) (match (.root app) (None - (def live (mount app next)) + (def live (mount app next-view)) (record-set! app (root (Some live))) ((.on-root app) (.control live))) ((Some live) - (def now (patch! app live next)) + (def now (patch! app live next-view)) (unless (eq? now live) (record-set! app (root (Some now))) ((.on-root app) (.control now))))) (record-set! app (patching #f))) -;; Gives the message that `pick` finds in the control's events to `update`. +;; Gives the message that `pick` finds in the control's events to `gui-update`. (: (-> (App %model %m) (Live %m) (-> (On %m) (Option %m)) void)) (defun (fire! app live pick) (unless (.patching app) @@ -391,21 +541,27 @@ (mutablevec-add! kids c) (.Add controls (.control c))))) -;; An app with no window: its view is made now, and `on-root` is given the -;; control to show each time that control changes. -(: (-> %model (-> %m %model %model) (-> %model (View %m)) (-> Control void) +;; An app with no window: its view is made now, its subscriptions started, +;; and `on-root` is given the control to show each time that control changes. +;; Its fibers belong to the scope it is started in. +(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m)) + (-> Control void) (#:subscriptions (-> %model (List (Sub %m)))) (App %model %m))) -(defun (start-app init update view on-root) - (def app (App (model init) (update update) (view view) (root None) (patching #f) - (on-root on-root))) - (render! app) +(defun (start-app init gui-update view on-root #:subscriptions (fun (m) '())) + (def app (App (model init) (gui-update gui-update) (view view) + (subscriptions subscriptions) (root None) (patching #f) (stopped #f) + (home (current-scope)) (subs '()) (on-root on-root))) + (step! app '()) app) -;; Runs the program in a window, until the window is closed. -(: (-> %model (-> %m %model %model) (-> %model (View %m)) +;; Runs the program in a window, until the window is closed. Then the +;; subscriptions and the commands still running are cancelled. +(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m)) + (#:subscriptions (-> %model (List (Sub %m)))) (#:title string) (#:width double) (#:height double) void)) -(defun (run-app init update view #:title "bjogui" #:width 400.0 #:height 300.0) +(defun (run-app init gui-update view #:subscriptions (fun (m) '()) + #:title "bjogui" #:width 400.0 #:height 300.0) ;; The Application is made inside the setup, because making one uses the ;; dispatcher, and the dispatcher is the platform's only after the setup. (def lifetime (Lifetime.)) @@ -418,7 +574,11 @@ (cast Object width) Priority.LocalValue)) (ignore (set-value (cast AvaloniaObject w) (cast AvaloniaProperty height-property) (cast Object height) Priority.LocalValue)) - (ignore (start-app init update view - (fun (c) (window-content! (cast ContentControl w) (cast Object c))))) - (main-window! lifetime w) - (ignore (start-lifetime lifetime (: (make-array 0) (Array ClrString))))) + (with-cancel (cancel) + (def app (start-app init gui-update view + (fun (c) (window-content! (cast ContentControl w) (cast Object c))) + #:subscriptions subscriptions)) + (main-window! lifetime w) + (ignore (start-lifetime lifetime (: (make-array 0) (Array ClrString)))) + (app-stop! app) + (cancel (Requested "the window is closed")))) diff --git a/tests/app.bjo b/tests/app.bjo index 59f9ef3..87e482c 100644 --- a/tests/app.bjo +++ b/tests/app.bjo @@ -8,7 +8,7 @@ ;; ;; No window is opened. The test raises the events a user would cause on the ;; Avalonia controls, and reads back what the controls hold, so it goes -;; through the handlers, update, view and patch as a program does. +;; through the handlers, gui-update, view and patch as a program does. (import (std prelude)) (import (std simpletest)) @@ -60,14 +60,15 @@ (type (: Msg (Union Inc Dec (: Typed string) (: Shout bool) Reset))) (type (: Model (Record (: count int) (: name string) (: loud bool)))) -(: update (-> Msg Model Model)) -(defun (update msg m) - (match msg - (Inc (record-set m (count (+ (.count m) 1)))) - (Dec (record-set m (count (- (.count m) 1)))) - ((Typed s) (record-set m (name s))) - ((Shout b) (record-set m (loud b))) - (Reset (Model (count 0) (name "") (loud #f))))) +(: gui-update (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m) + (next + (match msg + (Inc (record-set m (count (+ (.count m) 1)))) + (Dec (record-set m (count (- (.count m) 1)))) + ((Typed s) (record-set m (name s))) + ((Shout b) (record-set m (loud b))) + (Reset (Model (count 0) (name "") (loud #f)))))) (: greeting (-> Model string)) (defun (greeting m) @@ -92,7 +93,7 @@ (defun (main) (def/mutable roots 0) - (def app (start-app (Model (count 0) (name "") (loud #f)) update view + (def app (start-app (Model (count 0) (name "") (loud #f)) gui-update view (fun (c) (set! roots (+ roots 1))))) (defun (at path) (app-control-at app path)) diff --git a/tests/effects.bjo b/tests/effects.bjo new file mode 100644 index 0000000..3281cfc --- /dev/null +++ b/tests/effects.bjo @@ -0,0 +1,130 @@ +;; This Source Code Form is subject to the terms of the Mozilla Public +;; License, v. 2.0. If a copy of the MPL was not distributed with this +;; file, You can obtain one at http://mozilla.org/MPL/2.0/. + +;; bjogui/tests/effects.bjo — commands and subscriptions. +;; +;; bjo run tests/effects.bjo +;; +;; No window is opened. The fibers of commands and subscriptions post their +;; messages to the UI thread, and the test runs what was posted with +;; `app-run-pending!`, as Avalonia's loop would. + +(import (std prelude)) +(import (std simpletest)) +(import (bjogui view)) +(import (bjogui app)) + +(import/class + (TextBlock (: Avalonia.Controls.TextBlock))) + +(import/extern + (block-text (: Avalonia.Controls.TextBlock.Text (-> TextBlock string) #:get)) + (sleep-ms (: System.Threading.Thread.Sleep (-> int void) #:blocking))) + +;; --------------------------------------------------------------------------- +;; The program under test +;; --------------------------------------------------------------------------- + +(type (: Msg (Union Load (: Loaded string) Compute (: Computed int) + Start Stop Tick (: Got int) Other))) + +(type (: Model (Record (: text string) (: answer int) (: running bool) + (: ticks int) (: got (List int)) (: others int)))) + +(def jobs (: (make-chan) (Chan int))) + +(: gui-update (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m) + (match msg + (Load (next (record-set m (text "loading")) + (wrap (timeout (milliseconds 20)) (fun (_) (Loaded "done"))))) + ((Loaded s) (next (record-set m (text s)))) + (Compute (next m (wrap (blocking (fun () (* 6 7))) + (fun (r) (match r ((Ok n) (Computed n)) ((Err _) (Computed -1))))))) + ((Computed n) (next (record-set m (answer n)))) + (Start (next (record-set m (running #t)))) + (Stop (next (record-set m (running #f)))) + (Tick (next (record-set m (ticks (+ (.ticks m) 1))))) + ((Got n) (next (record-set m (got (cons n (.got m)))))) + (Other (next (record-set m (others (+ (.others m) 1))))))) + +;; A channel is a rendezvous, so a send waits for the subscription's fiber. +;; It is a fiber of its own, because `main` cannot wait on an event. +(: (-bjo-> void)) +(defbjo (feed-jobs) + (chan-put jobs 1) + (chan-put jobs 2)) + +(: subscriptions (-> Model (List (Sub Msg)))) +(defun (subscriptions m) + (cons (subscription "jobs" (fun () (wrap (chan-recv jobs) Got))) + (if (.running m) (list (every (milliseconds 10) Tick)) '()))) + +(: view (-> Model (View Msg))) +(defun (view m) + (column (text (.text m)) (text #"ticks: ${(.ticks m)}"))) + +;; --------------------------------------------------------------------------- +;; The test +;; --------------------------------------------------------------------------- + +(defun (main) + (def app (start-app (Model (text "") (answer 0) (running #f) (ticks 0) (got '()) (others 0)) + gui-update view (fun (c) unit) + #:subscriptions subscriptions)) + + ;; Runs what the fibers posted until `done?` holds, for two seconds at most. + (: (-> (-> Model bool) bool)) + (defun (wait-for done?) + (let go ((tries 0)) + (app-run-pending! app) + (cond ((done? (app-model app)) #t) + ((> tries 200) #f) + (else (sleep-ms 10) (go (+ tries 1)))))) + + ;; Waits a while and runs what was posted, for a check that nothing came. + (defun (settle) + (sleep-ms 60) + (app-run-pending! app)) + + ;; --- commands ------------------------------------------------------------- + (app-dispatch! app Load) + (expect "a command does not wait" (.text (app-model app)) "loading") + (expect "its message comes" (wait-for (fun (m) (= (.text m) "done"))) #t) + (expect "and is shown" (block-text (cast TextBlock (app-control-at app '(0)))) "done") + + (app-dispatch! app Compute) + (expect "a blocking command" (wait-for (fun (m) (= (.answer m) 42))) #t) + + ;; --- a subscription that the model turns on and off ------------------------ + (app-dispatch! app Start) + (expect "a running subscription ticks" (wait-for (fun (m) (>= (.ticks m) 3))) #t) + (app-dispatch! app Other) + (expect "it keeps ticking across other messages" + (let ((now (.ticks (app-model app)))) (wait-for (fun (m) (> (.ticks m) now)))) + #t) + (app-dispatch! app Stop) + (settle) + (def stopped-at (.ticks (app-model app))) + (settle) + (expect "a subscription that is gone stops" (.ticks (app-model app)) stopped-at) + (app-dispatch! app Start) + (expect "and starts again" (wait-for (fun (m) (> (.ticks m) stopped-at))) #t) + (app-dispatch! app Stop) + + ;; --- a subscription of one's own -------------------------------------------- + (spawn (feed-jobs)) + (expect "values from a channel" (wait-for (fun (m) (= (.got m) '(2 1)))) #t) + + ;; --- stopping -------------------------------------------------------------- + (app-dispatch! app Start) + (expect "ticking again" (wait-for (fun (m) (> (.ticks m) stopped-at))) #t) + (app-stop! app) + (settle) + (def final (.ticks (app-model app))) + (settle) + (expect "a stopped app hears nothing" (.ticks (app-model app)) final) + (app-dispatch! app Other) + (expect "and takes no messages" (.others (app-model app)) 1) + (println "bjogui effects ok"))