subr-x.el 9.83 KB
Newer Older
1
;;; subr-x.el --- extra Lisp functions  -*- lexical-binding:t -*-
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
4

5
;; Maintainer: emacs-devel@gnu.org
6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
;; Keywords: convenience
;; Package: emacs

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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 25

;;; Commentary:

26 27 28 29
;; Less commonly used functions that complement basic APIs, often implemented in
;; C code (like hash-tables and strings), and are not eligible for inclusion
;; in subr.el.

30
;; Do not document these functions in the lispref.
31
;; https://lists.gnu.org/r/emacs-devel/2014-01/msg01006.html
32

33 34 35
;; NB If you want to use this library, it's almost always correct to use:
;; (eval-when-compile (require 'subr-x))

36 37
;;; Code:

38
(eval-when-compile (require 'cl-lib))
39 40 41 42 43 44 45 46 47 48 49 50 51 52


(defmacro internal--thread-argument (first? &rest forms)
  "Internal implementation for `thread-first' and `thread-last'.
When Argument FIRST? is non-nil argument is threaded first, else
last.  FORMS are the expressions to be threaded."
  (pcase forms
    (`(,x (,f . ,args) . ,rest)
     `(internal--thread-argument
       ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest))
    (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest))
    (_ (car forms))))

(defmacro thread-first (&rest forms)
Paul Eggert's avatar
Paul Eggert committed
53
  "Thread FORMS elements as the first argument of their successor.
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
Example:
    (thread-first
      5
      (+ 20)
      (/ 25)
      -
      (+ 40))
Is equivalent to:
    (+ (- (/ (+ 5 20) 25)) 40)
Note how the single `-' got converted into a list before
threading."
  (declare (indent 1)
           (debug (form &rest [&or symbolp (sexp &rest form)])))
  `(internal--thread-argument t ,@forms))

(defmacro thread-last (&rest forms)
Paul Eggert's avatar
Paul Eggert committed
70
  "Thread FORMS elements as the last argument of their successor.
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
Example:
    (thread-last
      5
      (+ 20)
      (/ 25)
      -
      (+ 40))
Is equivalent to:
    (+ 40 (- (/ 25 (+ 20 5))))
Note how the single `-' got converted into a list before
threading."
  (declare (indent 1) (debug thread-first))
  `(internal--thread-argument nil ,@forms))

(defsubst internal--listify (elt)
Mark Oteiza's avatar
Mark Oteiza committed
86 87 88 89
  "Wrap ELT in a list if it is not one.
If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol."
  (cond
   ((symbolp elt) (list elt elt))
Mark Oteiza's avatar
Mark Oteiza committed
90
   ((null (cdr elt))
Mark Oteiza's avatar
Mark Oteiza committed
91 92
    (list (make-symbol "s") (car elt)))
   (t elt)))
93 94 95 96 97 98

(defsubst internal--check-binding (binding)
  "Check BINDING is properly formed."
  (when (> (length binding) 2)
    (signal
     'error
99
     (cons "`let' bindings can have only one value-form" binding)))
100 101 102 103
  binding)

(defsubst internal--build-binding-value-form (binding prev-var)
  "Build the conditional value form for BINDING using PREV-VAR."
Mark Oteiza's avatar
Mark Oteiza committed
104
  (let ((var (car binding)))
Mark Oteiza's avatar
Mark Oteiza committed
105
    `(,var (and ,prev-var ,(cadr binding)))))
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123

(defun internal--build-binding (binding prev-var)
  "Check and build a single BINDING with PREV-VAR."
  (thread-first
      binding
    internal--listify
    internal--check-binding
    (internal--build-binding-value-form prev-var)))

(defun internal--build-bindings (bindings)
  "Check and build conditional value forms for BINDINGS."
  (let ((prev-var t))
    (mapcar (lambda (binding)
              (let ((binding (internal--build-binding binding prev-var)))
                (setq prev-var (car binding))
                binding))
            bindings)))

Michael Heerdegen's avatar
Michael Heerdegen committed
124
(defmacro if-let* (varlist then &rest else)
125
  "Bind variables according to VARLIST and evaluate THEN or ELSE.
126 127
This is like `if-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
128
  (declare (indent 2)
Michael Heerdegen's avatar
Michael Heerdegen committed
129
           (debug ((&rest [&or symbolp (symbolp form) (form)])
130
                   form body)))
Mark Oteiza's avatar
Mark Oteiza committed
131 132 133 134 135
  (if varlist
      `(let* ,(setq varlist (internal--build-bindings varlist))
         (if ,(caar (last varlist))
             ,then
           ,@else))
136
    `(let* () ,then)))
Mark Oteiza's avatar
Mark Oteiza committed
137

Michael Heerdegen's avatar
Michael Heerdegen committed
138
(defmacro when-let* (varlist &rest body)
139
  "Bind variables according to VARLIST and conditionally evaluate BODY.
140 141
This is like `when-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
Michael Heerdegen's avatar
Michael Heerdegen committed
142 143
  (declare (indent 1) (debug if-let*))
  (list 'if-let* varlist (macroexp-progn body)))
144

Michael Heerdegen's avatar
Michael Heerdegen committed
145
(defmacro and-let* (varlist &rest body)
146
  "Bind variables according to VARLIST and conditionally evaluate BODY.
Michael Heerdegen's avatar
Michael Heerdegen committed
147
Like `when-let*', except if BODY is empty and all the bindings
Mark Oteiza's avatar
Mark Oteiza committed
148
are non-nil, then the result is non-nil."
Michael Heerdegen's avatar
Michael Heerdegen committed
149 150 151
  (declare (indent 1)
           (debug ((&rest [&or symbolp (symbolp form) (form)])
                   body)))
Mark Oteiza's avatar
Mark Oteiza committed
152 153 154
  (let (res)
    (if varlist
        `(let* ,(setq varlist (internal--build-bindings varlist))
155 156
           (when ,(setq res (caar (last varlist)))
             ,@(or body `(,res))))
Mark Oteiza's avatar
Mark Oteiza committed
157 158
      `(let* () ,@(or body '(t))))))

Michael Heerdegen's avatar
Michael Heerdegen committed
159
(defmacro if-let (spec then &rest else)
160 161 162
  "Bind variables according to SPEC and evaluate THEN or ELSE.
Evaluate each binding in turn, stopping if a binding value is nil.
If all are non-nil return the value of THEN, otherwise the last form in ELSE.
163

164
Each element of SPEC is a list (SYMBOL VALUEFORM) that binds
165 166 167 168 169 170
SYMBOL to the value of VALUEFORM.  An element can additionally be
of the form (VALUEFORM), which is evaluated and checked for nil;
i.e. SYMBOL can be omitted if only the test result is of
interest.  It can also be of the form SYMBOL, then the binding of
SYMBOL is checked for nil.

171 172 173
As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING)
like \((SYMBOL SOMETHING)).  This exists for backward compatibility
with an old syntax that accepted only one binding."
Michael Heerdegen's avatar
Michael Heerdegen committed
174 175 176
  (declare (indent 2)
           (debug ([&or (&rest [&or symbolp (symbolp form) (form)])
                        (symbolp form)]
177
                   form body)))
Michael Heerdegen's avatar
Michael Heerdegen committed
178 179 180 181 182 183 184
  (when (and (<= (length spec) 2)
             (not (listp (car spec))))
    ;; Adjust the single binding case
    (setq spec (list spec)))
  (list 'if-let* spec then (macroexp-progn else)))

(defmacro when-let (spec &rest body)
185 186 187
  "Bind variables according to SPEC and conditionally evaluate BODY.
Evaluate each binding in turn, stopping if a binding value is nil.
If all are non-nil, return the value of the last form in BODY.
188 189 190

The variable list SPEC is the same as in `if-let'."
  (declare (indent 1) (debug if-let))
Michael Heerdegen's avatar
Michael Heerdegen committed
191
  (list 'if-let spec (macroexp-progn body)))
Mark Oteiza's avatar
Mark Oteiza committed
192

Bozhidar Batsov's avatar
Bozhidar Batsov committed
193 194 195
(defsubst hash-table-empty-p (hash-table)
  "Check whether HASH-TABLE is empty (has 0 elements)."
  (zerop (hash-table-count hash-table)))
196

197 198
(defsubst hash-table-keys (hash-table)
  "Return a list of keys in HASH-TABLE."
199
  (cl-loop for k being the hash-keys of hash-table collect k))
200 201 202

(defsubst hash-table-values (hash-table)
  "Return a list of values in HASH-TABLE."
203
  (cl-loop for v being the hash-values of hash-table collect v))
204

205 206 207 208
(defsubst string-empty-p (string)
  "Check whether STRING is empty."
  (string= string ""))

209 210
(defsubst string-join (strings &optional separator)
  "Join all STRINGS using SEPARATOR."
211
  (mapconcat #'identity strings separator))
212

Stefan Monnier's avatar
Stefan Monnier committed
213
(define-obsolete-function-alias 'string-reverse 'reverse "25.1")
214

215 216 217 218
(defsubst string-trim-left (string &optional regexp)
  "Trim STRING of leading string matching REGEXP.

REGEXP defaults to \"[ \\t\\n\\r]+\"."
219 220
  (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
      (substring string (match-end 0))
221 222
    string))

223 224 225 226
(defsubst string-trim-right (string &optional regexp)
  "Trim STRING of trailing string matching REGEXP.

REGEXP defaults to  \"[ \\t\\n\\r]+\"."
227 228 229
  (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
                           string)))
    (if i (substring string 0 i) string)))
230

231 232 233 234 235
(defsubst string-trim (string &optional trim-left trim-right)
  "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.

TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
  (string-trim-left (string-trim-right string trim-right) trim-left))
236

237 238
(defsubst string-blank-p (string)
  "Check whether STRING is either empty or only whitespace."
239
  (string-match-p "\\`[ \t\n\r]*\\'" string))
240

241 242 243 244 245 246 247 248 249 250 251 252
(defsubst string-remove-prefix (prefix string)
  "Remove PREFIX from STRING if present."
  (if (string-prefix-p prefix string)
      (substring string (length prefix))
    string))

(defsubst string-remove-suffix (suffix string)
  "Remove SUFFIX from STRING if present."
  (if (string-suffix-p suffix string)
      (substring string 0 (- (length string) (length suffix)))
    string))

253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281
(defun replace-region-contents (beg end replace-fn
                                    &optional max-secs max-costs)
  "Replace the region between BEG and END using REPLACE-FN.
REPLACE-FN runs on the current buffer narrowed to the region.  It
should return either a string or a buffer replacing the region.

The replacement is performed using `replace-buffer-contents'
which also describes the MAX-SECS and MAX-COSTS arguments and the
return value.

Note: If the replacement is a string, it'll be placed in a
temporary buffer so that `replace-buffer-contents' can operate on
it.  Therefore, if you already have the replacement in a buffer,
it makes no sense to convert it to a string using
`buffer-substring' or similar."
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (let ((repl (funcall replace-fn)))
	(if (bufferp repl)
	    (replace-buffer-contents repl max-secs max-costs)
	  (let ((source-buffer (current-buffer)))
	    (with-temp-buffer
	      (insert repl)
	      (let ((tmp-buffer (current-buffer)))
		(set-buffer source-buffer)
		(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))

282
(provide 'subr-x)
283

284
;;; subr-x.el ends here