1 ;;; subr-x.el --- extra Lisp functions -*- lexical-binding:t -*-
3 ;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
5 ;; Maintainer: emacs-devel@gnu.org
6 ;; Keywords: convenience
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; Less commonly used functions that complement basic APIs, often implemented in
27 ;; C code (like hash-tables and strings), and are not eligible for inclusion
30 ;; Do not document these functions in the lispref.
31 ;; http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg01006.html
36 (eval-when-compile (require 'cl-lib
))
39 (defmacro internal--thread-argument
(first?
&rest forms
)
40 "Internal implementation for `thread-first' and `thread-last'.
41 When Argument FIRST? is non-nil argument is threaded first, else
42 last. FORMS are the expressions to be threaded."
44 (`(,x
(,f .
,args
) .
,rest
)
45 `(internal--thread-argument
46 ,first?
,(if first?
`(,f
,x
,@args
) `(,f
,@args
,x
)) ,@rest
))
47 (`(,x
,f .
,rest
) `(internal--thread-argument ,first?
(,f
,x
) ,@rest
))
50 (defmacro thread-first
(&rest forms
)
51 "Thread FORMS elements as the first argument of their successor.
60 (+ (- (/ (+ 5 20) 25)) 40)
61 Note how the single `-' got converted into a list before
64 (debug (form &rest
[&or symbolp
(sexp &rest form
)])))
65 `(internal--thread-argument t
,@forms
))
67 (defmacro thread-last
(&rest forms
)
68 "Thread FORMS elements as the last argument of their successor.
77 (+ 40 (- (/ 25 (+ 20 5))))
78 Note how the single `-' got converted into a list before
80 (declare (indent 1) (debug thread-first
))
81 `(internal--thread-argument nil
,@forms
))
83 (defsubst internal--listify
(elt)
84 "Wrap ELT in a list if it is not one."
89 (defsubst internal--check-binding
(binding)
90 "Check BINDING is properly formed."
91 (when (> (length binding
) 2)
94 (cons "`let' bindings can have only one value-form" binding
)))
97 (defsubst internal--build-binding-value-form
(binding prev-var
)
98 "Build the conditional value form for BINDING using PREV-VAR."
99 `(,(car binding
) (and ,prev-var
,(cadr binding
))))
101 (defun internal--build-binding (binding prev-var
)
102 "Check and build a single BINDING with PREV-VAR."
106 internal--check-binding
107 (internal--build-binding-value-form prev-var
)))
109 (defun internal--build-bindings (bindings)
110 "Check and build conditional value forms for BINDINGS."
112 (mapcar (lambda (binding)
113 (let ((binding (internal--build-binding binding prev-var
)))
114 (setq prev-var
(car binding
))
118 (defmacro if-let
* (bindings then
&rest else
)
119 "Bind variables according to VARLIST and eval THEN or ELSE.
120 Each binding is evaluated in turn with `let*', and evaluation
121 stops if a binding value is nil. If all are non-nil, the value
122 of THEN is returned, or the last form in ELSE is returned.
123 Each element of VARLIST is a symbol (which is bound to nil)
124 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
125 In the special case you only want to bind a single value,
126 VARLIST can just be a plain tuple.
127 \n(fn VARLIST THEN ELSE...)"
129 (debug ([&or
(&rest
(symbolp form
)) (symbolp form
)] form body
)))
130 (when (and (<= (length bindings
) 2)
131 (not (listp (car bindings
))))
132 ;; Adjust the single binding case
133 (setq bindings
(list bindings
)))
134 `(let* ,(internal--build-bindings bindings
)
135 (if ,(car (internal--listify (car (last bindings
))))
139 (defmacro when-let
* (bindings &rest body
)
140 "Bind variables according to VARLIST and conditionally eval BODY.
141 Each binding is evaluated in turn with `let*', and evaluation
142 stops if a binding value is nil. If all are non-nil, the value
143 of the last form in BODY is returned.
144 Each element of VARLIST is a symbol (which is bound to nil)
145 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
146 In the special case you only want to bind a single value,
147 VARLIST can just be a plain tuple.
148 \n(fn VARLIST BODY...)"
149 (declare (indent 1) (debug if-let
))
150 (list 'if-let bindings
(macroexp-progn body
)))
152 (defalias 'if-let
'if-let
*)
153 (defalias 'when-let
'when-let
*)
154 (defalias 'and-let
* 'when-let
*)
156 (defsubst hash-table-empty-p
(hash-table)
157 "Check whether HASH-TABLE is empty (has 0 elements)."
158 (zerop (hash-table-count hash-table
)))
160 (defsubst hash-table-keys
(hash-table)
161 "Return a list of keys in HASH-TABLE."
162 (cl-loop for k being the hash-keys of hash-table collect k
))
164 (defsubst hash-table-values
(hash-table)
165 "Return a list of values in HASH-TABLE."
166 (cl-loop for v being the hash-values of hash-table collect v
))
168 (defsubst string-empty-p
(string)
169 "Check whether STRING is empty."
172 (defsubst string-join
(strings &optional separator
)
173 "Join all STRINGS using SEPARATOR."
174 (mapconcat 'identity strings separator
))
176 (define-obsolete-function-alias 'string-reverse
'reverse
"25.1")
178 (defsubst string-trim-left
(string)
179 "Remove leading whitespace from STRING."
180 (if (string-match "\\`[ \t\n\r]+" string
)
181 (replace-match "" t t string
)
184 (defsubst string-trim-right
(string)
185 "Remove trailing whitespace from STRING."
186 (if (string-match "[ \t\n\r]+\\'" string
)
187 (replace-match "" t t string
)
190 (defsubst string-trim
(string)
191 "Remove leading and trailing whitespace from STRING."
192 (string-trim-left (string-trim-right string
)))
194 (defsubst string-blank-p
(string)
195 "Check whether STRING is either empty or only whitespace."
196 (string-match-p "\\`[ \t\n\r]*\\'" string
))
198 (defsubst string-remove-prefix
(prefix string
)
199 "Remove PREFIX from STRING if present."
200 (if (string-prefix-p prefix string
)
201 (substring string
(length prefix
))
204 (defsubst string-remove-suffix
(suffix string
)
205 "Remove SUFFIX from STRING if present."
206 (if (string-suffix-p suffix string
)
207 (substring string
0 (- (length string
) (length suffix
)))
210 (defun read-multiple-choice (prompt choices
)
211 "Ask user a multiple choice question.
212 PROMPT should be a string that will be displayed as the prompt.
214 CHOICES is an alist where the first element in each entry is a
215 character to be entered, the second element is a short name for
216 the entry to be displayed while prompting (if there's room, it
217 might be shortened), and the third, optional entry is a longer
218 explanation that will be displayed in a help buffer if the user
221 This function translates user input into responses by consulting
222 the bindings in `query-replace-map'; see the documentation of
223 that variable for more information. In this case, the useful
224 bindings are `recenter', `scroll-up', and `scroll-down'. If the
225 user enters `recenter', `scroll-up', or `scroll-down' responses,
226 perform the requested window recentering or scrolling and ask
229 When `use-dialog-box' is t (the default), this function can pop
230 up a dialog window to collect the user input. That functionality
231 requires `display-popup-menus-p' to return t. Otherwise, a text
234 The return value is the matching entry from the CHOICES list.
238 \(read-multiple-choice \"Continue connecting?\"
240 (?s \"session only\")
242 (let* ((altered-names nil
)
249 (let* ((name (cadr elem
))
250 (pos (seq-position name
(car elem
)))
253 ;; Not in the name string.
255 (format "[%c] %s" (car elem
) name
))
256 ;; The prompt character is in the name, so highlight
257 ;; it on graphical terminals...
258 ((display-supports-face-attributes-p
259 '(:underline t
) (window-frame))
260 (setq name
(copy-sequence name
))
261 (put-text-property pos
(1+ pos
)
262 'face
'read-multiple-choice-face
265 ;; And put it in [bracket] on non-graphical terminals.
268 (substring name
0 pos
)
270 (upcase (substring name pos
(1+ pos
)))
272 (substring name
(1+ pos
)))))))
273 (push (cons (car elem
) altered-name
)
276 (append choices
'((??
"?")))
278 tchar buf wrong-char answer
)
279 (save-window-excursion
288 (if (and (display-popup-menus-p)
289 last-input-event
; not during startup
290 (listp last-nonmenu-event
)
297 (cons (capitalize (cadr elem
))
301 (let ((cursor-in-echo-area t
))
304 (setq answer
(lookup-key query-replace-map
(vector tchar
) t
))
307 ((eq answer
'recenter
)
309 ((eq answer
'scroll-up
)
310 (ignore-errors (scroll-up-command)) t
)
311 ((eq answer
'scroll-down
)
312 (ignore-errors (scroll-down-command)) t
)
313 ((eq answer
'scroll-other-window
)
314 (ignore-errors (scroll-other-window)) t
)
315 ((eq answer
'scroll-other-window-down
)
316 (ignore-errors (scroll-other-window-down)) t
)
321 ;; The user has entered an invalid choice, so display the
323 (when (and (not (eq tchar nil
))
324 (not (assq tchar choices
)))
325 (setq wrong-char
(not (memq tchar
'(?? ?\C-h
)))
329 (with-help-window (setq buf
(get-buffer-create
330 "*Multiple Choice Help*"))
331 (with-current-buffer buf
334 (insert prompt
"\n\n")
335 (let* ((columns (/ (window-width) 25))
339 (dolist (elem choices
)
341 (unless (zerop times
)
342 (if (zerop (mod times columns
))
343 ;; Go to the next "line".
344 (goto-char (setq start
(point-max)))
348 (insert (make-string (max (- (* (mod times columns
)
354 (setq times
(1+ times
))
360 (cdr (assq (car elem
) altered-names
))))
361 (fill-region (point-min) (point-max))
363 (let ((start (point)))
364 (insert (nth 2 elem
))
367 (fill-region start
(point-max))))
370 (dolist (line (split-string text
"\n"))
375 (forward-line 1)))))))))))
376 (when (buffer-live-p buf
)
378 (assq tchar choices
)))
382 ;;; subr-x.el ends here