lisp/emacs-lisp/subr-x.el

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