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 (provide 'subr-x)
 202
 203 ;;; subr-x.el ends here