lisp/emacs-lisp/subr-x.el

   1 ;;; subr-x.el --- extra Lisp functions  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2013-2018 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/r/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 This is like `if-let' but doesn't handle a VARLIST of the form
 127 \(SYMBOL SOMETHING) specially."
 128   (declare (indent 2)
 129            (debug ((&rest [&or symbolp (symbolp form) (form)])
 130                    form body)))
 131   (if varlist
 132       `(let* ,(setq varlist (internal--build-bindings varlist))
 133          (if ,(caar (last varlist))
 134              ,then
 135            ,@else))
 136     `(let* () ,then)))
 137
 138 (defmacro when-let* (varlist &rest body)
 139   "Bind variables according to VARLIST and conditionally eval BODY.
 140 This is like `when-let' but doesn't handle a VARLIST of the form
 141 \(SYMBOL SOMETHING) specially."
 142   (declare (indent 1) (debug if-let*))
 143   (list 'if-let* varlist (macroexp-progn body)))
 144
 145 (defmacro and-let* (varlist &rest body)
 146   "Bind variables according to VARLIST and conditionally eval BODY.
 147 Like `when-let*', except if BODY is empty and all the bindings
 148 are non-nil, then the result is non-nil."
 149   (declare (indent 1)
 150            (debug ((&rest [&or symbolp (symbolp form) (form)])
 151                    body)))
 152   (let (res)
 153     (if varlist
 154         `(let* ,(setq varlist (internal--build-bindings varlist))
 155            (if ,(setq res (caar (last varlist)))
 156                ,@(or body `(,res))))
 157       `(let* () ,@(or body '(t))))))
 158
 159 (defmacro if-let (spec then &rest else)
 160   "Bind variables according to SPEC and eval THEN or ELSE.
 161 Each binding is evaluated in turn, and evaluation stops if a
 162 binding value is nil.  If all are non-nil, the value of THEN is
 163 returned, or the last form in ELSE is returned.
 164
 165 Each element of SPEC is a list (SYMBOL VALUEFORM) which binds
 166 SYMBOL to the value of VALUEFORM.  An element can additionally be
 167 of the form (VALUEFORM), which is evaluated and checked for nil;
 168 i.e. SYMBOL can be omitted if only the test result is of
 169 interest.  It can also be of the form SYMBOL, then the binding of
 170 SYMBOL is checked for nil.
 171
 172 As a special case, a SPEC of the form \(SYMBOL SOMETHING) is
 173 interpreted like \((SYMBOL SOMETHING)). This exists for backward
 174 compatibility with the old syntax that accepted only one
 175 binding."
 176   (declare (indent 2)
 177            (debug ([&or (&rest [&or symbolp (symbolp form) (form)])
 178                         (symbolp form)]
 179                    form body)))
 180   (when (and (<= (length spec) 2)
 181              (not (listp (car spec))))
 182     ;; Adjust the single binding case
 183     (setq spec (list spec)))
 184   (list 'if-let* spec then (macroexp-progn else)))
 185
 186 (defmacro when-let (spec &rest body)
 187   "Bind variables according to SPEC and conditionally eval BODY.
 188 Each binding is evaluated in turn, and evaluation stops if a
 189 binding value is nil.  If all are non-nil, the value of the last
 190 form in BODY is returned.
 191
 192 The variable list SPEC is the same as in `if-let'."
 193   (declare (indent 1) (debug if-let))
 194   (list 'if-let spec (macroexp-progn body)))
 195
 196 (defsubst hash-table-empty-p (hash-table)
 197   "Check whether HASH-TABLE is empty (has 0 elements)."
 198   (zerop (hash-table-count hash-table)))
 199
 200 (defsubst hash-table-keys (hash-table)
 201   "Return a list of keys in HASH-TABLE."
 202   (cl-loop for k being the hash-keys of hash-table collect k))
 203
 204 (defsubst hash-table-values (hash-table)
 205   "Return a list of values in HASH-TABLE."
 206   (cl-loop for v being the hash-values of hash-table collect v))
 207
 208 (defsubst string-empty-p (string)
 209   "Check whether STRING is empty."
 210   (string= string ""))
 211
 212 (defsubst string-join (strings &optional separator)
 213   "Join all STRINGS using SEPARATOR."
 214   (mapconcat 'identity strings separator))
 215
 216 (define-obsolete-function-alias 'string-reverse 'reverse "25.1")
 217
 218 (defsubst string-trim-left (string &optional regexp)
 219   "Trim STRING of leading 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-right (string &optional regexp)
 227   "Trim STRING of trailing string matching REGEXP.
 228
 229 REGEXP defaults to  \"[ \\t\\n\\r]+\"."
 230   (if (string-match (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string)
 231       (replace-match "" t t string)
 232     string))
 233
 234 (defsubst string-trim (string &optional trim-left trim-right)
 235   "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
 236
 237 TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
 238   (string-trim-left (string-trim-right string trim-right) trim-left))
 239
 240 (defsubst string-blank-p (string)
 241   "Check whether STRING is either empty or only whitespace."
 242   (string-match-p "\\`[ \t\n\r]*\\'" string))
 243
 244 (defsubst string-remove-prefix (prefix string)
 245   "Remove PREFIX from STRING if present."
 246   (if (string-prefix-p prefix string)
 247       (substring string (length prefix))
 248     string))
 249
 250 (defsubst string-remove-suffix (suffix string)
 251   "Remove SUFFIX from STRING if present."
 252   (if (string-suffix-p suffix string)
 253       (substring string 0 (- (length string) (length suffix)))
 254     string))
 255
 256 (provide 'subr-x)
 257
 258 ;;; subr-x.el ends here