bjogui/tests/native.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/native.bjo — controls that bjogui does not wrap.
;;
;;     bjo run tests/native.bjo
;;
;; No window is opened. A TextBox and a Calendar are made by the program, as
;; any control of Avalonia's or another package's would be.

(import (std prelude))
(import (std simpletest))
(import (std interop))
(import (std mutable vec))
(import (bjogui view))
(import (bjogui app))
(import (bjogui native))

(import/class
  (Object      (: System.Object))
  (Control     (: Avalonia.Controls.Control))
  (Layoutable  (: Avalonia.Layout.Layoutable))
  (TextBox     (: Avalonia.Controls.TextBox (-> TextBox)))
  (Calendar    (: Avalonia.Controls.Calendar (-> Calendar)))
  (RoutedEvent (: Avalonia.Interactivity.RoutedEvent))
  (RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs))
  (Interactive (: Avalonia.Interactivity.Interactive))
  (Routes      (: Avalonia.Interactivity.RoutingStrategies))
  ((EventHandler %a) (: System.EventHandler)))

(import/extern
  (text-of        (: Avalonia.Controls.TextBox.Text (-> TextBox string) #:get))
  (text!          (: Avalonia.Controls.TextBox.Text (-> TextBox string void) #:set))
  (text-changing  (: Avalonia.Controls.TextBox.TextChangingEvent #:get))
  (add-handler    (: Avalonia.Interactivity.Interactive.AddHandler
                     (-> Interactive RoutedEvent Delegate Routes bool void)))
  (width-of       (: Avalonia.Layout.Layoutable.Width (-> Layoutable double) #:get))
  (display-mode-of (: Avalonia.Controls.Calendar.DisplayMode (-> Calendar Avalonia.Controls.CalendarMode) #:get)))

;; What the controls were asked to do, in order.
(: calls (MutableVec string))
(def calls (mutablevec))
(: (-> string void))
(defun (note! s) (mutablevec-add! calls s))

;; A text box made by the program, which sends its whole text.
(: box (Native string string))
(def box
  (native (fun (send)
            (note! "make box")
            (def t (TextBox.))
            (add-handler (cast Interactive t) (cast RoutedEvent text-changing)
                         (cast Delegate (cast Object (: (as-delegate (: (fun (s e) (send (text-of t)))
                                                                       (-> Object RoutedEventArgs void)))
                                                        (EventHandler RoutedEventArgs))))
                         Routes.Bubble #f)
            (cast Control t))
          (fun (control value)
            (note! #"update box ${value}")
            (text! (cast TextBox control) value))))

;; A calendar, which sends nothing.
(: calendar (Native int Unit))
(def calendar
  (native (fun (send) (note! "make calendar") (cast Control (Calendar.)))
          (fun (control value) (note! #"update calendar ${value}"))))

;; A control whose value can be None, which is null at run time.
(: maybe (Native (Option string) Unit))
(def maybe
  (native (fun (send) (cast Control (TextBox.)))
          (fun (control value) (note! #"update maybe ${(written value)}"))))

(type (: Msg (Union (: Typed string) (: Set string) Noop Swap (: Inner string))))
(type (: Model (Record (: text string) (: typed (List string)) (: swap bool) (: noops int))))

(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
  (next (match msg
          ((Typed s) (record-set m (typed (cons s (.typed m)))))
          ((Set s) (record-set m (text s)))
          (Noop (record-set m (noops (+ (.noops m) 1))))
          (Swap (record-set m (swap (not (.swap m)))))
          ((Inner s) (record-set m (typed (cons #"inner ${s}" (.typed m))))))))

(: (-> Model (View Msg)))
(defun (view m)
  (column
    (hosted box (.text m) Typed #:width 120.0)                            ; 0
    (if (.swap m)                                                         ; 1
        (hosted calendar 3 (fun (u) Noop))
        (hosted box "second" Typed))
    (view-map Inner (hosted box "mapped" (fun (s) s)))                    ; 2
    (hosted maybe None (fun (u) Noop))))                                  ; 3

(defun (main)
  (def app (start-app (Model (text "a") (typed '()) (swap #f) (noops 0)) gui-update view (fun (c) unit)))
  (defun (ctl path) (app-control-at app path))
  (defun (calls-since n) (vec-drop (mutablevec->vec calls) n))

  (expect "each control is made, and given its value"
          (mutablevec->vec calls)
          ["make box" "update box a" "make box" "update box second" "make box" "update box mapped"
           "update maybe None"])
  (expect "the value is on the control" (text-of (cast TextBox (ctl '(0)))) "a")
  (expect "what it sent while it was given the value is dropped" (.typed (app-model app)) '())
  (expect "the view's size is the control's" (width-of (cast Layoutable (ctl '(0)))) 120.0)

  (def n (mutablevec-length calls))
  (app-dispatch! app (Set "b"))
  (expect "a new value is put on the control" (calls-since n) ["update box b"])
  (expect "and it is shown" (text-of (cast TextBox (ctl '(0)))) "b")
  (expect "and nothing is sent for it" (.typed (app-model app)) '())

  (def n (mutablevec-length calls))
  (app-dispatch! app Noop)
  (expect "the same value is not put again" (calls-since n) [])

  (text! (cast TextBox (ctl '(0))) "typed")
  (expect "what the user does is sent" (.typed (app-model app)) '("typed"))
  (text! (cast TextBox (ctl '(2))) "x")
  (expect "a mapped control's output is mapped" (list-ref (.typed (app-model app)) 0) "inner x")

  (def n (mutablevec-length calls))
  (def first-box (ctl '(1)))
  (app-dispatch! app Swap)
  (expect "another kind in the same place is another control" (calls-since n)
          ["make calendar" "update calendar 3"])
  (expect "a calendar of Avalonia's" (.ToString (cast Object (display-mode-of (cast Calendar (ctl '(1))))))
          "Month")
  (def n (mutablevec-length calls))
  (app-dispatch! app Swap)
  (expect "and a box again is a new box" (calls-since n) ["make box" "update box second"])
  (expect "not the first one" (eq? (cast Object (ctl '(1))) (cast Object first-box)) #f)

  (println "bjogui native ok"))