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
  column row grid scroll border
  ;; Wrappers.
  keyed at paint with-context-menu

  ;; 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
                     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 (: Label string)        ; the text of a text, a button or a checkbox
                     (: Value string)        ; the text in a text input
                     (: Placeholder string)  ; shown in an empty text input
                     (: Checked bool)
                     (: Enabled bool)
                     (: FontSize double)
                     (: Width double)
                     (: Height double)
                     (: Margin double)
                     (: Padding double)
                     (: Spacing double)
                     (: Wrap bool)              ; a text breaks its lines at the width
                     (: Minimum double)         ; of a slider or a progress bar
                     (: Maximum double)
                     (: Amount double)          ; where a slider or a progress bar is
                     (: Step double)            ; what an arrow key moves a slider by
                     (: Items (Vec string))     ; what a dropdown offers
                     (: Selected int)           ; which item is chosen; -1 for none
                     (: Source string)          ; the file an image shows
                     (: Columns string)         ; a grid's columns, as "Auto,*,2*"
                     (: Rows string)
                     (: Row int)                ; where a view is in its grid
                     (: Column int)
                     (: RowSpan int)
                     (: ColumnSpan int)
                     (: Background string)      ; a colour: "red", "#08f", "#80ff8800"
                     (: Foreground string)      ; the colour of the text
                     (: BorderColour string)
                     (: BorderWidth double)
                     (: Radius double)          ; how round a border's corners are
                     (: Shortcut string))))     ; a menu item's keys, as "Ctrl+S"

;; An event, and the message it sends.
(type (: (On %m) (Union (: Click %m)
                        (: Input (-> string %m))
                        (: Toggle (-> bool %m))
                        (: Slide (-> double %m))
                        (: Select (-> int %m)))))

;; One control and what is in it.
;;
;; `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) Foreground colour) Background 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 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) (Row row)) (Column column))
                                         (RowSpan row-span))
                                (ColumnSpan 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 Width width) Height height)
                        Margin margin)
             Padding 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 [(Label s) (Wrap wrap)] FontSize 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 [(Label label) (Enabled enabled)] width height margin padding)
        [(Click msg)]))

;; A one-line text input that holds `value`. Each change sends `(on-input
;; text)`, with the whole text.
(: (-> 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 [(Value value) (Placeholder placeholder) (Enabled enabled)]
                     width 0.0 margin 0.0)
        [(Input on-input)]))

;; A text input of several lines, that breaks its lines at its width. Each
;; change sends `(on-input text)`, with the whole text.
(: (-> 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 [(Value value) (Placeholder placeholder) (Enabled enabled)]
                     width height margin 0.0)
        [(Input 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 [(Minimum minimum) (Maximum maximum) (Amount value) (Step step)
                      (Enabled enabled)]
                     width 0.0 margin 0.0)
        [(Slide on-change)]))

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

;; A list to choose one of `options` from, with the one at `selected` chosen,
;; 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 [(Items options) (Selected selected) (Enabled enabled)]
                     width 0.0 margin 0.0)
        [(Select on-select)]))

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

;; A list of views to choose one of, with the one at `selected` chosen, or
;; none for -1. A choice sends `(on-select index)`. Give the items keys if
;; 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 [(Selected selected)] width height margin 0.0))
        (events [(Select 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 [(Selected selected)] 0.0 0.0 margin 0.0))
        (events [(Select on-select)])
        (children (array->vec tabs))
        (key None)))

;; A tab of `tabs`: its header, and what it shows when it is chosen.
(: (-> string (View %m) (View %m)))
(defun (tab header content)
  (View (kind TabKind) (props [(Label 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 [(Label 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)
            [(Label label) (Enabled enabled)]
            [(Label label) (Enabled enabled) (Shortcut shortcut)])
        [(Click msg)]))

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

;; 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 [(Label label) (Checked checked?) (Enabled enabled)] 0.0 0.0 margin 0.0)
        [(Toggle on-toggle)]))

(: (-> Kind (Vec Prop) (Vec (View %m)) (View %m)))
(defun (container kind props children)
  (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 [] Spacing 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 [(Columns columns) (Rows rows)] Spacing 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)
                                               BorderWidth thickness)
                                    Radius radius)
                         BorderColour colour)
                   Background background)
             [child]))

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