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

3
;; Copyright (C) 2013-2014 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 22 23 24 25
;; 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
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; 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 31 32
;; Do not document these functions in the lispref.
;; http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg01006.html

33 34
;;; Code:

35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
(require 'pcase)


(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
50
  "Thread FORMS elements as the first argument of their successor.
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
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
67
  "Thread FORMS elements as the last argument of their successor.
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
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)
  "Wrap ELT in a list if it is not one."
  (if (not (listp elt))
      (list elt)
    elt))

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

(defsubst internal--build-binding-value-form (binding prev-var)
  "Build the conditional value form for BINDING using PREV-VAR."
  `(,(car binding) (and ,prev-var ,(cadr binding))))

(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)))

(defmacro if-let (bindings then &rest else)
  "Process BINDINGS and if all values are non-nil eval THEN, else ELSE.
Argument BINDINGS is a list of tuples whose car is a symbol to be
bound and (optionally) used in THEN, and its cadr is a sexp to be
Paul Eggert's avatar
Paul Eggert committed
121
evalled to set symbol's value.  In the special case you only want
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
to bind a single value, BINDINGS can just be a plain tuple."
  (declare (indent 2) (debug ((&rest (symbolp form)) form body)))
  (when (and (<= (length bindings) 2)
             (not (listp (car bindings))))
    ;; Adjust the single binding case
    (setq bindings (list bindings)))
  `(let* ,(internal--build-bindings bindings)
     (if ,(car (internal--listify (car (last bindings))))
         ,then
       ,@else)))

(defmacro when-let (bindings &rest body)
  "Process BINDINGS and if all values are non-nil eval BODY.
Argument BINDINGS is a list of tuples whose car is a symbol to be
bound and (optionally) used in BODY, and its cadr is a sexp to be
Paul Eggert's avatar
Paul Eggert committed
137
evalled to set symbol's value.  In the special case you only want
138 139 140 141
to bind a single value, BINDINGS can just be a plain tuple."
  (declare (indent 1) (debug if-let))
  (list 'if-let bindings (macroexp-progn body)))

142 143 144
(defsubst hash-table-keys (hash-table)
  "Return a list of keys in HASH-TABLE."
  (let ((keys '()))
145
    (maphash (lambda (k _v) (push k keys)) hash-table)
146 147 148 149 150
    keys))

(defsubst hash-table-values (hash-table)
  "Return a list of values in HASH-TABLE."
  (let ((values '()))
151
    (maphash (lambda (_k v) (push v values)) hash-table)
152 153
    values))

154 155 156 157
(defsubst string-empty-p (string)
  "Check whether STRING is empty."
  (string= string ""))

158 159 160 161
(defsubst string-join (strings &optional separator)
  "Join all STRINGS using SEPARATOR."
  (mapconcat 'identity strings separator))

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

164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
(defsubst string-trim-left (string)
  "Remove leading whitespace from STRING."
  (if (string-match "\\`[ \t\n\r]+" string)
      (replace-match "" t t string)
    string))

(defsubst string-trim-right (string)
  "Remove trailing whitespace from STRING."
  (if (string-match "[ \t\n\r]+\\'" string)
      (replace-match "" t t string)
    string))

(defsubst string-trim (string)
  "Remove leading and trailing whitespace from STRING."
  (string-trim-left (string-trim-right string)))

180 181
(defsubst string-blank-p (string)
  "Check whether STRING is either empty or only whitespace."
182
  (string-match-p "\\`[ \t\n\r]*\\'" string))
183

184 185 186 187 188 189 190 191 192 193 194 195
(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))

196
(provide 'subr-x)
197

198
;;; subr-x.el ends here