-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy patharrow-macros.lisp
120 lines (109 loc) · 4.99 KB
/
arrow-macros.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
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
;;;; arrow-macros.lisp
;;;;
;;;; Copyright 2015 hipeta ([email protected])
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php
(in-package :cl-user)
(defpackage arrow-macros
(:use :cl)
(:export :->
:->>
:some->
:some->>
:as->
:cond->
:cond->>
:-<>
:-<>>
:some-<>
:some-<>>
:<>))
(in-package :arrow-macros)
(defun arrow-macro (init exps &optional >>-p some-p)
(let ((exps (mapcar (lambda (exp)
(cond ((symbolp exp) `(,exp))
((and (typep exp 'cons) (eq 'function (car exp)))
(if >>-p
`(funcall (function ,(cadr exp)))
`(->> (funcall (function ,(cadr exp))))))
((and (typep exp 'cons) (eq 'lambda (car exp)))
(if >>-p
`(funcall ,exp)
`(->> (funcall ,exp))))
(t exp)))
exps)))
(cond (some-p
(let ((gblock (gensym)))
`(block ,gblock
,(cadr
(let ((init `(or ,init (return-from ,gblock nil))))
(if >>-p
(reduce (lambda (e1 e2)
`(or ,(append e2 (cons e1 nil)) (return-from ,gblock nil)))
(cons init exps))
(reduce (lambda (e1 e2)
`(or (,(car e2) ,e1 ,@(cdr e2)) (return-from ,gblock nil)))
(cons init exps))))))))
(>>-p (reduce (lambda (e1 e2) (append e2 (cons e1 nil))) (cons init exps)))
(t (reduce (lambda (e1 e2) `(,(car e2) ,e1 ,@(cdr e2))) (cons init exps))))))
(defmacro -> (init &body exps) (arrow-macro init exps))
(defmacro ->> (init &body exps) (arrow-macro init exps t))
(defmacro some-> (init &body exps) (arrow-macro init exps nil t))
(defmacro some->> (init &body exps) (arrow-macro init exps t t))
(defmacro as-> (init var &body exps)
`(let ((,var ,init))
,var
,@(loop for (exp next-exp) on exps
collect (if next-exp `(setf ,var ,exp) exp))))
(defun cond-arrow-macro (init exps &optional >>-p)
(let ((gvar (gensym)) (arrow (if >>-p '->> '->)))
`(-> ,init
,@(loop for (pred form) on exps by #'cddr
collect `(lambda (,gvar) (if ,pred (,arrow ,gvar ,form) ,gvar))))))
(defmacro cond-> (init &body exps) (cond-arrow-macro init exps))
(defmacro cond->> (init &body exps) (cond-arrow-macro init exps t))
;; (define-symbol-macro <> (error "do not use <> outside the scope of diamond-wand macros!"))
(defun has-diamond% (form env)
(handler-bind ((hu.dwim.walker:walker-warning #'muffle-warning))
(let* ((walked (hu.dwim.walker:walk-form
form
:environment (hu.dwim.walker:make-walk-environment env)))
(refs (append (hu.dwim.walker:collect-variable-references
walked
:type 'hu.dwim.walker:free-variable-reference-form)
(hu.dwim.walker:collect-variable-references
walked
:type 'hu.dwim.walker:unwalked-lexical-variable-reference-form))))
(find '<> (mapcar #'hu.dwim.walker:name-of refs)))))
(defun has-diamond (form env)
"Return true when the form uses <> as a variable reference."
;; Note that simple tree parsing does not work for the cases like
;; (let ((<> ...)) ...)
(handler-case (has-diamond% form env)
#+sbcl(sb-kernel::arg-count-error () nil)
#-sbcl(error () nil)))
(defun diamond-wand (init exps env &optional spear-p some-p)
(let ((gblock (gensym)))
(if some-p
`(block ,gblock
(let ((<> (or ,init (return-from ,gblock nil))))
<>
,@(loop for (exp next-exp) on exps collect
(let ((exp (cond ((has-diamond exp env) exp)
(spear-p `(->> <> ,exp))
(t `(-> <> ,exp)))))
(if next-exp
`(setf <> (or ,exp (return-from ,gblock nil)))
exp)))))
`(let ((<> ,init))
<>
,@(loop for (exp next-exp) on exps collect
(let ((exp (cond ((has-diamond exp env) exp)
(spear-p `(->> <> ,exp))
(t `(-> <> ,exp)))))
(if next-exp `(setf <> ,exp) exp)))))))
(defmacro -<> (init &body exps &environment env) (diamond-wand init exps env))
(defmacro -<>> (init &body exps &environment env) (diamond-wand init exps env t))
(defmacro some-<> (init &body exps &environment env) (diamond-wand init exps env nil t))
(defmacro some-<>> (init &body exps &environment env) (diamond-wand init exps env t t))