bjogui/tests/controls.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/tests/controls.bjo — keyed children, and the controls past the
;; first six.
;;
;;     bjo run tests/controls.bjo
;;
;; No window is opened. Controls are compared by identity with `eq?`, to see
;; which were kept and which were made new.

(import (std prelude))
(import (std simpletest))
(import (bjogui view))
(import (bjogui app))
(import (std interop))

(import/class
  (Object           (: System.Object))
  (Disposable       (: System.IDisposable))
  (AvaloniaObject   (: Avalonia.AvaloniaObject))
  (AvaloniaProperty (: Avalonia.AvaloniaProperty))
  (Priority         (: Avalonia.Data.BindingPriority))
  (Control          (: Avalonia.Controls.Control))
  (Controls         (: Avalonia.Controls.Controls))
  (Panel            (: Avalonia.Controls.Panel))
  (Grid             (: Avalonia.Controls.Grid))
  (ColumnDefs       (: Avalonia.Controls.ColumnDefinitions))
  (TextBlock        (: Avalonia.Controls.TextBlock))
  (TextBox          (: Avalonia.Controls.TextBox))
  (ContentControl   (: Avalonia.Controls.ContentControl))
  (ScrollViewer     (: Avalonia.Controls.ScrollViewer))
  (RangeBase        (: Avalonia.Controls.Primitives.RangeBase))
  (ItemsControl     (: Avalonia.Controls.ItemsControl))
  (SelectingItemsControl (: Avalonia.Controls.Primitives.SelectingItemsControl))
  (Image            (: Avalonia.Controls.Image))
  (IImage           (: Avalonia.Media.IImage)))

