mirror of https://github.com/Chizi123/.emacs.d.git
view | history | commit | commitdiff
Chizi123
2018-11-18 c655eea759be1db69c5e6b45c228139d8390122a
commit | author | age
5cb5f7 1 ;;; anaphora.el --- anaphoric macros providing implicit temp variables  -*- lexical-binding: t -*-
C 2 ;;
3 ;; This code is in the public domain.
4 ;;
5 ;; Author: Roland Walker <walker@pobox.com>
6 ;; Homepage: http://github.com/rolandwalker/anaphora
7 ;; URL: http://raw.githubusercontent.com/rolandwalker/anaphora/master/anaphora.el
8 ;; Package-Version: 20180618.2200
9 ;; Version: 1.0.4
10 ;; Last-Updated: 18 Jun 2018
11 ;; EmacsWiki: Anaphora
12 ;; Keywords: extensions
13 ;;
14 ;;; Commentary:
15 ;;
16 ;; Quickstart
17 ;;
18 ;;     (require 'anaphora)
19 ;;
20 ;;     (awhen (big-long-calculation)
21 ;;       (foo it)      ; `it' is provided as
22 ;;       (bar it))     ; a temporary variable
23 ;;
24 ;;     ;; anonymous function to compute factorial using `self'
25 ;;     (alambda (x) (if (= x 0) 1 (* x (self (1- x)))))
26 ;;
27 ;;     ;; to fontify `it' and `self'
28 ;;     (with-eval-after-load "lisp-mode"
29 ;;       (anaphora-install-font-lock-keywords))
30 ;;
31 ;; Explanation
32 ;;
33 ;; Anaphoric expressions implicitly create one or more temporary
34 ;; variables which can be referred to during the expression.  This
35 ;; technique can improve clarity in certain cases.  It also enables
36 ;; recursion for anonymous functions.
37 ;;
38 ;; To use anaphora, place the anaphora.el library somewhere
39 ;; Emacs can find it, and add the following to your ~/.emacs file:
40 ;;
41 ;;     (require 'anaphora)
42 ;;
43 ;; The following macros are made available
44 ;;
45 ;;     `aand'
46 ;;     `ablock'
47 ;;     `acase'
48 ;;     `acond'
49 ;;     `aecase'
50 ;;     `aetypecase'
51 ;;     `aif'
52 ;;     `alambda'
53 ;;     `alet'
54 ;;     `aprog1'
55 ;;     `aprog2'
56 ;;     `atypecase'
57 ;;     `awhen'
58 ;;     `awhile'
59 ;;     `a+'
60 ;;     `a-'
61 ;;     `a*'
62 ;;     `a/'
63 ;;
64 ;; See Also
65 ;;
66 ;;     M-x customize-group RET anaphora RET
67 ;;     http://en.wikipedia.org/wiki/On_Lisp
68 ;;     http://en.wikipedia.org/wiki/Anaphoric_macro
69 ;;
70 ;; Notes
71 ;;
72 ;; Partially based on examples from the book "On Lisp", by Paul
73 ;; Graham.
74 ;;
75 ;; Compatibility and Requirements
76 ;;
77 ;;     GNU Emacs version 26.1           : yes
78 ;;     GNU Emacs version 25.x           : yes
79 ;;     GNU Emacs version 24.x           : yes
80 ;;     GNU Emacs version 23.x           : yes
81 ;;     GNU Emacs version 22.x           : yes
82 ;;     GNU Emacs version 21.x and lower : unknown
83 ;;
84 ;; Bugs
85 ;;
86 ;; TODO
87 ;;
88 ;;     better face for it and self
89 ;;
90 ;;; License
91 ;;
92 ;; All code contributed by the author to this library is placed in the
93 ;; public domain.  It is the author's belief that the portions adapted
94 ;; from examples in "On Lisp" are in the public domain.
95 ;;
96 ;; Regardless of the copyright status of individual functions, all
97 ;; code herein is free software, and is provided without any express
98 ;; or implied warranties.
99 ;;
100 ;;; Code:
101 ;;
102
103 ;;; requirements
104
105 ;; for declare, labels, do, block, case, ecase, typecase, etypecase
106 (require 'cl-lib)
107
108 ;;; customizable variables
109
110 ;;;###autoload
111 (defgroup anaphora nil
112   "Anaphoric macros providing implicit temp variables"
113   :version "1.0.4"
114   :link '(emacs-commentary-link :tag "Commentary" "anaphora")
115   :link '(url-link :tag "GitHub" "http://github.com/rolandwalker/anaphora")
116   :link '(url-link :tag "EmacsWiki" "http://emacswiki.org/emacs/Anaphora")
117   :prefix "anaphora-"
118   :group 'extensions)
119
120 ;;;###autoload
121 (defcustom anaphora-use-long-names-only nil
122   "Use only long names such as `anaphoric-if' instead of traditional `aif'."
123   :type 'boolean
124   :group 'anaphora)
125
126 ;;; font-lock
127
128 (defun anaphora-install-font-lock-keywords nil
129   "Fontify keywords `it' and `self'."
130   (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\<" (regexp-opt '("it" "self") 'paren) "\\>")
131                                               1 font-lock-variable-name-face)) 'append))
132
133 ;;; aliases
134
135 ;;;###autoload
136 (progn
137   (defun anaphora--install-traditional-aliases (&optional arg)
138     "Install traditional short aliases for anaphoric macros.
139
140 With negative numeric ARG, remove traditional aliases."
141     (let ((syms '(
142                   (if         .  t)
143                   (prog1      .  t)
144                   (prog2      .  t)
145                   (when       .  when)
146                   (while      .  t)
147                   (and        .  t)
148                   (cond       .  cond)
149                   (lambda     .  lambda)
150                   (block      .  block)
151                   (case       .  case)
152                   (ecase      .  ecase)
153                   (typecase   .  typecase)
154                   (etypecase  .  etypecase)
155                   (let        .  let)
156                   (+          .  t)
157                   (-          .  t)
158                   (*          .  t)
159                   (/          .  t)
160                   )))
161       (cond
162         ((and (numberp arg)
163               (< arg 0))
164          (dolist (cell syms)
165            (when (ignore-errors
166                    (eq (symbol-function (intern-soft (format "a%s" (car cell))))
167                                         (intern-soft (format "anaphoric-%s" (car cell)))))
168              (fmakunbound (intern (format "a%s" (car cell)))))))
169         (t
170          (dolist (cell syms)
171            (let* ((builtin (car cell))
172                   (traditional (intern (format "a%s" builtin)))
173                   (long (intern (format "anaphoric-%s" builtin))))
174              (defalias traditional long)
175              (put traditional 'lisp-indent-function
176                   (get builtin 'lisp-indent-function))
177              (put traditional 'edebug-form-spec (cdr cell)))))))))
178
179 ;;;###autoload
180 (unless anaphora-use-long-names-only
181   (anaphora--install-traditional-aliases))
182
183 ;;; macros
184
185 ;;;###autoload
186 (defmacro anaphoric-if (cond then &rest else)
187   "Like `if', but the result of evaluating COND is bound to `it'.
188
189 The variable `it' is available within THEN and ELSE.
190
191 COND, THEN, and ELSE are otherwise as documented for `if'."
192   (declare (debug t)
193            (indent 2))
194   `(let ((it ,cond))
195      (if it ,then ,@else)))
196
197 ;;;###autoload
198 (defmacro anaphoric-prog1 (first &rest body)
199   "Like `prog1', but the result of evaluating FIRST is bound to `it'.
200
201 The variable `it' is available within BODY.
202
203 FIRST and BODY are otherwise as documented for `prog1'."
204   (declare (debug t)
205            (indent 1))
206   `(let ((it ,first))
207      (progn ,@body)
208      it))
209
210 ;;;###autoload
211 (defmacro anaphoric-prog2 (form1 form2 &rest body)
212   "Like `prog2', but the result of evaluating FORM2 is bound to `it'.
213
214 The variable `it' is available within BODY.
215
216 FORM1, FORM2, and BODY are otherwise as documented for `prog2'."
217   (declare (debug t)
218            (indent 2))
219   `(progn
220      ,form1
221      (let ((it ,form2))
222        (progn ,@body)
223        it)))
224
225 ;;;###autoload
226 (defmacro anaphoric-when (cond &rest body)
227   "Like `when', but the result of evaluating COND is bound to `it'.
228
229 The variable `it' is available within BODY.
230
231 COND and BODY are otherwise as documented for `when'."
232   (declare (debug when)
233            (indent 1))
234   `(anaphoric-if ,cond
235        (progn ,@body)))
236
237 ;;;###autoload
238 (defmacro anaphoric-while (test &rest body)
239   "Like `while', but the result of evaluating TEST is bound to `it'.
240
241 The variable `it' is available within BODY.
242
243 TEST and BODY are otherwise as documented for `while'."
244   (declare (debug t)
245            (indent 1))
246   `(do ((it ,test ,test))
247        ((not it))
248      ,@body))
249
250 ;;;###autoload
251 (defmacro anaphoric-and (&rest conditions)
252   "Like `and', but the result of the previous condition is bound to `it'.
253
254 The variable `it' is available within all CONDITIONS after the
255 initial one.
256
257 CONDITIONS are otherwise as documented for `and'.
258
259 Note that some implementations of this macro bind only the first
260 condition to `it', rather than each successive condition."
261   (declare (debug t))
262   (cond
263     ((null conditions)
264      t)
265     ((null (cdr conditions))
266      (car conditions))
267     (t
268      `(anaphoric-if ,(car conditions) (anaphoric-and ,@(cdr conditions))))))
269
270 ;;;###autoload
271 (defmacro anaphoric-cond (&rest clauses)
272   "Like `cond', but the result of each condition is bound to `it'.
273
274 The variable `it' is available within the remainder of each of CLAUSES.
275
276 CLAUSES are otherwise as documented for `cond'."
277   (declare (debug cond))
278   (if (null clauses)
279       nil
280     (let ((cl1 (car clauses))
281           (sym (gensym)))
282       `(let ((,sym ,(car cl1)))
283          (if ,sym
284              (if (null ',(cdr cl1))
285                  ,sym
286                (let ((it ,sym)) ,@(cdr cl1)))
287            (anaphoric-cond ,@(cdr clauses)))))))
288
289 ;;;###autoload
290 (defmacro anaphoric-lambda (args &rest body)
291   "Like `lambda', but the function may refer to itself as `self'.
292
293 ARGS and BODY are otherwise as documented for `lambda'."
294   (declare (debug lambda)
295            (indent defun))
296   `(cl-labels ((self ,args ,@body))
297      #'self))
298
299 ;;;###autoload
300 (defmacro anaphoric-block (name &rest body)
301   "Like `block', but the result of the previous expression is bound to `it'.
302
303 The variable `it' is available within all expressions of BODY
304 except the initial one.
305
306 NAME and BODY are otherwise as documented for `block'."
307   (declare (debug block)
308            (indent 1))
309   `(cl-block ,name
310      ,(funcall (anaphoric-lambda (body)
311                  (cl-case (length body)
312                    (0 nil)
313                    (1 (car body))
314                    (t `(let ((it ,(car body)))
315                          ,(self (cdr body))))))
316                body)))
317
318 ;;;###autoload
319 (defmacro anaphoric-case (expr &rest clauses)
320   "Like `case', but the result of evaluating EXPR is bound to `it'.
321
322 The variable `it' is available within CLAUSES.
323
324 EXPR and CLAUSES are otherwise as documented for `case'."
325   (declare (debug case)
326            (indent 1))
327   `(let ((it ,expr))
328      (cl-case it ,@clauses)))
329
330 ;;;###autoload
331 (defmacro anaphoric-ecase (expr &rest clauses)
332   "Like `ecase', but the result of evaluating EXPR is bound to `it'.
333
334 The variable `it' is available within CLAUSES.
335
336 EXPR and CLAUSES are otherwise as documented for `ecase'."
337   (declare (debug ecase)
338            (indent 1))
339   `(let ((it ,expr))
340      (cl-ecase it ,@clauses)))
341
342 ;;;###autoload
343 (defmacro anaphoric-typecase (expr &rest clauses)
344   "Like `typecase', but the result of evaluating EXPR is bound to `it'.
345
346 The variable `it' is available within CLAUSES.
347
348 EXPR and CLAUSES are otherwise as documented for `typecase'."
349   (declare (debug typecase)
350            (indent 1))
351   `(let ((it ,expr))
352      (cl-typecase it ,@clauses)))
353
354 ;;;###autoload
355 (defmacro anaphoric-etypecase (expr &rest clauses)
356   "Like `etypecase', but result of evaluating EXPR is bound to `it'.
357
358 The variable `it' is available within CLAUSES.
359
360 EXPR and CLAUSES are otherwise as documented for `etypecase'."
361   (declare (debug etypecase)
362            (indent 1))
363   `(let ((it ,expr))
364      (cl-etypecase it ,@clauses)))
365
366 ;;;###autoload
367 (defmacro anaphoric-let (form &rest body)
368   "Like `let', but the result of evaluating FORM is bound to `it'.
369
370 FORM and BODY are otherwise as documented for `let'."
371   (declare (debug let)
372            (indent 1))
373   `(let ((it ,form))
374      (progn ,@body)))
375
376 ;;;###autoload
377 (defmacro anaphoric-+ (&rest numbers-or-markers)
378   "Like `+', but the result of evaluating the previous expression is bound to `it'.
379
380 The variable `it' is available within all expressions after the
381 initial one.
382
383 NUMBERS-OR-MARKERS are otherwise as documented for `+'."
384   (declare (debug t))
385   (cond
386     ((null numbers-or-markers)
387      0)
388     (t
389      `(let ((it ,(car numbers-or-markers)))
390         (+ it (anaphoric-+ ,@(cdr numbers-or-markers)))))))
391
392 ;;;###autoload
393 (defmacro anaphoric-- (&optional number-or-marker &rest numbers-or-markers)
394   "Like `-', but the result of evaluating the previous expression is bound to `it'.
395
396 The variable `it' is available within all expressions after the
397 initial one.
398
399 NUMBER-OR-MARKER and NUMBERS-OR-MARKERS are otherwise as
400 documented for `-'."
401   (declare (debug t))
402   (cond
403     ((null number-or-marker)
404      0)
405     ((null numbers-or-markers)
406      `(- ,number-or-marker))
407     (t
408      `(let ((it ,(car numbers-or-markers)))
409         (- ,number-or-marker (+ it (anaphoric-+ ,@(cdr numbers-or-markers))))))))
410
411 ;;;###autoload
412 (defmacro anaphoric-* (&rest numbers-or-markers)
413   "Like `*', but the result of evaluating the previous expression is bound to `it'.
414
415 The variable `it' is available within all expressions after the
416 initial one.
417
418 NUMBERS-OR-MARKERS are otherwise as documented for `*'."
419   (declare (debug t))
420   (cond
421     ((null numbers-or-markers)
422      1)
423     (t
424      `(let ((it ,(car numbers-or-markers)))
425         (* it (anaphoric-* ,@(cdr numbers-or-markers)))))))
426
427 ;;;###autoload
428 (defmacro anaphoric-/ (dividend divisor &rest divisors)
429   "Like `/', but the result of evaluating the previous divisor is bound to `it'.
430
431 The variable `it' is available within all expressions after the
432 first divisor.
433
434 DIVIDEND, DIVISOR, and DIVISORS are otherwise as documented for `/'."
435   (declare (debug t))
436   (cond
437     ((null divisors)
438      `(/ ,dividend ,divisor))
439     (t
440      `(let ((it ,divisor))
441         (/ ,dividend (* it (anaphoric-* ,@divisors)))))))
442
443 (provide 'anaphora)
444
445 ;;
446 ;; Emacs
447 ;;
448 ;; Local Variables:
449 ;; indent-tabs-mode: nil
450 ;; mangle-whitespace: t
451 ;; require-final-newline: t
452 ;; coding: utf-8
453 ;; byte-compile-warnings: (not cl-functions redefine)
454 ;; End:
455 ;;
456 ;; LocalWords: Anaphora EXPR awhen COND ARGS alambda ecase typecase
457 ;; LocalWords: etypecase aprog aand acond ablock acase aecase alet
458 ;; LocalWords: atypecase aetypecase
459 ;;
460
461 ;;; anaphora.el ends here