diff --git a/source/clog-gui.lisp b/source/clog-gui.lisp index bda8289..005c009 100644 --- a/source/clog-gui.lisp +++ b/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 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 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 ;; ;;;;;;;;;;;;;;;;; diff --git a/tutorial/22-tutorial.lisp b/tutorial/22-tutorial.lisp index 0d7598b..79fb860 100644 --- a/tutorial/22-tutorial.lisp +++ b/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"))