(import/extern
  (set-value      (: Avalonia.AvaloniaObject.SetValue
                     (-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
  (range-value-property (: Avalonia.Controls.Primitives.RangeBase.ValueProperty #:get))
  (selected-index-property
   (: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndexProperty #:get))
  (children       (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get))
  (count          (: Avalonia.Controls.Controls.Count (-> Controls int) #:get))
  (child-at       (: Avalonia.Controls.Controls.get_Item (-> Controls int Control)))
  (block-text     (: Avalonia.Controls.TextBlock.Text (-> TextBlock string) #:get))
  (box-text!      (: Avalonia.Controls.TextBox.Text (-> TextBox string void) #:set))
  (accepts-return? (: Avalonia.Controls.TextBox.AcceptsReturn (-> TextBox bool) #:get))
  (range-value    (: Avalonia.Controls.Primitives.RangeBase.Value (-> RangeBase double) #:get))
  (range-maximum  (: Avalonia.Controls.Primitives.RangeBase.Maximum (-> RangeBase double) #:get))
  (item-count     (: Avalonia.Controls.ItemsControl.ItemCount (-> ItemsControl int) #:get))
  (selected-index (: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndex
                     (-> SelectingItemsControl int) #:get))
  (grid-row       (: Avalonia.Controls.Grid.GetRow (-> Control int)))
  (grid-column    (: Avalonia.Controls.Grid.GetColumn (-> Control int)))
  (grid-columns   (: Avalonia.Controls.Grid.ColumnDefinitions (-> Grid ColumnDefs) #:get))
  (scroll-content (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object) #:get))
  (image-source   (: Avalonia.Controls.Image.Source (-> Image IImage) #:get))
  (null?          (: System.Object.ReferenceEquals (-> Object Object bool))))

;; ---------------------------------------------------------------------------
;; A list, keyed or not
;; ---------------------------------------------------------------------------

(type (: Item (Record (: id string) (: name string))))
;; The items, and whether to key them.
(type (: Lst (Record (: items (List Item)) (: keyed? bool))))

(: (-> Lst Lst (Tuple Lst (List (Event Lst)))))
(defun (replace msg m) (next msg))

(: (-> Lst (View Lst)))
(defun (list-view l)
  (apply column
         (vec->array
           (vec-map (fun (it)
                      (def v (text (.name it)))
                      (if (.keyed? l) (keyed (.id it) v) v))
                    (list->vec (.items l))))))

(: (-> (List string) bool Lst))
(defun (items ids keyed?)
  (Lst (items (list-map item ids)) (keyed? keyed?)))

(: (-> string Item))
(defun (item id) (Item (id id) (name (string-append "item " id))))

;; ---------------------------------------------------------------------------
;; The other controls
;; ---------------------------------------------------------------------------

(type (: Msg (Union (: Typed string) (: Slid double) (: Chose int) (: Show bool) Nothing)))
(type (: Model (Record (: notes string) (: level double) (: choice int) (: scrolled bool))))

(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
  (next (match msg
          ((Typed s) (record-set m (notes s)))
          ((Slid d) (record-set m (level d)))
          ((Chose i) (record-set m (choice i)))
          ((Show b) (record-set m (scrolled b)))
          (Nothing m))))

(: (-> Model (View Msg)))
(defun (view m)
  (column
    (text-area (.notes m) Typed #:height 80.0)                          ; 0
    (slider (.level m) 0.0 10.0 Slid)                                   ; 1
    (progress-bar (/ (.level m) 10.0))                                  ; 2
    (dropdown ["red" "green" "blue"] (.choice m) Chose)                 ; 3
    (grid #:columns "Auto,*" #:rows "Auto,Auto" #:spacing 4.0           ; 4
      (at 0 0 (text "name"))
      (at 0 1 (text "value"))
      (at 1 1 (text (.notes m))))
    (scroll (if (.scrolled m) (column (text "a") (text "b")) (text "just one"))
            #:height 50.0)                                              ; 5
    (image "/no/such/file.png" #:width 10.0)                            ; 6
    (text "a long line" #:wrap #t)))                                    ; 7

(defun (main)
  ;; --- keyed children ---------------------------------------------------------
  (def lst (start-app (items '("a" "b" "c") #t)
                      replace list-view (fun (c) unit)))
  (defun (at-row i) (app-control-at lst (list i)))
  (defun (names)
    (def kids (children (cast Panel (app-control lst))))
    (loop (:for i (range 0 (count kids)))
          (:acc out (listing (block-text (cast TextBlock (child-at kids i)))))
          => out))
  (def a (at-row 0))
  (def b (at-row 1))
  (def c (at-row 2))

  (app-dispatch! lst (items '("c" "b" "a") #t))
  (expect "reversed" (names) '("item c" "item b" "item a"))
  (expect "the controls moved with their keys"
          (list (eq? (at-row 0) c) (eq? (at-row 1) b) (eq? (at-row 2) a)) '(#t #t #t))

  (app-dispatch! lst (items '("z" "c" "b" "a") #t))
  (expect "one put in front" (names) '("item z" "item c" "item b" "item a"))
  (expect "the others kept" (list (eq? (at-row 1) c) (eq? (at-row 3) a)) '(#t #t))

  (app-dispatch! lst (items '("z" "b" "a") #t))
  (expect "one taken out" (names) '("item z" "item b" "item a"))
  (expect "the rest kept" (list (eq? (at-row 1) b) (eq? (at-row 2) a)) '(#t #t))

  (app-dispatch! lst (items '("a" "a" "b") #t))
  (expect "a key twice" (names) '("item a" "item a" "item b"))
  (expect "the first keeps the control" (eq? (at-row 0) a) #t)

  ;; With no keys, children are matched by place: the first control now
  ;; shows what the new first item is.
  (app-dispatch! lst (items '("a" "b") #f))
  (def first (at-row 0))
  (app-dispatch! lst (items '("y" "a" "b") #f))
  (expect "unkeyed, by place" (names) '("item y" "item a" "item b"))
  (expect "the first control shows the new first" (eq? (at-row 0) first) #t)

  ;; --- the other controls -----------------------------------------------------
  (def app (start-app (Model (notes "") (level 2.0) (choice 1) (scrolled #f))
                      gui-update view (fun (c) unit)))
  (defun (ctl i) (app-control-at app (list i)))

  (def area (cast TextBox (ctl 0)))
  (expect "a text area takes Enter" (accepts-return? area) #t)
  (box-text! area "one\ntwo")
  (expect "a text area sends its text" (.notes (app-model app)) "one\ntwo")

  (def slide (cast RangeBase (ctl 1)))
  (expect "a slider's value" (range-value slide) 2.0)
  (expect "a slider's bounds" (range-maximum slide) 10.0)
  (ignore (set-value (cast AvaloniaObject slide) (cast AvaloniaProperty range-value-property)
                     (cast Object 7.0) Priority.LocalValue))
  (expect "a slider sends where it is" (.level (app-model app)) 7.0)
  (expect "a progress bar follows" (range-value (cast RangeBase (ctl 2))) 0.7)

  (def drop (cast SelectingItemsControl (ctl 3)))
  (expect "a dropdown's items" (item-count (cast ItemsControl drop)) 3)
  (expect "a dropdown's choice" (selected-index drop) 1)
  (ignore (set-value (cast AvaloniaObject drop) (cast AvaloniaProperty selected-index-property)
                     (cast Object 2) Priority.LocalValue))
  (expect "a dropdown sends the choice" (.choice (app-model app)) 2)

  (def g (cast Grid (ctl 4)))
  (expect "a grid's columns" (.-Count (grid-columns g)) 2)
  (expect "a cell" (list (grid-row (app-control-at app '(4 2))) (grid-column (app-control-at app '(4 2))))
          '(1 1))
  (expect "the cell shows the model" (block-text (cast TextBlock (app-control-at app '(4 2)))) "one\ntwo")

  (def sc (cast ContentControl (ctl 5)))
  (def inner (app-control-at app '(5 0)))
  (expect "a scroll holds its child" (eq? (scroll-content sc) (cast Object inner)) #t)
  (app-dispatch! app (Show #t))
  (expect "a child of another kind replaces it"
          (eq? (scroll-content sc) (cast Object (app-control-at app '(5 0)))) #t)
  (expect "and is not the old one" (eq? (app-control-at app '(5 0)) inner) #f)

  (expect "an image that cannot be read shows nothing"
          (null? (cast Object (image-source (cast Image (ctl 6)))) (clr-default)) #t)

  (println "bjogui controls ok"))