LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - subr-x.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 29 165 17.6 %
Date: 2017-08-27 09:44:50 Functions: 10 25 40.0 %

          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

Generated by: LCOV version 1.12