diff --git a/Readme.org b/Readme.org index 4e468d0..0c2540c 100644 --- a/Readme.org +++ b/Readme.org @@ -68,6 +68,16 @@ being changed, and they are dropped, so only the user's events are messages. | ~(grid #:columns #:rows child ...)~ | ~Grid~ | nothing | | ~(scroll child)~ | ~ScrollViewer~ | 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), ~#:wrap~ (a text breaks its lines at its width), ~#:width~, ~#:height~, @@ -122,6 +132,53 @@ 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 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 ~gui-update~ is a plain function, so it cannot wait, and the compiler says so @@ -159,10 +216,42 @@ The fibers belong to the app. They post their messages to the UI thread, so ~gui-update~ and ~view~ always run there. When the window is closed they are cancelled, and the program ends. +* 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) -- ~(run-app init gui-update view #:subscriptions #:title #:width #:height)~ - opens a window and runs until it is closed. +- ~(run-app init gui-update view #:subscriptions #:keys #:theme #:styles + #:on-close #:title #:width #:height)~ opens a window and runs until it is + closed. - ~#: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 ~BJOGUI_SCREENSHOT~ unless the program says otherwise, so any program can @@ -176,6 +265,7 @@ cancelled, and the program ends. - ~app-run-pending!~ runs what fibers have posted, where no loop of Avalonia's does. - ~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 path of child indices. @@ -196,15 +286,21 @@ bjo run tests/app.bjo # prints "bjogui ok" bjo run tests/effects.bjo # prints "bjogui effects ok" bjo run tests/controls.bjo # prints "bjogui controls 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/stopwatch.bjo bjo run examples/todo.bjo +bjo run examples/styles.bjo #+END_SRC * Not yet -- Menus and dialogs. -- Styles of one's own, with classes, and colours for the pointer-over and - pressed states. +- A data grid, and lists that make controls only for the items on screen. +- Dialogs of one's own, with a view and a state. +- The macOS menu bar. +- Pointer-over and pressed colours for kinds other than buttons. - A moved control is taken out of the panel and put back, so it may lose the keyboard focus. diff --git a/docs/styles.png b/docs/styles.png new file mode 100644 index 0000000..b8127f8 Binary files /dev/null and b/docs/styles.png differ diff --git a/examples/styles.bjo b/examples/styles.bjo new file mode 100644 index 0000000..85f96f7 --- /dev/null +++ b/examples/styles.bjo @@ -0,0 +1,38 @@ +;; 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)) diff --git a/src/app.bjo b/src/app.bjo index d7eb4a6..79e4918 100644 --- a/src/app.bjo +++ b/src/app.bjo @@ -25,12 +25,12 @@ ;; `AvaloniaObject.SetValue`, so no Avalonia class is subclassed. (export - App Live Control Sub - run-app next + App Live Control Sub StyleRule + run-app next style ;; Subscriptions. every subscription ;; For tests and for hosts of their own: an app with no window. - start-app app-dispatch! app-send! app-stop! app-run-pending! + start-app app-dispatch! app-send! app-stop! app-run-pending! app-press! app-model app-control app-control-at) (import (std prelude)) @@ -80,6 +80,39 @@ (ItemsControl (: Avalonia.Controls.ItemsControl)) (ItemCollection (: Avalonia.Controls.ItemCollection)) (IList (: System.Collections.IList)) + (Menu (: Avalonia.Controls.Menu (-> Menu))) + (MenuItem (: Avalonia.Controls.MenuItem (-> MenuItem))) + (Separator (: Avalonia.Controls.Separator (-> Separator))) + (ContextMenu (: Avalonia.Controls.ContextMenu (-> ContextMenu))) + (KeyGesture (: Avalonia.Input.KeyGesture (-> KeyCode KeyModifiers KeyGesture))) + (KeyCode (: Avalonia.Input.Key)) + (KeyModifiers (: Avalonia.Input.KeyModifiers)) + (KeyEventArgs (: Avalonia.Input.KeyEventArgs)) + (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)) (Timer (: Avalonia.Threading.DispatcherTimer (-> Timer))) (TimeSpan (: System.TimeSpan)) @@ -163,6 +196,58 @@ (decorator-padding (: Avalonia.Controls.Decorator.PaddingProperty #:get)) (decorator-child (: Avalonia.Controls.Decorator.ChildProperty #:get)) (parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush))) + (menu-header-property + (: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl.HeaderProperty #:get)) + (input-gesture-property (: Avalonia.Controls.MenuItem.InputGestureProperty #:get)) + (context-menu-property (: Avalonia.Controls.Control.ContextMenuProperty #:get)) + (parse-gesture (: Avalonia.Input.KeyGesture.Parse (-> string KeyGesture))) + (gesture=? (: Avalonia.Input.KeyGesture.Equals (-> KeyGesture KeyGesture bool))) + (key-of (: Avalonia.Input.KeyEventArgs.Key (-> KeyEventArgs KeyCode) #:get)) + (modifiers-of (: Avalonia.Input.KeyEventArgs.KeyModifiers (-> KeyEventArgs KeyModifiers) #:get)) + (handled! (: Avalonia.Interactivity.RoutedEventArgs.Handled (-> RoutedEventArgs bool void) #:set)) + (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 ;; properties are. @@ -177,6 +262,9 @@ ;; Events. (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 ;; dispatcher and comes later, after the patch that set the text is over. (text-changing-event (: Avalonia.Controls.TextBox.TextChangingEvent #:get)) @@ -251,6 +339,8 @@ (ColumnKind #t) (RowKind #t) (GridKind #t) + (WrapKind #t) + (DockKind #t) (_ #f))) (: (-> Kind bool)) @@ -271,23 +361,43 @@ (RowKind #f) (GridKind #f) (BorderKind #f) + (ContextKind #f) + (WrapKind #f) + (DockKind #f) (_ #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. (: (-> Kind bool)) (defun (items? kind) (match kind (ListBoxKind #t) (TabsKind #t) + (MenuBarKind #t) + (MenuItemKind #t) + (ContextMenuKind #t) + (TreeKind #t) + (TreeNodeKind #t) (_ #f))) -;; A kind with one child, which is its content. +;; A kind whose children each have a place of their own: the content of a +;; scroll, a tab or a border, and a context menu's view and its menu. (: (-> Kind bool)) (defun (single? kind) (match kind (ScrollKind #t) (TabKind #t) (BorderKind #t) + (ContextKind #t) + (ExpanderKind #t) (_ #f))) ;; A kind that chooses one of its items or options. @@ -320,57 +430,82 @@ (defun (slot kind p) (defun (when-kind ok? prop) (if ok? (Some prop) None)) (match p - ((Label _) + ((PropLabel _) (match kind (TextKind (Some (cast AvaloniaProperty text-block-text))) (ButtonKind (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))) + (MenuItemKind (Some (cast AvaloniaProperty menu-header-property))) (_ None))) - ((Value _) (when-kind (text-box? kind) (cast AvaloniaProperty text-box-text))) - ((Placeholder _) (when-kind (text-box? kind) (cast AvaloniaProperty watermark-property))) - ((Checked _) (when-kind (= kind CheckBoxKind) (cast AvaloniaProperty is-checked-property))) - ((Enabled _) (Some (cast AvaloniaProperty is-enabled-property))) - ((FontSize _) + ((PropValue _) + (cond ((text-box? kind) (Some (cast AvaloniaProperty text-box-text))) + ((= kind AutoCompleteKind) (Some (cast AvaloniaProperty auto-text-property))) + (else None))) + ((PropPlaceholder _) + (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))) ((templated? kind) (Some (cast AvaloniaProperty font-size-property))) (else None))) - ((Width _) (Some (cast AvaloniaProperty width-property))) - ((Height _) (Some (cast AvaloniaProperty height-property))) - ((Margin _) (Some (cast AvaloniaProperty margin-property))) - ((Padding _) + ((PropWidth _) (Some (cast AvaloniaProperty width-property))) + ((PropHeight _) (Some (cast AvaloniaProperty height-property))) + ((PropMargin _) (Some (cast AvaloniaProperty margin-property))) + ((PropPadding _) (cond ((= kind BorderKind) (Some (cast AvaloniaProperty decorator-padding))) ((templated? kind) (Some (cast AvaloniaProperty padding-property))) (else None))) - ((Spacing _) (when-kind (stack? kind) (cast AvaloniaProperty spacing-property))) - ((Wrap _) (when-kind (= kind TextKind) (cast AvaloniaProperty text-block-wrapping))) - ((Minimum _) (when-kind (range? kind) (cast AvaloniaProperty minimum-property))) - ((Maximum _) (when-kind (range? kind) (cast AvaloniaProperty maximum-property))) - ((Amount _) (when-kind (range? kind) (cast AvaloniaProperty value-property))) - ((Step _) (when-kind (= kind SliderKind) (cast AvaloniaProperty small-change-property))) - ((Items _) (when-kind (= kind DropdownKind) (cast AvaloniaProperty items-source-property))) - ((Selected _) (when-kind (selecting? kind) (cast AvaloniaProperty selected-index-property))) - ((Row _) (Some (cast AvaloniaProperty grid-row-property))) - ((Column _) (Some (cast AvaloniaProperty grid-column-property))) - ((RowSpan _) (Some (cast AvaloniaProperty grid-row-span-property))) - ((ColumnSpan _) (Some (cast AvaloniaProperty grid-column-span-property))) - ((Background _) + ((PropSpacing _) (when-kind (stack? kind) (cast AvaloniaProperty spacing-property))) + ((PropWrap _) (when-kind (= kind TextKind) (cast AvaloniaProperty text-block-wrapping))) + ((PropMinimum _) (when-kind (range? kind) (cast AvaloniaProperty minimum-property))) + ((PropMaximum _) (when-kind (range? kind) (cast AvaloniaProperty maximum-property))) + ((PropAmount _) (when-kind (range? kind) (cast AvaloniaProperty value-property))) + ((PropStep _) (when-kind (= kind SliderKind) (cast AvaloniaProperty small-change-property))) + ((PropItems _) + (cond ((= kind DropdownKind) (Some (cast AvaloniaProperty items-source-property))) + ((= kind AutoCompleteKind) (Some (cast AvaloniaProperty auto-items-property))) + (else None))) + ((PropSelected _) (when-kind (selecting? kind) (cast AvaloniaProperty selected-index-property))) + ((PropRow _) (Some (cast AvaloniaProperty grid-row-property))) + ((PropColumn _) (Some (cast AvaloniaProperty grid-column-property))) + ((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))) ((= kind BorderKind) (Some (cast AvaloniaProperty border-background))) ((panel? kind) (Some (cast AvaloniaProperty panel-background))) ((templated? kind) (Some (cast AvaloniaProperty background-property))) (else None))) - ((Foreground _) + ((PropForeground _) (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-foreground))) ((templated? kind) (Some (cast AvaloniaProperty foreground-property))) (else None))) - ((BorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property))) - ((BorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property))) - ((Radius _) (when-kind (= kind BorderKind) (cast AvaloniaProperty corner-radius-property))) + ((PropBorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property))) + ((PropBorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property))) + ((PropRadius _) (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. - ((Source _) None) - ((Columns _) None) - ((Rows _) None))) + ((PropSource _) None) + ((PropColumns _) None) + ((PropRows _) None))) (: (-> bool TextWrapping)) (defun (wrapping wrap?) @@ -392,60 +527,84 @@ (: (-> Prop (Option Object))) (defun (boxed p) (match p - ((Background s) (brush s)) - ((Foreground s) (brush s)) - ((BorderColour s) (brush s)) + ((PropBackground s) (brush s)) + ((PropForeground s) (brush s)) + ((PropBorderColour 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))))) +;; Keys, as Avalonia reads them. None for keys it cannot read. +(: (-> string (Option KeyGesture))) +(defun (gesture s) + (match (try (parse-gesture s) #:catch (System.Exception)) + ((Ok g) (Some g)) + ((Err _) None))) + (: (-> Prop Object)) (defun (plain p) (defun (text s) (cast Object (->clr-string s))) (match p - ((Label s) (text s)) - ((Value s) (text s)) - ((Placeholder s) (text s)) - ((Checked b) (cast Object b)) - ((Enabled b) (cast Object b)) - ((FontSize d) (cast Object d)) - ((Width d) (cast Object d)) - ((Height d) (cast Object d)) - ((Margin d) (cast Object (Thickness. d))) - ((Padding d) (cast Object (Thickness. d))) - ((Spacing d) (cast Object d)) - ((Wrap b) (cast Object (wrapping b))) - ((Minimum d) (cast Object d)) - ((Maximum d) (cast Object d)) - ((Amount d) (cast Object d)) - ((Step d) (cast Object d)) + ((PropLabel s) (text s)) + ((PropValue s) (text s)) + ((PropPlaceholder s) (text s)) + ((PropChecked b) (cast Object b)) + ((PropEnabled b) (cast Object b)) + ((PropFontSize d) (cast Object d)) + ((PropWidth d) (cast Object d)) + ((PropHeight d) (cast Object d)) + ((PropMargin d) (cast Object (Thickness. d))) + ((PropPadding d) (cast Object (Thickness. d))) + ((PropSpacing d) (cast Object d)) + ((PropWrap b) (cast Object (wrapping b))) + ((PropMinimum d) (cast Object d)) + ((PropMaximum d) (cast Object d)) + ((PropAmount d) (cast Object d)) + ((PropStep d) (cast Object d)) ;; A .NET array of .NET strings, which a ComboBox shows as they are. - ((Items xs) (cast Object (: (vec->array (vec-map ->clr-string xs)) (Array ClrString)))) - ((Selected i) (cast Object i)) - ((Row i) (cast Object i)) - ((Column i) (cast Object i)) - ((RowSpan i) (cast Object i)) - ((ColumnSpan i) (cast Object i)) - ((Source s) (text s)) - ((Columns s) (text s)) - ((Rows s) (text s)) - ((Background s) (text s)) - ((Foreground s) (text s)) - ((BorderColour s) (text s)) - ((BorderWidth d) (cast Object (Thickness. d))) - ((Radius d) (cast Object (CornerRadius. d))))) + ((PropItems xs) (cast Object (: (vec->array (vec-map ->clr-string xs)) (Array ClrString)))) + ((PropSelected i) (cast Object i)) + ((PropRow i) (cast Object i)) + ((PropColumn i) (cast Object i)) + ((PropRowSpan i) (cast Object i)) + ((PropColumnSpan i) (cast Object i)) + ((PropSource s) (text s)) + ((PropColumns s) (text s)) + ((PropRows s) (text s)) + ((PropBackground s) (text s)) + ((PropForeground s) (text s)) + ((PropBorderColour s) (text s)) + ((PropBorderWidth d) (cast Object (Thickness. d))) + ((PropRadius 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 ;; property. (: (-> Prop int)) (defun (tag p) (match p - ((Label _) 0) ((Value _) 1) ((Placeholder _) 2) ((Checked _) 3) - ((Enabled _) 4) ((FontSize _) 5) ((Width _) 6) ((Height _) 7) - ((Margin _) 8) ((Padding _) 9) ((Spacing _) 10) ((Wrap _) 11) - ((Minimum _) 12) ((Maximum _) 13) ((Amount _) 14) ((Step _) 15) - ((Items _) 16) ((Selected _) 17) ((Source _) 18) ((Columns _) 19) - ((Rows _) 20) ((Row _) 21) ((Column _) 22) ((RowSpan _) 23) ((ColumnSpan _) 24) - ((Background _) 25) ((Foreground _) 26) ((BorderColour _) 27) ((BorderWidth _) 28) - ((Radius _) 29))) + ((PropLabel _) 0) ((PropValue _) 1) ((PropPlaceholder _) 2) ((PropChecked _) 3) + ((PropEnabled _) 4) ((PropFontSize _) 5) ((PropWidth _) 6) ((PropHeight _) 7) + ((PropMargin _) 8) ((PropPadding _) 9) ((PropSpacing _) 10) ((PropWrap _) 11) + ((PropMinimum _) 12) ((PropMaximum _) 13) ((PropAmount _) 14) ((PropStep _) 15) + ((PropItems _) 16) ((PropSelected _) 17) ((PropSource _) 18) ((PropColumns _) 19) + ((PropRows _) 20) ((PropRow _) 21) ((PropColumn _) 22) ((PropRowSpan _) 23) ((PropColumnSpan _) 24) + ((PropBackground _) 25) ((PropForeground _) 26) ((PropBorderColour _) 27) ((PropBorderWidth _) 28) + ((PropRadius _) 29) ((PropShortcut _) 30) ((PropTip _) 31) ((PropExpanded _) 32) ((PropDate _) 33) + ((PropDockSide _) 34) ((PropClasses _) 35) ((PropChosenKey _) 36))) (: (-> Control AvaloniaProperty Object void)) (defun (put! control property value) @@ -461,15 +620,31 @@ (: (-> Control Kind Prop void)) (defun (set-prop! control kind p) (match (Tuple kind p) - ((Tuple ImageKind (Source path)) + ((Tuple ImageKind (PropSource path)) (match (load-bitmap path) ((Some b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b))) (None (clear-value (cast AvaloniaObject control) (cast AvaloniaProperty image-source-property))))) - ((Tuple GridKind (Columns s)) (grid-columns! (cast Grid control) (parse-columns s))) - ((Tuple GridKind (Rows s)) (grid-rows! (cast Grid control) (parse-rows s))) - ((Tuple GridKind (Spacing d)) + ((Tuple GridKind (PropColumns s)) (grid-columns! (cast Grid control) (parse-columns s))) + ((Tuple GridKind (PropRows s)) (grid-rows! (cast Grid control) (parse-rows s))) + ((Tuple GridKind (PropSpacing d)) (put! control (cast AvaloniaProperty grid-row-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) ((Some property) @@ -482,12 +657,16 @@ (defun (clear-prop! control kind p) (defun (clear property) (clear-value (cast AvaloniaObject control) property)) (match (Tuple kind p) - ((Tuple ImageKind (Source _)) (clear (cast AvaloniaProperty image-source-property))) - ((Tuple GridKind (Columns _)) (grid-columns! (cast Grid control) (parse-columns "*"))) - ((Tuple GridKind (Rows _)) (grid-rows! (cast Grid control) (parse-rows "*"))) - ((Tuple GridKind (Spacing _)) + ((Tuple ImageKind (PropSource _)) (clear (cast AvaloniaProperty image-source-property))) + ((Tuple GridKind (PropColumns _)) (grid-columns! (cast Grid control) (parse-columns "*"))) + ((Tuple GridKind (PropRows _)) (grid-rows! (cast Grid control) (parse-rows "*"))) + ((Tuple GridKind (PropSpacing _)) (clear (cast AvaloniaProperty grid-row-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) ((Some property) (clear property)) @@ -567,6 +746,9 @@ (: gui-update (-> %m %model (Tuple %model (List (Event %m))))) (: view (-> %model (View %m))) (: subscriptions (-> %model (List (Sub %m)))) + (: keys (-> %model (List (Key %m)))) + (: theme (-> %model string)) + (: shown-theme string #:mutable) (: root (Option (Live %m)) #:mutable) (: patching bool #:mutable) (: stopped bool #:mutable) @@ -627,6 +809,45 @@ (defun (app-run-pending! app) (ui-run-jobs ui-dispatcher (clr-default))) +;; Sends the message of the keys `g`: of an enabled menu item in the view +;; with those keys as its shortcut, or else of the app's `#:keys`. True when +;; there was one. +(: (-> (App %model %m) KeyGesture bool)) +(defun (press! app g) + (defun (same? s) (match (gesture s) ((Some h) (gesture=? g h)) (None #f))) + (: (-> (View %m) (Option %m))) + (defun (in-view v) + (def props (view-props v)) + (if (and (= (view-kind v) MenuItemKind) + (not (vec-contains props (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 ;; dropped. A command that is still running is cancelled when the scope the ;; app was started in ends. @@ -639,6 +860,7 @@ (: (-> (App %model %m) (List (Event %m)) void)) (defun (step! app commands) (render! app) + (apply-theme! app) (in-scope (.home app) (loop (:for command commands) (:do (spawn/daemon (run-command app command))))) @@ -687,6 +909,18 @@ (:do (set! kept (cons (Tuple (sub-key sub) (start-sub! app sub)) 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)) (defun (render! app) (def next-view ((.view app) (.model app))) @@ -732,30 +966,76 @@ (fun (sender e) (when (eq? (event-source e) (cast Object control)) (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 + (MenuItemKind + (on-event (cast RoutedEvent menu-click-event) + (fun () (fun (on) (match on ((OnClick msg) (Some msg)) (_ None)))))) (ButtonKind (on-event (cast RoutedEvent click-event) - (fun () (fun (on) (match on ((Click msg) (Some msg)) (_ None)))))) + (fun () (fun (on) (match on ((OnClick msg) (Some msg)) (_ None)))))) ((or TextInputKind TextAreaKind) (on-event (cast RoutedEvent text-changing-event) (fun () (def s (text-box-value (cast TextBox control))) - (fun (on) (match on ((Input f) (Some (f s))) (_ None)))))) - (CheckBoxKind + (fun (on) (match on ((OnInput f) (Some (f s))) (_ None)))))) + (RadioKind (on-event (cast RoutedEvent checked-event) (fun () (def b (.GetValueOrDefault (is-checked (cast ToggleButton control)))) - (fun (on) (match on ((Toggle f) (Some (f b))) (_ None)))))) + (fun (on) (match on ((OnClick msg) (if b (Some msg) None)) (_ 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 (on-event (cast RoutedEvent value-changed-event) (fun () (def d (range-value (cast RangeBase control))) - (fun (on) (match on ((Slide f) (Some (f d))) (_ None)))))) + (fun (on) (match on ((OnSlide 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) (on-event (cast RoutedEvent selection-changed-event) (fun () (def i (selected-index (cast SelectingItemsControl control))) - (fun (on) (match on ((Select f) (Some (f i))) (_ None)))))) + (fun (on) (match on ((OnSelect f) (Some (f i))) (_ None)))))) (_ unit))) (: (-> Kind Control)) @@ -796,7 +1076,22 @@ (ListBoxKind (cast Control (ListBox.))) (TabsKind (cast Control (TabControl.))) (TabKind (cast Control (TabItem.))) - (BorderKind (cast Control (Border.))))) + (BorderKind (cast Control (Border.))) + (MenuBarKind (cast Control (Menu.))) + (MenuItemKind (cast Control (MenuItem.))) + (SeparatorKind (cast Control (Separator.))) + (ContextKind (cast Control (Border.))) + (ContextMenuKind (cast Control (ContextMenu.))) + (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. (: (-> Kind Control IList)) @@ -805,18 +1100,21 @@ (cast IList (items-of (cast ItemsControl parent))) (cast IList (panel-children (cast Panel parent))))) -;; Makes `child` the one child of a scroll, a tab or a border. -(: (-> Kind Control Control void)) -(defun (set-single! kind parent child) - (if (= kind BorderKind) - (put! parent (cast AvaloniaProperty decorator-child) (cast Object child)) - (content! (cast ContentControl parent) (cast Object child)))) +;; Puts `child` in its place: the content of a scroll, a tab or a border, and +;; for a context menu, its view at 0 and the menu at 1. +(: (-> Kind Control int Control void)) +(defun (set-slot! kind parent i child) + (cond ((and (= kind ContextKind) (= i 1)) + (put! parent (cast AvaloniaProperty context-menu-property) (cast Object child))) + ((or (= kind BorderKind) (= kind ContextKind)) + (put! parent (cast AvaloniaProperty decorator-child) (cast Object child))) + (else (content! (cast ContentControl parent) (cast Object child))))) -;; Puts a child's control in its parent's, as the last one. -(: (-> Kind Control Control void)) -(defun (adopt! kind parent child) +;; Puts a child's control in its parent's, as child `i`, the last one so far. +(: (-> Kind Control int Control void)) +(defun (adopt! kind parent i child) (if (single? kind) - (set-single! kind parent child) + (set-slot! kind parent i child) (ignore (list-add! (child-list kind parent) (cast Object child))))) ;; A list or tabs can choose an item only once the items are there, so the @@ -827,7 +1125,7 @@ (when (selecting? kind) (loop (:for p props) (:do (match p - ((Selected i) + ((PropSelected i) (unless (= (selected-index (cast SelectingItemsControl control)) i) (put! control (cast AvaloniaProperty selected-index-property) (cast Object i)))) (_ unit)))))) @@ -843,8 +1141,9 @@ (loop (:for child (view-children v)) (:do (def c (mount app child)) (mutablevec-add! (.children live) c) - (adopt! kind control (.control c)))) + (adopt! kind control (- (mutablevec-length (.children live)) 1) (.control c)))) (sync-selection! control kind (view-props v)) + (sync-tree-choice! live) live) ;; Changes the controls of `live` to show `next`. Gives `live` itself, or new @@ -862,17 +1161,61 @@ ((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next))) (else unit)) (sync-selection! (.control live) kind (view-props next)) + (sync-tree-choice! live) live))) -;; The one child of a scroll, a tab or a border. +;; The node of a tree whose control is `control`, among the live nodes below +;; `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)) (defun (patch-single! app live kind views) (def kids (.children live)) - (def was (mutablevec-ref kids 0)) - (def now (patch! app was (vec-ref views 0))) - (unless (eq? now was) - (mutablevec-set! kids 0 now) - (set-single! kind (.control live) (.control now)))) + (loop (:for (Tuple i v) (enumerate views)) + (:do (def was (mutablevec-ref kids i)) + (def now (patch! app was v)) + (unless (eq? now was) + (mutablevec-set! kids i now) + (set-slot! kind (.control live) i (.control now)))))) ;; Which child each view is: its key, or its place among the children that ;; have none. The two kinds cannot be mistaken for each other. @@ -940,14 +1283,132 @@ ;; Its fibers belong to the scope it is started in. (: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m)) (-> Control void) (#:subscriptions (-> %model (List (Sub %m)))) + (#:keys (-> %model (List (Key %m)))) (#:theme (-> %model string)) (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) - (subscriptions subscriptions) (root None) (patching #f) (stopped #f) + (subscriptions subscriptions) (keys keys) (theme theme) (shown-theme "") + (root None) (patching #f) (stopped #f) (home (current-scope)) (subs '()) (on-root on-root))) (step! 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 ;; out, and closes it. Twice the pixels of the window, so that it is sharp on ;; a screen with a scale of 2. @@ -970,6 +1431,10 @@ ;; Runs the program in a window, until the window is closed. Then the ;; 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 ;; is shown, and closes. It is the environment variable BJOGUI_SCREENSHOT ;; unless told otherwise, so any program can be pictured with no change: @@ -977,9 +1442,12 @@ ;; BJOGUI_SCREENSHOT=shot.png bjo run examples/todo.bjo (: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m)) (#:subscriptions (-> %model (List (Sub %m)))) + (#:keys (-> %model (List (Key %m)))) (#:on-close (Option %m)) + (#:theme (-> %model string)) (#:styles (List StyleRule)) (#:title string) (#:width double) (#:height double) (#:screenshot string) void)) -(defun (run-app init gui-update view #:subscriptions (fun (m) '()) +(defun (run-app init gui-update view #:subscriptions (fun (m) '()) #:keys (fun (m) '()) + #:on-close None #:theme (fun (m) "") #:styles '() #:title "bjogui" #:width 400.0 #:height 300.0 #:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") "")) ;; The Application is made inside the setup, because making one uses the @@ -988,6 +1456,9 @@ (ignore (setup-with-lifetime (use-platform-detect (configure (fun () (Application.)))) lifetime)) (.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.)) (window-title! w title) (ignore (set-value (cast AvaloniaObject w) (cast AvaloniaProperty width-property) @@ -997,7 +1468,24 @@ (with-cancel (cancel) (def app (start-app init gui-update view (fun (c) (window-content! (cast ContentControl w) (cast Object c))) - #:subscriptions subscriptions)) + #:subscriptions subscriptions #:keys keys #:theme theme)) + ;; 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) (unless (string-empty? screenshot) (screenshot-later! lifetime w width height screenshot)) diff --git a/src/dialogs.bjo b/src/dialogs.bjo new file mode 100644 index 0000000..96c632e --- /dev/null +++ b/src/dialogs.bjo @@ -0,0 +1,408 @@ +;; 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)))) diff --git a/src/view.bjo b/src/view.bjo index d1fc949..5b63129 100644 --- a/src/view.bjo +++ b/src/view.bjo @@ -20,9 +20,15 @@ ;; Constructors. text button text-input text-area checkbox slider progress-bar dropdown image list-box tabs tab - column row grid scroll border + menu-bar submenu menu-item menu-separator + toggle-switch radio number-input date-picker auto-complete expander + tree-view tree-node + column row grid scroll border flow dock ;; Wrappers. - keyed at paint + keyed at paint with-context-menu tooltip at-top at-bottom at-left at-right classed + + ;; Keyboard shortcuts. + Key key key-gesture key-message ;; Reading one. view-kind view-props view-events view-children view-key) @@ -37,47 +43,58 @@ (type (: Kind (Union TextKind ButtonKind TextInputKind TextAreaKind CheckBoxKind SliderKind ProgressKind DropdownKind ImageKind ListBoxKind TabsKind TabKind + MenuBarKind MenuItemKind SeparatorKind ContextKind ContextMenuKind + ToggleSwitchKind RadioKind NumberKind DateKind AutoCompleteKind + ExpanderKind WrapKind DockKind TreeKind TreeNodeKind ColumnKind RowKind GridKind ScrollKind BorderKind))) ;; A property of a control. A kind takes only some of them; the app ignores ;; the others. -(type (: Prop (Union (: Label string) ; the text of a text, a button or a checkbox - (: Value string) ; the text in a text input - (: Placeholder string) ; shown in an empty text input - (: Checked bool) - (: Enabled bool) - (: FontSize double) - (: Width double) - (: Height double) - (: Margin double) - (: Padding double) - (: Spacing double) - (: Wrap bool) ; a text breaks its lines at the width - (: Minimum double) ; of a slider or a progress bar - (: Maximum double) - (: Amount double) ; where a slider or a progress bar is - (: Step double) ; what an arrow key moves a slider by - (: Items (Vec string)) ; what a dropdown offers - (: Selected int) ; which item is chosen; -1 for none - (: Source string) ; the file an image shows - (: Columns string) ; a grid's columns, as "Auto,*,2*" - (: Rows string) - (: Row int) ; where a view is in its grid - (: Column int) - (: RowSpan int) - (: ColumnSpan int) - (: Background string) ; a colour: "red", "#08f", "#80ff8800" - (: Foreground string) ; the colour of the text - (: BorderColour string) - (: BorderWidth double) - (: Radius double)))) ; how round a border's corners are +(type (: Prop (Union (: PropLabel string) ; the text of a text, a button or a checkbox + (: PropValue string) ; the text in a text input + (: PropPlaceholder string) ; shown in an empty text input + (: PropChecked bool) + (: PropEnabled bool) + (: PropFontSize double) + (: PropWidth double) + (: PropHeight double) + (: PropMargin double) + (: PropPadding double) + (: PropSpacing double) + (: PropWrap bool) ; a text breaks its lines at the width + (: PropMinimum double) ; of a slider or a progress bar + (: PropMaximum double) + (: PropAmount double) ; where a slider or a progress bar is + (: PropStep double) ; what an arrow key moves a slider by + (: PropItems (Vec string)) ; what a dropdown offers + (: PropSelected int) ; which item is chosen; -1 for none + (: PropSource string) ; the file an image shows + (: PropColumns string) ; a grid's columns, as "Auto,*,2*" + (: PropRows string) + (: PropRow int) ; where a view is in its grid + (: PropColumn int) + (: PropRowSpan int) + (: PropColumnSpan int) + (: PropBackground string) ; a colour: "red", "#08f", "#80ff8800" + (: PropForeground string) ; the colour of the text + (: PropBorderColour string) + (: PropBorderWidth double) + (: PropRadius 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. -(type (: (On %m) (Union (: Click %m) - (: Input (-> string %m)) - (: Toggle (-> bool %m)) - (: Slide (-> double %m)) - (: Select (-> int %m))))) +(type (: (On %m) (Union (: OnClick %m) + (: OnInput (-> string %m)) + (: OnToggle (-> bool %m)) + (: OnSlide (-> double %m)) + (: OnSelect (-> int %m)) + (: OnPick (-> string %m))))) ;; One control and what is in it. ;; @@ -122,14 +139,49 @@ (: paint (-> (View %m) (#:colour string) (#:background string) (View %m))) (defun (paint v #:colour "" #:background "") (defun (with props make c) (if (string-empty? c) props (vec-add props (make c)))) - (record-set v (props (with (with (.props v) Foreground colour) Background background)))) + (record-set v (props (with (with (.props v) PropForeground colour) PropBackground 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. (: at (-> int int (View %m) (#:row-span int) (#:column-span int) (View %m))) (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) (Row row)) (Column column)) - (RowSpan row-span)) - (ColumnSpan column-span))))) + (record-set v (props (vec-add (vec-add (vec-add (vec-add (.props v) (PropRow row)) (PropColumn column)) + (PropRowSpan row-span)) + (PropColumnSpan column-span))))) ;; --------------------------------------------------------------------------- ;; Constructors @@ -144,9 +196,9 @@ (: (-> (Vec Prop) double double double double (Vec Prop))) (defun (with-layout props width height margin padding) - (with-size (with-size (with-size (with-size props Width width) Height height) - Margin margin) - Padding padding)) + (with-size (with-size (with-size (with-size props PropWidth width) PropHeight height) + PropMargin margin) + PropPadding padding)) (: (-> Kind (Vec Prop) (Vec (On %m)) (View %m))) (defun (leaf kind props events) @@ -158,7 +210,7 @@ (View %m))) (defun (text s #:size 0.0 #:wrap #f #:width 0.0 #:height 0.0 #:margin 0.0) (leaf TextKind - (with-layout (with-size [(Label s) (Wrap wrap)] FontSize size) width height margin 0.0) + (with-layout (with-size [(PropLabel s) (PropWrap wrap)] PropFontSize size) width height margin 0.0) [])) ;; A button that sends `msg` when it is clicked. @@ -167,8 +219,8 @@ (View %m))) (defun (button label msg #:enabled #t #:width 0.0 #:height 0.0 #:margin 0.0 #:padding 0.0) (leaf ButtonKind - (with-layout [(Label label) (Enabled enabled)] width height margin padding) - [(Click msg)])) + (with-layout [(PropLabel label) (PropEnabled enabled)] width height margin padding) + [(OnClick msg)])) ;; A one-line text input that holds `value`. Each change sends `(on-input ;; text)`, with the whole text. @@ -177,9 +229,9 @@ (View %m))) (defun (text-input value on-input #:placeholder "" #:enabled #t #:width 0.0 #:margin 0.0) (leaf TextInputKind - (with-layout [(Value value) (Placeholder placeholder) (Enabled enabled)] + (with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)] width 0.0 margin 0.0) - [(Input on-input)])) + [(OnInput on-input)])) ;; A text input of several lines, that breaks its lines at its width. Each ;; change sends `(on-input text)`, with the whole text. @@ -189,9 +241,9 @@ (defun (text-area value on-input #:placeholder "" #:enabled #t #:width 0.0 #:height 0.0 #:margin 0.0) (leaf TextAreaKind - (with-layout [(Value value) (Placeholder placeholder) (Enabled enabled)] + (with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)] width height margin 0.0) - [(Input on-input)])) + [(OnInput on-input)])) ;; A slider at `value`, from `minimum` to `maximum`. A move sends `(on-change ;; value)`. @@ -203,17 +255,17 @@ ;; The bounds come before the value, because a value outside the bounds ;; that are there is moved inside them. (leaf SliderKind - (with-layout [(Minimum minimum) (Maximum maximum) (Amount value) (Step step) - (Enabled enabled)] + (with-layout [(PropMinimum minimum) (PropMaximum maximum) (PropAmount value) (PropStep step) + (PropEnabled enabled)] width 0.0 margin 0.0) - [(Slide on-change)])) + [(OnSlide on-change)])) ;; A bar that is `value` of the way from 0 to `#:maximum`, 1 unless told ;; otherwise. (: (-> double (#:maximum double) (#:width double) (#:margin double) (View %m))) (defun (progress-bar value #:maximum 1.0 #:width 0.0 #:margin 0.0) (leaf ProgressKind - (with-layout [(Minimum 0.0) (Maximum maximum) (Amount value)] width 0.0 margin 0.0) + (with-layout [(PropMinimum 0.0) (PropMaximum maximum) (PropAmount value)] width 0.0 margin 0.0) [])) ;; A list to choose one of `options` from, with the one at `selected` chosen, @@ -224,15 +276,15 @@ ;; The items come before the choice, because the choice is an index into ;; them. (leaf DropdownKind - (with-layout [(Items options) (Selected selected) (Enabled enabled)] + (with-layout [(PropItems options) (PropSelected selected) (PropEnabled enabled)] width 0.0 margin 0.0) - [(Select on-select)])) + [(OnSelect on-select)])) ;; The picture in the file at `path`. A file that cannot be read shows ;; nothing. (: (-> string (#:width double) (#:height double) (#:margin double) (View %m))) (defun (image path #:width 0.0 #:height 0.0 #:margin 0.0) - (leaf ImageKind (with-layout [(Source path)] width height margin 0.0) [])) + (leaf ImageKind (with-layout [(PropSource path)] width height margin 0.0) [])) ;; A list of views to choose one of, with the one at `selected` chosen, or ;; none for -1. A choice sends `(on-select index)`. Give the items keys if @@ -241,8 +293,8 @@ (View %m))) (defun (list-box items selected on-select #:width 0.0 #:height 0.0 #:margin 0.0) (View (kind ListBoxKind) - (props (with-layout [(Selected selected)] width height margin 0.0)) - (events [(Select on-select)]) + (props (with-layout [(PropSelected selected)] width height margin 0.0)) + (events [(OnSelect on-select)]) (children items) (key None))) @@ -251,23 +303,128 @@ (: (-> int (-> int %m) (#:margin double) #:rest (View %m) (View %m))) (defun (tabs selected on-select #:margin 0.0 #:rest tabs) (View (kind TabsKind) - (props (with-layout [(Selected selected)] 0.0 0.0 margin 0.0)) - (events [(Select on-select)]) + (props (with-layout [(PropSelected selected)] 0.0 0.0 margin 0.0)) + (events [(OnSelect on-select)]) (children (array->vec tabs)) (key None))) ;; A tab of `tabs`: its header, and what it shows when it is chosen. (: (-> string (View %m) (View %m))) (defun (tab header content) - (View (kind TabKind) (props [(Label header)]) (events []) (children [content]) (key None))) + (View (kind TabKind) (props [(PropLabel 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 ;; the new state. (: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m))) (defun (checkbox label checked? on-toggle #:enabled #t #:margin 0.0) (leaf CheckBoxKind - (with-layout [(Label label) (Checked checked?) (Enabled enabled)] 0.0 0.0 margin 0.0) - [(Toggle on-toggle)])) + (with-layout [(PropLabel label) (PropChecked checked?) (PropEnabled enabled)] 0.0 0.0 margin 0.0) + [(OnToggle on-toggle)])) (: (-> Kind (Vec Prop) (Vec (View %m)) (View %m))) (defun (container kind props children) @@ -275,7 +432,7 @@ (: (-> Kind double double (Array (View %m)) (View %m))) (defun (stack kind spacing margin children) - (container kind (with-layout (with-size [] Spacing spacing) 0.0 0.0 margin 0.0) + (container kind (with-layout (with-size [] PropSpacing spacing) 0.0 0.0 margin 0.0) (array->vec children))) ;; Views one above the other. @@ -296,7 +453,7 @@ #:rest (View %m) (View %m))) (defun (grid #:columns "*" #:rows "*" #:spacing 0.0 #:margin 0.0 #:rest children) (container GridKind - (with-layout (with-size [(Columns columns) (Rows rows)] Spacing spacing) + (with-layout (with-size [(PropColumns columns) (PropRows rows)] PropSpacing spacing) 0.0 0.0 margin 0.0) (array->vec children))) @@ -311,13 +468,43 @@ (defun (with props make c) (if (string-empty? c) props (vec-add props (make c)))) (container BorderKind (with (with (with-size (with-size (with-layout [] 0.0 0.0 margin padding) - BorderWidth thickness) - Radius radius) - BorderColour colour) - Background background) + PropBorderWidth thickness) + PropRadius radius) + PropBorderColour colour) + PropBackground background) [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. (: (-> (View %m) (#:width double) (#:height double) (#:margin double) (View %m))) (defun (scroll child #:width 0.0 #:height 0.0 #:margin 0.0) (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)) diff --git a/tests/dialogs.bjo b/tests/dialogs.bjo new file mode 100644 index 0000000..951a452 --- /dev/null +++ b/tests/dialogs.bjo @@ -0,0 +1,54 @@ +;; 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")) diff --git a/tests/inputs.bjo b/tests/inputs.bjo new file mode 100644 index 0000000..dab22b4 --- /dev/null +++ b/tests/inputs.bjo @@ -0,0 +1,144 @@ +;; 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")) diff --git a/tests/menus.bjo b/tests/menus.bjo new file mode 100644 index 0000000..6115d32 --- /dev/null +++ b/tests/menus.bjo @@ -0,0 +1,118 @@ +;; 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")) diff --git a/tests/tree.bjo b/tests/tree.bjo new file mode 100644 index 0000000..68f5af8 --- /dev/null +++ b/tests/tree.bjo @@ -0,0 +1,84 @@ +;; 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"))