313 lines
12 KiB
EmacsLisp
313 lines
12 KiB
EmacsLisp
(require 'slime)
|
||
(require 'cl-lib)
|
||
(require 'grep)
|
||
|
||
(define-slime-contrib slime-asdf
|
||
"ASDF support."
|
||
(:authors "Daniel Barlow <dan@telent.net>"
|
||
"Marco Baringer <mb@bese.it>"
|
||
"Edi Weitz <edi@agharta.de>"
|
||
"Stas Boukarev <stassats@gmail.com>"
|
||
"Tobias C Rittweiler <tcr@freebits.de>")
|
||
(:license "GPL")
|
||
(:slime-dependencies slime-repl)
|
||
(:swank-dependencies swank-asdf)
|
||
(:on-load
|
||
(add-to-list 'slime-edit-uses-xrefs :depends-on t)
|
||
(define-key slime-who-map [?d] 'slime-who-depends-on)))
|
||
|
||
;;; NOTE: `system-name' is a predefined variable in Emacs. Try to
|
||
;;; avoid it as local variable name.
|
||
|
||
;;; Utilities
|
||
|
||
(defgroup slime-asdf nil
|
||
"ASDF support for Slime."
|
||
:prefix "slime-asdf-"
|
||
:group 'slime)
|
||
|
||
(defvar slime-system-history nil
|
||
"History list for ASDF system names.")
|
||
|
||
(defun slime-read-system-name (&optional prompt
|
||
default-value
|
||
determine-default-accurately)
|
||
"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 (slime-eval `(swank:list-asdf-systems)))
|
||
(default-value
|
||
(or default-value
|
||
(if determine-default-accurately
|
||
(slime-determine-asdf-system (buffer-file-name)
|
||
(slime-current-package))
|
||
(slime-find-asd-file (or default-directory
|
||
(buffer-file-name))
|
||
system-names))))
|
||
(prompt (concat prompt (if default-value
|
||
(format " (default `%s'): " default-value)
|
||
": "))))
|
||
(completing-read prompt (slime-bogus-completion-alist system-names)
|
||
nil nil nil
|
||
'slime-system-history default-value)))
|
||
|
||
|
||
|
||
(defun slime-find-asd-file (directory system-names)
|
||
"Tries to find an ASDF system definition file in the
|
||
`directory' and returns it if it's in `system-names'."
|
||
(let ((asd-files
|
||
(directory-files (file-name-directory directory) nil "\.asd$")))
|
||
(cl-loop for system in asd-files
|
||
for candidate = (file-name-sans-extension system)
|
||
when (cl-find candidate system-names :test #'string-equal)
|
||
do (cl-return candidate))))
|
||
|
||
(defun slime-determine-asdf-system (filename buffer-package)
|
||
"Try to determine the asdf system that `filename' belongs to."
|
||
(slime-eval
|
||
`(swank:asdf-determine-system ,(and filename
|
||
(slime-to-lisp-filename filename))
|
||
,buffer-package)))
|
||
|
||
(defun slime-who-depends-on-rpc (system)
|
||
(slime-eval `(swank:who-depends-on ,system)))
|
||
|
||
(defcustom slime-asdf-collect-notes t
|
||
"Collect and display notes produced by the compiler.
|
||
|
||
See also `slime-highlight-compiler-notes' and
|
||
`slime-compilation-finished-hook'."
|
||
:group 'slime-asdf)
|
||
|
||
(defun slime-asdf-operation-finished-function (system)
|
||
(if slime-asdf-collect-notes
|
||
#'slime-compilation-finished
|
||
(slime-curry (lambda (system result)
|
||
(let (slime-highlight-compiler-notes
|
||
slime-compilation-finished-hook)
|
||
(slime-compilation-finished result)))
|
||
system)))
|
||
|
||
(defun slime-oos (system operation &rest keyword-args)
|
||
"Operate On System."
|
||
(slime-save-some-lisp-buffers)
|
||
(slime-display-output-buffer)
|
||
(message "Performing ASDF %S%s on system %S"
|
||
operation (if keyword-args (format " %S" keyword-args) "")
|
||
system)
|
||
(slime-repl-shortcut-eval-async
|
||
`(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args)
|
||
(slime-asdf-operation-finished-function system)))
|
||
|
||
|
||
;;; Interactive functions
|
||
|
||
(defun slime-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 (slime-read-system-name)))
|
||
(slime-oos system 'load-op))
|
||
|
||
(defun slime-open-system (name &optional load interactive)
|
||
"Open all files in an ASDF system."
|
||
(interactive (list (slime-read-system-name) nil t))
|
||
(when (or load
|
||
(and interactive
|
||
(not (slime-eval `(swank:asdf-system-loaded-p ,name)))
|
||
(y-or-n-p "Load it? ")))
|
||
(slime-load-system name))
|
||
(slime-eval-async
|
||
`(swank:asdf-system-files ,name)
|
||
(lambda (files)
|
||
(when files
|
||
(let ((files (mapcar 'slime-from-lisp-filename
|
||
(nreverse files))))
|
||
(find-file-other-window (car files))
|
||
(mapc 'find-file (cdr files)))))))
|
||
|
||
(defun slime-browse-system (name)
|
||
"Browse files in an ASDF system using Dired."
|
||
(interactive (list (slime-read-system-name)))
|
||
(slime-eval-async `(swank:asdf-system-directory ,name)
|
||
(lambda (directory)
|
||
(when directory
|
||
(dired (slime-from-lisp-filename directory))))))
|
||
|
||
(if (fboundp 'rgrep)
|
||
(defun slime-rgrep-system (sys-name regexp)
|
||
"Run `rgrep' on the base directory of an ASDF system."
|
||
(interactive (progn (grep-compute-defaults)
|
||
(list (slime-read-system-name nil nil t)
|
||
(grep-read-regexp))))
|
||
(rgrep regexp "*.lisp"
|
||
(slime-from-lisp-filename
|
||
(slime-eval `(swank:asdf-system-directory ,sys-name)))))
|
||
(defun slime-rgrep-system ()
|
||
(interactive)
|
||
(error "This command is only supported on GNU Emacs >21.x.")))
|
||
|
||
(if (boundp 'multi-isearch-next-buffer-function)
|
||
(defun slime-isearch-system (sys-name)
|
||
"Run `isearch-forward' on the files of an ASDF system."
|
||
(interactive (list (slime-read-system-name nil nil t)))
|
||
(let* ((files (mapcar 'slime-from-lisp-filename
|
||
(slime-eval `(swank:asdf-system-files ,sys-name))))
|
||
(multi-isearch-next-buffer-function
|
||
(lexical-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)
|
||
(second (memq current-buffer buffers))))))))
|
||
(isearch-forward)))
|
||
(defun slime-isearch-system ()
|
||
(interactive)
|
||
(error "This command is only supported on GNU Emacs >23.1.x.")))
|
||
|
||
(defun slime-read-query-replace-args (format-string &rest format-args)
|
||
(let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
|
||
(minibuffer-local-map slime-minibuffer-map)
|
||
(common (query-replace-read-args (apply #'format format-string
|
||
format-args)
|
||
t t)))
|
||
(list (nth 0 common) (nth 1 common) (nth 2 common))))
|
||
|
||
(defun slime-query-replace-system (name from to &optional delimited)
|
||
"Run `query-replace' on an ASDF system."
|
||
(interactive (let ((system (slime-read-system-name nil nil t)))
|
||
(cons system (slime-read-query-replace-args
|
||
"Query replace throughout `%s'" system))))
|
||
(condition-case c
|
||
;; `tags-query-replace' actually uses `query-replace-regexp'
|
||
;; internally.
|
||
(tags-query-replace (regexp-quote from) to delimited
|
||
'(mapcar 'slime-from-lisp-filename
|
||
(slime-eval `(swank:asdf-system-files ,name))))
|
||
(error
|
||
;; Kludge: `tags-query-replace' does not actually return but
|
||
;; signals an unnamed error with the below error
|
||
;; message. (<=23.1.2, at least.)
|
||
(unless (string-equal (error-message-string c) "All files processed")
|
||
(signal (car c) (cdr c))) ; resignal
|
||
t)))
|
||
|
||
(defun slime-query-replace-system-and-dependents
|
||
(name from to &optional delimited)
|
||
"Run `query-replace' on an ASDF system and all the systems
|
||
depending on it."
|
||
(interactive (let ((system (slime-read-system-name nil nil t)))
|
||
(cons system (slime-read-query-replace-args
|
||
"Query replace throughout `%s'+dependencies"
|
||
system))))
|
||
(slime-query-replace-system name from to delimited)
|
||
(dolist (dep (slime-who-depends-on-rpc name))
|
||
(when (y-or-n-p (format "Descend into system `%s'? " dep))
|
||
(slime-query-replace-system dep from to delimited))))
|
||
|
||
(defun slime-delete-system-fasls (name)
|
||
"Delete FASLs produced by compiling a system."
|
||
(interactive (list (slime-read-system-name)))
|
||
(slime-repl-shortcut-eval-async
|
||
`(swank:delete-system-fasls ,name)
|
||
'message))
|
||
|
||
(defun slime-reload-system (system)
|
||
"Reload an ASDF system without reloading its dependencies."
|
||
(interactive (list (slime-read-system-name)))
|
||
(slime-save-some-lisp-buffers)
|
||
(slime-display-output-buffer)
|
||
(message "Performing ASDF LOAD-OP on system %S" system)
|
||
(slime-repl-shortcut-eval-async
|
||
`(swank:reload-system ,system)
|
||
(slime-asdf-operation-finished-function system)))
|
||
|
||
(defun slime-who-depends-on (system-name)
|
||
(interactive (list (slime-read-system-name)))
|
||
(slime-xref :depends-on system-name))
|
||
|
||
(defun slime-save-system (system)
|
||
"Save files belonging to an ASDF system."
|
||
(interactive (list (slime-read-system-name)))
|
||
(slime-eval-async
|
||
`(swank:asdf-system-files ,system)
|
||
(lambda (files)
|
||
(dolist (file files)
|
||
(let ((buffer (get-file-buffer (slime-from-lisp-filename file))))
|
||
(when buffer
|
||
(with-current-buffer buffer
|
||
(save-buffer buffer)))))
|
||
(message "Done."))))
|
||
|
||
|
||
;;; REPL shortcuts
|
||
|
||
(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
|
||
(:handler (lambda ()
|
||
(interactive)
|
||
(slime-oos (slime-read-system-name) 'load-op :force t)))
|
||
(:one-liner "Recompile and load an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-load-system ("load-system")
|
||
(:handler (lambda ()
|
||
(interactive)
|
||
(slime-oos (slime-read-system-name) 'load-op)))
|
||
(:one-liner "Compile (as needed) and load an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
|
||
(:handler (lambda ()
|
||
(interactive)
|
||
(slime-oos (slime-read-system-name) 'test-op :force t)))
|
||
(:one-liner "Recompile and test an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-test-system ("test-system")
|
||
(:handler (lambda ()
|
||
(interactive)
|
||
(slime-oos (slime-read-system-name) 'test-op)))
|
||
(:one-liner "Compile (as needed) and test an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-compile-system ("compile-system")
|
||
(:handler (lambda ()
|
||
(interactive)
|
||
(slime-oos (slime-read-system-name) 'compile-op)))
|
||
(:one-liner "Compile (but not load) an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-compile/force-system
|
||
("force-compile-system")
|
||
(:handler (lambda ()
|
||
(interactive)
|
||
(slime-oos (slime-read-system-name) 'compile-op :force t)))
|
||
(:one-liner "Recompile (but not completely load) an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-open-system ("open-system")
|
||
(:handler 'slime-open-system)
|
||
(:one-liner "Open all files in an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-browse-system ("browse-system")
|
||
(:handler 'slime-browse-system)
|
||
(:one-liner "Browse files in an ASDF system using Dired."))
|
||
|
||
(defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls")
|
||
(:handler 'slime-delete-system-fasls)
|
||
(:one-liner "Delete FASLs of an ASDF system."))
|
||
|
||
(defslime-repl-shortcut slime-repl-reload-system ("reload-system")
|
||
(:handler 'slime-reload-system)
|
||
(:one-liner "Recompile and load an ASDF system."))
|
||
|
||
(provide 'slime-asdf)
|