diff --git a/Readme.org b/Readme.org index dd6a5f1..08454da 100644 --- a/Readme.org +++ b/Readme.org @@ -58,9 +58,12 @@ 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 | +| ~(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 | | ~(grid #:columns #:rows child ...)~ | ~Grid~ | nothing | | ~(scroll child)~ | ~ScrollViewer~ | nothing | +| ~(border child)~ | ~Border~ | nothing | They take keywords where they apply: ~#:size~ (the font size of a text), ~#:wrap~ (a text breaks its lines at its width), ~#:width~, ~#:height~, @@ -86,6 +89,35 @@ number is pixels. ~(at row column view)~ puts a view in a cell, counting from An image that cannot be read shows nothing. +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 +item is a control, so a list of thousands makes thousands of controls. + +#+BEGIN_SRC scheme +(tabs (.tab m) Tab + (tab "Todo" (list-box (vec-map (fun (t) (keyed (.id t) (text (.title t)))) (.todos m)) + (.chosen m) Chose)) + (tab "Settings" (checkbox "Dark" (.dark m) Dark))) +#+END_SRC + +* Colours and borders + +~(paint view #:colour #:background)~ colours any view: ~#:colour~ is the +text, ~#:background~ what is behind it. 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. + +~(border child #:colour #:thickness #:radius #:background #:padding)~ draws +a line around a view, with round corners if ~#:radius~ is more than zero. + +#+BEGIN_SRC scheme +(border (paint (text "Saved") #:colour "#c0392b") + #:colour "#2980b9" #:radius 8.0 #:background "#ecf0f1" #:padding 8.0) +#+END_SRC + +The Fluent theme gives a button its own colours when the pointer is over it +or it is pressed, so a painted button shows the theme's colour then. + * Work: commands and subscriptions ~gui-update~ is a plain function, so it cannot wait, and the compiler says so @@ -154,13 +186,15 @@ cancelled, and the program ends. bjo run tests/app.bjo # prints "bjogui ok" bjo run tests/effects.bjo # prints "bjogui effects ok" bjo run tests/controls.bjo # prints "bjogui controls ok" +bjo run tests/lists.bjo # prints "bjogui lists ok" bjo run examples/counter.bjo bjo run examples/stopwatch.bjo #+END_SRC * Not yet -- A list box with a selection, tabs, menus and dialogs. -- Colours, borders and styles of one's own. +- Menus and dialogs. +- Styles of one's own, with classes, and colours for the pointer-over and + pressed states. - A moved control is taken out of the panel and put back, so it may lose the keyboard focus. diff --git a/src/app.bjo b/src/app.bjo index bebc561..fdb7652 100644 --- a/src/app.bjo +++ b/src/app.bjo @@ -71,6 +71,16 @@ (Image (: Avalonia.Controls.Image (-> Image))) (Bitmap (: Avalonia.Media.Imaging.Bitmap (-> string Bitmap))) (TextWrapping (: Avalonia.Media.TextWrapping)) + (IBrush (: Avalonia.Media.IBrush)) + (CornerRadius (: Avalonia.CornerRadius (-> double CornerRadius))) + (ListBox (: Avalonia.Controls.ListBox (-> ListBox))) + (TabControl (: Avalonia.Controls.TabControl (-> TabControl))) + (TabItem (: Avalonia.Controls.TabItem (-> TabItem))) + (Border (: Avalonia.Controls.Border (-> Border))) + (ItemsControl (: Avalonia.Controls.ItemsControl)) + (ItemCollection (: Avalonia.Controls.ItemCollection)) + (IList (: System.Collections.IList)) + (ICollection (: System.Collections.ICollection)) (Controls (: Avalonia.Controls.Controls)) (Panel (: Avalonia.Controls.Panel)) (StackPanel (: Avalonia.Controls.StackPanel (-> StackPanel))) @@ -133,6 +143,19 @@ (grid-column-span-property (: Avalonia.Controls.Grid.ColumnSpanProperty #:get)) (grid-row-spacing-property (: Avalonia.Controls.Grid.RowSpacingProperty #:get)) (grid-column-spacing-property (: Avalonia.Controls.Grid.ColumnSpacingProperty #:get)) + (header-property (: Avalonia.Controls.Primitives.HeaderedContentControl.HeaderProperty #:get)) + (text-block-background (: Avalonia.Controls.TextBlock.BackgroundProperty #:get)) + (text-block-foreground (: Avalonia.Controls.TextBlock.ForegroundProperty #:get)) + (background-property (: Avalonia.Controls.Primitives.TemplatedControl.BackgroundProperty #:get)) + (foreground-property (: Avalonia.Controls.Primitives.TemplatedControl.ForegroundProperty #:get)) + (panel-background (: Avalonia.Controls.Panel.BackgroundProperty #:get)) + (border-background (: Avalonia.Controls.Border.BackgroundProperty #:get)) + (border-brush-property (: Avalonia.Controls.Border.BorderBrushProperty #:get)) + (border-thickness-property (: Avalonia.Controls.Border.BorderThicknessProperty #:get)) + (corner-radius-property (: Avalonia.Controls.Border.CornerRadiusProperty #:get)) + (decorator-padding (: Avalonia.Controls.Decorator.PaddingProperty #:get)) + (decorator-child (: Avalonia.Controls.Decorator.ChildProperty #:get)) + (parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush))) ;; A grid's sizes are not Avalonia properties, so they are set as .NET ;; properties are. @@ -165,6 +188,17 @@ (selected-index (: Avalonia.Controls.Primitives.SelectingItemsControl.SelectedIndex (-> SelectingItemsControl int) #:get)) (panel-children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get)) + (items-of (: Avalonia.Controls.ItemsControl.Items (-> ItemsControl ItemCollection) #:get)) + (event-source (: Avalonia.Interactivity.RoutedEventArgs.Source (-> RoutedEventArgs Object) #:get)) + ;; Panel.Children and ItemsControl.Items are both an IList, so one patch + ;; serves a panel's children and a list's items. + (list-count (: System.Collections.ICollection.Count (-> ICollection int) #:get)) + (list-ref (: System.Collections.IList.get_Item (-> IList int Object))) + (list-index-of (: System.Collections.IList.IndexOf (-> IList Object int))) + (list-insert! (: System.Collections.IList.Insert (-> IList int Object void))) + (list-add! (: System.Collections.IList.Add (-> IList Object int))) + (list-remove! (: System.Collections.IList.Remove (-> IList Object void))) + (list-remove-at! (: System.Collections.IList.RemoveAt (-> IList int void))) (content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set)) (clr-string (: System.Convert.ToString (-> string ClrString))) @@ -219,8 +253,35 @@ (ColumnKind #f) (RowKind #f) (GridKind #f) + (BorderKind #f) (_ #t))) +;; A kind whose children are the items of an Avalonia ItemsControl. +(: (-> Kind bool)) +(defun (items? kind) + (match kind + (ListBoxKind #t) + (TabsKind #t) + (_ #f))) + +;; A kind with one child, which is its content. +(: (-> Kind bool)) +(defun (single? kind) + (match kind + (ScrollKind #t) + (TabKind #t) + (BorderKind #t) + (_ #f))) + +;; A kind that chooses one of its items or options. +(: (-> Kind bool)) +(defun (selecting? kind) + (match kind + (DropdownKind #t) + (ListBoxKind #t) + (TabsKind #t) + (_ #f))) + (: (-> Kind bool)) (defun (text-box? kind) (match kind @@ -247,6 +308,7 @@ (TextKind (Some (cast AvaloniaProperty text-block-text))) (ButtonKind (Some (cast AvaloniaProperty content-property))) (CheckBoxKind (Some (cast AvaloniaProperty content-property))) + (TabKind (Some (cast AvaloniaProperty header-property))) (_ None))) ((Value _) (when-kind (text-box? kind) (cast AvaloniaProperty text-box-text))) ((Placeholder _) (when-kind (text-box? kind) (cast AvaloniaProperty watermark-property))) @@ -259,7 +321,10 @@ ((Width _) (Some (cast AvaloniaProperty width-property))) ((Height _) (Some (cast AvaloniaProperty height-property))) ((Margin _) (Some (cast AvaloniaProperty margin-property))) - ((Padding _) (when-kind (templated? kind) (cast AvaloniaProperty padding-property))) + ((Padding _) + (cond ((= kind BorderKind) (Some (cast AvaloniaProperty decorator-padding))) + ((templated? kind) (Some (cast AvaloniaProperty padding-property))) + (else None))) ((Spacing _) (when-kind (stack? kind) (cast AvaloniaProperty spacing-property))) ((Wrap _) (when-kind (= kind TextKind) (cast AvaloniaProperty text-block-wrapping))) ((Minimum _) (when-kind (range? kind) (cast AvaloniaProperty minimum-property))) @@ -267,11 +332,24 @@ ((Amount _) (when-kind (range? kind) (cast AvaloniaProperty value-property))) ((Step _) (when-kind (= kind SliderKind) (cast AvaloniaProperty small-change-property))) ((Items _) (when-kind (= kind DropdownKind) (cast AvaloniaProperty items-source-property))) - ((Selected _) (when-kind (= kind DropdownKind) (cast AvaloniaProperty selected-index-property))) + ((Selected _) (when-kind (selecting? kind) (cast AvaloniaProperty selected-index-property))) ((Row _) (Some (cast AvaloniaProperty grid-row-property))) ((Column _) (Some (cast AvaloniaProperty grid-column-property))) ((RowSpan _) (Some (cast AvaloniaProperty grid-row-span-property))) ((ColumnSpan _) (Some (cast AvaloniaProperty grid-column-span-property))) + ((Background _) + (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-background))) + ((= kind BorderKind) (Some (cast AvaloniaProperty border-background))) + ((panel? kind) (Some (cast AvaloniaProperty panel-background))) + ((templated? kind) (Some (cast AvaloniaProperty background-property))) + (else None))) + ((Foreground _) + (cond ((= kind TextKind) (Some (cast AvaloniaProperty text-block-foreground))) + ((templated? kind) (Some (cast AvaloniaProperty foreground-property))) + (else None))) + ((BorderColour _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-brush-property))) + ((BorderWidth _) (when-kind (= kind BorderKind) (cast AvaloniaProperty border-thickness-property))) + ((Radius _) (when-kind (= kind BorderKind) (cast AvaloniaProperty corner-radius-property))) ;; Set by `set-prop!` itself. ((Source _) None) ((Columns _) None) @@ -284,9 +362,26 @@ (: (-> string ClrString)) (defun (->clr-string s) (clr-string s)) -;; The value of a prop, as the object `SetValue` takes. -(: (-> Prop Object)) +;; A colour, as Avalonia reads one. None for one it cannot read. +(: (-> string (Option Object))) +(defun (brush s) + (match (try (parse-brush s) #:catch (System.Exception)) + ((Ok b) (Some (cast Object b))) + ((Err _) None))) + +;; The value of a prop, as the object `SetValue` takes. None for a value that +;; cannot be one, such as a colour that cannot be read: the property is then +;; cleared, and the theme's value shows. +(: (-> Prop (Option Object))) (defun (boxed p) + (match p + ((Background s) (brush s)) + ((Foreground s) (brush s)) + ((BorderColour s) (brush s)) + (_ (Some (plain p))))) + +(: (-> Prop Object)) +(defun (plain p) (defun (text s) (cast Object (->clr-string s))) (match p ((Label s) (text s)) @@ -314,7 +409,12 @@ ((ColumnSpan i) (cast Object i)) ((Source s) (text s)) ((Columns s) (text s)) - ((Rows s) (text s)))) + ((Rows s) (text s)) + ((Background s) (text s)) + ((Foreground s) (text s)) + ((BorderColour s) (text s)) + ((BorderWidth d) (cast Object (Thickness. d))) + ((Radius d) (cast Object (CornerRadius. d))))) ;; Which prop it is, without its value. Two props with one tag set the same ;; property. @@ -326,7 +426,9 @@ ((Margin _) 8) ((Padding _) 9) ((Spacing _) 10) ((Wrap _) 11) ((Minimum _) 12) ((Maximum _) 13) ((Amount _) 14) ((Step _) 15) ((Items _) 16) ((Selected _) 17) ((Source _) 18) ((Columns _) 19) - ((Rows _) 20) ((Row _) 21) ((Column _) 22) ((RowSpan _) 23) ((ColumnSpan _) 24))) + ((Rows _) 20) ((Row _) 21) ((Column _) 22) ((RowSpan _) 23) ((ColumnSpan _) 24) + ((Background _) 25) ((Foreground _) 26) ((BorderColour _) 27) ((BorderWidth _) 28) + ((Radius _) 29))) (: (-> Control AvaloniaProperty Object void)) (defun (put! control property value) @@ -353,7 +455,10 @@ (put! control (cast AvaloniaProperty grid-column-spacing-property) (cast Object d))) (_ (match (slot kind p) - ((Some property) (put! control property (boxed p))) + ((Some property) + (match (boxed p) + ((Some value) (put! control property value)) + (None (clear-value (cast AvaloniaObject control) property)))) (None unit))))) (: (-> Control Kind Prop void)) @@ -603,8 +708,13 @@ (: (-> (App %model %m) (Live %m) Kind void)) (defun (listen! app live kind) (def control (.control live)) + ;; Only the control's own events: a routed event bubbles, so a list's + ;; handler would hear the selection of a dropdown in one of its items too. (defun (on-event (: event RoutedEvent) pick) - (on! control event (fun (sender e) (fire! app live (pick))))) + (on! control event + (fun (sender e) + (when (eq? (event-source e) (cast Object control)) + (fire! app live (pick)))))) (match kind (ButtonKind (on-event (cast RoutedEvent click-event) @@ -624,7 +734,7 @@ (fun () (def d (range-value (cast RangeBase control))) (fun (on) (match on ((Slide f) (Some (f d))) (_ None)))))) - (DropdownKind + ((or DropdownKind ListBoxKind TabsKind) (on-event (cast RoutedEvent selection-changed-event) (fun () (def i (selected-index (cast SelectingItemsControl control))) @@ -665,14 +775,45 @@ (put! panel (cast AvaloniaProperty orientation-property) (cast Object Orientation.Horizontal)) panel) (GridKind (cast Control (Grid.))) - (ScrollKind (cast Control (ScrollViewer.))))) + (ScrollKind (cast Control (ScrollViewer.))) + (ListBoxKind (cast Control (ListBox.))) + (TabsKind (cast Control (TabControl.))) + (TabKind (cast Control (TabItem.))) + (BorderKind (cast Control (Border.))))) + +;; Where the controls of a panel's children, or of a list's items, are. +(: (-> Kind Control IList)) +(defun (child-list kind parent) + (if (items? kind) + (cast IList (items-of (cast ItemsControl parent))) + (cast IList (panel-children (cast Panel parent))))) + +;; Makes `child` the one child of a scroll, a tab or a border. +(: (-> Kind Control Control void)) +(defun (set-single! kind parent child) + (if (= kind BorderKind) + (put! parent (cast AvaloniaProperty decorator-child) (cast Object child)) + (content! (cast ContentControl parent) (cast Object child)))) ;; Puts a child's control in its parent's, as the last one. (: (-> Kind Control Control void)) (defun (adopt! kind parent child) - (if (= kind ScrollKind) - (content! (cast ContentControl parent) (cast Object child)) - (.Add (panel-children (cast Panel parent)) child))) + (if (single? kind) + (set-single! kind parent child) + (ignore (list-add! (child-list kind parent) (cast Object child))))) + +;; A list or tabs can choose an item only once the items are there, so the +;; choice is set again after the children. A dropdown whose items changed +;; may have dropped its choice, so it is set again too. +(: (-> Control Kind (Vec Prop) void)) +(defun (sync-selection! control kind props) + (when (selecting? kind) + (loop (:for p props) + (:do (match p + ((Selected i) + (unless (= (selected-index (cast SelectingItemsControl control)) i) + (put! control (cast AvaloniaProperty selected-index-property) (cast Object i)))) + (_ unit)))))) ;; Makes the controls for a view. (: (-> (App %model %m) (View %m) (Live %m))) @@ -686,6 +827,7 @@ (:do (def c (mount app child)) (mutablevec-add! (.children live) c) (adopt! kind control (.control c)))) + (sync-selection! control kind (view-props v)) live) ;; Changes the controls of `live` to show `next`. Gives `live` itself, or new @@ -699,20 +841,21 @@ (begin (patch-props! (.control live) kind (view-props old) (view-props next)) (record-set! live (view next)) - (cond ((panel? kind) (patch-children! app live (view-children next))) - ((= kind ScrollKind) (patch-content! app live (view-children next))) + (cond ((single? kind) (patch-single! app live kind (view-children next))) + ((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next))) (else unit)) + (sync-selection! (.control live) kind (view-props next)) live))) -;; A scroll's one child is its content. -(: (-> (App %model %m) (Live %m) (Vec (View %m)) void)) -(defun (patch-content! app live views) +;; The one child of a scroll, a tab or a border. +(: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void)) +(defun (patch-single! app live kind views) (def kids (.children live)) (def was (mutablevec-ref kids 0)) (def now (patch! app was (vec-ref views 0))) (unless (eq? now was) (mutablevec-set! kids 0 now) - (content! (cast ContentControl (.control live)) (cast Object (.control now))))) + (set-single! kind (.control live) (.control now)))) ;; Which child each view is: its key, or its place among the children that ;; have none. The two kinds cannot be mistaken for each other. @@ -731,10 +874,10 @@ ;; its control, and is changed to the next view. The others are made new, ;; and those left over are removed. Then the controls are put in the order ;; of the next view, moving only those that are out of place. -(: (-> (App %model %m) (Live %m) (Vec (View %m)) void)) -(defun (patch-children! app live views) +(: (-> (App %model %m) (Live %m) Kind (Vec (View %m)) void)) +(defun (patch-children! app live kind views) (def kids (.children live)) - (def controls (panel-children (cast Panel (.control live)))) + (def controls (child-list kind (.control live))) (def olds (mutablevec->vec kids)) (def old-ids (identities (vec-map (fun (l) (.view l)) olds))) (def new-ids (identities views)) @@ -761,15 +904,16 @@ (loop (:for (Tuple i was) (enumerate olds)) (:when (not (array-ref kept i))) - (:do (ignore (.Remove controls (.control was))))) + (:do (list-remove! controls (cast Object (.control was))))) + ;; A control out of place is taken out and put back where it belongs. (loop (:for (Tuple j now) (enumerate (mutablevec->vec nexts))) - (:do (def c (.control now)) - (unless (and (< j (.-Count controls)) (eq? (.get_Item controls j) c)) - (def at (.IndexOf controls c)) - (if (>= at 0) - (.Move controls at j) - (.Insert controls j c))))) + (:do (def c (cast Object (.control now))) + (unless (and (< j (list-count (cast ICollection controls))) + (eq? (list-ref controls j) c)) + (def at (list-index-of controls c)) + (when (>= at 0) (list-remove-at! controls at)) + (list-insert! controls j c)))) (mutablevec-clear! kids) (loop (:for now (mutablevec->vec nexts)) (:do (mutablevec-add! kids now)))) diff --git a/src/view.bjo b/src/view.bjo index aab67a2..d1fc949 100644 --- a/src/view.bjo +++ b/src/view.bjo @@ -19,9 +19,10 @@ ;; Constructors. text button text-input text-area checkbox slider progress-bar dropdown image - column row grid scroll + list-box tabs tab + column row grid scroll border ;; Wrappers. - keyed at + keyed at paint ;; Reading one. view-kind view-props view-events view-children view-key) @@ -35,7 +36,8 @@ ;; What control a view is. (type (: Kind (Union TextKind ButtonKind TextInputKind TextAreaKind CheckBoxKind SliderKind ProgressKind DropdownKind ImageKind - ColumnKind RowKind GridKind ScrollKind))) + ListBoxKind TabsKind TabKind + ColumnKind RowKind GridKind ScrollKind BorderKind))) ;; A property of a control. A kind takes only some of them; the app ignores ;; the others. @@ -56,14 +58,19 @@ (: 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 of them is chosen; -1 for none + (: 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)))) + (: 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 ;; An event, and the message it sends. (type (: (On %m) (Union (: Click %m) @@ -109,6 +116,14 @@ (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, 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) @@ -219,6 +234,33 @@ (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 checkbox that is `checked?`. A click sends `(on-toggle checked)`, with ;; the new state. (: (-> string bool (-> bool %m) (#:enabled bool) (#:margin double) (View %m))) @@ -258,6 +300,23 @@ 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) diff --git a/tests/lists.bjo b/tests/lists.bjo new file mode 100644 index 0000000..6195c75 --- /dev/null +++ b/tests/lists.bjo @@ -0,0 +1,159 @@ +;; 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"))