Prompt Dialog

source/clog-gui.lisp

@@ -88,6 +88,7 @@
   (alert-dialog       function)
   (input-dialog       function)
   (confirm-dialog     function)
+  (prompt-dialog      function)
   (form-dialog        function)
   (server-file-dialog function)
 
@@ -2100,6 +2101,125 @@ Calls on-input with t if confirmed or nil if canceled."
         (window-close win)))
     result))
 
+;;;;;;;;;;;;;;;;;;;
+;; prompt-dialog ;;
+;;;;;;;;;;;;;;;;;;;
+
+(defun prompt-dialog (obj callback
+                      &key
+                        (title "Prompt")
+                        (completion #'list)
+                        (validation (constantly t))
+                        (presentation (lambda (it) (format nil "~a" it)))
+                        (initial-value "")
+                        (modal t)
+                        time-out
+                        left top (width 390) (height 425)
+                        maximize
+                        client-movement
+                        (keep-on-top t)
+                        html-id)
+  "Create a prompt dialog box with a selection of items generated by
+the provided COMPLETION function.
+
+COMPLETION is a function that takes the current string and returns
+a list of options.
+
+VALIDATION is a predicate that you can specify to prevent the user
+from entering a malformed text input.
+
+PRESENTATION is used if COMPLETION yields something other than strings.
+
+Pressing <Tab> will replace the input field with the top completion,
+as you might expect in an IDE.  Clicking an item will also put it in
+the input field.
+
+Pressing <Escape> will cancel the prompt."
+  (let* ((sem (when time-out (bt2:make-semaphore)))
+         (result nil)
+         (body (connection-body obj))
+         (win (create-gui-window obj
+                                 :title title
+                                 :maximize maximize
+                                 :top top
+                                 :left left
+                                 :width width
+                                 :height height
+                                 :hidden t
+                                 :client-movement client-movement
+                                 :keep-on-top keep-on-top
+                                 :html-id html-id))
+         (form (create-form (window-content win)
+                            :style "width:100%;display:flex;"))
+         (input (create-form-element form :input :style "flex-grow:1;"))
+         (ok (create-button form
+                            :content "Okay"
+                            :class "w3-button w3-black"))
+         (cancel (create-button form
+                                :content "Cancel"
+                                :class "w3-button w3-black"))
+         (items-list (create-unordered-list
+                      (window-content win)
+                      :class "w3-ul w3-hoverable"))
+         (items '()))
+    (unless top
+      (setf (top win) (unit :px (- (/ (inner-height (window body)) 2.0)
+                                   (/ (height win) 2.0)))))
+    (unless left
+      (setf (left win) (unit :px (- (/ (inner-width (window body)) 2.0)
+                                    (/ (width win) 2.0)))))
+    (setf (overflow items-list) :auto)
+    (setf (visiblep win) t)
+    (setf (value input) initial-value)
+    (setf (attribute input "autocomplete") "off")
+    (when modal
+      (window-make-modal win))
+    (flet ((refresh-completions ()
+             (setf (inner-html items-list) "")
+             (setf items '())
+             (dolist (it (funcall completion (value input)))
+               (setf items (append items (list it)))
+               (let ((li (create-list-item
+                          items-list
+                          :content (funcall presentation it))))
+                 (set-on-click li (lambda (obj)
+                                    (declare (ignore obj))
+                                    (setf (value input) it)
+                                    (focus input)))))
+             (focus input)))
+      (refresh-completions)
+      (set-on-window-close win (lambda (obj)
+                                 (declare (ignore obj))
+                                 (when modal
+                                   (window-end-modal win))
+                                 (when sem
+                                   (bt2:signal-semaphore sem))))
+      (set-on-click ok (lambda (obj)
+                         (declare (ignore obj))
+                         (when (funcall validation (value input))
+                           (when modal
+                             (window-end-modal win))
+                           (setf result (funcall callback (value input)))
+                           (window-close win)))
+                    :one-time t)
+      (set-on-click cancel (lambda (obj)
+                             (declare (ignore obj))
+                             (window-close win)))
+      (set-on-key-down input (lambda (obj ev)
+                               (declare (ignore obj))
+                               (let ((key (getf ev :key)))
+                                 (cond ((equal "Escape" key)
+                                        (window-close win))
+                                       ((equal "Tab" key)
+                                        (setf (value input) (car items))
+                                        )))
+                               (refresh-completions)))
+      (when sem
+        (unless (bt2:wait-on-semaphore sem :timeout time-out)
+          (setf sem nil)
+          (window-close win)))
+      result)))
+
 ;;;;;;;;;;;;;;;;;
 ;; form-dialog ;;
 ;;;;;;;;;;;;;;;;;

tutorial/22-tutorial.lisp

@@ -142,6 +142,19 @@
                  (alert-dialog obj results))
                :height 550))
 
+(defun on-dlg-prompt (obj)
+  (flet ((make-completion (selection &key (test #'search))
+           (lambda (str)
+             (remove-if-not (alexandria:curry test str) selection))))
+    (let ((options '("white" "red" "orange" "yellow" "green" "blue"
+                     "indigo" "violet" "brown" "black" "grey")))
+      (prompt-dialog obj
+                     (lambda (color) (alert-dialog obj color))
+                     :title "Color Prompt"
+                     :completion (make-completion options)
+                     :validation (lambda (str)
+                                   (find str options :test #'equal))))))
+
 (defun on-toast-alert (obj)
   (alert-toast obj "Stop!" "To get rid of me, click the X. I have no time-out"))
 
@@ -208,6 +221,7 @@
          (tmp   (create-gui-menu-item dlg :content "Alert Dialog Box" :on-click 'on-dlg-alert))
          (tmp   (create-gui-menu-item dlg :content "Input Dialog Box" :on-click 'on-dlg-input))
          (tmp   (create-gui-menu-item dlg :content "Confirm Dialog Box" :on-click 'on-dlg-confirm))
+         (tmp   (create-gui-menu-item dlg :content "Prompt Dialog Box" :on-click 'on-dlg-prompt))
          (tmp   (create-gui-menu-item dlg :content "Form Dialog Box" :on-click 'on-dlg-form))
          (tmp   (create-gui-menu-item dlg :content "Server File Dialog Box" :on-click 'on-dlg-file))
          (tst   (create-gui-menu-drop-down menu :content "Toasts"))