emacs.d/elpa/anaphora-20180618.2200/anaphora.el

;;; anaphora.el --- anaphoric macros providing implicit temp variables  -*- lexical-binding: t -*-
;;
;; This code is in the public domain.
;;
;; Author: Roland Walker <walker@pobox.com>
;; Homepage: http://github.com/rolandwalker/anaphora
;; URL: http://raw.githubusercontent.com/rolandwalker/anaphora/master/anaphora.el
;; Package-Version: 20180618.2200
;; Version: 1.0.4
;; Last-Updated: 18 Jun 2018
;; EmacsWiki: Anaphora
;; Keywords: extensions
;;
;;; Commentary:
;;
;; Quickstart
;;
;;     (require 'anaphora)
;;
;;     (awhen (big-long-calculation)
;;       (foo it)      ; `it' is provided as
;;       (bar it))     ; a temporary variable
;;
;;     ;; anonymous function to compute factorial using `self'
;;     (alambda (x) (if (= x 0) 1 (* x (self (1- x)))))
;;
;;     ;; to fontify `it' and `self'
;;     (with-eval-after-load "lisp-mode"
;;       (anaphora-install-font-lock-keywords))
;;
;; Explanation
;;
;; Anaphoric expressions implicitly create one or more temporary
;; variables which can be referred to during the expression.  This
;; technique can improve clarity in certain cases.  It also enables
;; recursion for anonymous functions.
;;
;; To use anaphora, place the anaphora.el library somewhere
;; Emacs can find it, and add the following to your ~/.emacs file:
;;
;;     (require 'anaphora)
;;
;; The following macros are made available
;;
;;     `aand'
;;     `ablock'
;;     `acase'
;;     `acond'
;;     `aecase'
;;     `aetypecase'
;;     `aif'
;;     `alambda'
;;     `alet'
;;     `aprog1'
;;     `aprog2'
;;     `atypecase'
;;     `awhen'
;;     `awhile'
;;     `a+'
;;     `a-'
;;     `a*'
;;     `a/'
;;
;; See Also
;;
;;     M-x customize-group RET anaphora RET
;;     http://en.wikipedia.org/wiki/On_Lisp
;;     http://en.wikipedia.org/wiki/Anaphoric_macro
;;
;; Notes
;;
;; Partially based on examples from the book "On Lisp", by Paul
;; Graham.
;;
;; Compatibility and Requirements
;;
;;     GNU Emacs version 26.1           : yes
;;     GNU Emacs version 25.x           : yes
;;     GNU Emacs version 24.x           : yes
;;     GNU Emacs version 23.x           : yes
;;     GNU Emacs version 22.x           : yes
;;     GNU Emacs version 21.x and lower : unknown
;;
;; Bugs
;;
;; TODO
;;
;;     better face for it and self
;;
;;; License
;;
;; All code contributed by the author to this library is placed in the
;; public domain.  It is the author's belief that the portions adapted
;; from examples in "On Lisp" are in the public domain.
;;
;; Regardless of the copyright status of individual functions, all
;; code herein is free software, and is provided without any express
;; or implied warranties.
;;
;;; Code:
;;

;;; requirements

;; for declare, labels, do, block, case, ecase, typecase, etypecase
(require 'cl-lib)

;;; customizable variables

;;;###autoload
(defgroup anaphora nil
  "Anaphoric macros providing implicit temp variables"
  :version "1.0.4"
  :link '(emacs-commentary-link :tag "Commentary" "anaphora")
  :link '(url-link :tag "GitHub" "http://github.com/rolandwalker/anaphora")
  :link '(url-link :tag "EmacsWiki" "http://emacswiki.org/emacs/Anaphora")
  :prefix "anaphora-"
  :group 'extensions)

;;;###autoload
(defcustom anaphora-use-long-names-only nil
  "Use only long names such as `anaphoric-if' instead of traditional `aif'."
  :type 'boolean
  :group 'anaphora)

;;; font-lock

(defun anaphora-install-font-lock-keywords nil
  "Fontify keywords `it' and `self'."
  (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\<" (regexp-opt '("it" "self") 'paren) "\\>")
                                              1 font-lock-variable-name-face)) 'append))

;;; aliases

;;;###autoload
(progn
  (defun anaphora--install-traditional-aliases (&optional arg)
    "Install traditional short aliases for anaphoric macros.

With negative numeric ARG, remove traditional aliases."
    (let ((syms '(
                  (if         .  t)
                  (prog1      .  t)
                  (prog2      .  t)
                  (when       .  when)
                  (while      .  t)
                  (and        .  t)
                  (cond       .  cond)
                  (lambda     .  lambda)
                  (block      .  block)
                  (case       .  case)
                  (ecase      .  ecase)
                  (typecase   .  typecase)
                  (etypecase  .  etypecase)
                  (let        .  let)
                  (+          .  t)
                  (-          .  t)
                  (*          .  t)
                  (/          .  t)
                  )))
      (cond
        ((and (numberp arg)
              (< arg 0))
         (dolist (cell syms)
           (when (ignore-errors
                   (eq (symbol-function (intern-soft (format "a%s" (car cell))))
                                        (intern-soft (format "anaphoric-%s" (car cell)))))
             (fmakunbound (intern (format "a%s" (car cell)))))))
        (t
         (dolist (cell syms)
           (let* ((builtin (car cell))
                  (traditional (intern (format "a%s" builtin)))
                  (long (intern (format "anaphoric-%s" builtin))))
             (defalias traditional long)
             (put traditional 'lisp-indent-function
                  (get builtin 'lisp-indent-function))
             (put traditional 'edebug-form-spec (cdr cell)))))))))

;;;###autoload
(unless anaphora-use-long-names-only
  (anaphora--install-traditional-aliases))

;;; macros

;;;###autoload
(defmacro anaphoric-if (cond then &rest else)
  "Like `if', but the result of evaluating COND is bound to `it'.

The variable `it' is available within THEN and ELSE.

COND, THEN, and ELSE are otherwise as documented for `if'."
  (declare (debug t)
           (indent 2))
  `(let ((it ,cond))
     (if it ,then ,@else)))

;;;###autoload
(defmacro anaphoric-prog1 (first &rest body)
  "Like `prog1', but the result of evaluating FIRST is bound to `it'.

The variable `it' is available within BODY.

FIRST and BODY are otherwise as documented for `prog1'."
  (declare (debug t)
           (indent 1))
  `(let ((it ,first))
     (progn ,@body)
     it))

;;;###autoload
(defmacro anaphoric-prog2 (form1 form2 &rest body)
  "Like `prog2', but the result of evaluating FORM2 is bound to `it'.

The variable `it' is available within BODY.

FORM1, FORM2, and BODY are otherwise as documented for `prog2'."
  (declare (debug t)
           (indent 2))
  `(progn
     ,form1
     (let ((it ,form2))
       (progn ,@body)
       it)))

;;;###autoload
(defmacro anaphoric-when (cond &rest body)
  "Like `when', but the result of evaluating COND is bound to `it'.

The variable `it' is available within BODY.

COND and BODY are otherwise as documented for `when'."
  (declare (debug when)
           (indent 1))
  `(anaphoric-if ,cond
       (progn ,@body)))

;;;###autoload
(defmacro anaphoric-while (test &rest body)
  "Like `while', but the result of evaluating TEST is bound to `it'.

The variable `it' is available within BODY.

TEST and BODY are otherwise as documented for `while'."
  (declare (debug t)
           (indent 1))
  `(do ((it ,test ,test))
       ((not it))
     ,@body))

;;;###autoload
(defmacro anaphoric-and (&rest conditions)
  "Like `and', but the result of the previous condition is bound to `it'.

The variable `it' is available within all CONDITIONS after the
initial one.

CONDITIONS are otherwise as documented for `and'.

Note that some implementations of this macro bind only the first
condition to `it', rather than each successive condition."
  (declare (debug t))
  (cond
    ((null conditions)
     t)
    ((null (cdr conditions))
     (car conditions))
    (t
     `(anaphoric-if ,(car conditions) (anaphoric-and ,@(cdr conditions))))))

;;;###autoload
(defmacro anaphoric-cond (&rest clauses)
  "Like `cond', but the result of each condition is bound to `it'.

The variable `it' is available within the remainder of each of CLAUSES.

CLAUSES are otherwise as documented for `cond'."
  (declare (debug cond))
  (if (null clauses)
      nil
    (let ((cl1 (car clauses))
          (sym (gensym)))
      `(let ((,sym ,(car cl1)))
         (if ,sym
             (if (null ',(cdr cl1))
                 ,sym
               (let ((it ,sym)) ,@(cdr cl1)))
           (anaphoric-cond ,@(cdr clauses)))))))

;;;###autoload
(defmacro anaphoric-lambda (args &rest body)
  "Like `lambda', but the function may refer to itself as `self'.

ARGS and BODY are otherwise as documented for `lambda'."
  (declare (debug lambda)
           (indent defun))
  `(cl-labels ((self ,args ,@body))
     #'self))

;;;###autoload
(defmacro anaphoric-block (name &rest body)
  "Like `block', but the result of the previous expression is bound to `it'.

The variable `it' is available within all expressions of BODY
except the initial one.

NAME and BODY are otherwise as documented for `block'."
  (declare (debug block)
           (indent 1))
  `(cl-block ,name
     ,(funcall (anaphoric-lambda (body)
                 (cl-case (length body)
                   (0 nil)
                   (1 (car body))
                   (t `(let ((it ,(car body)))
                         ,(self (cdr body))))))
               body)))

;;;###autoload
(defmacro anaphoric-case (expr &rest clauses)
  "Like `case', but the result of evaluating EXPR is bound to `it'.

The variable `it' is available within CLAUSES.

EXPR and CLAUSES are otherwise as documented for `case'."
  (declare (debug case)
           (indent 1))
  `(let ((it ,expr))
     (cl-case it ,@clauses)))

;;;###autoload
(defmacro anaphoric-ecase (expr &rest clauses)
  "Like `ecase', but the result of evaluating EXPR is bound to `it'.

The variable `it' is available within CLAUSES.

EXPR and CLAUSES are otherwise as documented for `ecase'."
  (declare (debug ecase)
           (indent 1))
  `(let ((it ,expr))
     (cl-ecase it ,@clauses)))

;;;###autoload
(defmacro anaphoric-typecase (expr &rest clauses)
  "Like `typecase', but the result of evaluating EXPR is bound to `it'.

The variable `it' is available within CLAUSES.

EXPR and CLAUSES are otherwise as documented for `typecase'."
  (declare (debug typecase)
           (indent 1))
  `(let ((it ,expr))
     (cl-typecase it ,@clauses)))

;;;###autoload
(defmacro anaphoric-etypecase (expr &rest clauses)
  "Like `etypecase', but result of evaluating EXPR is bound to `it'.

The variable `it' is available within CLAUSES.

EXPR and CLAUSES are otherwise as documented for `etypecase'."
  (declare (debug etypecase)
           (indent 1))
  `(let ((it ,expr))
     (cl-etypecase it ,@clauses)))

;;;###autoload
(defmacro anaphoric-let (form &rest body)
  "Like `let', but the result of evaluating FORM is bound to `it'.

FORM and BODY are otherwise as documented for `let'."
  (declare (debug let)
           (indent 1))
  `(let ((it ,form))
     (progn ,@body)))

;;;###autoload
(defmacro anaphoric-+ (&rest numbers-or-markers)
  "Like `+', but the result of evaluating the previous expression is bound to `it'.

The variable `it' is available within all expressions after the
initial one.

NUMBERS-OR-MARKERS are otherwise as documented for `+'."
  (declare (debug t))
  (cond
    ((null numbers-or-markers)
     0)
    (t
     `(let ((it ,(car numbers-or-markers)))
        (+ it (anaphoric-+ ,@(cdr numbers-or-markers)))))))

;;;###autoload
(defmacro anaphoric-- (&optional number-or-marker &rest numbers-or-markers)
  "Like `-', but the result of evaluating the previous expression is bound to `it'.

The variable `it' is available within all expressions after the
initial one.

NUMBER-OR-MARKER and NUMBERS-OR-MARKERS are otherwise as
documented for `-'."
  (declare (debug t))
  (cond
    ((null number-or-marker)
     0)
    ((null numbers-or-markers)
     `(- ,number-or-marker))
    (t
     `(let ((it ,(car numbers-or-markers)))
        (- ,number-or-marker (+ it (anaphoric-+ ,@(cdr numbers-or-markers))))))))

;;;###autoload
(defmacro anaphoric-* (&rest numbers-or-markers)
  "Like `*', but the result of evaluating the previous expression is bound to `it'.

The variable `it' is available within all expressions after the
initial one.

NUMBERS-OR-MARKERS are otherwise as documented for `*'."
  (declare (debug t))
  (cond
    ((null numbers-or-markers)
     1)
    (t
     `(let ((it ,(car numbers-or-markers)))
        (* it (anaphoric-* ,@(cdr numbers-or-markers)))))))

;;;###autoload
(defmacro anaphoric-/ (dividend divisor &rest divisors)
  "Like `/', but the result of evaluating the previous divisor is bound to `it'.

The variable `it' is available within all expressions after the
first divisor.

DIVIDEND, DIVISOR, and DIVISORS are otherwise as documented for `/'."
  (declare (debug t))
  (cond
    ((null divisors)
     `(/ ,dividend ,divisor))
    (t
     `(let ((it ,divisor))
        (/ ,dividend (* it (anaphoric-* ,@divisors)))))))

(provide 'anaphora)

;;
;; Emacs
;;
;; Local Variables:
;; indent-tabs-mode: nil
;; mangle-whitespace: t
;; require-final-newline: t
;; coding: utf-8
;; byte-compile-warnings: (not cl-functions redefine)
;; End:
;;
;; LocalWords: Anaphora EXPR awhen COND ARGS alambda ecase typecase
;; LocalWords: etypecase aprog aand acond ablock acase aecase alet
;; LocalWords: atypecase aetypecase
;;

;;; anaphora.el ends here