lisp/emacs-lisp/subr-x.el

   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 ;; 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) (debug ((&rest (symbolp form)) form body)))
 124   (when (and (<= (length bindings) 2)
 125              (not (listp (car bindings))))
 126     ;; Adjust the single binding case
 127     (setq bindings (list bindings)))
 128   `(let* ,(internal--build-bindings bindings)
 129      (if ,(car (internal--listify (car (last bindings))))
 130          ,then
 131        ,@else)))
 132
 133 (defmacro when-let (bindings &rest body)
 134   "Process BINDINGS and if all values are non-nil eval BODY.
 135 Argument BINDINGS is a list of tuples whose car is a symbol to be
 136 bound and (optionally) used in BODY, and its cadr is a sexp to be
 137 evalled to set symbol's value.  In the special case you only want
 138 to bind a single value, BINDINGS can just be a plain tuple."
 139   (declare (indent 1) (debug if-let))
 140   (list 'if-let bindings (macroexp-progn body)))
 141
 142 (defsubst hash-table-keys (hash-table)
 143   "Return a list of keys in HASH-TABLE."
 144   (let ((keys '()))
 145     (maphash (lambda (k _v) (push k keys)) hash-table)
 146     keys))
 147
 148 (defsubst hash-table-values (hash-table)
 149   "Return a list of values in HASH-TABLE."
 150   (let ((values '()))
 151     (maphash (lambda (_k v) (push v values)) hash-table)
 152     values))
 153
 154 (defsubst string-empty-p (string)
 155   "Check whether STRING is empty."
 156   (string= string ""))
 157
 158 (defsubst string-join (strings &optional separator)
 159   "Join all STRINGS using SEPARATOR."
 160   (mapconcat 'identity strings separator))
 161
 162 (define-obsolete-function-alias 'string-reverse 'reverse "25.1")
 163
 164 (defsubst string-trim-left (string)
 165   "Remove leading whitespace from STRING."
 166   (if (string-match "\\`[ \t\n\r]+" string)
 167       (replace-match "" t t string)
 168     string))
 169
 170 (defsubst string-trim-right (string)
 171   "Remove trailing whitespace from STRING."
 172   (if (string-match "[ \t\n\r]+\\'" string)
 173       (replace-match "" t t string)
 174     string))
 175
 176 (defsubst string-trim (string)
 177   "Remove leading and trailing whitespace from STRING."
 178   (string-trim-left (string-trim-right string)))
 179
 180 (defsubst string-blank-p (string)
 181   "Check whether STRING is either empty or only whitespace."
 182   (string-match-p "\\`[ \t\n\r]*\\'" string))
 183
 184 (defsubst string-remove-prefix (prefix string)
 185   "Remove PREFIX from STRING if present."
 186   (if (string-prefix-p prefix string)
 187       (substring string (length prefix))
 188     string))
 189
 190 (defsubst string-remove-suffix (suffix string)
 191   "Remove SUFFIX from STRING if present."
 192   (if (string-suffix-p suffix string)
 193       (substring string 0 (- (length string) (length suffix)))
 194     string))
 195
 196 (provide 'subr-x)
 197
 198 ;;; subr-x.el ends here