Controls that bjogui does not wrap, with (bjogui native)

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 <git@eca.dev>

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.

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))
+  (and (match (Tuple (custom-of a) (custom-of b))
          ((Tuple (Some x) (Some y)) (eq? (.identity x) (.identity y)))
-    (_ #t)))
+         (_ #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)))))

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))

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)]))

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"))