summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp/subr-x.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp/subr-x.el')
-rw-r--r--lisp/emacs-lisp/subr-x.el281
1 files changed, 71 insertions, 210 deletions
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 849ac19d6a5..37bcfc2003d 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -19,7 +19,7 @@
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -28,7 +28,7 @@
;; in subr.el.
;; Do not document these functions in the lispref.
-;; http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg01006.html
+;; https://lists.gnu.org/r/emacs-devel/2014-01/msg01006.html
;; NB If you want to use this library, it's almost always correct to use:
;; (eval-when-compile (require 'subr-x))
@@ -83,10 +83,13 @@ threading."
`(internal--thread-argument nil ,@forms))
(defsubst internal--listify (elt)
- "Wrap ELT in a list if it is not one."
- (if (not (listp elt))
- (list elt)
- elt))
+ "Wrap ELT in a list if it is not one.
+If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol."
+ (cond
+ ((symbolp elt) (list elt elt))
+ ((null (cdr elt))
+ (list (make-symbol "s") (car elt)))
+ (t elt)))
(defsubst internal--check-binding (binding)
"Check BINDING is properly formed."
@@ -98,7 +101,8 @@ threading."
(defsubst internal--build-binding-value-form (binding prev-var)
"Build the conditional value form for BINDING using PREV-VAR."
- `(,(car binding) (and ,prev-var ,(cadr binding))))
+ (let ((var (car binding)))
+ `(,var (and ,prev-var ,(cadr binding)))))
(defun internal--build-binding (binding prev-var)
"Check and build a single BINDING with PREV-VAR."
@@ -117,44 +121,71 @@ threading."
binding))
bindings)))
-(defmacro if-let* (bindings then &rest else)
+(defmacro if-let* (varlist then &rest else)
"Bind variables according to VARLIST and eval THEN or ELSE.
-Each binding is evaluated in turn with `let*', and evaluation
-stops if a binding value is nil. If all are non-nil, the value
-of THEN is returned, or the last form in ELSE is returned.
-Each element of VARLIST is a symbol (which is bound to nil)
-or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
-In the special case you only want to bind a single value,
-VARLIST can just be a plain tuple.
-\n(fn VARLIST THEN ELSE...)"
+Each binding is evaluated in turn, and evaluation stops if a
+binding value is nil. If all are non-nil, the value of THEN is
+returned, or the last form in ELSE is returned.
+
+Each element of VARLIST is a list (SYMBOL VALUEFORM) which binds
+SYMBOL to the value of VALUEFORM. An element can additionally
+be of the form (VALUEFORM), which is evaluated and checked for
+nil; i.e. SYMBOL can be omitted if only the test result is of
+interest."
(declare (indent 2)
- (debug ([&or (&rest [&or symbolp (symbolp form)]) (symbolp form)]
+ (debug ((&rest [&or symbolp (symbolp form) (form)])
form body)))
- (when (and (<= (length bindings) 2)
- (not (listp (car bindings))))
- ;; Adjust the single binding case
- (setq bindings (list bindings)))
- `(let* ,(internal--build-bindings bindings)
- (if ,(car (internal--listify (car (last bindings))))
- ,then
- ,@else)))
+ (if varlist
+ `(let* ,(setq varlist (internal--build-bindings varlist))
+ (if ,(caar (last varlist))
+ ,then
+ ,@else))
+ `(let* () ,then)))
+
+(defmacro when-let* (varlist &rest body)
+ "Bind variables according to VARLIST and conditionally eval BODY.
+Each binding is evaluated in turn, and evaluation stops if a
+binding value is nil. If all are non-nil, the value of the last
+form in BODY is returned.
-(defmacro when-let* (bindings &rest body)
+VARLIST is the same as in `if-let*'."
+ (declare (indent 1) (debug if-let*))
+ (list 'if-let* varlist (macroexp-progn body)))
+
+(defmacro and-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally eval BODY.
-Each binding is evaluated in turn with `let*', and evaluation
-stops if a binding value is nil. If all are non-nil, the value
-of the last form in BODY is returned.
-Each element of VARLIST is a symbol (which is bound to nil)
-or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
-In the special case you only want to bind a single value,
-VARLIST can just be a plain tuple.
-\n(fn VARLIST BODY...)"
- (declare (indent 1) (debug if-let))
- (list 'if-let bindings (macroexp-progn body)))
-
-(defalias 'if-let 'if-let*)
-(defalias 'when-let 'when-let*)
-(defalias 'and-let* 'when-let*)
+Like `when-let*', except if BODY is empty and all the bindings
+are non-nil, then the result is non-nil."
+ (declare (indent 1)
+ (debug ((&rest [&or symbolp (symbolp form) (form)])
+ body)))
+ (let (res)
+ (if varlist
+ `(let* ,(setq varlist (internal--build-bindings varlist))
+ (if ,(setq res (caar (last varlist)))
+ ,@(or body `(,res))))
+ `(let* () ,@(or body '(t))))))
+
+(defmacro if-let (spec then &rest else)
+ "Bind variables according to SPEC and eval THEN or ELSE.
+Like `if-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
+ (declare (indent 2)
+ (debug ([&or (&rest [&or symbolp (symbolp form) (form)])
+ (symbolp form)]
+ form body))
+ (obsolete "use `if-let*' instead." "26.1"))
+ (when (and (<= (length spec) 2)
+ (not (listp (car spec))))
+ ;; Adjust the single binding case
+ (setq spec (list spec)))
+ (list 'if-let* spec then (macroexp-progn else)))
+
+(defmacro when-let (spec &rest body)
+ "Bind variables according to SPEC and conditionally eval BODY.
+Like `when-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
+ (declare (indent 1) (debug if-let)
+ (obsolete "use `when-let*' instead." "26.1"))
+ (list 'if-let spec (macroexp-progn body)))
(defsubst hash-table-empty-p (hash-table)
"Check whether HASH-TABLE is empty (has 0 elements)."
@@ -216,176 +247,6 @@ TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
(substring string 0 (- (length string) (length suffix)))
string))
-(defun read-multiple-choice (prompt choices)
- "Ask user a multiple choice question.
-PROMPT should be a string that will be displayed as the prompt.
-
-CHOICES is an alist where the first element in each entry is a
-character to be entered, the second element is a short name for
-the entry to be displayed while prompting (if there's room, it
-might be shortened), and the third, optional entry is a longer
-explanation that will be displayed in a help buffer if the user
-requests more help.
-
-This function translates user input into responses by consulting
-the bindings in `query-replace-map'; see the documentation of
-that variable for more information. In this case, the useful
-bindings are `recenter', `scroll-up', and `scroll-down'. If the
-user enters `recenter', `scroll-up', or `scroll-down' responses,
-perform the requested window recentering or scrolling and ask
-again.
-
-When `use-dialog-box' is t (the default), this function can pop
-up a dialog window to collect the user input. That functionality
-requires `display-popup-menus-p' to return t. Otherwise, a text
-dialog will be used.
-
-The return value is the matching entry from the CHOICES list.
-
-Usage example:
-
-\(read-multiple-choice \"Continue connecting?\"
- \\='((?a \"always\")
- (?s \"session only\")
- (?n \"no\")))"
- (let* ((altered-names nil)
- (full-prompt
- (format
- "%s (%s): "
- prompt
- (mapconcat
- (lambda (elem)
- (let* ((name (cadr elem))
- (pos (seq-position name (car elem)))
- (altered-name
- (cond
- ;; Not in the name string.
- ((not pos)
- (format "[%c] %s" (car elem) name))
- ;; The prompt character is in the name, so highlight
- ;; it on graphical terminals...
- ((display-supports-face-attributes-p
- '(:underline t) (window-frame))
- (setq name (copy-sequence name))
- (put-text-property pos (1+ pos)
- 'face 'read-multiple-choice-face
- name)
- name)
- ;; And put it in [bracket] on non-graphical terminals.
- (t
- (concat
- (substring name 0 pos)
- "["
- (upcase (substring name pos (1+ pos)))
- "]"
- (substring name (1+ pos)))))))
- (push (cons (car elem) altered-name)
- altered-names)
- altered-name))
- (append choices '((?? "?")))
- ", ")))
- tchar buf wrong-char answer)
- (save-window-excursion
- (save-excursion
- (while (not tchar)
- (message "%s%s"
- (if wrong-char
- "Invalid choice. "
- "")
- full-prompt)
- (setq tchar
- (if (and (display-popup-menus-p)
- last-input-event ; not during startup
- (listp last-nonmenu-event)
- use-dialog-box)
- (x-popup-dialog
- t
- (cons prompt
- (mapcar
- (lambda (elem)
- (cons (capitalize (cadr elem))
- (car elem)))
- choices)))
- (condition-case nil
- (let ((cursor-in-echo-area t))
- (read-char))
- (error nil))))
- (setq answer (lookup-key query-replace-map (vector tchar) t))
- (setq tchar
- (cond
- ((eq answer 'recenter)
- (recenter) t)
- ((eq answer 'scroll-up)
- (ignore-errors (scroll-up-command)) t)
- ((eq answer 'scroll-down)
- (ignore-errors (scroll-down-command)) t)
- ((eq answer 'scroll-other-window)
- (ignore-errors (scroll-other-window)) t)
- ((eq answer 'scroll-other-window-down)
- (ignore-errors (scroll-other-window-down)) t)
- (t tchar)))
- (when (eq tchar t)
- (setq wrong-char nil
- tchar nil))
- ;; The user has entered an invalid choice, so display the
- ;; help messages.
- (when (and (not (eq tchar nil))
- (not (assq tchar choices)))
- (setq wrong-char (not (memq tchar '(?? ?\C-h)))
- tchar nil)
- (when wrong-char
- (ding))
- (with-help-window (setq buf (get-buffer-create
- "*Multiple Choice Help*"))
- (with-current-buffer buf
- (erase-buffer)
- (pop-to-buffer buf)
- (insert prompt "\n\n")
- (let* ((columns (/ (window-width) 25))
- (fill-column 21)
- (times 0)
- (start (point)))
- (dolist (elem choices)
- (goto-char start)
- (unless (zerop times)
- (if (zerop (mod times columns))
- ;; Go to the next "line".
- (goto-char (setq start (point-max)))
- ;; Add padding.
- (while (not (eobp))
- (end-of-line)
- (insert (make-string (max (- (* (mod times columns)
- (+ fill-column 4))
- (current-column))
- 0)
- ?\s))
- (forward-line 1))))
- (setq times (1+ times))
- (let ((text
- (with-temp-buffer
- (insert (format
- "%c: %s\n"
- (car elem)
- (cdr (assq (car elem) altered-names))))
- (fill-region (point-min) (point-max))
- (when (nth 2 elem)
- (let ((start (point)))
- (insert (nth 2 elem))
- (unless (bolp)
- (insert "\n"))
- (fill-region start (point-max))))
- (buffer-string))))
- (goto-char start)
- (dolist (line (split-string text "\n"))
- (end-of-line)
- (if (bolp)
- (insert line "\n")
- (insert line))
- (forward-line 1)))))))))))
- (when (buffer-live-p buf)
- (kill-buffer buf))
- (assq tchar choices)))
-
(provide 'subr-x)
;;; subr-x.el ends here