bjogui/src/app.bjo

;; 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-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))
  (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))

  ;; 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))
  ;; 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))
  (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))
  (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)
    (_ #t)))

(: (-> 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)))
       (_ 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 _) (when-kind (templated? kind) (cast AvaloniaProperty padding-property)))
    ((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 (= kind DropdownKind) (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)))
    ;; 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))

;; The value of a prop, as the object `SetValue` takes.
(: (-> Prop Object))
(defun (boxed 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))))

;; 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)))

(: (-> 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) (put! control property (boxed p)))
       (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))))
                 (: 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)))

;; 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))
  (defun (on-event (: event RoutedEvent) pick)
    (on! control event (fun (sender e) (fire! app live (pick)))))
  (match kind
    (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))))))
    (DropdownKind
     (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.)))))

;; Puts a child's control in its parent's, as the last one.
(: (-> Kind Control Control void))
(defun (adopt! kind parent child)
  (if (= kind ScrollKind)
      (content! (cast ContentControl parent) (cast Object child))
      (.Add (panel-children (cast Panel parent)) child)))

;; 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 (.control c))))
  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 ((panel? kind) (patch-children! app live (view-children next)))
              ((= kind ScrollKind) (patch-content! app live (view-children next)))
              (else unit))
        live)))

;; A scroll's one child is its content.
(: (-> (App %model %m) (Live %m) (Vec (View %m)) void))
(defun (patch-content! app live views)
  (def kids (.children live))
  (def was (mutablevec-ref kids 0))
  (def now (patch! app was (vec-ref views 0)))
  (unless (eq? now was)
    (mutablevec-set! kids 0 now)
    (content! (cast ContentControl (.control live)) (cast Object (.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) (Vec (View %m)) void))
(defun (patch-children! app live views)
  (def kids (.children live))
  (def controls (panel-children (cast Panel (.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 (ignore (.Remove controls (.control was)))))

  (loop (:for (Tuple j now) (enumerate (mutablevec->vec nexts)))
        (:do (def c (.control now))
             (unless (and (< j (.-Count controls)) (eq? (.get_Item controls j) c))
               (def at (.IndexOf controls c))
               (if (>= at 0)
                   (.Move controls at j)
                   (.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))))
       (App %model %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) (root None) (patching #f) (stopped #f)
                (home (current-scope)) (subs '()) (on-root on-root)))
  (step! app '())
  app)

;; Runs the program in a window, until the window is closed. Then the
;; subscriptions and the commands still running are cancelled.
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
       (#:subscriptions (-> %model (List (Sub %m))))
       (#:title string) (#:width double) (#:height double)
       void))
(defun (run-app init gui-update view #:subscriptions (fun (m) '())
                #:title "bjogui" #:width 400.0 #:height 300.0)
  ;; 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))
    (main-window! lifetime w)
    (ignore (start-lifetime lifetime (: (make-array 0) (Array ClrString))))
    (app-stop! app)
    (cancel (Requested "the window is closed"))))