-
Notifications
You must be signed in to change notification settings - Fork 6
/
arrow-macros.lisp
143 lines (127 loc) · 6.14 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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;;;; arrow-macros.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; 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))
(defparameter *diamond-wands* '(-<> -<>> some-<> some-<>>))
(defun diamond-wand-symbol-p (sym) (member sym *diamond-wands* :test #'eq))
(defun has-diamond (exp)
(labels ((rec (exp)
(cond ((eq exp '<>) (return-from has-diamond t))
; inner diamond wand can refer to outer <> symbol only in initial form
((and (listp exp) (diamond-wand-symbol-p (car exp)))
(rec (cadr exp)))
((listp exp) (mapcar #'rec exp))
(t nil))))
(rec exp)
nil))
(defun replace-diamond (exp diamond-exp)
(cond ((eq exp '<>) diamond-exp)
((and (listp exp) (diamond-wand-symbol-p (car exp)))
(let ((init (replace-diamond (cadr exp) diamond-exp)))
(case (car exp)
(-<> (diamond-wand init (cddr exp)))
(-<>> (diamond-wand init (cddr exp) t))
(some-<> (diamond-wand init (cddr exp) nil t))
(some-<>> (diamond-wand init (cddr exp) t t)))))
((listp exp) (mapcar (lambda (x) (replace-diamond x diamond-exp)) exp))
(t exp)))
(defun diamond-wand% (diamond-exp exps some-p)
(let ((gblock (gensym)))
(labels ((rec (diamond-exp exps)
(let ((diamond-exp (if some-p
`(or ,diamond-exp (return-from ,gblock nil))
diamond-exp)))
(cond ((eq (car exps) '<!>)
(let ((gvar (gensym)))
`(let ((,gvar ,diamond-exp))
,(rec gvar (cdr exps)))))
(exps (rec (replace-diamond (car exps) diamond-exp) (cdr exps)))
(t (if some-p
(cadr diamond-exp) ; outermost parenthesis shouldn't be sandwiched by `(or ~~ (return-from ,gblock nil))
diamond-exp))))))
(if some-p
`(block ,gblock ,(rec diamond-exp exps))
(rec diamond-exp exps)))))
(defun diamond-wand (init exps &optional >>-p some-p)
(let* (; preprocessing for lambda, function, <!>, one symbol expressions
(exps (loop for exp in exps collect (cond ((and (symbolp exp)
(not (eq exp '<!>)) `(,exp)))
((and (consp exp) (eq 'function (car exp)))
`(funcall ,exp <>))
((and (consp exp) (eq 'lambda (car exp)))
`(funcall ,exp <>))
(t exp))))
; supplement expressions with diamond symbols
(exps (loop for exp in exps collect (cond ((eq '<!> exp) exp)
((has-diamond exp) exp)
(>>-p
`(,(car exp) ,@(cdr exp) <>))
(t
`(,(car exp) <> ,@(cdr exp)))))))
(diamond-wand% init exps some-p)))
(defmacro -<> (init &body exps) (diamond-wand init exps))
(defmacro -<>> (init &body exps) (diamond-wand init exps t))
(defmacro some-<> (init &body exps) (diamond-wand init exps nil t))
(defmacro some-<>> (init &body exps) (diamond-wand init exps t t))