bjoli/bjogui
SHA256
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Commands for focus, scrolling and the clipboard, and pictures from bytes

Browse source 
focus, scroll-to-end, scroll-to-start and scroll-into-view find their
control by the key of its view, and run once the update's controls are
laid out. copy-text puts text on the clipboard, and paste-text sends what
it holds. A command that sends no message ends its fiber when its work is
done, so none is left waiting until the app stops.

image-data shows a picture from the bytes of a file, read again only when
it is given another array.

start-headless! now adds the Fluent theme, as run-app does, so controls
are templated and laid out as in a window.

🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8)

Co-Authored-By: eca-agent <git@eca.dev>
This commit is contained in:
Linus Björnstam 2026-10-25 21:15:12 +01:00
parent 52ebd0ace8
commit 708256d0b3
4 changed files with 342 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

29
Readme.org
View file

@ -62,6 +62,7 @@ being changed, and they are dropped, so only the user's events are messages.
| ~(progress-bar value)~ | ~ProgressBar~ | nothing |
| ~(dropdown options selected on-select)~ | ~ComboBox~ | ~(on-select index)~ |
| ~(image path)~ | ~Image~ | nothing |
| ~(image-data bytes)~, the bytes of a picture file | ~Image~ | nothing |
| ~(list-box views selected on-select)~ | ~ListBox~ | ~(on-select index)~ |
| ~(tabs selected on-select (tab header view) ...)~ | ~TabControl~ | ~(on-select index)~ |
| ~(column child ...)~, ~(row child ...)~ | ~StackPanel~ | nothing |
@ -101,7 +102,8 @@ number is pixels. ~(at row column view)~ puts a view in a cell, counting from
#:height 200.0)
#+END_SRC
An image that cannot be read shows nothing.
An image that cannot be read shows nothing. ~image-data~ reads its bytes
again only when it is given another array, so keep the array in the model.
A list box's items are views, so an item can be anything: a text, a row with
a checkbox, a dropdown. Give them keys if the list can change order. Each
@ -379,6 +381,30 @@ 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.
** Commands that act on the controls and the clipboard
Some commands do work of their own and send no message. Each finds its
control by the key of its view, given with ~keyed~, and runs once the
controls of the update are laid out, so a view the same update made is
there.
| Command | Does |
|-------------------------------+---------------------------------------------------------|
| ~(focus key)~ | gives the keyboard to the control |
| ~(scroll-to-end key)~ | scrolls a ~scroll~ view to its end, as a log wants |
| ~(scroll-to-start key)~ | scrolls a ~scroll~ view to its start |
| ~(scroll-into-view key)~ | scrolls the views around the control until it is seen |
| ~(copy-text text)~ | puts ~text~ on the clipboard |
| ~(paste-text on-text)~ | sends ~(on-text (Some text))~, or ~(on-text None)~ |
#+BEGIN_SRC scheme
(Add (next (record-set m (items (vec-add (.items m) (.draft m))) (draft ""))
(focus "draft")
(scroll-to-end "items")))
(keyed "draft" (text-input (.draft m) Draft))
#+END_SRC
* Dialogs: (bjogui dialogs)
A dialog is a command, and its answer comes back as a message.
@ -458,6 +484,7 @@ bjo run tests/tree.bjo # prints "bjogui tree ok"
bjo run tests/canvas.bjo # prints "bjogui canvas ok"
bjo run tests/components.bjo # prints "bjogui components ok"
bjo run tests/native.bjo # prints "bjogui native ok"
bjo run tests/commands.bjo # prints "bjogui commands ok"
bjo run examples/counter.bjo
bjo run examples/stopwatch.bjo
bjo run examples/todo.bjo

185
src/app.bjo
View file

