Commit | Line | Data |
---|---|---|
132e74fe | 1 | ;;; guix-utils.el --- General utility functions -*- lexical-binding: t -*- |
457f60fa | 2 | |
6ea80938 | 3 | ;; Copyright © 2014, 2015, 2016 Alex Kost <alezost@gmail.com> |
457f60fa AK |
4 | |
5 | ;; This file is part of GNU Guix. | |
6 | ||
7 | ;; GNU Guix is free software; you can redistribute it and/or modify | |
8 | ;; it under the terms of the GNU General Public License as published by | |
9 | ;; the Free Software Foundation, either version 3 of the License, or | |
10 | ;; (at your option) any later version. | |
11 | ||
12 | ;; GNU Guix is distributed in the hope that it will be useful, | |
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;; GNU General Public License for more details. | |
16 | ||
17 | ;; You should have received a copy of the GNU General Public License | |
18 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;; Commentary: | |
21 | ||
22 | ;; This file provides auxiliary general functions for guix.el package. | |
23 | ||
24 | ;;; Code: | |
25 | ||
2e269860 | 26 | (require 'cl-lib) |
457f60fa AK |
27 | |
28 | (defvar guix-true-string "Yes") | |
29 | (defvar guix-false-string "–") | |
30 | (defvar guix-list-separator ", ") | |
31 | ||
32 | (defvar guix-time-format "%F %T" | |
33 | "String used to format time values. | |
34 | For possible formats, see `format-time-string'.") | |
35 | ||
36 | (defun guix-get-string (val &optional face) | |
37 | "Convert VAL into a string and return it. | |
38 | ||
39 | VAL can be an expression of any type. | |
40 | If VAL is t/nil, it is replaced with | |
41 | `guix-true-string'/`guix-false-string'. | |
42 | If VAL is list, its elements are concatenated using | |
43 | `guix-list-separator'. | |
44 | ||
45 | If FACE is non-nil, propertize returned string with this FACE." | |
46 | (let ((str (cond | |
47 | ((stringp val) val) | |
48 | ((null val) guix-false-string) | |
49 | ((eq t val) guix-true-string) | |
50 | ((numberp val) (number-to-string val)) | |
51 | ((listp val) (mapconcat #'guix-get-string | |
52 | val guix-list-separator)) | |
53 | (t (prin1-to-string val))))) | |
54 | (if (and val face) | |
2e269860 | 55 | (propertize str 'font-lock-face face) |
457f60fa AK |
56 | str))) |
57 | ||
58 | (defun guix-get-time-string (seconds) | |
59 | "Return formatted time string from SECONDS. | |
60 | Use `guix-time-format'." | |
61 | (format-time-string guix-time-format (seconds-to-time seconds))) | |
62 | ||
63 | (defun guix-get-one-line (str) | |
64 | "Return one-line string from a multi-line STR." | |
65 | (replace-regexp-in-string "\n" " " str)) | |
66 | ||
36c00c61 AK |
67 | (defmacro guix-with-indent (indent &rest body) |
68 | "Evaluate BODY and indent inserted text by INDENT number of spaces." | |
69 | (declare (indent 1) (debug t)) | |
70 | (let ((region-beg-var (make-symbol "region-beg")) | |
71 | (indent-var (make-symbol "indent"))) | |
72 | `(let ((,region-beg-var (point)) | |
73 | (,indent-var ,indent)) | |
74 | ,@body | |
75 | (unless (zerop ,indent-var) | |
76 | (indent-rigidly ,region-beg-var (point) ,indent-var))))) | |
77 | ||
457f60fa AK |
78 | (defun guix-format-insert (val &optional face format) |
79 | "Convert VAL into a string and insert it at point. | |
80 | If FACE is non-nil, propertize VAL with FACE. | |
81 | If FORMAT is non-nil, format VAL with FORMAT." | |
82 | (let ((str (guix-get-string val face))) | |
83 | (insert (if format | |
84 | (format format str) | |
85 | str)))) | |
86 | ||
65e5fe54 | 87 | (cl-defun guix-mapinsert (function sequence separator &key indent column) |
457f60fa AK |
88 | "Like `mapconcat' but for inserting text. |
89 | Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR | |
65e5fe54 AK |
90 | at point between each FUNCTION call. |
91 | ||
92 | If INDENT is non-nil, it should be a number of spaces used to | |
93 | indent each line of the inserted text. | |
94 | ||
95 | If COLUMN is non-nil, it should be a column number which | |
96 | shouldn't be exceeded by the inserted text." | |
97 | (pcase sequence | |
98 | (`(,first . ,rest) | |
99 | (let* ((indent (or indent 0)) | |
100 | (max-column (and column (- column indent)))) | |
101 | (guix-with-indent indent | |
102 | (funcall function first) | |
103 | (dolist (element rest) | |
104 | (let ((before-sep-pos (and column (point)))) | |
105 | (insert separator) | |
106 | (let ((after-sep-pos (and column (point)))) | |
107 | (funcall function element) | |
108 | (when (and column | |
109 | (> (current-column) max-column)) | |
110 | (save-excursion | |
111 | (delete-region before-sep-pos after-sep-pos) | |
112 | (goto-char before-sep-pos) | |
113 | (insert "\n"))))))))))) | |
457f60fa | 114 | |
2e269860 AK |
115 | (defun guix-insert-button (label &optional type &rest properties) |
116 | "Make button of TYPE with LABEL and insert it at point. | |
457f60fa AK |
117 | See `insert-text-button' for the meaning of PROPERTIES." |
118 | (if (null label) | |
119 | (guix-format-insert nil) | |
2e269860 AK |
120 | (apply #'insert-text-button label |
121 | :type (or type 'button) | |
457f60fa AK |
122 | properties))) |
123 | ||
2c7ed388 AK |
124 | (defun guix-buttonize (value button-type separator &rest properties) |
125 | "Make BUTTON-TYPE button(s) from VALUE. | |
126 | Return a string with button(s). | |
127 | ||
128 | VALUE should be a string or a list of strings. If it is a list | |
129 | of strings, buttons are separated with SEPARATOR string. | |
130 | ||
131 | PROPERTIES are passed to `guix-insert-button'." | |
132 | (with-temp-buffer | |
133 | (let ((labels (if (listp value) value (list value)))) | |
134 | (guix-mapinsert (lambda (label) | |
135 | (apply #'guix-insert-button | |
136 | label button-type properties)) | |
137 | labels | |
138 | separator)) | |
139 | (buffer-substring (point-min) (point-max)))) | |
140 | ||
141 | (defun guix-button-type? (symbol) | |
142 | "Return non-nil, if SYMBOL is a button type." | |
143 | (and symbol | |
144 | (get symbol 'button-category-symbol))) | |
145 | ||
457f60fa AK |
146 | (defun guix-split-insert (val &optional face col separator) |
147 | "Convert VAL into a string, split it and insert at point. | |
148 | ||
149 | If FACE is non-nil, propertize returned string with this FACE. | |
150 | ||
151 | If COL is non-nil and result string is a one-line string longer | |
152 | than COL, split it into several short lines. | |
153 | ||
154 | Separate inserted lines with SEPARATOR." | |
155 | (if (null val) | |
156 | (guix-format-insert nil) | |
157 | (let ((strings (guix-split-string (guix-get-string val) col))) | |
158 | (guix-mapinsert (lambda (str) (guix-format-insert str face)) | |
159 | strings | |
160 | (or separator ""))))) | |
161 | ||
162 | (defun guix-split-string (str &optional col) | |
163 | "Split string STR by lines and return list of result strings. | |
2c7ed388 AK |
164 | If COL is non-nil, fill STR to this column." |
165 | (let ((str (if col | |
166 | (guix-get-filled-string str col) | |
167 | str))) | |
168 | (split-string str "\n *" t))) | |
457f60fa AK |
169 | |
170 | (defun guix-get-filled-string (str col) | |
171 | "Return string by filling STR to column COL." | |
172 | (with-temp-buffer | |
173 | (insert str) | |
174 | (let ((fill-column col)) | |
175 | (fill-region (point-min) (point-max))) | |
176 | (buffer-string))) | |
177 | ||
1ce96dd9 AK |
178 | (defun guix-concat-strings (strings separator &optional location) |
179 | "Return new string by concatenating STRINGS with SEPARATOR. | |
180 | If LOCATION is a symbol `head', add another SEPARATOR to the | |
181 | beginning of the returned string; if `tail' - add SEPARATOR to | |
182 | the end of the string; if nil, do not add SEPARATOR; otherwise | |
183 | add both to the end and to the beginning." | |
184 | (let ((str (mapconcat #'identity strings separator))) | |
185 | (cond ((null location) | |
186 | str) | |
187 | ((eq location 'head) | |
188 | (concat separator str)) | |
189 | ((eq location 'tail) | |
190 | (concat str separator)) | |
191 | (t | |
192 | (concat separator str separator))))) | |
193 | ||
32950fc8 AK |
194 | (defun guix-hexify (value) |
195 | "Convert VALUE to string and hexify it." | |
196 | (url-hexify-string (guix-get-string value))) | |
197 | ||
198 | (defun guix-number->bool (number) | |
199 | "Convert NUMBER to boolean value. | |
200 | Return nil, if NUMBER is 0; return t otherwise." | |
201 | (not (zerop number))) | |
202 | ||
009d6388 AK |
203 | (defun guix-shell-quote-argument (argument) |
204 | "Quote shell command ARGUMENT. | |
205 | This function is similar to `shell-quote-argument', but less strict." | |
206 | (if (equal argument "") | |
207 | "''" | |
208 | (replace-regexp-in-string | |
209 | "\n" "'\n'" | |
210 | (replace-regexp-in-string | |
211 | (rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument)))) | |
212 | ||
ceea647c AK |
213 | (defun guix-symbol-title (symbol) |
214 | "Return SYMBOL's name, a string. | |
215 | This is like `symbol-name', but fancier." | |
216 | (if (eq symbol 'id) | |
217 | "ID" | |
218 | (let ((str (replace-regexp-in-string "-" " " (symbol-name symbol)))) | |
219 | (concat (capitalize (substring str 0 1)) | |
220 | (substring str 1))))) | |
221 | ||
009d6388 AK |
222 | (defun guix-command-symbol (&optional args) |
223 | "Return symbol by concatenating 'guix' and ARGS (strings)." | |
224 | (intern (guix-concat-strings (cons "guix" args) "-"))) | |
225 | ||
226 | (defun guix-command-string (&optional args) | |
227 | "Return 'guix ARGS ...' string with quoted shell arguments." | |
228 | (let ((args (mapcar #'guix-shell-quote-argument args))) | |
229 | (guix-concat-strings (cons "guix" args) " "))) | |
230 | ||
ad0f31f6 AK |
231 | (defun guix-copy-as-kill (string &optional no-message?) |
232 | "Put STRING into `kill-ring'. | |
233 | If NO-MESSAGE? is non-nil, do not display a message about it." | |
234 | (kill-new string) | |
235 | (unless no-message? | |
236 | (message "'%s' has been added to kill ring." string))) | |
237 | ||
238 | (defun guix-copy-command-as-kill (args &optional no-message?) | |
239 | "Put 'guix ARGS ...' string into `kill-ring'. | |
240 | See also `guix-copy-as-kill'." | |
241 | (guix-copy-as-kill (guix-command-string args) no-message?)) | |
242 | ||
6ea80938 AK |
243 | (defun guix-compose-buffer-name (base-name postfix) |
244 | "Return buffer name by appending BASE-NAME and POSTFIX. | |
245 | ||
246 | In a simple case the result is: | |
247 | ||
248 | BASE-NAME: POSTFIX | |
249 | ||
250 | If BASE-NAME is wrapped by '*', then the result is: | |
251 | ||
252 | *BASE-NAME: POSTFIX*" | |
253 | (let ((re (rx string-start | |
254 | (group (? "*")) | |
255 | (group (*? any)) | |
256 | (group (? "*")) | |
257 | string-end))) | |
258 | (or (string-match re base-name) | |
259 | (error "Unexpected error in defining buffer name")) | |
260 | (let ((first* (match-string 1 base-name)) | |
261 | (name-body (match-string 2 base-name)) | |
262 | (last* (match-string 3 base-name))) | |
263 | ;; Handle the case when buffer name is wrapped by '*'. | |
264 | (if (and (string= "*" first*) | |
265 | (string= "*" last*)) | |
266 | (concat "*" name-body ": " postfix "*") | |
267 | (concat base-name ": " postfix))))) | |
268 | ||
dc690c44 AK |
269 | (defun guix-completing-read (prompt table &optional predicate |
270 | require-match initial-input | |
271 | hist def inherit-input-method) | |
272 | "Same as `completing-read' but return nil instead of an empty string." | |
273 | (let ((res (completing-read prompt table predicate | |
274 | require-match initial-input | |
275 | hist def inherit-input-method))) | |
276 | (unless (string= "" res) res))) | |
277 | ||
457f60fa AK |
278 | (defun guix-completing-read-multiple (prompt table &optional predicate |
279 | require-match initial-input | |
280 | hist def inherit-input-method) | |
281 | "Same as `completing-read-multiple' but remove duplicates in result." | |
282 | (cl-remove-duplicates | |
283 | (completing-read-multiple prompt table predicate | |
284 | require-match initial-input | |
285 | hist def inherit-input-method) | |
286 | :test #'string=)) | |
287 | ||
189cea27 AK |
288 | (declare-function org-read-date "org" t) |
289 | ||
290 | (defun guix-read-date (prompt) | |
291 | "Prompt for a date or time using `org-read-date'. | |
292 | Return time value." | |
293 | (require 'org) | |
294 | (org-read-date nil t nil prompt)) | |
295 | ||
b1990426 AK |
296 | (defun guix-read-file-name (prompt &optional dir default-filename |
297 | mustmatch initial predicate) | |
298 | "Read file name. | |
299 | This function is similar to `read-file-name' except it also | |
300 | expands the file name." | |
301 | (expand-file-name (read-file-name prompt dir default-filename | |
302 | mustmatch initial predicate))) | |
303 | ||
32c0b6d7 AK |
304 | (defcustom guix-find-file-function #'find-file |
305 | "Function used to find a file. | |
306 | The function is called by `guix-find-file' with a file name as a | |
307 | single argument." | |
308 | :type '(choice (function-item find-file) | |
309 | (function-item org-open-file) | |
310 | (function :tag "Other function")) | |
311 | :group 'guix) | |
312 | ||
e718f6cc AK |
313 | (defun guix-find-file (file) |
314 | "Find FILE if it exists." | |
315 | (if (file-exists-p file) | |
32c0b6d7 | 316 | (funcall guix-find-file-function file) |
e718f6cc AK |
317 | (message "File '%s' does not exist." file))) |
318 | ||
83d95c7b AK |
319 | (defvar url-handler-regexp) |
320 | ||
321 | (defun guix-find-file-or-url (file-or-url) | |
322 | "Find FILE-OR-URL." | |
323 | (require 'url-handlers) | |
324 | (let ((file-name-handler-alist | |
325 | (cons (cons url-handler-regexp 'url-file-handler) | |
326 | file-name-handler-alist))) | |
327 | (find-file file-or-url))) | |
328 | ||
c10521e9 AK |
329 | (defmacro guix-while-search (regexp &rest body) |
330 | "Evaluate BODY after each search for REGEXP in the current buffer." | |
331 | (declare (indent 1) (debug t)) | |
332 | `(save-excursion | |
333 | (goto-char (point-min)) | |
334 | (while (re-search-forward ,regexp nil t) | |
335 | ,@body))) | |
336 | ||
32950fc8 AK |
337 | (defmacro guix-while-null (&rest body) |
338 | "Evaluate BODY until its result becomes non-nil." | |
339 | (declare (indent 0) (debug t)) | |
340 | (let ((result-var (make-symbol "result"))) | |
341 | `(let (,result-var) | |
342 | (while (null ,result-var) | |
343 | (setq ,result-var ,@body)) | |
344 | ,result-var))) | |
345 | ||
959c78f6 AK |
346 | (defun guix-modify (object modifiers) |
347 | "Apply MODIFIERS to OBJECT. | |
348 | OBJECT is passed as an argument to the first function from | |
349 | MODIFIERS list, the returned result is passed to the second | |
350 | function from the list and so on. Return result of the last | |
351 | modifier call." | |
352 | (if (null modifiers) | |
353 | object | |
354 | (guix-modify (funcall (car modifiers) object) | |
355 | (cdr modifiers)))) | |
356 | ||
4ba476f9 AK |
357 | (defmacro guix-keyword-args-let (args varlist &rest body) |
358 | "Parse ARGS, bind variables from VARLIST and eval BODY. | |
359 | ||
360 | Find keyword values in ARGS, bind them to variables according to | |
361 | VARLIST, then evaluate BODY. | |
362 | ||
363 | ARGS is a keyword/value property list. | |
364 | ||
365 | Each element of VARLIST has a form: | |
366 | ||
367 | (SYMBOL KEYWORD [DEFAULT-VALUE]) | |
368 | ||
369 | SYMBOL is a varible name. KEYWORD is a symbol that will be | |
370 | searched in ARGS for an according value. If the value of KEYWORD | |
371 | does not exist, bind SYMBOL to DEFAULT-VALUE or nil. | |
372 | ||
373 | The rest arguments (that present in ARGS but not in VARLIST) will | |
374 | be bound to `%foreign-args' variable. | |
375 | ||
376 | Example: | |
377 | ||
378 | (guix-keyword-args-let '(:two 8 :great ! :guix is) | |
379 | ((one :one 1) | |
380 | (two :two 2) | |
381 | (foo :smth)) | |
382 | (list one two foo %foreign-args)) | |
383 | ||
384 | => (1 8 nil (:guix is :great !))" | |
385 | (declare (indent 2)) | |
386 | (let ((args-var (make-symbol "args"))) | |
387 | `(let (,@(mapcar (lambda (spec) | |
388 | (pcase-let ((`(,name ,_ ,val) spec)) | |
389 | (list name val))) | |
390 | varlist) | |
391 | (,args-var ,args) | |
392 | %foreign-args) | |
393 | (while ,args-var | |
394 | (pcase ,args-var | |
395 | (`(,key ,val . ,rest-args) | |
396 | (cl-case key | |
397 | ,@(mapcar (lambda (spec) | |
398 | (pcase-let ((`(,name ,key ,_) spec)) | |
399 | `(,key (setq ,name val)))) | |
400 | varlist) | |
401 | (t (setq %foreign-args | |
402 | (cl-list* key val %foreign-args)))) | |
403 | (setq ,args-var rest-args)))) | |
404 | ,@body))) | |
405 | ||
d38bd08c | 406 | \f |
d9c9f9a5 | 407 | ;;; Alist procedures |
51dac383 AK |
408 | |
409 | (defmacro guix-define-alist-accessor (name assoc-fun) | |
410 | "Define NAME function to access alist values using ASSOC-FUN." | |
411 | `(defun ,name (alist &rest keys) | |
412 | ,(format "Return value from ALIST by KEYS using `%s'. | |
413 | ALIST is alist of alists of alists ... which can be consecutively | |
414 | accessed with KEYS." | |
415 | assoc-fun) | |
416 | (if (or (null alist) (null keys)) | |
417 | alist | |
418 | (apply #',name | |
419 | (cdr (,assoc-fun (car keys) alist)) | |
420 | (cdr keys))))) | |
421 | ||
422 | (guix-define-alist-accessor guix-assq-value assq) | |
423 | (guix-define-alist-accessor guix-assoc-value assoc) | |
424 | ||
d9c9f9a5 AK |
425 | (defun guix-alist-put (value alist &rest keys) |
426 | "Put (add or replace if exists) VALUE to ALIST using KEYS. | |
427 | Return the new alist. | |
428 | ||
429 | ALIST is alist of alists of alists ... which can be consecutively | |
430 | accessed with KEYS. | |
431 | ||
432 | Example: | |
433 | ||
434 | (guix-alist-put | |
435 | 'foo | |
436 | '((one (a . 1) (b . 2)) | |
437 | (two (m . 7) (n . 8))) | |
438 | 'one 'b) | |
439 | ||
440 | => ((one (a . 1) (b . foo)) | |
441 | (two (m . 7) (n . 8)))" | |
442 | (or keys (error "Keys should be specified")) | |
443 | (guix-alist-put-1 value alist keys)) | |
444 | ||
445 | (defun guix-alist-put-1 (value alist keys) | |
446 | "Subroutine of `guix-alist-put'." | |
447 | (cond | |
448 | ((null keys) | |
449 | value) | |
450 | ((null alist) | |
451 | (list (cons (car keys) | |
452 | (guix-alist-put-1 value nil (cdr keys))))) | |
453 | ((eq (car keys) (caar alist)) | |
454 | (cons (cons (car keys) | |
455 | (guix-alist-put-1 value (cdar alist) (cdr keys))) | |
456 | (cdr alist))) | |
457 | (t | |
458 | (cons (car alist) | |
459 | (guix-alist-put-1 value (cdr alist) keys))))) | |
460 | ||
461 | (defun guix-alist-put! (value variable &rest keys) | |
462 | "Modify alist VARIABLE (symbol) by putting VALUE using KEYS. | |
463 | See `guix-alist-put' for details." | |
464 | (set variable | |
465 | (apply #'guix-alist-put value (symbol-value variable) keys))) | |
466 | ||
51dac383 | 467 | \f |
d38bd08c AK |
468 | ;;; Diff |
469 | ||
470 | (defvar guix-diff-switches "-u" | |
471 | "A string or list of strings specifying switches to be passed to diff.") | |
472 | ||
473 | (defun guix-diff (old new &optional switches no-async) | |
474 | "Same as `diff', but use `guix-diff-switches' as default." | |
475 | (diff old new (or switches guix-diff-switches) no-async)) | |
476 | ||
132e74fe | 477 | \f |
b1990426 AK |
478 | ;;; Completing readers definers |
479 | ||
480 | (defmacro guix-define-reader (name read-fun completions prompt) | |
481 | "Define NAME function to read from minibuffer. | |
482 | READ-FUN may be `completing-read', `completing-read-multiple' or | |
483 | another function with the same arguments." | |
484 | `(defun ,name (&optional prompt initial-contents) | |
485 | (,read-fun ,(if prompt | |
486 | `(or prompt ,prompt) | |
487 | 'prompt) | |
488 | ,completions nil nil initial-contents))) | |
489 | ||
490 | (defmacro guix-define-readers (&rest args) | |
491 | "Define reader functions. | |
492 | ||
493 | ARGS should have a form [KEYWORD VALUE] ... The following | |
494 | keywords are available: | |
495 | ||
496 | - `completions-var' - variable used to get completions. | |
497 | ||
498 | - `completions-getter' - function used to get completions. | |
499 | ||
500 | - `single-reader', `single-prompt' - name of a function to read | |
501 | a single value, and a prompt for it. | |
502 | ||
503 | - `multiple-reader', `multiple-prompt' - name of a function to | |
504 | read multiple values, and a prompt for it. | |
505 | ||
506 | - `multiple-separator' - if specified, another | |
507 | `<multiple-reader-name>-string' function returning a string | |
508 | of multiple values separated the specified separator will be | |
509 | defined." | |
510 | (guix-keyword-args-let args | |
511 | ((completions-var :completions-var) | |
512 | (completions-getter :completions-getter) | |
513 | (single-reader :single-reader) | |
514 | (single-prompt :single-prompt) | |
515 | (multiple-reader :multiple-reader) | |
516 | (multiple-prompt :multiple-prompt) | |
517 | (multiple-separator :multiple-separator)) | |
518 | (let ((completions | |
519 | (cond ((and completions-var completions-getter) | |
520 | `(or ,completions-var | |
521 | (setq ,completions-var | |
522 | (funcall ',completions-getter)))) | |
523 | (completions-var | |
524 | completions-var) | |
525 | (completions-getter | |
526 | `(funcall ',completions-getter))))) | |
527 | `(progn | |
528 | ,(when (and completions-var | |
529 | (not (boundp completions-var))) | |
530 | `(defvar ,completions-var nil)) | |
531 | ||
532 | ,(when single-reader | |
dc690c44 | 533 | `(guix-define-reader ,single-reader guix-completing-read |
b1990426 AK |
534 | ,completions ,single-prompt)) |
535 | ||
536 | ,(when multiple-reader | |
537 | `(guix-define-reader ,multiple-reader completing-read-multiple | |
538 | ,completions ,multiple-prompt)) | |
539 | ||
540 | ,(when (and multiple-reader multiple-separator) | |
541 | (let ((name (intern (concat (symbol-name multiple-reader) | |
542 | "-string")))) | |
543 | `(defun ,name (&optional prompt initial-contents) | |
544 | (guix-concat-strings | |
545 | (,multiple-reader prompt initial-contents) | |
546 | ,multiple-separator)))))))) | |
547 | ||
548 | \f | |
132e74fe AK |
549 | ;;; Memoizing |
550 | ||
551 | (defun guix-memoize (function) | |
552 | "Return a memoized version of FUNCTION." | |
553 | (let ((cache (make-hash-table :test 'equal))) | |
554 | (lambda (&rest args) | |
555 | (let ((result (gethash args cache 'not-found))) | |
556 | (if (eq result 'not-found) | |
557 | (let ((result (apply function args))) | |
558 | (puthash args result cache) | |
559 | result) | |
560 | result))))) | |
561 | ||
562 | (defmacro guix-memoized-defun (name arglist docstring &rest body) | |
563 | "Define a memoized function NAME. | |
564 | See `defun' for the meaning of arguments." | |
565 | (declare (doc-string 3) (indent 2)) | |
566 | `(defalias ',name | |
567 | (guix-memoize (lambda ,arglist ,@body)) | |
568 | ;; Add '(name args ...)' string with real arglist to the docstring, | |
569 | ;; because *Help* will display '(name &rest ARGS)' for a defined | |
570 | ;; function (since `guix-memoize' returns a lambda with '(&rest | |
571 | ;; args)'). | |
572 | ,(format "(%S %s)\n\n%s" | |
573 | name | |
574 | (mapconcat #'symbol-name arglist " ") | |
575 | docstring))) | |
576 | ||
6543601f AK |
577 | (defmacro guix-memoized-defalias (symbol definition &optional docstring) |
578 | "Set SYMBOL's function definition to memoized version of DEFINITION." | |
579 | (declare (doc-string 3) (indent 1)) | |
580 | `(defalias ',symbol | |
581 | (guix-memoize #',definition) | |
582 | ,(or docstring | |
583 | (format "Memoized version of `%S'." definition)))) | |
584 | ||
36c00c61 AK |
585 | \f |
586 | (defvar guix-utils-font-lock-keywords | |
6543601f | 587 | (eval-when-compile |
b1990426 AK |
588 | `((,(rx "(" (group (or "guix-define-reader" |
589 | "guix-define-readers" | |
590 | "guix-keyword-args-let" | |
32950fc8 AK |
591 | "guix-while-null" |
592 | "guix-while-search" | |
4ba476f9 | 593 | "guix-with-indent")) |
36c00c61 AK |
594 | symbol-end) |
595 | . 1) | |
596 | (,(rx "(" | |
6543601f AK |
597 | (group "guix-memoized-" (or "defun" "defalias")) |
598 | symbol-end | |
599 | (zero-or-more blank) | |
600 | (zero-or-one | |
601 | (group (one-or-more (or (syntax word) (syntax symbol)))))) | |
602 | (1 font-lock-keyword-face) | |
603 | (2 font-lock-function-name-face nil t))))) | |
604 | ||
36c00c61 | 605 | (font-lock-add-keywords 'emacs-lisp-mode guix-utils-font-lock-keywords) |
6543601f | 606 | |
457f60fa AK |
607 | (provide 'guix-utils) |
608 | ||
609 | ;;; guix-utils.el ends here |