├── .gitignore ├── nocompletion.lisp ├── duologue-test.asd ├── package.lisp ├── duologue-readline.asd ├── duologue.asd ├── tests.lisp ├── LICENSE ├── readline.lisp ├── README.md └── duologue.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl -------------------------------------------------------------------------------- /nocompletion.lisp: -------------------------------------------------------------------------------- 1 | (in-package :duologue) 2 | 3 | (defun complete-prompt (prompt options completer) 4 | (declare (ignore prompt options completer)) 5 | (error "duologue error: no completion backend loaded")) 6 | -------------------------------------------------------------------------------- /duologue-test.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:duologue-test 2 | :license "MIT" 3 | :description "Tests for Duologue" 4 | :author "Mariano Montone " 5 | :depends-on (#:duologue #:stefil) 6 | :components 7 | ((:file "tests")) 8 | :perform (asdf:test-op (op c) 9 | (uiop:symbol-call :duologue/tests :run-tests))) 10 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:duologue 2 | (:use #:cl #:anaphora) 3 | (:export :say 4 | :ask 5 | :choose 6 | :choose-many 7 | :prompt 8 | :prompt-integer 9 | :prompt-email 10 | :prompt-url 11 | :prompt-datetime 12 | :prompt-pathname 13 | :parse-prompt 14 | :make-list-completer 15 | :while) 16 | (:documentation "High-level interaction library for Common Lisp")) 17 | -------------------------------------------------------------------------------- /duologue-readline.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:duologue-readline 2 | :description "High-level user interaction library for Common Lisp" 3 | :author "Mariano Montone " 4 | :license "GPL v3" 5 | :homepage "https://github.com/mmontone/duologue" 6 | :long-description 7 | #.(uiop:read-file-string 8 | (uiop:subpathname *load-pathname* "README.md")) 9 | :serial t 10 | :components ((:file "package") 11 | (:file "readline") 12 | (:file "duologue")) 13 | :depends-on (:anaphora 14 | :alexandria 15 | :clavier 16 | :chronicity 17 | :cl-readline 18 | :cl-ansi-text 19 | :drakma 20 | :cl-fad)) 21 | -------------------------------------------------------------------------------- /duologue.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:duologue 2 | :description "High-level user interaction library for Common Lisp" 3 | :author "Mariano Montone " 4 | :license "MIT" 5 | :homepage "https://github.com/mmontone/duologue" 6 | :long-description 7 | #.(uiop:read-file-string 8 | (uiop:subpathname *load-pathname* "README.md")) 9 | :serial t 10 | :components ((:file "package") 11 | (:file "nocompletion") 12 | (:file "duologue")) 13 | :depends-on (:anaphora 14 | :alexandria 15 | :clavier 16 | :chronicity 17 | :cl-ansi-text 18 | :cl-fad) 19 | :in-order-to ((asdf:test-op (asdf:test-op :duologue-test)))) 20 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :duologue/tests 2 | (:use :cl :stefil :duologue) 3 | (:export :run-tests)) 4 | 5 | (in-package :duologue/tests) 6 | 7 | (defsuite* duologue-tests) 8 | 9 | (defun run-tests () 10 | (duologue-tests)) 11 | 12 | (deftest prompt-test () 13 | (with-input-from-string (*query-io* "something 14 | ") 15 | (is (string= (prompt "Something:") "something"))) 16 | 17 | (signals error 18 | (with-input-from-string (*query-io* "something") 19 | (prompt "Integer:" :parser #'parse-integer))) 20 | 21 | (with-input-from-string (*query-io* "22") 22 | (is (= (prompt "Integer:" :parser #'parse-integer) 22))) 23 | 24 | (with-input-from-string (*query-io* "aa 25 | 22") 26 | (is (= (prompt "Integer:" :parser #'parse-integer) 22))) 27 | 28 | (signals error (with-input-from-string (*query-io* "lala 29 | ") 30 | (prompt-integer "Integer: ")))) 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /readline.lisp: -------------------------------------------------------------------------------- 1 | (in-package :duologue) 2 | 3 | (defun readline/make-list-completer (options) 4 | "Makes a default completer from a list of options" 5 | (lambda (text start end) 6 | (declare (ignorable start end)) 7 | (labels ((common-prefix (items) 8 | (subseq 9 | (car items) 0 10 | (position 11 | nil 12 | (mapcar 13 | (lambda (i) 14 | (every (lambda (x) 15 | (char= (char (car items) i) 16 | (char x i))) 17 | (cdr items))) 18 | (alexandria:iota (reduce #'min (mapcar #'length items))))))) 19 | (select-completions (list) 20 | (let ((els (remove-if-not (alexandria:curry #'alexandria:starts-with-subseq text) 21 | list))) 22 | (if (cdr els) 23 | (cons (common-prefix els) els) 24 | els)))) 25 | (select-completions options)))) 26 | 27 | (defun complete-prompt (prompt options completer) 28 | (rl:register-function :complete (or completer (readline/make-list-completer options))) 29 | (string-trim (list #\ ) (rl:readline :prompt prompt))) 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DUOLOGUE 2 | 3 | Duologue is high-level interaction library for Common Lisp. Command line interaction is implemented at the moment. It features coloured printing via cl-ansi-text and readline completion. 4 | 5 | ## Functions 6 | ### ask 7 | 8 | ```lisp 9 | (msg &key (default nil default-p) if-wrong-answer 10 | (color *prompt-color*) (error-color *prompt-error-color*)) 11 | ``` 12 | 13 | Ask for yes or no. 14 | 15 | - **msg**: (string) The prompt to use. 16 | - **default**: Default value. It gets selected if the user enters the empty string. Default: nil. 17 | - **if-wrong-answer**: (function) Function to execute if a wrong answer is given. 18 | - **color**: Prompt color. 19 | - **error-color**: Prompt error color. 20 | 21 | 22 | 23 | 24 | ### choose 25 | 26 | ```lisp 27 | (msg options &key if-wrong-option default (print-options t) (separator "~%") 28 | complete completer (color *prompt-color*) (error-color *prompt-error-color*)) 29 | ``` 30 | 31 | Asks the user to choose one of the given options. 32 | 33 | - **msg**: (string) The prompt message. 34 | - **options**: (list) The list of options the user can choose from. 35 | - **if-wrong-option**: (function) When present, this function is run if the user enters a wrong option. Default: nil. 36 | - **default**: The default value. The default value is selected if the user just hits the ENTER key. Default: nil. 37 | - **print-options**: (boolean) Print the options on the screen. Default: T. 38 | - **separator**: (string) Separation string to use when printing the options. Default: '~%' 39 | - **complete**: If T, then readline completion is enabled. Default: nil. 40 | - **completer**: A custom completer. If NIL, then the default completer is used. 41 | - **color**: Color to use at prompt. Default: *prompt-color* 42 | - **error-color**: Color to use when error ocurrs. Default: *prompt-error-color* 43 | 44 | 45 | Example: 46 | 47 | ```lisp 48 | (choose "Choose: " (list "foo" "bar" "baz") :default "baz") 49 | ``` 50 | **Tags**: menu, choose 51 | 52 | 53 | ### choose-many 54 | 55 | ```lisp 56 | (msg options &key if-wrong-option default (print-options t) (separator "~%") 57 | complete completer (test #'eql) (color *prompt-color*) 58 | (error-color *prompt-error-color*)) 59 | ``` 60 | 61 | Asks the user to choose many of the given options. 62 | 63 | - **msg**: (string) The prompt message. 64 | - **options**: (list) The list of options the user can choose from. 65 | - **if-wrong-option**: (function) When present, this function is run if the user enters a wrong option. Default: nil. 66 | - **default**: The default value. The default value is selected if the user just hits the ENTER key. Default: nil. 67 | - **print-options**: (boolean) Print the options on the screen. Default: T. 68 | - **separator**: (string) Separation string to use when printing the options. Default: '~%' 69 | - **complete**: If T, then readline completion is enabled. Default: nil. 70 | - **completer**: A custom completer. If NIL, then the default completer is used. 71 | - **color**: Color to use at prompt. Default: *prompt-color* 72 | - **error-color**: Color to use when error ocurrs. Default: *prompt-error-color* 73 | 74 | 75 | Example: 76 | 77 | ```lisp 78 | (choose-many "Choose: " (list "foo" "bar" "baz") :default '("baz")) 79 | ``` 80 | **Tags**: menu, choose 81 | 82 | 83 | ### prompt 84 | 85 | ```lisp 86 | (msg &key (default nil default-p) (required-p t) validator if-invalid 87 | parser completer (color *prompt-color*) (error-color *prompt-error-color*)) 88 | ``` 89 | 90 | Prompt for a string. 91 | 92 | - **msg**: The prompt. 93 | - **default**: Default value. This is returned if the user enters the empty string. Default: nil. 94 | - **required-p**: (boolean) If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 95 | - **validator**: (function) A function to use to validate the input. Should return T if the input is valid, or NIL otherwise. 96 | - **if-invalid**: (function) Function to execute if the validator fails. 97 | - **parser**: (function) A function to parse the input string. 98 | - **completer**: A custom completer. Default: no completion. 99 | - **color**: Prompt color 100 | - **error-color**: Prompt error color. 101 | 102 | 103 | 104 | 105 | ### prompt-datetime 106 | 107 | ```lisp 108 | (msg &key default (required-p t) if-invalid (color *prompt-color*) 109 | (error-color *prompt-error-color*)) 110 | ``` 111 | 112 | Prompts for a timestamp. 113 | 114 | - **msg**: The prompt. 115 | - **default**: Default value. This is returned if the user enters the empty string. Default: nil. 116 | - **required-p**: (boolean) If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 117 | - **if-invalid**: (function) Function to execute if the validator fails. 118 | - **color**: Prompt color 119 | - **error-color**: Prompt error color. 120 | 121 | 122 | **Returns**: the parsed local-time 123 | 124 | The input is parsed with chronicity library and transformed to a local-time. 125 | The input is validated and the process does not stop until the user enters a valid timestamp address. 126 | 127 | ### prompt-email 128 | 129 | ```lisp 130 | (msg &key default (required-p t) if-invalid (color *prompt-color*) 131 | (error-color *prompt-error-color*)) 132 | ``` 133 | 134 | Prompts for an email. 135 | 136 | - **msg**: The prompt. 137 | - **default**: Default value. This is returned if the user enters the empty string. Default: nil. 138 | - **required-p**: (boolean) If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 139 | - **if-invalid**: (function) Function to execute if the validator fails. 140 | - **color**: Prompt color 141 | - **error-color**: Prompt error color. 142 | 143 | 144 | **Returns**: the entered email 145 | 146 | The email is validated and the process does not stop until the user enters a valid email address. 147 | 148 | ### prompt-integer 149 | 150 | ```lisp 151 | (msg &key default (required-p t) if-invalid (color *prompt-color*) 152 | (error-color *prompt-error-color*)) 153 | ``` 154 | 155 | Prompts for an integer. 156 | 157 | - **msg**: The prompt. 158 | - **default**: Default value. This is returned if the user enters the empty string. Default: nil. 159 | - **required-p**: (boolean) If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 160 | - **if-invalid**: (function) Function to execute if the validator fails. 161 | - **color**: Prompt color 162 | - **error-color**: Prompt error color. 163 | 164 | 165 | **Returns**: the entered number 166 | 167 | 168 | 169 | ### prompt-pathname 170 | 171 | ```lisp 172 | (msg &key default (required-p t) if-invalid (color *prompt-color*) 173 | (error-color *prompt-error-color*) probe if-exists (if-does-not-exist :error) 174 | absolute-p file-type directory-p (complete t)) 175 | ``` 176 | 177 | Prompts for a pathname. 178 | 179 | - **msg**: The prompt. 180 | - **default**: Default value. This is returned if the user enters the empty string. Default: nil. 181 | - **required-p**: (boolean) If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 182 | - **if-invalid**: (function) Function to execute if the validator fails. 183 | - **color**: Prompt color 184 | - **error-color**: Prompt error color. 185 | - **complete**: If T, then uses readline path completion. Default: T. 186 | - probe. If T, checks that the file exists on the filesystem. 187 | - **if-exists**: Function to call if the probe is successful. 188 | - **if-does-not-exist**: (keyword) One of: 189 | * :error : Tries again until the pathname can be accessed. 190 | * :warn : Warns the user the pathname could not be accessed and asks for continuing. 191 | * :warn-and-continue: Warns the user the pathname could not be accessed and continues. 192 | 193 | 194 | 195 | 196 | 197 | ### prompt-url 198 | 199 | ```lisp 200 | (msg &key default (required-p t) if-invalid (color *prompt-color*) 201 | (error-color *prompt-error-color*) probe if-exists (if-does-not-exist :error)) 202 | ``` 203 | 204 | Prompts for an url. 205 | 206 | - **msg**: The prompt. 207 | - **default**: Default value. This is returned if the user enters the empty string. Default: nil. 208 | - **required-p**: (boolean) If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 209 | - **if-invalid**: (function) Function to execute if the validator fails. 210 | - **color**: Prompt color 211 | - **error-color**: Prompt error color 212 | - **probe**: (boolean) If T, then url is accessed and verified. 213 | - **if-exists**: (function) A function to call if the url exists (can be accessed). 214 | - **if-does-not-exist**: (keyword) One of: 215 | * :error : Tries again until the url can be accessed. 216 | * :warn : Warns the user the url could not be accessed and asks for continuing. 217 | * :warn-and-continue: Warns the user the url could not be accessed and continues. 218 | 219 | 220 | 221 | **Returns**: the entered url 222 | 223 | 224 | 225 | ### say 226 | 227 | ```lisp 228 | (datum &rest args) 229 | ``` 230 | 231 | Prints a message on the screen. 232 | 233 | - **datum**: (string) A format like string. 234 | - **args**: Format arguments or :color, :newline options 235 | - **color**: (keyword) An ansi-text color. One of ansi-colors (.i.e :red, :green, :yellow) 236 | - **newline**: (boolean) If t, forces a newline after printing 237 | 238 | 239 | A newline is printed iff either newline parameter is T or datum doesn't end with a space. That is, if datum ends in a space, then no newline is printed. 240 | 241 | Example: 242 | 243 | ```lisp 244 | (say "Hello ~A" "John" :color :blue) 245 | ``` 246 | **Categories**: printing 247 | **Tags**: printing 248 | 249 | 250 | ## Macros 251 | ### while 252 | 253 | ```lisp 254 | (msg (&rest options) &body body) 255 | ``` 256 | 257 | Asks to repeat a task several times and collects its result. 258 | 259 | - **msg**: The thing to ask to confirm the task 260 | - **options**: Options of the ask operation 261 | - **body**: The task to execute while the user confirms it. 262 | 263 | 264 | **Returns**: A list of collected task results 265 | 266 | Example: 267 | ```lisp 268 | (while "Add item?: " (:default t) 269 | (prompt "Item: ")) 270 | ``` 271 | **Tags**: flow 272 | -------------------------------------------------------------------------------- /duologue.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:duologue) 2 | 3 | (defparameter *prompt-color* nil "The default prompt color.") 4 | (defparameter *prompt-error-color* nil "The default error color") 5 | 6 | (defun make-validator (thing) 7 | (cond 8 | ((typep thing 'clavier:validator) 9 | thing) 10 | ((functionp thing) 11 | (clavier:fn thing "")) 12 | (t 13 | (error "Invalid validator spec: ~s" thing)))) 14 | 15 | (defun remove-options (args &rest keys) 16 | (let ((args (copy-list args)) 17 | (new-args nil)) 18 | (loop 19 | with arg 20 | while args 21 | do (setf arg (pop args)) 22 | (if (member arg keys) 23 | (pop args) 24 | (push arg new-args))) 25 | new-args)) 26 | 27 | (defun find-option (args option) 28 | (let ((args (copy-list args))) 29 | (loop with arg 30 | while args 31 | do (setf arg (pop args)) 32 | (when (equalp arg option) 33 | (return-from find-option (car args)))) 34 | nil)) 35 | 36 | (defun duologue-read-line () 37 | (read-line *query-io*)) 38 | 39 | (defun say (datum &rest args) 40 | "Prints a message on the screen. 41 | 42 | Args: - datum(string): A format like string. 43 | - args: Format arguments or :color, :newline options 44 | - color(keyword): An ansi-text color. One of ansi-colors (.i.e :red, :green, :yellow) 45 | - newline(boolean): If t, forces a newline after printing 46 | 47 | A newline is printed iff either newline parameter is T or datum doesn't end with a space. That is, if datum ends in a space, then no newline is printed. 48 | 49 | Example: 50 | 51 | ``(say \"Hello ~A\" \"John\" :color :blue)`` 52 | 53 | Categories: printing 54 | Tags: printing" 55 | (let ((format-args (remove-options args :color :newline)) 56 | (color (find-option args :color)) 57 | (newline (find-option args :newline))) 58 | (if color 59 | (cl-ansi-text:with-color (color) 60 | (apply #'format t (cons datum format-args))) 61 | ; else 62 | (apply #'format t (cons datum format-args))) 63 | (when (or newline 64 | (not (cl-ppcre:scan "[ \\t](\\e\\[\\d+(;\\d+)*m)?\\Z" datum))) 65 | (terpri)))) 66 | 67 | (defun parse-if-invalid (spec &optional error-color) 68 | (cond 69 | ((null spec) spec) 70 | ((stringp spec) (lambda (value) 71 | (declare (ignore value)) 72 | (say spec :color error-color))) 73 | ((functionp spec) spec) 74 | (t (error "Invalid value for :if-invalid: ~s" spec)))) 75 | 76 | (defun choose (msg options &key if-wrong-option 77 | default 78 | (print-options t) 79 | (separator "~%") 80 | complete 81 | completer 82 | (color *prompt-color*) 83 | (error-color *prompt-error-color*)) 84 | "Asks the user to choose one of the given options. 85 | 86 | Args: - msg(string): The prompt message. 87 | - options(list): The list of options the user can choose from. 88 | - if-wrong-option(function): When present, this function is run if the user enters a wrong option. Default: nil. 89 | - default: The default value. The default value is selected if the user just hits the ENTER key. Default: nil. 90 | - print-options(boolean): Print the options on the screen. Default: T. 91 | - separator(string): Separation string to use when printing the options. Default: '~%' 92 | - complete: If T, then completion is enabled. Default: nil. 93 | - completer: A custom completer. If NIL, then the default completer is used. 94 | - color: Color to use at prompt. Default: *prompt-color* 95 | - error-color: Color to use when error ocurrs. Default: *prompt-error-color* 96 | 97 | Example: 98 | 99 | ``(choose \"Choose: \" (list \"foo\" \"bar\" \"baz\") :default \"baz\")`` 100 | 101 | Tags: menu, choose" 102 | (assert (or (not default) 103 | (member default options :test 'string=)) 104 | nil "Invalid default: ~s" default) 105 | (flet ((print-options () 106 | (loop 107 | for option in options 108 | for i from 0 109 | do 110 | (format *query-io* "[~A] ~A" i option) 111 | (when (< (1+ i) (length options)) 112 | (format *query-io* separator))) 113 | (terpri)) 114 | (read-option () 115 | (cond 116 | ((or complete completer) 117 | (let ((prompt (if color 118 | (with-output-to-string (s) 119 | (cl-ansi-text:with-color (color :stream s) 120 | (format s "~A~@[[~A]~]" msg default))) 121 | (format nil "~A~@[[~A]~]" msg default)))) 122 | (complete-prompt prompt options completer))) 123 | (t 124 | (say msg :color color) 125 | (when default 126 | (say "[~A] " default :color color)) 127 | (string-trim (list #\ ) (duologue-read-line)))))) 128 | (when print-options 129 | (print-options)) 130 | (let* ((chosen-option (read-option)) 131 | (option-number (ignore-errors (parse-integer chosen-option)))) 132 | (loop 133 | do 134 | (cond ((and (equalp chosen-option "") 135 | default) 136 | (return default)) 137 | ((find chosen-option (mapcar #'princ-to-string options) :test #'string=) 138 | (return (find chosen-option (mapcar #'princ-to-string options) :test #'string=))) 139 | ((and option-number 140 | (>= option-number 0) 141 | (< option-number (length options))) 142 | ;; Correct option 143 | (return (nth option-number options))) 144 | (t 145 | ;; Incorrect option 146 | (progn 147 | (if if-wrong-option 148 | (funcall if-wrong-option) 149 | (say "Wrong option." :color error-color)) 150 | (when print-options 151 | (print-options))))) 152 | (setf chosen-option (read-option)) 153 | (setf option-number (ignore-errors (parse-integer chosen-option))))))) 154 | 155 | (defun ask (msg &key 156 | (default nil default-p) 157 | if-wrong-answer 158 | (color *prompt-color*) 159 | (error-color *prompt-error-color*)) 160 | "Ask for yes or no. 161 | 162 | Args: - msg(string): The prompt to use. Default: 'Yes or no: '. 163 | - default: Default value. It gets selected if the user enters the empty string. Default: nil. 164 | - if-wrong-answer(function): Function to execute if a wrong answer is given. 165 | - color: Prompt color. 166 | - error-color: Prompt error color." 167 | (check-type default boolean) 168 | (labels ((format-boolean (boolean) 169 | (if boolean "yes" "no")) 170 | (ask-question () 171 | (say msg :color color) 172 | (when default-p 173 | (say "[~A] " (format-boolean default) :color color)) 174 | (string-trim (list #\ ) (duologue-read-line)))) 175 | (let ((answer (ask-question))) 176 | (loop 177 | do 178 | (cond 179 | ((and (equalp answer "") default-p) 180 | (return-from ask default)) 181 | ((member answer (list "yes" "y" "on" "true") :test #'string-equal) 182 | (return-from ask t)) 183 | ((member answer (list "no" "n" "off" "false") :test #'string-equal) 184 | (return-from ask nil)) 185 | (t 186 | (if if-wrong-answer 187 | (funcall if-wrong-answer) 188 | (say "Answer yes or no" :color error-color)) 189 | (setf answer (ask-question)))))))) 190 | 191 | (defun prompt (msg &key 192 | default 193 | (required-p t) 194 | validator 195 | if-invalid 196 | parser 197 | completer 198 | type 199 | (color *prompt-color*) 200 | (error-color *prompt-error-color*)) 201 | "Prompt for a string. 202 | 203 | Args: - msg: The prompt. 204 | - default: Default value. This is returned if the user enters the empty string. Default: nil. 205 | - required-p(boolean): If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 206 | - validator(function): A function to use to validate the input. Should return T if the input is valid, or NIL otherwise. 207 | - if-invalid(function): Function to execute if the validator fails. 208 | - parser (function): A function to parse the input string. 209 | - completer: A custom completer. Default: no completion. 210 | - type: Type expected. 211 | - color: Prompt color 212 | - error-color: Prompt error color." 213 | (flet ((read-input () 214 | (cond 215 | (completer 216 | (let ((prompt (if color 217 | (with-output-to-string (s) 218 | (cl-ansi-text:with-color (color :stream s) 219 | (format s "~A~@[[~A]~]" msg default))) 220 | (format nil "~A~@[[~A]~]" msg default)))) 221 | (complete-prompt prompt nil completer))) 222 | ((not completer) 223 | (when msg 224 | (say msg :color color)) 225 | (when default 226 | (say "[~A] " default :color color)) 227 | (string-trim (list #\ ) (duologue-read-line)))))) 228 | (loop do 229 | (let ((input (read-input))) 230 | (cond ((and (equalp input "") default) 231 | (return default)) 232 | ((and (equalp input "") required-p) 233 | (say "A non empty value is required" :color error-color)) 234 | (t (let ((parsed-input (if parser 235 | (ignore-errors (funcall parser input)) 236 | input))) 237 | (cond 238 | ((not parsed-input) 239 | (if if-invalid 240 | (funcall (parse-if-invalid if-invalid error-color) input) 241 | (say "Invalid value" :color error-color))) 242 | ((and validator 243 | (not (funcall validator parsed-input))) 244 | (if if-invalid 245 | (funcall (parse-if-invalid if-invalid error-color) parsed-input) 246 | (say "The value is not valid" :color error-color))) 247 | ((and type (not (typep parsed-input type))) 248 | (if if-invalid 249 | (funcall (parse-if-invalid if-invalid error-color) parsed-input) 250 | (say "Value should be of type: ~a" type :color error-color))) 251 | (t 252 | (return parsed-input)))))))))) 253 | 254 | (defun prompt-integer (msg &key default 255 | (required-p t) 256 | if-invalid 257 | validator 258 | (color *prompt-color*) 259 | (error-color *prompt-error-color*)) 260 | "Prompts for an integer. 261 | 262 | Args: - msg: The prompt. 263 | - default: Default value. This is returned if the user enters the empty string. Default: nil. 264 | - required-p(boolean): If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 265 | - if-invalid(function): Function to execute if the validator fails. 266 | - color: Prompt color 267 | - error-color: Prompt error color. 268 | 269 | Returns: the entered number" 270 | (prompt msg 271 | :parser #'parse-integer 272 | :validator (or (and validator (clavier:&& (clavier:is-an-integer) 273 | (make-validator validator))) 274 | (clavier:is-an-integer)) 275 | :default default 276 | :required-p required-p 277 | :if-invalid (or (parse-if-invalid if-invalid error-color) 278 | (lambda (&rest args) 279 | (declare (ignore args)) 280 | (say "Error: Not a number" :color error-color))) 281 | :color color 282 | :error-color error-color)) 283 | 284 | (defun prompt-email (msg &key default 285 | (required-p t) 286 | validator 287 | if-invalid 288 | (color *prompt-color*) 289 | (error-color *prompt-error-color*)) 290 | "Prompts for an email. 291 | 292 | Args: - msg: The prompt. 293 | - default: Default value. This is returned if the user enters the empty string. Default: nil. 294 | - required-p(boolean): If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 295 | - if-invalid(function): Function to execute if the validator fails. 296 | - color: Prompt color 297 | - error-color: Prompt error color. 298 | 299 | Returns: the entered email 300 | 301 | The email is validated and the process does not stop until the user enters a valid email address." 302 | (prompt msg :default default 303 | :required-p required-p 304 | :validator (or (and validator (clavier:&& (clavier:valid-email) 305 | (make-validator validator))) 306 | (clavier:valid-email)) 307 | :if-invalid (or (parse-if-invalid if-invalid error-color) 308 | (lambda (&optional value) 309 | (declare (ignore value)) 310 | (say "Invalid email" :color error-color))) 311 | :color color 312 | :error-color error-color)) 313 | 314 | (defun prompt-url (msg &key default 315 | (required-p t) 316 | if-invalid 317 | (color *prompt-color*) 318 | (error-color *prompt-error-color*) 319 | probe 320 | if-exists 321 | (if-does-not-exist :error)) 322 | "Prompts for an url. 323 | 324 | Args: - msg: The prompt. 325 | - default: Default value. This is returned if the user enters the empty string. Default: nil. 326 | - required-p(boolean): If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 327 | - if-invalid(function): Function to execute if the validator fails. 328 | - color: Prompt color 329 | - error-color: Prompt error color 330 | - probe(boolean): If T, then url is accessed and verified. 331 | - if-exists(function): A function to call if the url exists (can be accessed). 332 | - if-does-not-exist(keyword): One of: 333 | * :error : Tries again until the url can be accessed. 334 | * :warn : Warns the user the url could not be accessed and asks for continuing. 335 | * :warn-and-continue: Warns the user the url could not be accessed and continues. 336 | 337 | Returns: the entered url" 338 | (flet ((recurse () 339 | (return-from prompt-url 340 | (prompt-url msg :default default 341 | :required-p required-p 342 | :if-invalid if-invalid 343 | :color color 344 | :error-color error-color 345 | :probe probe 346 | :if-exists if-exists 347 | :if-does-not-exist if-does-not-exist)))) 348 | (let ((url 349 | (prompt msg :default default 350 | :required-p required-p 351 | :validator (clavier:valid-url) 352 | :if-invalid (or (parse-if-invalid if-invalid error-color) 353 | (lambda (&optional value) 354 | (declare (ignore value)) 355 | (say "Invalid url" :color error-color))) 356 | :color color 357 | :error-color error-color))) 358 | (when probe 359 | (multiple-value-bind (result status) 360 | (ignore-errors (funcall probe url)) 361 | (declare (ignore result)) 362 | (if (member status (list 200 302)) 363 | (when if-exists 364 | (funcall if-exists)) 365 | ;; else 366 | (ecase if-does-not-exist 367 | (:error 368 | (say "The url does not exist." :color error-color) 369 | (recurse)) 370 | (:warn 371 | (say "The url does not exist." :color error-color) 372 | (when (not (ask "Continue?:" :default nil)) 373 | (recurse))) 374 | (:warn-and-continue 375 | (say "The url does not exist." :color error-color)))))) 376 | url))) 377 | 378 | (defun prompt-pathname (msg &key default 379 | (required-p t) 380 | if-invalid 381 | (color *prompt-color*) 382 | (error-color *prompt-error-color*) 383 | probe 384 | if-exists 385 | (if-does-not-exist :error) 386 | absolute-p 387 | file-type 388 | (complete t)) 389 | "Prompts for a pathname. 390 | 391 | Args: - msg: The prompt. 392 | - default: Default value. This is returned if the user enters the empty string. Default: nil. 393 | - required-p(boolean): If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 394 | - if-invalid(function): Function to execute if the validator fails. 395 | - color: Prompt color 396 | - error-color: Prompt error color. 397 | - complete: If T, then uses path completion. Default: T. 398 | - probe. If T, checks that the file exists on the filesystem. 399 | - if-exists: Function to call if the probe is successful. 400 | - if-does-not-exist(keyword): One of: 401 | * :error : Tries again until the pathname can be accessed. 402 | * :warn : Warns the user the pathname could not be accessed and asks for continuing. 403 | * :warn-and-continue: Warns the user the pathname could not be accessed and continues." 404 | (flet ((recurse () 405 | (return-from prompt-pathname 406 | (prompt-pathname msg :default default 407 | :required-p required-p 408 | :if-invalid if-invalid 409 | :color color 410 | :error-color error-color 411 | :probe probe 412 | :if-exists if-exists 413 | :if-does-not-exist if-does-not-exist 414 | :absolute-p absolute-p 415 | :file-type file-type 416 | :complete complete)))) 417 | (flet ((read-input () 418 | (cond 419 | (complete 420 | (let ((prompt (if color 421 | (with-output-to-string (s) 422 | (cl-ansi-text:with-color (color :stream s) 423 | (format s "~@[~A~]~@[[~A]~]" msg default))) 424 | (format nil "~@[~A~]~@[[~A]~]" msg default)))) 425 | (complete-prompt prompt nil nil))) 426 | ((not complete) 427 | (when msg 428 | (say msg :color color)) 429 | (when default 430 | (say "[~A] " default :color color)) 431 | (duologue-read-line))))) 432 | (let ((pathname 433 | (loop do 434 | (let* ((input (read-input)) 435 | (parsed-input (ignore-errors (funcall #'pathname input)))) 436 | (cond ((and (string-equal input "") default) 437 | (return default)) 438 | ((and (string-equal input "") required-p) 439 | (say "A non empty value is required" :color error-color)) 440 | ((and (string-equal input "") (not required-p)) 441 | (return nil)) 442 | ((not parsed-input) 443 | (if if-invalid 444 | (funcall (parse-if-invalid if-invalid error-color)) 445 | (say "Invalid value" :color error-color))) 446 | (parsed-input 447 | (return parsed-input))))))) 448 | (when probe 449 | (if (probe-file pathname) 450 | (when if-exists 451 | (funcall if-exists)) 452 | ;; else 453 | (ecase if-does-not-exist 454 | (:error 455 | (say "The pathname does not exist." :color error-color) 456 | (recurse)) 457 | (:warn 458 | (say "The pathname does not exist." :color error-color) 459 | (when (not (ask "Continue?:" :default nil)) 460 | (recurse))) 461 | (:warn-and-continue 462 | (say "The pathname does not exist." :color error-color)) 463 | ))) 464 | pathname)))) 465 | 466 | (defun prompt-datetime (msg &key default 467 | (required-p t) 468 | if-invalid 469 | (color *prompt-color*) 470 | (error-color *prompt-error-color*)) 471 | "Prompts for a timestamp. 472 | 473 | Args: - msg: The prompt. 474 | - default: Default value. This is returned if the user enters the empty string. Default: nil. 475 | - required-p(boolean): If T, then the empty string is not allowed as a valid input, and the user is asked again for input. Default: t. 476 | - if-invalid(function): Function to execute if the validator fails. 477 | - color: Prompt color 478 | - error-color: Prompt error color. 479 | 480 | Returns: the parsed local-time 481 | 482 | The input is parsed with chronicity library and transformed to a local-time. 483 | The input is validated and the process does not stop until the user enters a valid timestamp address." 484 | 485 | (prompt msg 486 | :parser #'chronicity:parse 487 | :default default 488 | :required-p required-p 489 | :if-invalid (or (parse-if-invalid if-invalid error-color) 490 | (lambda () (say "Error. Invalid timestamp" 491 | :color error-color))) 492 | :color color 493 | :error-color error-color)) 494 | 495 | (defun choose-many (msg options &key if-wrong-option 496 | default 497 | (print-options t) 498 | (separator "~%") 499 | complete 500 | completer 501 | (test #'eql) 502 | (color *prompt-color*) 503 | (error-color *prompt-error-color*)) 504 | "Asks the user to choose many of the given options. 505 | 506 | Args: - msg(string): The prompt message. 507 | - options(list): The list of options the user can choose from. 508 | - if-wrong-option(function): When present, this function is run if the user enters a wrong option. Default: nil. 509 | - default: The default value. The default value is selected if the user just hits the ENTER key. Default: nil. 510 | - print-options(boolean): Print the options on the screen. Default: T. 511 | - separator(string): Separation string to use when printing the options. Default: '~%' 512 | - complete: If T, then completion is enabled. Default: nil. 513 | - completer: A custom completer. If NIL, then the default completer is used. 514 | - color: Color to use at prompt. Default: *prompt-color* 515 | - error-color: Color to use when error ocurrs. Default: *prompt-error-color* 516 | 517 | Example: 518 | 519 | ``(choose-many \"Choose: \" (list \"foo\" \"bar\" \"baz\") :default '(\"baz\"))`` 520 | 521 | Tags: menu, choose" 522 | (assert (every (lambda (option) (member option options :test 'string=)) default) 523 | nil "Invalid default: ~s" default) 524 | (let ((chosen-options nil)) 525 | (flet ((print-options () 526 | (loop 527 | for option in options 528 | for i from 0 529 | do 530 | (format *query-io* "[~A] ~A" i option) 531 | (when (< (1+ i) (length options)) 532 | (format *query-io* separator))) 533 | (terpri) 534 | (say "Chosen options: ~{~A~^, ~}" (reverse chosen-options))) 535 | (read-option () 536 | (cond 537 | ((or complete completer) 538 | (let ((prompt (if color 539 | (with-output-to-string (s) 540 | (cl-ansi-text:with-color (color :stream s) 541 | (format s "~A~@[[~A]~]" msg default))) 542 | (format nil "~A~@[[~A]~]" msg default)))) 543 | (complete-prompt prompt options completer))) 544 | (t 545 | (say msg :color color) 546 | (when default 547 | (say "[~A] " default :color color)) 548 | (string-trim (list #\ ) (duologue-read-line)))))) 549 | (when print-options 550 | (print-options)) 551 | (let* ((chosen-option (read-option)) 552 | (option-number (ignore-errors (parse-integer chosen-option)))) 553 | (loop 554 | do 555 | (cond ((equalp chosen-option "") 556 | (if chosen-options 557 | (return (reverse chosen-options)) 558 | (return default))) 559 | ((find chosen-option (mapcar #'princ-to-string options) :test #'string=) 560 | (pushnew (find chosen-option (mapcar #'princ-to-string options) :test #'string=) chosen-options :test test) 561 | (when print-options 562 | (print-options))) 563 | ((and option-number 564 | (>= option-number 0) 565 | (< option-number (length options))) 566 | ;; Correct option 567 | (pushnew (nth option-number options) chosen-options :test test) 568 | (when print-options 569 | (print-options))) 570 | (t 571 | ;; Incorrect option 572 | (progn 573 | (if if-wrong-option 574 | (funcall if-wrong-option) 575 | (say "Wrong option." :color error-color)) 576 | (when print-options 577 | (print-options))))) 578 | (setf chosen-option (read-option)) 579 | (setf option-number (ignore-errors (parse-integer chosen-option)))))))) 580 | 581 | (defmacro while (msg (&rest options) &body body) 582 | "Asks to repeat a task several times and collects its result. 583 | 584 | Args: - msg: The thing to ask to confirm the task 585 | - options: Options of the ask operation 586 | - body: The task to execute while the user confirms it. 587 | 588 | Returns: A list of collected task results 589 | 590 | Example: 591 | ``(while \"Add item?: \" (:default t) 592 | (prompt \"Item: \"))`` 593 | 594 | Tags: flow" 595 | 596 | (alexandria:with-unique-names (result while) 597 | `(block ,while 598 | (let ((,result nil)) 599 | (flet ((cancel () 600 | (return-from ,while nil)) 601 | (continue* () 602 | (return-from ,while ,result))) 603 | (loop 604 | :while (ask ,msg ,@options) 605 | :do (setf ,result (append ,result (list (progn ,@body))))) 606 | ,result))))) 607 | --------------------------------------------------------------------------------