@ -29,6 +29,8 @@
run-app next style
;; Subscriptions.
every subscription
;; Commands that act on the controls and the clipboard.
focus scroll-to-end scroll-to-start scroll-into-view copy-text paste-text
;; For tests and for hosts of their own: an app with no window.
start-app app-dispatch! app-send! app-stop! app-run-pending! app-press! app-input!
app-model app-control app-control-at start-headless!)
@ -168,7 +170,13 @@
(WheelArgs (: Avalonia.Input.PointerWheelEventArgs))
(InputElement (: Avalonia.Input.InputElement))
(NavigationMethod (: Avalonia.Input.NavigationMethod))
(HeadlessOptions (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions (-> HeadlessOptions))))
(HeadlessOptions (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions (-> HeadlessOptions)))
;; Commands, and pictures from memory.
(TopLevel (: Avalonia.Controls.TopLevel))
(IClipboard (: Avalonia.Input.Platform.IClipboard))
(Stream (: System.IO.Stream))
(MemoryStream (: System.IO.MemoryStream (-> (Array byte) MemoryStream)))
(StreamBitmap (: Avalonia.Media.Imaging.Bitmap (-> Stream StreamBitmap))))
(import/extern
;; Properties, as the objects `SetValue` takes.
@ -404,7 +412,25 @@
(-> AppBuilder HeadlessOptions AppBuilder)))
(headless-drawing! (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions.UseHeadlessDrawing
(-> HeadlessOptions bool void) #:set))
(setup-without-starting (: Avalonia.AppBuilder.SetupWithoutStarting (-> AppBuilder AppBuilder))))
(setup-without-starting (: Avalonia.AppBuilder.SetupWithoutStarting (-> AppBuilder AppBuilder)))
;; Commands.
(ui-post-late (: Avalonia.Threading.Dispatcher.InvokeAsync
(-> Dispatcher (-> Unit) UiPriority (DispatcherOp Unit))))
(background-priority (: Avalonia.Threading.DispatcherPriority.Background #:get))
;; Runs a function that starts a Task on the UI thread, and waits for the
;; Task. The clipboard takes no CancellationToken, so this cannot be
;; cancelled.
(on-ui (: Avalonia.Threading.Dispatcher.InvokeAsync
(-> Dispatcher (-> (Task %a)) %a) #:async #:uncancellable))
(answered (: System.Threading.Tasks.Task.FromResult (-> %a (Task %a))))
(top-level-of (: Avalonia.Controls.TopLevel.GetTopLevel (-> Visual TopLevel)))
(clipboard-of (: Avalonia.Controls.TopLevel.Clipboard (-> TopLevel IClipboard) #:get))
(clipboard-text (: Avalonia.Input.Platform.IClipboard.GetTextAsync (-> IClipboard (Task ClrString))))
(clipboard-text! (: Avalonia.Input.Platform.IClipboard.SetTextAsync (-> IClipboard string Task)))
(scroll-end! (: Avalonia.Controls.ScrollViewer.ScrollToEnd (-> ScrollViewer void)))
(scroll-home! (: Avalonia.Controls.ScrollViewer.ScrollToHome (-> ScrollViewer void)))
(bring-into-view! (: Avalonia.Controls.ControlExtensions.BringIntoView (-> Control void))))
;; ---------------------------------------------------------------------------
;; Properties
@ -608,6 +634,7 @@
((PropDate _) (when-kind (= kind DateKind) (cast AvaloniaProperty date-property)))
;; Set by `set-prop!` itself.
((PropSource _) None)
((PropPicture _) None)
((PropColumns _) None)
((PropRows _) None)))
@ -706,6 +733,7 @@
((PropStart x y) (cast Object (Point. x y)))
((PropEnd x y) (cast Object (Point. x y)))
((PropData s) (text s))
((PropPicture o) o)
((PropDockSide i)
(cast Object (match i (0 DockEdge.Left) (1 DockEdge.Top) (2 DockEdge.Right) (_ DockEdge.Bottom))))))
@ -724,7 +752,8 @@
((PropRadius _) 29) ((PropShortcut _) 30) ((PropTip _) 31) ((PropExpanded _) 32) ((PropDate _) 33)
((PropDockSide _) 34) ((PropClasses _) 35) ((PropChosenKey _) 36)
((PropLeft _) 37) ((PropTop _) 38) ((PropFill _) 39) ((PropStroke _) 40)
((PropStrokeWidth _) 41) ((PropStart _ _) 42) ((PropEnd _ _) 43) ((PropData _) 44)))
((PropStrokeWidth _) 41) ((PropStart _ _) 42) ((PropEnd _ _) 43) ((PropData _) 44)
((PropPicture _) 45)))
(: (-> Control AvaloniaProperty Object void))
(defun (put! control property value)
@ -740,6 +769,10 @@
(: (-> Control Kind Prop void))
(defun (set-prop! control kind p)
(match (Tuple kind p)
((Tuple ImageKind (PropPicture o))
(match (try (StreamBitmap. (cast Stream (MemoryStream. (cast (Array byte) o)))) #:catch (System.Exception))
((Ok b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b)))
((Err _) (clear-value (cast AvaloniaObject control) (cast AvaloniaProperty image-source-property)))))
((Tuple ImageKind (PropSource path))
(match (load-bitmap path)
((Some b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b)))
@ -781,6 +814,7 @@
(defun (clear property) (clear-value (cast AvaloniaObject control) property))
(match (Tuple kind p)
((Tuple ImageKind (PropSource _)) (clear (cast AvaloniaProperty image-source-property)))
((Tuple ImageKind (PropPicture _)) (clear (cast AvaloniaProperty image-source-property)))
((Tuple GridKind (PropColumns _)) (grid-columns! (cast Grid control) (parse-columns "*")))
((Tuple GridKind (PropRows _)) (grid-rows! (cast Grid control) (parse-rows "*")))
((Tuple GridKind (PropSpacing _))
@ -813,6 +847,18 @@
;; The app
;; ---------------------------------------------------------------------------
;; What a command finds a running app by: the control of a view with a key,
;; and the controls at the roots of its views.
(type (: Running (Record (: find (-> string (Option Control)))
(: roots (-> (List Control))))))
;; The apps started, in order. A command looks for its control in each.
(: running (MutableVec Running))
(def running (mutablevec))
;; Raised by a command that sends no message, and caught by `run-command`.
(def no-message (cast Exception (InvalidOperation. "bjogui: a command that sends no message")))
;; What a component was drawn with: its value, its state, and its size.
(type (: Painted (Record (: drawn-value Object) (: drawn-state Object)
(: drawn-width double) (: drawn-height double))))
@ -1015,7 +1061,11 @@
(: (-bjo-> (App %model %m) (Event %m) void))
(defbjo (run-command app command)
(post! app (sync command)))
;; A command that sends no message raises `no-message` once it has done
;; its work, so that its fiber ends.
(match (try (sync command) #:catch (System.InvalidOperationException))
((Ok msg) (post! app msg))
((Err e) (unless (eq? (cast Object e) (cast Object no-message)) (raise e)))))
(: (-bjo-> (App %model %m) (-> (Event %m)) void))
(defbjo (run-sub app next-event)
@ -1494,6 +1544,10 @@
(subscriptions subscriptions) (keys keys) (theme theme) (shown-theme "")
(root None) (patching #f) (stopped #f)
(home (current-scope)) (subs '()) (on-root on-root)))
(mutablevec-add! running (Running (find (fun (key) (keyed-control app key)))
(roots (fun () (match (.root app)
((Some live) (list (.control live)))
(None '()))))))
(step! app '())
app)
@ -1891,14 +1945,16 @@
(repaint! live)))
(-> Object Object void)))))
;; Sets Avalonia up with no screen, drawing with Skia, so that components can
;; be drawn and their pictures read in a test. Call it once, before
;; `start-app`.
;; Sets Avalonia up with no screen, drawing with Skia, and with the theme
;; `run-app` uses, so that controls are drawn and laid out as in a window: a
;; test can draw components and read their pictures, and scroll a view.
;; Call it once, before `start-app`.
(: (-> void))
(defun (start-headless!)
(def options (HeadlessOptions.))
(headless-drawing! options #f)
(ignore (setup-without-starting (use-headless (use-skia (configure (fun () (Application.)))) options))))
(ignore (setup-without-starting (use-headless (use-skia (configure (fun () (Application.)))) options)))
(.Add (app-styles current-app) (FluentTheme. (clr-default))))
;; ---------------------------------------------------------------------------
;; Native controls
@ -1941,3 +1997,116 @@
(if (ui-thread? ui-dispatcher)
(unless (.patching app) (deliver!))
(ignore (ui-post ui-dispatcher (fun () (deliver!) unit)))))
;; ---------------------------------------------------------------------------
;; Commands that act on the controls and the clipboard
;; ---------------------------------------------------------------------------
;; The control of the view with `key`, below the root.
(: (-> (App %model %m) string (Option Control)))
(defun (keyed-control app key)
(: (-> (Live %m) (Option Control)))
(defun (walk live)
(if (= (view-key (.view live)) (Some key))
(Some (.control live))
(loop (:for c (mutablevec->vec (.children live)))
(:when-let (Some found) (walk c))
(:finish #t (Some found))
=> None)))
(match (.root app)
((Some live) (walk live))
(None None)))
;; A command that runs `act` on the UI thread and sends no message. It runs
;; after the controls are laid out, so a control the same update made is
;; there, and its size is known.
(: (-> (-> void) (Event %m)))
(defun (acting act)
(guard (fun ()
(ignore (ui-post-late ui-dispatcher (fun () (act) unit) background-priority))
(raise no-message))))
;; A command that runs `act` on the control of the view with `key`, in the
;; first app that has one. With none, it does nothing.
(: (-> string (-> Control void) (Event %m)))
(defun (on-keyed key act)
(acting (fun ()
(loop (:for r (mutablevec->vec running))
(:when-let (Some c) ((.find r) key))
(:finish #t (act c))
=> unit))))
;; Gives the keyboard to the control of the view with `key`, as a click
;; would. Sends nothing.
;;
;; (Add (next (add-item m) (focus "new-item")))
(: focus (-> string (Event %m)))
(defun (focus key)
(on-keyed key (fun (c) (ignore (focus! (cast InputElement c) NavigationMethod.Unspecified KeyModifiers.None)))))
;; Scrolls the `scroll` view with `key` to its end, such as a log after a
;; line is added. Sends nothing.
(: scroll-to-end (-> string (Event %m)))
(defun (scroll-to-end key)
(on-keyed key (fun (c) (match (try (cast ScrollViewer c) #:catch (System.InvalidCastException))
((Ok v) (scroll-end! v))
((Err _) unit)))))
;; Scrolls the `scroll` view with `key` to its start. Sends nothing.
(: scroll-to-start (-> string (Event %m)))
(defun (scroll-to-start key)
(on-keyed key (fun (c) (match (try (cast ScrollViewer c) #:catch (System.InvalidCastException))
((Ok v) (scroll-home! v))
((Err _) unit)))))
;; Scrolls the views around the view with `key` until it is seen. Sends
;; nothing.
(: scroll-into-view (-> string (Event %m)))
(defun (scroll-into-view key)
(on-keyed key bring-into-view!))
;; The clipboard of the window an app is shown in, if one is.
(: (-> (Option IClipboard)))
(defun (clipboard)
(: (-> Control (Option IClipboard)))
(defun (of c)
(def top (cast Object (top-level-of (cast Visual c))))
(if (eq? top (clr-default))
None
(begin
(def board (cast Object (clipboard-of (cast TopLevel top))))
(if (eq? board (clr-default)) None (Some (cast IClipboard board))))))
(: (-> Running (Option IClipboard)))
(defun (in r)
(loop (:for c ((.roots r)))
(:when-let (Some board) (of c))
(:finish #t (Some board))
=> None))
(loop (:for r (mutablevec->vec running))
(:when-let (Some board) (in r))
(:finish #t (Some board))
=> None))
;; Puts `text` on the clipboard. Sends nothing.
(: copy-text (-> string (Event %m)))
(defun (copy-text text)
(acting (fun ()
(match (clipboard)
((Some board) (ignore (clipboard-text! board text)))
(None unit)))))
(: (-bjo-> (Option string)))
(defbjo (read-clipboard)
(def text (on-ui ui-dispatcher
(fun () (match (clipboard)
((Some board) (clipboard-text board))
(None (answered (: (clr-default) ClrString)))))))
(if (eq? (cast Object text) (clr-default)) None (Some (.ToString text))))
;; Reads the clipboard, and sends `(on-text (Some text))`, or `(on-text None)`
;; when it holds no text or there is no window.
(: paste-text (-> (-> (Option string) %m) (Event %m)))
(defun (paste-text on-text)
(guard (fun ()
(wrap (promise-join (bjo (read-clipboard)))
(fun (r) (on-text (match r ((Ok t) t) ((Err _) None))))))))

14
src/view.bjo
View file

@ -22,7 +22,7 @@
View Kind Prop On
;; Constructors.
text button text-input text-area checkbox slider progress-bar dropdown image
text button text-input text-area checkbox slider progress-bar dropdown image image-data
list-box tabs tab
menu-bar submenu menu-item menu-separator
toggle-switch radio number-input date-picker auto-complete expander
@ -115,7 +115,8 @@
(: PropStrokeWidth double)
(: PropStart double double) ; the ends of a line
(: PropEnd double double)
(: PropData string)))) ; a path, as "M 0 0 L 10 10 Z"
(: PropData string) ; a path, as "M 0 0 L 10 10 Z"
(: PropPicture Object)))) ; an image's bytes, as an (Array byte)
;; Where the pointer is on a component, from its top left corner, and how.
;; `button` is "left", "right" or "middle" for a press and a release, and ""
@ -433,6 +434,15 @@
(defun (image path #:width 0.0 #:height 0.0 #:margin 0.0)
(leaf ImageKind (with-layout [(PropSource path)] width height margin 0.0) []))
;; The picture in `bytes`, the contents of a PNG, JPEG, BMP or other file
;; that Avalonia reads, such as an image made by the program or downloaded.
;; Bytes that cannot be read show nothing. The picture is read again only
;; when the view is given another array, so keep the array in the model and
;; do not make it anew for each view.
(: (-> (Array byte) (#:width double) (#:height double) (#:margin double) (View %m)))
(defun (image-data bytes #:width 0.0 #:height 0.0 #:margin 0.0)
(leaf ImageKind (with-layout [(PropPicture (cast Object bytes))] width height margin 0.0) []))
;; A list of views to choose one of, with the one at `selected` chosen, or
;; none for -1. A choice sends `(on-select index)`. Give the items keys if
;; the list can change order.

125
tests/commands.bjo Normal file
View file

@ -0,0 +1,125 @@
;; 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/commands.bjo — commands that act on the controls and the
;; clipboard, and pictures from memory.
;;
;; bjo run tests/commands.bjo
;;
;; Avalonia runs with no screen, and the app is shown in a window of it, so
;; that a control can take the keyboard, a scroll view is laid out, and there
;; is a clipboard.
(import (std prelude))
(import (std simpletest))
(import (std interop))
(import (bjogui view))
(import (bjogui app))
(import/class
(Object (: System.Object))
(Control (: Avalonia.Controls.Control))
(Window (: Avalonia.Controls.Window (-> Window)))
(ContentControl (: Avalonia.Controls.ContentControl))
(Layoutable (: Avalonia.Layout.Layoutable))
(InputElement (: Avalonia.Input.InputElement))
(ScrollViewer (: Avalonia.Controls.ScrollViewer))
(Image (: Avalonia.Controls.Image))
(IImage (: Avalonia.Media.IImage))
(Vector (: Avalonia.Vector)))
(import/extern
(content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set))
(show! (: Avalonia.Controls.Window.Show (-> Window void)))
(width! (: Avalonia.Layout.Layoutable.Width (-> Layoutable double void) #:set))
(height! (: Avalonia.Layout.Layoutable.Height (-> Layoutable double void) #:set))
(update-layout! (: Avalonia.Layout.Layoutable.UpdateLayout (-> Layoutable void)))
(focused? (: Avalonia.Input.InputElement.IsFocused (-> InputElement bool) #:get))
(offset-of (: Avalonia.Controls.ScrollViewer.Offset (-> ScrollViewer Vector) #:get))
(vector-y (: Avalonia.Vector.Y (-> Vector double) #:get))
(source-of (: Avalonia.Controls.Image.Source (-> Image IImage) #:get))
(sleep-ms (: System.Threading.Thread.Sleep (-> int void) #:blocking)))
(type (: Msg (Union FocusName FocusOther End Start Into (: Copy string) Paste (: Pasted (Option string)))))
(type (: Model (Record (: messages int) (: pasted (Option string)))))
(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m0)
(def m (record-set m0 (messages (+ (.messages m0) 1))))
(match msg
(FocusName (next m (focus "name")))
(FocusOther (next m (focus "other")))
(End (next m (scroll-to-end "log")))
(Start (next m (scroll-to-start "log")))
(Into (next m (scroll-into-view "line 25")))
((Copy s) (next m (copy-text s)))
(Paste (next m (paste-text Pasted)))
((Pasted s) (next (record-set m (pasted s))))))
(def picture (file-read-bytes "docs/mixer.png"))
(: (-> Model (View Msg)))
(defun (view m)
(column
(keyed "name" (text-input "" (fun (s) Start))) ; 0
(keyed "other" (text-input "" (fun (s) Start))) ; 1
(keyed "log" (scroll (apply column (vec->array (vec-map (fun (i) (keyed #"line ${i}" (text #"line ${i}")))
(->vec (range 0 40)))))
#:height 60.0)) ; 2
(image-data picture #:width 46.0 #:height 30.0) ; 3
(image-data (: (make-array 3 #:fill (cast byte 7)) (Array byte))))) ; 4
(defun (main)
(start-headless!)
(def w (Window.))
(width! (cast Layoutable w) 300.0)
(height! (cast Layoutable w) 400.0)
(def app (start-app (Model (messages 0) (pasted None)) gui-update view
(fun (c) (content! (cast ContentControl w) (cast Object c)))))
(show! w)
(defun (ctl path) (app-control-at app path))
(defun (settle) (app-run-pending! app) (update-layout! (cast Layoutable w)))
(: (-> (-> bool) bool))
(defun (wait-for done?)
(let go ((tries 0))
(settle)
(cond ((done?) #t)
((> tries 200) #f)
(else (sleep-ms 10) (go (+ tries 1))))))
(defun (log-offset) (vector-y (offset-of (cast ScrollViewer (ctl '(2))))))
(settle)
;; --- focus ------------------------------------------------------------------------
(app-dispatch! app FocusName)
(expect "focus gives the keyboard to the keyed control"
(wait-for (fun () (focused? (cast InputElement (ctl '(0)))))) #t)
(app-dispatch! app FocusOther)
(expect "and to another" (wait-for (fun () (focused? (cast InputElement (ctl '(1)))))) #t)
(expect "which the first has no more" (focused? (cast InputElement (ctl '(0)))) #f)
;; --- scrolling --------------------------------------------------------------------
(expect "the log starts at the top" (log-offset) 0.0)
(app-dispatch! app End)
(expect "scroll-to-end" (wait-for (fun () (> (log-offset) 500.0))) #t)
(app-dispatch! app Start)
(expect "scroll-to-start" (wait-for (fun () (= (log-offset) 0.0))) #t)
(app-dispatch! app Into)
(expect "scroll-into-view" (wait-for (fun () (> (log-offset) 300.0))) #t)
;; --- the clipboard -----------------------------------------------------------------
(app-dispatch! app (Copy "copied"))
(app-dispatch! app Paste)
(expect "a copy is pasted" (wait-for (fun () (= (.pasted (app-model app)) (Some "copied")))) #t)
;; --- commands that send nothing --------------------------------------------------
(sleep-ms 50)
(settle)
(expect "send nothing: only the messages dispatched, and Pasted" (.messages (app-model app)) 8)
;; --- pictures from memory ---------------------------------------------------------
(expect "a picture from bytes" (eq? (cast Object (source-of (cast Image (ctl '(3))))) (clr-default)) #f)
(expect "bytes that are no picture show nothing"
(eq? (cast Object (source-of (cast Image (ctl '(4))))) (clr-default)) #t)
(println "bjogui commands ok"))