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, an `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. `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.
;;
;; Every control is made with plain constructors and changed with
;; `AvaloniaObject.SetValue`, so no Avalonia class is subclassed.

(export
  App Live Control
  run-app
  ;; For tests and for hosts of their own: an app with no window.
  start-app app-dispatch! app-model app-control app-control-at)

(import (std prelude))
(import (std interop))
(import (std mutable vec))
(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))
  (Control           (: Avalonia.Controls.Control))
  (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))))

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

  (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))
  (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))
  (panel-children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get))
  (clr-string     (: System.Convert.ToString (-> string ClrString)))

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

(: (-> 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
    (ButtonKind #t)
    (TextInputKind #t)
    (CheckBoxKind #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.
(: (-> Kind Prop (Option AvaloniaProperty)))
(defun (slot kind p)
  (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 _) (if (= kind TextInputKind) (Some (cast AvaloniaProperty text-box-text)) None))
    ((Placeholder _) (if (= kind TextInputKind) (Some (cast AvaloniaProperty watermark-property)) None))
    ((Checked _) (if (= kind CheckBoxKind) (Some (cast AvaloniaProperty is-checked-property)) None))
    ((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 _) (if (templated? kind) (Some (cast AvaloniaProperty padding-property)) None))
    ((Spacing _) (if (stack? kind) (Some (cast AvaloniaProperty spacing-property)) None))))

;; The value of a prop, as the object `SetValue` takes.
(: (-> Prop Object))
(defun (boxed p)
  (match p
    ((Label s) (cast Object (clr-string s)))
    ((Value s) (cast Object (clr-string s)))
    ((Placeholder s) (cast Object (clr-string 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))))

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

(: (-> Control Kind Prop void))
(defun (set-prop! control kind p)
  (match (slot kind p)
    ((Some property)
     (ignore (set-value (cast AvaloniaObject control) property (boxed p) Priority.LocalValue)))
    (None unit)))

(: (-> Control Kind Prop void))
(defun (clear-prop! control kind p)
  (match (slot kind p)
    ((Some property) (clear-value (cast AvaloniaObject control) 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))))))

;; 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.
(type (: (App %model %m) #:opaque (Record (: model %model #:mutable)
                                 (: update (-> %m %model %model))
                                 (: view (-> %model (View %m)))
                                 (: root (Option (Live %m)) #:mutable)
                                 (: patching bool #: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`, and shows its view.
(: (-> (App %model %m) %m void))
(defun (app-dispatch! app msg)
  (record-set! app (model ((.update app) msg (.model app))))
  (render! app))

(: (-> (App %model %m) void))
(defun (render! app)
  (def next ((.view app) (.model app)))
  (record-set! app (patching #t))
  (match (.root app)
    (None
     (def live (mount app next))
     (record-set! app (root (Some live)))
     ((.on-root app) (.control live)))
    ((Some live)
     (def now (patch! app live next))
     (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 `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))
  (match kind
    (ButtonKind
     (on! control (cast RoutedEvent click-event)
          (fun (sender e)
            (fire! app live (fun (on) (match on ((Click msg) (Some msg)) (_ None)))))))
    (TextInputKind
     (on! control (cast RoutedEvent text-changing-event)
          (fun (sender e)
            (def s (text-box-value (cast TextBox control)))
            (fire! app live (fun (on) (match on ((Input f) (Some (f s))) (_ None)))))))
    (CheckBoxKind
     (on! control (cast RoutedEvent checked-event)
          (fun (sender e)
            (def b (.GetValueOrDefault (is-checked (cast ToggleButton control))))
            (fire! app live (fun (on) (match on ((Toggle f) (Some (f b))) (_ None)))))))
    (_ unit)))

(: (-> Kind Control))
(defun (make-control kind)
  (match kind
    (TextKind (cast Control (TextBlock.)))
    (ButtonKind
     ;; Centred, because a button given a width shows its label at the left.
     (def b (Button.))
     (ignore (set-value (cast AvaloniaObject b) (cast AvaloniaProperty content-alignment-property)
                        (cast Object HAlignment.Center) Priority.LocalValue))
     (cast Control b))
    (TextInputKind (cast Control (TextBox.)))
    (CheckBoxKind (cast Control (CheckBox.)))
    (ColumnKind (cast Control (StackPanel.)))
    (RowKind
     (def panel (StackPanel.))
     (ignore (set-value (cast AvaloniaObject panel) (cast AvaloniaProperty orientation-property)
                        (cast Object Orientation.Horizontal) Priority.LocalValue))
     (cast Control panel))))

;; 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)
             (.Add (panel-children (cast Panel 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))
        (when (stack? kind)
          (patch-children! app live (view-children next)))
        live)))

;; Children are matched by their place: the first with the first, and so on.
;; Those past the end of the shorter list are added or removed.
(: (-> (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 n (vec-length views))
  (loop (:for i (range 0 (min n (mutablevec-length kids))))
        (:do (def was (mutablevec-ref kids i))
             (def now (patch! app was (vec-ref views i)))
             (unless (eq? now was)
               (mutablevec-set! kids i now)
               (.set_Item controls i (.control now)))))
  (loop (:while (> (mutablevec-length kids) n))
        (:do (ignore (mutablevec-pop! kids))
             (.RemoveAt controls (mutablevec-length kids))))
  (loop (:for i (range (mutablevec-length kids) n))
        (:do (def c (mount app (vec-ref views i)))
             (mutablevec-add! kids c)
             (.Add controls (.control c)))))

;; An app with no window: its view is made now, and `on-root` is given the
;; control to show each time that control changes.
(: (-> %model (-> %m %model %model) (-> %model (View %m)) (-> Control void)
       (App %model %m)))
(defun (start-app init update view on-root)
  (def app (App (model init) (update update) (view view) (root None) (patching #f)
                (on-root on-root)))
  (render! app)
  app)

;; Runs the program in a window, until the window is closed.
(: (-> %model (-> %m %model %model) (-> %model (View %m))
       (#:title string) (#:width double) (#:height double)
       void))
(defun (run-app init update view #: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))
  (ignore (start-app init update view
                     (fun (c) (window-content! (cast ContentControl w) (cast Object c)))))
  (main-window! lifetime w)
  (ignore (start-lifetime lifetime (: (make-array 0) (Array ClrString)))))