diff --git a/Readme.org b/Readme.org index b7d2223..63e5a90 100644 --- a/Readme.org +++ b/Readme.org @@ -62,6 +62,7 @@ being changed, and they are dropped, so only the user's events are messages. | ~(progress-bar value)~ | ~ProgressBar~ | nothing | | ~(dropdown options selected on-select)~ | ~ComboBox~ | ~(on-select index)~ | | ~(image path)~ | ~Image~ | nothing | +| ~(image-data bytes)~, the bytes of a picture file | ~Image~ | nothing | | ~(list-box views selected on-select)~ | ~ListBox~ | ~(on-select index)~ | | ~(tabs selected on-select (tab header view) ...)~ | ~TabControl~ | ~(on-select index)~ | | ~(column child ...)~, ~(row child ...)~ | ~StackPanel~ | nothing | @@ -101,7 +102,8 @@ number is pixels. ~(at row column view)~ puts a view in a cell, counting from #:height 200.0) #+END_SRC -An image that cannot be read shows nothing. +An image that cannot be read shows nothing. ~image-data~ reads its bytes +again only when it is given another array, so keep the array in the model. A list box's items are views, so an item can be anything: a text, a row with a checkbox, a dropdown. Give them keys if the list can change order. Each @@ -379,6 +381,30 @@ The fibers belong to the app. They post their messages to the UI thread, so ~gui-update~ and ~view~ always run there. When the window is closed they are cancelled, and the program ends. +** Commands that act on the controls and the clipboard + +Some commands do work of their own and send no message. Each finds its +control by the key of its view, given with ~keyed~, and runs once the +controls of the update are laid out, so a view the same update made is +there. + +| Command | Does | +|-------------------------------+---------------------------------------------------------| +| ~(focus key)~ | gives the keyboard to the control | +| ~(scroll-to-end key)~ | scrolls a ~scroll~ view to its end, as a log wants | +| ~(scroll-to-start key)~ | scrolls a ~scroll~ view to its start | +| ~(scroll-into-view key)~ | scrolls the views around the control until it is seen | +| ~(copy-text text)~ | puts ~text~ on the clipboard | +| ~(paste-text on-text)~ | sends ~(on-text (Some text))~, or ~(on-text None)~ | + +#+BEGIN_SRC scheme +(Add (next (record-set m (items (vec-add (.items m) (.draft m))) (draft "")) + (focus "draft") + (scroll-to-end "items"))) + +(keyed "draft" (text-input (.draft m) Draft)) +#+END_SRC + * Dialogs: (bjogui dialogs) A dialog is a command, and its answer comes back as a message. @@ -458,6 +484,7 @@ bjo run tests/tree.bjo # prints "bjogui tree ok" bjo run tests/canvas.bjo # prints "bjogui canvas ok" bjo run tests/components.bjo # prints "bjogui components ok" bjo run tests/native.bjo # prints "bjogui native ok" +bjo run tests/commands.bjo # prints "bjogui commands ok" bjo run examples/counter.bjo bjo run examples/stopwatch.bjo bjo run examples/todo.bjo diff --git a/src/app.bjo b/src/app.bjo index 0419dd2..2a96bde 100644 --- a/src/app.bjo +++ b/src/app.bjo @@ -29,6 +29,8 @@ run-app next style ;; Subscriptions. every subscription + ;; Commands that act on the controls and the clipboard. + focus scroll-to-end scroll-to-start scroll-into-view copy-text paste-text ;; For tests and for hosts of their own: an app with no window. start-app app-dispatch! app-send! app-stop! app-run-pending! app-press! app-input! app-model app-control app-control-at start-headless!) @@ -168,7 +170,13 @@ (WheelArgs (: Avalonia.Input.PointerWheelEventArgs)) (InputElement (: Avalonia.Input.InputElement)) (NavigationMethod (: Avalonia.Input.NavigationMethod)) - (HeadlessOptions (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions (-> HeadlessOptions)))) + (HeadlessOptions (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions (-> HeadlessOptions))) + ;; Commands, and pictures from memory. + (TopLevel (: Avalonia.Controls.TopLevel)) + (IClipboard (: Avalonia.Input.Platform.IClipboard)) + (Stream (: System.IO.Stream)) + (MemoryStream (: System.IO.MemoryStream (-> (Array byte) MemoryStream))) + (StreamBitmap (: Avalonia.Media.Imaging.Bitmap (-> Stream StreamBitmap)))) (import/extern ;; Properties, as the objects `SetValue` takes. @@ -404,7 +412,25 @@ (-> AppBuilder HeadlessOptions AppBuilder))) (headless-drawing! (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions.UseHeadlessDrawing (-> HeadlessOptions bool void) #:set)) - (setup-without-starting (: Avalonia.AppBuilder.SetupWithoutStarting (-> AppBuilder AppBuilder)))) + (setup-without-starting (: Avalonia.AppBuilder.SetupWithoutStarting (-> AppBuilder AppBuilder))) + + ;; Commands. + (ui-post-late (: Avalonia.Threading.Dispatcher.InvokeAsync + (-> Dispatcher (-> Unit) UiPriority (DispatcherOp Unit)))) + (background-priority (: Avalonia.Threading.DispatcherPriority.Background #:get)) + ;; Runs a function that starts a Task on the UI thread, and waits for the + ;; Task. The clipboard takes no CancellationToken, so this cannot be + ;; cancelled. + (on-ui (: Avalonia.Threading.Dispatcher.InvokeAsync + (-> Dispatcher (-> (Task %a)) %a) #:async #:uncancellable)) + (answered (: System.Threading.Tasks.Task.FromResult (-> %a (Task %a)))) + (top-level-of (: Avalonia.Controls.TopLevel.GetTopLevel (-> Visual TopLevel))) + (clipboard-of (: Avalonia.Controls.TopLevel.Clipboard (-> TopLevel IClipboard) #:get)) + (clipboard-text (: Avalonia.Input.Platform.IClipboard.GetTextAsync (-> IClipboard (Task ClrString)))) + (clipboard-text! (: Avalonia.Input.Platform.IClipboard.SetTextAsync (-> IClipboard string Task))) + (scroll-end! (: Avalonia.Controls.ScrollViewer.ScrollToEnd (-> ScrollViewer void))) + (scroll-home! (: Avalonia.Controls.ScrollViewer.ScrollToHome (-> ScrollViewer void))) + (bring-into-view! (: Avalonia.Controls.ControlExtensions.BringIntoView (-> Control void)))) ;; --------------------------------------------------------------------------- ;; Properties @@ -608,6 +634,7 @@ ((PropDate _) (when-kind (= kind DateKind) (cast AvaloniaProperty date-property))) ;; Set by `set-prop!` itself. ((PropSource _) None) + ((PropPicture _) None) ((PropColumns _) None) ((PropRows _) None))) @@ -706,6 +733,7 @@ ((PropStart x y) (cast Object (Point. x y))) ((PropEnd x y) (cast Object (Point. x y))) ((PropData s) (text s)) + ((PropPicture o) o) ((PropDockSide i) (cast Object (match i (0 DockEdge.Left) (1 DockEdge.Top) (2 DockEdge.Right) (_ DockEdge.Bottom)))))) @@ -724,7 +752,8 @@ ((PropRadius _) 29) ((PropShortcut _) 30) ((PropTip _) 31) ((PropExpanded _) 32) ((PropDate _) 33) ((PropDockSide _) 34) ((PropClasses _) 35) ((PropChosenKey _) 36) ((PropLeft _) 37) ((PropTop _) 38) ((PropFill _) 39) ((PropStroke _) 40) - ((PropStrokeWidth _) 41) ((PropStart _ _) 42) ((PropEnd _ _) 43) ((PropData _) 44))) + ((PropStrokeWidth _) 41) ((PropStart _ _) 42) ((PropEnd _ _) 43) ((PropData _) 44) + ((PropPicture _) 45))) (: (-> Control AvaloniaProperty Object void)) (defun (put! control property value) @@ -740,6 +769,10 @@ (: (-> Control Kind Prop void)) (defun (set-prop! control kind p) (match (Tuple kind p) + ((Tuple ImageKind (PropPicture o)) + (match (try (StreamBitmap. (cast Stream (MemoryStream. (cast (Array byte) o)))) #:catch (System.Exception)) + ((Ok b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b))) + ((Err _) (clear-value (cast AvaloniaObject control) (cast AvaloniaProperty image-source-property))))) ((Tuple ImageKind (PropSource path)) (match (load-bitmap path) ((Some b) (put! control (cast AvaloniaProperty image-source-property) (cast Object b))) @@ -781,6 +814,7 @@ (defun (clear property) (clear-value (cast AvaloniaObject control) property)) (match (Tuple kind p) ((Tuple ImageKind (PropSource _)) (clear (cast AvaloniaProperty image-source-property))) + ((Tuple ImageKind (PropPicture _)) (clear (cast AvaloniaProperty image-source-property))) ((Tuple GridKind (PropColumns _)) (grid-columns! (cast Grid control) (parse-columns "*"))) ((Tuple GridKind (PropRows _)) (grid-rows! (cast Grid control) (parse-rows "*"))) ((Tuple GridKind (PropSpacing _)) @@ -813,6 +847,18 @@ ;; The app ;; --------------------------------------------------------------------------- +;; What a command finds a running app by: the control of a view with a key, +;; and the controls at the roots of its views. +(type (: Running (Record (: find (-> string (Option Control))) + (: roots (-> (List Control)))))) + +;; The apps started, in order. A command looks for its control in each. +(: running (MutableVec Running)) +(def running (mutablevec)) + +;; Raised by a command that sends no message, and caught by `run-command`. +(def no-message (cast Exception (InvalidOperation. "bjogui: a command that sends no message"))) + ;; What a component was drawn with: its value, its state, and its size. (type (: Painted (Record (: drawn-value Object) (: drawn-state Object) (: drawn-width double) (: drawn-height double)))) @@ -1015,7 +1061,11 @@ (: (-bjo-> (App %model %m) (Event %m) void)) (defbjo (run-command app command) - (post! app (sync command))) + ;; A command that sends no message raises `no-message` once it has done + ;; its work, so that its fiber ends. + (match (try (sync command) #:catch (System.InvalidOperationException)) + ((Ok msg) (post! app msg)) + ((Err e) (unless (eq? (cast Object e) (cast Object no-message)) (raise e))))) (: (-bjo-> (App %model %m) (-> (Event %m)) void)) (defbjo (run-sub app next-event) @@ -1494,6 +1544,10 @@ (subscriptions subscriptions) (keys keys) (theme theme) (shown-theme "") (root None) (patching #f) (stopped #f) (home (current-scope)) (subs '()) (on-root on-root))) + (mutablevec-add! running (Running (find (fun (key) (keyed-control app key))) + (roots (fun () (match (.root app) + ((Some live) (list (.control live))) + (None '())))))) (step! app '()) app) @@ -1891,14 +1945,16 @@ (repaint! live))) (-> Object Object void))))) -;; Sets Avalonia up with no screen, drawing with Skia, so that components can -;; be drawn and their pictures read in a test. Call it once, before -;; `start-app`. +;; Sets Avalonia up with no screen, drawing with Skia, and with the theme +;; `run-app` uses, so that controls are drawn and laid out as in a window: a +;; test can draw components and read their pictures, and scroll a view. +;; Call it once, before `start-app`. (: (-> void)) (defun (start-headless!) (def options (HeadlessOptions.)) (headless-drawing! options #f) - (ignore (setup-without-starting (use-headless (use-skia (configure (fun () (Application.)))) options)))) + (ignore (setup-without-starting (use-headless (use-skia (configure (fun () (Application.)))) options))) + (.Add (app-styles current-app) (FluentTheme. (clr-default)))) ;; --------------------------------------------------------------------------- ;; Native controls @@ -1941,3 +1997,116 @@ (if (ui-thread? ui-dispatcher) (unless (.patching app) (deliver!)) (ignore (ui-post ui-dispatcher (fun () (deliver!) unit))))) + +;; --------------------------------------------------------------------------- +;; Commands that act on the controls and the clipboard +;; --------------------------------------------------------------------------- + +;; The control of the view with `key`, below the root. +(: (-> (App %model %m) string (Option Control))) +(defun (keyed-control app key) + (: (-> (Live %m) (Option Control))) + (defun (walk live) + (if (= (view-key (.view live)) (Some key)) + (Some (.control live)) + (loop (:for c (mutablevec->vec (.children live))) + (:when-let (Some found) (walk c)) + (:finish #t (Some found)) + => None))) + (match (.root app) + ((Some live) (walk live)) + (None None))) + +;; A command that runs `act` on the UI thread and sends no message. It runs +;; after the controls are laid out, so a control the same update made is +;; there, and its size is known. +(: (-> (-> void) (Event %m))) +(defun (acting act) + (guard (fun () + (ignore (ui-post-late ui-dispatcher (fun () (act) unit) background-priority)) + (raise no-message)))) + +;; A command that runs `act` on the control of the view with `key`, in the +;; first app that has one. With none, it does nothing. +(: (-> string (-> Control void) (Event %m))) +(defun (on-keyed key act) + (acting (fun () + (loop (:for r (mutablevec->vec running)) + (:when-let (Some c) ((.find r) key)) + (:finish #t (act c)) + => unit)))) + +;; Gives the keyboard to the control of the view with `key`, as a click +;; would. Sends nothing. +;; +;; (Add (next (add-item m) (focus "new-item"))) +(: focus (-> string (Event %m))) +(defun (focus key) + (on-keyed key (fun (c) (ignore (focus! (cast InputElement c) NavigationMethod.Unspecified KeyModifiers.None))))) + +;; Scrolls the `scroll` view with `key` to its end, such as a log after a +;; line is added. Sends nothing. +(: scroll-to-end (-> string (Event %m))) +(defun (scroll-to-end key) + (on-keyed key (fun (c) (match (try (cast ScrollViewer c) #:catch (System.InvalidCastException)) + ((Ok v) (scroll-end! v)) + ((Err _) unit))))) + +;; Scrolls the `scroll` view with `key` to its start. Sends nothing. +(: scroll-to-start (-> string (Event %m))) +(defun (scroll-to-start key) + (on-keyed key (fun (c) (match (try (cast ScrollViewer c) #:catch (System.InvalidCastException)) + ((Ok v) (scroll-home! v)) + ((Err _) unit))))) + +;; Scrolls the views around the view with `key` until it is seen. Sends +;; nothing. +(: scroll-into-view (-> string (Event %m))) +(defun (scroll-into-view key) + (on-keyed key bring-into-view!)) + +;; The clipboard of the window an app is shown in, if one is. +(: (-> (Option IClipboard))) +(defun (clipboard) + (: (-> Control (Option IClipboard))) + (defun (of c) + (def top (cast Object (top-level-of (cast Visual c)))) + (if (eq? top (clr-default)) + None + (begin + (def board (cast Object (clipboard-of (cast TopLevel top)))) + (if (eq? board (clr-default)) None (Some (cast IClipboard board)))))) + (: (-> Running (Option IClipboard))) + (defun (in r) + (loop (:for c ((.roots r))) + (:when-let (Some board) (of c)) + (:finish #t (Some board)) + => None)) + (loop (:for r (mutablevec->vec running)) + (:when-let (Some board) (in r)) + (:finish #t (Some board)) + => None)) + +;; Puts `text` on the clipboard. Sends nothing. +(: copy-text (-> string (Event %m))) +(defun (copy-text text) + (acting (fun () + (match (clipboard) + ((Some board) (ignore (clipboard-text! board text))) + (None unit))))) + +(: (-bjo-> (Option string))) +(defbjo (read-clipboard) + (def text (on-ui ui-dispatcher + (fun () (match (clipboard) + ((Some board) (clipboard-text board)) + (None (answered (: (clr-default) ClrString))))))) + (if (eq? (cast Object text) (clr-default)) None (Some (.ToString text)))) + +;; Reads the clipboard, and sends `(on-text (Some text))`, or `(on-text None)` +;; when it holds no text or there is no window. +(: paste-text (-> (-> (Option string) %m) (Event %m))) +(defun (paste-text on-text) + (guard (fun () + (wrap (promise-join (bjo (read-clipboard))) + (fun (r) (on-text (match r ((Ok t) t) ((Err _) None)))))))) diff --git a/src/view.bjo b/src/view.bjo index 3992ae6..c7a26b5 100644 --- a/src/view.bjo +++ b/src/view.bjo @@ -22,7 +22,7 @@ View Kind Prop On ;; Constructors. - text button text-input text-area checkbox slider progress-bar dropdown image + text button text-input text-area checkbox slider progress-bar dropdown image image-data list-box tabs tab menu-bar submenu menu-item menu-separator toggle-switch radio number-input date-picker auto-complete expander @@ -115,7 +115,8 @@ (: PropStrokeWidth double) (: PropStart double double) ; the ends of a line (: PropEnd double double) - (: PropData string)))) ; a path, as "M 0 0 L 10 10 Z" + (: PropData string) ; a path, as "M 0 0 L 10 10 Z" + (: PropPicture Object)))) ; an image's bytes, as an (Array byte) ;; Where the pointer is on a component, from its top left corner, and how. ;; `button` is "left", "right" or "middle" for a press and a release, and "" @@ -433,6 +434,15 @@ (defun (image path #:width 0.0 #:height 0.0 #:margin 0.0) (leaf ImageKind (with-layout [(PropSource path)] width height margin 0.0) [])) +;; The picture in `bytes`, the contents of a PNG, JPEG, BMP or other file +;; that Avalonia reads, such as an image made by the program or downloaded. +;; Bytes that cannot be read show nothing. The picture is read again only +;; when the view is given another array, so keep the array in the model and +;; do not make it anew for each view. +(: (-> (Array byte) (#:width double) (#:height double) (#:margin double) (View %m))) +(defun (image-data bytes #:width 0.0 #:height 0.0 #:margin 0.0) + (leaf ImageKind (with-layout [(PropPicture (cast Object bytes))] 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. diff --git a/tests/commands.bjo b/tests/commands.bjo new file mode 100644 index 0000000..dde7a2f --- /dev/null +++ b/tests/commands.bjo @@ -0,0 +1,125 @@ +;; 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/commands.bjo — commands that act on the controls and the +;; clipboard, and pictures from memory. +;; +;; bjo run tests/commands.bjo +;; +;; Avalonia runs with no screen, and the app is shown in a window of it, so +;; that a control can take the keyboard, a scroll view is laid out, and there +;; is a clipboard. + +(import (std prelude)) +(import (std simpletest)) +(import (std interop)) +(import (bjogui view)) +(import (bjogui app)) + +(import/class + (Object (: System.Object)) + (Control (: Avalonia.Controls.Control)) + (Window (: Avalonia.Controls.Window (-> Window))) + (ContentControl (: Avalonia.Controls.ContentControl)) + (Layoutable (: Avalonia.Layout.Layoutable)) + (InputElement (: Avalonia.Input.InputElement)) + (ScrollViewer (: Avalonia.Controls.ScrollViewer)) + (Image (: Avalonia.Controls.Image)) + (IImage (: Avalonia.Media.IImage)) + (Vector (: Avalonia.Vector))) + +(import/extern + (content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set)) + (show! (: Avalonia.Controls.Window.Show (-> Window void))) + (width! (: Avalonia.Layout.Layoutable.Width (-> Layoutable double void) #:set)) + (height! (: Avalonia.Layout.Layoutable.Height (-> Layoutable double void) #:set)) + (update-layout! (: Avalonia.Layout.Layoutable.UpdateLayout (-> Layoutable void))) + (focused? (: Avalonia.Input.InputElement.IsFocused (-> InputElement bool) #:get)) + (offset-of (: Avalonia.Controls.ScrollViewer.Offset (-> ScrollViewer Vector) #:get)) + (vector-y (: Avalonia.Vector.Y (-> Vector double) #:get)) + (source-of (: Avalonia.Controls.Image.Source (-> Image IImage) #:get)) + (sleep-ms (: System.Threading.Thread.Sleep (-> int void) #:blocking))) + +(type (: Msg (Union FocusName FocusOther End Start Into (: Copy string) Paste (: Pasted (Option string))))) +(type (: Model (Record (: messages int) (: pasted (Option string))))) + +(: (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m0) + (def m (record-set m0 (messages (+ (.messages m0) 1)))) + (match msg + (FocusName (next m (focus "name"))) + (FocusOther (next m (focus "other"))) + (End (next m (scroll-to-end "log"))) + (Start (next m (scroll-to-start "log"))) + (Into (next m (scroll-into-view "line 25"))) + ((Copy s) (next m (copy-text s))) + (Paste (next m (paste-text Pasted))) + ((Pasted s) (next (record-set m (pasted s)))))) + +(def picture (file-read-bytes "docs/mixer.png")) + +(: (-> Model (View Msg))) +(defun (view m) + (column + (keyed "name" (text-input "" (fun (s) Start))) ; 0 + (keyed "other" (text-input "" (fun (s) Start))) ; 1 + (keyed "log" (scroll (apply column (vec->array (vec-map (fun (i) (keyed #"line ${i}" (text #"line ${i}"))) + (->vec (range 0 40))))) + #:height 60.0)) ; 2 + (image-data picture #:width 46.0 #:height 30.0) ; 3 + (image-data (: (make-array 3 #:fill (cast byte 7)) (Array byte))))) ; 4 + +(defun (main) + (start-headless!) + (def w (Window.)) + (width! (cast Layoutable w) 300.0) + (height! (cast Layoutable w) 400.0) + (def app (start-app (Model (messages 0) (pasted None)) gui-update view + (fun (c) (content! (cast ContentControl w) (cast Object c))))) + (show! w) + (defun (ctl path) (app-control-at app path)) + (defun (settle) (app-run-pending! app) (update-layout! (cast Layoutable w))) + (: (-> (-> bool) bool)) + (defun (wait-for done?) + (let go ((tries 0)) + (settle) + (cond ((done?) #t) + ((> tries 200) #f) + (else (sleep-ms 10) (go (+ tries 1)))))) + (defun (log-offset) (vector-y (offset-of (cast ScrollViewer (ctl '(2)))))) + (settle) + + ;; --- focus ------------------------------------------------------------------------ + (app-dispatch! app FocusName) + (expect "focus gives the keyboard to the keyed control" + (wait-for (fun () (focused? (cast InputElement (ctl '(0)))))) #t) + (app-dispatch! app FocusOther) + (expect "and to another" (wait-for (fun () (focused? (cast InputElement (ctl '(1)))))) #t) + (expect "which the first has no more" (focused? (cast InputElement (ctl '(0)))) #f) + + ;; --- scrolling -------------------------------------------------------------------- + (expect "the log starts at the top" (log-offset) 0.0) + (app-dispatch! app End) + (expect "scroll-to-end" (wait-for (fun () (> (log-offset) 500.0))) #t) + (app-dispatch! app Start) + (expect "scroll-to-start" (wait-for (fun () (= (log-offset) 0.0))) #t) + (app-dispatch! app Into) + (expect "scroll-into-view" (wait-for (fun () (> (log-offset) 300.0))) #t) + + ;; --- the clipboard ----------------------------------------------------------------- + (app-dispatch! app (Copy "copied")) + (app-dispatch! app Paste) + (expect "a copy is pasted" (wait-for (fun () (= (.pasted (app-model app)) (Some "copied")))) #t) + + ;; --- commands that send nothing -------------------------------------------------- + (sleep-ms 50) + (settle) + (expect "send nothing: only the messages dispatched, and Pasted" (.messages (app-model app)) 8) + + ;; --- pictures from memory --------------------------------------------------------- + (expect "a picture from bytes" (eq? (cast Object (source-of (cast Image (ctl '(3))))) (clr-default)) #f) + (expect "bytes that are no picture show nothing" + (eq? (cast Object (source-of (cast Image (ctl '(4))))) (clr-default)) #t) + + (println "bjogui commands ok"))