lisp/emacs-lisp/subr-x.el

   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 <https://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 ;; https://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   (pcase forms
  46     (`(,x (,f . ,args) . ,rest)
  47      `(internal--thread-argument
  48        ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest))
  49     (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest))
  50     (_ (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   `(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   `(internal--thread-argument nil ,@forms))
  84
  85 (defsubst internal--listify (elt)
  86   "Wrap ELT in a list if it is not one.
  87 If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol."
  88   (cond
  89    ((symbolp elt) (list elt elt))
  90    ((null (cdr elt))
  91     (list (make-symbol "s") (car elt)))
  92    (t elt)))
  93
  94 (defsubst internal--check-binding (binding)
  95   "Check BINDING is properly formed."
  96   (when (> (length binding) 2)
  97     (signal
  98      'error
  99      (cons "`let' bindings can have only one value-form" binding)))
 100   binding)
 101
 102 (defsubst internal--build-binding-value-form (binding prev-var)
 103   "Build the conditional value form for BINDING using PREV-VAR."
 104   (let ((var (car binding)))
 105     `(,var (and ,prev-var ,(cadr binding)))))
 106
 107 (defun internal--build-binding (binding prev-var)
 108   "Check and build a single BINDING with PREV-VAR."
 109   (thread-first
 110       binding
 111     internal--listify
 112     internal--check-binding
 113     (internal--build-binding-value-form prev-var)))
 114
 115 (defun internal--build-bindings (bindings)
 116   "Check and build conditional value forms for BINDINGS."
 117   (let ((prev-var t))
 118     (mapcar (lambda (binding)
 119               (let ((binding (internal--build-binding binding prev-var)))
 120                 (setq prev-var (car binding))
 121                 binding))
 122             bindings)))
 123
 124 (defmacro if-let* (varlist then &rest else)
 125   "Bind variables according to VARLIST and eval THEN or ELSE.
 126 Each binding is evaluated in turn, and evaluation stops if a
 127 binding value is nil.  If all are non-nil, the value of THEN is
 128 returned, or the last form in ELSE is returned.
 129
 130 Each element of VARLIST is a list (SYMBOL VALUEFORM) which binds
 131 SYMBOL to the value of VALUEFORM.  An element can additionally
 132 be of the form (VALUEFORM), which is evaluated and checked for
 133 nil; i.e. SYMBOL can be omitted if only the test result is of
 134 interest."
 135   (declare (indent 2)
 136            (debug ((&rest [&or symbolp (symbolp form) (sexp)])
 137                    form body)))
 138   (if varlist
 139       `(let* ,(setq varlist (internal--build-bindings varlist))
 140          (if ,(caar (last varlist))
 141              ,then
 142            ,@else))
 143     `(let* () ,then)))
 144
 145 (defmacro when-let* (varlist &rest body)
 146   "Bind variables according to VARLIST and conditionally eval BODY.
 147 Each binding is evaluated in turn, and evaluation stops if a
 148 binding value is nil.  If all are non-nil, the value of the last
 149 form in BODY is returned.
 150
 151 VARLIST is the same as in `if-let*'."
 152   (declare (indent 1) (debug if-let*))
 153   (list 'if-let* varlist (macroexp-progn body)))
 154
 155 (defmacro and-let* (varlist &rest body)
 156   "Bind variables according to VARLIST and conditionally eval BODY.
 157 Like `when-let*', except if BODY is empty and all the bindings
 158 are non-nil, then the result is non-nil."
 159   (declare (indent 1) (debug when-let*))
 160   (let (res)
 161     (if varlist
 162         `(let* ,(setq varlist (internal--build-bindings varlist))
 163            (if ,(setq res (caar (last varlist)))
 164                ,@(or body `(,res))))
 165       `(let* () ,@(or body '(t))))))
 166
 167 (defmacro if-let (spec then &rest else)
 168   "Bind variables according to SPEC and eval THEN or ELSE.
 169 Like `if-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
 170   (declare (indent 2)
 171            (debug ([&or (&rest [&or symbolp (symbolp form) (sexp)])
 172                         (symbolp form)]
 173                    form body))
 174            (obsolete "use `if-let*' instead." "26.1"))
 175   (when (and (<= (length spec) 2)
 176              (not (listp (car spec))))
 177     ;; Adjust the single binding case
 178     (setq spec (list spec)))
 179   (list 'if-let* spec then (macroexp-progn else)))
 180
 181 (defmacro when-let (spec &rest body)
 182   "Bind variables according to SPEC and conditionally eval BODY.
 183 Like `when-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
 184   (declare (indent 1) (debug if-let)
 185            (obsolete "use `when-let*' instead." "26.1"))
 186   (list 'if-let spec (macroexp-progn body)))
 187
 188 (defsubst hash-table-empty-p (hash-table)
 189   "Check whether HASH-TABLE is empty (has 0 elements)."
 190   (zerop (hash-table-count hash-table)))
 191
 192 (defsubst hash-table-keys (hash-table)
 193   "Return a list of keys in HASH-TABLE."
 194   (cl-loop for k being the hash-keys of hash-table collect k))
 195
 196 (defsubst hash-table-values (hash-table)
 197   "Return a list of values in HASH-TABLE."
 198   (cl-loop for v being the hash-values of hash-table collect v))
 199
 200 (defsubst string-empty-p (string)
 201   "Check whether STRING is empty."
 202   (string= string ""))
 203
 204 (defsubst string-join (strings &optional separator)
 205   "Join all STRINGS using SEPARATOR."
 206   (mapconcat 'identity strings separator))
 207
 208 (define-obsolete-function-alias 'string-reverse 'reverse "25.1")
 209
 210 (defsubst string-trim-left (string &optional regexp)
 211   "Trim STRING of leading string matching REGEXP.
 212
 213 REGEXP defaults to \"[ \\t\\n\\r]+\"."
 214   (if (string-match (concat "\\`\\(?:" (or  regexp "[ \t\n\r]+")"\\)") string)
 215       (replace-match "" t t string)
 216     string))
 217
 218 (defsubst string-trim-right (string &optional regexp)
 219   "Trim STRING of trailing string matching REGEXP.
 220
 221 REGEXP defaults to  \"[ \\t\\n\\r]+\"."
 222   (if (string-match (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string)
 223       (replace-match "" t t string)
 224     string))
 225
 226 (defsubst string-trim (string &optional trim-left trim-right)
 227   "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
 228
 229 TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
 230   (string-trim-left (string-trim-right string trim-right) trim-left))
 231
 232 (defsubst string-blank-p (string)
 233   "Check whether STRING is either empty or only whitespace."
 234   (string-match-p "\\`[ \t\n\r]*\\'" string))
 235
 236 (defsubst string-remove-prefix (prefix string)
 237   "Remove PREFIX from STRING if present."
 238   (if (string-prefix-p prefix string)
 239       (substring string (length prefix))
 240     string))
 241
 242 (defsubst string-remove-suffix (suffix string)
 243   "Remove SUFFIX from STRING if present."
 244   (if (string-suffix-p suffix string)
 245       (substring string 0 (- (length string) (length suffix)))
 246     string))
 247
 248 (defun read-multiple-choice (prompt choices)
 249   "Ask user a multiple choice question.
 250 PROMPT should be a string that will be displayed as the prompt.
 251
 252 CHOICES is an alist where the first element in each entry is a
 253 character to be entered, the second element is a short name for
 254 the entry to be displayed while prompting (if there's room, it
 255 might be shortened), and the third, optional entry is a longer
 256 explanation that will be displayed in a help buffer if the user
 257 requests more help.
 258
 259 This function translates user input into responses by consulting
 260 the bindings in `query-replace-map'; see the documentation of
 261 that variable for more information.  In this case, the useful
 262 bindings are `recenter', `scroll-up', and `scroll-down'.  If the
 263 user enters `recenter', `scroll-up', or `scroll-down' responses,
 264 perform the requested window recentering or scrolling and ask
 265 again.
 266
 267 When `use-dialog-box' is t (the default), this function can pop
 268 up a dialog window to collect the user input. That functionality
 269 requires `display-popup-menus-p' to return t. Otherwise, a text
 270 dialog will be used.
 271
 272 The return value is the matching entry from the CHOICES list.
 273
 274 Usage example:
 275
 276 \(read-multiple-choice \"Continue connecting?\"
 277                       \\='((?a \"always\")
 278                         (?s \"session only\")
 279                         (?n \"no\")))"
 280   (let* ((altered-names nil)
 281          (full-prompt
 282           (format
 283            "%s (%s): "
 284            prompt
 285            (mapconcat
 286             (lambda (elem)
 287               (let* ((name (cadr elem))
 288                      (pos (seq-position name (car elem)))
 289                      (altered-name
 290                       (cond
 291                        ;; Not in the name string.
 292                        ((not pos)
 293                         (format "[%c] %s" (car elem) name))
 294                        ;; The prompt character is in the name, so highlight
 295                        ;; it on graphical terminals...
 296                        ((display-supports-face-attributes-p
 297                          '(:underline t) (window-frame))
 298                         (setq name (copy-sequence name))
 299                         (put-text-property pos (1+ pos)
 300                                            'face 'read-multiple-choice-face
 301                                            name)
 302                         name)
 303                        ;; And put it in [bracket] on non-graphical terminals.
 304                        (t
 305                         (concat
 306                          (substring name 0 pos)
 307                          "["
 308                          (upcase (substring name pos (1+ pos)))
 309                          "]"
 310                          (substring name (1+ pos)))))))
 311                 (push (cons (car elem) altered-name)
 312                       altered-names)
 313                 altered-name))
 314             (append choices '((?? "?")))
 315             ", ")))
 316          tchar buf wrong-char answer)
 317     (save-window-excursion
 318       (save-excursion
 319         (while (not tchar)
 320           (message "%s%s"
 321                    (if wrong-char
 322                        "Invalid choice.  "
 323                      "")
 324                    full-prompt)
 325           (setq tchar
 326                 (if (and (display-popup-menus-p)
 327                          last-input-event ; not during startup
 328                          (listp last-nonmenu-event)
 329                          use-dialog-box)
 330                     (x-popup-dialog
 331                      t
 332                      (cons prompt
 333                            (mapcar
 334                             (lambda (elem)
 335                               (cons (capitalize (cadr elem))
 336                                     (car elem)))
 337                             choices)))
 338                   (condition-case nil
 339                       (let ((cursor-in-echo-area t))
 340                         (read-char))
 341                     (error nil))))
 342           (setq answer (lookup-key query-replace-map (vector tchar) t))
 343           (setq tchar
 344                 (cond
 345                  ((eq answer 'recenter)
 346                   (recenter) t)
 347                  ((eq answer 'scroll-up)
 348                   (ignore-errors (scroll-up-command)) t)
 349                  ((eq answer 'scroll-down)
 350                   (ignore-errors (scroll-down-command)) t)
 351                  ((eq answer 'scroll-other-window)
 352                   (ignore-errors (scroll-other-window)) t)
 353                  ((eq answer 'scroll-other-window-down)
 354                   (ignore-errors (scroll-other-window-down)) t)
 355                  (t tchar)))
 356           (when (eq tchar t)
 357             (setq wrong-char nil
 358                   tchar nil))
 359           ;; The user has entered an invalid choice, so display the
 360           ;; help messages.
 361           (when (and (not (eq tchar nil))
 362                      (not (assq tchar choices)))
 363             (setq wrong-char (not (memq tchar '(?? ?\C-h)))
 364                   tchar nil)
 365             (when wrong-char
 366               (ding))
 367             (with-help-window (setq buf (get-buffer-create
 368                                          "*Multiple Choice Help*"))
 369               (with-current-buffer buf
 370                 (erase-buffer)
 371                 (pop-to-buffer buf)
 372                 (insert prompt "\n\n")
 373                 (let* ((columns (/ (window-width) 25))
 374                        (fill-column 21)
 375                        (times 0)
 376                        (start (point)))
 377                   (dolist (elem choices)
 378                     (goto-char start)
 379                     (unless (zerop times)
 380                       (if (zerop (mod times columns))
 381                           ;; Go to the next "line".
 382                           (goto-char (setq start (point-max)))
 383                         ;; Add padding.
 384                         (while (not (eobp))
 385                           (end-of-line)
 386                           (insert (make-string (max (- (* (mod times columns)
 387                                                           (+ fill-column 4))
 388                                                        (current-column))
 389                                                     0)
 390                                                ?\s))
 391                           (forward-line 1))))
 392                     (setq times (1+ times))
 393                     (let ((text
 394                            (with-temp-buffer
 395                              (insert (format
 396                                       "%c: %s\n"
 397                                       (car elem)
 398                                       (cdr (assq (car elem) altered-names))))
 399                              (fill-region (point-min) (point-max))
 400                              (when (nth 2 elem)
 401                                (let ((start (point)))
 402                                  (insert (nth 2 elem))
 403                                  (unless (bolp)
 404                                    (insert "\n"))
 405                                  (fill-region start (point-max))))
 406                              (buffer-string))))
 407                       (goto-char start)
 408                       (dolist (line (split-string text "\n"))
 409                         (end-of-line)
 410                         (if (bolp)
 411                             (insert line "\n")
 412                           (insert line))
 413                         (forward-line 1)))))))))))
 414     (when (buffer-live-p buf)
 415       (kill-buffer buf))
 416     (assq tchar choices)))
 417
 418 (provide 'subr-x)
 419
 420 ;;; subr-x.el ends here