-
Notifications
You must be signed in to change notification settings - Fork 3
/
import-set.lisp
223 lines (205 loc) · 8.88 KB
/
import-set.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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
(defpackage :vernacular/import-set
(:documentation "Syntax for import sets.
Influenced by, but not identical with, the R6RS syntax.")
(:use :cl :alexandria :serapeum
:vernacular/types)
(:import-from :trivia :match :ematch)
(:shadow :drop-prefix)
(:export
:expand-import-set
:import-set=))
(in-package :vernacular/import-set)
(defcondition import-set-condition ()
())
(defcondition import-set-error (import-set-condition simple-error)
((import-set :initarg :import-set)))
(defcondition invalid-import-set (import-set-error)
()
(:report (lambda (c s)
(with-slots (import-set) c
(format s "Invalid import set:~%~s" import-set)))))
(defcondition missing-id (import-set-error)
((id :initarg :id))
(:report (lambda (c s)
(with-slots (id import-set) c
(format s "Missing id ~s in import set:~%~s" id import-set)))))
(defun rename-import (import new-name)
`(,(private-side import)
:as
(,(public-ns new-name)
,(public-name new-name))))
(defun same-binding? (x y)
(and (equal (public-side x) (public-side y))
(equal (private-side x) (private-side y))))
(defun expand-import-set (import-set get-exports
&key (package *package*))
"Expand IMPORT-SET, an R6RS-style import set, into a list of imports.
Imports are aliased to ensure that they are accessible in the current
package (or PACKAGE, if specified.)"
(unless (functionp get-exports)
(setf get-exports (constantly get-exports)))
(fbindrec ((get-exports
(once
(lambda ()
(let ((exports (funcall get-exports)))
;; Strip reserved names (default, main, etc.).
(remove (find-package :vernacular/well-known)
exports
:key (compose #'symbol-package #'public-name))))))
(local-name
(lambda (export)
(intern (string (public-name export)) package)))
(rec
(lambda (import-set)
(match import-set
;; Compat.
((list* :import-set import-sets)
(mappend #'rec import-sets))
;; Coerce everything to a variable
(:all
(loop for export in (get-exports)
for sym = (local-name export)
collect `(,export :as ,sym)))
;; Coerce everything to a function.
(:all-as-functions
(loop for export in (get-exports)
for sym = (local-name export)
collect `(,(public-side export) :as #',sym)))
(:all-as-setters
;; Coerce everything to a setf function.
(loop for export in (get-exports)
for sym = (local-name export)
collect `(,(public-side export) :as #'(setf ,sym))))
;; Just marked variables.
(:all-vars
(loop for export in (get-exports)
when (eql (public-ns export) 'nil)
collect `(,(public-side export) :as ,(local-name export))))
;; Just marked setf functions.
(:all-setters
(loop for export in (get-exports)
when (eql (public-ns export) 'setf)
collect `(,(public-side export) :as #'(setf ,(local-name export)))))
;; All functions, plus any setf functions with the same names.
(:all-functions
(let* ((functions (keep 'function (get-exports) :key #'public-ns))
(setters (keep 'setf (get-exports) :key #'public-ns))
(function-setters
(filter (lambda (setter)
(find (public-name setter)
functions
:key #'public-name))
setters)))
(rec (append functions function-setters))))
;; Remove everything but IDs from IMPORT-SET.
((list* :only import-set ids)
(only (rec import-set) ids))
;; Remove IDs from IMPORT-SET.
((list* :except import-set ids)
(except (rec import-set) ids))
;; Renames are a list of (old-name new-name).
((list* :rename import-set renames)
(rename (rec import-set) renames))
;; Add PREFIX to every local name in IMPORT-SET.
((list :prefix import-set prefix)
(prefix (rec import-set) prefix))
;; Same thing as :prefix.
((list :add-prefix import-set prefix)
(rec `(:prefix ,import-set ,prefix)))
;; Remove PREFIX from every local name in IMPORT-SET.
((list :drop-prefix import-set prefix)
(drop-prefix (rec import-set) prefix))
;; Alias is just like rename, except that the old
;; binding isn't removed.
((list* :alias import-set renames)
(alias (rec import-set) renames))
((type keyword)
(error 'invalid-import-set
:import-set import-set))
;; Imports per se.
((and sym (type symbol))
(list `(,sym :as ,(local-name sym))))
((function-spec ns symbol)
(list `((function (,ns ,symbol)) :as (function (,ns ,(local-name symbol))))))
((ns ns symbol)
(list `((,ns ,symbol) :as (,ns ,(local-name symbol)))))
;; Leave explicit aliases unchanged.
((and export (list _ :as _)) (list export))
;; Descend into lists.
((type list)
(mappend #'rec import-set))
(otherwise
(error 'invalid-import-set
:import-set import-set))))))
(remove-duplicates (rec import-set) :test #'same-binding?)))
(defun only (import-set ids)
(reduce (lambda (out id)
(if-let (import (find-id id import-set))
(cons import out)
(error 'missing-id
:id id
:import-set import-set)))
ids
:initial-value nil))
(defun except (import-set ids)
(reduce (lambda (import-set id)
(if-let (import (find-id id import-set))
(remove import import-set)
(error 'missing-id
:id id
:import-set import-set)))
ids
:initial-value import-set))
(defun rename (import-set renames)
(rename-alias-common import-set renames t))
(defun alias (import-set renames)
(rename-alias-common import-set renames nil))
(defun rename-alias-common (import-set renames remove?)
(reduce (lambda (import-set renaming)
(destructuring-bind (old-name new-name) renaming
(if-let (import (find-id old-name import-set))
(cons (rename-import import new-name)
(if remove?
(remove import import-set)
import-set))
(error 'missing-id
:id old-name
:import-set import-set))))
renames
:initial-value import-set))
(defun prefix (import-set prefix)
(mass-rename import-set (op (symbolicate prefix _))))
(defun drop-prefix (import-set prefix)
(flet ((drop-prefix (symbol)
(eif (string^= prefix symbol)
(intern (drop (length (string prefix))
(symbol-name symbol))
(symbol-package symbol))
symbol)))
(mass-rename import-set #'drop-prefix)))
(defun mass-rename (import-set rename-fn)
(loop for import in import-set
for new-name = (frob-name (public-side import) rename-fn)
collect (rename-import import new-name)))
(defun frob-name (spec frob)
(fbind (frob)
`(,(public-ns spec)
,(frob (public-name spec)))))
(defun find-id (id imports)
(find (public-side id)
imports
:key #'public-side
:test #'equal))
(defun import-set= (set1 set2)
(set-equal set1 set2
:key #'public-side
:test (lambda (x y)
(let ((x
(match x
((list nil x) x)
(t x)))
(y
(match y
((list nil y) y)
(t y))))
(equal x y)))))