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

Menus, context menus and keyboard shortcuts

Browse source 
A menu bar, submenus and menu items are views. A menu item's items are an
ItemsControl's, so they are patched as a list's. A context menu wraps a
view: the view and its menu are two places of the wrapper.

Keys are matched in the window's KeyDown, after the focused control had its
chance: an enabled menu item in the view whose shortcut it is, or else the
app's #:keys. Avalonia's own key bindings take an ICommand, which a Bjolang
program cannot make. app-press! presses keys for a test.

🤖 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 17:55:19 +01:00
parent 1e46202eef
commit be288ac03e
3 changed files with 300 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

149
src/app.bjo
View file

@ -30,7 +30,7 @@
;; Subscriptions.
every subscription
;; For tests and for hosts of their own: an app with no window.
start-app app-dispatch! app-send! app-stop! app-run-pending!
start-app app-dispatch! app-send! app-stop! app-run-pending! app-press!
app-model app-control app-control-at)
(import (std prelude))
@ -80,6 +80,14 @@
(ItemsControl (: Avalonia.Controls.ItemsControl))
(ItemCollection (: Avalonia.Controls.ItemCollection))
(IList (: System.Collections.IList))
(Menu (: Avalonia.Controls.Menu (-> Menu)))
(MenuItem (: Avalonia.Controls.MenuItem (-> MenuItem)))
(Separator (: Avalonia.Controls.Separator (-> Separator)))
(ContextMenu (: Avalonia.Controls.ContextMenu (-> ContextMenu)))
(KeyGesture (: Avalonia.Input.KeyGesture (-> KeyCode KeyModifiers KeyGesture)))
(KeyCode (: Avalonia.Input.Key))
(KeyModifiers (: Avalonia.Input.KeyModifiers))
(KeyEventArgs (: Avalonia.Input.KeyEventArgs))
(ICollection (: System.Collections.ICollection))
(Timer (: Avalonia.Threading.DispatcherTimer (-> Timer)))
(TimeSpan (: System.TimeSpan))
@ -163,6 +171,15 @@
(decorator-padding (: Avalonia.Controls.Decorator.PaddingProperty #:get))
(decorator-child (: Avalonia.Controls.Decorator.ChildProperty #:get))
(parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush)))
(menu-header-property
(: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl.HeaderProperty #:get))
(input-gesture-property (: Avalonia.Controls.MenuItem.InputGestureProperty #:get))
(context-menu-property (: Avalonia.Controls.Control.ContextMenuProperty #:get))
(parse-gesture (: Avalonia.Input.KeyGesture.Parse (-> string KeyGesture)))
(gesture=? (: Avalonia.Input.KeyGesture.Equals (-> KeyGesture KeyGesture bool)))
(key-of (: Avalonia.Input.KeyEventArgs.Key (-> KeyEventArgs KeyCode) #:get))
(modifiers-of (: Avalonia.Input.KeyEventArgs.KeyModifiers (-> KeyEventArgs KeyModifiers) #:get))
(handled! (: Avalonia.Interactivity.RoutedEventArgs.Handled (-> RoutedEventArgs bool void) #:set))
;; A grid's sizes are not Avalonia properties, so they are set as .NET
;; properties are.
@ -177,6 +194,8 @@
;; Events.
(click-event (: Avalonia.Controls.Button.ClickEvent #:get))
(menu-click-event (: Avalonia.Controls.MenuItem.ClickEvent #:get))
(key-down-event (: Avalonia.Input.InputElement.KeyDownEvent #:get))
;; TextChanging and not TextChanged: TextChanged is posted to the
;; dispatcher and comes later, after the patch that set the text is over.
(text-changing-event (: Avalonia.Controls.TextBox.TextChangingEvent #:get))
@ -271,6 +290,7 @@
(RowKind #f)
(GridKind #f)
(BorderKind #f)
(ContextKind #f)
(_ #t)))
;; A kind whose children are the items of an Avalonia ItemsControl.
@ -279,15 +299,20 @@
(match kind
(ListBoxKind #t)
(TabsKind #t)
(MenuBarKind #t)
(MenuItemKind #t)
(ContextMenuKind #t)
(_ #f)))
;; A kind with one child, which is its content.
;; A kind whose children each have a place of their own: the content of a
;; scroll, a tab or a border, and a context menu's view and its menu.
(: (-> Kind bool))
(defun (single? kind)
(match kind
(ScrollKind #t)
(TabKind #t)
(BorderKind #t)
(ContextKind #t)
(_ #f)))
;; A kind that chooses one of its items or options.
@ -326,6 +351,7 @@
(ButtonKind (Some (cast AvaloniaProperty content-property)))
(CheckBoxKind (Some (cast AvaloniaProperty content-property)))
(TabKind (Some (cast AvaloniaProperty header-property)))
(MenuItemKind (Some (cast AvaloniaProperty menu-header-property)))
(_ None)))
((Value _) (when-kind (text-box? kind) (cast AvaloniaProperty text-box-text)))
((Placeholder _) (when-kind (text-box? kind) (cast AvaloniaProperty watermark-property)))
@ -367,6 +393,7 @@
((BorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property)))
((BorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property)))
((Radius _) (when-kind (= kind BorderKind) (cast AvaloniaProperty corner-radius-property)))
((Shortcut _) (when-kind (= kind MenuItemKind) (cast AvaloniaProperty input-gesture-property)))
;; Set by `set-prop!` itself.
((Source _) None)
((Columns _) None)
@ -395,8 +422,16 @@
((Background s) (brush s))
((Foreground s) (brush s))
((BorderColour s) (brush s))
((Shortcut s) (match (gesture s) ((Some g) (Some (cast Object g))) (None None)))
(_ (Some (plain p)))))
;; Keys, as Avalonia reads them. None for keys it cannot read.
(: (-> string (Option KeyGesture)))
(defun (gesture s)
(match (try (parse-gesture s) #:catch (System.Exception))
((Ok g) (Some g))
((Err _) None)))
(: (-> Prop Object))
(defun (plain p)
(defun (text s) (cast Object (->clr-string s)))
@ -431,7 +466,8 @@
((Foreground s) (text s))
((BorderColour s) (text s))
((BorderWidth d) (cast Object (Thickness. d)))
((Radius d) (cast Object (CornerRadius. d)))))
((Radius d) (cast Object (CornerRadius. d)))
((Shortcut s) (text s))))
;; Which prop it is, without its value. Two props with one tag set the same
;; property.
@ -445,7 +481,7 @@
((Items _) 16) ((Selected _) 17) ((Source _) 18) ((Columns _) 19)
((Rows _) 20) ((Row _) 21) ((Column _) 22) ((RowSpan _) 23) ((ColumnSpan _) 24)
((Background _) 25) ((Foreground _) 26) ((BorderColour _) 27) ((BorderWidth _) 28)
((Radius _) 29)))
((Radius _) 29) ((Shortcut _) 30)))
(: (-> Control AvaloniaProperty Object void))
(defun (put! control property value)
@ -567,6 +603,7 @@
(: gui-update (-> %m %model (Tuple %model (List (Event %m)))))
(: view (-> %model (View %m)))
(: subscriptions (-> %model (List (Sub %m))))
(: keys (-> %model (List (Key %m))))
(: root (Option (Live %m)) #:mutable)
(: patching bool #:mutable)
(: stopped bool #:mutable)
@ -627,6 +664,45 @@
(defun (app-run-pending! app)
(ui-run-jobs ui-dispatcher (clr-default)))
;; Sends the message of the keys `g`: of an enabled menu item in the view
;; with those keys as its shortcut, or else of the app's `#:keys`. True when
;; there was one.
(: (-> (App %model %m) KeyGesture bool))
(defun (press! app g)
(defun (same? s) (match (gesture s) ((Some h) (gesture=? g h)) (None #f)))
(: (-> (View %m) (Option %m)))
(defun (in-view v)
(def props (view-props v))
(if (and (= (view-kind v) MenuItemKind)
(not (vec-contains props (Enabled #f)))
(any? (fun (p) (match p ((Shortcut s) (same? s)) (_ #f))) props))
(loop (:for on (view-events v))
(:when-let (Click msg) on)
(:finish #t (Some msg))
=> None)
(loop (:for c (view-children v))
(:when-let (Some msg) (in-view c))
(:finish #t (Some msg))
=> None)))
(def found
(match (match (.root app) ((Some live) (in-view (.view live))) (None None))
((Some msg) (Some msg))
(None (loop (:for k ((.keys app) (.model app)))
(:when (same? (key-gesture k)))
(:finish #t (Some (key-message k)))
=> None))))
(match found
((Some msg) (app-dispatch! app msg) #t)
(None #f)))
;; Presses the keys `keys`, such as "Ctrl+S", as `press!` does when they are
;; pressed in the window. True when they sent a message. For tests.
(: (-> (App %model %m) string bool))
(defun (app-press! app keys)
(match (gesture keys)
((Some g) (press! app g))
(None #f)))
;; 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.
@ -733,6 +809,9 @@
(when (eq? (event-source e) (cast Object control))
(fire! app live (pick))))))
(match kind
(MenuItemKind
(on-event (cast RoutedEvent menu-click-event)
(fun () (fun (on) (match on ((Click msg) (Some msg)) (_ None))))))
(ButtonKind
(on-event (cast RoutedEvent click-event)
(fun () (fun (on) (match on ((Click msg) (Some msg)) (_ None))))))
@ -796,7 +875,12 @@
(ListBoxKind (cast Control (ListBox.)))
(TabsKind (cast Control (TabControl.)))
(TabKind (cast Control (TabItem.)))
(BorderKind (cast Control (Border.)))))
(BorderKind (cast Control (Border.)))
(MenuBarKind (cast Control (Menu.)))
(MenuItemKind (cast Control (MenuItem.)))
(SeparatorKind (cast Control (Separator.)))
(ContextKind (cast Control (Border.)))
(ContextMenuKind (cast Control (ContextMenu.)))))
;; Where the controls of a panel's children, or of a list's items, are.
(: (-> Kind Control IList))
@ -805,18 +889,21 @@
(cast IList (items-of (cast ItemsControl parent)))
(cast IList (panel-children (cast Panel parent)))))
;; Makes `child` the one child of a scroll, a tab or a border.
(: (-> Kind Control Control void))
(defun (set-single! kind parent child)
(if (= kind BorderKind)
(put! parent (cast AvaloniaProperty decorator-child) (cast Object child))
(content! (cast ContentControl parent) (cast Object child))))
;; Puts `child` in its place: the content of a scroll, a tab or a border, and
;; for a context menu, its view at 0 and the menu at 1.
(: (-> Kind Control int Control void))
(defun (set-slot! kind parent i child)
(cond ((and (= kind ContextKind) (= i 1))
(put! parent (cast AvaloniaProperty context-menu-property) (cast Object child)))
((or (= kind BorderKind) (= kind ContextKind))
(put! parent (cast AvaloniaProperty decorator-child) (cast Object child)))
(else (content! (cast ContentControl parent) (cast Object child)))))
;; Puts a child's control in its parent's, as the last one.
(: (-> Kind Control Control void))
(defun (adopt! kind parent child)
;; Puts a child's control in its parent's, as child `i`, the last one so far.
(: (-> Kind Control int Control void))
(defun (adopt! kind parent i child)
(if (single? kind)
(set-single! kind parent child)
(set-slot! kind parent i child)
(ignore (list-add! (child-list kind parent) (cast Object child)))))
;; A list or tabs can choose an item only once the items are there, so the
@ -843,7 +930,7 @@
(loop (:for child (view-children v))
(:do (def c (mount app child))
(mutablevec-add! (.children live) c)
(adopt! kind control (.control c))))
(adopt! kind control (- (mutablevec-length (.children live)) 1) (.control c))))
(sync-selection! control kind (view-props v))
live)
@ -864,15 +951,16 @@
(sync-selection! (.control live) kind (view-props next))
live)))
;; The one child of a scroll, a tab or a border.
;; The children of a kind whose children each have a place of their own.
(: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void))
(defun (patch-single! app live kind views)
(def kids (.children live))
(def was (mutablevec-ref kids 0))
(def now (patch! app was (vec-ref views 0)))
(unless (eq? now was)
(mutablevec-set! kids 0 now)
(set-single! kind (.control live) (.control now))))
(loop (:for (Tuple i v) (enumerate views))
(:do (def was (mutablevec-ref kids i))
(def now (patch! app was v))
(unless (eq? now was)
(mutablevec-set! kids i now)
(set-slot! kind (.control live) i (.control now))))))
;; Which child each view is: its key, or its place among the children that
;; have none. The two kinds cannot be mistaken for each other.
@ -940,10 +1028,12 @@
;; 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))))
(#:keys (-> %model (List (Key %m))))
(App %model %m)))
(defun (start-app init gui-update view on-root #:subscriptions (fun (m) '()))
(defun (start-app init gui-update view on-root #:subscriptions (fun (m) '())
#:keys (fun (m) '()))
(def app (App (model init) (gui-update gui-update) (view view)
(subscriptions subscriptions) (root None) (patching #f) (stopped #f)
(subscriptions subscriptions) (keys keys) (root None) (patching #f) (stopped #f)
(home (current-scope)) (subs '()) (on-root on-root)))
(step! app '())
app)
@ -977,9 +1067,10 @@
;; BJOGUI_SCREENSHOT=shot.png bjo run examples/todo.bjo
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
(#:subscriptions (-> %model (List (Sub %m))))
(#:keys (-> %model (List (Key %m))))
(#:title string) (#:width double) (#:height double) (#:screenshot string)
void))
(defun (run-app init gui-update view #:subscriptions (fun (m) '())
(defun (run-app init gui-update view #:subscriptions (fun (m) '()) #:keys (fun (m) '())
#:title "bjogui" #:width 400.0 #:height 300.0
#:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") ""))
;; The Application is made inside the setup, because making one uses the
@ -997,7 +1088,13 @@
(with-cancel (cancel)
(def app (start-app init gui-update view
(fun (c) (window-content! (cast ContentControl w) (cast Object c)))
#:subscriptions subscriptions))
#:subscriptions subscriptions #:keys keys))
;; Keys that no control took, such as a shortcut pressed in a text input.
(on! (cast Control w) (cast RoutedEvent key-down-event)
(fun (sender e)
(def k (cast KeyEventArgs e))
(when (press! app (KeyGesture. (key-of k) (modifiers-of k)))
(handled! e #t))))
(main-window! lifetime w)
(unless (string-empty? screenshot)
(screenshot-later! lifetime w width height screenshot))