Linus Björnstam
be288ac03e
A menu bar, submenus and menu items are views. A menu item's items are an ItemsControl's, so they are patched as a list's. A context menu wraps a view: the view and its menu are two places of the wrapper. Keys are matched in the window's KeyDown, after the focused control had its chance: an enabled menu item in the view whose shortcut it is, or else the app's #:keys. Avalonia's own key bindings take an ICommand, which a Bjolang program cannot make. app-press! presses keys for a test. 🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8) Co-Authored-By: eca-agent <git@eca.dev>
1103 lines
51 KiB
Text
1103 lines
51 KiB
Text
;; 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/app.bjo — the module (bjogui app).
|
|
;;
|
|
;; Runs a program written as a model, a `gui-update` and a `view`, in an
|
|
;; Avalonia window. Every Avalonia name stays in this module: what it exports
|
|
;; takes and gives Bjolang values, and a control only as an opaque `Control`.
|
|
;;
|
|
;; The loop: an event finds its message in the view the control was last
|
|
;; given. `gui-update` makes the next model from it, and `view` the next view.
|
|
;; The next view is compared with the last one, control by control, and only
|
|
;; what differs is changed. So a control keeps its focus, its caret and its
|
|
;; scroll position when the model changes.
|
|
;;
|
|
;; `gui-update` does no work of its own: it is a plain function, so it cannot
|
|
;; wait. Work is a value it returns. A command is an `(Event %m)`: the app
|
|
;; syncs it in a fiber, and gives the message it answers to `gui-update`. A
|
|
;; subscription is a source of messages that runs as long as the model asks
|
|
;; for it: after each update the app starts the subscriptions that are new
|
|
;; and stops those that are gone.
|
|
;;
|
|
;; Every control is made with plain constructors and changed with
|
|
;; `AvaloniaObject.SetValue`, so no Avalonia class is subclassed.
|
|
|
|
(export
|
|
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!
|
|
app-model app-control app-control-at)
|
|
|
|
(import (std prelude))
|
|
(import (std interop))
|
|
(import (std mutable vec))
|
|
(import (std mutable map))
|
|
(import (bjogui view))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; Avalonia
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(import/class
|
|
(Object (: System.Object))
|
|
(InvalidOperation (: System.InvalidOperationException (-> string InvalidOperation)))
|
|
(ClrString (: System.String))
|
|
(Disposable (: System.IDisposable))
|
|
(Services (: System.IServiceProvider))
|
|
((Nullable %a) (: System.Nullable))
|
|
((EventHandler %a) (: System.EventHandler))
|
|
(AvaloniaObject (: Avalonia.AvaloniaObject))
|
|
(AvaloniaProperty (: Avalonia.AvaloniaProperty))
|
|
(Priority (: Avalonia.Data.BindingPriority))
|
|
(Thickness (: Avalonia.Thickness (-> double Thickness)))
|
|
(Orientation (: Avalonia.Layout.Orientation))
|
|
(HAlignment (: Avalonia.Layout.HorizontalAlignment))
|
|
(VAlignment (: Avalonia.Layout.VerticalAlignment))
|
|
(Control (: Avalonia.Controls.Control))
|
|
(Grid (: Avalonia.Controls.Grid (-> Grid)))
|
|
(ColumnDefs (: Avalonia.Controls.ColumnDefinitions))
|
|
(RowDefs (: Avalonia.Controls.RowDefinitions))
|
|
(ScrollViewer (: Avalonia.Controls.ScrollViewer (-> ScrollViewer)))
|
|
(Slider (: Avalonia.Controls.Slider (-> Slider)))
|
|
(ProgressBar (: Avalonia.Controls.ProgressBar (-> ProgressBar)))
|
|
(RangeBase (: Avalonia.Controls.Primitives.RangeBase))
|
|
(ComboBox (: Avalonia.Controls.ComboBox (-> ComboBox)))
|
|
(SelectingItemsControl (: Avalonia.Controls.Primitives.SelectingItemsControl))
|
|
(Image (: Avalonia.Controls.Image (-> Image)))
|
|
(Bitmap (: Avalonia.Media.Imaging.Bitmap (-> string Bitmap)))
|
|
(TextWrapping (: Avalonia.Media.TextWrapping))
|
|
(IBrush (: Avalonia.Media.IBrush))
|
|
(CornerRadius (: Avalonia.CornerRadius (-> double CornerRadius)))
|
|
(ListBox (: Avalonia.Controls.ListBox (-> ListBox)))
|
|
(TabControl (: Avalonia.Controls.TabControl (-> TabControl)))
|
|
(TabItem (: Avalonia.Controls.TabItem (-> TabItem)))
|
|
(Border (: Avalonia.Controls.Border (-> Border)))
|
|
(ItemsControl (: Avalonia.Controls.ItemsControl))
|
|
(ItemCollection (: Avalonia.Controls.ItemCollection))
|
|
(IList (: System.Collections.IList))
|
|
(Menu (: Avalonia.Controls.Menu (-> Menu)))
|
|
(MenuItem (: Avalonia.Controls.MenuItem (-> MenuItem)))
|
|
(Separator (: Avalonia.Controls.Separator (-> Separator)))
|
|
(ContextMenu (: Avalonia.Controls.ContextMenu (-> ContextMenu)))
|
|
(KeyGesture (: Avalonia.Input.KeyGesture (-> KeyCode KeyModifiers KeyGesture)))
|
|
(KeyCode (: Avalonia.Input.Key))
|
|
(KeyModifiers (: Avalonia.Input.KeyModifiers))
|
|
(KeyEventArgs (: Avalonia.Input.KeyEventArgs))
|
|
(ICollection (: System.Collections.ICollection))
|
|
(Timer (: Avalonia.Threading.DispatcherTimer (-> Timer)))
|
|
(TimeSpan (: System.TimeSpan))
|
|
(EventArgs (: System.EventArgs))
|
|
(PixelSize (: Avalonia.PixelSize (-> int int PixelSize)))
|
|
(Vector (: Avalonia.Vector (-> double double Vector)))
|
|
(Visual (: Avalonia.Visual))
|
|
(RenderBitmap (: Avalonia.Media.Imaging.RenderTargetBitmap (-> PixelSize Vector RenderBitmap)))
|
|
(Controls (: Avalonia.Controls.Controls))
|
|
(Panel (: Avalonia.Controls.Panel))
|
|
(StackPanel (: Avalonia.Controls.StackPanel (-> StackPanel)))
|
|
(TextBlock (: Avalonia.Controls.TextBlock (-> TextBlock)))
|
|
(Button (: Avalonia.Controls.Button (-> Button)))
|
|
(TextBox (: Avalonia.Controls.TextBox (-> TextBox)))
|
|
(CheckBox (: Avalonia.Controls.CheckBox (-> CheckBox)))
|
|
(ToggleButton (: Avalonia.Controls.Primitives.ToggleButton))
|
|
(ContentControl (: Avalonia.Controls.ContentControl))
|
|
(Window (: Avalonia.Controls.Window (-> Window)))
|
|
(Interactive (: Avalonia.Interactivity.Interactive))
|
|
(RoutedEvent (: Avalonia.Interactivity.RoutedEvent))
|
|
(RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs))
|
|
(Routes (: Avalonia.Interactivity.RoutingStrategies))
|
|
(Application (: Avalonia.Application (-> Application)))
|
|
(Styles (: Avalonia.Styling.Styles))
|
|
(FluentTheme (: Avalonia.Themes.Fluent.FluentTheme (-> Services FluentTheme)))
|
|
(AppBuilder (: Avalonia.AppBuilder))
|
|
(ILifetime (: Avalonia.Controls.ApplicationLifetimes.IApplicationLifetime))
|
|
(Lifetime (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime
|
|
(-> Lifetime)))
|
|
(Dispatcher (: Avalonia.Threading.Dispatcher))
|
|
(UiPriority (: Avalonia.Threading.DispatcherPriority))
|
|
((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation)))
|
|
|
|
(import/extern
|
|
;; Properties, as the objects `SetValue` takes.
|
|
(text-block-text (: Avalonia.Controls.TextBlock.TextProperty #:get))
|
|
(text-block-font-size (: Avalonia.Controls.TextBlock.FontSizeProperty #:get))
|
|
(content-property (: Avalonia.Controls.ContentControl.ContentProperty #:get))
|
|
(text-box-text (: Avalonia.Controls.TextBox.TextProperty #:get))
|
|
(watermark-property (: Avalonia.Controls.TextBox.WatermarkProperty #:get))
|
|
(is-checked-property (: Avalonia.Controls.Primitives.ToggleButton.IsCheckedProperty #:get))
|
|
(is-enabled-property (: Avalonia.Input.InputElement.IsEnabledProperty #:get))
|
|
(font-size-property (: Avalonia.Controls.Primitives.TemplatedControl.FontSizeProperty #:get))
|
|
(padding-property (: Avalonia.Controls.Primitives.TemplatedControl.PaddingProperty #:get))
|
|
(width-property (: Avalonia.Layout.Layoutable.WidthProperty #:get))
|
|
(height-property (: Avalonia.Layout.Layoutable.HeightProperty #:get))
|
|
(margin-property (: Avalonia.Layout.Layoutable.MarginProperty #:get))
|
|
(spacing-property (: Avalonia.Controls.StackPanel.SpacingProperty #:get))
|
|
(orientation-property (: Avalonia.Controls.StackPanel.OrientationProperty #:get))
|
|
(content-alignment-property
|
|
(: Avalonia.Controls.ContentControl.HorizontalContentAlignmentProperty #:get))
|
|
(horizontal-alignment-property (: Avalonia.Layout.Layoutable.HorizontalAlignmentProperty #:get))
|
|
(vertical-alignment-property (: Avalonia.Layout.Layoutable.VerticalAlignmentProperty #:get))
|
|
(text-block-wrapping (: Avalonia.Controls.TextBlock.TextWrappingProperty #:get))
|
|
(text-box-wrapping (: Avalonia.Controls.TextBox.TextWrappingProperty #:get))
|
|
(accepts-return-property (: Avalonia.Controls.TextBox.AcceptsReturnProperty #:get))
|
|
(minimum-property (: Avalonia.Controls.Primitives.RangeBase.MinimumProperty #:get))
|
|
(maximum-property (: Avalonia.Controls.Primitives.RangeBase.MaximumProperty #:get))
|
|
(value-property (: Avalonia.Controls.Primitives.RangeBase.ValueProperty #:get))
|
|
(small-change-property (: Avalonia.Controls.Primitives.RangeBase.SmallChangeProperty #:get))
|
|
(items-source-property (: Avalonia.Controls.ItemsControl.ItemsSourceProperty #:get))
|
|
(selected-index-property
|
|
(: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndexProperty #:get))
|
|
(image-source-property (: Avalonia.Controls.Image.SourceProperty #:get))
|
|
(grid-row-property (: Avalonia.Controls.Grid.RowProperty #:get))
|
|
(grid-column-property (: Avalonia.Controls.Grid.ColumnProperty #:get))
|
|
(grid-row-span-property (: Avalonia.Controls.Grid.RowSpanProperty #:get))
|
|
(grid-column-span-property (: Avalonia.Controls.Grid.ColumnSpanProperty #:get))
|
|
(grid-row-spacing-property (: Avalonia.Controls.Grid.RowSpacingProperty #:get))
|
|
(grid-column-spacing-property (: Avalonia.Controls.Grid.ColumnSpacingProperty #:get))
|
|
(header-property (: Avalonia.Controls.Primitives.HeaderedContentControl.HeaderProperty #:get))
|
|
(text-block-background (: Avalonia.Controls.TextBlock.BackgroundProperty #:get))
|
|
(text-block-foreground (: Avalonia.Controls.TextBlock.ForegroundProperty #:get))
|
|
(background-property (: Avalonia.Controls.Primitives.TemplatedControl.BackgroundProperty #:get))
|
|
(foreground-property (: Avalonia.Controls.Primitives.TemplatedControl.ForegroundProperty #:get))
|
|
(panel-background (: Avalonia.Controls.Panel.BackgroundProperty #:get))
|
|
(border-background (: Avalonia.Controls.Border.BackgroundProperty #:get))
|
|
(border-brush-property (: Avalonia.Controls.Border.BorderBrushProperty #:get))
|
|
(border-thickness-property (: Avalonia.Controls.Border.BorderThicknessProperty #:get))
|
|
(corner-radius-property (: Avalonia.Controls.Border.CornerRadiusProperty #:get))
|
|
(decorator-padding (: Avalonia.Controls.Decorator.PaddingProperty #:get))
|
|
(decorator-child (: Avalonia.Controls.Decorator.ChildProperty #:get))
|
|
(parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush)))
|
|
(menu-header-property
|
|
(: Avalonia.Controls.Primitives.HeaderedSelectingItemsControl.HeaderProperty #:get))
|
|
(input-gesture-property (: Avalonia.Controls.MenuItem.InputGestureProperty #:get))
|
|
(context-menu-property (: Avalonia.Controls.Control.ContextMenuProperty #:get))
|
|
(parse-gesture (: Avalonia.Input.KeyGesture.Parse (-> string KeyGesture)))
|
|
(gesture=? (: Avalonia.Input.KeyGesture.Equals (-> KeyGesture KeyGesture bool)))
|
|
(key-of (: Avalonia.Input.KeyEventArgs.Key (-> KeyEventArgs KeyCode) #:get))
|
|
(modifiers-of (: Avalonia.Input.KeyEventArgs.KeyModifiers (-> KeyEventArgs KeyModifiers) #:get))
|
|
(handled! (: Avalonia.Interactivity.RoutedEventArgs.Handled (-> RoutedEventArgs bool void) #:set))
|
|
|
|
;; A grid's sizes are not Avalonia properties, so they are set as .NET
|
|
;; properties are.
|
|
(grid-columns! (: Avalonia.Controls.Grid.ColumnDefinitions (-> Grid ColumnDefs void) #:set))
|
|
(grid-rows! (: Avalonia.Controls.Grid.RowDefinitions (-> Grid RowDefs void) #:set))
|
|
(parse-columns (: Avalonia.Controls.ColumnDefinitions.Parse (-> string ColumnDefs)))
|
|
(parse-rows (: Avalonia.Controls.RowDefinitions.Parse (-> string RowDefs)))
|
|
|
|
(set-value (: Avalonia.AvaloniaObject.SetValue
|
|
(-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
|
|
(clear-value (: Avalonia.AvaloniaObject.ClearValue (-> AvaloniaObject AvaloniaProperty void)))
|
|
|
|
;; Events.
|
|
(click-event (: Avalonia.Controls.Button.ClickEvent #:get))
|
|
(menu-click-event (: Avalonia.Controls.MenuItem.ClickEvent #:get))
|
|
(key-down-event (: Avalonia.Input.InputElement.KeyDownEvent #:get))
|
|
;; TextChanging and not TextChanged: TextChanged is posted to the
|
|
;; dispatcher and comes later, after the patch that set the text is over.
|
|
(text-changing-event (: Avalonia.Controls.TextBox.TextChangingEvent #:get))
|
|
(checked-event (: Avalonia.Controls.Primitives.ToggleButton.IsCheckedChangedEvent #:get))
|
|
(value-changed-event (: Avalonia.Controls.Primitives.RangeBase.ValueChangedEvent #:get))
|
|
(selection-changed-event
|
|
(: Avalonia.Controls.Primitives.SelectingItemsControl.SelectionChangedEvent #:get))
|
|
(add-handler (: Avalonia.Interactivity.Interactive.AddHandler
|
|
(-> Interactive RoutedEvent Delegate Routes bool void)))
|
|
|
|
;; What a control holds.
|
|
(text-box-value (: Avalonia.Controls.TextBox.Text (-> TextBox string) #:get))
|
|
(is-checked (: Avalonia.Controls.Primitives.ToggleButton.IsChecked
|
|
(-> ToggleButton (Nullable bool)) #:get))
|
|
(range-value (: Avalonia.Controls.Primitives.RangeBase.Value (-> RangeBase double) #:get))
|
|
(selected-index (: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndex
|
|
(-> SelectingItemsControl int) #:get))
|
|
(panel-children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get))
|
|
(items-of (: Avalonia.Controls.ItemsControl.Items (-> ItemsControl ItemCollection) #:get))
|
|
(event-source (: Avalonia.Interactivity.RoutedEventArgs.Source (-> RoutedEventArgs Object) #:get))
|
|
;; Panel.Children and ItemsControl.Items are both an IList, so one patch
|
|
;; serves a panel's children and a list's items.
|
|
(list-count (: System.Collections.ICollection.Count (-> ICollection int) #:get))
|
|
(list-ref (: System.Collections.IList.get_Item (-> IList int Object)))
|
|
(list-index-of (: System.Collections.IList.IndexOf (-> IList Object int)))
|
|
(list-insert! (: System.Collections.IList.Insert (-> IList int Object void)))
|
|
(list-add! (: System.Collections.IList.Add (-> IList Object int)))
|
|
(list-remove! (: System.Collections.IList.Remove (-> IList Object void)))
|
|
(list-remove-at! (: System.Collections.IList.RemoveAt (-> IList int void)))
|
|
(content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set))
|
|
(clr-string (: System.Convert.ToString (-> string ClrString)))
|
|
|
|
;; The UI thread. Controls may be touched only there, so a message from a
|
|
;; fiber is posted to it.
|
|
(ui-dispatcher (: Avalonia.Threading.Dispatcher.UIThread #:get))
|
|
(ui-thread? (: Avalonia.Threading.Dispatcher.CheckAccess (-> Dispatcher bool)))
|
|
(ui-post (: Avalonia.Threading.Dispatcher.InvokeAsync (-> Dispatcher (-> Unit) (DispatcherOp Unit))))
|
|
(ui-run-jobs (: Avalonia.Threading.Dispatcher.RunJobs (-> Dispatcher (Nullable UiPriority) void)))
|
|
|
|
;; The window and the application.
|
|
(configure (: Avalonia.AppBuilder.Configure (-> (-> Application) AppBuilder)))
|
|
(use-platform-detect (: Avalonia.AppBuilderDesktopExtensions.UsePlatformDetect
|
|
(-> AppBuilder AppBuilder)))
|
|
(setup-with-lifetime (: Avalonia.AppBuilder.SetupWithLifetime (-> AppBuilder ILifetime AppBuilder)))
|
|
(current-app (: Avalonia.Application.Current #:get))
|
|
(app-styles (: Avalonia.Application.Styles (-> Application Styles) #:get))
|
|
(main-window! (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.MainWindow
|
|
(-> Lifetime Window void) #:set))
|
|
(start-lifetime (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.Start
|
|
(-> Lifetime (Array ClrString) int)))
|
|
(window-title! (: Avalonia.Controls.Window.Title (-> Window string void) #:set))
|
|
(shutdown! (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.Shutdown
|
|
(-> Lifetime int void)))
|
|
|
|
;; A picture of the window, for `#:screenshot`.
|
|
(seconds->span (: System.TimeSpan.FromSeconds (-> double TimeSpan)))
|
|
(interval! (: Avalonia.Threading.DispatcherTimer.Interval (-> Timer TimeSpan void) #:set))
|
|
(timer-start! (: Avalonia.Threading.DispatcherTimer.Start (-> Timer void)))
|
|
(timer-stop! (: Avalonia.Threading.DispatcherTimer.Stop (-> Timer void)))
|
|
(render-into! (: Avalonia.Media.Imaging.RenderTargetBitmap.Render (-> RenderBitmap Visual void)))
|
|
(save-png! (: Avalonia.Media.Imaging.Bitmap.Save (-> Bitmap string (Nullable int) void)))
|
|
(window-content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set)))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; Properties
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; A kind whose children are the children of an Avalonia Panel.
|
|
(: (-> Kind bool))
|
|
(defun (panel? kind)
|
|
(match kind
|
|
(ColumnKind #t)
|
|
(RowKind #t)
|
|
(GridKind #t)
|
|
(_ #f)))
|
|
|
|
(: (-> Kind bool))
|
|
(defun (stack? kind)
|
|
(match kind
|
|
(ColumnKind #t)
|
|
(RowKind #t)
|
|
(_ #f)))
|
|
|
|
;; A kind that Avalonia draws with a template, and so has a padding and a
|
|
;; font size of its own.
|
|
(: (-> Kind bool))
|
|
(defun (templated? kind)
|
|
(match kind
|
|
(TextKind #f)
|
|
(ImageKind #f)
|
|
(ColumnKind #f)
|
|
(RowKind #f)
|
|
(GridKind #f)
|
|
(BorderKind #f)
|
|
(ContextKind #f)
|
|
(_ #t)))
|
|
|
|
;; 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)
|
|
(_ #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.
|
|
(: (-> Kind bool))
|
|
(defun (single? kind)
|
|
(match kind
|
|
(ScrollKind #t)
|
|
(TabKind #t)
|
|
(BorderKind #t)
|
|
(ContextKind #t)
|
|
(_ #f)))
|
|
|
|
;; A kind that chooses one of its items or options.
|
|
(: (-> Kind bool))
|
|
(defun (selecting? kind)
|
|
(match kind
|
|
(DropdownKind #t)
|
|
(ListBoxKind #t)
|
|
(TabsKind #t)
|
|
(_ #f)))
|
|
|
|
(: (-> Kind bool))
|
|
(defun (text-box? kind)
|
|
(match kind
|
|
(TextInputKind #t)
|
|
(TextAreaKind #t)
|
|
(_ #f)))
|
|
|
|
(: (-> Kind bool))
|
|
(defun (range? kind)
|
|
(match kind
|
|
(SliderKind #t)
|
|
(ProgressKind #t)
|
|
(_ #f)))
|
|
|
|
;; The Avalonia property that a prop sets on a control of this kind. None
|
|
;; for a prop that the kind does not take, and for the props that `set-prop!`
|
|
;; sets in a way of their own.
|
|
(: (-> Kind Prop (Option AvaloniaProperty)))
|
|
(defun (slot kind p)
|
|
(defun (when-kind ok? prop) (if ok? (Some prop) None))
|
|
(match p
|
|
((Label _)
|
|
(match kind
|
|
(TextKind (Some (cast AvaloniaProperty text-block-text)))
|
|
(ButtonKind (Some (cast AvaloniaProperty content-property)))
|
|
(CheckBoxKind (Some (cast AvaloniaProperty content-property)))
|
|
(TabKind (Some (cast AvaloniaProperty header-property)))
|
|
(MenuItemKind (Some (cast AvaloniaProperty menu-header-property)))
|
|
(_ None)))
|
|
((Value _) (when-kind (text-box? kind) (cast AvaloniaProperty text-box-text)))
|
|
((Placeholder _) (when-kind (text-box? kind) (cast AvaloniaProperty watermark-property)))
|
|
((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)))
|
|
((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)))
|
|
((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)))
|
|
((Foreground _)
|
|
(cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-foreground)))
|
|
((templated? kind) (Some (cast AvaloniaProperty foreground-property)))
|
|
(else None)))
|
|
((BorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property)))
|
|
((BorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property)))
|
|
((Radius _) (when-kind (= kind BorderKind) (cast AvaloniaProperty corner-radius-property)))
|
|
((Shortcut _) (when-kind (= kind MenuItemKind) (cast AvaloniaProperty input-gesture-property)))
|
|
;; Set by `set-prop!` itself.
|
|
((Source _) None)
|
|
((Columns _) None)
|
|
((Rows _) None)))
|
|
|
|
(: (-> bool TextWrapping))
|
|
(defun (wrapping wrap?)
|
|
(if wrap? TextWrapping.Wrap TextWrapping.NoWrap))
|
|
|
|
(: (-> string ClrString))
|
|
(defun (->clr-string s) (clr-string s))
|
|
|
|
;; A colour, as Avalonia reads one. None for one it cannot read.
|
|
(: (-> string (Option Object)))
|
|
(defun (brush s)
|
|
(match (try (parse-brush s) #:catch (System.Exception))
|
|
((Ok b) (Some (cast Object b)))
|
|
((Err _) None)))
|
|
|
|
;; The value of a prop, as the object `SetValue` takes. None for a value that
|
|
;; cannot be one, such as a colour that cannot be read: the property is then
|
|
;; cleared, and the theme's value shows.
|
|
(: (-> Prop (Option Object)))
|
|
(defun (boxed p)
|
|
(match p
|
|
((Background s) (brush s))
|
|
((Foreground s) (brush s))
|
|
((BorderColour s) (brush s))
|
|
((Shortcut s) (match (gesture s) ((Some g) (Some (cast Object g))) (None None)))
|
|
(_ (Some (plain p)))))
|
|
|
|
;; Keys, as Avalonia reads them. None for keys it cannot read.
|
|
(: (-> string (Option KeyGesture)))
|
|
(defun (gesture s)
|
|
(match (try (parse-gesture s) #:catch (System.Exception))
|
|
((Ok g) (Some g))
|
|
((Err _) None)))
|
|
|
|
(: (-> Prop Object))
|
|
(defun (plain p)
|
|
(defun (text s) (cast Object (->clr-string s)))
|
|
(match p
|
|
((Label s) (text s))
|
|
((Value s) (text s))
|
|
((Placeholder s) (text s))
|
|
((Checked b) (cast Object b))
|
|
((Enabled b) (cast Object b))
|
|
((FontSize d) (cast Object d))
|
|
((Width d) (cast Object d))
|
|
((Height d) (cast Object d))
|
|
((Margin d) (cast Object (Thickness. d)))
|
|
((Padding d) (cast Object (Thickness. d)))
|
|
((Spacing d) (cast Object d))
|
|
((Wrap b) (cast Object (wrapping b)))
|
|
((Minimum d) (cast Object d))
|
|
((Maximum d) (cast Object d))
|
|
((Amount d) (cast Object d))
|
|
((Step d) (cast Object d))
|
|
;; A .NET array of .NET strings, which a ComboBox shows as they are.
|
|
((Items xs) (cast Object (: (vec->array (vec-map ->clr-string xs)) (Array ClrString))))
|
|
((Selected i) (cast Object i))
|
|
((Row i) (cast Object i))
|
|
((Column i) (cast Object i))
|
|
((RowSpan i) (cast Object i))
|
|
((ColumnSpan i) (cast Object i))
|
|
((Source s) (text s))
|
|
((Columns s) (text s))
|
|
((Rows s) (text s))
|
|
((Background s) (text s))
|
|
((Foreground s) (text s))
|
|
((BorderColour s) (text s))
|
|
((BorderWidth d) (cast Object (Thickness. d)))
|
|
((Radius d) (cast Object (CornerRadius. d)))
|
|
((Shortcut s) (text s))))
|
|
|
|
;; Which prop it is, without its value. Two props with one tag set the same
|
|
;; property.
|
|
(: (-> Prop int))
|
|
(defun (tag p)
|
|
(match p
|
|
((Label _) 0) ((Value _) 1) ((Placeholder _) 2) ((Checked _) 3)
|
|
((Enabled _) 4) ((FontSize _) 5) ((Width _) 6) ((Height _) 7)
|
|
((Margin _) 8) ((Padding _) 9) ((Spacing _) 10) ((Wrap _) 11)
|
|
((Minimum _) 12) ((Maximum _) 13) ((Amount _) 14) ((Step _) 15)
|
|
((Items _) 16) ((Selected _) 17) ((Source _) 18) ((Columns _) 19)
|
|
((Rows _) 20) ((Row _) 21) ((Column _) 22) ((RowSpan _) 23) ((ColumnSpan _) 24)
|
|
((Background _) 25) ((Foreground _) 26) ((BorderColour _) 27) ((BorderWidth _) 28)
|
|
((Radius _) 29) ((Shortcut _) 30)))
|
|
|
|
(: (-> Control AvaloniaProperty Object void))
|
|
(defun (put! control property value)
|
|
(ignore (set-value (cast AvaloniaObject control) property value Priority.LocalValue)))
|
|
|
|
;; The picture in a file, or None when it cannot be read.
|
|
(: (-> string (Option Bitmap)))
|
|
(defun (load-bitmap path)
|
|
(match (try (Bitmap. path) #:catch (System.Exception))
|
|
((Ok b) (Some b))
|
|
((Err _) None)))
|
|
|
|
(: (-> Control Kind Prop void))
|
|
(defun (set-prop! control kind p)
|
|
(match (Tuple kind p)
|
|
((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 (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)))
|
|
(_
|
|
(match (slot kind p)
|
|
((Some property)
|
|
(match (boxed p)
|
|
((Some value) (put! control property value))
|
|
(None (clear-value (cast AvaloniaObject control) property))))
|
|
(None unit)))))
|
|
|
|
(: (-> Control Kind Prop void))
|
|
(defun (clear-prop! control kind p)
|
|
(defun (clear property) (clear-value (cast AvaloniaObject control) property))
|
|
(match (Tuple kind p)
|
|
((Tuple ImageKind (Source _)) (clear (cast AvaloniaProperty image-source-property)))
|
|
((Tuple GridKind (Columns _)) (grid-columns! (cast Grid control) (parse-columns "*")))
|
|
((Tuple GridKind (Rows _)) (grid-rows! (cast Grid control) (parse-rows "*")))
|
|
((Tuple GridKind (Spacing _))
|
|
(clear (cast AvaloniaProperty grid-row-spacing-property))
|
|
(clear (cast AvaloniaProperty grid-column-spacing-property)))
|
|
(_
|
|
(match (slot kind p)
|
|
((Some property) (clear property))
|
|
(None unit)))))
|
|
|
|
;; Clears the props that are gone, and sets the ones that are new or have
|
|
;; another value. A prop with the same value is not set again.
|
|
(: (-> Control Kind (Vec Prop) (Vec Prop) void))
|
|
(defun (patch-props! control kind old new)
|
|
(loop (:for p old)
|
|
(:when (not (any? (fun (q) (= (tag q) (tag p))) new)))
|
|
(:do (clear-prop! control kind p)))
|
|
(loop (:for p new)
|
|
(:when (not (vec-contains old p)))
|
|
(:do (set-prop! control kind p))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; The app
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; A control, the view it was last given, and the live children it holds.
|
|
(type (: (Live %m) #:opaque (Record (: control Control)
|
|
(: view (View %m) #:mutable)
|
|
(: children (MutableVec (Live %m))))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; Commands and subscriptions
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; A source of messages that runs while the model asks for it. `key` says
|
|
;; which one it is: after an update, a subscription whose key was there before
|
|
;; keeps running, and is not started again.
|
|
;;
|
|
;; `next-event` gives the event of the next message. A fiber of the
|
|
;; subscription's own calls it, syncs the event, sends the message, and calls
|
|
;; it again. The fiber is cancelled at that `sync` when the key is gone, and
|
|
;; when the app stops.
|
|
(type (: (Sub %m) #:opaque (Record (: key string)
|
|
(: next-event (-> (Event %m))))))
|
|
|
|
;; A subscription to a source of your own: `(subscription "jobs" (fun ()
|
|
;; (chan-recv jobs)))` sends each value that comes on a channel. Two
|
|
;; subscriptions with the same key are one: the first is the one that runs.
|
|
(: subscription (-> string (-> (Event %m)) (Sub %m)))
|
|
(defun (subscription key next-event)
|
|
(Sub (key key) (next-event next-event)))
|
|
|
|
;; Sends `msg` each time `d` has passed. The time is counted from the last
|
|
;; message, so a slow update makes the next one later and they do not queue
|
|
;; up.
|
|
(: every (-> Duration %m (Sub %m)) (where (Written %m)))
|
|
(defun (every d msg)
|
|
(Sub (key #"every ${(duration-ticks d)} ${(written msg)}")
|
|
(next-event (fun () (wrap (timeout d) (fun (_) msg))))))
|
|
|
|
;; The next model, and the commands to run. `(next m)` is the model alone.
|
|
(: next (-> %model #:rest (Event %m) (Tuple %model (List (Event %m)))))
|
|
(defun (next m #:rest commands)
|
|
(Tuple m (->list commands)))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; The app
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; A running program.
|
|
;;
|
|
;; `patching` is true while the controls are being changed. A control that
|
|
;; is changed raises its own events, such as a text input whose text is set,
|
|
;; and those are not the user's: they are dropped.
|
|
;;
|
|
;; `home` is the scope the app's fibers belong to. A message can arrive from
|
|
;; Avalonia on a thread with no scope, so each update is run in it.
|
|
;; `subs` holds each running subscription's key, and the scope it runs in, so
|
|
;; that one can be cancelled and the others not.
|
|
(type (: (App %model %m) #:opaque
|
|
(Record (: model %model #:mutable)
|
|
(: gui-update (-> %m %model (Tuple %model (List (Event %m)))))
|
|
(: view (-> %model (View %m)))
|
|
(: subscriptions (-> %model (List (Sub %m))))
|
|
(: keys (-> %model (List (Key %m))))
|
|
(: root (Option (Live %m)) #:mutable)
|
|
(: patching bool #:mutable)
|
|
(: stopped bool #:mutable)
|
|
(: home Scope)
|
|
(: subs (List (Tuple string Scope)) #:mutable)
|
|
(: on-root (-> Control void)))))
|
|
|
|
(: (-> (App %model %m) %model))
|
|
(defun (app-model app) (.model app))
|
|
|
|
;; The control the view is shown in. It changes when the root view changes
|
|
;; kind.
|
|
(: (-> (App %model %m) Control))
|
|
(defun (app-control app)
|
|
(match (.root app)
|
|
((Some live) (.control live))
|
|
(None (raise (cast Exception (InvalidOperation. "the app has no view"))))))
|
|
|
|
;; The control at `path`, a child index for each level below the root.
|
|
(: (-> (App %model %m) (List int) Control))
|
|
(defun (app-control-at app path)
|
|
(: (-> (Live %m) (List int) Control))
|
|
(defun (walk live path)
|
|
(match path
|
|
(() (.control live))
|
|
((List i rest ...) (walk (mutablevec-ref (.children live) i) rest))))
|
|
(match (.root app)
|
|
((Some live) (walk live path))
|
|
(None (raise (cast Exception (InvalidOperation. "the app has no view"))))))
|
|
|
|
;; Makes the next model from `msg`, shows its view, starts its commands, and
|
|
;; starts and stops subscriptions. Only on the UI thread; from anywhere else,
|
|
;; use `app-send!`. A stopped app drops the message.
|
|
(: (-> (App %model %m) %m void))
|
|
(defun (app-dispatch! app msg)
|
|
(unless (.stopped app)
|
|
(def (Tuple model commands) ((.gui-update app) msg (.model app)))
|
|
(record-set! app (model model))
|
|
(step! app commands)))
|
|
|
|
;; Gives `msg` to the app from any thread. Off the UI thread it is posted to
|
|
;; the UI thread, and runs there after the messages posted before it.
|
|
(: (-> (App %model %m) %m void))
|
|
(defun (app-send! app msg)
|
|
(if (ui-thread? ui-dispatcher)
|
|
(app-dispatch! app msg)
|
|
(post! app msg)))
|
|
|
|
;; Posts `msg` to the UI thread. What a fiber does: it is never on the UI
|
|
;; thread, and it must not run an update itself.
|
|
(: (-> (App %model %m) %m void))
|
|
(defun (post! app msg)
|
|
(ignore (ui-post ui-dispatcher (fun () (app-dispatch! app msg) unit))))
|
|
|
|
;; Runs the messages that fibers have posted to the UI thread, now. For a test
|
|
;; or a host with no window, where no loop of Avalonia's runs them.
|
|
(: (-> (App %model %m) void))
|
|
(defun (app-run-pending! app)
|
|
(ui-run-jobs ui-dispatcher (clr-default)))
|
|
|
|
;; Sends the message of the keys `g`: of an enabled menu item in the view
|
|
;; with those keys as its shortcut, or else of the app's `#:keys`. True when
|
|
;; there was one.
|
|
(: (-> (App %model %m) KeyGesture bool))
|
|
(defun (press! app g)
|
|
(defun (same? s) (match (gesture s) ((Some h) (gesture=? g h)) (None #f)))
|
|
(: (-> (View %m) (Option %m)))
|
|
(defun (in-view v)
|
|
(def props (view-props v))
|
|
(if (and (= (view-kind v) MenuItemKind)
|
|
(not (vec-contains props (Enabled #f)))
|
|
(any? (fun (p) (match p ((Shortcut s) (same? s)) (_ #f))) props))
|
|
(loop (:for on (view-events v))
|
|
(:when-let (Click msg) on)
|
|
(:finish #t (Some msg))
|
|
=> None)
|
|
(loop (:for c (view-children v))
|
|
(:when-let (Some msg) (in-view c))
|
|
(:finish #t (Some msg))
|
|
=> None)))
|
|
(def found
|
|
(match (match (.root app) ((Some live) (in-view (.view live))) (None None))
|
|
((Some msg) (Some msg))
|
|
(None (loop (:for k ((.keys app) (.model app)))
|
|
(:when (same? (key-gesture k)))
|
|
(:finish #t (Some (key-message k)))
|
|
=> None))))
|
|
(match found
|
|
((Some msg) (app-dispatch! app msg) #t)
|
|
(None #f)))
|
|
|
|
;; Presses the keys `keys`, such as "Ctrl+S", as `press!` does when they are
|
|
;; pressed in the window. True when they sent a message. For tests.
|
|
(: (-> (App %model %m) string bool))
|
|
(defun (app-press! app keys)
|
|
(match (gesture keys)
|
|
((Some g) (press! app g))
|
|
(None #f)))
|
|
|
|
;; Stops the app: its subscriptions are cancelled, and later messages are
|
|
;; dropped. A command that is still running is cancelled when the scope the
|
|
;; app was started in ends.
|
|
(: (-> (App %model %m) void))
|
|
(defun (app-stop! app)
|
|
(record-set! app (stopped #t))
|
|
(loop (:for (Tuple _ scope) (.subs app)) (:do (stop-scope! scope)))
|
|
(record-set! app (subs '())))
|
|
|
|
(: (-> (App %model %m) (List (Event %m)) void))
|
|
(defun (step! app commands)
|
|
(render! app)
|
|
(in-scope (.home app)
|
|
(loop (:for command commands)
|
|
(:do (spawn/daemon (run-command app command)))))
|
|
(sync-subs! app))
|
|
|
|
(: (-bjo-> (App %model %m) (Event %m) void))
|
|
(defbjo (run-command app command)
|
|
(post! app (sync command)))
|
|
|
|
(: (-bjo-> (App %model %m) (-> (Event %m)) void))
|
|
(defbjo (run-sub app next-event)
|
|
(let go ()
|
|
(post! app (sync (next-event)))
|
|
(go)))
|
|
|
|
;; Cancels a subscription's scope, and so its fiber. The scope is not closed:
|
|
;; closing waits, and nothing is owned in it to release.
|
|
(: (-> Scope void))
|
|
(defun (stop-scope! scope)
|
|
(scope-cancel! scope (Requested "the subscription is gone")))
|
|
|
|
;; Starts a subscription in a scope of its own, inside the app's, so that it
|
|
;; can be cancelled alone.
|
|
(: (-> (App %model %m) (Sub %m) Scope))
|
|
(defun (start-sub! app sub)
|
|
(in-scope (.home app)
|
|
(def scope (scope-open! 0))
|
|
(in-scope scope
|
|
(spawn/daemon (run-sub app (.next-event sub))))
|
|
scope))
|
|
|
|
(: (-> (Sub %m) string))
|
|
(defun (sub-key sub) (.key sub))
|
|
|
|
(: (-> (App %model %m) void))
|
|
(defun (sync-subs! app)
|
|
(def wanted ((.subscriptions app) (.model app)))
|
|
(defun (wanted? key) (any? (fun (sub) (= (sub-key sub) key)) wanted))
|
|
(def/mutable kept '())
|
|
(loop (:for (Tuple key scope) (.subs app))
|
|
(:do (if (wanted? key)
|
|
(set! kept (cons (Tuple key scope) kept))
|
|
(stop-scope! scope))))
|
|
(loop (:for sub wanted)
|
|
(:when (not (any? (fun (t) (= (fst t) (sub-key sub))) kept)))
|
|
(:do (set! kept (cons (Tuple (sub-key sub) (start-sub! app sub)) kept))))
|
|
(record-set! app (subs kept)))
|
|
|
|
(: (-> (App %model %m) void))
|
|
(defun (render! app)
|
|
(def next-view ((.view app) (.model app)))
|
|
(record-set! app (patching #t))
|
|
(match (.root app)
|
|
(None
|
|
(def live (mount app next-view))
|
|
(record-set! app (root (Some live)))
|
|
((.on-root app) (.control live)))
|
|
((Some live)
|
|
(def now (patch! app live next-view))
|
|
(unless (eq? now live)
|
|
(record-set! app (root (Some now)))
|
|
((.on-root app) (.control now)))))
|
|
(record-set! app (patching #f)))
|
|
|
|
;; Gives the message that `pick` finds in the control's events to `gui-update`.
|
|
(: (-> (App %model %m) (Live %m) (-> (On %m) (Option %m)) void))
|
|
(defun (fire! app live pick)
|
|
(unless (.patching app)
|
|
(match (loop (:for on (.events (.view live)))
|
|
(:when-let (Some msg) (pick on))
|
|
(:finish #t (Some msg))
|
|
=> None)
|
|
((Some msg) (app-dispatch! app msg))
|
|
(None unit))))
|
|
|
|
(: (-> Control RoutedEvent (-> Object RoutedEventArgs void) void))
|
|
(defun (on! control event handler)
|
|
(add-handler (cast Interactive control) event
|
|
(cast Delegate (cast Object (: (as-delegate handler) (EventHandler RoutedEventArgs))))
|
|
Routes.Bubble #f))
|
|
|
|
;; Adds the handlers of the kind. A handler reads the view the control has
|
|
;; when the event comes, so a new view needs no new handler.
|
|
(: (-> (App %model %m) (Live %m) Kind void))
|
|
(defun (listen! app live kind)
|
|
(def control (.control live))
|
|
;; Only the control's own events: a routed event bubbles, so a list's
|
|
;; handler would hear the selection of a dropdown in one of its items too.
|
|
(defun (on-event (: event RoutedEvent) pick)
|
|
(on! control event
|
|
(fun (sender e)
|
|
(when (eq? (event-source e) (cast Object control))
|
|
(fire! app live (pick))))))
|
|
(match kind
|
|
(MenuItemKind
|
|
(on-event (cast RoutedEvent menu-click-event)
|
|
(fun () (fun (on) (match on ((Click msg) (Some msg)) (_ None))))))
|
|
(ButtonKind
|
|
(on-event (cast RoutedEvent click-event)
|
|
(fun () (fun (on) (match on ((Click msg) (Some msg)) (_ None))))))
|
|
((or TextInputKind TextAreaKind)
|
|
(on-event (cast RoutedEvent text-changing-event)
|
|
(fun ()
|
|
(def s (text-box-value (cast TextBox control)))
|
|
(fun (on) (match on ((Input f) (Some (f s))) (_ None))))))
|
|
(CheckBoxKind
|
|
(on-event (cast RoutedEvent checked-event)
|
|
(fun ()
|
|
(def b (.GetValueOrDefault (is-checked (cast ToggleButton control))))
|
|
(fun (on) (match on ((Toggle f) (Some (f b))) (_ None))))))
|
|
(SliderKind
|
|
(on-event (cast RoutedEvent value-changed-event)
|
|
(fun ()
|
|
(def d (range-value (cast RangeBase control)))
|
|
(fun (on) (match on ((Slide f) (Some (f d))) (_ None))))))
|
|
((or DropdownKind ListBoxKind TabsKind)
|
|
(on-event (cast RoutedEvent selection-changed-event)
|
|
(fun ()
|
|
(def i (selected-index (cast SelectingItemsControl control)))
|
|
(fun (on) (match on ((Select f) (Some (f i))) (_ None))))))
|
|
(_ unit)))
|
|
|
|
(: (-> Kind Control))
|
|
(defun (make-control kind)
|
|
(match kind
|
|
(TextKind
|
|
;; Centred in the height it is given, so a label lines up with the
|
|
;; control beside it in a row or a grid.
|
|
(def t (cast Control (TextBlock.)))
|
|
(put! t (cast AvaloniaProperty vertical-alignment-property) (cast Object VAlignment.Center))
|
|
t)
|
|
(ButtonKind
|
|
;; Centred, because a button given a width shows its label at the left.
|
|
(def b (cast Control (Button.)))
|
|
(put! b (cast AvaloniaProperty content-alignment-property) (cast Object HAlignment.Center))
|
|
b)
|
|
(TextInputKind (cast Control (TextBox.)))
|
|
(TextAreaKind
|
|
(def t (cast Control (TextBox.)))
|
|
(put! t (cast AvaloniaProperty accepts-return-property) (cast Object #t))
|
|
(put! t (cast AvaloniaProperty text-box-wrapping) (cast Object TextWrapping.Wrap))
|
|
t)
|
|
(CheckBoxKind (cast Control (CheckBox.)))
|
|
(SliderKind (cast Control (Slider.)))
|
|
(ProgressKind (cast Control (ProgressBar.)))
|
|
(DropdownKind
|
|
(def d (cast Control (ComboBox.)))
|
|
(put! d (cast AvaloniaProperty horizontal-alignment-property) (cast Object HAlignment.Stretch))
|
|
d)
|
|
(ImageKind (cast Control (Image.)))
|
|
(ColumnKind (cast Control (StackPanel.)))
|
|
(RowKind
|
|
(def panel (cast Control (StackPanel.)))
|
|
(put! panel (cast AvaloniaProperty orientation-property) (cast Object Orientation.Horizontal))
|
|
panel)
|
|
(GridKind (cast Control (Grid.)))
|
|
(ScrollKind (cast Control (ScrollViewer.)))
|
|
(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.)))))
|
|
|
|
;; Where the controls of a panel's children, or of a list's items, are.
|
|
(: (-> Kind Control IList))
|
|
(defun (child-list kind parent)
|
|
(if (items? kind)
|
|
(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)))))
|
|
|
|
;; Puts a child's control in its parent's, as child `i`, the last one so far.
|
|
(: (-> Kind Control int Control void))
|
|
(defun (adopt! kind parent i child)
|
|
(if (single? kind)
|
|
(set-slot! kind parent i child)
|
|
(ignore (list-add! (child-list kind parent) (cast Object child)))))
|
|
|
|
;; A list or tabs can choose an item only once the items are there, so the
|
|
;; choice is set again after the children. A dropdown whose items changed
|
|
;; may have dropped its choice, so it is set again too.
|
|
(: (-> Control Kind (Vec Prop) void))
|
|
(defun (sync-selection! control kind props)
|
|
(when (selecting? kind)
|
|
(loop (:for p props)
|
|
(:do (match p
|
|
((Selected i)
|
|
(unless (= (selected-index (cast SelectingItemsControl control)) i)
|
|
(put! control (cast AvaloniaProperty selected-index-property) (cast Object i))))
|
|
(_ unit))))))
|
|
|
|
;; Makes the controls for a view.
|
|
(: (-> (App %model %m) (View %m) (Live %m)))
|
|
(defun (mount app v)
|
|
(def kind (view-kind v))
|
|
(def control (make-control kind))
|
|
(def live (Live (control control) (view v) (children (mutablevec))))
|
|
(loop (:for p (view-props v)) (:do (set-prop! control kind p)))
|
|
(listen! app live kind)
|
|
(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))))
|
|
(sync-selection! control kind (view-props v))
|
|
live)
|
|
|
|
;; Changes the controls of `live` to show `next`. Gives `live` itself, or new
|
|
;; controls when the kind is another.
|
|
(: (-> (App %model %m) (Live %m) (View %m) (Live %m)))
|
|
(defun (patch! app live next)
|
|
(def old (.view live))
|
|
(def kind (view-kind next))
|
|
(if (not (= (view-kind old) kind))
|
|
(mount app next)
|
|
(begin
|
|
(patch-props! (.control live) kind (view-props old) (view-props next))
|
|
(record-set! live (view next))
|
|
(cond ((single? kind) (patch-single! app live kind (view-children next)))
|
|
((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next)))
|
|
(else unit))
|
|
(sync-selection! (.control live) kind (view-props next))
|
|
live)))
|
|
|
|
;; The children of a kind whose children each have a place of their own.
|
|
(: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void))
|
|
(defun (patch-single! app live kind views)
|
|
(def kids (.children live))
|
|
(loop (:for (Tuple i v) (enumerate views))
|
|
(:do (def was (mutablevec-ref kids i))
|
|
(def now (patch! app was v))
|
|
(unless (eq? now was)
|
|
(mutablevec-set! kids i now)
|
|
(set-slot! kind (.control live) i (.control now))))))
|
|
|
|
;; Which child each view is: its key, or its place among the children that
|
|
;; have none. The two kinds cannot be mistaken for each other.
|
|
(: (-> (Vec (View %m)) (Vec string)))
|
|
(defun (identities views)
|
|
(def/mutable unkeyed 0)
|
|
(loop (:for v views)
|
|
(:acc out (vecing (match (view-key v)
|
|
((Some k) (string-append "k" k))
|
|
(None (set! unkeyed (+ unkeyed 1))
|
|
#"i${(- unkeyed 1)}"))))
|
|
=> out))
|
|
|
|
;; Children are matched by identity: a child of the last view whose key, or
|
|
;; whose place among those with no key, is a child's of the next one keeps
|
|
;; its control, and is changed to the next view. The others are made new,
|
|
;; and those left over are removed. Then the controls are put in the order
|
|
;; of the next view, moving only those that are out of place.
|
|
(: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void))
|
|
(defun (patch-children! app live kind views)
|
|
(def kids (.children live))
|
|
(def controls (child-list kind (.control live)))
|
|
(def olds (mutablevec->vec kids))
|
|
(def old-ids (identities (vec-map (fun (l) (.view l)) olds)))
|
|
(def new-ids (identities views))
|
|
|
|
;; Where each identity was. A second child with one identity is new.
|
|
(def where (mutablemap))
|
|
(loop (:for (Tuple i id) (enumerate old-ids))
|
|
(:when (not (mutablemap-contains? where id)))
|
|
(:do (mutablemap-set! where id i)))
|
|
(def kept (: (make-array (vec-length olds) #:fill #f) (Array bool)))
|
|
|
|
(def nexts (mutablevec))
|
|
(loop (:for (Tuple j v) (enumerate views))
|
|
(:do (def now
|
|
(match (mutablemap-try-ref where (vec-ref new-ids j))
|
|
((Some i)
|
|
(ignore (mutablemap-remove! where (vec-ref new-ids j)))
|
|
(def was (vec-ref olds i))
|
|
(def now (patch! app was v))
|
|
(when (eq? now was) (array-set! kept i #t))
|
|
now)
|
|
(None (mount app v))))
|
|
(mutablevec-add! nexts now)))
|
|
|
|
(loop (:for (Tuple i was) (enumerate olds))
|
|
(:when (not (array-ref kept i)))
|
|
(:do (list-remove! controls (cast Object (.control was)))))
|
|
|
|
;; A control out of place is taken out and put back where it belongs.
|
|
(loop (:for (Tuple j now) (enumerate (mutablevec->vec nexts)))
|
|
(:do (def c (cast Object (.control now)))
|
|
(unless (and (< j (list-count (cast ICollection controls)))
|
|
(eq? (list-ref controls j) c))
|
|
(def at (list-index-of controls c))
|
|
(when (>= at 0) (list-remove-at! controls at))
|
|
(list-insert! controls j c))))
|
|
|
|
(mutablevec-clear! kids)
|
|
(loop (:for now (mutablevec->vec nexts)) (:do (mutablevec-add! kids now))))
|
|
|
|
;; An app with no window: its view is made now, its subscriptions started,
|
|
;; and `on-root` is given the control to show each time that control changes.
|
|
;; Its fibers belong to the scope it is started in.
|
|
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
|
|
(-> Control void) (#:subscriptions (-> %model (List (Sub %m))))
|
|
(#:keys (-> %model (List (Key %m))))
|
|
(App %model %m)))
|
|
(defun (start-app init gui-update view on-root #:subscriptions (fun (m) '())
|
|
#:keys (fun (m) '()))
|
|
(def app (App (model init) (gui-update gui-update) (view view)
|
|
(subscriptions subscriptions) (keys keys) (root None) (patching #f) (stopped #f)
|
|
(home (current-scope)) (subs '()) (on-root on-root)))
|
|
(step! app '())
|
|
app)
|
|
|
|
;; 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.
|
|
(: (-> Lifetime Window double double string void))
|
|
(defun (screenshot-later! lifetime w width height path)
|
|
(def timer (Timer.))
|
|
(interval! timer (seconds->span 1.0))
|
|
(ignore (add-event-handler! timer "Tick"
|
|
(: (fun (sender e)
|
|
(timer-stop! timer)
|
|
(def bitmap (RenderBitmap. (PixelSize. (cast System.Int32 (* 2.0 width))
|
|
(cast System.Int32 (* 2.0 height)))
|
|
(Vector. 192.0 192.0)))
|
|
(render-into! bitmap (cast Visual w))
|
|
(save-png! (cast Bitmap bitmap) path (clr-default))
|
|
(shutdown! lifetime 0))
|
|
(-> Object EventArgs void))))
|
|
(timer-start! timer))
|
|
|
|
;; Runs the program in a window, until the window is closed. Then the
|
|
;; subscriptions and the commands still running are cancelled.
|
|
;;
|
|
;; 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:
|
|
;;
|
|
;; BJOGUI_SCREENSHOT=shot.png bjo run examples/todo.bjo
|
|
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
|
|
(#:subscriptions (-> %model (List (Sub %m))))
|
|
(#:keys (-> %model (List (Key %m))))
|
|
(#:title string) (#:width double) (#:height double) (#:screenshot string)
|
|
void))
|
|
(defun (run-app init gui-update view #:subscriptions (fun (m) '()) #:keys (fun (m) '())
|
|
#:title "bjogui" #:width 400.0 #:height 300.0
|
|
#:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") ""))
|
|
;; The Application is made inside the setup, because making one uses the
|
|
;; dispatcher, and the dispatcher is the platform's only after the setup.
|
|
(def lifetime (Lifetime.))
|
|
(ignore (setup-with-lifetime (use-platform-detect (configure (fun () (Application.))))
|
|
lifetime))
|
|
(.Add (app-styles current-app) (FluentTheme. (clr-default)))
|
|
(def w (Window.))
|
|
(window-title! w title)
|
|
(ignore (set-value (cast AvaloniaObject w) (cast AvaloniaProperty width-property)
|
|
(cast Object width) Priority.LocalValue))
|
|
(ignore (set-value (cast AvaloniaObject w) (cast AvaloniaProperty height-property)
|
|
(cast Object height) Priority.LocalValue))
|
|
(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))
|
|
;; Keys that no control took, such as a shortcut pressed in a text input.
|
|
(on! (cast Control w) (cast RoutedEvent key-down-event)
|
|
(fun (sender e)
|
|
(def k (cast KeyEventArgs e))
|
|
(when (press! app (KeyGesture. (key-of k) (modifiers-of k)))
|
|
(handled! e #t))))
|
|
(main-window! lifetime w)
|
|
(unless (string-empty? screenshot)
|
|
(screenshot-later! lifetime w width height screenshot))
|
|
(ignore (start-lifetime lifetime (: (make-array 0) (Array ClrString))))
|
|
(app-stop! app)
|
|
(cancel (Requested "the window is closed"))))
|