dotfiles / emacs.d / slime-2012-01-20 / contrib / slime-asdf.el

Mike Steder ddf7185 

(define-slime-contrib slime-asdf
  "ASDF support."
  (:authors "Daniel Barlow       <>"
            "Marco Baringer      <>"
            "Edi Weitz           <>"
            "Stas Boukarev       <>"
            "Tobias C Rittweiler <>")
  (:license "GPL")
  (:slime-dependencies slime-repl)
  (:swank-dependencies swank-asdf)
   (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 
  "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-find-asd-file (or default-directory
         (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$")))
    (loop for system in asd-files
          for candidate = (file-name-sans-extension system)
          when (find candidate system-names :test #'string-equal)
            do (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 ,(slime-to-lisp-filename filename)

(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
  :group 'slime-asdf)

(defun slime-asdf-operation-finished-function (system)
  (if slime-asdf-collect-notes
      (lexical-let ((system system))
        (lambda (result)
          (let (slime-highlight-compiler-notes
            (slime-compilation-finished result))))))

(defun slime-oos (system operation &rest keyword-args)
  "Operate On System."
  (message "Performing ASDF %S%s on system %S"
           operation (if keyword-args (format " %S" keyword-args) "")
   `(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)
  "Open all files in an ASDF system."
  (interactive (list (slime-read-system-name)))
  (when (or load
            (and (called-interactively-p)
                 (not (slime-eval `(swank:asdf-system-loaded-p ,name)))
                 (y-or-n-p "Load it? ")))
    (slime-load-system name))
   `(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)
      (rgrep regexp "*.lisp"
              (slime-eval `(swank:asdf-system-directory ,sys-name)))))
    (defun slime-rgrep-system ()
      (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))))
                  ((buffers-forward  (mapcar #'find-file-noselect files))
                   (buffers-backward (reverse buffers-forward)))
                #'(lambda (current-buffer wrap)
                    ;; Contrarily to the 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
                      (if wrap
                          (car buffers)
                          (second (memq current-buffer buffers))))))))
    (defun slime-isearch-system ()
      (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
                                          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))))
     ;; 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

(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"
  (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)))
   `(swank:delete-system-fasls ,name)

(defun slime-reload-system (system)
  "Reload an ASDF system without reloading its dependencies."
  (interactive (list (slime-read-system-name)))
  (message "Performing ASDF LOAD-OP on system %S" system)
   `(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)))
      `(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 ()
              (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 ()
              (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 ()
              (slime-oos (slime-read-system-name) 'test-op :force t)))
  (:one-liner "Compile (as needed) and force test an ASDF system."))

(defslime-repl-shortcut slime-repl-test-system ("test-system")
  (:handler (lambda ()
              (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 ()
              (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 
  (:handler (lambda ()
              (slime-oos (slime-read-system-name) 'compile-op :force t)))
  (:one-liner "Recompile (but not 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)