-
Notifications
You must be signed in to change notification settings - Fork 11
/
sly-asdf.el
364 lines (298 loc) · 13.7 KB
/
sly-asdf.el
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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
;;; sly-asdf.el --- ASDF system support for SLY -*- lexical-binding: t; -*-
;;
;; Version: 0.1
;; URL: https://github.com/mmgeorge/sly-asdf
;; Keywords: languages, lisp, sly, asdf
;; Package-Requires: ((emacs "24.3")(sly "1.0.0-beta2")(popup "0.5.3"))
;; Maintainer: Matt George <[email protected]>
;;
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; `sly-asdf` is an external contrib for SLY that provides additional
;; support for working with asdf projects. Ported from the original slime
;; contrib. See <https://github.com/slime/slime/blob/master/contrib/slime-asdf.el>.
;;
;; See README.md
;;
;;; Code:
(require 'sly)
(require 'cl-lib)
(require 'grep)
(defvar sly-mrepl-shortcut-alist) ;; declared in sly-mrepl
(defvar sly-asdf-find-system-file-max-depth 10
"Max recursive depth for finding an asd system definition from the current directory.")
(defvar sly-asdf-shortcut-alist
'(("load-system" . sly-asdf-load-system)
("reload-system" . sly-asdf-reload-system)
("test-system" . sly-asdf-test-system)
("browse-system" . sly-asdf-browse-system)
("open-system" . sly-asdf-open-system)
("save-system" . sly-asdf-save-system)))
(define-sly-contrib sly-asdf
"ASDF system support"
(:authors "Daniel Barlow <[email protected]>"
"Marco Baringer <[email protected]>"
"Edi Weitz <[email protected]>"
"Stas Boukarev <[email protected]>"
"Tobias C Rittweiler <[email protected]>")
(:license "GPL")
(:slynk-dependencies slynk-asdf)
(:on-load
(setq sly-mrepl-shortcut-alist
(append sly-mrepl-shortcut-alist sly-asdf-shortcut-alist))))
(defvar *sly-asdf-lisp-extensions* (list "lisp")
"File extensions to look for when finding open Lisp files.")
(defun sly-asdf--lisp-buffer-p (buffer)
"Check whether BUFFER refers to a Lisp buffer."
(member (file-name-extension (buffer-name buffer)) *sly-asdf-lisp-extensions*))
(defun sly-asdf--current-lisp-buffers ()
"Traverses the current `buffer-list`, returning those buffers with a .lisp extension."
(cl-remove-if-not #'sly-asdf--lisp-buffer-p (buffer-list)))
;;; Interactive functions
(defun sly-asdf-load-system (&optional system)
"Compile and load an ASDF SYSTEM.
Default system name is taken from first file matching *.asd in current
buffer's working directory"
(interactive (list (sly-asdf-read-system-name)))
(sly-asdf-oos system 'load-op :force t))
(defun sly-asdf-reload-system (system)
"Compile and load an ASDF SYSTEM without reloading dependencies.
Default system name is taken from first file matching *.asd in current
buffer's working directory"
(interactive (list (sly-asdf-read-system-name)))
(sly-asdf-save-some-lisp-buffers)
;;(sly-asdf-display-output-buffer)
(message "Performing ASDF LOAD-OP on system %S" system)
(sly-eval-async
`(slynk-asdf:reload-system ,system)
#'(lambda (result)
(sly-asdf-oos-finished result (current-buffer))
(run-hooks 'sly-asdf--after-oos-hook))))
(defun sly-asdf-compile-system (&optional system)
"Compile and load an ASDF SYSTEM.
Default system name is taken from first file matching *.asd in current
buffer's working directory"
(interactive (list (sly-asdf-read-system-name)))
(sly-asdf-oos system 'compile-op))
(defun sly-asdf-test-system (&optional system)
"Compile and test an ASDF SYSTEM.
Default system name is taken from first file matching *.asd in current
buffer's working directory"
(interactive (list (sly-asdf-read-system-name)))
(sly-asdf-oos system 'test-op :force t))
(defun sly-asdf-save-system (system)
"Save files belonging to an ASDF SYSTEM."
(interactive (list (sly-asdf-read-system-name)))
(sly-eval-async
`(slynk-asdf:asdf-system-files ,system)
(lambda (files)
(dolist (file files)
(let ((buffer (get-file-buffer (sly-from-lisp-filename file))))
(when buffer
(with-current-buffer buffer
(save-buffer buffer)))))
(message "Done."))))
(defun sly-asdf-browse-system (name)
"Browse files in an ASDF system NAME using Dired."
(interactive (list (sly-asdf-read-system-name)))
(sly-eval-async `(slynk-asdf:asdf-system-directory ,name)
(lambda (directory)
(when directory
(dired (sly-from-lisp-filename directory))))))
(defun sly-asdf-open-system (name &optional load interactive)
"Open all files implicated in an ASDF system, in separate emacs buffers."
(interactive (list (sly-asdf-read-system-name) nil t))
(when (or load
(and interactive
(not (sly-eval `(slynk-asdf:asdf-system-loaded-p ,name)))
(y-or-n-p "Load it? ")))
(sly-asdf-load-system name))
(sly-eval-async
`(slynk-asdf:asdf-system-files ,name)
(lambda (files)
(when files
(let ((files (mapcar 'sly-from-lisp-filename
(nreverse files))))
(find-file-other-window (car files))
(mapc 'find-file (cdr files)))))))
(defun sly-asdf-rgrep-system (sys-name regexp)
"Run `rgrep' for REGEXP for SYS-NAME on the base directory of an ASDF system."
(interactive (progn (grep-compute-defaults)
(list (sly-asdf-read-system-name nil nil)
(grep-read-regexp))))
(rgrep regexp "*.lisp"
(sly-from-lisp-filename
(sly-eval `(slynk-asdf:asdf-system-directory ,sys-name)))))
(defun sly-asdf-isearch-system (sys-name)
"Run function `isearch-forward' on the files of an ASDF system SYS-NAME."
(interactive (list (sly-asdf-read-system-name nil nil)))
(let* ((files (mapcar 'sly-from-lisp-filename
(sly-eval `(slynk-asdf:asdf-system-files ,sys-name))))
(multi-isearch-next-buffer-function
(let*
((buffers-forward (mapcar #'find-file-noselect files))
(buffers-backward (reverse buffers-forward)))
#'(lambda (current-buffer wrap)
;; Contrarily to the docstring of
;; `multi-isearch-next-buffer-function', the first
;; arg is not necessarily a buffer. Report sent
;; upstream. (2009-11-17)
(setq current-buffer (or current-buffer (current-buffer)))
(let* ((buffers (if isearch-forward
buffers-forward
buffers-backward)))
(if wrap
(car buffers)
(cl-second (memq current-buffer buffers))))))))
(isearch-forward)))
(defun sly-asdf-query-replace-system (name from to &optional delimited)
"Query-replace in all files of an ASDF system.
NAME is the ASDF's sytem name, FROM is the string to replace, TO
its replacement, and the optional DELIMITED when true restricts
replacements to word-delimited matches."
(interactive (let ((system (sly-asdf-read-system-name)))
(cons system (sly-asdf-read-query-replace-args
"Query replace throughout `%s'" system))))
(fileloop-initialize-replace
(regexp-quote from) to
(mapcar #'sly-from-lisp-filename
(sly-eval `(slynk-asdf:asdf-system-files ,name)))
'default
delimited)
(fileloop-continue))
(defun sly-asdf-query-replace-system-and-dependents
(name from to &optional delimited)
"Run `query-replace' on an ASDF system with NAME given FROM and TO.
DELIMITED is optional. Includes the base system and all other systems it depending on it."
(interactive (let ((system (sly-asdf-read-system-name)))
(cons system (sly-asdf-read-query-replace-args
"Query replace throughout `%s'+dependencies"
system))))
(sly-asdf-query-replace-system name from to delimited)
(dolist (dep (sly-asdf-who-depends-on-rpc name))
(when (y-or-n-p (format "Descend into system `%s'? " dep))
(sly-asdf-query-replace-system dep from to delimited))))
(defun sly-asdf-delete-system-fasls (name)
"Delete FASLs produced by compiling a system with NAME."
(interactive (list (sly-asdf-read-system-name)))
(sly-eval-async
`(slynk-asdf:delete-system-fasls ,name)
'message))
(defun sly-asdf-who-depends-on (sys-name)
"Determine who depends on system with SYS-NAME."
(interactive (list (sly-asdf-read-system-name)))
(sly-xref :depends-on sys-name))
;;; Utilities
(defgroup sly-asdf nil
"ASDF support for Sly."
:prefix "sly-asdf-"
:group 'sly)
(defvar sly-asdf-system-history nil
"History list for ASDF system names.")
(defun sly-asdf-bogus-completion-alist (list)
"Make an alist out of LIST.
The same elements go in the CAR, and nil in the CDR. To support the
apparently very stupid `try-completions' interface, that wants an
alist but ignores CDRs."
(mapcar (lambda (x) (cons x nil)) list))
(defun sly-asdf-save-some-lisp-buffers ()
"Compatability."
;;(if slime-repl-only-save-lisp-buffers
;;(save-some-buffers nil (lambda ()
;;(and (memq major-mode slime-lisp-modes)
;;(not (null buffer-file-name)))))
(save-some-buffers))
(defun sly-asdf-read-query-replace-args (format-string &rest format-args)
"Read query args, displaying FORMAT-STRING with FORMAT-ARGS."
(let* ((common (query-replace-read-args (apply #'format format-string
format-args)
t t)))
(list (nth 0 common) (nth 1 common) (nth 2 common))))
(defun sly-asdf-read-system-name (&optional prompt default-value)
"Read a system name from the minibuffer, prompting with PROMPT.
If no DEFAULT-VALUE is given, one is tried to be determined: if
DETERMINE-DEFAULT-ACCURATELY is true, by an RPC request which
grovels through all defined systems; if it's not true, by looking
in the directory of the current buffer."
(let* ((completion-ignore-case nil)
(prompt (or prompt "System"))
(system-names (sly-eval `(slynk-asdf:list-asdf-systems)))
(default-value
(or default-value (sly-asdf-find-current-system) (car sly-asdf-system-history)))
(prompt (concat prompt (if default-value
(format " (default `%s'): " default-value)
": "))))
(let ((history-delete-duplicates t))
(completing-read prompt (sly-asdf-bogus-completion-alist system-names)
nil nil nil
'sly-asdf-system-history default-value))))
(cl-defun sly-asdf-find-current-system (&optional buffer)
"Find the name of the current asd system."
(setf buffer (or buffer
(cl-find-if #'buffer-file-name (sly-asdf--current-lisp-buffers))
(current-buffer)))
(let* ((buffer-file-name (buffer-file-name buffer))
(directory (if buffer-file-name
(file-name-directory buffer-file-name)
default-directory))
(system-file (sly-asdf-find-system-file directory)))
(when system-file
(file-name-base system-file))))
(cl-defun sly-asdf-find-system-file (directory &optional (depth sly-asdf-find-system-file-max-depth))
"Find the first file in the current DIRECTORY or a parent of DIRECTORY that includes a .asd file."
(let ((fname (directory-file-name directory)))
(or
(cl-find-if #'(lambda (file) (string-equal "asd" (file-name-extension file)))
(directory-files directory))
(and (> depth 0)
(file-name-directory fname)
(sly-asdf-find-system-file (file-name-directory fname) (1- depth))))))
(defun sly-asdf-determine-asdf-system (filename buffer-package)
"Try to determine the asdf system provided BUFFER-PACKAGE that FILENAME belongs to."
(sly-eval
`(slynk-asdf:asdf-determine-system ,(and filename
(sly-to-lisp-filename filename))
,buffer-package)))
(defun sly-asdf-who-depends-on-rpc (system)
"Find who depends on RPC for SYSTEM."
(sly-eval `(slynk-asdf:who-depends-on ,system)))
(defun sly-asdf-oos (system operation &rest keyword-args)
"Operate On System. Apply the given OPERATION on SYSTEM provided KEYWORD-ARGS."
(message "Performing ASDF %S%s on system %S"
operation (if keyword-args (format " %S" keyword-args) "")
system)
(sly-eval-async
`(slynk-asdf:operate-on-system-for-emacs ,system ',operation ,@keyword-args)
#'(lambda (result)
(sly-asdf-oos-finished result (current-buffer))
(run-hooks 'sly-asdf--after-oos-hook))))
(defun sly-asdf-oos-finished (result buffer &optional message)
"Called when compilation is finished"
(let ((notes (sly-compilation-result.notes result))
(duration (sly-compilation-result.duration result))
(successp (sly-compilation-result.successp result)))
(sly-show-note-counts notes duration successp t)
(setf sly-last-compilation-result result) ;; For interactive use
(when sly-highlight-compiler-notes
(sly-highlight-notes notes))
(when message (message message))
;; Conditionally show compilation log and other options defined in settings
(run-hook-with-args 'sly-compilation-finished-hook successp notes buffer t)))
;;;###autoload
(with-eval-after-load 'sly
(add-to-list 'sly-contribs 'sly-asdf 'append))
(provide 'sly-asdf)
;;; sly-asdf.el ends here