diff --git a/Readme.org b/Readme.org index 0c2540c..4e468d0 100644 --- a/Readme.org +++ b/Readme.org @@ -68,16 +68,6 @@ 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~, @@ -132,53 +122,6 @@ a line around a view, with round corners if ~#:radius~ is more than zero. The Fluent theme gives a button its own colours when the pointer is over it 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 @@ -216,42 +159,10 @@ The fibers belong to the app. They post their messages to the UI thread, so ~gui-update~ and ~view~ always run there. When the window is closed they are 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 #:keys #:theme #:styles - #:on-close #:title #:width #:height)~ opens a window and runs until it is - closed. +- ~(run-app init gui-update view #:subscriptions #: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 @@ -265,7 +176,6 @@ answered. - ~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. @@ -286,21 +196,15 @@ 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 -- 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. +- Menus and dialogs. +- Styles of one's own, with classes, and colours for the pointer-over and + pressed states. - 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 deleted file mode 100644 index b8127f8..0000000 Binary files a/docs/styles.png and /dev/null differ diff --git a/examples/styles.bjo b/examples/styles.bjo deleted file mode 100644 index 85f96f7..0000000 --- a/examples/styles.bjo +++ /dev/null @@ -1,38 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public -;; License, v. 2.0. If a copy of the MPL was not distributed with this -;; file, You can obtain one at http://mozilla.org/MPL/2.0/. - -;; bjogui/examples/styles.bjo — styles, classes and the dark theme. -;; -;; bjo run examples/styles.bjo -;; -;; The picture in the Readme is this program, taken with -;; -;; BJOGUI_SCREENSHOT=docs/styles.png bjo run examples/styles.bjo -(import (std prelude)) -(import (bjogui view)) -(import (bjogui app)) - -(type (: Msg (Union Nothing))) - -(defun (main) - (run-app 0 (fun (msg n) (next n)) - (fun (n) - (column #:spacing 12.0 #:margin 20.0 - (classed (text "Styled with classes") "title") - (row #:spacing 8.0 - (classed (button "Save" Nothing) "primary") - (classed (button "Delete" Nothing) "danger") - (button "Plain" Nothing)) - (classed (border (text "a card") #:padding 10.0) "card") - (toggle-switch "Dark mode" #t (fun (b) Nothing)) - (number-input 3.0 (fun (d) Nothing) #:width 160.0) - (date-picker "2026-10-25" (fun (d) Nothing)))) - #:theme (fun (n) "dark") - #:styles (list (style "text" #:class "title" #:font-size 22.0 #:colour "#f1c40f") - (style "button" #:class "primary" #:background "#27ae60" #:colour "white" - #:hover-background "#2ecc71" #:pressed-background "#1e8449") - (style "button" #:class "danger" #:background "#c0392b" #:colour "white" - #:hover-background "#e74c3c" #:radius 12.0) - (style "border" #:class "card" #:background "#34495e" #:radius 8.0)) - #:title "styles" #:width 360.0 #:height 330.0)) diff --git a/src/app.bjo b/src/app.bjo index 79e4918..d7eb4a6 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 StyleRule - run-app next style + App Live Control Sub + run-app next ;; 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! app-press! + start-app app-dispatch! app-send! app-stop! app-run-pending! app-model app-control app-control-at) (import (std prelude)) @@ -80,39 +80,6 @@ (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)) @@ -196,58 +163,6 @@ (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. @@ -262,9 +177,6 @@ ;; 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)) @@ -339,8 +251,6 @@ (ColumnKind #t) (RowKind #t) (GridKind #t) - (WrapKind #t) - (DockKind #t) (_ #f))) (: (-> Kind bool)) @@ -361,43 +271,23 @@ (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 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. +;; A kind with one child, which is its content. (: (-> 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. @@ -430,82 +320,57 @@ (defun (slot kind p) (defun (when-kind ok? prop) (if ok? (Some prop) None)) (match p - ((PropLabel _) + ((Label _) (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))) - ((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 _) + ((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 _) (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-font-size))) ((templated? kind) (Some (cast AvaloniaProperty font-size-property))) (else None))) - ((PropWidth _) (Some (cast AvaloniaProperty width-property))) - ((PropHeight _) (Some (cast AvaloniaProperty height-property))) - ((PropMargin _) (Some (cast AvaloniaProperty margin-property))) - ((PropPadding _) + ((Width _) (Some (cast AvaloniaProperty width-property))) + ((Height _) (Some (cast AvaloniaProperty height-property))) + ((Margin _) (Some (cast AvaloniaProperty margin-property))) + ((Padding _) (cond ((= kind BorderKind) (Some (cast AvaloniaProperty decorator-padding))) ((templated? kind) (Some (cast AvaloniaProperty padding-property))) (else None))) - ((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 _) + ((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 _) (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))) - ((PropForeground _) + ((Foreground _) (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-foreground))) ((templated? kind) (Some (cast AvaloniaProperty foreground-property))) (else None))) - ((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))) + ((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))) ;; Set by `set-prop!` itself. - ((PropSource _) None) - ((PropColumns _) None) - ((PropRows _) None))) + ((Source _) None) + ((Columns _) None) + ((Rows _) None))) (: (-> bool TextWrapping)) (defun (wrapping wrap?) @@ -527,84 +392,60 @@ (: (-> Prop (Option Object))) (defun (boxed p) (match p - ((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)))) + ((Background s) (brush s)) + ((Foreground s) (brush s)) + ((BorderColour s) (brush s)) (_ (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 - ((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)) + ((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)) ;; A .NET array of .NET strings, which a ComboBox shows as they are. - ((PropItems xs) (cast Object (: (vec->array (vec-map ->clr-string xs)) (Array ClrString)))) - ((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)))))) + ((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))))) ;; Which prop it is, without its value. Two props with one tag set the same ;; property. (: (-> Prop int)) (defun (tag p) (match p - ((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))) + ((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))) (: (-> Control AvaloniaProperty Object void)) (defun (put! control property value) @@ -620,31 +461,15 @@ (: (-> Control Kind Prop void)) (defun (set-prop! control kind p) (match (Tuple kind p) - ((Tuple ImageKind (PropSource path)) + ((Tuple ImageKind (Source 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 (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)) + ((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)) (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) @@ -657,16 +482,12 @@ (defun (clear-prop! control kind p) (defun (clear property) (clear-value (cast AvaloniaObject control) property)) (match (Tuple kind p) - ((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 _)) + ((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 _)) (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)) @@ -746,9 +567,6 @@ (: 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) @@ -809,45 +627,6 @@ (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. @@ -860,7 +639,6 @@ (: (-> (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))))) @@ -909,18 +687,6 @@ (: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))) @@ -966,76 +732,30 @@ (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 ((OnClick msg) (Some msg)) (_ None)))))) + (fun () (fun (on) (match on ((Click 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 ((OnInput f) (Some (f s))) (_ None)))))) - (RadioKind + (fun (on) (match on ((Input f) (Some (f s))) (_ None)))))) + (CheckBoxKind (on-event (cast RoutedEvent checked-event) (fun () (def b (.GetValueOrDefault (is-checked (cast ToggleButton control)))) - (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)))))) + (fun (on) (match on ((Toggle 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 ((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)))))) + (fun (on) (match on ((Slide f) (Some (f d))) (_ None)))))) ((or DropdownKind ListBoxKind TabsKind) (on-event (cast RoutedEvent selection-changed-event) (fun () (def i (selected-index (cast SelectingItemsControl control))) - (fun (on) (match on ((OnSelect f) (Some (f i))) (_ None)))))) + (fun (on) (match on ((Select f) (Some (f i))) (_ None)))))) (_ unit))) (: (-> Kind Control)) @@ -1076,22 +796,7 @@ (ListBoxKind (cast Control (ListBox.))) (TabsKind (cast Control (TabControl.))) (TabKind (cast Control (TabItem.))) - (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.))))) + (BorderKind (cast Control (Border.))))) ;; Where the controls of a panel's children, or of a list's items, are. (: (-> Kind Control IList)) @@ -1100,21 +805,18 @@ (cast IList (items-of (cast ItemsControl parent))) (cast IList (panel-children (cast Panel parent))))) -;; 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))))) +;; 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 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) +;; Puts a child's control in its parent's, as the last one. +(: (-> Kind Control Control void)) +(defun (adopt! kind parent child) (if (single? kind) - (set-slot! kind parent i child) + (set-single! kind parent 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 @@ -1125,7 +827,7 @@ (when (selecting? kind) (loop (:for p props) (:do (match p - ((PropSelected i) + ((Selected i) (unless (= (selected-index (cast SelectingItemsControl control)) i) (put! control (cast AvaloniaProperty selected-index-property) (cast Object i)))) (_ unit)))))) @@ -1141,9 +843,8 @@ (loop (:for child (view-children v)) (:do (def c (mount app child)) (mutablevec-add! (.children live) c) - (adopt! kind control (- (mutablevec-length (.children live)) 1) (.control c)))) + (adopt! kind control (.control c)))) (sync-selection! control kind (view-props v)) - (sync-tree-choice! live) live) ;; Changes the controls of `live` to show `next`. Gives `live` itself, or new @@ -1161,61 +862,17 @@ ((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next))) (else unit)) (sync-selection! (.control live) kind (view-props next)) - (sync-tree-choice! live) live))) -;; 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. +;; The one child of a scroll, a tab or a border. (: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void)) (defun (patch-single! app live kind views) (def kids (.children live)) - (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)))))) + (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)))) ;; 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. @@ -1283,132 +940,14 @@ ;; 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) '()) - #:keys (fun (m) '()) #:theme (fun (m) "")) +(defun (start-app init gui-update view on-root #:subscriptions (fun (m) '())) (def app (App (model init) (gui-update gui-update) (view view) - (subscriptions subscriptions) (keys keys) (theme theme) (shown-theme "") - (root None) (patching #f) (stopped #f) + (subscriptions subscriptions) (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. @@ -1431,10 +970,6 @@ ;; 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: @@ -1442,12 +977,9 @@ ;; 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) '()) #:keys (fun (m) '()) - #:on-close None #:theme (fun (m) "") #:styles '() +(defun (run-app init gui-update view #:subscriptions (fun (m) '()) #:title "bjogui" #:width 400.0 #:height 300.0 #:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") "")) ;; The Application is made inside the setup, because making one uses the @@ -1456,9 +988,6 @@ (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) @@ -1468,24 +997,7 @@ (with-cancel (cancel) (def app (start-app init gui-update view (fun (c) (window-content! (cast ContentControl w) (cast Object c))) - #: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)))) + #:subscriptions subscriptions)) (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 deleted file mode 100644 index 96c632e..0000000 --- a/src/dialogs.bjo +++ /dev/null @@ -1,408 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public -;; License, v. 2.0. If a copy of the MPL was not distributed with this -;; file, You can obtain one at http://mozilla.org/MPL/2.0/. - -;; bjogui/src/dialogs.bjo — the module (bjogui dialogs). -;; -;; Dialogs, file pickers and quitting, as commands: each is an `(Event %m)` -;; that `gui-update` returns, and the answer comes back as a message. -;; -;; (Delete (next m (confirm "Delete it?" Deleted?))) -;; ((Deleted? #t) (next (remove m))) -;; -;; A dialog is a window, which only the UI thread may make, and a command is -;; synced in a fiber. So each one is a `guard`: when the fiber syncs it, a -;; fiber of its own asks the UI thread to show the dialog, and waits for the -;; Task that the dialog gives back. -;; -;; A dialog needs a window to belong to. With none, as in a test that runs an -;; app with `start-app`, each answers as if it was cancelled: `confirm` #f, -;; `prompt` and the pickers None or nothing. - -(export - alert confirm prompt - open-file open-files save-file open-folder - quit) - -(import (std prelude)) -(import (std interop)) - -(import/class - (Object (: System.Object)) - (DispatcherOpBase (: Avalonia.Threading.DispatcherOperation)) - (ClrType (: System.Type)) - (PropertyInfo (: System.Reflection.PropertyInfo)) - (ClrString (: System.String)) - ((ReadOnlyList %a) (: System.Collections.Generic.IReadOnlyList)) - ((EventHandler %a) (: System.EventHandler)) - (Application (: Avalonia.Application)) - (ILifetime (: Avalonia.Controls.ApplicationLifetimes.IApplicationLifetime)) - (Lifetime (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime)) - (Dispatcher (: Avalonia.Threading.Dispatcher)) - ((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation)) - (AvaloniaObject (: Avalonia.AvaloniaObject)) - (AvaloniaProperty (: Avalonia.AvaloniaProperty)) - (Priority (: Avalonia.Data.BindingPriority)) - (Disposable (: System.IDisposable)) - (Thickness (: Avalonia.Thickness (-> double Thickness))) - (Orientation (: Avalonia.Layout.Orientation)) - (HAlignment (: Avalonia.Layout.HorizontalAlignment)) - (TextWrapping (: Avalonia.Media.TextWrapping)) - (SizeToContent (: Avalonia.Controls.SizeToContent)) - (StartupLocation (: Avalonia.Controls.WindowStartupLocation)) - (Control (: Avalonia.Controls.Control)) - (Controls (: Avalonia.Controls.Controls)) - (Panel (: Avalonia.Controls.Panel)) - (StackPanel (: Avalonia.Controls.StackPanel (-> StackPanel))) - (TextBlock (: Avalonia.Controls.TextBlock (-> TextBlock))) - (TextBox (: Avalonia.Controls.TextBox (-> TextBox))) - (Button (: Avalonia.Controls.Button (-> Button))) - (Window (: Avalonia.Controls.Window (-> Window))) - (TopLevel (: Avalonia.Controls.TopLevel)) - (Interactive (: Avalonia.Interactivity.Interactive)) - (RoutedEvent (: Avalonia.Interactivity.RoutedEvent)) - (RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs)) - (Routes (: Avalonia.Interactivity.RoutingStrategies)) - (StorageProvider (: Avalonia.Platform.Storage.IStorageProvider)) - (StorageItem (: Avalonia.Platform.Storage.IStorageItem)) - (StorageFile (: Avalonia.Platform.Storage.IStorageFile)) - (StorageFolder (: Avalonia.Platform.Storage.IStorageFolder)) - (FileType (: Avalonia.Platform.Storage.FilePickerFileType (-> string FileType))) - (PickerOptions (: Avalonia.Platform.Storage.PickerOptions)) - (OpenOptions (: Avalonia.Platform.Storage.FilePickerOpenOptions (-> OpenOptions))) - (SaveOptions (: Avalonia.Platform.Storage.FilePickerSaveOptions (-> SaveOptions))) - (FolderOptions (: Avalonia.Platform.Storage.FolderPickerOpenOptions (-> FolderOptions)))) - -(import/extern - ;; The UI thread, and the window a dialog belongs to. - (ui-dispatcher (: Avalonia.Threading.Dispatcher.UIThread #:get)) - (ui-post (: Avalonia.Threading.Dispatcher.InvokeAsync (-> Dispatcher (-> Unit) (DispatcherOp Unit)))) - ;; Runs a function on the UI thread. - (on-ui (: Avalonia.Threading.Dispatcher.InvokeAsync - (-> Dispatcher (-> Unit) (DispatcherOp Unit)))) - (op-task (: Avalonia.Threading.DispatcherOperation.GetTask (-> DispatcherOpBase Task))) - ;; Waits for Tasks. Avalonia's dialogs take no CancellationToken, so this - ;; cannot be cancelled: a cancelled command stops at its next sync, and the - ;; dialog stays until it is answered. - (await-tasks (: System.Threading.Tasks.Task.WhenAll (-> (Array Task) void) - #:async #:uncancellable)) - ;; What a finished Task answers. By reflection, because Bjolang reads no - ;; Task's Result: on a Task that is not finished, that would block. - (type-of (: System.Object.GetType (-> Object ClrType))) - (property-of (: System.Type.GetProperty (-> ClrType string PropertyInfo))) - (value-of (: System.Reflection.PropertyInfo.GetValue (-> PropertyInfo Object Object))) - (answered (: System.Threading.Tasks.Task.FromResult (-> %a (Task %a)))) - (current-app (: Avalonia.Application.Current #:get)) - (app-lifetime (: Avalonia.Application.ApplicationLifetime (-> Application ILifetime) #:get)) - (main-window (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.MainWindow - (-> Lifetime Window) #:get)) - (shutdown! (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.Shutdown - (-> Lifetime int void))) - (reference=? (: System.Object.ReferenceEquals (-> Object Object bool))) - - ;; The dialog window. - (set-value (: Avalonia.AvaloniaObject.SetValue - (-> AvaloniaObject AvaloniaProperty Object Priority Disposable))) - (title-property (: Avalonia.Controls.Window.TitleProperty #:get)) - (size-to-content-property (: Avalonia.Controls.Window.SizeToContentProperty #:get)) - (startup-location-property (: Avalonia.Controls.Window.WindowStartupLocationProperty #:get)) - (can-resize-property (: Avalonia.Controls.Window.CanResizeProperty #:get)) - (show-in-taskbar-property (: Avalonia.Controls.Window.ShowInTaskbarProperty #:get)) - (content-property (: Avalonia.Controls.ContentControl.ContentProperty #:get)) - (margin-property (: Avalonia.Layout.Layoutable.MarginProperty #:get)) - (max-width-property (: Avalonia.Layout.Layoutable.MaxWidthProperty #:get)) - (min-width-property (: Avalonia.Layout.Layoutable.MinWidthProperty #:get)) - (halign-property (: Avalonia.Layout.Layoutable.HorizontalAlignmentProperty #:get)) - (spacing-property (: Avalonia.Controls.StackPanel.SpacingProperty #:get)) - (orientation-property (: Avalonia.Controls.StackPanel.OrientationProperty #:get)) - (text-property (: Avalonia.Controls.TextBlock.TextProperty #:get)) - (wrapping-property (: Avalonia.Controls.TextBlock.TextWrappingProperty #:get)) - (box-text-property (: Avalonia.Controls.TextBox.TextProperty #:get)) - (is-default-property (: Avalonia.Controls.Button.IsDefaultProperty #:get)) - (is-cancel-property (: Avalonia.Controls.Button.IsCancelProperty #:get)) - (click-event (: Avalonia.Controls.Button.ClickEvent #:get)) - (add-handler (: Avalonia.Interactivity.Interactive.AddHandler - (-> Interactive RoutedEvent Delegate Routes bool void))) - (children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get)) - (box-text (: Avalonia.Controls.TextBox.Text (-> TextBox ClrString) #:get)) - (close-with! (: Avalonia.Controls.Window.Close (-> Window Object void))) - (show-dialog (: Avalonia.Controls.Window.ShowDialog (-> Window Window (Task Object)))) - (clr-string (: System.Convert.ToString (-> string ClrString))) - - ;; The pickers. - (storage-provider (: Avalonia.Controls.TopLevel.StorageProvider (-> TopLevel StorageProvider) #:get)) - (pick-files (: Avalonia.Platform.Storage.IStorageProvider.OpenFilePickerAsync - (-> StorageProvider OpenOptions (Task (ReadOnlyList StorageFile))))) - (pick-save (: Avalonia.Platform.Storage.IStorageProvider.SaveFilePickerAsync - (-> StorageProvider SaveOptions (Task StorageFile)))) - (pick-folders (: Avalonia.Platform.Storage.IStorageProvider.OpenFolderPickerAsync - (-> StorageProvider FolderOptions (Task (ReadOnlyList StorageFolder))))) - (local-path (: Avalonia.Platform.Storage.StorageProviderExtensions.TryGetLocalPath (-> StorageItem string))) - (title! (: Avalonia.Platform.Storage.PickerOptions.Title (-> PickerOptions string void) #:set)) - (allow-multiple! (: Avalonia.Platform.Storage.FilePickerOpenOptions.AllowMultiple (-> OpenOptions bool void) #:set)) - (file-types! (: Avalonia.Platform.Storage.FilePickerOpenOptions.FileTypeFilter - (-> OpenOptions (ReadOnlyList FileType) void) #:set)) - (suggested-name! (: Avalonia.Platform.Storage.FilePickerSaveOptions.SuggestedFileName - (-> SaveOptions string void) #:set)) - (patterns! (: Avalonia.Platform.Storage.FilePickerFileType.Patterns - (-> FileType (ReadOnlyList ClrString) void) #:set))) - -;; --------------------------------------------------------------------------- -;; The UI thread -;; --------------------------------------------------------------------------- - -(: (-> Object bool)) -(defun (null? x) (reference=? x (clr-default))) - -;; The app's main window, if there is an app with one. -(: (-> (Option Window))) -(defun (owner) - (def app (cast Object current-app)) - (if (null? app) - None - (match (try (cast Lifetime (app-lifetime (cast Application app))) - #:catch (System.InvalidCastException System.NullReferenceException)) - ((Ok lifetime) - (def w (main-window lifetime)) - (if (null? (cast Object w)) None (Some w))) - ((Err _) None)))) - -;; Runs `start` on the UI thread with the main window, and waits for the -;; Task it makes. `none` is the answer when there is no window. -(: (-bjo-> (-> Window (Task %a)) %a %a)) -(defbjo (run-on-ui start none) - (def/mutable task (: (clr-default) Task)) - (def op (on-ui ui-dispatcher - (fun () - (set! task (cast Task (cast Object (match (owner) - ((Some w) (start w)) - (None (answered none)))))) - unit))) - (await-tasks #[(op-task (cast DispatcherOpBase (cast Object op)))]) - (await-tasks #[task]) - (cast %a (value-of (property-of (type-of (cast Object task)) "Result") (cast Object task)))) - -;; The event of what the Task that `start` makes answers, at each sync. -;; `none` is the answer when there is no window, or the Task fails. -(: (-> (-> Window (Task %a)) %a (Event %a))) -(defun (ask start none) - (guard (fun () - (wrap (promise-join (bjo (run-on-ui start none))) - (fun (r) (match r - ((Ok x) x) - ((Err _) none))))))) - -;; None for null. -(: (-> Object (Option Object))) -(defun (non-null o) (if (null? o) None (Some o))) - -;; --------------------------------------------------------------------------- -;; Message boxes -;; --------------------------------------------------------------------------- - -(: (-> AvaloniaObject AvaloniaProperty Object void)) -(defun (put! o property value) - (ignore (set-value o property value Priority.LocalValue))) - -(: (-> Control (-> void) void)) -(defun (on-click! button f) - (add-handler (cast Interactive button) (cast RoutedEvent click-event) - (cast Delegate (cast Object (: (as-delegate (: (fun (s e) (f)) (-> Object RoutedEventArgs void))) - (EventHandler RoutedEventArgs)))) - Routes.Bubble #f)) - -;; A button of a dialog: its label, what the dialog answers when it is -;; clicked, from its text input, and whether Enter or Escape clicks it. -(type (: Choice (Record (: label string) (: answer (-> TextBox Object)) (: enter bool) (: escape bool)))) - -;; Shows a dialog with `text`, a text input holding `value` if there is one, -;; and the buttons of `choices`, and answers the Task of what it closes with. -(: (-> string string (Option string) (List Choice) Window (Task Object))) -(defun (show-box! title text value choices owner) - (def w (Window.)) - (def o (cast AvaloniaObject w)) - (put! o (cast AvaloniaProperty title-property) (cast Object (clr-string title))) - (put! o (cast AvaloniaProperty size-to-content-property) (cast Object SizeToContent.WidthAndHeight)) - (put! o (cast AvaloniaProperty startup-location-property) (cast Object StartupLocation.CenterOwner)) - (put! o (cast AvaloniaProperty can-resize-property) (cast Object #f)) - (put! o (cast AvaloniaProperty show-in-taskbar-property) (cast Object #f)) - - (def panel (StackPanel.)) - (put! (cast AvaloniaObject panel) (cast AvaloniaProperty margin-property) (cast Object (Thickness. 20.0))) - (put! (cast AvaloniaObject panel) (cast AvaloniaProperty spacing-property) (cast Object 14.0)) - (put! (cast AvaloniaObject panel) (cast AvaloniaProperty min-width-property) (cast Object 280.0)) - - (def label (TextBlock.)) - (put! (cast AvaloniaObject label) (cast AvaloniaProperty text-property) (cast Object (clr-string text))) - (put! (cast AvaloniaObject label) (cast AvaloniaProperty wrapping-property) (cast Object TextWrapping.Wrap)) - (put! (cast AvaloniaObject label) (cast AvaloniaProperty max-width-property) (cast Object 400.0)) - (.Add (children (cast Panel panel)) (cast Control label)) - - (def input (TextBox.)) - (match value - ((Some v) - (put! (cast AvaloniaObject input) (cast AvaloniaProperty box-text-property) (cast Object (clr-string v))) - (.Add (children (cast Panel panel)) (cast Control input))) - (None unit)) - - (def buttons (StackPanel.)) - (put! (cast AvaloniaObject buttons) (cast AvaloniaProperty orientation-property) (cast Object Orientation.Horizontal)) - (put! (cast AvaloniaObject buttons) (cast AvaloniaProperty spacing-property) (cast Object 8.0)) - (put! (cast AvaloniaObject buttons) (cast AvaloniaProperty halign-property) (cast Object HAlignment.Right)) - (loop (:for c choices) - (:do (def b (Button.)) - (put! (cast AvaloniaObject b) (cast AvaloniaProperty content-property) (cast Object (clr-string (.label c)))) - (put! (cast AvaloniaObject b) (cast AvaloniaProperty is-default-property) (cast Object (.enter c))) - (put! (cast AvaloniaObject b) (cast AvaloniaProperty is-cancel-property) (cast Object (.escape c))) - (on-click! (cast Control b) (fun () (close-with! w ((.answer c) input)))) - (.Add (children (cast Panel buttons)) (cast Control b)))) - (.Add (children (cast Panel panel)) (cast Control buttons)) - (put! o (cast AvaloniaProperty content-property) (cast Object panel)) - (show-dialog w owner)) - -(: (-> string (-> TextBox Object) bool bool Choice)) -(defun (choice label answer enter escape) - (Choice (label label) (answer answer) (enter enter) (escape escape))) - -;; A message, and an OK button. Sends `msg` when it is closed. -(: alert (-> string %m (#:title string) (Event %m))) -(defun (alert text msg #:title "") - (wrap (ask (fun (w) (show-box! title text None - (list (choice "OK" (fun (i) (clr-default)) #t #t)) w)) - (clr-default)) - (fun (_) msg))) - -;; A question, with OK and Cancel. Sends `(on-answer #t)` for OK, and -;; `(on-answer #f)` for Cancel, Escape or a closed window. -(: confirm (-> string (-> bool %m) (#:title string) (#:ok string) (#:cancel string) (Event %m))) -(defun (confirm text on-answer #:title "" #:ok "OK" #:cancel "Cancel") - (wrap (ask (fun (w) (show-box! title text None - (list (choice cancel (fun (i) (cast Object #f)) #f #t) - (choice ok (fun (i) (cast Object #t)) #t #f)) - w)) - (clr-default)) - (fun (answer) - (on-answer (match (non-null answer) ((Some o) (.Equals o (cast Object #t))) (None #f)))))) - -;; A question with a text input holding `#:value`. Sends `(on-answer (Some -;; text))` for OK, and `(on-answer None)` for Cancel, Escape or a closed -;; window. -(: prompt (-> string (-> (Option string) %m) (#:value string) (#:title string) (Event %m))) -(defun (prompt text on-answer #:value "" #:title "") - (wrap (ask (fun (w) (show-box! title text (Some value) - (list (choice "Cancel" (fun (i) (clr-default)) #f #t) - (choice "OK" (fun (i) (cast Object (box-text i))) #t #f)) - w)) - (clr-default)) - (fun (answer) - (on-answer (match (non-null answer) ((Some o) (Some (.ToString o))) (None None)))))) - -;; --------------------------------------------------------------------------- -;; Files -;; --------------------------------------------------------------------------- - -;; The local paths of the items. A list of Avalonia's is walked as a Seq. -(: (-> (ReadOnlyList StorageItem) (List string))) -(defun (paths items) - (loop (:for item (cast (Seq StorageItem) (cast Object items))) - (:let p (local-path item)) - (:when (not (string-empty? p))) - (:acc out (listing p)) - => out)) - -(: (-> (List string) (Array ClrString))) -(defun (clr-strings xs) - (vec->array (list->vec (list-map (fun (s) (clr-string s)) xs)))) - -(: (-> (List (Tuple string (List string))) (ReadOnlyList FileType))) -(defun (file-types filters) - (def types - (list-map (fun (f) - (def t (FileType. (fst f))) - (patterns! t (cast (ReadOnlyList ClrString) (cast Object (clr-strings (snd f))))) - t) - filters)) - (cast (ReadOnlyList FileType) (cast Object (vec->array (list->vec types))))) - -(: (-> (ReadOnlyList StorageFile))) -(defun (no-files) - (cast (ReadOnlyList StorageFile) (cast Object (: (make-array 0) (Array StorageFile))))) - -(: (-> string (List (Tuple string (List string))) bool (Event (List string)))) -(defun (ask-files title filters many?) - (wrap (ask (fun (w) - (def options (OpenOptions.)) - (unless (string-empty? title) (title! (cast PickerOptions options) title)) - (allow-multiple! options many?) - (unless (list-empty? filters) (file-types! options (file-types filters))) - (pick-files (storage-provider (cast TopLevel w)) options)) - (no-files)) - (fun (files) (paths (cast (ReadOnlyList StorageItem) (cast Object files)))))) - -(: (-> (List string) (Option string))) -(defun (first-path ps) - (match ps ((List p rest ...) (Some p)) (_ None))) - -;; Asks for a file to open. Sends `(on-answer (Some path))`, or `(on-answer -;; None)` when the picker is cancelled. `#:filters` are the kinds of file it -;; shows, each a name and patterns: `(list (Tuple "Text" '("*.txt" "*.md")))`. -(: open-file (-> (-> (Option string) %m) (#:title string) - (#:filters (List (Tuple string (List string)))) (Event %m))) -(defun (open-file on-answer #:title "" #:filters '()) - (wrap (ask-files title filters #f) (fun (ps) (on-answer (first-path ps))))) - -;; Asks for files to open. Sends `(on-answer paths)`, empty when the picker -;; is cancelled. -(: open-files (-> (-> (List string) %m) (#:title string) - (#:filters (List (Tuple string (List string)))) (Event %m))) -(defun (open-files on-answer #:title "" #:filters '()) - (wrap (ask-files title filters #t) on-answer)) - -;; Asks where to save a file. Sends `(on-answer (Some path))`, or `(on-answer -;; None)` when the picker is cancelled. The file is not made. -(: save-file (-> (-> (Option string) %m) (#:title string) (#:name string) (Event %m))) -(defun (save-file on-answer #:title "" #:name "") - (wrap (ask (fun (w) - (def options (SaveOptions.)) - (unless (string-empty? title) (title! (cast PickerOptions options) title)) - (unless (string-empty? name) (suggested-name! options name)) - (pick-save (storage-provider (cast TopLevel w)) options)) - (: (clr-default) StorageFile)) - (fun (f) - (on-answer (if (null? (cast Object f)) - None - (match (local-path (cast StorageItem f)) - ("" None) - (p (Some p)))))))) - -;; Asks for a folder. Sends `(on-answer (Some path))`, or `(on-answer None)` -;; when the picker is cancelled. -(: open-folder (-> (-> (Option string) %m) (#:title string) (Event %m))) -(defun (open-folder on-answer #:title "") - (wrap (ask (fun (w) - (def options (FolderOptions.)) - (unless (string-empty? title) (title! (cast PickerOptions options) title)) - (pick-folders (storage-provider (cast TopLevel w)) options)) - (cast (ReadOnlyList StorageFolder) (cast Object (: (make-array 0) (Array StorageFolder))))) - (fun (folders) (on-answer (first-path (paths (cast (ReadOnlyList StorageItem) (cast Object folders)))))))) - -;; --------------------------------------------------------------------------- -;; Quitting -;; --------------------------------------------------------------------------- - -;; Closes the app's windows, and so ends `run-app`. Sends nothing. This is how -;; a program closes after it was asked with `#:on-close`. -(: quit (-> (Event %m))) -(defun (quit) - (guard (fun () - (ignore (ui-post ui-dispatcher - (fun () - (def app (cast Object current-app)) - (unless (null? app) - (match (try (cast Lifetime (app-lifetime (cast Application app))) - #:catch (System.InvalidCastException - System.NullReferenceException)) - ((Ok lifetime) (shutdown! lifetime 0)) - ((Err _) unit))) - unit))) - (never)))) diff --git a/src/view.bjo b/src/view.bjo index 5b63129..d1fc949 100644 --- a/src/view.bjo +++ b/src/view.bjo @@ -20,15 +20,9 @@ ;; Constructors. text button text-input text-area checkbox slider progress-bar dropdown image list-box tabs tab - 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 + column row grid scroll border ;; Wrappers. - keyed at paint with-context-menu tooltip at-top at-bottom at-left at-right classed - - ;; Keyboard shortcuts. - Key key key-gesture key-message + keyed at paint ;; Reading one. view-kind view-props view-events view-children view-key) @@ -43,58 +37,47 @@ (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 (: 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 +(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 ;; An event, and the message it sends. -(type (: (On %m) (Union (: OnClick %m) - (: OnInput (-> string %m)) - (: OnToggle (-> bool %m)) - (: OnSlide (-> double %m)) - (: OnSelect (-> int %m)) - (: OnPick (-> string %m))))) +(type (: (On %m) (Union (: Click %m) + (: Input (-> string %m)) + (: Toggle (-> bool %m)) + (: Slide (-> double %m)) + (: Select (-> int %m))))) ;; One control and what is in it. ;; @@ -139,49 +122,14 @@ (: 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) 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)) + (record-set v (props (with (with (.props v) Foreground colour) Background background)))) ;; 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) (PropRow row)) (PropColumn column)) - (PropRowSpan row-span)) - (PropColumnSpan column-span))))) + (record-set v (props (vec-add (vec-add (vec-add (vec-add (.props v) (Row row)) (Column column)) + (RowSpan row-span)) + (ColumnSpan column-span))))) ;; --------------------------------------------------------------------------- ;; Constructors @@ -196,9 +144,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 PropWidth width) PropHeight height) - PropMargin margin) - PropPadding padding)) + (with-size (with-size (with-size (with-size props Width width) Height height) + Margin margin) + Padding padding)) (: (-> Kind (Vec Prop) (Vec (On %m)) (View %m))) (defun (leaf kind props events) @@ -210,7 +158,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 [(PropLabel s) (PropWrap wrap)] PropFontSize size) width height margin 0.0) + (with-layout (with-size [(Label s) (Wrap wrap)] FontSize size) width height margin 0.0) [])) ;; A button that sends `msg` when it is clicked. @@ -219,8 +167,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 [(PropLabel label) (PropEnabled enabled)] width height margin padding) - [(OnClick msg)])) + (with-layout [(Label label) (Enabled enabled)] width height margin padding) + [(Click msg)])) ;; A one-line text input that holds `value`. Each change sends `(on-input ;; text)`, with the whole text. @@ -229,9 +177,9 @@ (View %m))) (defun (text-input value on-input #:placeholder "" #:enabled #t #:width 0.0 #:margin 0.0) (leaf TextInputKind - (with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)] + (with-layout [(Value value) (Placeholder placeholder) (Enabled enabled)] width 0.0 margin 0.0) - [(OnInput on-input)])) + [(Input on-input)])) ;; A text input of several lines, that breaks its lines at its width. Each ;; change sends `(on-input text)`, with the whole text. @@ -241,9 +189,9 @@ (defun (text-area value on-input #:placeholder "" #:enabled #t #:width 0.0 #:height 0.0 #:margin 0.0) (leaf TextAreaKind - (with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)] + (with-layout [(Value value) (Placeholder placeholder) (Enabled enabled)] width height margin 0.0) - [(OnInput on-input)])) + [(Input on-input)])) ;; A slider at `value`, from `minimum` to `maximum`. A move sends `(on-change ;; value)`. @@ -255,17 +203,17 @@ ;; The bounds come before the value, because a value outside the bounds ;; that are there is moved inside them. (leaf SliderKind - (with-layout [(PropMinimum minimum) (PropMaximum maximum) (PropAmount value) (PropStep step) - (PropEnabled enabled)] + (with-layout [(Minimum minimum) (Maximum maximum) (Amount value) (Step step) + (Enabled enabled)] width 0.0 margin 0.0) - [(OnSlide on-change)])) + [(Slide on-change)])) ;; A bar that is `value` of the way from 0 to `#:maximum`, 1 unless told ;; 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 [(PropMinimum 0.0) (PropMaximum maximum) (PropAmount value)] width 0.0 margin 0.0) + (with-layout [(Minimum 0.0) (Maximum maximum) (Amount value)] width 0.0 margin 0.0) [])) ;; A list to choose one of `options` from, with the one at `selected` chosen, @@ -276,15 +224,15 @@ ;; The items come before the choice, because the choice is an index into ;; them. (leaf DropdownKind - (with-layout [(PropItems options) (PropSelected selected) (PropEnabled enabled)] + (with-layout [(Items options) (Selected selected) (Enabled enabled)] width 0.0 margin 0.0) - [(OnSelect on-select)])) + [(Select on-select)])) ;; The picture in the file at `path`. A file that cannot be read shows ;; 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 [(PropSource path)] width height margin 0.0) [])) + (leaf ImageKind (with-layout [(Source path)] width height margin 0.0) [])) ;; A list of views to choose one of, with the one at `selected` chosen, or ;; none for -1. A choice sends `(on-select index)`. Give the items keys if @@ -293,8 +241,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 [(PropSelected selected)] width height margin 0.0)) - (events [(OnSelect on-select)]) + (props (with-layout [(Selected selected)] width height margin 0.0)) + (events [(Select on-select)]) (children items) (key None))) @@ -303,128 +251,23 @@ (: (-> 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 [(PropSelected selected)] 0.0 0.0 margin 0.0)) - (events [(OnSelect on-select)]) + (props (with-layout [(Selected selected)] 0.0 0.0 margin 0.0)) + (events [(Select 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 [(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)))) + (View (kind TabKind) (props [(Label header)]) (events []) (children [content]) (key None))) ;; 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 [(PropLabel label) (PropChecked checked?) (PropEnabled enabled)] 0.0 0.0 margin 0.0) - [(OnToggle on-toggle)])) + (with-layout [(Label label) (Checked checked?) (Enabled enabled)] 0.0 0.0 margin 0.0) + [(Toggle on-toggle)])) (: (-> Kind (Vec Prop) (Vec (View %m)) (View %m))) (defun (container kind props children) @@ -432,7 +275,7 @@ (: (-> Kind double double (Array (View %m)) (View %m))) (defun (stack kind spacing margin children) - (container kind (with-layout (with-size [] PropSpacing spacing) 0.0 0.0 margin 0.0) + (container kind (with-layout (with-size [] Spacing spacing) 0.0 0.0 margin 0.0) (array->vec children))) ;; Views one above the other. @@ -453,7 +296,7 @@ #:rest (View %m) (View %m))) (defun (grid #:columns "*" #:rows "*" #:spacing 0.0 #:margin 0.0 #:rest children) (container GridKind - (with-layout (with-size [(PropColumns columns) (PropRows rows)] PropSpacing spacing) + (with-layout (with-size [(Columns columns) (Rows rows)] Spacing spacing) 0.0 0.0 margin 0.0) (array->vec children))) @@ -468,43 +311,13 @@ (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) - PropBorderWidth thickness) - PropRadius radius) - PropBorderColour colour) - PropBackground background) + BorderWidth thickness) + Radius radius) + BorderColour colour) + Background 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 deleted file mode 100644 index 951a452..0000000 --- a/tests/dialogs.bjo +++ /dev/null @@ -1,54 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public -;; License, v. 2.0. If a copy of the MPL was not distributed with this -;; file, You can obtain one at http://mozilla.org/MPL/2.0/. - -;; bjogui/tests/dialogs.bjo — dialogs and pickers with no window. -;; -;; bjo run tests/dialogs.bjo -;; -;; A dialog needs a window to belong to, and an app started with `start-app` -;; has none. So each answers as if it was cancelled, and that is what this -;; checks: that the command goes to the UI thread and back, and its message -;; comes. A dialog on a screen is looked at by a person. - -(import (std prelude)) -(import (std simpletest)) -(import (bjogui view)) -(import (bjogui app)) -(import (bjogui dialogs)) - -(import/extern - (sleep-ms (: System.Threading.Thread.Sleep (-> int void) #:blocking))) - -(type (: Msg (Union Ask (: Answer string)))) - -(: (-> Msg (List string) (Tuple (List string) (List (Event Msg))))) -(defun (gui-update msg answers) - (match msg - (Ask (next answers - (alert "Saved." (Answer "alert")) - (confirm "Delete?" (fun (b) (Answer #"confirm ${b}"))) - (prompt "Name?" (fun (s) (Answer #"prompt ${(option-ref-or s "none")}")) #:value "Ada") - (open-file (fun (p) (Answer #"open-file ${(option-ref-or p "none")}"))) - (open-files (fun (ps) (Answer #"open-files ${(length ps)}"))) - (save-file (fun (p) (Answer #"save-file ${(option-ref-or p "none")}")) #:name "a.txt") - (open-folder (fun (p) (Answer #"open-folder ${(option-ref-or p "none")}"))) - (quit))) - ((Answer s) (next (cons s answers))))) - -(defun (main) - (def app (start-app '() gui-update (fun (m) (text "")) (fun (c) unit))) - (app-dispatch! app Ask) - (let go ((tries 0)) - (app-run-pending! app) - (when (and (< (length (app-model app)) 7) (< tries 300)) - (sleep-ms 10) - (go (+ tries 1)))) - (def answers (list-sort (app-model app))) - (expect "every dialog answered" (length answers) 7) - (expect "the answers with no window" - answers - (list-sort '("alert" "confirm #f" "prompt none" "open-file none" "open-files 0" - "save-file none" "open-folder none"))) - (app-stop! app) - (println "bjogui dialogs ok")) diff --git a/tests/inputs.bjo b/tests/inputs.bjo deleted file mode 100644 index dab22b4..0000000 --- a/tests/inputs.bjo +++ /dev/null @@ -1,144 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public -;; License, v. 2.0. If a copy of the MPL was not distributed with this -;; file, You can obtain one at http://mozilla.org/MPL/2.0/. - -;; bjogui/tests/inputs.bjo — switches, radios, numbers, dates, completion, -;; expanders, tooltips, flows and docks. -;; -;; bjo run tests/inputs.bjo -;; -;; No window is opened. A control is changed as a user's input would change -;; it, through its Avalonia property, and the message is checked. - -(import (std prelude)) -(import (std simpletest)) -(import (bjogui view)) -(import (bjogui app)) - -(import/class - (Object (: System.Object)) - (ClrString (: System.String)) - (Disposable (: System.IDisposable)) - (AvaloniaObject (: Avalonia.AvaloniaObject)) - (AvaloniaProperty (: Avalonia.AvaloniaProperty)) - (Priority (: Avalonia.Data.BindingPriority)) - (Control (: Avalonia.Controls.Control)) - (Controls (: Avalonia.Controls.Controls)) - (Panel (: Avalonia.Controls.Panel)) - (ToggleButton (: Avalonia.Controls.Primitives.ToggleButton)) - (NumericUpDown (: Avalonia.Controls.NumericUpDown)) - (DatePicker (: Avalonia.Controls.DatePicker)) - (DateTimeOffset (: System.DateTimeOffset)) - (AutoCompleteBox (: Avalonia.Controls.AutoCompleteBox)) - (Expander (: Avalonia.Controls.Expander)) - (DockEdge (: Avalonia.Controls.Dock)) - (StyledElement (: Avalonia.StyledElement)) - (Classes (: Avalonia.Controls.Classes)) - ((Nullable %a) (: System.Nullable))) - -(import/extern - (set-value (: Avalonia.AvaloniaObject.SetValue - (-> AvaloniaObject AvaloniaProperty Object Priority Disposable))) - (checked-property (: Avalonia.Controls.Primitives.ToggleButton.IsCheckedProperty #:get)) - (number-property (: Avalonia.Controls.NumericUpDown.ValueProperty #:get)) - (date-property (: Avalonia.Controls.DatePicker.SelectedDateProperty #:get)) - (auto-property (: Avalonia.Controls.AutoCompleteBox.TextProperty #:get)) - (expanded-property (: Avalonia.Controls.Expander.IsExpandedProperty #:get)) - (is-checked (: Avalonia.Controls.Primitives.ToggleButton.IsChecked - (-> ToggleButton (Nullable bool)) #:get)) - (number-value (: Avalonia.Controls.NumericUpDown.Value (-> NumericUpDown (Nullable decimal)) #:get)) - (selected-date (: Avalonia.Controls.DatePicker.SelectedDate (-> DatePicker (Nullable DateTimeOffset)) #:get)) - (parse-date (: System.DateTimeOffset.Parse (-> string DateTimeOffset))) - (expanded? (: Avalonia.Controls.Expander.IsExpanded (-> Expander bool) #:get)) - (tip-of (: Avalonia.Controls.ToolTip.GetTip (-> Control Object))) - (dock-of (: Avalonia.Controls.DockPanel.GetDock (-> Control DockEdge))) - (children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get)) - (count (: Avalonia.Controls.Controls.Count (-> Controls int) #:get)) - (classes-of (: Avalonia.StyledElement.Classes (-> StyledElement Classes) #:get)) - (clr-string (: System.Convert.ToString (-> string ClrString)))) - -(type (: Msg (Union (: Switched bool) (: Picked string) (: Amount double) (: Dated string) - (: Typed string) (: Opened bool)))) -(type (: Model (Record (: on bool) (: pick string) (: amount double) (: date string) - (: typed string) (: open bool)))) - -(: (-> Msg Model (Tuple Model (List (Event Msg))))) -(defun (gui-update msg m) - (next (match msg - ((Switched b) (record-set m (on b))) - ((Picked s) (record-set m (pick s))) - ((Amount d) (record-set m (amount d))) - ((Dated s) (record-set m (date s))) - ((Typed s) (record-set m (typed s))) - ((Opened b) (record-set m (open b)))))) - -(: (-> Model (View Msg))) -(defun (view m) - (column - (toggle-switch "Wi-Fi" (.on m) Switched) ; 0 - (row (radio "tea" (= (.pick m) "tea") (Picked "tea")) ; 1 0 - (radio "coffee" (= (.pick m) "coffee") (Picked "coffee"))) ; 1 1 - (number-input (.amount m) Amount #:minimum 0.0 #:maximum 10.0 #:step 0.5) ; 2 - (date-picker (.date m) Dated) ; 3 - (auto-complete (.typed m) ["apple" "apricot" "banana"] Typed) ; 4 - (expander "More" (.open m) Opened (text "inside")) ; 5 - (tooltip (text "hover me") "a tip") ; 6 - (flow #:spacing 4.0 (text "a") (text "b") (text "c")) ; 7 - (dock (at-top (text "top")) (text "fill")) ; 8 - (if (.open m) (classed (text "c") "wide") (classed (text "c") "big" "red")))) ; 9 - -(defun (main) - (def app (start-app (Model (on #f) (pick "tea") (amount 2.0) (date "2026-10-25") - (typed "") (open #f)) - gui-update view (fun (c) unit))) - (defun (ctl path) (app-control-at app path)) - (defun (put! path property value) - (ignore (set-value (cast AvaloniaObject (ctl path)) property value Priority.LocalValue))) - (defun (model) (app-model app)) - - ;; --- switch and radios -------------------------------------------------------- - (put! '(0) (cast AvaloniaProperty checked-property) (cast Object #t)) - (expect "a switch sends its state" (.on (model)) #t) - (expect "a radio shows the model's choice" - (.GetValueOrDefault (is-checked (cast ToggleButton (ctl '(1 0))))) #t) - (put! '(1 1) (cast AvaloniaProperty checked-property) (cast Object #t)) - (expect "choosing a radio sends its message" (.pick (model)) "coffee") - (expect "the other one is not chosen any more" - (.GetValueOrDefault (is-checked (cast ToggleButton (ctl '(1 0))))) #f) - - ;; --- number --------------------------------------------------------------------- - (expect "a number input's value" (cast System.Double (.GetValueOrDefault (number-value (cast NumericUpDown (ctl '(2)))))) 2.0) - (put! '(2) (cast AvaloniaProperty number-property) (cast Object (cast System.Decimal 3.5))) - (expect "a number sends its value" (.amount (model)) 3.5) - - ;; --- date ----------------------------------------------------------------------- - (expect "a date picker's date" (.ToString (.-Value (selected-date (cast DatePicker (ctl '(3))))) "yyyy-MM-dd") - "2026-10-25") - (put! '(3) (cast AvaloniaProperty date-property) (cast Object (parse-date "2026-12-24"))) - (expect "a date picked is sent" (.date (model)) "2026-12-24") - - ;; --- completion ------------------------------------------------------------------- - (put! '(4) (cast AvaloniaProperty auto-property) (cast Object (clr-string "ap"))) - (expect "completion sends what is typed" (.typed (model)) "ap") - - ;; --- expander --------------------------------------------------------------------- - (expect "an expander starts closed" (expanded? (cast Expander (ctl '(5)))) #f) - (put! '(5) (cast AvaloniaProperty expanded-property) (cast Object #t)) - (expect "opening it sends a message" (.open (model)) #t) - - ;; --- tooltip, flow, dock --------------------------------------------------------- - (expect "a tooltip" (.ToString (tip-of (ctl '(6)))) "a tip") - (expect "a flow's children" (count (children (cast Panel (ctl '(7))))) 3) - (expect "a docked child" (written (dock-of (ctl '(8 0)))) "Top") - - ;; --- classes --------------------------------------------------------------------- - ;; The expander was opened above, so the view has "wide" and not the others. - (def cls (classes-of (cast StyledElement (ctl '(9))))) - (defun (has-class? (: c Classes) (: name string)) (.Contains c name)) - (expect "a class" (has-class? cls "wide") #t) - (expect "the classes of the last view are gone" (has-class? cls "big") #f) - (put! '(5) (cast AvaloniaProperty expanded-property) (cast Object #f)) - (expect "and change with the model" (list (has-class? cls "big") (has-class? cls "red") (has-class? cls "wide")) - '(#t #t #f)) - - (println "bjogui inputs ok")) diff --git a/tests/menus.bjo b/tests/menus.bjo deleted file mode 100644 index 6115d32..0000000 --- a/tests/menus.bjo +++ /dev/null @@ -1,118 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public -;; License, v. 2.0. If a copy of the MPL was not distributed with this -;; file, You can obtain one at http://mozilla.org/MPL/2.0/. - -;; bjogui/tests/menus.bjo — menus, context menus and keyboard shortcuts. -;; -;; bjo run tests/menus.bjo -;; -;; No window is opened. A click is raised on a menu item as Avalonia raises -;; it, and keys are pressed with `app-press!`, which is what the window's -;; handler calls. - -(import (std prelude)) -(import (std simpletest)) -(import (bjogui view)) -(import (bjogui app)) - -(import/class - (Object (: System.Object)) - (Control (: Avalonia.Controls.Control)) - (Interactive (: Avalonia.Interactivity.Interactive)) - (RoutedEvent (: Avalonia.Interactivity.RoutedEvent)) - (RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs (-> RoutedEvent RoutedEventArgs))) - (ItemsControl (: Avalonia.Controls.ItemsControl)) - (MenuItem (: Avalonia.Controls.MenuItem)) - (Headered (: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl)) - (KeyGesture (: Avalonia.Input.KeyGesture)) - (ContextMenu (: Avalonia.Controls.ContextMenu))) - -(import/extern - (menu-click-event (: Avalonia.Controls.MenuItem.ClickEvent #:get)) - (raise-event (: Avalonia.Interactivity.Interactive.RaiseEvent (-> Interactive RoutedEventArgs void))) - (item-count (: Avalonia.Controls.ItemsControl.ItemCount (-> ItemsControl int) #:get)) - (header (: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl.Header - (-> Headered Object) #:get)) - (input-gesture (: Avalonia.Controls.MenuItem.InputGesture (-> MenuItem KeyGesture) #:get)) - (context-menu (: Avalonia.Controls.Control.ContextMenu (-> Control ContextMenu) #:get))) - -;; --------------------------------------------------------------------------- -;; The program under test -;; --------------------------------------------------------------------------- - -(type (: Msg (Union New (: Open string) Quit Copy Refresh AllowQuit))) -(type (: Model (Record (: log (List string)) (: can-quit bool)))) - -(: (-> Msg Model (Tuple Model (List (Event Msg))))) -(defun (gui-update msg m) - (defun (log s) (record-set m (log (cons s (.log m))))) - (next (match msg - (New (log "new")) - ((Open f) (log (string-append "open " f))) - (Quit (log "quit")) - (Copy (log "copy")) - (Refresh (log "refresh")) - (AllowQuit (record-set m (can-quit #t)))))) - -(: (-> Model (View Msg))) -(defun (view m) - (column - (menu-bar ; 0 - (submenu "File" ; 0 0 - (menu-item "New" New #:shortcut "Ctrl+N") ; 0 0 0 - (menu-separator) ; 0 0 1 - (submenu "Recent" ; 0 0 2 - (menu-item "notes.txt" (Open "notes.txt"))) ; 0 0 2 0 - (menu-item "Quit" Quit #:shortcut "Ctrl+Q" #:enabled (.can-quit m)))) - (with-context-menu (text "right click me") ; 1 - (menu-item "Copy" Copy #:shortcut "Ctrl+C")))) - -(: (-> Model (List (Key Msg)))) -(defun (keys m) (list (key "F5" Refresh))) - -;; --------------------------------------------------------------------------- -;; The test -;; --------------------------------------------------------------------------- - -(defun (main) - (def app (start-app (Model (log '()) (can-quit #f)) gui-update view (fun (c) unit) - #:keys keys)) - (defun (ctl path) (app-control-at app path)) - (defun (click path) - (raise-event (cast Interactive (ctl path)) - (RoutedEventArgs. (cast RoutedEvent menu-click-event)))) - (defun (history) (.log (app-model app))) - - ;; --- the menu bar ------------------------------------------------------------- - (expect "one menu" (item-count (cast ItemsControl (ctl '(0)))) 1) - (expect "its items, with the separator" (item-count (cast ItemsControl (ctl '(0 0)))) 4) - (expect "a header" (.ToString (header (cast Headered (ctl '(0 0 0))))) "New") - (expect "a shortcut is shown" (.ToString (cast Object (input-gesture (cast MenuItem (ctl '(0 0 0)))))) - "Ctrl+N") - - (click '(0 0 0)) - (expect "an item chosen is a message" (history) '("new")) - ;; The click bubbles through "Recent" and "File"; only the item answers. - (click '(0 0 2 0)) - (expect "an item in a submenu, once" (history) '("open notes.txt" "new")) - - ;; --- the context menu ------------------------------------------------------- - (def cm (context-menu (ctl '(1)))) - (expect "the context menu is the view's" (eq? (cast Object cm) (cast Object (ctl '(1 1)))) #t) - (expect "its items" (item-count (cast ItemsControl cm)) 1) - (click '(1 1 0)) - (expect "a context menu item" (first (history)) (Some "copy")) - - ;; --- keys ----------------------------------------------------------------------- - (expect "a menu item's shortcut" (app-press! app "Ctrl+N") #t) - (expect "sends its message" (first (history)) (Some "new")) - (expect "a context menu's shortcut too" (app-press! app "Ctrl+C") #t) - (expect "a disabled item's shortcut does nothing" (app-press! app "Ctrl+Q") #f) - (app-dispatch! app AllowQuit) - (expect "until it is enabled" (app-press! app "Ctrl+Q") #t) - (expect "the app's own keys" (app-press! app "F5") #t) - (expect "and their message" (first (history)) (Some "refresh")) - (expect "keys bound to nothing" (app-press! app "Ctrl+X") #f) - (expect "keys that cannot be read" (app-press! app "Ctrl+Nope") #f) - - (println "bjogui menus ok")) diff --git a/tests/tree.bjo b/tests/tree.bjo deleted file mode 100644 index 68f5af8..0000000 --- a/tests/tree.bjo +++ /dev/null @@ -1,84 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public -;; License, v. 2.0. If a copy of the MPL was not distributed with this -;; file, You can obtain one at http://mozilla.org/MPL/2.0/. - -;; bjogui/tests/tree.bjo — tree views. -;; -;; bjo run tests/tree.bjo -;; -;; No window is opened. - -(import (std prelude)) -(import (std simpletest)) -(import (std interop)) -(import (bjogui view)) -(import (bjogui app)) - -(import/class - (Object (: System.Object)) - (Disposable (: System.IDisposable)) - (AvaloniaObject (: Avalonia.AvaloniaObject)) - (AvaloniaProperty (: Avalonia.AvaloniaProperty)) - (Priority (: Avalonia.Data.BindingPriority)) - (ItemsControl (: Avalonia.Controls.ItemsControl)) - (TreeView (: Avalonia.Controls.TreeView)) - (TreeViewItem (: Avalonia.Controls.TreeViewItem)) - (Headered (: Avalonia.Controls.Primitives.HeaderedItemsControl))) - -(import/extern - (set-value (: Avalonia.AvaloniaObject.SetValue - (-> AvaloniaObject AvaloniaProperty Object Priority Disposable))) - (selected-property (: Avalonia.Controls.TreeView.SelectedItemProperty #:get)) - (selected (: Avalonia.Controls.TreeView.SelectedItem (-> TreeView Object) #:get)) - (item-count (: Avalonia.Controls.ItemsControl.ItemCount (-> ItemsControl int) #:get)) - (header (: Avalonia.Controls.Primitives.HeaderedItemsControl.Header (-> Headered Object) #:get)) - (expanded? (: Avalonia.Controls.TreeViewItem.IsExpanded (-> TreeViewItem bool) #:get)) - (same? (: System.Object.ReferenceEquals (-> Object Object bool)))) - -(type (: Msg (Union (: Chose string) Reverse))) -(type (: Model (Record (: chosen string) (: fruit (List string))))) - -(: (-> Msg Model (Tuple Model (List (Event Msg))))) -(defun (gui-update msg m) - (next (match msg - ((Chose k) (record-set m (chosen k))) - (Reverse (record-set m (fruit (list-reverse (.fruit m)))))))) - -(: (-> Model (View Msg))) -(defun (view m) - (tree-view (.chosen m) Chose - (apply tree-node "fruit" "Fruit" #:expanded #t - (vec->array (vec-map (fun (f) (tree-node f (string-upcase f))) (list->vec (.fruit m))))) - (tree-node "veg" "Vegetables" - (tree-node "kale" "KALE")))) - -(defun (main) - (def app (start-app (Model (chosen "pear") (fruit '("apple" "pear"))) - gui-update view (fun (c) unit))) - (defun (ctl path) (app-control-at app path)) - (def tree (cast TreeView (ctl '()))) - (defun (chosen-is? path) (same? (selected tree) (cast Object (ctl path)))) - - (expect "the top nodes" (item-count (cast ItemsControl tree)) 2) - (expect "a node's nodes" (item-count (cast ItemsControl (ctl '(0)))) 2) - (expect "a header" (.ToString (header (cast Headered (ctl '(0 1))))) "PEAR") - (expect "open at first" (expanded? (cast TreeViewItem (ctl '(0)))) #t) - (expect "closed at first" (expanded? (cast TreeViewItem (ctl '(1)))) #f) - (expect "the chosen node is chosen once the nodes are there" (chosen-is? '(0 1)) #t) - - (ignore (set-value (cast AvaloniaObject tree) (cast AvaloniaProperty selected-property) - (cast Object (ctl '(1 0))) Priority.LocalValue)) - (expect "a node chosen sends its key" (.chosen (app-model app)) "kale") - - (app-dispatch! app (Chose "apple")) - (expect "the model chooses the node" (chosen-is? '(0 0)) #t) - - (def apple (ctl '(0 0))) - (app-dispatch! app Reverse) - (expect "nodes moved by key keep their controls" (same? (cast Object (ctl '(0 1))) (cast Object apple)) #t) - (expect "and the choice" (chosen-is? '(0 1)) #t) - - (app-dispatch! app (Chose "")) - (expect "no choice" (same? (selected tree) (clr-default)) #t) - - (println "bjogui tree ok"))