Line data Source code
1 : ;;; subr-x.el --- extra Lisp functions -*- lexical-binding:t -*-
2 :
3 : ;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
4 :
5 : ;; Maintainer: emacs-devel@gnu.org
6 : ;; Keywords: convenience
7 : ;; Package: emacs
8 :
9 : ;; This file is part of GNU Emacs.
10 :
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.
15 :
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.
20 :
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/>.
23 :
24 : ;;; Commentary:
25 :
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
28 : ;; in subr.el.
29 :
30 : ;; Do not document these functions in the lispref.
31 : ;; http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg01006.html
32 :
33 : ;; NB If you want to use this library, it's almost always correct to use:
34 : ;; (eval-when-compile (require 'subr-x))
35 :
36 : ;;; Code:
37 :
38 : (eval-when-compile (require 'cl-lib))
39 :
40 :
41 : (defmacro internal--thread-argument (first? &rest forms)
42 : "Internal implementation for `thread-first' and `thread-last'.
43 : When Argument FIRST? is non-nil argument is threaded first, else
44 : last. FORMS are the expressions to be threaded."
45 4 : (pcase forms
46 : (`(,x (,f . ,args) . ,rest)
47 1 : `(internal--thread-argument
48 1 : ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest))
49 2 : (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest))
50 4 : (_ (car forms))))
51 :
52 : (defmacro thread-first (&rest forms)
53 : "Thread FORMS elements as the first argument of their successor.
54 : Example:
55 : (thread-first
56 : 5
57 : (+ 20)
58 : (/ 25)
59 : -
60 : (+ 40))
61 : Is equivalent to:
62 : (+ (- (/ (+ 5 20) 25)) 40)
63 : Note how the single `-' got converted into a list before
64 : threading."
65 : (declare (indent 1)
66 : (debug (form &rest [&or symbolp (sexp &rest form)])))
67 1 : `(internal--thread-argument t ,@forms))
68 :
69 : (defmacro thread-last (&rest forms)
70 : "Thread FORMS elements as the last argument of their successor.
71 : Example:
72 : (thread-last
73 : 5
74 : (+ 20)
75 : (/ 25)
76 : -
77 : (+ 40))
78 : Is equivalent to:
79 : (+ 40 (- (/ 25 (+ 20 5))))
80 : Note how the single `-' got converted into a list before
81 : threading."
82 : (declare (indent 1) (debug thread-first))
83 0 : `(internal--thread-argument nil ,@forms))
84 :
85 : (defsubst internal--listify (elt)
86 : "Wrap ELT in a list if it is not one."
87 6 : (if (not (listp elt))
88 0 : (list elt)
89 6 : elt))
90 :
91 : (defsubst internal--check-binding (binding)
92 : "Check BINDING is properly formed."
93 5 : (when (> (length binding) 2)
94 0 : (signal
95 : 'error
96 5 : (cons "`let' bindings can have only one value-form" binding)))
97 5 : binding)
98 :
99 : (defsubst internal--build-binding-value-form (binding prev-var)
100 : "Build the conditional value form for BINDING using PREV-VAR."
101 5 : `(,(car binding) (and ,prev-var ,(cadr binding))))
102 :
103 : (defun internal--build-binding (binding prev-var)
104 : "Check and build a single BINDING with PREV-VAR."
105 5 : (thread-first
106 5 : binding
107 : internal--listify
108 : internal--check-binding
109 5 : (internal--build-binding-value-form prev-var)))
110 :
111 : (defun internal--build-bindings (bindings)
112 : "Check and build conditional value forms for BINDINGS."
113 1 : (let ((prev-var t))
114 1 : (mapcar (lambda (binding)
115 5 : (let ((binding (internal--build-binding binding prev-var)))
116 5 : (setq prev-var (car binding))
117 5 : binding))
118 1 : bindings)))
119 :
120 : (defmacro if-let* (bindings then &rest else)
121 : "Bind variables according to VARLIST and eval THEN or ELSE.
122 : Each binding is evaluated in turn with `let*', and evaluation
123 : stops if a binding value is nil. If all are non-nil, the value
124 : of THEN is returned, or the last form in ELSE is returned.
125 : Each element of VARLIST is a symbol (which is bound to nil)
126 : or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
127 : In the special case you only want to bind a single value,
128 : VARLIST can just be a plain tuple.
129 : \n(fn VARLIST THEN ELSE...)"
130 : (declare (indent 2)
131 : (debug ([&or (&rest [&or symbolp (symbolp form)]) (symbolp form)]
132 : form body)))
133 1 : (when (and (<= (length bindings) 2)
134 1 : (not (listp (car bindings))))
135 : ;; Adjust the single binding case
136 1 : (setq bindings (list bindings)))
137 1 : `(let* ,(internal--build-bindings bindings)
138 1 : (if ,(car (internal--listify (car (last bindings))))
139 1 : ,then
140 1 : ,@else)))
141 :
142 : (defmacro when-let* (bindings &rest body)
143 : "Bind variables according to VARLIST and conditionally eval BODY.
144 : Each binding is evaluated in turn with `let*', and evaluation
145 : stops if a binding value is nil. If all are non-nil, the value
146 : of the last form in BODY is returned.
147 : Each element of VARLIST is a symbol (which is bound to nil)
148 : or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
149 : In the special case you only want to bind a single value,
150 : VARLIST can just be a plain tuple.
151 : \n(fn VARLIST BODY...)"
152 : (declare (indent 1) (debug if-let))
153 1 : (list 'if-let bindings (macroexp-progn body)))
154 :
155 : (defalias 'if-let 'if-let*)
156 : (defalias 'when-let 'when-let*)
157 : (defalias 'and-let* 'when-let*)
158 :
159 : (defsubst hash-table-empty-p (hash-table)
160 : "Check whether HASH-TABLE is empty (has 0 elements)."
161 0 : (zerop (hash-table-count hash-table)))
162 :
163 : (defsubst hash-table-keys (hash-table)
164 : "Return a list of keys in HASH-TABLE."
165 0 : (cl-loop for k being the hash-keys of hash-table collect k))
166 :
167 : (defsubst hash-table-values (hash-table)
168 : "Return a list of values in HASH-TABLE."
169 0 : (cl-loop for v being the hash-values of hash-table collect v))
170 :
171 : (defsubst string-empty-p (string)
172 : "Check whether STRING is empty."
173 0 : (string= string ""))
174 :
175 : (defsubst string-join (strings &optional separator)
176 : "Join all STRINGS using SEPARATOR."
177 0 : (mapconcat 'identity strings separator))
178 :
179 : (define-obsolete-function-alias 'string-reverse 'reverse "25.1")
180 :
181 : (defsubst string-trim-left (string &optional regexp)
182 : "Trim STRING of leading string matching REGEXP.
183 :
184 : REGEXP defaults to \"[ \\t\\n\\r]+\"."
185 0 : (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+")"\\)") string)
186 0 : (replace-match "" t t string)
187 0 : string))
188 :
189 : (defsubst string-trim-right (string &optional regexp)
190 : "Trim STRING of trailing string matching REGEXP.
191 :
192 : REGEXP defaults to \"[ \\t\\n\\r]+\"."
193 0 : (if (string-match (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string)
194 0 : (replace-match "" t t string)
195 0 : string))
196 :
197 : (defsubst string-trim (string &optional trim-left trim-right)
198 : "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
199 :
200 : TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
201 0 : (string-trim-left (string-trim-right string trim-right) trim-left))
202 :
203 : (defsubst string-blank-p (string)
204 : "Check whether STRING is either empty or only whitespace."
205 0 : (string-match-p "\\`[ \t\n\r]*\\'" string))
206 :
207 : (defsubst string-remove-prefix (prefix string)
208 : "Remove PREFIX from STRING if present."
209 0 : (if (string-prefix-p prefix string)
210 0 : (substring string (length prefix))
211 0 : string))
212 :
213 : (defsubst string-remove-suffix (suffix string)
214 : "Remove SUFFIX from STRING if present."
215 0 : (if (string-suffix-p suffix string)
216 0 : (substring string 0 (- (length string) (length suffix)))
217 0 : string))
218 :
219 : (defun read-multiple-choice (prompt choices)
220 : "Ask user a multiple choice question.
221 : PROMPT should be a string that will be displayed as the prompt.
222 :
223 : CHOICES is an alist where the first element in each entry is a
224 : character to be entered, the second element is a short name for
225 : the entry to be displayed while prompting (if there's room, it
226 : might be shortened), and the third, optional entry is a longer
227 : explanation that will be displayed in a help buffer if the user
228 : requests more help.
229 :
230 : This function translates user input into responses by consulting
231 : the bindings in `query-replace-map'; see the documentation of
232 : that variable for more information. In this case, the useful
233 : bindings are `recenter', `scroll-up', and `scroll-down'. If the
234 : user enters `recenter', `scroll-up', or `scroll-down' responses,
235 : perform the requested window recentering or scrolling and ask
236 : again.
237 :
238 : When `use-dialog-box' is t (the default), this function can pop
239 : up a dialog window to collect the user input. That functionality
240 : requires `display-popup-menus-p' to return t. Otherwise, a text
241 : dialog will be used.
242 :
243 : The return value is the matching entry from the CHOICES list.
244 :
245 : Usage example:
246 :
247 : \(read-multiple-choice \"Continue connecting?\"
248 : \\='((?a \"always\")
249 : (?s \"session only\")
250 : (?n \"no\")))"
251 0 : (let* ((altered-names nil)
252 : (full-prompt
253 0 : (format
254 : "%s (%s): "
255 0 : prompt
256 0 : (mapconcat
257 : (lambda (elem)
258 0 : (let* ((name (cadr elem))
259 0 : (pos (seq-position name (car elem)))
260 : (altered-name
261 0 : (cond
262 : ;; Not in the name string.
263 0 : ((not pos)
264 0 : (format "[%c] %s" (car elem) name))
265 : ;; The prompt character is in the name, so highlight
266 : ;; it on graphical terminals...
267 0 : ((display-supports-face-attributes-p
268 0 : '(:underline t) (window-frame))
269 0 : (setq name (copy-sequence name))
270 0 : (put-text-property pos (1+ pos)
271 : 'face 'read-multiple-choice-face
272 0 : name)
273 0 : name)
274 : ;; And put it in [bracket] on non-graphical terminals.
275 : (t
276 0 : (concat
277 0 : (substring name 0 pos)
278 : "["
279 0 : (upcase (substring name pos (1+ pos)))
280 : "]"
281 0 : (substring name (1+ pos)))))))
282 0 : (push (cons (car elem) altered-name)
283 0 : altered-names)
284 0 : altered-name))
285 0 : (append choices '((?? "?")))
286 0 : ", ")))
287 : tchar buf wrong-char answer)
288 0 : (save-window-excursion
289 0 : (save-excursion
290 0 : (while (not tchar)
291 0 : (message "%s%s"
292 0 : (if wrong-char
293 : "Invalid choice. "
294 0 : "")
295 0 : full-prompt)
296 0 : (setq tchar
297 0 : (if (and (display-popup-menus-p)
298 0 : last-input-event ; not during startup
299 0 : (listp last-nonmenu-event)
300 0 : use-dialog-box)
301 0 : (x-popup-dialog
302 : t
303 0 : (cons prompt
304 0 : (mapcar
305 : (lambda (elem)
306 0 : (cons (capitalize (cadr elem))
307 0 : (car elem)))
308 0 : choices)))
309 0 : (condition-case nil
310 0 : (let ((cursor-in-echo-area t))
311 0 : (read-char))
312 0 : (error nil))))
313 0 : (setq answer (lookup-key query-replace-map (vector tchar) t))
314 0 : (setq tchar
315 0 : (cond
316 0 : ((eq answer 'recenter)
317 0 : (recenter) t)
318 0 : ((eq answer 'scroll-up)
319 0 : (ignore-errors (scroll-up-command)) t)
320 0 : ((eq answer 'scroll-down)
321 0 : (ignore-errors (scroll-down-command)) t)
322 0 : ((eq answer 'scroll-other-window)
323 0 : (ignore-errors (scroll-other-window)) t)
324 0 : ((eq answer 'scroll-other-window-down)
325 0 : (ignore-errors (scroll-other-window-down)) t)
326 0 : (t tchar)))
327 0 : (when (eq tchar t)
328 0 : (setq wrong-char nil
329 0 : tchar nil))
330 : ;; The user has entered an invalid choice, so display the
331 : ;; help messages.
332 0 : (when (and (not (eq tchar nil))
333 0 : (not (assq tchar choices)))
334 0 : (setq wrong-char (not (memq tchar '(?? ?\C-h)))
335 0 : tchar nil)
336 0 : (when wrong-char
337 0 : (ding))
338 0 : (with-help-window (setq buf (get-buffer-create
339 0 : "*Multiple Choice Help*"))
340 0 : (with-current-buffer buf
341 0 : (erase-buffer)
342 0 : (pop-to-buffer buf)
343 0 : (insert prompt "\n\n")
344 0 : (let* ((columns (/ (window-width) 25))
345 : (fill-column 21)
346 : (times 0)
347 0 : (start (point)))
348 0 : (dolist (elem choices)
349 0 : (goto-char start)
350 0 : (unless (zerop times)
351 0 : (if (zerop (mod times columns))
352 : ;; Go to the next "line".
353 0 : (goto-char (setq start (point-max)))
354 : ;; Add padding.
355 0 : (while (not (eobp))
356 0 : (end-of-line)
357 0 : (insert (make-string (max (- (* (mod times columns)
358 0 : (+ fill-column 4))
359 0 : (current-column))
360 0 : 0)
361 0 : ?\s))
362 0 : (forward-line 1))))
363 0 : (setq times (1+ times))
364 0 : (let ((text
365 0 : (with-temp-buffer
366 0 : (insert (format
367 : "%c: %s\n"
368 0 : (car elem)
369 0 : (cdr (assq (car elem) altered-names))))
370 0 : (fill-region (point-min) (point-max))
371 0 : (when (nth 2 elem)
372 0 : (let ((start (point)))
373 0 : (insert (nth 2 elem))
374 0 : (unless (bolp)
375 0 : (insert "\n"))
376 0 : (fill-region start (point-max))))
377 0 : (buffer-string))))
378 0 : (goto-char start)
379 0 : (dolist (line (split-string text "\n"))
380 0 : (end-of-line)
381 0 : (if (bolp)
382 0 : (insert line "\n")
383 0 : (insert line))
384 0 : (forward-line 1)))))))))))
385 0 : (when (buffer-live-p buf)
386 0 : (kill-buffer buf))
387 0 : (assq tchar choices)))
388 :
389 : (provide 'subr-x)
390 :
391 : ;;; subr-x.el ends here
|