Vous ne pouvez pas sélectionner plus de 25 sujets
Les noms de sujets doivent commencer par une lettre ou un nombre, peuvent contenir des tirets ('-') et peuvent comporter jusqu'à 35 caractères.
313 lignes
12 KiB
313 lignes
12 KiB
(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)
|