bjogui/src/view.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/view.bjo — the module (bjogui view).
;;
;; A view is a value: what the window shows for one model. `view` functions
;; build it with the constructors here, and (bjogui app) makes the controls
;; for it and changes them when the next view differs. Nothing here knows
;; about Avalonia, so a view can be built and compared in a test with no
;; window.
;;
;; An event is a message, or a function that makes one from what the control
;; holds. The app gives the message to `update`.

(export
  ;; Types.
  View Kind Prop On

  ;; Constructors.
  text button text-input text-area checkbox slider progress-bar dropdown image
  list-box tabs tab
  menu-bar submenu menu-item menu-separator
  toggle-switch radio number-input date-picker auto-complete expander
  column row grid scroll border flow dock
  ;; Wrappers.
  keyed at paint with-context-menu tooltip at-top at-bottom at-left at-right classed

  ;; Keyboard shortcuts.
  Key key key-gesture key-message

  ;; Reading one.
  view-kind view-props view-events view-children view-key)

(import (std prelude))

;; ---------------------------------------------------------------------------
;; The types
;; ---------------------------------------------------------------------------

;; What control a view is.
(type (: Kind (Union TextKind ButtonKind TextInputKind TextAreaKind CheckBoxKind
                     SliderKind ProgressKind DropdownKind ImageKind
                     ListBoxKind TabsKind TabKind
                     MenuBarKind MenuItemKind SeparatorKind ContextKind ContextMenuKind
                     ToggleSwitchKind RadioKind NumberKind DateKind AutoCompleteKind
                     ExpanderKind WrapKind DockKind
                     ColumnKind RowKind GridKind ScrollKind BorderKind)))

;; A property of a control. A kind takes only some of them; the app ignores
;; the others.
(type (: Prop (Union (: PropLabel string)        ; the text of a text, a button or a checkbox
                     (: PropValue string)        ; the text in a text input
                     (: PropPlaceholder string)  ; shown in an empty text input
                     (: PropChecked bool)
                     (: PropEnabled bool)
                     (: PropFontSize double)
                     (: PropWidth double)
                     (: PropHeight double)
                     (: PropMargin double)
                     (: PropPadding double)
                     (: PropSpacing double)
                     (: PropWrap bool)              ; a text breaks its lines at the width
                     (: PropMinimum double)         ; of a slider or a progress bar
                     (: PropMaximum double)
                     (: PropAmount double)          ; where a slider or a progress bar is
                     (: PropStep double)            ; what an arrow key moves a slider by
                     (: PropItems (Vec string))     ; what a dropdown offers
                     (: PropSelected int)           ; which item is chosen; -1 for none
                     (: PropSource string)          ; the file an image shows
                     (: PropColumns string)         ; a grid's columns, as "Auto,*,2*"
                     (: PropRows string)
                     (: PropRow int)                ; where a view is in its grid
                     (: PropColumn int)
                     (: PropRowSpan int)
                     (: PropColumnSpan int)
                     (: PropBackground string)      ; a colour: "red", "#08f", "#80ff8800"
                     (: PropForeground string)      ; the colour of the text
                     (: PropBorderColour string)
                     (: PropBorderWidth double)
                     (: PropRadius double)          ; how round a border's corners are
                     (: PropShortcut string)        ; a menu item's keys, as "Ctrl+S"
                     (: PropTip string)             ; shown when the pointer rests on a view
                     (: PropExpanded bool)          ; whether an expander shows its content
                     (: PropDate string)            ; a date picker's date, as "2026-10-25"
                     (: PropDockSide int)           ; where a view is in its dock: 0 to 3
                     (: PropClasses (Vec string)))))  ; the classes that styles match

;; An event, and the message it sends.
(type (: (On %m) (Union (: OnClick %m)
                        (: OnInput (-> string %m))
                        (: OnToggle (-> bool %m))
                        (: OnSlide (-> double %m))
                        (: OnSelect (-> int %m)))))

;; One control and what is in it.
;;
;; `key` says which child of its parent a view is. Children with keys are
;; matched by key when the next view is compared with the last one, so a
;; child that moves keeps its control. Children without one are matched by
;; their place among the others without one.
(type (: (View %m) (Record (: kind Kind)
                           (: props (Vec Prop))
                           (: events (Vec (On %m)))
                           (: children (Vec (View %m)))
                           (: key (Option string)))))

(: view-kind (-> (View %m) Kind))
(defun (view-kind v) (.kind v))

