Teach SLIME how to jump to new kinds of definitions

lookup-fiveam-fixtures.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HACK: Teach SLIME about jumping to FiveAM fixture definitions ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'sb-introspect)
(ql:quickload :swank)
(ql:quickload :fiveam)

;; Poor man's defadvice - stolen from https://gist.github.com/spacebat/46740966846623148c014ab261050bc0

(defvar *wrapped-functions* (make-hash-table))

(defun wrapped-function-p (function)
  (if (gethash function *wrapped-functions*) t nil))

(defmacro undefwrapper (function)
  (check-type function symbol)
  `(let ((orig-function (gethash ',function *wrapped-functions*)))
     (when orig-function
       (setf (fdefinition ',function) orig-function)
       (remhash ',function *wrapped-functions*))))

(defmacro defwrapper (function &body body)
  (labels ((copy (node)
             (etypecase node
               (symbol (intern (symbol-name node)))
               (atom node)
               (cons (cons (copy (car node))
                           (copy (cdr node)))))))
    (check-type function symbol)
    `(progn
       (assert (fboundp ',function))
       (assert (not (gethash ',function *wrapped-functions*)))
       (setf (gethash ',function *wrapped-functions*) #',function)
       (macrolet ((get-orig-function ()
                    `(gethash ',',function *wrapped-functions*))
                  (call-orig-function (&rest args)
                    `(apply (gethash ',',function *wrapped-functions*) (list ,@args))))
         (setf (fdefinition ',function)
               (lambda ,(copy (sb-introspect:function-lambda-list function))
                 ,@body))))))

;;;;;;;;;;;;;;;;;;;;;;;;
;; Lookup code proper ;;
;;;;;;;;;;;;;;;;;;;;;;;;

;; Extend definition types with a user-picked name and a defining form
(setf (getf swank/sbcl::*definition-types* :fiveam-test-fixture) '5am:def-fixture)

;; Extend DEF-FIXTURE macro to attach location as a symbol property
(sb-ext:without-package-locks
  (defmacro 5am:def-fixture (name (&rest args) &body body)
    "Defines a fixture named NAME. A fixture is very much like a
macro but is used only for simple templating. A fixture created
with DEF-FIXTURE is a macro which can use the special macrolet
&BODY to specify where the body should go.

See Also: WITH-FIXTURE
"
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (setf (5am:get-fixture ',name) (cons ',args ',body))
       ;; Attach location info to symbol
       (setf (get ',name :location)
	     (sb-introspect::translate-source-location
	      (sb-c:source-location)))
       ',name)))

;; Register a function wrapper around FIND-DEFINITION-SOURCES-BY-NAME
;; to also include fixture location lookup
(defwrapper sb-introspect::find-definition-sources-by-name
  (let ((orig-result (funcall (get-orig-function) name type)))
    (or orig-result
	(sb-int:ensure-list
	 (case type
	   (:fiveam-test-fixture
	    (when (and (symbolp name)
		       (5am:get-fixture name))
	      (get name :location))))))))

#+nil
(undefwrapper sb-introspect::find-definition-sources-by-name)

;; Adding other lookup types would follow the same basic steps:
;; - add new type of definition to swank/sbcl::*definition-types*
;; - possibly extend appropriate macro/function to somehow register location info
;; - in the wrapper for FIND-DEFINITION-SOURCES-BY-NAME add appropriate CASE branch