bjogui/tests/lists.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/lists.bjo — list boxes, tabs, colours and borders.
;;
;;     bjo run tests/lists.bjo
;;
;; No window is opened.

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

(import/class
  (Object           (: System.Object))
  (Disposable       (: System.IDisposable))
  (AvaloniaObject   (: Avalonia.AvaloniaObject))
  (AvaloniaProperty (: Avalonia.AvaloniaProperty))
  (Priority         (: Avalonia.Data.BindingPriority))
  (Control          (: Avalonia.Controls.Control))
  (ItemsControl     (: Avalonia.Controls.ItemsControl))
  (ItemCollection   (: Avalonia.Controls.ItemCollection))
  (SelectingItemsControl (: Avalonia.Controls.Primitives.SelectingItemsControl))
  (Headered         (: Avalonia.Controls.Primitives.HeaderedContentControl))
  (ContentControl   (: Avalonia.Controls.ContentControl))
  (TextBlock        (: Avalonia.Controls.TextBlock))
  (Button           (: Avalonia.Controls.Primitives.TemplatedControl))
  (Border           (: Avalonia.Controls.Border))
  (Decorator        (: Avalonia.Controls.Decorator))
  (IBrush           (: Avalonia.Media.IBrush)))

(import/extern
  (set-value      (: Avalonia.AvaloniaObject.SetValue
                     (-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
  (selected-index-property
   (: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndexProperty #:get))
  (items          (: Avalonia.Controls.ItemsControl.Items (-> ItemsControl ItemCollection) #:get))
  (item-at        (: Avalonia.Controls.ItemCollection.get_Item (-> ItemCollection int Object)))
  (item-count     (: Avalonia.Controls.ItemsControl.ItemCount (-> ItemsControl int) #:get))
  (selected-index (: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndex
                     (-> SelectingItemsControl int) #:get))
  (header         (: Avalonia.Controls.Primitives.HeaderedContentControl.Header
                     (-> Headered Object) #:get))
  (content        (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object) #:get))
  (block-text     (: Avalonia.Controls.TextBlock.Text (-> TextBlock string) #:get))
  (foreground     (: Avalonia.Controls.TextBlock.Foreground (-> TextBlock IBrush) #:get))
  (background     (: Avalonia.Controls.TextBlock.Background (-> TextBlock IBrush) #:get))
  (button-background (: Avalonia.Controls.Primitives.TemplatedControl.Background
                        (-> Button IBrush) #:get))
  (child          (: Avalonia.Controls.Decorator.Child (-> Decorator Control) #:get))
  (border-brush   (: Avalonia.Controls.Border.BorderBrush (-> Border IBrush) #:get)))

;; ---------------------------------------------------------------------------
;; The program under test
;; ---------------------------------------------------------------------------

(type (: Msg (Union (: Chose int) (: Picked int) (: Tab int) Reverse (: Colour string))))
(type (: Model (Record (: ids (List string)) (: chosen int) (: picked int) (: tab int)
                       (: colour string))))

(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
  (next (match msg
          ((Chose i) (record-set m (chosen i)))
          ((Picked i) (record-set m (picked i)))
          ((Tab i) (record-set m (tab i)))
          (Reverse (record-set m (ids (list-reverse (.ids m)))))
          ((Colour c) (record-set m (colour c))))))

(: (-> Model (View Msg)))
(defun (view m)
  (column
    ;; 0: the items are keyed texts, and one is a dropdown, whose own choice
    ;; must not be taken for the list's.
    (list-box (vec-add (vec-map (fun (id) (keyed id (text #"item ${id}"))) (list->vec (.ids m)))
                       (keyed "drop" (dropdown ["x" "y"] (.picked m) Picked)))
              (.chosen m) Chose)
    ;; 1
    (tabs (.tab m) Tab
      (tab "One" (text "first"))
      (tab "Two" (text "second")))
    ;; 2
    (paint (text "painted") #:colour (.colour m) #:background "#00ff00")
    ;; 3
    (border (text "framed") #:colour "blue" #:thickness 2.0 #:radius 4.0 #:padding 3.0)
    ;; 4
    (paint (button "b" Reverse) #:background "#123456")))

;; ---------------------------------------------------------------------------
;; The test
;; ---------------------------------------------------------------------------

(defun (main)
  (def app (start-app (Model (ids '("a" "b" "c")) (chosen 1) (picked 0) (tab 0) (colour "red"))
                      gui-update view (fun (c) unit)))
  (defun (ctl path) (app-control-at app path))
  (defun (choose! path i)
    (ignore (set-value (cast AvaloniaObject (ctl path))
                       (cast AvaloniaProperty selected-index-property)
                       (cast Object i) Priority.LocalValue)))
  (defun (brush b) (.ToString (cast Object b)))

  ;; --- list box ---------------------------------------------------------------
  (def lb (ctl '(0)))
  (def lb-items (items (cast ItemsControl lb)))
  (expect "a list box's items" (item-count (cast ItemsControl lb)) 4)
  (expect "an item is the view's control" (eq? (item-at lb-items 0) (cast Object (ctl '(0 0)))) #t)
  (expect "the choice is set after the items" (selected-index (cast SelectingItemsControl lb)) 1)
  (choose! '(0) 2)
  (expect "a choice is a message" (.chosen (app-model app)) 2)

  (def a (ctl '(0 0)))
  (def c (ctl '(0 2)))
  (app-dispatch! app Reverse)
  (expect "reversed items keep their controls"
          (list (eq? (item-at lb-items 0) (cast Object c)) (eq? (item-at lb-items 2) (cast Object a)))
          '(#t #t))
  (expect "and the text" (block-text (cast TextBlock (ctl '(0 0)))) "item c")
  (expect "the choice is the model's after a move" (selected-index (cast SelectingItemsControl lb)) 2)

  (choose! '(0 3) 1)
  (expect "a dropdown in an item sends its own message" (.picked (app-model app)) 1)
  (expect "and not the list's" (.chosen (app-model app)) 2)

  ;; --- tabs -------------------------------------------------------------------
  (def tb (ctl '(1)))
  (expect "tabs" (item-count (cast ItemsControl tb)) 2)
  (expect "a tab's header" (.ToString (header (cast Headered (ctl '(1 1))))) "Two")
  (expect "a tab's content" (eq? (content (cast ContentControl (ctl '(1 1)))) (cast Object (ctl '(1 1 0)))) #t)
  (choose! '(1) 1)
  (expect "a tab chosen is a message" (.tab (app-model app)) 1)
  (app-dispatch! app (Tab 0))
  (expect "the model chooses the tab" (selected-index (cast SelectingItemsControl tb)) 0)

  ;; --- colours ----------------------------------------------------------------
  (def painted (cast TextBlock (ctl '(2))))
  ;; A text with no colour of its own: what the theme gives.
  (def plain (cast TextBlock (ctl '(3 0))))
  (expect "a colour" (brush (foreground painted)) "Red")
  (expect "a background" (brush (background painted)) "Lime")
  (app-dispatch! app (Colour "#80123456"))
  (expect "a colour with alpha" (brush (foreground painted)) "#80123456")
  (app-dispatch! app (Colour "no such colour"))
  (expect "a colour that cannot be read is the theme's"
          (brush (foreground painted)) (brush (foreground plain)))
  (app-dispatch! app (Colour "blue"))
  (expect "and back" (brush (foreground painted)) "Blue")
  (app-dispatch! app (Colour ""))
  (expect "no colour is the theme's" (brush (foreground painted)) (brush (foreground plain)))
  (expect "a button's background" (brush (button-background (cast Button (ctl '(4))))) "#ff123456")

  ;; --- border -----------------------------------------------------------------
  (def framed (ctl '(3)))
  (expect "a border holds its child" (eq? (child (cast Decorator framed)) (ctl '(3 0))) #t)
  (expect "its colour" (brush (border-brush (cast Border framed))) "Blue")

  (println "bjogui lists ok"))