/[slime]/slime/contrib/slime-asdf.el
ViewVC logotype

Contents of /slime/contrib/slime-asdf.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.34 - (show annotations)
Fri Feb 1 20:43:13 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.33: +12 -9 lines
* slime-asdf.el (slime-determine-asdf-system): Don't call
slime-to-lisp-filename on NIL.
Reported by Tamas Papp.
1 (define-slime-contrib slime-asdf
2 "ASDF support."
3 (:authors "Daniel Barlow <dan@telent.net>"
4 "Marco Baringer <mb@bese.it>"
5 "Edi Weitz <edi@agharta.de>"
6 "Stas Boukarev <stassats@gmail.com>"
7 "Tobias C Rittweiler <tcr@freebits.de>")
8 (:license "GPL")
9 (:slime-dependencies slime-repl)
10 (:swank-dependencies swank-asdf)
11 (:on-load
12 (add-to-list 'slime-edit-uses-xrefs :depends-on t)
13 (define-key slime-who-map [?d] 'slime-who-depends-on)))
14
15 ;;; NOTE: `system-name' is a predefined variable in Emacs. Try to
16 ;;; avoid it as local variable name.
17
18 ;;; Utilities
19
20 (defgroup slime-asdf nil
21 "ASDF support for Slime."
22 :prefix "slime-asdf-"
23 :group 'slime)
24
25 (defvar slime-system-history nil
26 "History list for ASDF system names.")
27
28 (defun slime-read-system-name (&optional prompt
29 default-value
30 determine-default-accurately)
31 "Read a system name from the minibuffer, prompting with PROMPT.
32 If no `default-value' is given, one is tried to be determined: if
33 `determine-default-accurately' is true, by an RPC request which
34 grovels through all defined systems; if it's not true, by looking
35 in the directory of the current buffer."
36 (let* ((completion-ignore-case nil)
37 (prompt (or prompt "System"))
38 (system-names (slime-eval `(swank:list-asdf-systems)))
39 (default-value
40 (or default-value
41 (if determine-default-accurately
42 (slime-determine-asdf-system (buffer-file-name)
43 (slime-current-package))
44 (slime-find-asd-file (or default-directory
45 (buffer-file-name))
46 system-names))))
47 (prompt (concat prompt (if default-value
48 (format " (default `%s'): " default-value)
49 ": "))))
50 (completing-read prompt (slime-bogus-completion-alist system-names)
51 nil nil nil
52 'slime-system-history default-value)))
53
54
55
56 (defun slime-find-asd-file (directory system-names)
57 "Tries to find an ASDF system definition file in the
58 `directory' and returns it if it's in `system-names'."
59 (let ((asd-files
60 (directory-files (file-name-directory directory) nil "\.asd$")))
61 (loop for system in asd-files
62 for candidate = (file-name-sans-extension system)
63 when (find candidate system-names :test #'string-equal)
64 do (return candidate))))
65
66 (defun slime-determine-asdf-system (filename buffer-package)
67 "Try to determine the asdf system that `filename' belongs to."
68 (slime-eval
69 `(swank:asdf-determine-system ,(and filename
70 (slime-to-lisp-filename filename))
71 ,buffer-package)))
72
73 (defun slime-who-depends-on-rpc (system)
74 (slime-eval `(swank:who-depends-on ,system)))
75
76 (defcustom slime-asdf-collect-notes t
77 "Collect and display notes produced by the compiler.
78
79 See also `slime-highlight-compiler-notes' and
80 `slime-compilation-finished-hook'."
81 :group 'slime-asdf)
82
83 (defun slime-asdf-operation-finished-function (system)
84 (if slime-asdf-collect-notes
85 #'slime-compilation-finished
86 (lexical-let ((system system))
87 (lambda (result)
88 (let (slime-highlight-compiler-notes
89 slime-compilation-finished-hook)
90 (slime-compilation-finished result))))))
91
92 (defun slime-oos (system operation &rest keyword-args)
93 "Operate On System."
94 (slime-save-some-lisp-buffers)
95 (slime-display-output-buffer)
96 (message "Performing ASDF %S%s on system %S"
97 operation (if keyword-args (format " %S" keyword-args) "")
98 system)
99 (slime-repl-shortcut-eval-async
100 `(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args)
101 (slime-asdf-operation-finished-function system)))
102
103
104 ;;; Interactive functions
105
106 (defun slime-load-system (&optional system)
107 "Compile and load an ASDF system.
108
109 Default system name is taken from first file matching *.asd in current
110 buffer's working directory"
111 (interactive (list (slime-read-system-name)))
112 (slime-oos system 'load-op))
113
114 (defun slime-open-system (name &optional load)
115 "Open all files in an ASDF system."
116 (interactive (list (slime-read-system-name)))
117 (when (or load
118 (and (called-interactively-p)
119 (not (slime-eval `(swank:asdf-system-loaded-p ,name)))
120 (y-or-n-p "Load it? ")))
121 (slime-load-system name))
122 (slime-eval-async
123 `(swank:asdf-system-files ,name)
124 (lambda (files)
125 (when files
126 (let ((files (mapcar 'slime-from-lisp-filename
127 (nreverse files))))
128 (find-file-other-window (car files))
129 (mapc 'find-file (cdr files)))))))
130
131 (defun slime-browse-system (name)
132 "Browse files in an ASDF system using Dired."
133 (interactive (list (slime-read-system-name)))
134 (slime-eval-async `(swank:asdf-system-directory ,name)
135 (lambda (directory)
136 (when directory
137 (dired (slime-from-lisp-filename directory))))))
138
139 (if (fboundp 'rgrep)
140 (defun slime-rgrep-system (sys-name regexp)
141 "Run `rgrep' on the base directory of an ASDF system."
142 (interactive (progn (grep-compute-defaults)
143 (list (slime-read-system-name nil nil t)
144 (grep-read-regexp))))
145 (rgrep regexp "*.lisp"
146 (slime-from-lisp-filename
147 (slime-eval `(swank:asdf-system-directory ,sys-name)))))
148 (defun slime-rgrep-system ()
149 (interactive)
150 (error "This command is only supported on GNU Emacs >21.x.")))
151
152 (if (boundp 'multi-isearch-next-buffer-function)
153 (defun slime-isearch-system (sys-name)
154 "Run `isearch-forward' on the files of an ASDF system."
155 (interactive (list (slime-read-system-name nil nil t)))
156 (let* ((files (mapcar 'slime-from-lisp-filename
157 (slime-eval `(swank:asdf-system-files ,sys-name))))
158 (multi-isearch-next-buffer-function
159 (lexical-let*
160 ((buffers-forward (mapcar #'find-file-noselect files))
161 (buffers-backward (reverse buffers-forward)))
162 #'(lambda (current-buffer wrap)
163 ;; Contrarily to the the docstring of
164 ;; `multi-isearch-next-buffer-function', the first
165 ;; arg is not necessarily a buffer. Report sent
166 ;; upstream. (2009-11-17)
167 (setq current-buffer (or current-buffer (current-buffer)))
168 (let* ((buffers (if isearch-forward
169 buffers-forward
170 buffers-backward)))
171 (if wrap
172 (car buffers)
173 (second (memq current-buffer buffers))))))))
174 (isearch-forward)))
175 (defun slime-isearch-system ()
176 (interactive)
177 (error "This command is only supported on GNU Emacs >23.1.x.")))
178
179 (defun slime-read-query-replace-args (format-string &rest format-args)
180 (let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
181 (minibuffer-local-map slime-minibuffer-map)
182 (common (query-replace-read-args (apply #'format format-string
183 format-args)
184 t t)))
185 (list (nth 0 common) (nth 1 common) (nth 2 common))))
186
187 (defun slime-query-replace-system (name from to &optional delimited)
188 "Run `query-replace' on an ASDF system."
189 (interactive (let ((system (slime-read-system-name nil nil t)))
190 (cons system (slime-read-query-replace-args
191 "Query replace throughout `%s'" system))))
192 (condition-case c
193 ;; `tags-query-replace' actually uses `query-replace-regexp'
194 ;; internally.
195 (tags-query-replace (regexp-quote from) to delimited
196 '(mapcar 'slime-from-lisp-filename
197 (slime-eval `(swank:asdf-system-files ,name))))
198 (error
199 ;; Kludge: `tags-query-replace' does not actually return but
200 ;; signals an unnamed error with the below error
201 ;; message. (<=23.1.2, at least.)
202 (unless (string-equal (error-message-string c) "All files processed")
203 (signal (car c) (cdr c))) ; resignal
204 t)))
205
206 (defun slime-query-replace-system-and-dependents
207 (name from to &optional delimited)
208 "Run `query-replace' on an ASDF system and all the systems
209 depending on it."
210 (interactive (let ((system (slime-read-system-name nil nil t)))
211 (cons system (slime-read-query-replace-args
212 "Query replace throughout `%s'+dependencies"
213 system))))
214 (slime-query-replace-system name from to delimited)
215 (dolist (dep (slime-who-depends-on-rpc name))
216 (when (y-or-n-p (format "Descend into system `%s'? " dep))
217 (slime-query-replace-system dep from to delimited))))
218
219 (defun slime-delete-system-fasls (name)
220 "Delete FASLs produced by compiling a system."
221 (interactive (list (slime-read-system-name)))
222 (slime-repl-shortcut-eval-async
223 `(swank:delete-system-fasls ,name)
224 'message))
225
226 (defun slime-reload-system (system)
227 "Reload an ASDF system without reloading its dependencies."
228 (interactive (list (slime-read-system-name)))
229 (slime-save-some-lisp-buffers)
230 (slime-display-output-buffer)
231 (message "Performing ASDF LOAD-OP on system %S" system)
232 (slime-repl-shortcut-eval-async
233 `(swank:reload-system ,system)
234 (slime-asdf-operation-finished-function system)))
235
236 (defun slime-who-depends-on (system-name)
237 (interactive (list (slime-read-system-name)))
238 (slime-xref :depends-on system-name))
239
240 (defun slime-save-system (system)
241 "Save files belonging to an ASDF system."
242 (interactive (list (slime-read-system-name)))
243 (slime-eval-async
244 `(swank:asdf-system-files ,system)
245 (lambda (files)
246 (dolist (file files)
247 (let ((buffer (get-file-buffer (slime-from-lisp-filename file))))
248 (when buffer
249 (with-current-buffer buffer
250 (save-buffer buffer)))))
251 (message "Done."))))
252
253
254 ;;; REPL shortcuts
255
256 (defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
257 (:handler (lambda ()
258 (interactive)
259 (slime-oos (slime-read-system-name) 'load-op :force t)))
260 (:one-liner "Recompile and load an ASDF system."))
261
262 (defslime-repl-shortcut slime-repl-load-system ("load-system")
263 (:handler (lambda ()
264 (interactive)
265 (slime-oos (slime-read-system-name) 'load-op)))
266 (:one-liner "Compile (as needed) and load an ASDF system."))
267
268 (defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
269 (:handler (lambda ()
270 (interactive)
271 (slime-oos (slime-read-system-name) 'test-op :force t)))
272 (:one-liner "Compile (as needed) and force test an ASDF system."))
273
274 (defslime-repl-shortcut slime-repl-test-system ("test-system")
275 (:handler (lambda ()
276 (interactive)
277 (slime-oos (slime-read-system-name) 'test-op)))
278 (:one-liner "Compile (as needed) and test an ASDF system."))
279
280 (defslime-repl-shortcut slime-repl-compile-system ("compile-system")
281 (:handler (lambda ()
282 (interactive)
283 (slime-oos (slime-read-system-name) 'compile-op)))
284 (:one-liner "Compile (but not load) an ASDF system."))
285
286 (defslime-repl-shortcut slime-repl-compile/force-system
287 ("force-compile-system")
288 (:handler (lambda ()
289 (interactive)
290 (slime-oos (slime-read-system-name) 'compile-op :force t)))
291 (:one-liner "Recompile (but not load) an ASDF system."))
292
293 (defslime-repl-shortcut slime-repl-open-system ("open-system")
294 (:handler 'slime-open-system)
295 (:one-liner "Open all files in an ASDF system."))
296
297 (defslime-repl-shortcut slime-repl-browse-system ("browse-system")
298 (:handler 'slime-browse-system)
299 (:one-liner "Browse files in an ASDF system using Dired."))
300
301 (defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls")
302 (:handler 'slime-delete-system-fasls)
303 (:one-liner "Delete FASLs of an ASDF system."))
304
305 (defslime-repl-shortcut slime-repl-reload-system ("reload-system")
306 (:handler 'slime-reload-system)
307 (:one-liner "Recompile and load an ASDF system."))
308
309 (provide 'slime-asdf)

  ViewVC Help
Powered by ViewVC 1.1.5