klimi
/
dotfiles


								(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)