From 52ebd0ace8df88b1f4dc04b9c4161bf7c17760eaec6ee95ee3ec055ea2e5469d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= Date: Sun, 25 Oct 2026 21:02:17 +0100 Subject: [PATCH] Controls that bjogui does not wrap, with (bjogui native) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A native is made with a function that makes the control and hooks its events, and one that puts a value on it. hosted puts it in a view: the control is made once for its place, given a value only when the view's value changes, and what it sends while it is given one is dropped. Its outputs become the app's messages through on-output and view-map, and may be sent from any thread. 🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8) Co-Authored-By: eca-agent --- Readme.org | 49 ++++++++++++++++- src/app.bjo | 68 +++++++++++++++++++++-- src/native.bjo | 65 ++++++++++++++++++++++ src/view.bjo | 36 +++++++++++-- tests/native.bjo | 137 +++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 346 insertions(+), 9 deletions(-) create mode 100644 src/native.bjo create mode 100644 tests/native.bjo diff --git a/Readme.org b/Readme.org index f2a602c..b7d2223 100644 --- a/Readme.org +++ b/Readme.org @@ -255,6 +255,53 @@ a playhead, marks and a hover line. ~start-headless!~ sets Avalonia up with no screen, so that a test can draw components and read their pixels; see ~tests/components.bjo~. +* Controls bjogui does not wrap: (bjogui native) + +Any control of Avalonia's, or of another package's, can be put in a view. +The program makes the control and hooks its events itself, so this is the +one place where it names Avalonia's types. + +#+BEGIN_SRC scheme +(import (std interop)) +(import (bjogui native)) +(import/class (Control (: Avalonia.Controls.Control)) + (Calendar (: Avalonia.Controls.Calendar (-> Calendar))) + (DateTime (: System.DateTime)) + ((Nullable %a) (: System.Nullable))) +(import/extern + (selected-date (: Avalonia.Controls.Calendar.SelectedDate (-> Calendar (Nullable DateTime)) #:get)) + (selected-date! (: Avalonia.Controls.Calendar.SelectedDate (-> Calendar (Nullable DateTime) void) #:set)) + (parse-date (: System.DateTime.Parse (-> string DateTime)))) + +;; A calendar, for a date as "2026-10-25". +(: calendar (Native string string)) +(def calendar + (native (fun (send) ; makes one control + (def c (Calendar.)) + (ignore (add-event-handler! c "SelectedDatesChanged" + (: (fun (s e) + (def d (selected-date c)) + (when (.-HasValue d) (send (.ToString (.-Value d) "yyyy-MM-dd")))) + (-> Object Object void)))) + (cast Control c)) + (fun (control date) ; puts a value on it + (selected-date! (cast Calendar control) (parse-date date))))) + +;; In a view: +(hosted calendar (.date model) Picked) +#+END_SRC + +- ~(make send)~ makes the control once for its place in the view. ~send~ + gives an output to the app, as a message that ~hosted~ makes with + ~on-output~. It may be called from any thread. +- ~(put-value control value)~ is called after ~make~, and again each time the + view gives another value. What the control sends while it is given a value + is dropped, because it is not the user's. +- ~#:width~, ~#:height~ and ~#:margin~ are set on the control, as on any + view. A control measures itself, as Avalonia's do. +- Make a ~native~ once, at the top of a module. A view in the place of + another one is a new control. + * Styles and themes [[file:docs/styles.png]] @@ -410,6 +457,7 @@ bjo run tests/dialogs.bjo # prints "bjogui dialogs ok" 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 examples/counter.bjo bjo run examples/stopwatch.bjo bjo run examples/todo.bjo @@ -424,7 +472,6 @@ bjo run examples/mixer.bjo - Dialogs of one's own, with a view and a state. - The macOS menu bar. - Pointer-over and pressed colours for kinds other than buttons. -- Controls of Avalonia's or another package's that bjogui does not wrap. - A component asks for no size of its own: it is given one, or fills the space it gets. Measuring itself, an accessibility tree, and text input inside a component would need a subclass. diff --git a/src/app.bjo b/src/app.bjo index 440f396..0419dd2 100644 --- a/src/app.bjo +++ b/src/app.bjo @@ -449,6 +449,7 @@ (LineKind #f) (PathKind #f) (CustomKind #f) + (NativeKind #f) (_ #t))) ;; A kind that Avalonia draws as a shape, with a fill and a stroke. @@ -1278,7 +1279,9 @@ (put! image (cast AvaloniaProperty image-stretch-property) (cast Object Stretch.None)) (put! image (cast AvaloniaProperty hit-test-property) (cast Object #f)) (ignore (list-add! (cast IList (panel-children (cast Panel c))) (cast Object image))) - c))) + c) + ;; Made by `mount` with the view's own function, and never here. + (NativeKind (cast Control (Border.))))) ;; Where the controls of a panel's children, or of a list's items, are. (: (-> Kind Control IList)) @@ -1321,9 +1324,17 @@ (: (-> (App %model %m) (View %m) (Live %m))) (defun (mount app v) (def kind (view-kind v)) - (def control (make-control kind)) + ;; A native control sends to its live control, which is made after it. + (def/mutable made None) + (def control + (match (hosted-of v) + ((Some h) (cast Control ((.make h) (fun (o) (match made + ((Some l) (native-send! app l o)) + (None unit)))))) + (None (make-control kind)))) (def live (Live (control control) (view v) (children (mutablevec)) (local (: (clr-default) Object)) (painted None) (cursor-name ""))) + (set! made (Some live)) (loop (:for p (view-props v)) (:do (set-prop! control kind p))) (listen! app live kind) (loop (:for child (view-children v)) @@ -1333,6 +1344,7 @@ (sync-selection! control kind (view-props v)) (sync-tree-choice! live) (when (= kind CustomKind) (start-custom! live)) + (when (= kind NativeKind) (update-native! live)) live) ;; Changes the controls of `live` to show `next`. Gives `live` itself, or new @@ -1347,6 +1359,7 @@ (patch-props! (.control live) kind (view-props old) (view-props next)) (record-set! live (view next)) (when (= kind CustomKind) (sync-custom! live)) + (when (= kind NativeKind) (update-native! live)) (cond ((single? kind) (patch-single! app live kind (view-children next))) ((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next))) (else unit)) @@ -1698,9 +1711,12 @@ ;; of another component in the same place is another control. (: (-> (View %m) (View %m) bool)) (defun (same-component? a b) - (match (Tuple (custom-of a) (custom-of b)) - ((Tuple (Some x) (Some y)) (eq? (.identity x) (.identity y))) - (_ #t))) + (and (match (Tuple (custom-of a) (custom-of b)) + ((Tuple (Some x) (Some y)) (eq? (.identity x) (.identity y))) + (_ #t)) + (match (Tuple (hosted-of a) (hosted-of b)) + ((Tuple (Some x) (Some y)) (eq? (.identity x) (.identity y))) + (_ #t)))) ;; The size a component is drawn at: the size it was laid out at, or before ;; it is laid out, the size its view gives it, or 0. @@ -1883,3 +1899,45 @@ (def options (HeadlessOptions.)) (headless-drawing! options #f) (ignore (setup-without-starting (use-headless (use-skia (configure (fun () (Application.)))) options)))) + +;; --------------------------------------------------------------------------- +;; Native controls +;; --------------------------------------------------------------------------- + +(: (-> (View %m) (Option (Hosted %m)))) +(defun (hosted-of v) + (loop (:for on (view-events v)) + (:when-let (OnHosted h) on) + (:finish #t (Some h)) + => None)) + +;; Puts the view's value on a native control, when it is another than the +;; value it was last given. That value is kept as what it was painted with, +;; and not in `local`, because a value can be null, as None is. It is put +;; while the app patches, so what the control sends then is dropped. +(: (-> (Live %m) void)) +(defun (update-native! live) + (match (hosted-of (.view live)) + ((Some h) + (def fresh? (match (.painted live) + ((Some p) ((.same-value? h) (.drawn-value p))) + (None #f))) + (unless fresh? + ((.update h) (cast Object (.control live))) + (record-set! live (painted (Some (Painted (drawn-value (.value h)) (drawn-state (clr-default)) + (drawn-width 0.0) (drawn-height 0.0))))))) + (None unit))) + +;; Gives an output of a native control to `gui-update`, as the message its +;; view makes of it. From any thread: off the UI thread it is posted there. +;; On the UI thread, while the app patches, it is dropped, because the +;; control sends it for a value the app put, and not for the user. +(: (-> (App %model %m) (Live %m) Object void)) +(defun (native-send! app live o) + (defun (deliver!) + (match (hosted-of (.view live)) + ((Some h) (app-dispatch! app ((.deliver h) o))) + (None unit))) + (if (ui-thread? ui-dispatcher) + (unless (.patching app) (deliver!)) + (ignore (ui-post ui-dispatcher (fun () (deliver!) unit))))) diff --git a/src/native.bjo b/src/native.bjo new file mode 100644 index 0000000..5c700a2 --- /dev/null +++ b/src/native.bjo @@ -0,0 +1,65 @@ +;; 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/src/native.bjo — the module (bjogui native). +;; +;; Controls that bjogui does not wrap: any Avalonia control, Avalonia's own +;; or another package's, in a view. The program makes the control itself and +;; hooks its events, so it names Avalonia's types here, and only here. +;; +;; (: calendar (Native string string)) +;; (def calendar +;; (native (fun (send) +;; (def c (Calendar.)) +;; (add-event-handler! c "SelectedDatesChanged" (fun (s e) (send (picked c)))) +;; (cast Control c)) +;; (fun (control date) (show-date! (cast Calendar control) date)))) +;; +;; (hosted calendar (.date model) Picked) + +(export Native native hosted) + +(import (std prelude)) +(import (bjogui view)) + +(import/class + (Object (: System.Object)) + (Control (: Avalonia.Controls.Control))) + +;; A kind of control, for values of type %v, that sends outputs of type %o. +(type (: (Native %v %o) #:opaque (Record (: make (-> (-> %o void) Control)) + (: update (-> Control %v void))))) + +;; A kind of control that bjogui does not wrap. +;; +;; `(make send)` makes one control, and hooks its events: an event calls +;; `send` with an output, which `hosted` makes a message of. `send` may be +;; called from any thread. +;; +;; `(put-value control value)` puts a value on the control: once after `make`, +;; and again each time the view gives another value. What the control sends +;; while it is updated is dropped, because it is not the user's. +;; +;; Make it once, at the top of a module, as a component: a view in the place +;; of another kind is a new control. +(: native (-> (-> (-> %o void) Control) (-> Control %v void) (Native %v %o))) +(defun (native make put-value) + (Native (make make) (update put-value))) + +;; A control of the kind `n`, showing `value`. Each output it sends is given +;; to `on-output`, and the message that makes is the app's. `#:width`, +;; `#:height` and `#:margin` are set on the control as on any other view. +(: hosted (-> (Native %v %o) %v (-> %o %m) (#:width double) (#:height double) (#:margin double) + (View %m)) + (where (Eq %v))) +(defun (hosted n value on-output #:width 0.0 #:height 0.0 #:margin 0.0) + (def make (.make n)) + (def put-value (.update n)) + (hosted-view (Hosted (identity (cast Object n)) + (value (cast Object value)) + (same-value? (fun (o) (= value (cast %v o)))) + (make (fun (send) (cast Object (make (fun (o) (send (cast Object o))))))) + (update (fun (c) (put-value (cast Control c) value))) + (deliver (fun (o) (on-output (cast %o o))))) + width height margin)) diff --git a/src/view.bjo b/src/view.bjo index eac61a2..3992ae6 100644 --- a/src/view.bjo +++ b/src/view.bjo @@ -39,6 +39,9 @@ ;; Components. Component Input Pointer Custom component drawn + ;; Controls that bjogui does not wrap, for (bjogui native). + Hosted hosted-view + ;; Keyboard shortcuts. Key key key-gesture key-message @@ -63,7 +66,8 @@ ToggleSwitchKind RadioKind NumberKind DateKind AutoCompleteKind ExpanderKind WrapKind DockKind TreeKind TreeNodeKind CanvasKind RectKind EllipseKind LineKind PathKind - ColumnKind RowKind GridKind ScrollKind BorderKind CustomKind))) + ColumnKind RowKind GridKind ScrollKind BorderKind CustomKind + NativeKind))) ;; A property of a control. A kind takes only some of them; the app ignores ;; the others. @@ -153,6 +157,20 @@ (: cursor (-> Object string)) (: focusable bool)))) +;; A control that bjogui does not wrap, as the app holds one: made by +;; (bjogui native), which knows its types. The control and the value are +;; objects here, because this module knows nothing of Avalonia. +;; +;; `make` makes the control, and is given the function the control sends +;; its outputs with. `update` puts this view's value on the control. +;; `deliver` makes an output the app's message. +(type (: (Hosted %m) (Record (: identity Object) + (: value Object) + (: same-value? (-> Object bool)) + (: make (-> (-> Object void) Object)) + (: update (-> Object void)) + (: deliver (-> Object %m))))) + ;; An event, and the message it sends. (type (: (On %m) (Union (: OnClick %m) (: OnInput (-> string %m)) @@ -163,7 +181,8 @@ (: OnPress (-> double double %m)) (: OnMove (-> double double %m)) (: OnRelease (-> double double %m)) - (: OnCustom (Custom %m))))) + (: OnCustom (Custom %m)) + (: OnHosted (Hosted %m))))) ;; One control and what is in it. ;; @@ -269,7 +288,12 @@ ((OnPress g) (OnPress (fun (x y) (f (g x y))))) ((OnMove g) (OnMove (fun (x y) (f (g x y))))) ((OnRelease g) (OnRelease (fun (x y) (f (g x y))))) - ((OnCustom c) (OnCustom (custom-map f c))))) + ((OnCustom c) (OnCustom (custom-map f c))) + ((OnHosted h) + (def deliver (.deliver h)) + (OnHosted (Hosted (identity (.identity h)) (value (.value h)) (same-value? (.same-value? h)) + (make (.make h)) (update (.update h)) + (deliver (fun (o) (f (deliver o))))))))) (View (kind (.kind v)) (props (.props v)) (events (vec-map map-on (.events v))) @@ -767,3 +791,9 @@ (cursor (fun (s) (cursor (state-of s) value))) (focusable (.focusable c)))) (leaf CustomKind (with-layout [] width height margin 0.0) [(OnCustom custom)])) + +;; The view of a control that bjogui does not wrap. Made by `hosted` of +;; (bjogui native). +(: hosted-view (-> (Hosted %m) double double double (View %m))) +(defun (hosted-view h width height margin) + (leaf NativeKind (with-layout [] width height margin 0.0) [(OnHosted h)])) diff --git a/tests/native.bjo b/tests/native.bjo new file mode 100644 index 0000000..14a6468 --- /dev/null +++ b/tests/native.bjo @@ -0,0 +1,137 @@ +;; 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/native.bjo — controls that bjogui does not wrap. +;; +;; bjo run tests/native.bjo +;; +;; No window is opened. A TextBox and a Calendar are made by the program, as +;; any control of Avalonia's or another package's would be. + +(import (std prelude)) +(import (std simpletest)) +(import (std interop)) +(import (std mutable vec)) +(import (bjogui view)) +(import (bjogui app)) +(import (bjogui native)) + +(import/class + (Object (: System.Object)) + (Control (: Avalonia.Controls.Control)) + (Layoutable (: Avalonia.Layout.Layoutable)) + (TextBox (: Avalonia.Controls.TextBox (-> TextBox))) + (Calendar (: Avalonia.Controls.Calendar (-> Calendar))) + (RoutedEvent (: Avalonia.Interactivity.RoutedEvent)) + (RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs)) + (Interactive (: Avalonia.Interactivity.Interactive)) + (Routes (: Avalonia.Interactivity.RoutingStrategies)) + ((EventHandler %a) (: System.EventHandler))) + +(import/extern + (text-of (: Avalonia.Controls.TextBox.Text (-> TextBox string) #:get)) + (text! (: Avalonia.Controls.TextBox.Text (-> TextBox string void) #:set)) + (text-changing (: Avalonia.Controls.TextBox.TextChangingEvent #:get)) + (add-handler (: Avalonia.Interactivity.Interactive.AddHandler + (-> Interactive RoutedEvent Delegate Routes bool void))) + (width-of (: Avalonia.Layout.Layoutable.Width (-> Layoutable double) #:get)) + (display-mode-of (: Avalonia.Controls.Calendar.DisplayMode (-> Calendar Avalonia.Controls.CalendarMode) #:get))) + +;; What the controls were asked to do, in order. +(: calls (MutableVec string)) +(def calls (mutablevec)) +(: (-> string void)) +(defun (note! s) (mutablevec-add! calls s)) + +;; A text box made by the program, which sends its whole text. +(: box (Native string string)) +(def box + (native (fun (send) + (note! "make box") + (def t (TextBox.)) + (add-handler (cast Interactive t) (cast RoutedEvent text-changing) + (cast Delegate (cast Object (: (as-delegate (: (fun (s e) (send (text-of t))) + (-> Object RoutedEventArgs void))) + (EventHandler RoutedEventArgs)))) + Routes.Bubble #f) + (cast Control t)) + (fun (control value) + (note! #"update box ${value}") + (text! (cast TextBox control) value)))) + +;; A calendar, which sends nothing. +(: calendar (Native int Unit)) +(def calendar + (native (fun (send) (note! "make calendar") (cast Control (Calendar.))) + (fun (control value) (note! #"update calendar ${value}")))) + +;; A control whose value can be None, which is null at run time. +(: maybe (Native (Option string) Unit)) +(def maybe + (native (fun (send) (cast Control (TextBox.))) + (fun (control value) (note! #"update maybe ${(written value)}")))) + +(type (: Msg (Union (: Typed string) (: Set string) Noop Swap (: Inner string)))) +(type (: Model (Record (: text string) (: typed (List string)) (: swap bool) (: noops int)))) + +(: (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m) + (next (match msg + ((Typed s) (record-set m (typed (cons s (.typed m))))) + ((Set s) (record-set m (text s))) + (Noop (record-set m (noops (+ (.noops m) 1)))) + (Swap (record-set m (swap (not (.swap m))))) + ((Inner s) (record-set m (typed (cons #"inner ${s}" (.typed m)))))))) + +(: (-> Model (View Msg))) +(defun (view m) + (column + (hosted box (.text m) Typed #:width 120.0) ; 0 + (if (.swap m) ; 1 + (hosted calendar 3 (fun (u) Noop)) + (hosted box "second" Typed)) + (view-map Inner (hosted box "mapped" (fun (s) s))) ; 2 + (hosted maybe None (fun (u) Noop)))) ; 3 + +(defun (main) + (def app (start-app (Model (text "a") (typed '()) (swap #f) (noops 0)) gui-update view (fun (c) unit))) + (defun (ctl path) (app-control-at app path)) + (defun (calls-since n) (vec-drop (mutablevec->vec calls) n)) + + (expect "each control is made, and given its value" + (mutablevec->vec calls) + ["make box" "update box a" "make box" "update box second" "make box" "update box mapped" + "update maybe None"]) + (expect "the value is on the control" (text-of (cast TextBox (ctl '(0)))) "a") + (expect "what it sent while it was given the value is dropped" (.typed (app-model app)) '()) + (expect "the view's size is the control's" (width-of (cast Layoutable (ctl '(0)))) 120.0) + + (def n (mutablevec-length calls)) + (app-dispatch! app (Set "b")) + (expect "a new value is put on the control" (calls-since n) ["update box b"]) + (expect "and it is shown" (text-of (cast TextBox (ctl '(0)))) "b") + (expect "and nothing is sent for it" (.typed (app-model app)) '()) + + (def n (mutablevec-length calls)) + (app-dispatch! app Noop) + (expect "the same value is not put again" (calls-since n) []) + + (text! (cast TextBox (ctl '(0))) "typed") + (expect "what the user does is sent" (.typed (app-model app)) '("typed")) + (text! (cast TextBox (ctl '(2))) "x") + (expect "a mapped control's output is mapped" (list-ref (.typed (app-model app)) 0) "inner x") + + (def n (mutablevec-length calls)) + (def first-box (ctl '(1))) + (app-dispatch! app Swap) + (expect "another kind in the same place is another control" (calls-since n) + ["make calendar" "update calendar 3"]) + (expect "a calendar of Avalonia's" (.ToString (cast Object (display-mode-of (cast Calendar (ctl '(1)))))) + "Month") + (def n (mutablevec-length calls)) + (app-dispatch! app Swap) + (expect "and a box again is a new box" (calls-since n) ["make box" "update box second"]) + (expect "not the first one" (eq? (cast Object (ctl '(1))) (cast Object first-box)) #f) + + (println "bjogui native ok"))