(: view-props (-> (View %m) (Vec Prop)))
(defun (view-props v) (.props v))

(: view-events (-> (View %m) (Vec (On %m))))
(defun (view-events v) (.events v))

(: view-children (-> (View %m) (Vec (View %m))))
(defun (view-children v) (.children v))

(: view-key (-> (View %m) (Option string)))
(defun (view-key v) (.key v))

;; ---------------------------------------------------------------------------
;; Wrappers
;; ---------------------------------------------------------------------------

;; The view, with a key that says which child it is. Give each item of a list
;; that can change order a key of its own, such as its id.
(: keyed (-> string (View %m) (View %m)))
(defun (keyed key v)
  (record-set v (key (Some key))))

;; The view, in colours. A colour is a name, such as "red", or "#rgb",
;; "#rrggbb" or "#aarrggbb". The empty string, the default, leaves the colour
;; to the theme, and so does a colour that cannot be read.
(: paint (-> (View %m) (#:colour string) (#:background string) (View %m)))
(defun (paint v #:colour "" #:background "")
  (defun (with props make c) (if (string-empty? c) props (vec-add props (make c))))
  (record-set v (props (with (with (.props v) PropForeground colour) PropBackground background))))

;; The view, with a menu that opens when it is clicked with the right button.
;; The items are made by `menu-item`, `submenu` and `menu-separator`.
(: with-context-menu (-> (View %m) #:rest (View %m) (View %m)))
(defun (with-context-menu v #:rest items)
  (container ContextKind [] [v (container ContextMenuKind [] (array->vec items))]))

;; The view, in the classes `names`, which the styles given to `run-app`
;; match with `#:class`.
(: classed (-> (View %m) #:rest string (View %m)))
(defun (classed v #:rest names)
  (record-set v (props (vec-add (.props v) (PropClasses (array->vec names))))))

;; The view, with `text` shown when the pointer rests on it.
(: tooltip (-> (View %m) string (View %m)))
(defun (tooltip v text)
  (record-set v (props (vec-add (.props v) (PropTip text)))))

(: (-> int (View %m) (View %m)))
(defun (docked side v)
  (record-set v (props (vec-add (.props v) (PropDockSide side)))))

;; The view, at an edge of its dock. The last child of a dock that is put at
;; no edge fills what is left.
(: at-left (-> (View %m) (View %m)))
(defun (at-left v) (docked 0 v))

(: at-top (-> (View %m) (View %m)))
(defun (at-top v) (docked 1 v))

(: at-right (-> (View %m) (View %m)))
(defun (at-right v) (docked 2 v))

(: at-bottom (-> (View %m) (View %m)))
(defun (at-bottom v) (docked 3 v))

;; The view, in a cell of its grid. Rows and columns count from 0.
(: at (-> int int (View %m) (#:row-span int) (#:column-span int) (View %m)))
(defun (at row column v #:row-span 1 #:column-span 1)
  (record-set v (props (vec-add (vec-add (vec-add (vec-add (.props v) (PropRow row)) (PropColumn column))
                                         (PropRowSpan row-span))
                                (PropColumnSpan column-span)))))

;; ---------------------------------------------------------------------------
;; Constructors
;; ---------------------------------------------------------------------------

;; A size of zero or less means: the size the control asks for. The
;; constructors leave such a size out of the props, so the control keeps its
;; own.
(: (-> (Vec Prop) (-> double Prop) double (Vec Prop)))
(defun (with-size props make size)
  (if (> size 0.0) (vec-add props (make size)) props))

(: (-> (Vec Prop) double double double double (Vec Prop)))
(defun (with-layout props width height margin padding)
  (with-size (with-size (with-size (with-size props PropWidth width) PropHeight height)
                        PropMargin margin)
             PropPadding padding))

(: (-> Kind (Vec Prop) (Vec (On %m)) (View %m)))
(defun (leaf kind props events)
  (View (kind kind) (props props) (events events) (children []) (key None)))

;; A text.
(: (-> string (#:size double) (#:wrap bool) (#:width double) (#:height double)
       (#:margin double)
       (View %m)))
(defun (text s #:size 0.0 #:wrap #f #:width 0.0 #:height 0.0 #:margin 0.0)
  (leaf TextKind
        (with-layout (with-size [(PropLabel s) (PropWrap wrap)] PropFontSize size) width height margin 0.0)
        []))

;; A button that sends `msg` when it is clicked.
(: (-> string %m (#:enabled bool) (#:width double) (#:height double)
       (#:margin double) (#:padding double)
       (View %m)))
(defun (button label msg #:enabled #t #:width 0.0 #:height 0.0 #:margin 0.0 #:padding 0.0)
  (leaf ButtonKind
        (with-layout [(PropLabel label) (PropEnabled enabled)] width height margin padding)
        [(OnClick msg)]))

;; A one-line text input that holds `value`. Each change sends `(on-input
;; text)`, with the whole text.
(: (-> string (-> string %m) (#:placeholder string) (#:enabled bool)
       (#:width double) (#:margin double)
       (View %m)))
(defun (text-input value on-input #:placeholder "" #:enabled #t #:width 0.0 #:margin 0.0)
  (leaf TextInputKind
        (with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)]
                     width 0.0 margin 0.0)
        [(OnInput on-input)]))

;; A text input of several lines, that breaks its lines at its width. Each
;; change sends `(on-input text)`, with the whole text.
(: (-> string (-> string %m) (#:placeholder string) (#:enabled bool)
       (#:width double) (#:height double) (#:margin double)
       (View %m)))
(defun (text-area value on-input #:placeholder "" #:enabled #t #:width 0.0 #:height 0.0
                  #:margin 0.0)
  (leaf TextAreaKind
        (with-layout [(PropValue value) (PropPlaceholder placeholder) (PropEnabled enabled)]
                     width height margin 0.0)
        [(OnInput on-input)]))

;; A slider at `value`, from `minimum` to `maximum`. A move sends `(on-change
;; value)`.
(: (-> double double double (-> double %m) (#:step double) (#:enabled bool)
       (#:width double) (#:margin double)
       (View %m)))
(defun (slider value minimum maximum on-change #:step 1.0 #:enabled #t #:width 0.0
               #:margin 0.0)
  ;; The bounds come before the value, because a value outside the bounds
  ;; that are there is moved inside them.
  (leaf SliderKind
        (with-layout [(PropMinimum minimum) (PropMaximum maximum) (PropAmount value) (PropStep step)
                      (PropEnabled enabled)]
                     width 0.0 margin 0.0)
        [(OnSlide on-change)]))

;; A bar that is `value` of the way from 0 to `#:maximum`, 1 unless told
;; otherwise.
(: (-> double (#:maximum double) (#:width double) (#:margin double) (View %m)))
(defun (progress-bar value #:maximum 1.0 #:width 0.0 #:margin 0.0)
  (leaf ProgressKind
        (with-layout [(PropMinimum 0.0) (PropMaximum maximum) (PropAmount value)] width 0.0 margin 0.0)
        []))

;; A list to choose one of `options` from, with the one at `selected` chosen,
;; or none for -1. A choice sends `(on-select index)`.
(: (-> (Vec string) int (-> int %m) (#:enabled bool) (#:width double) (#:margin double)
       (View %m)))
(defun (dropdown options selected on-select #:enabled #t #:width 0.0 #:margin 0.0)
  ;; The items come before the choice, because the choice is an index into
  ;; them.
  (leaf DropdownKind
        (with-layout [(PropItems options) (PropSelected selected) (PropEnabled enabled)]
                     width 0.0 margin 0.0)
        [(OnSelect on-select)]))

;; The picture in the file at `path`. A file that cannot be read shows
;; nothing.
(: (-> string (#:width double) (#:height double) (#:margin double) (View %m)))
(defun (image path #:width 0.0 #:height 0.0 #:margin 0.0)
  (leaf ImageKind (with-layout [(PropSource path)] width height margin 0.0) []))

;; A list of views to choose one of, with the one at `selected` chosen, or
;; none for -1. A choice sends `(on-select index)`. Give the items keys if
;; the list can change order.
(: (-> (Vec (View %m)) int (-> int %m) (#:width double) (#:height double) (#:margin double)
       (View %m)))
(defun (list-box items selected on-select #:width 0.0 #:height 0.0 #:margin 0.0)
  (View (kind ListBoxKind)
        (props (with-layout [(PropSelected selected)] width height margin 0.0))
        (events [(OnSelect on-select)])
        (children items)
        (key None)))

;; Tabs, with the one at `selected` shown. A click on another tab sends
;; `(on-select index)`. Each tab is made by `tab`.
(: (-> int (-> int %m) (#:margin double) #:rest (View %m) (View %m)))
(defun (tabs selected on-select #:margin 0.0 #:rest tabs)
  (View (kind TabsKind)
        (props (with-layout [(PropSelected selected)] 0.0 0.0 margin 0.0))
        (events [(OnSelect on-select)])
        (children (array->vec tabs))
        (key None)))

;; A tab of `tabs`: its header, and what it shows when it is chosen.
(: (-> string (View %m) (View %m)))
(defun (tab header content)
  (View (kind TabKind) (props [(PropLabel header)]) (events []) (children [content]) (key None)))

;; A bar of menus, made by `submenu`, for the top of the window.
(: (-> #:rest (View %m) (View %m)))
(defun (menu-bar #:rest menus)
  (container MenuBarKind [] (array->vec menus)))

;; A menu of items, in a menu bar or in another menu.
(: (-> string #:rest (View %m) (View %m)))
(defun (submenu label #:rest items)
  (View (kind MenuItemKind) (props [(PropLabel label)]) (events []) (children (array->vec items))
        (key None)))

;; An item that sends `msg` when it is chosen. `#:shortcut`, such as
;; "Ctrl+S", is shown beside it, and the keys send `msg` too while the item
;; is in the view and enabled.
(: (-> string %m (#:shortcut string) (#:enabled bool) (View %m)))
(defun (menu-item label msg #:shortcut "" #:enabled #t)
  (leaf MenuItemKind
        (if (string-empty? shortcut)
            [(PropLabel label) (PropEnabled enabled)]
            [(PropLabel label) (PropEnabled enabled) (PropShortcut shortcut)])
        [(OnClick msg)]))

;; A line between items of a menu.
(: (-> (View %m)))
(defun (menu-separator)
  (leaf SeparatorKind [] []))

;; A switch that is on when `on?`. A flip sends `(on-toggle on)`.
(: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m)))
(defun (toggle-switch label on? on-toggle #:enabled #t #:margin 0.0)
  (leaf ToggleSwitchKind
        (with-layout [(PropLabel label) (PropChecked on?) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
        [(OnToggle on-toggle)]))

;; One of a set of choices, chosen when `chosen?`. Choosing it sends `msg`.
;; The model says which is chosen, so give one of a set `#t` and the others
;; `#f`.
(: (-> string bool %m (#:enabled bool) (#:margin double) (View %m)))
(defun (radio label chosen? msg #:enabled #t #:margin 0.0)
  (leaf RadioKind
        (with-layout [(PropLabel label) (PropChecked chosen?) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
        [(OnClick msg)]))

;; A number to type, or to step with arrows by `#:step`. A change sends
;; `(on-change value)`.
(: (-> double (-> double %m) (#:minimum double) (#:maximum double) (#:step double)
       (#:enabled bool) (#:width double) (#:margin double)
       (View %m)))
(defun (number-input value on-change #:minimum -1e9 #:maximum 1e9 #:step 1.0 #:enabled #t
                     #:width 0.0 #:margin 0.0)
  (leaf NumberKind
        (with-layout [(PropMinimum minimum) (PropMaximum maximum) (PropStep step) (PropAmount value)
                      (PropEnabled enabled)]
                     width 0.0 margin 0.0)
        [(OnSlide on-change)]))

;; A date to pick, as "2026-10-25", or "" for none. A pick sends
;; `(on-change date)`.
(: (-> string (-> string %m) (#:enabled bool) (#:margin double) (View %m)))
(defun (date-picker date on-change #:enabled #t #:margin 0.0)
  (leaf DateKind (with-layout [(PropDate date) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
        [(OnInput on-change)]))

;; A text input that offers the `options` that match what is typed. Each
;; change sends `(on-input text)`.
(: (-> string (Vec string) (-> string %m) (#:placeholder string) (#:width double)
       (#:margin double)
       (View %m)))
(defun (auto-complete value options on-input #:placeholder "" #:width 0.0 #:margin 0.0)
  (leaf AutoCompleteKind
        (with-layout [(PropItems options) (PropValue value) (PropPlaceholder placeholder)] width 0.0 margin 0.0)
        [(OnInput on-input)]))

;; A header that shows `child` below it when `expanded?`. A click on the
;; header sends `(on-toggle expanded)`.
(: (-> string bool (-> bool %m) (View %m) (#:margin double) (View %m)))
(defun (expander header expanded? on-toggle child #:margin 0.0)
  (View (kind ExpanderKind)
        (props (with-layout [(PropLabel header) (PropExpanded expanded?)] 0.0 0.0 margin 0.0))
        (events [(OnToggle on-toggle)])
        (children [child])
        (key None)))

;; A checkbox that is `checked?`. A click sends `(on-toggle checked)`, with
;; the new state.
(: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m)))
(defun (checkbox label checked? on-toggle #:enabled #t #:margin 0.0)
  (leaf CheckBoxKind
        (with-layout [(PropLabel label) (PropChecked checked?) (PropEnabled enabled)] 0.0 0.0 margin 0.0)
        [(OnToggle on-toggle)]))

(: (-> Kind (Vec Prop) (Vec (View %m)) (View %m)))
(defun (container kind props children)
  (View (kind kind) (props props) (events []) (children children) (key None)))

(: (-> Kind double double (Array (View %m)) (View %m)))
(defun (stack kind spacing margin children)
  (container kind (with-layout (with-size [] PropSpacing spacing) 0.0 0.0 margin 0.0)
             (array->vec children)))

;; Views one above the other.
(: (-> (#:spacing double) (#:margin double) #:rest (View %m) (View %m)))
(defun (column #:spacing 0.0 #:margin 0.0 #:rest children)
  (stack ColumnKind spacing margin children))

;; Views side by side.
(: (-> (#:spacing double) (#:margin double) #:rest (View %m) (View %m)))
(defun (row #:spacing 0.0 #:margin 0.0 #:rest children)
  (stack RowKind spacing margin children))

;; Views in the cells of a grid. `#:columns` and `#:rows` are the sizes, as
;; in Avalonia: "Auto" fits the content, "*" shares what is left, "2*" takes
;; two shares, and a number is pixels. Put a view in a cell with `at`; one
;; that is not put anywhere is in the first.
(: (-> (#:columns string) (#:rows string) (#:spacing double) (#:margin double)
       #:rest (View %m) (View %m)))
(defun (grid #:columns "*" #:rows "*" #:spacing 0.0 #:margin 0.0 #:rest children)
  (container GridKind
             (with-layout (with-size [(PropColumns columns) (PropRows rows)] PropSpacing spacing)
                          0.0 0.0 margin 0.0)
             (array->vec children)))

;; A view in a frame: a line of `#:colour` and `#:thickness` around it,
;; corners as round as `#:radius`, `#:background` behind it, and `#:padding`
;; between the line and the view.
(: (-> (View %m) (#:colour string) (#:thickness double) (#:radius double)
       (#:background string) (#:padding double) (#:margin double)
       (View %m)))
(defun (border child #:colour "" #:thickness 1.0 #:radius 0.0 #:background ""
               #:padding 0.0 #:margin 0.0)
  (defun (with props make c) (if (string-empty? c) props (vec-add props (make c))))
  (container BorderKind
             (with (with (with-size (with-size (with-layout [] 0.0 0.0 margin padding)
                                               PropBorderWidth thickness)
                                    PropRadius radius)
                         PropBorderColour colour)
                   PropBackground background)
             [child]))

;; Views side by side, on as many lines as they need.
(: (-> (#:spacing double) (#:margin double) #:rest (View %m) (View %m)))
(defun (flow #:spacing 0.0 #:margin 0.0 #:rest children)
  (stack WrapKind spacing margin children))

;; Views at the edges, put there with `at-top`, `at-bottom`, `at-left` and
;; `at-right`, in order from the outside in. The last child, at no edge,
;; fills the middle.
(: (-> (#:margin double) #:rest (View %m) (View %m)))
(defun (dock #:margin 0.0 #:rest children)
  (stack DockKind 0.0 margin children))

;; A view that scrolls when it is taller than the space it has.
(: (-> (View %m) (#:width double) (#:height double) (#:margin double) (View %m)))
(defun (scroll child #:width 0.0 #:height 0.0 #:margin 0.0)
  (container ScrollKind (with-layout [] width height margin 0.0) [child]))

;; ---------------------------------------------------------------------------
;; Keyboard shortcuts
;; ---------------------------------------------------------------------------

;; Keys, such as "Ctrl+N" or "F5", and the message they send.
(type (: (Key %m) (Record (: gesture string) (: msg %m))))

;; `msg` is sent when `gesture` is pressed in the window, and no control that
;; has the keyboard takes the keys itself.
(: key (-> string %m (Key %m)))
(defun (key gesture msg) (Key (gesture gesture) (msg msg)))

(: key-gesture (-> (Key %m) string))
(defun (key-gesture k) (.gesture k))

(: key-message (-> (Key %m) %m))
(defun (key-message k) (.msg k))