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

Compare commits

base: bjoli:8941425f0569ab9811cb3765a974c69420ec86b62323d9d92cc65fa0ce55968e
Branches Tags
bjoli:main
..
compare: bjoli:1e46202eef0141bd14cca25a16727e591a21f4a9cef102694eb2a7f47f94e938
Branches Tags
bjoli:main

No commits in common. "8941425f0569ab9811cb3765a974c69420ec86b62323d9d92cc65fa0ce55968e" and "1e46202eef0141bd14cca25a16727e591a21f4a9cef102694eb2a7f47f94e938" have entirely different histories.
8941425f05 ... 1e46202eef

10 changed files with 188 additions and 1805 deletions
Download patch file Download diff file Expand all files Collapse all files

106
Readme.org
View file

@ -68,16 +68,6 @@ being changed, and they are dropped, so only the user's events are messages.
| ~(grid #:columns #:rows child ...)~ | ~Grid~ | nothing | | ~(grid #:columns #:rows child ...)~ | ~Grid~ | nothing |
| ~(scroll child)~ | ~ScrollViewer~ | nothing | | ~(scroll child)~ | ~ScrollViewer~ | nothing |
| ~(border child)~ | ~Border~ | nothing | | ~(border child)~ | ~Border~ | nothing |
| ~(toggle-switch label on? on-toggle)~ | ~ToggleSwitch~ | ~(on-toggle on)~ |
| ~(radio label chosen? msg)~ | ~RadioButton~ | ~msg~ when it is chosen |
| ~(number-input value on-change)~ | ~NumericUpDown~ | ~(on-change value)~ |
| ~(date-picker "2026-10-25" on-change)~ | ~DatePicker~ | ~(on-change date)~ |
| ~(auto-complete value options on-input)~ | ~AutoCompleteBox~ | ~(on-input text)~ |
| ~(expander header expanded? on-toggle child)~ | ~Expander~ | ~(on-toggle expanded)~ |
| ~(tree-view chosen on-pick (tree-node key header ...) ...)~ | ~TreeView~ | ~(on-pick key)~ |
| ~(flow child ...)~ | ~WrapPanel~ | nothing |
| ~(dock child ...)~, with ~at-top~, ~at-left~ … | ~DockPanel~ | nothing |
| ~(menu-bar (submenu label (menu-item label msg) ...))~ | ~Menu~ | ~msg~ when an item is chosen |
They take keywords where they apply: ~#:size~ (the font size of a text), They take keywords where they apply: ~#:size~ (the font size of a text),
~#:wrap~ (a text breaks its lines at its width), ~#:width~, ~#:height~, ~#:wrap~ (a text breaks its lines at its width), ~#:width~, ~#:height~,
@ -132,53 +122,6 @@ a line around a view, with round corners if ~#:radius~ is more than zero.
The Fluent theme gives a button its own colours when the pointer is over it The Fluent theme gives a button its own colours when the pointer is over it
or it is pressed, so a painted button shows the theme's colour then. or it is pressed, so a painted button shows the theme's colour then.
More wrappers: ~(tooltip view "text")~, ~(with-context-menu view item ...)~
for a menu on the right button, and ~(classed view "name" ...)~ for styles.
A tree node is known by its key, which must be its own in the tree. A node
is open at first when it says ~#:expanded~; after that the user opens and
closes it.
* Styles and themes
[[file:docs/styles.png]]
~run-app~'s ~#:theme~ gives ~"light"~, ~"dark"~, or anything else for the
system's, for a model, so a setting can switch it. ~#:styles~ is a list of
rules made by ~style~: a kind, by the name of its constructor, a class
given with ~classed~, and the look.
#+BEGIN_SRC scheme
(run-app init gui-update view
#:theme (fun (m) (if (.dark m) "dark" "light"))
#:styles (list (style "text" #:class "title" #:font-size 22.0 #:colour "#f1c40f")
(style "button" #:class "primary" #:background "#27ae60" #:colour "white"
#:hover-background "#2ecc71" #:pressed-background "#1e8449")))
#+END_SRC
A rule takes ~#:colour~, ~#:background~, ~#:font-size~, ~#:padding~ and
~#:radius~. A button's rule also takes ~#:hover-colour~, ~#:hover-background~,
~#:pressed-colour~ and ~#:pressed-background~, which are set inside its
template, as the Fluent theme sets its own; no other kind has them.
[[file:examples/styles.bjo][examples/styles.bjo]] is the picture above.
* Menus and keys
#+BEGIN_SRC scheme
(menu-bar
(submenu "File"
(menu-item "New" New #:shortcut "Ctrl+N")
(menu-separator)
(menu-item "Quit" Quit #:shortcut "Ctrl+Q")))
#+END_SRC
A menu bar is a view, so it goes where the program puts it, usually at the
top of a ~dock~. A menu item's ~#:shortcut~ is shown beside it, and the keys
send its message while it is in the view and enabled. ~run-app~'s ~#:keys~
gives more, for a model: ~(fun (m) (list (key "F5" Refresh)))~. Keys are
the window's after the control that has the keyboard had its chance, so a
text input keeps ~Ctrl+C~.
* Work: commands and subscriptions * Work: commands and subscriptions
~gui-update~ is a plain function, so it cannot wait, and the compiler says so ~gui-update~ is a plain function, so it cannot wait, and the compiler says so
@ -216,42 +159,10 @@ 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 ~gui-update~ and ~view~ always run there. When the window is closed they are
cancelled, and the program ends. cancelled, and the program ends.
* Dialogs: (bjogui dialogs)
A dialog is a command, and its answer comes back as a message.
| Command | Sends |
|-------------------------------------------+-----------------------------------------------|
| ~(alert text msg)~ | ~msg~ when it is closed |
| ~(confirm text on-answer)~ | ~(on-answer #t)~ for OK, ~#f~ otherwise |
| ~(prompt text on-answer #:value)~ | ~(on-answer (Some text))~, or ~None~ |
| ~(open-file on-answer #:filters)~ | ~(on-answer (Some path))~, or ~None~ |
| ~(open-files on-answer)~ | ~(on-answer paths)~ |
| ~(save-file on-answer #:name)~ | ~(on-answer (Some path))~, or ~None~ |
| ~(open-folder on-answer)~ | ~(on-answer (Some path))~, or ~None~ |
| ~(quit)~ | nothing: it closes the windows |
#+BEGIN_SRC scheme
(Delete (next m (confirm "Delete it?" Deleted?)))
((Deleted? #t) (next (remove m)))
((Deleted? #f) (next m))
#+END_SRC
~#:filters~ are kinds of file, each a name and patterns: ~(list (Tuple "Text"
'("*.txt" "*.md")))~. ~run-app~'s ~#:on-close msg~ makes the close button
send ~msg~ instead of closing, and the program closes with ~(quit)~ when it
is ready, say after asking about unsaved work.
A dialog belongs to the main window. With none, as under ~start-app~, each
answers as if it was cancelled. Avalonia's dialogs cannot be cancelled, so a
command that is cancelled stops waiting, and the dialog stays until it is
answered.
* Running: (bjogui app) * Running: (bjogui app)
- ~(run-app init gui-update view #:subscriptions #:keys #:theme #:styles - ~(run-app init gui-update view #:subscriptions #:title #:width #:height)~
#:on-close #:title #:width #:height)~ opens a window and runs until it is opens a window and runs until it is closed.
closed.
- ~#:screenshot path~ makes ~run-app~ save a PNG of the window once it is - ~#:screenshot path~ makes ~run-app~ save a PNG of the window once it is
shown, at twice its size, and close it. It is the environment variable shown, at twice its size, and close it. It is the environment variable
~BJOGUI_SCREENSHOT~ unless the program says otherwise, so any program can ~BJOGUI_SCREENSHOT~ unless the program says otherwise, so any program can
@ -265,7 +176,6 @@ answered.
- ~app-run-pending!~ runs what fibers have posted, where no loop of - ~app-run-pending!~ runs what fibers have posted, where no loop of
Avalonia's does. Avalonia's does.
- ~app-stop!~ cancels the subscriptions and drops later messages. - ~app-stop!~ cancels the subscriptions and drops later messages.
- ~app-press!~ presses keys, such as ~"Ctrl+S"~, as the window does.
- ~app-model~ reads the model, and ~app-control-at~ finds a control by its - ~app-model~ reads the model, and ~app-control-at~ finds a control by its
path of child indices. path of child indices.
@ -286,21 +196,15 @@ bjo run tests/app.bjo # prints "bjogui ok"
bjo run tests/effects.bjo # prints "bjogui effects ok" bjo run tests/effects.bjo # prints "bjogui effects ok"
bjo run tests/controls.bjo # prints "bjogui controls ok" bjo run tests/controls.bjo # prints "bjogui controls ok"
bjo run tests/lists.bjo # prints "bjogui lists ok" bjo run tests/lists.bjo # prints "bjogui lists ok"
bjo run tests/inputs.bjo # prints "bjogui inputs ok"
bjo run tests/menus.bjo # prints "bjogui menus ok"
bjo run tests/dialogs.bjo # prints "bjogui dialogs ok"
bjo run tests/tree.bjo # prints "bjogui tree ok"
bjo run examples/counter.bjo bjo run examples/counter.bjo
bjo run examples/stopwatch.bjo bjo run examples/stopwatch.bjo
bjo run examples/todo.bjo bjo run examples/todo.bjo
bjo run examples/styles.bjo
#+END_SRC #+END_SRC
* Not yet * Not yet
- A data grid, and lists that make controls only for the items on screen. - Menus and dialogs.
- Dialogs of one's own, with a view and a state. - Styles of one's own, with classes, and colours for the pointer-over and
- The macOS menu bar. pressed states.
- Pointer-over and pressed colours for kinds other than buttons.
- A moved control is taken out of the panel and put back, so it may lose the - A moved control is taken out of the panel and put back, so it may lose the
keyboard focus. keyboard focus.

BIN
docs/styles.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 33 KiB

38
examples/styles.bjo
View file

@ -1,38 +0,0 @@
;; 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/styles.bjo — styles, classes and the dark theme.
;;
;; bjo run examples/styles.bjo
;;
;; The picture in the Readme is this program, taken with
;;
;; BJOGUI_SCREENSHOT=docs/styles.png bjo run examples/styles.bjo
(import (std prelude))
(import (bjogui view))
(import (bjogui app))
(type (: Msg (Union Nothing)))
(defun (main)
(run-app 0 (fun (msg n) (next n))
(fun (n)
(column #:spacing 12.0 #:margin 20.0
(classed (text "Styled with classes") "title")
(row #:spacing 8.0
(classed (button "Save" Nothing) "primary")
(classed (button "Delete" Nothing) "danger")
(button "Plain" Nothing))
(classed (border (text "a card") #:padding 10.0) "card")
(toggle-switch "Dark mode" #t (fun (b) Nothing))
(number-input 3.0 (fun (d) Nothing) #:width 160.0)
(date-picker "2026-10-25" (fun (d) Nothing))))
#:theme (fun (n) "dark")
#:styles (list (style "text" #:class "title" #:font-size 22.0 #:colour "#f1c40f")
(style "button" #:class "primary" #:background "#27ae60" #:colour "white"
#:hover-background "#2ecc71" #:pressed-background "#1e8449")
(style "button" #:class "danger" #:background "#c0392b" #:colour "white"
#:hover-background "#e74c3c" #:radius 12.0)
(style "border" #:class "card" #:background "#34495e" #:radius 8.0))
#:title "styles" #:width 360.0 #:height 330.0))

712
src/app.bjo
View file

@ -25,12 +25,12 @@
;; `AvaloniaObject.SetValue`, so no Avalonia class is subclassed. ;; `AvaloniaObject.SetValue`, so no Avalonia class is subclassed.
(export (export
App Live Control Sub StyleRule App Live Control Sub
run-app next style run-app next
;; Subscriptions. ;; Subscriptions.
every subscription every subscription
;; For tests and for hosts of their own: an app with no window. ;; 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! start-app app-dispatch! app-send! app-stop! app-run-pending!
app-model app-control app-control-at) app-model app-control app-control-at)
(import (std prelude)) (import (std prelude))
@ -80,39 +80,6 @@
(ItemsControl (: Avalonia.Controls.ItemsControl)) (ItemsControl (: Avalonia.Controls.ItemsControl))
(ItemCollection (: Avalonia.Controls.ItemCollection)) (ItemCollection (: Avalonia.Controls.ItemCollection))
(IList (: System.Collections.IList)) (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))
(ClosingArgs (: Avalonia.Controls.WindowClosingEventArgs))
(ToggleSwitch (: Avalonia.Controls.ToggleSwitch (-> ToggleSwitch)))
(RadioButton (: Avalonia.Controls.RadioButton (-> RadioButton)))
(NumericUpDown (: Avalonia.Controls.NumericUpDown (-> NumericUpDown)))
(DatePicker (: Avalonia.Controls.DatePicker (-> DatePicker)))
(DateTimeOffset (: System.DateTimeOffset))
(AutoCompleteBox (: Avalonia.Controls.AutoCompleteBox (-> AutoCompleteBox)))
(Expander (: Avalonia.Controls.Expander (-> Expander)))
(WrapPanel (: Avalonia.Controls.WrapPanel (-> WrapPanel)))
(DockPanel (: Avalonia.Controls.DockPanel (-> DockPanel)))
(DockEdge (: Avalonia.Controls.Dock))
(TreeView (: Avalonia.Controls.TreeView (-> TreeView)))
(TreeViewItem (: Avalonia.Controls.TreeViewItem (-> TreeViewItem)))
(PropertyChange (: Avalonia.AvaloniaPropertyChangedEventArgs))
(Classes (: Avalonia.Controls.Classes))
(StyledElement (: Avalonia.StyledElement))
(Selector (: Avalonia.Styling.Selector))
(AvaloniaStyle (: Avalonia.Styling.Style (-> AvaloniaStyle)))
(Setter (: Avalonia.Styling.Setter (-> AvaloniaProperty Object Setter)))
(SetterBase (: Avalonia.Styling.SetterBase))
((IListOf %a) (: System.Collections.Generic.IList))
(StyleBase (: Avalonia.Styling.StyleBase))
(ThemeVariant (: Avalonia.Styling.ThemeVariant))
(ClrType (: System.Type))
(CancelArgs (: System.ComponentModel.CancelEventArgs))
(ICollection (: System.Collections.ICollection)) (ICollection (: System.Collections.ICollection))
(Timer (: Avalonia.Threading.DispatcherTimer (-> Timer))) (Timer (: Avalonia.Threading.DispatcherTimer (-> Timer)))
(TimeSpan (: System.TimeSpan)) (TimeSpan (: System.TimeSpan))
@ -196,58 +163,6 @@
(decorator-padding (: Avalonia.Controls.Decorator.PaddingProperty #:get)) (decorator-padding (: Avalonia.Controls.Decorator.PaddingProperty #:get))
(decorator-child (: Avalonia.Controls.Decorator.ChildProperty #:get)) (decorator-child (: Avalonia.Controls.Decorator.ChildProperty #:get))
(parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush))) (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))
(programmatic? (: Avalonia.Controls.WindowClosingEventArgs.IsProgrammatic (-> ClosingArgs bool) #:get))
(tip-property (: Avalonia.Controls.ToolTip.TipProperty #:get))
(dock-property (: Avalonia.Controls.DockPanel.DockProperty #:get))
(expanded-property (: Avalonia.Controls.Expander.IsExpandedProperty #:get))
(number-value-property (: Avalonia.Controls.NumericUpDown.ValueProperty #:get))
(number-minimum-property (: Avalonia.Controls.NumericUpDown.MinimumProperty #:get))
(number-maximum-property (: Avalonia.Controls.NumericUpDown.MaximumProperty #:get))
(number-increment-property (: Avalonia.Controls.NumericUpDown.IncrementProperty #:get))
(number-value (: Avalonia.Controls.NumericUpDown.Value (-> NumericUpDown (Nullable decimal)) #:get))
(date-property (: Avalonia.Controls.DatePicker.SelectedDateProperty #:get))
(selected-date (: Avalonia.Controls.DatePicker.SelectedDate (-> DatePicker (Nullable DateTimeOffset)) #:get))
(parse-date (: System.DateTimeOffset.Parse (-> string DateTimeOffset)))
(auto-text-property (: Avalonia.Controls.AutoCompleteBox.TextProperty #:get))
(auto-items-property (: Avalonia.Controls.AutoCompleteBox.ItemsSourceProperty #:get))
(auto-watermark-property (: Avalonia.Controls.AutoCompleteBox.WatermarkProperty #:get))
(auto-text (: Avalonia.Controls.AutoCompleteBox.Text (-> AutoCompleteBox string) #:get))
(expanded? (: Avalonia.Controls.Expander.IsExpanded (-> Expander bool) #:get))
(tree-header-property (: Avalonia.Controls.Primitives.HeaderedItemsControl.HeaderProperty #:get))
(tree-expanded-property (: Avalonia.Controls.TreeViewItem.IsExpandedProperty #:get))
(tree-selected-property (: Avalonia.Controls.TreeView.SelectedItemProperty #:get))
(tree-selected (: Avalonia.Controls.TreeView.SelectedItem (-> TreeView Object) #:get))
(classes-of (: Avalonia.StyledElement.Classes (-> StyledElement Classes) #:get))
(classes-clear! (: Avalonia.Controls.Classes.Clear (-> Classes void)))
(classes-add! (: Avalonia.Controls.Classes.Add (-> Classes string void)))
(of-type (: Avalonia.Styling.Selectors.OfType (-> Selector ClrType Selector)))
(with-class (: Avalonia.Styling.Selectors.Class (-> Selector string Selector)))
(in-template (: Avalonia.Styling.Selectors.Template (-> Selector Selector)))
(named (: Avalonia.Styling.Selectors.Name (-> Selector string Selector)))
(selector! (: Avalonia.Styling.Style.Selector (-> AvaloniaStyle Selector void) #:set))
(setters-of (: Avalonia.Styling.StyleBase.Setters (-> StyleBase (IListOf SetterBase)) #:get))
(type-named (: System.Type.GetType (-> string ClrType)))
(theme-light (: Avalonia.Styling.ThemeVariant.Light #:get))
(theme-dark (: Avalonia.Styling.ThemeVariant.Dark #:get))
(theme-default (: Avalonia.Styling.ThemeVariant.Default #:get))
(requested-theme! (: Avalonia.Application.RequestedThemeVariant (-> Application ThemeVariant void) #:set))
(presenter-background (: Avalonia.Controls.Presenters.ContentPresenter.BackgroundProperty #:get))
(presenter-foreground (: Avalonia.Controls.Presenters.ContentPresenter.ForegroundProperty #:get))
(corner-property (: Avalonia.Controls.Primitives.TemplatedControl.CornerRadiusProperty #:get))
(changed-property (: Avalonia.AvaloniaPropertyChangedEventArgs.Property
(-> PropertyChange AvaloniaProperty) #:get))
(wrap-item-spacing (: Avalonia.Controls.WrapPanel.ItemSpacingProperty #:get))
(wrap-line-spacing (: Avalonia.Controls.WrapPanel.LineSpacingProperty #:get))
(cancel-close! (: System.ComponentModel.CancelEventArgs.Cancel (-> CancelArgs bool void) #:set))
;; A grid's sizes are not Avalonia properties, so they are set as .NET ;; A grid's sizes are not Avalonia properties, so they are set as .NET
;; properties are. ;; properties are.
@ -262,9 +177,6 @@
;; Events. ;; Events.
(click-event (: Avalonia.Controls.Button.ClickEvent #:get)) (click-event (: Avalonia.Controls.Button.ClickEvent #:get))
(menu-click-event (: Avalonia.Controls.MenuItem.ClickEvent #:get))
(number-changed-event (: Avalonia.Controls.NumericUpDown.ValueChangedEvent #:get))
(key-down-event (: Avalonia.Input.InputElement.KeyDownEvent #:get))
;; TextChanging and not TextChanged: TextChanged is posted to the ;; TextChanging and not TextChanged: TextChanged is posted to the
;; dispatcher and comes later, after the patch that set the text is over. ;; dispatcher and comes later, after the patch that set the text is over.
(text-changing-event (: Avalonia.Controls.TextBox.TextChangingEvent #:get)) (text-changing-event (: Avalonia.Controls.TextBox.TextChangingEvent #:get))
@ -339,8 +251,6 @@
(ColumnKind #t) (ColumnKind #t)
(RowKind #t) (RowKind #t)
(GridKind #t) (GridKind #t)
(WrapKind #t)
(DockKind #t)
(_ #f))) (_ #f)))
(: (-> Kind bool)) (: (-> Kind bool))
@ -361,43 +271,23 @@
(RowKind #f) (RowKind #f)
(GridKind #f) (GridKind #f)
(BorderKind #f) (BorderKind #f)
(ContextKind #f)
(WrapKind #f)
(DockKind #f)
(_ #t))) (_ #t)))
;; A kind that is on or off, as a checkbox.
(: (-> Kind bool))
(defun (toggle? kind)
(match kind
(CheckBoxKind #t)
(ToggleSwitchKind #t)
(RadioKind #t)
(_ #f)))
;; A kind whose children are the items of an Avalonia ItemsControl. ;; A kind whose children are the items of an Avalonia ItemsControl.
(: (-> Kind bool)) (: (-> Kind bool))
(defun (items? kind) (defun (items? kind)
(match kind (match kind
(ListBoxKind #t) (ListBoxKind #t)
(TabsKind #t) (TabsKind #t)
(MenuBarKind #t)
(MenuItemKind #t)
(ContextMenuKind #t)
(TreeKind #t)
(TreeNodeKind #t)
(_ #f))) (_ #f)))
;; A kind whose children each have a place of their own: the content of a ;; A kind with one child, which is its content.
;; scroll, a tab or a border, and a context menu's view and its menu.
(: (-> Kind bool)) (: (-> Kind bool))
(defun (single? kind) (defun (single? kind)
(match kind (match kind
(ScrollKind #t) (ScrollKind #t)
(TabKind #t) (TabKind #t)
(BorderKind #t) (BorderKind #t)
(ContextKind #t)
(ExpanderKind #t)
(_ #f))) (_ #f)))
;; A kind that chooses one of its items or options. ;; A kind that chooses one of its items or options.
@ -430,82 +320,57 @@
(defun (slot kind p) (defun (slot kind p)
(defun (when-kind ok? prop) (if ok? (Some prop) None)) (defun (when-kind ok? prop) (if ok? (Some prop) None))
(match p (match p
((PropLabel _) ((Label _)
(match kind (match kind
(TextKind (Some (cast AvaloniaProperty text-block-text))) (TextKind (Some (cast AvaloniaProperty text-block-text)))
(ButtonKind (Some (cast AvaloniaProperty content-property))) (ButtonKind (Some (cast AvaloniaProperty content-property)))
(CheckBoxKind (Some (cast AvaloniaProperty content-property))) (CheckBoxKind (Some (cast AvaloniaProperty content-property)))
(ToggleSwitchKind (Some (cast AvaloniaProperty content-property)))
(RadioKind (Some (cast AvaloniaProperty content-property)))
(ExpanderKind (Some (cast AvaloniaProperty header-property)))
(TreeNodeKind (Some (cast AvaloniaProperty tree-header-property)))
(TabKind (Some (cast AvaloniaProperty header-property))) (TabKind (Some (cast AvaloniaProperty header-property)))
(MenuItemKind (Some (cast AvaloniaProperty menu-header-property)))
(_ None))) (_ None)))
((PropValue _) ((Value _) (when-kind (text-box? kind) (cast AvaloniaProperty text-box-text)))
(cond ((text-box? kind) (Some (cast AvaloniaProperty text-box-text))) ((Placeholder _) (when-kind (text-box? kind) (cast AvaloniaProperty watermark-property)))
((= kind AutoCompleteKind) (Some (cast AvaloniaProperty auto-text-property))) ((Checked _) (when-kind (= kind CheckBoxKind) (cast AvaloniaProperty is-checked-property)))
(else None))) ((Enabled _) (Some (cast AvaloniaProperty is-enabled-property)))
((PropPlaceholder _) ((FontSize _)
(cond ((text-box? kind) (Some (cast AvaloniaProperty watermark-property)))
((= kind AutoCompleteKind) (Some (cast AvaloniaProperty auto-watermark-property)))
(else None)))
((PropChecked _) (when-kind (toggle? kind) (cast AvaloniaProperty is-checked-property)))
((PropEnabled _) (Some (cast AvaloniaProperty is-enabled-property)))
((PropFontSize _)
(cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-font-size))) (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-font-size)))
((templated? kind) (Some (cast AvaloniaProperty font-size-property))) ((templated? kind) (Some (cast AvaloniaProperty font-size-property)))
(else None))) (else None)))
((PropWidth _) (Some (cast AvaloniaProperty width-property))) ((Width _) (Some (cast AvaloniaProperty width-property)))
((PropHeight _) (Some (cast AvaloniaProperty height-property))) ((Height _) (Some (cast AvaloniaProperty height-property)))
((PropMargin _) (Some (cast AvaloniaProperty margin-property))) ((Margin _) (Some (cast AvaloniaProperty margin-property)))
((PropPadding _) ((Padding _)
(cond ((= kind BorderKind) (Some (cast AvaloniaProperty decorator-padding))) (cond ((= kind BorderKind) (Some (cast AvaloniaProperty decorator-padding)))
((templated? kind) (Some (cast AvaloniaProperty padding-property))) ((templated? kind) (Some (cast AvaloniaProperty padding-property)))
(else None))) (else None)))
((PropSpacing _) (when-kind (stack? kind) (cast AvaloniaProperty spacing-property))) ((Spacing _) (when-kind (stack? kind) (cast AvaloniaProperty spacing-property)))
((PropWrap _) (when-kind (= kind TextKind) (cast AvaloniaProperty text-block-wrapping))) ((Wrap _) (when-kind (= kind TextKind) (cast AvaloniaProperty text-block-wrapping)))
((PropMinimum _) (when-kind (range? kind) (cast AvaloniaProperty minimum-property))) ((Minimum _) (when-kind (range? kind) (cast AvaloniaProperty minimum-property)))
((PropMaximum _) (when-kind (range? kind) (cast AvaloniaProperty maximum-property))) ((Maximum _) (when-kind (range? kind) (cast AvaloniaProperty maximum-property)))
((PropAmount _) (when-kind (range? kind) (cast AvaloniaProperty value-property))) ((Amount _) (when-kind (range? kind) (cast AvaloniaProperty value-property)))
((PropStep _) (when-kind (= kind SliderKind) (cast AvaloniaProperty small-change-property))) ((Step _) (when-kind (= kind SliderKind) (cast AvaloniaProperty small-change-property)))
((PropItems _) ((Items _) (when-kind (= kind DropdownKind) (cast AvaloniaProperty items-source-property)))
(cond ((= kind DropdownKind) (Some (cast AvaloniaProperty items-source-property))) ((Selected _) (when-kind (selecting? kind) (cast AvaloniaProperty selected-index-property)))
((= kind AutoCompleteKind) (Some (cast AvaloniaProperty auto-items-property))) ((Row _) (Some (cast AvaloniaProperty grid-row-property)))
(else None))) ((Column _) (Some (cast AvaloniaProperty grid-column-property)))
((PropSelected _) (when-kind (selecting? kind) (cast AvaloniaProperty selected-index-property))) ((RowSpan _) (Some (cast AvaloniaProperty grid-row-span-property)))
((PropRow _) (Some (cast AvaloniaProperty grid-row-property))) ((ColumnSpan _) (Some (cast AvaloniaProperty grid-column-span-property)))
((PropColumn _) (Some (cast AvaloniaProperty grid-column-property))) ((Background _)
((PropRowSpan _) (Some (cast AvaloniaProperty grid-row-span-property)))
((PropColumnSpan _) (Some (cast AvaloniaProperty grid-column-span-property)))
((PropBackground _)
(cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-background))) (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-background)))
((= kind BorderKind) (Some (cast AvaloniaProperty border-background))) ((= kind BorderKind) (Some (cast AvaloniaProperty border-background)))
((panel? kind) (Some (cast AvaloniaProperty panel-background))) ((panel? kind) (Some (cast AvaloniaProperty panel-background)))
((templated? kind) (Some (cast AvaloniaProperty background-property))) ((templated? kind) (Some (cast AvaloniaProperty background-property)))
(else None))) (else None)))
((PropForeground _) ((Foreground _)
(cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-foreground))) (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-foreground)))
((templated? kind) (Some (cast AvaloniaProperty foreground-property))) ((templated? kind) (Some (cast AvaloniaProperty foreground-property)))
(else None))) (else None)))
((PropBorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property))) ((BorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property)))
((PropBorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property))) ((BorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property)))
((PropRadius _) (when-kind (= kind BorderKind) (cast AvaloniaProperty corner-radius-property))) ((Radius _) (when-kind (= kind BorderKind) (cast AvaloniaProperty corner-radius-property)))
((PropShortcut _) (when-kind (= kind MenuItemKind) (cast AvaloniaProperty input-gesture-property)))
((PropTip _) (Some (cast AvaloniaProperty tip-property)))
((PropExpanded _)
(cond ((= kind ExpanderKind) (Some (cast AvaloniaProperty expanded-property)))
((= kind TreeNodeKind) (Some (cast AvaloniaProperty tree-expanded-property)))
(else None)))
;; Set after the children, by `sync-tree-choice!`.
((PropChosenKey _) None)
((PropDockSide _) (Some (cast AvaloniaProperty dock-property)))
((PropClasses _) None)
((PropDate _) (when-kind (= kind DateKind) (cast AvaloniaProperty date-property)))
;; Set by `set-prop!` itself. ;; Set by `set-prop!` itself.
((PropSource _) None) ((Source _) None)
((PropColumns _) None) ((Columns _) None)
((PropRows _) None))) ((Rows _) None)))
(: (-> bool TextWrapping)) (: (-> bool TextWrapping))
(defun (wrapping wrap?) (defun (wrapping wrap?)
@ -527,84 +392,60 @@
(: (-> Prop (Option Object))) (: (-> Prop (Option Object)))
(defun (boxed p) (defun (boxed p)
(match p (match p
((PropBackground s) (brush s)) ((Background s) (brush s))
((PropForeground s) (brush s)) ((Foreground s) (brush s))
((PropBorderColour s) (brush s)) ((BorderColour s) (brush s))
((PropShortcut s) (match (gesture s) ((Some g) (Some (cast Object g))) (None None)))
;; No date, or one that cannot be read, is none: the property is cleared.
((PropDate s)
(if (string-empty? s)
None
(match (try (parse-date s) #:catch (System.Exception))
((Ok d) (Some (cast Object d)))
((Err _) None))))
(_ (Some (plain p))))) (_ (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)) (: (-> Prop Object))
(defun (plain p) (defun (plain p)
(defun (text s) (cast Object (->clr-string s))) (defun (text s) (cast Object (->clr-string s)))
(match p (match p
((PropLabel s) (text s)) ((Label s) (text s))
((PropValue s) (text s)) ((Value s) (text s))
((PropPlaceholder s) (text s)) ((Placeholder s) (text s))
((PropChecked b) (cast Object b)) ((Checked b) (cast Object b))
((PropEnabled b) (cast Object b)) ((Enabled b) (cast Object b))
((PropFontSize d) (cast Object d)) ((FontSize d) (cast Object d))
((PropWidth d) (cast Object d)) ((Width d) (cast Object d))
((PropHeight d) (cast Object d)) ((Height d) (cast Object d))
((PropMargin d) (cast Object (Thickness. d))) ((Margin d) (cast Object (Thickness. d)))
((PropPadding d) (cast Object (Thickness. d))) ((Padding d) (cast Object (Thickness. d)))
((PropSpacing d) (cast Object d)) ((Spacing d) (cast Object d))
((PropWrap b) (cast Object (wrapping b))) ((Wrap b) (cast Object (wrapping b)))
((PropMinimum d) (cast Object d)) ((Minimum d) (cast Object d))
((PropMaximum d) (cast Object d)) ((Maximum d) (cast Object d))
((PropAmount d) (cast Object d)) ((Amount d) (cast Object d))
((PropStep d) (cast Object d)) ((Step d) (cast Object d))
;; A .NET array of .NET strings, which a ComboBox shows as they are. ;; A .NET array of .NET strings, which a ComboBox shows as they are.
((PropItems xs) (cast Object (: (vec->array (vec-map ->clr-string xs)) (Array ClrString)))) ((Items xs) (cast Object (: (vec->array (vec-map ->clr-string xs)) (Array ClrString))))
((PropSelected i) (cast Object i)) ((Selected i) (cast Object i))
((PropRow i) (cast Object i)) ((Row i) (cast Object i))
((PropColumn i) (cast Object i)) ((Column i) (cast Object i))
((PropRowSpan i) (cast Object i)) ((RowSpan i) (cast Object i))
((PropColumnSpan i) (cast Object i)) ((ColumnSpan i) (cast Object i))
((PropSource s) (text s)) ((Source s) (text s))
((PropColumns s) (text s)) ((Columns s) (text s))
((PropRows s) (text s)) ((Rows s) (text s))
((PropBackground s) (text s)) ((Background s) (text s))
((PropForeground s) (text s)) ((Foreground s) (text s))
((PropBorderColour s) (text s)) ((BorderColour s) (text s))
((PropBorderWidth d) (cast Object (Thickness. d))) ((BorderWidth d) (cast Object (Thickness. d)))
((PropRadius d) (cast Object (CornerRadius. d))) ((Radius d) (cast Object (CornerRadius. d)))))
((PropShortcut s) (text s))
((PropTip s) (text s))
((PropExpanded b) (cast Object b))
((PropDate s) (text s))
((PropClasses _) (cast Object 0))
((PropChosenKey s) (text s))
((PropDockSide i)
(cast Object (match i (0 DockEdge.Left) (1 DockEdge.Top) (2 DockEdge.Right) (_ DockEdge.Bottom))))))
;; Which prop it is, without its value. Two props with one tag set the same ;; Which prop it is, without its value. Two props with one tag set the same
;; property. ;; property.
(: (-> Prop int)) (: (-> Prop int))
(defun (tag p) (defun (tag p)
(match p (match p
((PropLabel _) 0) ((PropValue _) 1) ((PropPlaceholder _) 2) ((PropChecked _) 3) ((Label _) 0) ((Value _) 1) ((Placeholder _) 2) ((Checked _) 3)
((PropEnabled _) 4) ((PropFontSize _) 5) ((PropWidth _) 6) ((PropHeight _) 7) ((Enabled _) 4) ((FontSize _) 5) ((Width _) 6) ((Height _) 7)
((PropMargin _) 8) ((PropPadding _) 9) ((PropSpacing _) 10) ((PropWrap _) 11) ((Margin _) 8) ((Padding _) 9) ((Spacing _) 10) ((Wrap _) 11)
((PropMinimum _) 12) ((PropMaximum _) 13) ((PropAmount _) 14) ((PropStep _) 15) ((Minimum _) 12) ((Maximum _) 13) ((Amount _) 14) ((Step _) 15)
((PropItems _) 16) ((PropSelected _) 17) ((PropSource _) 18) ((PropColumns _) 19) ((Items _) 16) ((Selected _) 17) ((Source _) 18) ((Columns _) 19)
((PropRows _) 20) ((PropRow _) 21) ((PropColumn _) 22) ((PropRowSpan _) 23) ((PropColumnSpan _) 24) ((Rows _) 20) ((Row _) 21) ((Column _) 22) ((RowSpan _) 23) ((ColumnSpan _) 24)
((PropBackground _) 25) ((PropForeground _) 26) ((PropBorderColour _) 27) ((PropBorderWidth _) 28) ((Background _) 25) ((Foreground _) 26) ((BorderColour _) 27) ((BorderWidth _) 28)
((PropRadius _) 29) ((PropShortcut _) 30) ((PropTip _) 31) ((PropExpanded _) 32) ((PropDate _) 33) ((Radius _) 29)))
((PropDockSide _) 34) ((PropClasses _) 35) ((PropChosenKey _) 36)))
(: (-> Control AvaloniaProperty Object void)) (: (-> Control AvaloniaProperty Object void))
(defun (put! control property value) (defun (put! control property value)
@ -620,31 +461,15 @@
(: (-> Control Kind Prop void)) (: (-> Control Kind Prop void))
(defun (set-prop! control kind p) (defun (set-prop! control kind p)
(match (Tuple kind p) (match (Tuple kind p)
((Tuple ImageKind (PropSource path)) ((Tuple ImageKind (Source path))
(match (load-bitmap path) (match (load-bitmap path)
((Some b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b))) ((Some b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b)))
(None (clear-value (cast AvaloniaObject control) (cast AvaloniaProperty image-source-property))))) (None (clear-value (cast AvaloniaObject control) (cast AvaloniaProperty image-source-property)))))
((Tuple GridKind (PropColumns s)) (grid-columns! (cast Grid control) (parse-columns s))) ((Tuple GridKind (Columns s)) (grid-columns! (cast Grid control) (parse-columns s)))
((Tuple GridKind (PropRows s)) (grid-rows! (cast Grid control) (parse-rows s))) ((Tuple GridKind (Rows s)) (grid-rows! (cast Grid control) (parse-rows s)))
((Tuple GridKind (PropSpacing d)) ((Tuple GridKind (Spacing d))
(put! control (cast AvaloniaProperty grid-row-spacing-property) (cast Object d)) (put! control (cast AvaloniaProperty grid-row-spacing-property) (cast Object d))
(put! control (cast AvaloniaProperty grid-column-spacing-property) (cast Object d))) (put! control (cast AvaloniaProperty grid-column-spacing-property) (cast Object d)))
((Tuple WrapKind (PropSpacing d))
(put! control (cast AvaloniaProperty wrap-item-spacing) (cast Object d))
(put! control (cast AvaloniaProperty wrap-line-spacing) (cast Object d)))
((Tuple _ (PropClasses names))
(def classes (classes-of (cast StyledElement control)))
(classes-clear! classes)
(loop (:for n names) (:do (classes-add! classes n))))
;; A number input's numbers are decimals.
((Tuple NumberKind (PropMinimum d))
(put! control (cast AvaloniaProperty number-minimum-property) (cast Object (cast System.Decimal d))))
((Tuple NumberKind (PropMaximum d))
(put! control (cast AvaloniaProperty number-maximum-property) (cast Object (cast System.Decimal d))))
((Tuple NumberKind (PropStep d))
(put! control (cast AvaloniaProperty number-increment-property) (cast Object (cast System.Decimal d))))
((Tuple NumberKind (PropAmount d))
(put! control (cast AvaloniaProperty number-value-property) (cast Object (cast System.Decimal d))))
(_ (_
(match (slot kind p) (match (slot kind p)
((Some property) ((Some property)
@ -657,16 +482,12 @@
(defun (clear-prop! control kind p) (defun (clear-prop! control kind p)
(defun (clear property) (clear-value (cast AvaloniaObject control) property)) (defun (clear property) (clear-value (cast AvaloniaObject control) property))
(match (Tuple kind p) (match (Tuple kind p)
((Tuple ImageKind (PropSource _)) (clear (cast AvaloniaProperty image-source-property))) ((Tuple ImageKind (Source _)) (clear (cast AvaloniaProperty image-source-property)))
((Tuple GridKind (PropColumns _)) (grid-columns! (cast Grid control) (parse-columns "*"))) ((Tuple GridKind (Columns _)) (grid-columns! (cast Grid control) (parse-columns "*")))
((Tuple GridKind (PropRows _)) (grid-rows! (cast Grid control) (parse-rows "*"))) ((Tuple GridKind (Rows _)) (grid-rows! (cast Grid control) (parse-rows "*")))
((Tuple GridKind (PropSpacing _)) ((Tuple GridKind (Spacing _))
(clear (cast AvaloniaProperty grid-row-spacing-property)) (clear (cast AvaloniaProperty grid-row-spacing-property))
(clear (cast AvaloniaProperty grid-column-spacing-property))) (clear (cast AvaloniaProperty grid-column-spacing-property)))
((Tuple WrapKind (PropSpacing _))
(clear (cast AvaloniaProperty wrap-item-spacing))
(clear (cast AvaloniaProperty wrap-line-spacing)))
((Tuple _ (PropClasses _)) (classes-clear! (classes-of (cast StyledElement control))))
(_ (_
(match (slot kind p) (match (slot kind p)
((Some property) (clear property)) ((Some property) (clear property))
@ -746,9 +567,6 @@
(: gui-update (-> %m %model (Tuple %model (List (Event %m))))) (: gui-update (-> %m %model (Tuple %model (List (Event %m)))))
(: view (-> %model (View %m))) (: view (-> %model (View %m)))
(: subscriptions (-> %model (List (Sub %m)))) (: subscriptions (-> %model (List (Sub %m))))
(: keys (-> %model (List (Key %m))))
(: theme (-> %model string))
(: shown-theme string #:mutable)
(: root (Option (Live %m)) #:mutable) (: root (Option (Live %m)) #:mutable)
(: patching bool #:mutable) (: patching bool #:mutable)
(: stopped bool #:mutable) (: stopped bool #:mutable)
@ -809,45 +627,6 @@
(defun (app-run-pending! app) (defun (app-run-pending! app)
(ui-run-jobs ui-dispatcher (clr-default))) (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 (PropEnabled #f)))
(any? (fun (p) (match p ((PropShortcut s) (same? s)) (_ #f))) props))
(loop (:for on (view-events v))
(:when-let (OnClick 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 ;; Stops the app: its subscriptions are cancelled, and later messages are
;; dropped. A command that is still running is cancelled when the scope the ;; dropped. A command that is still running is cancelled when the scope the
;; app was started in ends. ;; app was started in ends.
@ -860,7 +639,6 @@
(: (-> (App %model %m) (List (Event %m)) void)) (: (-> (App %model %m) (List (Event %m)) void))
(defun (step! app commands) (defun (step! app commands)
(render! app) (render! app)
(apply-theme! app)
(in-scope (.home app) (in-scope (.home app)
(loop (:for command commands) (loop (:for command commands)
(:do (spawn/daemon (run-command app command))))) (:do (spawn/daemon (run-command app command)))))
@ -909,18 +687,6 @@
(:do (set! kept (cons (Tuple (sub-key sub) (start-sub! app sub)) kept)))) (:do (set! kept (cons (Tuple (sub-key sub) (start-sub! app sub)) kept))))
(record-set! app (subs kept))) (record-set! app (subs kept)))
;; Sets the theme the model asks for, when it is another than the one shown.
;; "light" and "dark" are those; anything else is the system's.
(: (-> (App %model %m) void))
(defun (apply-theme! app)
(def wanted ((.theme app) (.model app)))
(unless (= wanted (.shown-theme app))
(record-set! app (shown-theme wanted))
(def application (cast Object current-app))
(unless (eq? application (clr-default))
(requested-theme! (cast Application application)
(match wanted ("light" theme-light) ("dark" theme-dark) (_ theme-default))))))
(: (-> (App %model %m) void)) (: (-> (App %model %m) void))
(defun (render! app) (defun (render! app)
(def next-view ((.view app) (.model app))) (def next-view ((.view app) (.model app)))
@ -966,76 +732,30 @@
(fun (sender e) (fun (sender e)
(when (eq? (event-source e) (cast Object control)) (when (eq? (event-source e) (cast Object control))
(fire! app live (pick)))))) (fire! app live (pick))))))
(defun (on-change (: property AvaloniaProperty) pick)
(ignore (add-event-handler! control "PropertyChanged"
(: (fun (sender e)
(when (eq? (changed-property (cast PropertyChange e)) property)
(fire! app live (pick))))
(-> Object Object void)))))
(match kind (match kind
(MenuItemKind
(on-event (cast RoutedEvent menu-click-event)
(fun () (fun (on) (match on ((OnClick msg) (Some msg)) (_ None))))))
(ButtonKind (ButtonKind
(on-event (cast RoutedEvent click-event) (on-event (cast RoutedEvent click-event)
(fun () (fun (on) (match on ((OnClick msg) (Some msg)) (_ None)))))) (fun () (fun (on) (match on ((Click msg) (Some msg)) (_ None))))))
((or TextInputKind TextAreaKind) ((or TextInputKind TextAreaKind)
(on-event (cast RoutedEvent text-changing-event) (on-event (cast RoutedEvent text-changing-event)
(fun () (fun ()
(def s (text-box-value (cast TextBox control))) (def s (text-box-value (cast TextBox control)))
(fun (on) (match on ((OnInput f) (Some (f s))) (_ None)))))) (fun (on) (match on ((Input f) (Some (f s))) (_ None))))))
(RadioKind (CheckBoxKind
(on-event (cast RoutedEvent checked-event) (on-event (cast RoutedEvent checked-event)
(fun () (fun ()
(def b (.GetValueOrDefault (is-checked (cast ToggleButton control)))) (def b (.GetValueOrDefault (is-checked (cast ToggleButton control))))
(fun (on) (match on ((OnClick msg) (if b (Some msg) None)) (_ None)))))) (fun (on) (match on ((Toggle f) (Some (f b))) (_ None))))))
(NumberKind
(on-event (cast RoutedEvent number-changed-event)
(fun ()
(def d (cast System.Double (.GetValueOrDefault (number-value (cast NumericUpDown control)))))
(fun (on) (match on ((OnSlide f) (Some (f d))) (_ None))))))
;; An expander's and a completion box's own events come from the parts of
;; their templates, so they listen to the property itself.
(ExpanderKind
(on-change (cast AvaloniaProperty expanded-property)
(fun ()
(def b (expanded? (cast Expander control)))
(fun (on) (match on ((OnToggle f) (Some (f b))) (_ None))))))
(AutoCompleteKind
(on-change (cast AvaloniaProperty auto-text-property)
(fun ()
(def s (auto-text (cast AutoCompleteBox control)))
(fun (on) (match on ((OnInput f) (Some (f s))) (_ None))))))
(DateKind
;; A .NET event and not a routed one.
(ignore (add-event-handler! control "SelectedDateChanged"
(: (fun (sender e)
(def d (selected-date (cast DatePicker control)))
(def s (if (.-HasValue d) (.ToString (.-Value d) "yyyy-MM-dd") ""))
(fire! app live (fun (on) (match on ((OnInput f) (Some (f s))) (_ None)))))
(-> Object Object void)))))
((or CheckBoxKind ToggleSwitchKind)
(on-event (cast RoutedEvent checked-event)
(fun ()
(def b (.GetValueOrDefault (is-checked (cast ToggleButton control))))
(fun (on) (match on ((OnToggle f) (Some (f b))) (_ None))))))
(SliderKind (SliderKind
(on-event (cast RoutedEvent value-changed-event) (on-event (cast RoutedEvent value-changed-event)
(fun () (fun ()
(def d (range-value (cast RangeBase control))) (def d (range-value (cast RangeBase control)))
(fun (on) (match on ((OnSlide f) (Some (f d))) (_ None)))))) (fun (on) (match on ((Slide f) (Some (f d))) (_ None))))))
(TreeKind
(on-event (cast RoutedEvent selection-changed-event)
(fun ()
(def key (match (tree-node-key live (tree-selected (cast TreeView control)))
((Some k) k)
(None "")))
(fun (on) (match on ((OnPick f) (Some (f key))) (_ None))))))
((or DropdownKind ListBoxKind TabsKind) ((or DropdownKind ListBoxKind TabsKind)
(on-event (cast RoutedEvent selection-changed-event) (on-event (cast RoutedEvent selection-changed-event)
(fun () (fun ()
(def i (selected-index (cast SelectingItemsControl control))) (def i (selected-index (cast SelectingItemsControl control)))
(fun (on) (match on ((OnSelect f) (Some (f i))) (_ None)))))) (fun (on) (match on ((Select f) (Some (f i))) (_ None))))))
(_ unit))) (_ unit)))
(: (-> Kind Control)) (: (-> Kind Control))
@ -1076,22 +796,7 @@
(ListBoxKind (cast Control (ListBox.))) (ListBoxKind (cast Control (ListBox.)))
(TabsKind (cast Control (TabControl.))) (TabsKind (cast Control (TabControl.)))
(TabKind (cast Control (TabItem.))) (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.)))
(TreeKind (cast Control (TreeView.)))
(TreeNodeKind (cast Control (TreeViewItem.)))
(ToggleSwitchKind (cast Control (ToggleSwitch.)))
(RadioKind (cast Control (RadioButton.)))
(NumberKind (cast Control (NumericUpDown.)))
(DateKind (cast Control (DatePicker.)))
(AutoCompleteKind (cast Control (AutoCompleteBox.)))
(ExpanderKind (cast Control (Expander.)))
(WrapKind (cast Control (WrapPanel.)))
(DockKind (cast Control (DockPanel.)))))
;; Where the controls of a panel's children, or of a list's items, are. ;; Where the controls of a panel's children, or of a list's items, are.
(: (-> Kind Control IList)) (: (-> Kind Control IList))
@ -1100,21 +805,18 @@
(cast IList (items-of (cast ItemsControl parent))) (cast IList (items-of (cast ItemsControl parent)))
(cast IList (panel-children (cast Panel parent))))) (cast IList (panel-children (cast Panel parent)))))
;; Puts `child` in its place: the content of a scroll, a tab or a border, and ;; Makes `child` the one child of a scroll, a tab or a border.
;; for a context menu, its view at 0 and the menu at 1. (: (-> Kind Control Control void))
(: (-> Kind Control int Control void)) (defun (set-single! kind parent child)
(defun (set-slot! kind parent i child) (if (= kind BorderKind)
(cond ((and (= kind ContextKind) (= i 1)) (put! parent (cast AvaloniaProperty decorator-child) (cast Object child))
(put! parent (cast AvaloniaProperty context-menu-property) (cast Object child))) (content! (cast ContentControl parent) (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 child `i`, the last one so far. ;; Puts a child's control in its parent's, as the last one.
(: (-> Kind Control int Control void)) (: (-> Kind Control Control void))
(defun (adopt! kind parent i child) (defun (adopt! kind parent child)
(if (single? kind) (if (single? kind)
(set-slot! kind parent i child) (set-single! kind parent child)
(ignore (list-add! (child-list kind parent) (cast Object 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 ;; A list or tabs can choose an item only once the items are there, so the
@ -1125,7 +827,7 @@
(when (selecting? kind) (when (selecting? kind)
(loop (:for p props) (loop (:for p props)
(:do (match p (:do (match p
((PropSelected i) ((Selected i)
(unless (= (selected-index (cast SelectingItemsControl control)) i) (unless (= (selected-index (cast SelectingItemsControl control)) i)
(put! control (cast AvaloniaProperty selected-index-property) (cast Object i)))) (put! control (cast AvaloniaProperty selected-index-property) (cast Object i))))
(_ unit)))))) (_ unit))))))
@ -1141,9 +843,8 @@
(loop (:for child (view-children v)) (loop (:for child (view-children v))
(:do (def c (mount app child)) (:do (def c (mount app child))
(mutablevec-add! (.children live) c) (mutablevec-add! (.children live) c)
(adopt! kind control (- (mutablevec-length (.children live)) 1) (.control c)))) (adopt! kind control (.control c))))
(sync-selection! control kind (view-props v)) (sync-selection! control kind (view-props v))
(sync-tree-choice! live)
live) live)
;; Changes the controls of `live` to show `next`. Gives `live` itself, or new ;; Changes the controls of `live` to show `next`. Gives `live` itself, or new
@ -1161,61 +862,17 @@
((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next))) ((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next)))
(else unit)) (else unit))
(sync-selection! (.control live) kind (view-props next)) (sync-selection! (.control live) kind (view-props next))
(sync-tree-choice! live)
live))) live)))
;; The node of a tree whose control is `control`, among the live nodes below ;; The one child of a scroll, a tab or a border.
;; `live`, and its key.
(: (-> (Live %m) Object (Option string)))
(defun (tree-node-key live control)
(: (-> (Live %m) (Option string)))
(defun (walk l)
(if (and (= (view-kind (.view l)) TreeNodeKind) (eq? (cast Object (.control l)) control))
(view-key (.view l))
(loop (:for c (mutablevec->vec (.children l)))
(:when-let (Some k) (walk c))
(:finish #t (Some k))
=> None)))
(walk live))
;; The control of the node with `key` below `live`.
(: (-> (Live %m) string (Option Control)))
(defun (tree-node-control live key)
(if (and (= (view-kind (.view live)) TreeNodeKind) (= (view-key (.view live)) (Some key)))
(Some (.control live))
(loop (:for c (mutablevec->vec (.children live)))
(:when-let (Some found) (tree-node-control c key))
(:finish #t (Some found))
=> None)))
;; Chooses the node of a tree whose key the view gives, once the nodes are
;; there, if it is not chosen already.
(: (-> (Live %m) void))
(defun (sync-tree-choice! live)
(when (= (view-kind (.view live)) TreeKind)
(def control (.control live))
(loop (:for p (view-props (.view live)))
(:do (match p
((PropChosenKey key)
(match (if (string-empty? key) None (tree-node-control live key))
((Some node)
(unless (eq? (tree-selected (cast TreeView control)) (cast Object node))
(put! control (cast AvaloniaProperty tree-selected-property) (cast Object node))))
;; Null and not a clear: SelectedItem is a direct property,
;; which a clear does not reset.
(None (put! control (cast AvaloniaProperty tree-selected-property) (clr-default)))))
(_ unit))))))
;; The children of a kind whose children each have a place of their own.
(: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void)) (: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void))
(defun (patch-single! app live kind views) (defun (patch-single! app live kind views)
(def kids (.children live)) (def kids (.children live))
(loop (:for (Tuple i v) (enumerate views)) (def was (mutablevec-ref kids 0))
(:do (def was (mutablevec-ref kids i)) (def now (patch! app was (vec-ref views 0)))
(def now (patch! app was v)) (unless (eq? now was)
(unless (eq? now was) (mutablevec-set! kids 0 now)
(mutablevec-set! kids i now) (set-single! kind (.control live) (.control now))))
(set-slot! kind (.control live) i (.control now))))))
;; Which child each view is: its key, or its place among the children that ;; 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. ;; have none. The two kinds cannot be mistaken for each other.
@ -1283,132 +940,14 @@
;; Its fibers belong to the scope it is started in. ;; Its fibers belong to the scope it is started in.
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m)) (: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
(-> Control void) (#:subscriptions (-> %model (List (Sub %m)))) (-> Control void) (#:subscriptions (-> %model (List (Sub %m))))
(#:keys (-> %model (List (Key %m)))) (#:theme (-> %model string))
(App %model %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) '()) #:theme (fun (m) ""))
(def app (App (model init) (gui-update gui-update) (view view) (def app (App (model init) (gui-update gui-update) (view view)
(subscriptions subscriptions) (keys keys) (theme theme) (shown-theme "") (subscriptions subscriptions) (root None) (patching #f) (stopped #f)
(root None) (patching #f) (stopped #f)
(home (current-scope)) (subs '()) (on-root on-root))) (home (current-scope)) (subs '()) (on-root on-root)))
(step! app '()) (step! app '())
app) app)
;; ---------------------------------------------------------------------------
;; Styles
;; ---------------------------------------------------------------------------
;; A style: the look of every view of a kind, or of a kind and a class.
(type (: StyleRule (Record (: kind string) (: class string) (: props (Vec Prop))
(: hover (Vec Prop)) (: pressed (Vec Prop)))))
(: (-> (Vec Prop) string (-> string Prop) (Vec Prop)))
(defun (with-colour props c make)
(if (string-empty? c) props (vec-add props (make c))))
;; The look of every view of `kind` in the class `#:class`, or of every view
;; of `kind` if there is no class. `kind` is the name of the constructor:
;; "button", "text", "text-input", "checkbox", "border" and so on.
;;
;; `#:hover-…` and `#:pressed-…` are the colours while the pointer is over a
;; button and while it is pressed. They are set inside the button's template,
;; as the Fluent theme sets its own, and so only a button has them.
(: style (-> string (#:class string) (#:colour string) (#:background string)
(#:hover-colour string) (#:hover-background string)
(#:pressed-colour string) (#:pressed-background string)
(#:font-size double) (#:padding double) (#:radius double)
StyleRule))
(defun (style kind #:class "" #:colour "" #:background "" #:hover-colour "" #:hover-background ""
#:pressed-colour "" #:pressed-background "" #:font-size 0.0 #:padding 0.0
#:radius 0.0)
(defun (size props make d) (if (> d 0.0) (vec-add props (make d)) props))
(StyleRule (kind kind) (class class)
(props (size (size (size (with-colour (with-colour [] colour PropForeground)
background PropBackground)
PropFontSize font-size)
PropPadding padding)
PropRadius radius))
(hover (with-colour (with-colour [] hover-colour PropForeground)
hover-background PropBackground))
(pressed (with-colour (with-colour [] pressed-colour PropForeground)
pressed-background PropBackground))))
;; The kind a constructor's name makes, and the Avalonia class of it.
(: (-> string (Option (Tuple Kind string))))
(defun (styled-kind name)
(match name
("text" (Some (Tuple TextKind "Avalonia.Controls.TextBlock")))
("button" (Some (Tuple ButtonKind "Avalonia.Controls.Button")))
("text-input" (Some (Tuple TextInputKind "Avalonia.Controls.TextBox")))
("text-area" (Some (Tuple TextAreaKind "Avalonia.Controls.TextBox")))
("checkbox" (Some (Tuple CheckBoxKind "Avalonia.Controls.CheckBox")))
("toggle-switch" (Some (Tuple ToggleSwitchKind "Avalonia.Controls.ToggleSwitch")))
("radio" (Some (Tuple RadioKind "Avalonia.Controls.RadioButton")))
("list-box" (Some (Tuple ListBoxKind "Avalonia.Controls.ListBox")))
("dropdown" (Some (Tuple DropdownKind "Avalonia.Controls.ComboBox")))
("border" (Some (Tuple BorderKind "Avalonia.Controls.Border")))
("column" (Some (Tuple ColumnKind "Avalonia.Controls.StackPanel")))
("row" (Some (Tuple RowKind "Avalonia.Controls.StackPanel")))
("grid" (Some (Tuple GridKind "Avalonia.Controls.Grid")))
(_ None)))
;; The setters are a List of Avalonia's, so they are reached as an IList.
(: (-> AvaloniaStyle Setter void))
(defun (add-setter! s setter)
(ignore (list-add! (cast IList (cast Object (setters-of (cast StyleBase s)))) (cast Object setter))))
;; A setter for each prop that the kind takes.
(: (-> AvaloniaStyle Kind (Vec Prop) void))
(defun (add-setters! s kind props)
(loop (:for p props)
(:do (def property
(match (Tuple kind p)
((Tuple BorderKind (PropRadius _)) (Some (cast AvaloniaProperty corner-radius-property)))
((Tuple _ (PropRadius _))
(if (templated? kind) (Some (cast AvaloniaProperty corner-property)) None))
(_ (slot kind p))))
(match (Tuple property (boxed p))
((Tuple (Some prop) (Some value))
(add-setter! s (Setter. prop value)))
(_ unit)))))
;; The setters of a state of a button, on the presenter in its template.
(: (-> AvaloniaStyle (Vec Prop) void))
(defun (add-presenter-setters! s props)
(loop (:for p props)
(:do (match (Tuple p (boxed p))
((Tuple (PropBackground _) (Some v))
(add-setter! s (Setter. (cast AvaloniaProperty presenter-background) v)))
((Tuple (PropForeground _) (Some v))
(add-setter! s (Setter. (cast AvaloniaProperty presenter-foreground) v)))
(_ unit)))))
;; The Avalonia styles of a rule: the look at rest, and for a button the look
;; while the pointer is over it and while it is pressed. A kind that has no
;; name here makes none.
(: (-> StyleRule (List AvaloniaStyle)))
(defun (avalonia-styles rule)
(match (styled-kind (.kind rule))
(None '())
((Some (Tuple kind type-name))
;; Made anew for each style, because Selectors.Class adds a class to a
;; type-and-class selector it is given, and does not make a new one.
(defun (base)
(def t (of-type (clr-default) (type-named #"${type-name}, Avalonia.Controls")))
(if (string-empty? (.class rule)) t (with-class t (.class rule))))
(defun (make sel) (def s (AvaloniaStyle.)) (selector! s sel) s)
(def at-rest (make (base)))
(add-setters! at-rest kind (.props rule))
(defun (state pseudo props)
(def s (make (named (of-type (in-template (with-class (base) pseudo))
(type-named "Avalonia.Controls.Presenters.ContentPresenter, Avalonia.Controls"))
"PART_ContentPresenter")))
(add-presenter-setters! s props)
s)
(if (and (= kind ButtonKind) (or (> (vec-length (.hover rule)) 0) (> (vec-length (.pressed rule)) 0)))
(list at-rest (state ":pointerover" (.hover rule)) (state ":pressed" (.pressed rule)))
(list at-rest)))))
;; Saves a picture of the window to `path` once it has been shown and laid ;; Saves a picture of the window to `path` once it has been shown and laid
;; out, and closes it. Twice the pixels of the window, so that it is sharp on ;; out, and closes it. Twice the pixels of the window, so that it is sharp on
;; a screen with a scale of 2. ;; a screen with a scale of 2.
@ -1431,10 +970,6 @@
;; Runs the program in a window, until the window is closed. Then the ;; Runs the program in a window, until the window is closed. Then the
;; subscriptions and the commands still running are cancelled. ;; subscriptions and the commands still running are cancelled.
;; ;;
;; With `#:on-close msg`, a click on the window's close button does not close
;; it: it sends `msg`, and the program closes it with `quit` from
;; (bjogui dialogs) when it is ready, say after asking about unsaved work.
;;
;; With `#:screenshot`, a path, the window saves a PNG of itself there once it ;; With `#:screenshot`, a path, the window saves a PNG of itself there once it
;; is shown, and closes. It is the environment variable BJOGUI_SCREENSHOT ;; is shown, and closes. It is the environment variable BJOGUI_SCREENSHOT
;; unless told otherwise, so any program can be pictured with no change: ;; unless told otherwise, so any program can be pictured with no change:
@ -1442,12 +977,9 @@
;; BJOGUI_SCREENSHOT=shot.png bjo run examples/todo.bjo ;; BJOGUI_SCREENSHOT=shot.png bjo run examples/todo.bjo
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m)) (: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
(#:subscriptions (-> %model (List (Sub %m)))) (#:subscriptions (-> %model (List (Sub %m))))
(#:keys (-> %model (List (Key %m)))) (#:on-close (Option %m))
(#:theme (-> %model string)) (#:styles (List StyleRule))
(#:title string) (#:width double) (#:height double) (#:screenshot string) (#:title string) (#:width double) (#:height double) (#:screenshot string)
void)) void))
(defun (run-app init gui-update view #:subscriptions (fun (m) '()) #:keys (fun (m) '()) (defun (run-app init gui-update view #:subscriptions (fun (m) '())
#:on-close None #:theme (fun (m) "") #:styles '()
#:title "bjogui" #:width 400.0 #:height 300.0 #:title "bjogui" #:width 400.0 #:height 300.0
#:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") "")) #:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") ""))
;; The Application is made inside the setup, because making one uses the ;; The Application is made inside the setup, because making one uses the
@ -1456,9 +988,6 @@
(ignore (setup-with-lifetime (use-platform-detect (configure (fun () (Application.)))) (ignore (setup-with-lifetime (use-platform-detect (configure (fun () (Application.))))
lifetime)) lifetime))
(.Add (app-styles current-app) (FluentTheme. (clr-default))) (.Add (app-styles current-app) (FluentTheme. (clr-default)))
(loop (:for rule styles)
(:do (loop (:for s (avalonia-styles rule))
(:do (.Add (app-styles current-app) s)))))
(def w (Window.)) (def w (Window.))
(window-title! w title) (window-title! w title)
(ignore (set-value (cast AvaloniaObject w) (cast AvaloniaProperty width-property) (ignore (set-value (cast AvaloniaObject w) (cast AvaloniaProperty width-property)
@ -1468,24 +997,7 @@
(with-cancel (cancel) (with-cancel (cancel)
(def app (start-app init gui-update view (def app (start-app init gui-update view
(fun (c) (window-content! (cast ContentControl w) (cast Object c))) (fun (c) (window-content! (cast ContentControl w) (cast Object c)))
#:subscriptions subscriptions #:keys keys #:theme theme)) #:subscriptions subscriptions))
;; With `#:on-close`, closing the window is a message. The program closes
;; it with `quit`, which closes it by program, and that is not asked.
(match on-close
((Some msg)
(ignore (add-event-handler! w "Closing"
(: (fun (sender e)
(unless (programmatic? (cast ClosingArgs e))
(cancel-close! (cast CancelArgs e) #t)
(app-dispatch! app msg)))
(-> Object Object void)))))
(None unit))
;; 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) (main-window! lifetime w)
(unless (string-empty? screenshot) (unless (string-empty? screenshot)
(screenshot-later! lifetime w width height screenshot)) (screenshot-later! lifetime w width height screenshot))

408
src/dialogs.bjo
View file

@ -1,408 +0,0 @@
;; 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/dialogs.bjo — the module (bjogui dialogs).
;;
;; Dialogs, file pickers and quitting, as commands: each is an `(Event %m)`
;; that `gui-update` returns, and the answer comes back as a message.
;;
;; (Delete (next m (confirm "Delete it?" Deleted?)))
;; ((Deleted? #t) (next (remove m)))
;;
;; A dialog is a window, which only the UI thread may make, and a command is
;; synced in a fiber. So each one is a `guard`: when the fiber syncs it, a
;; fiber of its own asks the UI thread to show the dialog, and waits for the
;; Task that the dialog gives back.
;;
;; A dialog needs a window to belong to. With none, as in a test that runs an
;; app with `start-app`, each answers as if it was cancelled: `confirm` #f,
;; `prompt` and the pickers None or nothing.
(export
alert confirm prompt
open-file open-files save-file open-folder
quit)
(import (std prelude))
(import (std interop))
(import/class
(Object (: System.Object))
(DispatcherOpBase (: Avalonia.Threading.DispatcherOperation))
(ClrType (: System.Type))
(PropertyInfo (: System.Reflection.PropertyInfo))
(ClrString (: System.String))
((ReadOnlyList %a) (: System.Collections.Generic.IReadOnlyList))
((EventHandler %a) (: System.EventHandler))
(Application (: Avalonia.Application))
(ILifetime (: Avalonia.Controls.ApplicationLifetimes.IApplicationLifetime))
(Lifetime (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime))
(Dispatcher (: Avalonia.Threading.Dispatcher))
((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation))
(AvaloniaObject (: Avalonia.AvaloniaObject))
(AvaloniaProperty (: Avalonia.AvaloniaProperty))
(Priority (: Avalonia.Data.BindingPriority))
(Disposable (: System.IDisposable))
(Thickness (: Avalonia.Thickness (-> double Thickness)))
(Orientation (: Avalonia.Layout.Orientation))
(HAlignment (: Avalonia.Layout.HorizontalAlignment))
(TextWrapping (: Avalonia.Media.TextWrapping))
(SizeToContent (: Avalonia.Controls.SizeToContent))
(StartupLocation (: Avalonia.Controls.WindowStartupLocation))
(Control (: Avalonia.Controls.Control))
(Controls (: Avalonia.Controls.Controls))
(Panel (: Avalonia.Controls.Panel))
(StackPanel (: Avalonia.Controls.StackPanel (-> StackPanel)))
(TextBlock (: Avalonia.Controls.TextBlock (-> TextBlock)))
(TextBox (: Avalonia.Controls.TextBox (-> TextBox)))
(Button (: Avalonia.Controls.Button (-> Button)))
(Window (: Avalonia.Controls.Window (-> Window)))
(TopLevel (: Avalonia.Controls.TopLevel))
(Interactive (: Avalonia.Interactivity.Interactive))
(RoutedEvent (: Avalonia.Interactivity.RoutedEvent))
(RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs))
(Routes (: Avalonia.Interactivity.RoutingStrategies))
(StorageProvider (: Avalonia.Platform.Storage.IStorageProvider))
(StorageItem (: Avalonia.Platform.Storage.IStorageItem))
(StorageFile (: Avalonia.Platform.Storage.IStorageFile))
(StorageFolder (: Avalonia.Platform.Storage.IStorageFolder))
(FileType (: Avalonia.Platform.Storage.FilePickerFileType (-> string FileType)))
(PickerOptions (: Avalonia.Platform.Storage.PickerOptions))
(OpenOptions (: Avalonia.Platform.Storage.FilePickerOpenOptions (-> OpenOptions)))
(SaveOptions (: Avalonia.Platform.Storage.FilePickerSaveOptions (-> SaveOptions)))
(FolderOptions (: Avalonia.Platform.Storage.FolderPickerOpenOptions (-> FolderOptions))))
(import/extern
;; The UI thread, and the window a dialog belongs to.
(ui-dispatcher (: Avalonia.Threading.Dispatcher.UIThread #:get))
(ui-post (: Avalonia.Threading.Dispatcher.InvokeAsync (-> Dispatcher (-> Unit) (DispatcherOp Unit))))
;; Runs a function on the UI thread.
(on-ui (: Avalonia.Threading.Dispatcher.InvokeAsync
(-> Dispatcher (-> Unit) (DispatcherOp Unit))))
(op-task (: Avalonia.Threading.DispatcherOperation.GetTask (-> DispatcherOpBase Task)))
;; Waits for Tasks. Avalonia's dialogs take no CancellationToken, so this
;; cannot be cancelled: a cancelled command stops at its next sync, and the
;; dialog stays until it is answered.
(await-tasks (: System.Threading.Tasks.Task.WhenAll (-> (Array Task) void)
#:async #:uncancellable))
;; What a finished Task answers. By reflection, because Bjolang reads no
;; Task's Result: on a Task that is not finished, that would block.
(type-of (: System.Object.GetType (-> Object ClrType)))
(property-of (: System.Type.GetProperty (-> ClrType string PropertyInfo)))
(value-of (: System.Reflection.PropertyInfo.GetValue (-> PropertyInfo Object Object)))
(answered (: System.Threading.Tasks.Task.FromResult (-> %a (Task %a))))
(current-app (: Avalonia.Application.Current #:get))
(app-lifetime (: Avalonia.Application.ApplicationLifetime (-> Application ILifetime) #:get))
(main-window (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.MainWindow
(-> Lifetime Window) #:get))
(shutdown! (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.Shutdown
(-> Lifetime int void)))
(reference=? (: System.Object.ReferenceEquals (-> Object Object bool)))
;; The dialog window.
(set-value (: Avalonia.AvaloniaObject.SetValue
(-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
(title-property (: Avalonia.Controls.Window.TitleProperty #:get))
(size-to-content-property (: Avalonia.Controls.Window.SizeToContentProperty #:get))
(startup-location-property (: Avalonia.Controls.Window.WindowStartupLocationProperty #:get))
(can-resize-property (: Avalonia.Controls.Window.CanResizeProperty #:get))
(show-in-taskbar-property (: Avalonia.Controls.Window.ShowInTaskbarProperty #:get))
(content-property (: Avalonia.Controls.ContentControl.ContentProperty #:get))
(margin-property (: Avalonia.Layout.Layoutable.MarginProperty #:get))
(max-width-property (: Avalonia.Layout.Layoutable.MaxWidthProperty #:get))
(min-width-property (: Avalonia.Layout.Layoutable.MinWidthProperty #:get))
(halign-property (: Avalonia.Layout.Layoutable.HorizontalAlignmentProperty #:get))
(spacing-property (: Avalonia.Controls.StackPanel.SpacingProperty #:get))
(orientation-property (: Avalonia.Controls.StackPanel.OrientationProperty #:get))
(text-property (: Avalonia.Controls.TextBlock.TextProperty #:get))
(wrapping-property (: Avalonia.Controls.TextBlock.TextWrappingProperty #:get))
(box-text-property (: Avalonia.Controls.TextBox.TextProperty #:get))
(is-default-property (: Avalonia.Controls.Button.IsDefaultProperty #:get))
(is-cancel-property (: Avalonia.Controls.Button.IsCancelProperty #:get))
(click-event (: Avalonia.Controls.Button.ClickEvent #:get))
(add-handler (: Avalonia.Interactivity.Interactive.AddHandler
(-> Interactive RoutedEvent Delegate Routes bool void)))
(children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get))
(box-text (: Avalonia.Controls.TextBox.Text (-> TextBox ClrString) #:get))
(close-with! (: Avalonia.Controls.Window.Close (-> Window Object void)))
(show-dialog (: Avalonia.Controls.Window.ShowDialog (-> Window Window (Task Object))))
(clr-string (: System.Convert.ToString (-> string ClrString)))
;; The pickers.
(storage-provider (: Avalonia.Controls.TopLevel.StorageProvider (-> TopLevel StorageProvider) #:get))
(pick-files (: Avalonia.Platform.Storage.IStorageProvider.OpenFilePickerAsync
(-> StorageProvider OpenOptions (Task (ReadOnlyList StorageFile)))))
(pick-save (: Avalonia.Platform.Storage.IStorageProvider.SaveFilePickerAsync
(-> StorageProvider SaveOptions (Task StorageFile))))
(pick-folders (: Avalonia.Platform.Storage.IStorageProvider.OpenFolderPickerAsync
(-> StorageProvider FolderOptions (Task (ReadOnlyList StorageFolder)))))
(local-path (: Avalonia.Platform.Storage.StorageProviderExtensions.TryGetLocalPath (-> StorageItem string)))
(title! (: Avalonia.Platform.Storage.PickerOptions.Title (-> PickerOptions string void) #:set))
(allow-multiple! (: Avalonia.Platform.Storage.FilePickerOpenOptions.AllowMultiple (-> OpenOptions bool void) #:set))
(file-types! (: Avalonia.Platform.Storage.FilePickerOpenOptions.FileTypeFilter
(-> OpenOptions (ReadOnlyList FileType) void) #:set))
(suggested-name! (: Avalonia.Platform.Storage.FilePickerSaveOptions.SuggestedFileName
(-> SaveOptions string void) #:set))
(patterns! (: Avalonia.Platform.Storage.FilePickerFileType.Patterns
(-> FileType (ReadOnlyList ClrString) void) #:set)))
;; ---------------------------------------------------------------------------
;; The UI thread
;; ---------------------------------------------------------------------------
(: (-> Object bool))
(defun (null? x) (reference=? x (clr-default)))
;; The app's main window, if there is an app with one.
(: (-> (Option Window)))
(defun (owner)
(def app (cast Object current-app))
(if (null? app)
None
(match (try (cast Lifetime (app-lifetime (cast Application app)))
#:catch (System.InvalidCastException System.NullReferenceException))
((Ok lifetime)
(def w (main-window lifetime))
(if (null? (cast Object w)) None (Some w)))
((Err _) None))))
;; Runs `start` on the UI thread with the main window, and waits for the
;; Task it makes. `none` is the answer when there is no window.
(: (-bjo-> (-> Window (Task %a)) %a %a))
(defbjo (run-on-ui start none)
(def/mutable task (: (clr-default) Task))
(def op (on-ui ui-dispatcher
(fun ()
(set! task (cast Task (cast Object (match (owner)
((Some w) (start w))
(None (answered none))))))
unit)))
(await-tasks #[(op-task (cast DispatcherOpBase (cast Object op)))])
(await-tasks #[task])
(cast %a (value-of (property-of (type-of (cast Object task)) "Result") (cast Object task))))
;; The event of what the Task that `start` makes answers, at each sync.
;; `none` is the answer when there is no window, or the Task fails.
(: (-> (-> Window (Task %a)) %a (Event %a)))
(defun (ask start none)
(guard (fun ()
(wrap (promise-join (bjo (run-on-ui start none)))
(fun (r) (match r
((Ok x) x)
((Err _) none)))))))
;; None for null.
(: (-> Object (Option Object)))
(defun (non-null o) (if (null? o) None (Some o)))
;; ---------------------------------------------------------------------------
;; Message boxes
;; ---------------------------------------------------------------------------
(: (-> AvaloniaObject AvaloniaProperty Object void))
(defun (put! o property value)
(ignore (set-value o property value Priority.LocalValue)))
(: (-> Control (-> void) void))
(defun (on-click! button f)
(add-handler (cast Interactive button) (cast RoutedEvent click-event)
(cast Delegate (cast Object (: (as-delegate (: (fun (s e) (f)) (-> Object RoutedEventArgs void)))
(EventHandler RoutedEventArgs))))
Routes.Bubble #f))
;; A button of a dialog: its label, what the dialog answers when it is
;; clicked, from its text input, and whether Enter or Escape clicks it.
(type (: Choice (Record (: label string) (: answer (-> TextBox Object)) (: enter bool) (: escape bool))))
;; Shows a dialog with `text`, a text input holding `value` if there is one,
;; and the buttons of `choices`, and answers the Task of what it closes with.
(: (-> string string (Option string) (List Choice) Window (Task Object)))
(defun (show-box! title text value choices owner)
(def w (Window.))
(def o (cast AvaloniaObject w))
(put! o (cast AvaloniaProperty title-property) (cast Object (clr-string title)))
(put! o (cast AvaloniaProperty size-to-content-property) (cast Object SizeToContent.WidthAndHeight))
(put! o (cast AvaloniaProperty startup-location-property) (cast Object StartupLocation.CenterOwner))
(put! o (cast AvaloniaProperty can-resize-property) (cast Object #f))
(put! o (cast AvaloniaProperty show-in-taskbar-property) (cast Object #f))
(def panel (StackPanel.))
(put! (cast AvaloniaObject panel) (cast AvaloniaProperty margin-property) (cast Object (Thickness. 20.0)))
(put! (cast AvaloniaObject panel) (cast AvaloniaProperty spacing-property) (cast Object 14.0))
(put! (cast AvaloniaObject panel) (cast AvaloniaProperty min-width-property) (cast Object 280.0))
(def label (TextBlock.))
(put! (cast AvaloniaObject label) (cast AvaloniaProperty text-property) (cast Object (clr-string text)))
(put! (cast AvaloniaObject label) (cast AvaloniaProperty wrapping-property) (cast Object TextWrapping.Wrap))
(put! (cast AvaloniaObject label) (cast AvaloniaProperty max-width-property) (cast Object 400.0))
(.Add (children (cast Panel panel)) (cast Control label))
(def input (TextBox.))
(match value
((Some v)
(put! (cast AvaloniaObject input) (cast AvaloniaProperty box-text-property) (cast Object (clr-string v)))
(.Add (children (cast Panel panel)) (cast Control input)))
(None unit))
(def buttons (StackPanel.))
(put! (cast AvaloniaObject buttons) (cast AvaloniaProperty orientation-property) (cast Object Orientation.Horizontal))
(put! (cast AvaloniaObject buttons) (cast AvaloniaProperty spacing-property) (cast Object 8.0))
(put! (cast AvaloniaObject buttons) (cast AvaloniaProperty halign-property) (cast Object HAlignment.Right))
(loop (:for c choices)
(:do (def b (Button.))
(put! (cast AvaloniaObject b) (cast AvaloniaProperty content-property) (cast Object (clr-string (.label c))))
(put! (cast AvaloniaObject b) (cast AvaloniaProperty is-default-property) (cast Object (.enter c)))
(put! (cast AvaloniaObject b) (cast AvaloniaProperty is-cancel-property) (cast Object (.escape c)))
(on-click! (cast Control b) (fun () (close-with! w ((.answer c) input))))
(.Add (children (cast Panel buttons)) (cast Control b))))
(.Add (children (cast Panel panel)) (cast Control buttons))
(put! o (cast AvaloniaProperty content-property) (cast Object panel))
(show-dialog w owner))
(: (-> string (-> TextBox Object) bool bool Choice))
(defun (choice label answer enter escape)
(Choice (label label) (answer answer) (enter enter) (escape escape)))
;; A message, and an OK button. Sends `msg` when it is closed.
(: alert (-> string %m (#:title string) (Event %m)))
(defun (alert text msg #:title "")
(wrap (ask (fun (w) (show-box! title text None
(list (choice "OK" (fun (i) (clr-default)) #t #t)) w))
(clr-default))
(fun (_) msg)))
;; A question, with OK and Cancel. Sends `(on-answer #t)` for OK, and
;; `(on-answer #f)` for Cancel, Escape or a closed window.
(: confirm (-> string (-> bool %m) (#:title string) (#:ok string) (#:cancel string) (Event %m)))
(defun (confirm text on-answer #:title "" #:ok "OK" #:cancel "Cancel")
(wrap (ask (fun (w) (show-box! title text None
(list (choice cancel (fun (i) (cast Object #f)) #f #t)
(choice ok (fun (i) (cast Object #t)) #t #f))
w))
(clr-default))
(fun (answer)
(on-answer (match (non-null answer) ((Some o) (.Equals o (cast Object #t))) (None #f))))))
;; A question with a text input holding `#:value`. Sends `(on-answer (Some
;; text))` for OK, and `(on-answer None)` for Cancel, Escape or a closed
;; window.
(: prompt (-> string (-> (Option string) %m) (#:value string) (#:title string) (Event %m)))
(defun (prompt text on-answer #:value "" #:title "")
(wrap (ask (fun (w) (show-box! title text (Some value)
(list (choice "Cancel" (fun (i) (clr-default)) #f #t)
(choice "OK" (fun (i) (cast Object (box-text i))) #t #f))
w))
(clr-default))
(fun (answer)
(on-answer (match (non-null answer) ((Some o) (Some (.ToString o))) (None None))))))
;; ---------------------------------------------------------------------------
;; Files
;; ---------------------------------------------------------------------------
;; The local paths of the items. A list of Avalonia's is walked as a Seq.
(: (-> (ReadOnlyList StorageItem) (List string)))
(defun (paths items)
(loop (:for item (cast (Seq StorageItem) (cast Object items)))
(:let p (local-path item))
(:when (not (string-empty? p)))
(:acc out (listing p))
=> out))
(: (-> (List string) (Array ClrString)))
(defun (clr-strings xs)
(vec->array (list->vec (list-map (fun (s) (clr-string s)) xs))))
(: (-> (List (Tuple string (List string))) (ReadOnlyList FileType)))
(defun (file-types filters)
(def types
(list-map (fun (f)
(def t (FileType. (fst f)))
(patterns! t (cast (ReadOnlyList ClrString) (cast Object (clr-strings (snd f)))))
t)
filters))
(cast (ReadOnlyList FileType) (cast Object (vec->array (list->vec types)))))
(: (-> (ReadOnlyList StorageFile)))
(defun (no-files)
(cast (ReadOnlyList StorageFile) (cast Object (: (make-array 0) (Array StorageFile)))))
(: (-> string (List (Tuple string (List string))) bool (Event (List string))))
(defun (ask-files title filters many?)
(wrap (ask (fun (w)
(def options (OpenOptions.))
(unless (string-empty? title) (title! (cast PickerOptions options) title))
(allow-multiple! options many?)
(unless (list-empty? filters) (file-types! options (file-types filters)))
(pick-files (storage-provider (cast TopLevel w)) options))
(no-files))
(fun (files) (paths (cast (ReadOnlyList StorageItem) (cast Object files))))))
(: (-> (List string) (Option string)))
(defun (first-path ps)
(match ps ((List p rest ...) (Some p)) (_ None)))
;; Asks for a file to open. Sends `(on-answer (Some path))`, or `(on-answer
;; None)` when the picker is cancelled. `#:filters` are the kinds of file it
;; shows, each a name and patterns: `(list (Tuple "Text" '("*.txt" "*.md")))`.
(: open-file (-> (-> (Option string) %m) (#:title string)
(#:filters (List (Tuple string (List string)))) (Event %m)))
(defun (open-file on-answer #:title "" #:filters '())
(wrap (ask-files title filters #f) (fun (ps) (on-answer (first-path ps)))))
;; Asks for files to open. Sends `(on-answer paths)`, empty when the picker
;; is cancelled.
(: open-files (-> (-> (List string) %m) (#:title string)
(#:filters (List (Tuple string (List string)))) (Event %m)))
(defun (open-files on-answer #:title "" #:filters '())
(wrap (ask-files title filters #t) on-answer))
;; Asks where to save a file. Sends `(on-answer (Some path))`, or `(on-answer
;; None)` when the picker is cancelled. The file is not made.
(: save-file (-> (-> (Option string) %m) (#:title string) (#:name string) (Event %m)))
(defun (save-file on-answer #:title "" #:name "")
(wrap (ask (fun (w)
(def options (SaveOptions.))
(unless (string-empty? title) (title! (cast PickerOptions options) title))
(unless (string-empty? name) (suggested-name! options name))
(pick-save (storage-provider (cast TopLevel w)) options))
(: (clr-default) StorageFile))
(fun (f)
(on-answer (if (null? (cast Object f))
None
(match (local-path (cast StorageItem f))
("" None)
(p (Some p))))))))
;; Asks for a folder. Sends `(on-answer (Some path))`, or `(on-answer None)`
;; when the picker is cancelled.
(: open-folder (-> (-> (Option string) %m) (#:title string) (Event %m)))
(defun (open-folder on-answer #:title "")
(wrap (ask (fun (w)
(def options (FolderOptions.))
(unless (string-empty? title) (title! (cast PickerOptions options) title))
(pick-folders (storage-provider (cast TopLevel w)) options))
(cast (ReadOnlyList StorageFolder) (cast Object (: (make-array 0) (Array StorageFolder)))))
(fun (folders) (on-answer (first-path (paths (cast (ReadOnlyList StorageItem) (cast Object folders))))))))
;; ---------------------------------------------------------------------------
;; Quitting
;; ---------------------------------------------------------------------------
;; Closes the app's windows, and so ends `run-app`. Sends nothing. This is how
;; a program closes after it was asked with `#:on-close`.
(: quit (-> (Event %m)))
(defun (quit)
(guard (fun ()
(ignore (ui-post ui-dispatcher
(fun ()
(def app (cast Object current-app))
(unless (null? app)
(match (try (cast Lifetime (app-lifetime (cast Application app)))
#:catch (System.InvalidCastException
System.NullReferenceException))
((Ok lifetime) (shutdown! lifetime 0))
((Err _) unit)))
unit)))
(never))))

329
src/view.bjo
View file

@ -20,15 +20,9 @@
;; Constructors. ;; 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
list-box tabs tab list-box tabs tab
menu-bar submenu menu-item menu-separator column row grid scroll border
toggle-switch radio number-input date-picker auto-complete expander
tree-view tree-node
column row grid scroll border flow dock
;; Wrappers. ;; Wrappers.
keyed at paint with-context-menu tooltip at-top at-bottom at-left at-right classed keyed at paint
;; Keyboard shortcuts.
Key key key-gesture key-message
;; Reading one. ;; Reading one.
view-kind view-props view-events view-children view-key) view-kind view-props view-events view-children view-key)
@ -43,58 +37,47 @@
(type (: Kind (Union TextKind ButtonKind TextInputKind TextAreaKind CheckBoxKind (type (: Kind (Union TextKind ButtonKind TextInputKind TextAreaKind CheckBoxKind
SliderKind ProgressKind DropdownKind ImageKind SliderKind ProgressKind DropdownKind ImageKind
ListBoxKind TabsKind TabKind ListBoxKind TabsKind TabKind
MenuBarKind MenuItemKind SeparatorKind ContextKind ContextMenuKind
ToggleSwitchKind RadioKind NumberKind DateKind AutoCompleteKind
ExpanderKind WrapKind DockKind TreeKind TreeNodeKind
ColumnKind RowKind GridKind ScrollKind BorderKind))) ColumnKind RowKind GridKind ScrollKind BorderKind)))
;; A property of a control. A kind takes only some of them; the app ignores ;; A property of a control. A kind takes only some of them; the app ignores
;; the others. ;; the others.
(type (: Prop (Union (: PropLabel string) ; the text of a text, a button or a checkbox (type (: Prop (Union (: Label string) ; the text of a text, a button or a checkbox
(: PropValue string) ; the text in a text input (: Value string) ; the text in a text input
(: PropPlaceholder string) ; shown in an empty text input (: Placeholder string) ; shown in an empty text input
(: PropChecked bool) (: Checked bool)
(: PropEnabled bool) (: Enabled bool)
(: PropFontSize double) (: FontSize double)
(: PropWidth double) (: Width double)
(: PropHeight double) (: Height double)
(: PropMargin double) (: Margin double)
(: PropPadding double) (: Padding double)
(: PropSpacing double) (: Spacing double)
(: PropWrap bool) ; a text breaks its lines at the width (: Wrap bool) ; a text breaks its lines at the width
(: PropMinimum double) ; of a slider or a progress bar (: Minimum double) ; of a slider or a progress bar
(: PropMaximum double) (: Maximum double)
(: PropAmount double) ; where a slider or a progress bar is (: Amount double) ; where a slider or a progress bar is
(: PropStep double) ; what an arrow key moves a slider by (: Step double) ; what an arrow key moves a slider by
(: PropItems (Vec string)) ; what a dropdown offers (: Items (Vec string)) ; what a dropdown offers
(: PropSelected int) ; which item is chosen; -1 for none (: Selected int) ; which item is chosen; -1 for none
(: PropSource string) ; the file an image shows (: Source string) ; the file an image shows
(: PropColumns string) ; a grid's columns, as "Auto,*,2*" (: Columns string) ; a grid's columns, as "Auto,*,2*"
(: PropRows string) (: Rows string)
(: PropRow int) ; where a view is in its grid (: Row int) ; where a view is in its grid
(: PropColumn int) (: Column int)
(: PropRowSpan int) (: RowSpan int)
(: PropColumnSpan int) (: ColumnSpan int)
(: PropBackground string) ; a colour: "red", "#08f", "#80ff8800" (: Background string) ; a colour: "red", "#08f", "#80ff8800"
(: PropForeground string) ; the colour of the text (: Foreground string) ; the colour of the text
(: PropBorderColour string) (: BorderColour string)
(: PropBorderWidth double) (: BorderWidth double)
(: PropRadius double) ; how round a border's corners are (: Radius double)))) ; how round a border's corners are
(: PropShortcut string) ; a menu item's keys, as "Ctrl+S"
(: PropTip string) ; shown when the pointer rests on a view
(: PropExpanded bool) ; whether an expander shows its content
(: PropDate string) ; a date picker's date, as "2026-10-25"
(: PropDockSide int) ; where a view is in its dock: 0 to 3
(: PropClasses (Vec string)) ; the classes that styles match
(: PropChosenKey string)))) ; the key of a tree's chosen node
;; An event, and the message it sends. ;; An event, and the message it sends.
(type (: (On %m) (Union (: OnClick %m) (type (: (On %m) (Union (: Click %m)
(: OnInput (-> string %m)) (: Input (-> string %m))
(: OnToggle (-> bool %m)) (: Toggle (-> bool %m))
(: OnSlide (-> double %m)) (: Slide (-> double %m))
(: OnSelect (-> int %m)) (: Select (-> int %m)))))
(: OnPick (-> string %m)))))
;; One control and what is in it. ;; One control and what is in it.
;; ;;
@ -139,49 +122,14 @@
(: paint (-> (View %m) (#:colour string) (#:background string) (View %m))) (: paint (-> (View %m) (#:colour string) (#:background string) (View %m)))
(defun (paint v #:colour "" #:background "") (defun (paint v #:colour "" #:background "")
(defun (with props make c) (if (string-empty? c) props (vec-add props (make c)))) (defun (with props make c) (if (string-empty? c) props (vec-add props (make c))))
(record-set v (props (with (with (.props v) PropForeground colour) PropBackground background)))) (record-set v (props (with (with (.props v) Foreground colour) Background background))))
;; The view, with a menu that opens when it is clicked with the right button.
;; The items are made by `menu-item`, `submenu` and `menu-separator`.
(: with-context-menu (-> (View %m) #:rest (View %m) (View %m)))
(defun (with-context-menu v #:rest items)
(container ContextKind [] [v (container ContextMenuKind [] (array->vec items))]))
;; The view, in the classes `names`, which the styles given to `run-app`
;; match with `#:class`.
(: classed (-> (View %m) #:rest string (View %m)))
(defun (classed v #:rest names)
(record-set v (props (vec-add (.props v) (PropClasses (array->vec names))))))
;; The view, with `text` shown when the pointer rests on it.
(: tooltip (-> (View %m) string (View %m)))
(defun (tooltip v text)
(record-set v (props (vec-add (.props v) (PropTip text)))))
(: (-> int (View %m) (View %m)))
(defun (docked side v)
(record-set v (props (vec-add (.props v) (PropDockSide side)))))
;; The view, at an edge of its dock. The last child of a dock that is put at
;; no edge fills what is left.
(: at-left (-> (View %m) (View %m)))
(defun (at-left v) (docked 0 v))
(: at-top (-> (View %m) (View %m)))
(defun (at-top v) (docked 1 v))
(: at-right (-> (View %m) (View %m)))
(defun (at-right v) (docked 2 v))
(: at-bottom (-> (View %m) (View %m)))
(defun (at-bottom v) (docked 3 v))
;; The view, in a cell of its grid. Rows and columns count from 0. ;; The view, in a cell of its grid. Rows and columns count from 0.
(: at (-> int int (View %m) (#:row-span int) (#:column-span int) (View %m))) (: at (-> int int (View %m) (#:row-span int) (#:column-span int) (View %m)))
(defun (at row column v #:row-span 1 #:column-span 1) (defun (at row column v #:row-span 1 #:column-span 1)
(record-set v (props (vec-add (vec-add (vec-add (vec-add (.props v) (PropRow row)) (PropColumn column)) (record-set v (props (vec-add (vec-add (vec-add (vec-add (.props v) (Row row)) (Column column))
(PropRowSpan row-span)) (RowSpan row-span))
(PropColumnSpan column-span))))) (ColumnSpan column-span)))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Constructors ;; Constructors
@ -196,9 +144,9 @@
(: (-> (Vec Prop) double double double double (Vec Prop))) (: (-> (Vec Prop) double double double double (Vec Prop)))
(defun (with-layout props width height margin padding) (defun (with-layout props width height margin padding)
(with-size (with-size (with-size (with-size props PropWidth width) PropHeight height) (with-size (with-size (with-size (with-size props Width width) Height height)
PropMargin margin) Margin margin)
PropPadding padding)) Padding padding))
(: (-> Kind (Vec Prop) (Vec (On %m)) (View %m))) (: (-> Kind (Vec Prop) (Vec (On %m)) (View %m)))
(defun (leaf kind props events) (defun (leaf kind props events)
@ -210,7 +158,7 @@
(View %m))) (View %m)))
(defun (text s #:size 0.0 #:wrap #f #:width 0.0 #:height 0.0 #:margin 0.0) (defun (text s #:size 0.0 #:wrap #f #:width 0.0 #:height 0.0 #:margin 0.0)
(leaf TextKind (leaf TextKind
(with-layout (with-size [(PropLabel s) (PropWrap wrap)] PropFontSize size) width height margin 0.0) (with-layout (with-size [(Label s) (Wrap wrap)] FontSize size) width height margin 0.0)
[])) []))
;; A button that sends `msg` when it is clicked. ;; A button that sends `msg` when it is clicked.
@ -219,8 +167,8 @@
(View %m))) (View %m)))
(defun (button label msg #:enabled #t #:width 0.0 #:height 0.0 #:margin 0.0 #:padding 0.0) (defun (button label msg #:enabled #t #:width 0.0 #:height 0.0 #:margin 0.0 #:padding 0.0)
(leaf ButtonKind (leaf ButtonKind
(with-layout [(PropLabel label) (PropEnabled enabled)] width height margin padding) (with-layout [(Label label) (Enabled enabled)] width height margin padding)
[(OnClick msg)])) [(Click msg)]))
;; A one-line text input that holds `value`. Each change sends `(on-input ;; A one-line text input that holds `value`. Each change sends `(on-input
;; text)`, with the whole text. ;; text)`, with the whole text.
@ -229,9 +177,9 @@
(View %m))) (View %m)))
(defun (text-input value on-input #:placeholder "" #:enabled #t #:width 0.0 #:margin 0.0) (defun (text-input value on-input #:placeholder "" #:enabled #t #:width 0.0 #:margin 0.0)
(leaf TextInputKind (leaf TextInputKind
(with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)] (with-layout [(Value value) (Placeholder placeholder) (Enabled enabled)]
width 0.0 margin 0.0) width 0.0 margin 0.0)
[(OnInput on-input)])) [(Input on-input)]))
;; A text input of several lines, that breaks its lines at its width. Each ;; A text input of several lines, that breaks its lines at its width. Each
;; change sends `(on-input text)`, with the whole text. ;; change sends `(on-input text)`, with the whole text.
@ -241,9 +189,9 @@
(defun (text-area value on-input #:placeholder "" #:enabled #t #:width 0.0 #:height 0.0 (defun (text-area value on-input #:placeholder "" #:enabled #t #:width 0.0 #:height 0.0
#:margin 0.0) #:margin 0.0)
(leaf TextAreaKind (leaf TextAreaKind
(with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)] (with-layout [(Value value) (Placeholder placeholder) (Enabled enabled)]
width height margin 0.0) width height margin 0.0)
[(OnInput on-input)])) [(Input on-input)]))
;; A slider at `value`, from `minimum` to `maximum`. A move sends `(on-change ;; A slider at `value`, from `minimum` to `maximum`. A move sends `(on-change
;; value)`. ;; value)`.
@ -255,17 +203,17 @@
;; The bounds come before the value, because a value outside the bounds ;; The bounds come before the value, because a value outside the bounds
;; that are there is moved inside them. ;; that are there is moved inside them.
(leaf SliderKind (leaf SliderKind
(with-layout [(PropMinimum minimum) (PropMaximum maximum) (PropAmount value) (PropStep step) (with-layout [(Minimum minimum) (Maximum maximum) (Amount value) (Step step)
(PropEnabled enabled)] (Enabled enabled)]
width 0.0 margin 0.0) width 0.0 margin 0.0)
[(OnSlide on-change)])) [(Slide on-change)]))
;; A bar that is `value` of the way from 0 to `#:maximum`, 1 unless told ;; A bar that is `value` of the way from 0 to `#:maximum`, 1 unless told
;; otherwise. ;; otherwise.
(: (-> double (#:maximum double) (#:width double) (#:margin double) (View %m))) (: (-> double (#:maximum double) (#:width double) (#:margin double) (View %m)))
(defun (progress-bar value #:maximum 1.0 #:width 0.0 #:margin 0.0) (defun (progress-bar value #:maximum 1.0 #:width 0.0 #:margin 0.0)
(leaf ProgressKind (leaf ProgressKind
(with-layout [(PropMinimum 0.0) (PropMaximum maximum) (PropAmount value)] width 0.0 margin 0.0) (with-layout [(Minimum 0.0) (Maximum maximum) (Amount value)] width 0.0 margin 0.0)
[])) []))
;; A list to choose one of `options` from, with the one at `selected` chosen, ;; A list to choose one of `options` from, with the one at `selected` chosen,
@ -276,15 +224,15 @@
;; The items come before the choice, because the choice is an index into ;; The items come before the choice, because the choice is an index into
;; them. ;; them.
(leaf DropdownKind (leaf DropdownKind
(with-layout [(PropItems options) (PropSelected selected) (PropEnabled enabled)] (with-layout [(Items options) (Selected selected) (Enabled enabled)]
width 0.0 margin 0.0) width 0.0 margin 0.0)
[(OnSelect on-select)])) [(Select on-select)]))
;; The picture in the file at `path`. A file that cannot be read shows ;; The picture in the file at `path`. A file that cannot be read shows
;; nothing. ;; nothing.
(: (-> string (#:width double) (#:height double) (#:margin double) (View %m))) (: (-> string (#:width double) (#:height double) (#:margin double) (View %m)))
(defun (image path #:width 0.0 #:height 0.0 #:margin 0.0) (defun (image path #:width 0.0 #:height 0.0 #:margin 0.0)
(leaf ImageKind (with-layout [(PropSource path)] width height margin 0.0) [])) (leaf ImageKind (with-layout [(Source path)] width height margin 0.0) []))
;; A list of views to choose one of, with the one at `selected` chosen, or ;; 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 ;; none for -1. A choice sends `(on-select index)`. Give the items keys if
@ -293,8 +241,8 @@
(View %m))) (View %m)))
(defun (list-box items selected on-select #:width 0.0 #:height 0.0 #:margin 0.0) (defun (list-box items selected on-select #:width 0.0 #:height 0.0 #:margin 0.0)
(View (kind ListBoxKind) (View (kind ListBoxKind)
(props (with-layout [(PropSelected selected)] width height margin 0.0)) (props (with-layout [(Selected selected)] width height margin 0.0))
(events [(OnSelect on-select)]) (events [(Select on-select)])
(children items) (children items)
(key None))) (key None)))
@ -303,128 +251,23 @@
(: (-> int (-> int %m) (#:margin double) #:rest (View %m) (View %m))) (: (-> int (-> int %m) (#:margin double) #:rest (View %m) (View %m)))
(defun (tabs selected on-select #:margin 0.0 #:rest tabs) (defun (tabs selected on-select #:margin 0.0 #:rest tabs)
(View (kind TabsKind) (View (kind TabsKind)
(props (with-layout [(PropSelected selected)] 0.0 0.0 margin 0.0)) (props (with-layout [(Selected selected)] 0.0 0.0 margin 0.0))
(events [(OnSelect on-select)]) (events [(Select on-select)])
(children (array->vec tabs)) (children (array->vec tabs))
(key None))) (key None)))
;; A tab of `tabs`: its header, and what it shows when it is chosen. ;; A tab of `tabs`: its header, and what it shows when it is chosen.
(: (-> string (View %m) (View %m))) (: (-> string (View %m) (View %m)))
(defun (tab header content) (defun (tab header content)
(View (kind TabKind) (props [(PropLabel header)]) (events []) (children [content]) (key None))) (View (kind TabKind) (props [(Label header)]) (events []) (children [content]) (key None)))
;; A bar of menus, made by `submenu`, for the top of the window.
(: (-> #:rest (View %m) (View %m)))
(defun (menu-bar #:rest menus)
(container MenuBarKind [] (array->vec menus)))
;; A menu of items, in a menu bar or in another menu.
(: (-> string #:rest (View %m) (View %m)))
(defun (submenu label #:rest items)
(View (kind MenuItemKind) (props [(PropLabel label)]) (events []) (children (array->vec items))
(key None)))
;; An item that sends `msg` when it is chosen. `#:shortcut`, such as
;; "Ctrl+S", is shown beside it, and the keys send `msg` too while the item
;; is in the view and enabled.
(: (-> string %m (#:shortcut string) (#:enabled bool) (View %m)))
(defun (menu-item label msg #:shortcut "" #:enabled #t)
(leaf MenuItemKind
(if (string-empty? shortcut)
[(PropLabel label) (PropEnabled enabled)]
[(PropLabel label) (PropEnabled enabled) (PropShortcut shortcut)])
[(OnClick msg)]))
;; A line between items of a menu.
(: (-> (View %m)))
(defun (menu-separator)
(leaf SeparatorKind [] []))
;; A switch that is on when `on?`. A flip sends `(on-toggle on)`.
(: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m)))
(defun (toggle-switch label on? on-toggle #:enabled #t #:margin 0.0)
(leaf ToggleSwitchKind
(with-layout [(PropLabel label) (PropChecked on?) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
[(OnToggle on-toggle)]))
;; One of a set of choices, chosen when `chosen?`. Choosing it sends `msg`.
;; The model says which is chosen, so give one of a set `#t` and the others
;; `#f`.
(: (-> string bool %m (#:enabled bool) (#:margin double) (View %m)))
(defun (radio label chosen? msg #:enabled #t #:margin 0.0)
(leaf RadioKind
(with-layout [(PropLabel label) (PropChecked chosen?) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
[(OnClick msg)]))
;; A number to type, or to step with arrows by `#:step`. A change sends
;; `(on-change value)`.
(: (-> double (-> double %m) (#:minimum double) (#:maximum double) (#:step double)
(#:enabled bool) (#:width double) (#:margin double)
(View %m)))
(defun (number-input value on-change #:minimum -1e9 #:maximum 1e9 #:step 1.0 #:enabled #t
#:width 0.0 #:margin 0.0)
(leaf NumberKind
(with-layout [(PropMinimum minimum) (PropMaximum maximum) (PropStep step) (PropAmount value)
(PropEnabled enabled)]
width 0.0 margin 0.0)
[(OnSlide on-change)]))
;; A date to pick, as "2026-10-25", or "" for none. A pick sends
;; `(on-change date)`.
(: (-> string (-> string %m) (#:enabled bool) (#:margin double) (View %m)))
(defun (date-picker date on-change #:enabled #t #:margin 0.0)
(leaf DateKind (with-layout [(PropDate date) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
[(OnInput on-change)]))
;; A text input that offers the `options` that match what is typed. Each
;; change sends `(on-input text)`.
(: (-> string (Vec string) (-> string %m) (#:placeholder string) (#:width double)
(#:margin double)
(View %m)))
(defun (auto-complete value options on-input #:placeholder "" #:width 0.0 #:margin 0.0)
(leaf AutoCompleteKind
(with-layout [(PropItems options) (PropValue value) (PropPlaceholder placeholder)] width 0.0 margin 0.0)
[(OnInput on-input)]))
;; A header that shows `child` below it when `expanded?`. A click on the
;; header sends `(on-toggle expanded)`.
(: (-> string bool (-> bool %m) (View %m) (#:margin double) (View %m)))
(defun (expander header expanded? on-toggle child #:margin 0.0)
(View (kind ExpanderKind)
(props (with-layout [(PropLabel header) (PropExpanded expanded?)] 0.0 0.0 margin 0.0))
(events [(OnToggle on-toggle)])
(children [child])
(key None)))
;; A tree of nodes made by `tree-node`, with the node whose key is `chosen`
;; chosen, or none for "". A click on a node sends `(on-pick key)`.
(: (-> string (-> string %m) (#:width double) (#:height double) (#:margin double)
#:rest (View %m) (View %m)))
(defun (tree-view chosen on-pick #:width 0.0 #:height 0.0 #:margin 0.0 #:rest nodes)
(View (kind TreeKind)
(props (with-layout [(PropChosenKey chosen)] width height margin 0.0))
(events [(OnPick on-pick)])
(children (array->vec nodes))
(key None)))
;; A node of a tree, known by `key`, which must be one of its own in the
;; tree. It opens to show `children`, more nodes, and is open at first when
;; `#:expanded`; after that it is opened and closed by the user.
(: (-> string string (#:expanded bool) #:rest (View %m) (View %m)))
(defun (tree-node key header #:expanded #f #:rest children)
(View (kind TreeNodeKind)
(props [(PropLabel header) (PropExpanded expanded)])
(events [])
(children (array->vec children))
(key (Some key))))
;; A checkbox that is `checked?`. A click sends `(on-toggle checked)`, with ;; A checkbox that is `checked?`. A click sends `(on-toggle checked)`, with
;; the new state. ;; the new state.
(: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m))) (: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m)))
(defun (checkbox label checked? on-toggle #:enabled #t #:margin 0.0) (defun (checkbox label checked? on-toggle #:enabled #t #:margin 0.0)
(leaf CheckBoxKind (leaf CheckBoxKind
(with-layout [(PropLabel label) (PropChecked checked?) (PropEnabled enabled)] 0.0 0.0 margin 0.0) (with-layout [(Label label) (Checked checked?) (Enabled enabled)] 0.0 0.0 margin 0.0)
[(OnToggle on-toggle)])) [(Toggle on-toggle)]))
(: (-> Kind (Vec Prop) (Vec (View %m)) (View %m))) (: (-> Kind (Vec Prop) (Vec (View %m)) (View %m)))
(defun (container kind props children) (defun (container kind props children)
@ -432,7 +275,7 @@
(: (-> Kind double double (Array (View %m)) (View %m))) (: (-> Kind double double (Array (View %m)) (View %m)))
(defun (stack kind spacing margin children) (defun (stack kind spacing margin children)
(container kind (with-layout (with-size [] PropSpacing spacing) 0.0 0.0 margin 0.0) (container kind (with-layout (with-size [] Spacing spacing) 0.0 0.0 margin 0.0)
(array->vec children))) (array->vec children)))
;; Views one above the other. ;; Views one above the other.
@ -453,7 +296,7 @@
#:rest (View %m) (View %m))) #:rest (View %m) (View %m)))
(defun (grid #:columns "*" #:rows "*" #:spacing 0.0 #:margin 0.0 #:rest children) (defun (grid #:columns "*" #:rows "*" #:spacing 0.0 #:margin 0.0 #:rest children)
(container GridKind (container GridKind
(with-layout (with-size [(PropColumns columns) (PropRows rows)] PropSpacing spacing) (with-layout (with-size [(Columns columns) (Rows rows)] Spacing spacing)
0.0 0.0 margin 0.0) 0.0 0.0 margin 0.0)
(array->vec children))) (array->vec children)))
@ -468,43 +311,13 @@
(defun (with props make c) (if (string-empty? c) props (vec-add props (make c)))) (defun (with props make c) (if (string-empty? c) props (vec-add props (make c))))
(container BorderKind (container BorderKind
(with (with (with-size (with-size (with-layout [] 0.0 0.0 margin padding) (with (with (with-size (with-size (with-layout [] 0.0 0.0 margin padding)
PropBorderWidth thickness) BorderWidth thickness)
PropRadius radius) Radius radius)
PropBorderColour colour) BorderColour colour)
PropBackground background) Background background)
[child])) [child]))
;; Views side by side, on as many lines as they need.
(: (-> (#:spacing double) (#:margin double) #:rest (View %m) (View %m)))
(defun (flow #:spacing 0.0 #:margin 0.0 #:rest children)
(stack WrapKind spacing margin children))
;; Views at the edges, put there with `at-top`, `at-bottom`, `at-left` and
;; `at-right`, in order from the outside in. The last child, at no edge,
;; fills the middle.
(: (-> (#:margin double) #:rest (View %m) (View %m)))
(defun (dock #:margin 0.0 #:rest children)
(stack DockKind 0.0 margin children))
;; A view that scrolls when it is taller than the space it has. ;; A view that scrolls when it is taller than the space it has.
(: (-> (View %m) (#:width double) (#:height double) (#:margin double) (View %m))) (: (-> (View %m) (#:width double) (#:height double) (#:margin double) (View %m)))
(defun (scroll child #:width 0.0 #:height 0.0 #:margin 0.0) (defun (scroll child #:width 0.0 #:height 0.0 #:margin 0.0)
(container ScrollKind (with-layout [] width height margin 0.0) [child])) (container ScrollKind (with-layout [] width height margin 0.0) [child]))
;; ---------------------------------------------------------------------------
;; Keyboard shortcuts
;; ---------------------------------------------------------------------------
;; Keys, such as "Ctrl+N" or "F5", and the message they send.
(type (: (Key %m) (Record (: gesture string) (: msg %m))))
;; `msg` is sent when `gesture` is pressed in the window, and no control that
;; has the keyboard takes the keys itself.
(: key (-> string %m (Key %m)))
(defun (key gesture msg) (Key (gesture gesture) (msg msg)))
(: key-gesture (-> (Key %m) string))
(defun (key-gesture k) (.gesture k))
(: key-message (-> (Key %m) %m))
(defun (key-message k) (.msg k))

54
tests/dialogs.bjo
View file

@ -1,54 +0,0 @@
;; 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/dialogs.bjo — dialogs and pickers with no window.
;;
;; bjo run tests/dialogs.bjo
;;
;; A dialog needs a window to belong to, and an app started with `start-app`
;; has none. So each answers as if it was cancelled, and that is what this
;; checks: that the command goes to the UI thread and back, and its message
;; comes. A dialog on a screen is looked at by a person.
(import (std prelude))
(import (std simpletest))
(import (bjogui view))
(import (bjogui app))
(import (bjogui dialogs))
(import/extern
(sleep-ms (: System.Threading.Thread.Sleep (-> int void) #:blocking)))
(type (: Msg (Union Ask (: Answer string))))
(: (-> Msg (List string) (Tuple (List string) (List (Event Msg)))))
(defun (gui-update msg answers)
(match msg
(Ask (next answers
(alert "Saved." (Answer "alert"))
(confirm "Delete?" (fun (b) (Answer #"confirm ${b}")))
(prompt "Name?" (fun (s) (Answer #"prompt ${(option-ref-or s "none")}")) #:value "Ada")
(open-file (fun (p) (Answer #"open-file ${(option-ref-or p "none")}")))
(open-files (fun (ps) (Answer #"open-files ${(length ps)}")))
(save-file (fun (p) (Answer #"save-file ${(option-ref-or p "none")}")) #:name "a.txt")
(open-folder (fun (p) (Answer #"open-folder ${(option-ref-or p "none")}")))
(quit)))
((Answer s) (next (cons s answers)))))
(defun (main)
(def app (start-app '() gui-update (fun (m) (text "")) (fun (c) unit)))
(app-dispatch! app Ask)
(let go ((tries 0))
(app-run-pending! app)
(when (and (< (length (app-model app)) 7) (< tries 300))
(sleep-ms 10)
(go (+ tries 1))))
(def answers (list-sort (app-model app)))
(expect "every dialog answered" (length answers) 7)
(expect "the answers with no window"
answers
(list-sort '("alert" "confirm #f" "prompt none" "open-file none" "open-files 0"
"save-file none" "open-folder none")))
(app-stop! app)
(println "bjogui dialogs ok"))

144
tests/inputs.bjo
View file

@ -1,144 +0,0 @@
;; 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/inputs.bjo — switches, radios, numbers, dates, completion,
;; expanders, tooltips, flows and docks.
;;
;; bjo run tests/inputs.bjo
;;
;; No window is opened. A control is changed as a user's input would change
;; it, through its Avalonia property, and the message is checked.
(import (std prelude))
(import (std simpletest))
(import (bjogui view))
(import (bjogui app))
(import/class
(Object (: System.Object))
(ClrString (: System.String))
(Disposable (: System.IDisposable))
(AvaloniaObject (: Avalonia.AvaloniaObject))
(AvaloniaProperty (: Avalonia.AvaloniaProperty))
(Priority (: Avalonia.Data.BindingPriority))
(Control (: Avalonia.Controls.Control))
(Controls (: Avalonia.Controls.Controls))
(Panel (: Avalonia.Controls.Panel))
(ToggleButton (: Avalonia.Controls.Primitives.ToggleButton))
(NumericUpDown (: Avalonia.Controls.NumericUpDown))
(DatePicker (: Avalonia.Controls.DatePicker))
(DateTimeOffset (: System.DateTimeOffset))
(AutoCompleteBox (: Avalonia.Controls.AutoCompleteBox))
(Expander (: Avalonia.Controls.Expander))
(DockEdge (: Avalonia.Controls.Dock))
(StyledElement (: Avalonia.StyledElement))
(Classes (: Avalonia.Controls.Classes))
((Nullable %a) (: System.Nullable)))
(import/extern
(set-value (: Avalonia.AvaloniaObject.SetValue
(-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
(checked-property (: Avalonia.Controls.Primitives.ToggleButton.IsCheckedProperty #:get))
(number-property (: Avalonia.Controls.NumericUpDown.ValueProperty #:get))
(date-property (: Avalonia.Controls.DatePicker.SelectedDateProperty #:get))
(auto-property (: Avalonia.Controls.AutoCompleteBox.TextProperty #:get))
(expanded-property (: Avalonia.Controls.Expander.IsExpandedProperty #:get))
(is-checked (: Avalonia.Controls.Primitives.ToggleButton.IsChecked
(-> ToggleButton (Nullable bool)) #:get))
(number-value (: Avalonia.Controls.NumericUpDown.Value (-> NumericUpDown (Nullable decimal)) #:get))
(selected-date (: Avalonia.Controls.DatePicker.SelectedDate (-> DatePicker (Nullable DateTimeOffset)) #:get))
(parse-date (: System.DateTimeOffset.Parse (-> string DateTimeOffset)))
(expanded? (: Avalonia.Controls.Expander.IsExpanded (-> Expander bool) #:get))
(tip-of (: Avalonia.Controls.ToolTip.GetTip (-> Control Object)))
(dock-of (: Avalonia.Controls.DockPanel.GetDock (-> Control DockEdge)))
(children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get))
(count (: Avalonia.Controls.Controls.Count (-> Controls int) #:get))
(classes-of (: Avalonia.StyledElement.Classes (-> StyledElement Classes) #:get))
(clr-string (: System.Convert.ToString (-> string ClrString))))
(type (: Msg (Union (: Switched bool) (: Picked string) (: Amount double) (: Dated string)
(: Typed string) (: Opened bool))))
(type (: Model (Record (: on bool) (: pick string) (: amount double) (: date string)
(: typed string) (: open bool))))
(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
(next (match msg
((Switched b) (record-set m (on b)))
((Picked s) (record-set m (pick s)))
((Amount d) (record-set m (amount d)))
((Dated s) (record-set m (date s)))
((Typed s) (record-set m (typed s)))
((Opened b) (record-set m (open b))))))
(: (-> Model (View Msg)))
(defun (view m)
(column
(toggle-switch "Wi-Fi" (.on m) Switched) ; 0
(row (radio "tea" (= (.pick m) "tea") (Picked "tea")) ; 1 0
(radio "coffee" (= (.pick m) "coffee") (Picked "coffee"))) ; 1 1
(number-input (.amount m) Amount #:minimum 0.0 #:maximum 10.0 #:step 0.5) ; 2
(date-picker (.date m) Dated) ; 3
(auto-complete (.typed m) ["apple" "apricot" "banana"] Typed) ; 4
(expander "More" (.open m) Opened (text "inside")) ; 5
(tooltip (text "hover me") "a tip") ; 6
(flow #:spacing 4.0 (text "a") (text "b") (text "c")) ; 7
(dock (at-top (text "top")) (text "fill")) ; 8
(if (.open m) (classed (text "c") "wide") (classed (text "c") "big" "red")))) ; 9
(defun (main)
(def app (start-app (Model (on #f) (pick "tea") (amount 2.0) (date "2026-10-25")
(typed "") (open #f))
gui-update view (fun (c) unit)))
(defun (ctl path) (app-control-at app path))
(defun (put! path property value)
(ignore (set-value (cast AvaloniaObject (ctl path)) property value Priority.LocalValue)))
(defun (model) (app-model app))
;; --- switch and radios --------------------------------------------------------
(put! '(0) (cast AvaloniaProperty checked-property) (cast Object #t))
(expect "a switch sends its state" (.on (model)) #t)
(expect "a radio shows the model's choice"
(.GetValueOrDefault (is-checked (cast ToggleButton (ctl '(1 0))))) #t)
(put! '(1 1) (cast AvaloniaProperty checked-property) (cast Object #t))
(expect "choosing a radio sends its message" (.pick (model)) "coffee")
(expect "the other one is not chosen any more"
(.GetValueOrDefault (is-checked (cast ToggleButton (ctl '(1 0))))) #f)
;; --- number ---------------------------------------------------------------------
(expect "a number input's value" (cast System.Double (.GetValueOrDefault (number-value (cast NumericUpDown (ctl '(2)))))) 2.0)
(put! '(2) (cast AvaloniaProperty number-property) (cast Object (cast System.Decimal 3.5)))
(expect "a number sends its value" (.amount (model)) 3.5)
;; --- date -----------------------------------------------------------------------
(expect "a date picker's date" (.ToString (.-Value (selected-date (cast DatePicker (ctl '(3))))) "yyyy-MM-dd")
"2026-10-25")
(put! '(3) (cast AvaloniaProperty date-property) (cast Object (parse-date "2026-12-24")))
(expect "a date picked is sent" (.date (model)) "2026-12-24")
;; --- completion -------------------------------------------------------------------
(put! '(4) (cast AvaloniaProperty auto-property) (cast Object (clr-string "ap")))
(expect "completion sends what is typed" (.typed (model)) "ap")
;; --- expander ---------------------------------------------------------------------
(expect "an expander starts closed" (expanded? (cast Expander (ctl '(5)))) #f)
(put! '(5) (cast AvaloniaProperty expanded-property) (cast Object #t))
(expect "opening it sends a message" (.open (model)) #t)
;; --- tooltip, flow, dock ---------------------------------------------------------
(expect "a tooltip" (.ToString (tip-of (ctl '(6)))) "a tip")
(expect "a flow's children" (count (children (cast Panel (ctl '(7))))) 3)
(expect "a docked child" (written (dock-of (ctl '(8 0)))) "Top")
;; --- classes ---------------------------------------------------------------------
;; The expander was opened above, so the view has "wide" and not the others.
(def cls (classes-of (cast StyledElement (ctl '(9)))))
(defun (has-class? (: c Classes) (: name string)) (.Contains c name))
(expect "a class" (has-class? cls "wide") #t)
(expect "the classes of the last view are gone" (has-class? cls "big") #f)
(put! '(5) (cast AvaloniaProperty expanded-property) (cast Object #f))
(expect "and change with the model" (list (has-class? cls "big") (has-class? cls "red") (has-class? cls "wide"))
'(#t #t #f))
(println "bjogui inputs ok"))

118
tests/menus.bjo
View file

@ -1,118 +0,0 @@
;; 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/menus.bjo — menus, context menus and keyboard shortcuts.
;;
;; bjo run tests/menus.bjo
;;
;; No window is opened. A click is raised on a menu item as Avalonia raises
;; it, and keys are pressed with `app-press!`, which is what the window's
;; handler calls.
(import (std prelude))
(import (std simpletest))
(import (bjogui view))
(import (bjogui app))
(import/class
(Object (: System.Object))
(Control (: Avalonia.Controls.Control))
(Interactive (: Avalonia.Interactivity.Interactive))
(RoutedEvent (: Avalonia.Interactivity.RoutedEvent))
(RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs (-> RoutedEvent RoutedEventArgs)))
(ItemsControl (: Avalonia.Controls.ItemsControl))
(MenuItem (: Avalonia.Controls.MenuItem))
(Headered (: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl))
(KeyGesture (: Avalonia.Input.KeyGesture))
(ContextMenu (: Avalonia.Controls.ContextMenu)))
(import/extern
(menu-click-event (: Avalonia.Controls.MenuItem.ClickEvent #:get))
(raise-event (: Avalonia.Interactivity.Interactive.RaiseEvent (-> Interactive RoutedEventArgs void)))
(item-count (: Avalonia.Controls.ItemsControl.ItemCount (-> ItemsControl int) #:get))
(header (: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl.Header
(-> Headered Object) #:get))
(input-gesture (: Avalonia.Controls.MenuItem.InputGesture (-> MenuItem KeyGesture) #:get))
(context-menu (: Avalonia.Controls.Control.ContextMenu (-> Control ContextMenu) #:get)))
;; ---------------------------------------------------------------------------
;; The program under test
;; ---------------------------------------------------------------------------
(type (: Msg (Union New (: Open string) Quit Copy Refresh AllowQuit)))
(type (: Model (Record (: log (List string)) (: can-quit bool))))
(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
(defun (log s) (record-set m (log (cons s (.log m)))))
(next (match msg
(New (log "new"))
((Open f) (log (string-append "open " f)))
(Quit (log "quit"))
(Copy (log "copy"))
(Refresh (log "refresh"))
(AllowQuit (record-set m (can-quit #t))))))
(: (-> Model (View Msg)))
(defun (view m)
(column
(menu-bar ; 0
(submenu "File" ; 0 0
(menu-item "New" New #:shortcut "Ctrl+N") ; 0 0 0
(menu-separator) ; 0 0 1
(submenu "Recent" ; 0 0 2
(menu-item "notes.txt" (Open "notes.txt"))) ; 0 0 2 0
(menu-item "Quit" Quit #:shortcut "Ctrl+Q" #:enabled (.can-quit m))))
(with-context-menu (text "right click me") ; 1
(menu-item "Copy" Copy #:shortcut "Ctrl+C"))))
(: (-> Model (List (Key Msg))))
(defun (keys m) (list (key "F5" Refresh)))
;; ---------------------------------------------------------------------------
;; The test
;; ---------------------------------------------------------------------------
(defun (main)
(def app (start-app (Model (log '()) (can-quit #f)) gui-update view (fun (c) unit)
#:keys keys))
(defun (ctl path) (app-control-at app path))
(defun (click path)
(raise-event (cast Interactive (ctl path))
(RoutedEventArgs. (cast RoutedEvent menu-click-event))))
(defun (history) (.log (app-model app)))
;; --- the menu bar -------------------------------------------------------------
(expect "one menu" (item-count (cast ItemsControl (ctl '(0)))) 1)
(expect "its items, with the separator" (item-count (cast ItemsControl (ctl '(0 0)))) 4)
(expect "a header" (.ToString (header (cast Headered (ctl '(0 0 0))))) "New")
(expect "a shortcut is shown" (.ToString (cast Object (input-gesture (cast MenuItem (ctl '(0 0 0))))))
"Ctrl+N")
(click '(0 0 0))
(expect "an item chosen is a message" (history) '("new"))
;; The click bubbles through "Recent" and "File"; only the item answers.
(click '(0 0 2 0))
(expect "an item in a submenu, once" (history) '("open notes.txt" "new"))
;; --- the context menu -------------------------------------------------------
(def cm (context-menu (ctl '(1))))
(expect "the context menu is the view's" (eq? (cast Object cm) (cast Object (ctl '(1 1)))) #t)
(expect "its items" (item-count (cast ItemsControl cm)) 1)
(click '(1 1 0))
(expect "a context menu item" (first (history)) (Some "copy"))
;; --- keys -----------------------------------------------------------------------
(expect "a menu item's shortcut" (app-press! app "Ctrl+N") #t)
(expect "sends its message" (first (history)) (Some "new"))
(expect "a context menu's shortcut too" (app-press! app "Ctrl+C") #t)
(expect "a disabled item's shortcut does nothing" (app-press! app "Ctrl+Q") #f)
(app-dispatch! app AllowQuit)
(expect "until it is enabled" (app-press! app "Ctrl+Q") #t)
(expect "the app's own keys" (app-press! app "F5") #t)
(expect "and their message" (first (history)) (Some "refresh"))
(expect "keys bound to nothing" (app-press! app "Ctrl+X") #f)
(expect "keys that cannot be read" (app-press! app "Ctrl+Nope") #f)
(println "bjogui menus ok"))

84
tests/tree.bjo
View file

@ -1,84 +0,0 @@
;; 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/tree.bjo — tree views.
;;
;; bjo run tests/tree.bjo
;;
;; No window is opened.
(import (std prelude))
(import (std simpletest))
(import (std interop))
(import (bjogui view))
(import (bjogui app))
(import/class
(Object (: System.Object))
(Disposable (: System.IDisposable))
(AvaloniaObject (: Avalonia.AvaloniaObject))
(AvaloniaProperty (: Avalonia.AvaloniaProperty))
(Priority (: Avalonia.Data.BindingPriority))
(ItemsControl (: Avalonia.Controls.ItemsControl))
(TreeView (: Avalonia.Controls.TreeView))
(TreeViewItem (: Avalonia.Controls.TreeViewItem))
(Headered (: Avalonia.Controls.Primitives.HeaderedItemsControl)))
(import/extern
(set-value (: Avalonia.AvaloniaObject.SetValue
(-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
(selected-property (: Avalonia.Controls.TreeView.SelectedItemProperty #:get))
(selected (: Avalonia.Controls.TreeView.SelectedItem (-> TreeView Object) #:get))
(item-count (: Avalonia.Controls.ItemsControl.ItemCount (-> ItemsControl int) #:get))
(header (: Avalonia.Controls.Primitives.HeaderedItemsControl.Header (-> Headered Object) #:get))
(expanded? (: Avalonia.Controls.TreeViewItem.IsExpanded (-> TreeViewItem bool) #:get))
(same? (: System.Object.ReferenceEquals (-> Object Object bool))))
(type (: Msg (Union (: Chose string) Reverse)))
(type (: Model (Record (: chosen string) (: fruit (List string)))))
(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
(next (match msg
((Chose k) (record-set m (chosen k)))
(Reverse (record-set m (fruit (list-reverse (.fruit m))))))))
(: (-> Model (View Msg)))
(defun (view m)
(tree-view (.chosen m) Chose
(apply tree-node "fruit" "Fruit" #:expanded #t
(vec->array (vec-map (fun (f) (tree-node f (string-upcase f))) (list->vec (.fruit m)))))
(tree-node "veg" "Vegetables"
(tree-node "kale" "KALE"))))
(defun (main)
(def app (start-app (Model (chosen "pear") (fruit '("apple" "pear")))
gui-update view (fun (c) unit)))
(defun (ctl path) (app-control-at app path))
(def tree (cast TreeView (ctl '())))
(defun (chosen-is? path) (same? (selected tree) (cast Object (ctl path))))
(expect "the top nodes" (item-count (cast ItemsControl tree)) 2)
(expect "a node's nodes" (item-count (cast ItemsControl (ctl '(0)))) 2)
(expect "a header" (.ToString (header (cast Headered (ctl '(0 1))))) "PEAR")
(expect "open at first" (expanded? (cast TreeViewItem (ctl '(0)))) #t)
(expect "closed at first" (expanded? (cast TreeViewItem (ctl '(1)))) #f)
(expect "the chosen node is chosen once the nodes are there" (chosen-is? '(0 1)) #t)
(ignore (set-value (cast AvaloniaObject tree) (cast AvaloniaProperty selected-property)
(cast Object (ctl '(1 0))) Priority.LocalValue))
(expect "a node chosen sends its key" (.chosen (app-model app)) "kale")
(app-dispatch! app (Chose "apple"))
(expect "the model chooses the node" (chosen-is? '(0 0)) #t)
(def apple (ctl '(0 0)))
(app-dispatch! app Reverse)
(expect "nodes moved by key keep their controls" (same? (cast Object (ctl '(0 1))) (cast Object apple)) #t)
(expect "and the choice" (chosen-is? '(0 1)) #t)
(app-dispatch! app (Chose ""))
(expect "no choice" (same? (selected tree) (clr-default)) #t)
(println "bjogui tree ok"))