Dialogs, file pickers, and closing by the program's leave
(bjogui dialogs) has alert, confirm and prompt, the open, save and folder pickers, and quit, each a command whose answer comes back as a message. A dialog is a window, which only the UI thread may make, so the command posts it there and awaits its Task in a fiber. Avalonia's dialogs take no CancellationToken, so they cannot be task->event; the Task is awaited through the non-generic Task.WhenAll, and its result read by reflection, because Bjolang reads no Task's Result. With no window, as under start-app, each answers as if cancelled. run-app's #:on-close turns the close button into a message, and quit closes the windows by program, which is not asked again. 🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8) Co-Authored-By: eca-agent <git@eca.dev>
This commit is contained in:
parent
be288ac03e
commit
cfcb1851b7
3 changed files with 483 additions and 1 deletions
22
src/app.bjo
22
src/app.bjo
|
|
@ -88,6 +88,8 @@
|
|||
(KeyCode (: Avalonia.Input.Key))
|
||||
(KeyModifiers (: Avalonia.Input.KeyModifiers))
|
||||
(KeyEventArgs (: Avalonia.Input.KeyEventArgs))
|
||||
(ClosingArgs (: Avalonia.Controls.WindowClosingEventArgs))
|
||||
(CancelArgs (: System.ComponentModel.CancelEventArgs))
|
||||
(ICollection (: System.Collections.ICollection))
|
||||
(Timer (: Avalonia.Threading.DispatcherTimer (-> Timer)))
|
||||
(TimeSpan (: System.TimeSpan))
|
||||
|
|
@ -180,6 +182,8 @@
|
|||
(key-of (: Avalonia.Input.KeyEventArgs.Key (-> KeyEventArgs KeyCode) #:get))
|
||||
(modifiers-of (: Avalonia.Input.KeyEventArgs.KeyModifiers (-> KeyEventArgs KeyModifiers) #:get))
|
||||
(handled! (: Avalonia.Interactivity.RoutedEventArgs.Handled (-> RoutedEventArgs bool void) #:set))
|
||||
(programmatic? (: Avalonia.Controls.WindowClosingEventArgs.IsProgrammatic (-> ClosingArgs bool) #:get))
|
||||
(cancel-close! (: System.ComponentModel.CancelEventArgs.Cancel (-> CancelArgs bool void) #:set))
|
||||
|
||||
;; A grid's sizes are not Avalonia properties, so they are set as .NET
|
||||
;; properties are.
|
||||
|
|
@ -1060,6 +1064,10 @@
|
|||
;; Runs the program in a window, until the window is closed. Then the
|
||||
;; subscriptions and the commands still running are cancelled.
|
||||
;;
|
||||
;; With `#:on-close msg`, a click on the window's close button does not close
|
||||
;; it: it sends `msg`, and the program closes it with `quit` from
|
||||
;; (bjogui dialogs) when it is ready, say after asking about unsaved work.
|
||||
;;
|
||||
;; With `#:screenshot`, a path, the window saves a PNG of itself there once it
|
||||
;; is shown, and closes. It is the environment variable BJOGUI_SCREENSHOT
|
||||
;; unless told otherwise, so any program can be pictured with no change:
|
||||
|
|
@ -1067,10 +1075,11 @@
|
|||
;; BJOGUI_SCREENSHOT=shot.png bjo run examples/todo.bjo
|
||||
(: (-> %model (-> %m %model (Tuple %model (List (Event %m)))) (-> %model (View %m))
|
||||
(#:subscriptions (-> %model (List (Sub %m))))
|
||||
(#:keys (-> %model (List (Key %m))))
|
||||
(#:keys (-> %model (List (Key %m)))) (#:on-close (Option %m))
|
||||
(#:title string) (#:width double) (#:height double) (#:screenshot string)
|
||||
void))
|
||||
(defun (run-app init gui-update view #:subscriptions (fun (m) '()) #:keys (fun (m) '())
|
||||
#:on-close None
|
||||
#:title "bjogui" #:width 400.0 #:height 300.0
|
||||
#:screenshot (option-ref-or (get-environment-variable "BJOGUI_SCREENSHOT") ""))
|
||||
;; The Application is made inside the setup, because making one uses the
|
||||
|
|
@ -1089,6 +1098,17 @@
|
|||
(def app (start-app init gui-update view
|
||||
(fun (c) (window-content! (cast ContentControl w) (cast Object c)))
|
||||
#:subscriptions subscriptions #:keys keys))
|
||||
;; With `#:on-close`, closing the window is a message. The program closes
|
||||
;; it with `quit`, which closes it by program, and that is not asked.
|
||||
(match on-close
|
||||
((Some msg)
|
||||
(ignore (add-event-handler! w "Closing"
|
||||
(: (fun (sender e)
|
||||
(unless (programmatic? (cast ClosingArgs e))
|
||||
(cancel-close! (cast CancelArgs e) #t)
|
||||
(app-dispatch! app msg)))
|
||||
(-> Object Object void)))))
|
||||
(None unit))
|
||||
;; Keys that no control took, such as a shortcut pressed in a text input.
|
||||
(on! (cast Control w) (cast RoutedEvent key-down-event)
|
||||
(fun (sender e)
|
||||
|
|
|
|||
408
src/dialogs.bjo
Normal file
408
src/dialogs.bjo
Normal file
|
|
@ -0,0 +1,408 @@
|
|||
;; 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/src/dialogs.bjo — the module (bjogui dialogs).
|
||||
;;
|
||||
;; Dialogs, file pickers and quitting, as commands: each is an `(Event %m)`
|
||||
;; that `gui-update` returns, and the answer comes back as a message.
|
||||
;;
|
||||
;; (Delete (next m (confirm "Delete it?" Deleted?)))
|
||||
;; ((Deleted? #t) (next (remove m)))
|
||||
;;
|
||||
;; A dialog is a window, which only the UI thread may make, and a command is
|
||||
;; synced in a fiber. So each one is a `guard`: when the fiber syncs it, a
|
||||
;; fiber of its own asks the UI thread to show the dialog, and waits for the
|
||||
;; Task that the dialog gives back.
|
||||
;;
|
||||
;; A dialog needs a window to belong to. With none, as in a test that runs an
|
||||
;; app with `start-app`, each answers as if it was cancelled: `confirm` #f,
|
||||
;; `prompt` and the pickers None or nothing.
|
||||
|
||||
(export
|
||||
alert confirm prompt
|
||||
open-file open-files save-file open-folder
|
||||
quit)
|
||||
|
||||
(import (std prelude))
|
||||
(import (std interop))
|
||||
|
||||
(import/class
|
||||
(Object (: System.Object))
|
||||
(DispatcherOpBase (: Avalonia.Threading.DispatcherOperation))
|
||||
(ClrType (: System.Type))
|
||||
(PropertyInfo (: System.Reflection.PropertyInfo))
|
||||
(ClrString (: System.String))
|
||||
((ReadOnlyList %a) (: System.Collections.Generic.IReadOnlyList))
|
||||
((EventHandler %a) (: System.EventHandler))
|
||||
(Application (: Avalonia.Application))
|
||||
(ILifetime (: Avalonia.Controls.ApplicationLifetimes.IApplicationLifetime))
|
||||
(Lifetime (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime))
|
||||
(Dispatcher (: Avalonia.Threading.Dispatcher))
|
||||
((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation))
|
||||
(AvaloniaObject (: Avalonia.AvaloniaObject))
|
||||
(AvaloniaProperty (: Avalonia.AvaloniaProperty))
|
||||
(Priority (: Avalonia.Data.BindingPriority))
|
||||
(Disposable (: System.IDisposable))
|
||||
(Thickness (: Avalonia.Thickness (-> double Thickness)))
|
||||
(Orientation (: Avalonia.Layout.Orientation))
|
||||
(HAlignment (: Avalonia.Layout.HorizontalAlignment))
|
||||
(TextWrapping (: Avalonia.Media.TextWrapping))
|
||||
(SizeToContent (: Avalonia.Controls.SizeToContent))
|
||||
(StartupLocation (: Avalonia.Controls.WindowStartupLocation))
|
||||
(Control (: Avalonia.Controls.Control))
|
||||
(Controls (: Avalonia.Controls.Controls))
|
||||
(Panel (: Avalonia.Controls.Panel))
|
||||
(StackPanel (: Avalonia.Controls.StackPanel (-> StackPanel)))
|
||||
(TextBlock (: Avalonia.Controls.TextBlock (-> TextBlock)))
|
||||
(TextBox (: Avalonia.Controls.TextBox (-> TextBox)))
|
||||
(Button (: Avalonia.Controls.Button (-> Button)))
|
||||
(Window (: Avalonia.Controls.Window (-> Window)))
|
||||
(TopLevel (: Avalonia.Controls.TopLevel))
|
||||
(Interactive (: Avalonia.Interactivity.Interactive))
|
||||
(RoutedEvent (: Avalonia.Interactivity.RoutedEvent))
|
||||
(RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs))
|
||||
(Routes (: Avalonia.Interactivity.RoutingStrategies))
|
||||
(StorageProvider (: Avalonia.Platform.Storage.IStorageProvider))
|
||||
(StorageItem (: Avalonia.Platform.Storage.IStorageItem))
|
||||
(StorageFile (: Avalonia.Platform.Storage.IStorageFile))
|
||||
(StorageFolder (: Avalonia.Platform.Storage.IStorageFolder))
|
||||
(FileType (: Avalonia.Platform.Storage.FilePickerFileType (-> string FileType)))
|
||||
(PickerOptions (: Avalonia.Platform.Storage.PickerOptions))
|
||||
(OpenOptions (: Avalonia.Platform.Storage.FilePickerOpenOptions (-> OpenOptions)))
|
||||
(SaveOptions (: Avalonia.Platform.Storage.FilePickerSaveOptions (-> SaveOptions)))
|
||||
(FolderOptions (: Avalonia.Platform.Storage.FolderPickerOpenOptions (-> FolderOptions))))
|
||||
|
||||
(import/extern
|
||||
;; The UI thread, and the window a dialog belongs to.
|
||||
(ui-dispatcher (: Avalonia.Threading.Dispatcher.UIThread #:get))
|
||||
(ui-post (: Avalonia.Threading.Dispatcher.InvokeAsync (-> Dispatcher (-> Unit) (DispatcherOp Unit))))
|
||||
;; Runs a function on the UI thread.
|
||||
(on-ui (: Avalonia.Threading.Dispatcher.InvokeAsync
|
||||
(-> Dispatcher (-> Unit) (DispatcherOp Unit))))
|
||||
(op-task (: Avalonia.Threading.DispatcherOperation.GetTask (-> DispatcherOpBase Task)))
|
||||
;; Waits for Tasks. Avalonia's dialogs take no CancellationToken, so this
|
||||
;; cannot be cancelled: a cancelled command stops at its next sync, and the
|
||||
;; dialog stays until it is answered.
|
||||
(await-tasks (: System.Threading.Tasks.Task.WhenAll (-> (Array Task) void)
|
||||
#:async #:uncancellable))
|
||||
;; What a finished Task answers. By reflection, because Bjolang reads no
|
||||
;; Task's Result: on a Task that is not finished, that would block.
|
||||
(type-of (: System.Object.GetType (-> Object ClrType)))
|
||||
(property-of (: System.Type.GetProperty (-> ClrType string PropertyInfo)))
|
||||
(value-of (: System.Reflection.PropertyInfo.GetValue (-> PropertyInfo Object Object)))
|
||||
(answered (: System.Threading.Tasks.Task.FromResult (-> %a (Task %a))))
|
||||
(current-app (: Avalonia.Application.Current #:get))
|
||||
(app-lifetime (: Avalonia.Application.ApplicationLifetime (-> Application ILifetime) #:get))
|
||||
(main-window (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.MainWindow
|
||||
(-> Lifetime Window) #:get))
|
||||
(shutdown! (: Avalonia.Controls.ApplicationLifetimes.ClassicDesktopStyleApplicationLifetime.Shutdown
|
||||
(-> Lifetime int void)))
|
||||
(reference=? (: System.Object.ReferenceEquals (-> Object Object bool)))
|
||||
|
||||
;; The dialog window.
|
||||
(set-value (: Avalonia.AvaloniaObject.SetValue
|
||||
(-> AvaloniaObject AvaloniaProperty Object Priority Disposable)))
|
||||
(title-property (: Avalonia.Controls.Window.TitleProperty #:get))
|
||||
(size-to-content-property (: Avalonia.Controls.Window.SizeToContentProperty #:get))
|
||||
(startup-location-property (: Avalonia.Controls.Window.WindowStartupLocationProperty #:get))
|
||||
(can-resize-property (: Avalonia.Controls.Window.CanResizeProperty #:get))
|
||||
(show-in-taskbar-property (: Avalonia.Controls.Window.ShowInTaskbarProperty #:get))
|
||||
(content-property (: Avalonia.Controls.ContentControl.ContentProperty #:get))
|
||||
(margin-property (: Avalonia.Layout.Layoutable.MarginProperty #:get))
|
||||
(max-width-property (: Avalonia.Layout.Layoutable.MaxWidthProperty #:get))
|
||||
(min-width-property (: Avalonia.Layout.Layoutable.MinWidthProperty #:get))
|
||||
(halign-property (: Avalonia.Layout.Layoutable.HorizontalAlignmentProperty #:get))
|
||||
(spacing-property (: Avalonia.Controls.StackPanel.SpacingProperty #:get))
|
||||
(orientation-property (: Avalonia.Controls.StackPanel.OrientationProperty #:get))
|
||||
(text-property (: Avalonia.Controls.TextBlock.TextProperty #:get))
|
||||
(wrapping-property (: Avalonia.Controls.TextBlock.TextWrappingProperty #:get))
|
||||
(box-text-property (: Avalonia.Controls.TextBox.TextProperty #:get))
|
||||
(is-default-property (: Avalonia.Controls.Button.IsDefaultProperty #:get))
|
||||
(is-cancel-property (: Avalonia.Controls.Button.IsCancelProperty #:get))
|
||||
(click-event (: Avalonia.Controls.Button.ClickEvent #:get))
|
||||
(add-handler (: Avalonia.Interactivity.Interactive.AddHandler
|
||||
(-> Interactive RoutedEvent Delegate Routes bool void)))
|
||||
(children (: Avalonia.Controls.Panel.Children (-> Panel Controls) #:get))
|
||||
(box-text (: Avalonia.Controls.TextBox.Text (-> TextBox ClrString) #:get))
|
||||
(close-with! (: Avalonia.Controls.Window.Close (-> Window Object void)))
|
||||
(show-dialog (: Avalonia.Controls.Window.ShowDialog (-> Window Window (Task Object))))
|
||||
(clr-string (: System.Convert.ToString (-> string ClrString)))
|
||||
|
||||
;; The pickers.
|
||||
(storage-provider (: Avalonia.Controls.TopLevel.StorageProvider (-> TopLevel StorageProvider) #:get))
|
||||
(pick-files (: Avalonia.Platform.Storage.IStorageProvider.OpenFilePickerAsync
|
||||
(-> StorageProvider OpenOptions (Task (ReadOnlyList StorageFile)))))
|
||||
(pick-save (: Avalonia.Platform.Storage.IStorageProvider.SaveFilePickerAsync
|
||||
(-> StorageProvider SaveOptions (Task StorageFile))))
|
||||
(pick-folders (: Avalonia.Platform.Storage.IStorageProvider.OpenFolderPickerAsync
|
||||
(-> StorageProvider FolderOptions (Task (ReadOnlyList StorageFolder)))))
|
||||
(local-path (: Avalonia.Platform.Storage.StorageProviderExtensions.TryGetLocalPath (-> StorageItem string)))
|
||||
(title! (: Avalonia.Platform.Storage.PickerOptions.Title (-> PickerOptions string void) #:set))
|
||||
(allow-multiple! (: Avalonia.Platform.Storage.FilePickerOpenOptions.AllowMultiple (-> OpenOptions bool void) #:set))
|
||||
(file-types! (: Avalonia.Platform.Storage.FilePickerOpenOptions.FileTypeFilter
|
||||
(-> OpenOptions (ReadOnlyList FileType) void) #:set))
|
||||
(suggested-name! (: Avalonia.Platform.Storage.FilePickerSaveOptions.SuggestedFileName
|
||||
(-> SaveOptions string void) #:set))
|
||||
(patterns! (: Avalonia.Platform.Storage.FilePickerFileType.Patterns
|
||||
(-> FileType (ReadOnlyList ClrString) void) #:set)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; The UI thread
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(: (-> Object bool))
|
||||
(defun (null? x) (reference=? x (clr-default)))
|
||||
|
||||
;; The app's main window, if there is an app with one.
|
||||
(: (-> (Option Window)))
|
||||
(defun (owner)
|
||||
(def app (cast Object current-app))
|
||||
(if (null? app)
|
||||
None
|
||||
(match (try (cast Lifetime (app-lifetime (cast Application app)))
|
||||
#:catch (System.InvalidCastException System.NullReferenceException))
|
||||
((Ok lifetime)
|
||||
(def w (main-window lifetime))
|
||||
(if (null? (cast Object w)) None (Some w)))
|
||||
((Err _) None))))
|
||||
|
||||
;; Runs `start` on the UI thread with the main window, and waits for the
|
||||
;; Task it makes. `none` is the answer when there is no window.
|
||||
(: (-bjo-> (-> Window (Task %a)) %a %a))
|
||||
(defbjo (run-on-ui start none)
|
||||
(def/mutable task (: (clr-default) Task))
|
||||
(def op (on-ui ui-dispatcher
|
||||
(fun ()
|
||||
(set! task (cast Task (cast Object (match (owner)
|
||||
((Some w) (start w))
|
||||
(None (answered none))))))
|
||||
unit)))
|
||||
(await-tasks #[(op-task (cast DispatcherOpBase (cast Object op)))])
|
||||
(await-tasks #[task])
|
||||
(cast %a (value-of (property-of (type-of (cast Object task)) "Result") (cast Object task))))
|
||||
|
||||
;; The event of what the Task that `start` makes answers, at each sync.
|
||||
;; `none` is the answer when there is no window, or the Task fails.
|
||||
(: (-> (-> Window (Task %a)) %a (Event %a)))
|
||||
(defun (ask start none)
|
||||
(guard (fun ()
|
||||
(wrap (promise-join (bjo (run-on-ui start none)))
|
||||
(fun (r) (match r
|
||||
((Ok x) x)
|
||||
((Err _) none)))))))
|
||||
|
||||
;; None for null.
|
||||
(: (-> Object (Option Object)))
|
||||
(defun (non-null o) (if (null? o) None (Some o)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Message boxes
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(: (-> AvaloniaObject AvaloniaProperty Object void))
|
||||
(defun (put! o property value)
|
||||
(ignore (set-value o property value Priority.LocalValue)))
|
||||
|
||||
(: (-> Control (-> void) void))
|
||||
(defun (on-click! button f)
|
||||
(add-handler (cast Interactive button) (cast RoutedEvent click-event)
|
||||
(cast Delegate (cast Object (: (as-delegate (: (fun (s e) (f)) (-> Object RoutedEventArgs void)))
|
||||
(EventHandler RoutedEventArgs))))
|
||||
Routes.Bubble #f))
|
||||
|
||||
;; A button of a dialog: its label, what the dialog answers when it is
|
||||
;; clicked, from its text input, and whether Enter or Escape clicks it.
|
||||
(type (: Choice (Record (: label string) (: answer (-> TextBox Object)) (: enter bool) (: escape bool))))
|
||||
|
||||
;; Shows a dialog with `text`, a text input holding `value` if there is one,
|
||||
;; and the buttons of `choices`, and answers the Task of what it closes with.
|
||||
(: (-> string string (Option string) (List Choice) Window (Task Object)))
|
||||
(defun (show-box! title text value choices owner)
|
||||
(def w (Window.))
|
||||
(def o (cast AvaloniaObject w))
|
||||
(put! o (cast AvaloniaProperty title-property) (cast Object (clr-string title)))
|
||||
(put! o (cast AvaloniaProperty size-to-content-property) (cast Object SizeToContent.WidthAndHeight))
|
||||
(put! o (cast AvaloniaProperty startup-location-property) (cast Object StartupLocation.CenterOwner))
|
||||
(put! o (cast AvaloniaProperty can-resize-property) (cast Object #f))
|
||||
(put! o (cast AvaloniaProperty show-in-taskbar-property) (cast Object #f))
|
||||
|
||||
(def panel (StackPanel.))
|
||||
(put! (cast AvaloniaObject panel) (cast AvaloniaProperty margin-property) (cast Object (Thickness. 20.0)))
|
||||
(put! (cast AvaloniaObject panel) (cast AvaloniaProperty spacing-property) (cast Object 14.0))
|
||||
(put! (cast AvaloniaObject panel) (cast AvaloniaProperty min-width-property) (cast Object 280.0))
|
||||
|
||||
(def label (TextBlock.))
|
||||
(put! (cast AvaloniaObject label) (cast AvaloniaProperty text-property) (cast Object (clr-string text)))
|
||||
(put! (cast AvaloniaObject label) (cast AvaloniaProperty wrapping-property) (cast Object TextWrapping.Wrap))
|
||||
(put! (cast AvaloniaObject label) (cast AvaloniaProperty max-width-property) (cast Object 400.0))
|
||||
(.Add (children (cast Panel panel)) (cast Control label))
|
||||
|
||||
(def input (TextBox.))
|
||||
(match value
|
||||
((Some v)
|
||||
(put! (cast AvaloniaObject input) (cast AvaloniaProperty box-text-property) (cast Object (clr-string v)))
|
||||
(.Add (children (cast Panel panel)) (cast Control input)))
|
||||
(None unit))
|
||||
|
||||
(def buttons (StackPanel.))
|
||||
(put! (cast AvaloniaObject buttons) (cast AvaloniaProperty orientation-property) (cast Object Orientation.Horizontal))
|
||||
(put! (cast AvaloniaObject buttons) (cast AvaloniaProperty spacing-property) (cast Object 8.0))
|
||||
(put! (cast AvaloniaObject buttons) (cast AvaloniaProperty halign-property) (cast Object HAlignment.Right))
|
||||
(loop (:for c choices)
|
||||
(:do (def b (Button.))
|
||||
(put! (cast AvaloniaObject b) (cast AvaloniaProperty content-property) (cast Object (clr-string (.label c))))
|
||||
(put! (cast AvaloniaObject b) (cast AvaloniaProperty is-default-property) (cast Object (.enter c)))
|
||||
(put! (cast AvaloniaObject b) (cast AvaloniaProperty is-cancel-property) (cast Object (.escape c)))
|
||||
(on-click! (cast Control b) (fun () (close-with! w ((.answer c) input))))
|
||||
(.Add (children (cast Panel buttons)) (cast Control b))))
|
||||
(.Add (children (cast Panel panel)) (cast Control buttons))
|
||||
(put! o (cast AvaloniaProperty content-property) (cast Object panel))
|
||||
(show-dialog w owner))
|
||||
|
||||
(: (-> string (-> TextBox Object) bool bool Choice))
|
||||
(defun (choice label answer enter escape)
|
||||
(Choice (label label) (answer answer) (enter enter) (escape escape)))
|
||||
|
||||
;; A message, and an OK button. Sends `msg` when it is closed.
|
||||
(: alert (-> string %m (#:title string) (Event %m)))
|
||||
(defun (alert text msg #:title "")
|
||||
(wrap (ask (fun (w) (show-box! title text None
|
||||
(list (choice "OK" (fun (i) (clr-default)) #t #t)) w))
|
||||
(clr-default))
|
||||
(fun (_) msg)))
|
||||
|
||||
;; A question, with OK and Cancel. Sends `(on-answer #t)` for OK, and
|
||||
;; `(on-answer #f)` for Cancel, Escape or a closed window.
|
||||
(: confirm (-> string (-> bool %m) (#:title string) (#:ok string) (#:cancel string) (Event %m)))
|
||||
(defun (confirm text on-answer #:title "" #:ok "OK" #:cancel "Cancel")
|
||||
(wrap (ask (fun (w) (show-box! title text None
|
||||
(list (choice cancel (fun (i) (cast Object #f)) #f #t)
|
||||
(choice ok (fun (i) (cast Object #t)) #t #f))
|
||||
w))
|
||||
(clr-default))
|
||||
(fun (answer)
|
||||
(on-answer (match (non-null answer) ((Some o) (.Equals o (cast Object #t))) (None #f))))))
|
||||
|
||||
;; A question with a text input holding `#:value`. Sends `(on-answer (Some
|
||||
;; text))` for OK, and `(on-answer None)` for Cancel, Escape or a closed
|
||||
;; window.
|
||||
(: prompt (-> string (-> (Option string) %m) (#:value string) (#:title string) (Event %m)))
|
||||
(defun (prompt text on-answer #:value "" #:title "")
|
||||
(wrap (ask (fun (w) (show-box! title text (Some value)
|
||||
(list (choice "Cancel" (fun (i) (clr-default)) #f #t)
|
||||
(choice "OK" (fun (i) (cast Object (box-text i))) #t #f))
|
||||
w))
|
||||
(clr-default))
|
||||
(fun (answer)
|
||||
(on-answer (match (non-null answer) ((Some o) (Some (.ToString o))) (None None))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Files
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; The local paths of the items. A list of Avalonia's is walked as a Seq.
|
||||
(: (-> (ReadOnlyList StorageItem) (List string)))
|
||||
(defun (paths items)
|
||||
(loop (:for item (cast (Seq StorageItem) (cast Object items)))
|
||||
(:let p (local-path item))
|
||||
(:when (not (string-empty? p)))
|
||||
(:acc out (listing p))
|
||||
=> out))
|
||||
|
||||
(: (-> (List string) (Array ClrString)))
|
||||
(defun (clr-strings xs)
|
||||
(vec->array (list->vec (list-map (fun (s) (clr-string s)) xs))))
|
||||
|
||||
(: (-> (List (Tuple string (List string))) (ReadOnlyList FileType)))
|
||||
(defun (file-types filters)
|
||||
(def types
|
||||
(list-map (fun (f)
|
||||
(def t (FileType. (fst f)))
|
||||
(patterns! t (cast (ReadOnlyList ClrString) (cast Object (clr-strings (snd f)))))
|
||||
t)
|
||||
filters))
|
||||
(cast (ReadOnlyList FileType) (cast Object (vec->array (list->vec types)))))
|
||||
|
||||
(: (-> (ReadOnlyList StorageFile)))
|
||||
(defun (no-files)
|
||||
(cast (ReadOnlyList StorageFile) (cast Object (: (make-array 0) (Array StorageFile)))))
|
||||
|
||||
(: (-> string (List (Tuple string (List string))) bool (Event (List string))))
|
||||
(defun (ask-files title filters many?)
|
||||
(wrap (ask (fun (w)
|
||||
(def options (OpenOptions.))
|
||||
(unless (string-empty? title) (title! (cast PickerOptions options) title))
|
||||
(allow-multiple! options many?)
|
||||
(unless (list-empty? filters) (file-types! options (file-types filters)))
|
||||
(pick-files (storage-provider (cast TopLevel w)) options))
|
||||
(no-files))
|
||||
(fun (files) (paths (cast (ReadOnlyList StorageItem) (cast Object files))))))
|
||||
|
||||
(: (-> (List string) (Option string)))
|
||||
(defun (first-path ps)
|
||||
(match ps ((List p rest ...) (Some p)) (_ None)))
|
||||
|
||||
;; Asks for a file to open. Sends `(on-answer (Some path))`, or `(on-answer
|
||||
;; None)` when the picker is cancelled. `#:filters` are the kinds of file it
|
||||
;; shows, each a name and patterns: `(list (Tuple "Text" '("*.txt" "*.md")))`.
|
||||
(: open-file (-> (-> (Option string) %m) (#:title string)
|
||||
(#:filters (List (Tuple string (List string)))) (Event %m)))
|
||||
(defun (open-file on-answer #:title "" #:filters '())
|
||||
(wrap (ask-files title filters #f) (fun (ps) (on-answer (first-path ps)))))
|
||||
|
||||
;; Asks for files to open. Sends `(on-answer paths)`, empty when the picker
|
||||
;; is cancelled.
|
||||
(: open-files (-> (-> (List string) %m) (#:title string)
|
||||
(#:filters (List (Tuple string (List string)))) (Event %m)))
|
||||
(defun (open-files on-answer #:title "" #:filters '())
|
||||
(wrap (ask-files title filters #t) on-answer))
|
||||
|
||||
;; Asks where to save a file. Sends `(on-answer (Some path))`, or `(on-answer
|
||||
;; None)` when the picker is cancelled. The file is not made.
|
||||
(: save-file (-> (-> (Option string) %m) (#:title string) (#:name string) (Event %m)))
|
||||
(defun (save-file on-answer #:title "" #:name "")
|
||||
(wrap (ask (fun (w)
|
||||
(def options (SaveOptions.))
|
||||
(unless (string-empty? title) (title! (cast PickerOptions options) title))
|
||||
(unless (string-empty? name) (suggested-name! options name))
|
||||
(pick-save (storage-provider (cast TopLevel w)) options))
|
||||
(: (clr-default) StorageFile))
|
||||
(fun (f)
|
||||
(on-answer (if (null? (cast Object f))
|
||||
None
|
||||
(match (local-path (cast StorageItem f))
|
||||
("" None)
|
||||
(p (Some p))))))))
|
||||
|
||||
;; Asks for a folder. Sends `(on-answer (Some path))`, or `(on-answer None)`
|
||||
;; when the picker is cancelled.
|
||||
(: open-folder (-> (-> (Option string) %m) (#:title string) (Event %m)))
|
||||
(defun (open-folder on-answer #:title "")
|
||||
(wrap (ask (fun (w)
|
||||
(def options (FolderOptions.))
|
||||
(unless (string-empty? title) (title! (cast PickerOptions options) title))
|
||||
(pick-folders (storage-provider (cast TopLevel w)) options))
|
||||
(cast (ReadOnlyList StorageFolder) (cast Object (: (make-array 0) (Array StorageFolder)))))
|
||||
(fun (folders) (on-answer (first-path (paths (cast (ReadOnlyList StorageItem) (cast Object folders))))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Quitting
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; Closes the app's windows, and so ends `run-app`. Sends nothing. This is how
|
||||
;; a program closes after it was asked with `#:on-close`.
|
||||
(: quit (-> (Event %m)))
|
||||
(defun (quit)
|
||||
(guard (fun ()
|
||||
(ignore (ui-post ui-dispatcher
|
||||
(fun ()
|
||||
(def app (cast Object current-app))
|
||||
(unless (null? app)
|
||||
(match (try (cast Lifetime (app-lifetime (cast Application app)))
|
||||
#:catch (System.InvalidCastException
|
||||
System.NullReferenceException))
|
||||
((Ok lifetime) (shutdown! lifetime 0))
|
||||
((Err _) unit)))
|
||||
unit)))
|
||||
(never))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue