A macroexpand-in-context hack for SLIME

slime-utils-walker.lisp

(require 'asdf)
(asdf:load-system :hu.dwim.walker)

;;;; Walker interface implementation

(defpackage :swank-macro-context
  (:use :cl :hu.dwim.walker :hu.dwim.def :contextl :metabang-bind)
  (:export #:apply-expander))

(in-package :swank-macro-context)

;;; Subtree pruning: avoids walking unnecessary parts

(defun find-path-to-pos (tree table)
  (setf (gethash tree table)
        (or (eq tree 'swank::%MACROEXPAND-POS%)
            (and (listp tree)
                 (not (every (lambda (x) (not (find-path-to-pos x table))) tree))))))

(defun add-all-to-table (tree table)
  (setf (gethash tree table) t)
  (when (listp tree)
    (dolist (x tree)
      (add-all-to-table x table))))

(defun adjust-table-for-macrolet (tree table)
  (if (gethash (second tree) table)
      (add-all-to-table tree table) ; (foo)
      (add-all-to-table (second tree) table)))

(defun merge-identity-with (tree base)
  (cond
    ;; Phase through the macroexpand pos marker
    ((and (consp tree)
          (eq (first tree) 'swank::%MACROEXPAND-POS%))
     (list 'swank::%MACROEXPAND-POS%
           (merge-identity-with (second tree) base)))
    ;; Recurse through congruent lists
    ((and (listp tree) (listp base)
          (= (length tree) (length base)))
     (mapcar #'merge-identity-with tree base))
    ;; Merge atoms
    ((and (atom tree) (atom base)
          (equal (type-of tree) (type-of base))
          (not (numberp tree))
          (or (not (symbolp tree))
              (and (equal (symbol-name tree) (symbol-name base))
                   (equal (symbol-package tree) (symbol-package base)))))
     base)
    ;; Otherwise bail out
    (t tree)))

;;; Walker operation layer

(defvar *nodes-in-path* nil)

(contextl:deflayer macro-context)

(def contextl:layered-method walk-form :in macro-context :around ((form cons) &key parent environment)
  (declare (ignore environment))
  ;; Cull unused subtrees
  (multiple-value-bind (value found)
      (gethash form *nodes-in-path*)
    (if (or value (not found))
        (call-next-layered-method)
        (make-instance 'constant-form :parent parent :value '#:stub))))

(def (walker :in macro-context) macrolet
  (adjust-table-for-macrolet -form- *nodes-in-path*)
  (call-next-layered-method))

(def (walker :in macro-context) symbol-macrolet
  (adjust-table-for-macrolet -form- *nodes-in-path*)
  (call-next-layered-method))

;;; Core implementation

(defvar *last-expansion-env* nil)
(defvar *last-expansion-tree* nil)

(defun compute-macro-context (tree env)
  (let ((*nodes-in-path* (make-hash-table :test #'eq)))
    (find-path-to-pos tree *nodes-in-path*)
    (contextl:with-active-layers (macro-context)
      (values-list
       (catch 'swank::%MACROEXPAND-POS%/FOUND
         (let ((v (walk-form tree :environment (make-walk-environment env))))
           (break "~A" v))
         nil)))))

#+nil
(macrolet ((foo (i j &environment env)
             (eq (macroexpand i env) (macroexpand j env)))
           (bar (&body code)
             (let ((g (gensym)))
               `(symbol-macrolet ((a ,g) (b ,g)) ,@code))))
  (bar (foo a a)
       (foo a b)
       (foo a c)))

(defun exec-expand (expander macro inplace?)
  ;;(print macro)
  ;;(print *last-expansion-tree*)
  (bind ((old-env (if inplace? *last-expansion-env*))
         (adj-tree (if inplace?
                       (merge-identity-with macro *last-expansion-tree*)
                       macro))
         ((:values found macro-exp env replace-exp)
          (compute-macro-context adj-tree old-env))
         (result
          (if found
              (funcall expander macro-exp env)
              "This form is never expanded in this context."))
         (out-tree (if inplace?
                       (if found
                           (subst result replace-exp adj-tree)
                           adj-tree)
                       result)))
    (setf *last-expansion-tree* out-tree)
    (unless inplace?
      (setf *last-expansion-env* env))
    result))

(defun apply-expander (expander string inplace?)
  (swank::apply-macro-expander
   (lambda (macro) (exec-expand expander macro inplace?))
   string))

;;; Swank API method definitions

(in-package :swank)

(defmacro %MACROEXPAND-POS% (&whole whole &optional target &environment env)
  (throw '%MACROEXPAND-POS%/FOUND
    (list t target env whole)))

(defslimefun swank-expand-with-context (string)
  (swank-macro-context:apply-expander #'expand string nil))

(defslimefun swank-expand-with-context-inplace (string)
  (swank-macro-context:apply-expander #'expand string t))

(defslimefun swank-expand-1-with-context (string)
  (swank-macro-context:apply-expander #'expand-1 string nil))

(defslimefun swank-expand-1-with-context-inplace (string)
  (swank-macro-context:apply-expander #'expand-1 string t))

(defslimefun swank-macroexpand-with-context (string)
  (swank-macro-context:apply-expander #'macroexpand string nil))

(defslimefun swank-macroexpand-with-context-inplace (string)
  (swank-macro-context:apply-expander #'macroexpand string t))

(defslimefun swank-macroexpand-1-with-context (string)
  (swank-macro-context:apply-expander #'macroexpand-1 string nil))

(defslimefun swank-macroexpand-1-with-context-inplace (string)
  (swank-macro-context:apply-expander #'macroexpand-1 string t))

(defslimefun swank-compiler-macroexpand-with-context (string)
  (swank-macro-context:apply-expander #'compiler-macroexpand string nil))

(defslimefun swank-compiler-macroexpand-with-context-inplace (string)
  (swank-macro-context:apply-expander #'compiler-macroexpand string t))

(defslimefun swank-compiler-macroexpand-1-with-context (string)
  (swank-macro-context:apply-expander #'compiler-macroexpand-1 string nil))

(defslimefun swank-compiler-macroexpand-1-with-context-inplace (string)
  (swank-macro-context:apply-expander #'compiler-macroexpand-1 string t))

slime-utils.el

(defun my-sexp-for-macroexpansion (&optional bounds)
  (destructuring-bind (start end)
      (slime-region-for-defun-at-point)
    (let* ((wbounds (or bounds (slime-bounds-of-sexp-at-point)))
           (pos1 (car wbounds))
           (pos2 (cdr wbounds))
           (str1 (buffer-substring-no-properties start pos1))
           (str  (buffer-substring-no-properties pos1 pos2))
           (str2 (buffer-substring-no-properties pos2 end))
           (cstr (concat str1 "(SWANK::%MACROEXPAND-POS% " str ")" str2)))
      cstr)))

(slime-def-connection-var my-walker-utils-loaded nil
  "Flag used to load the utility file on demand.")

(defun my-load-walker-utils ()
  (print "loading utils")
  (slime-load-file (concat dotfiles-dir "slime-utils-walker.lisp"))
  (setf (my-walker-utils-loaded) t))

(defun my-slime-macroexpander (expander)
  (case expander
    (swank:swank-expand
     'swank:swank-expand-with-context)
    (swank:swank-expand-1
     'swank:swank-expand-1-with-context)
    (swank:swank-macroexpand
     'swank:swank-macroexpand-with-context)
    (swank:swank-macroexpand-1
     'swank:swank-macroexpand-1-with-context)
    (swank:swank-compiler-macroexpand
     'swank:swank-compiler-macroexpand-with-context)
    (swank:swank-compiler-macroexpand-1
     'swank:swank-compiler-macroexpand-1-with-context)))

(defadvice slime-eval-macroexpand (around slime-macroexpand-context disable)
  (let ((updated-expander (my-slime-macroexpander (ad-get-arg 0))))
    (if (and updated-expander
             (null (ad-get-arg 1)))
        (progn
          (ad-set-arg 0 updated-expander)
          (ad-set-arg 1 (my-sexp-for-macroexpansion))
          (unless (my-walker-utils-loaded)
            (my-load-walker-utils))
          ad-do-it)
      ad-do-it)))

(defun my-slime-macroexpander-inplace (expander)
  (case expander
    (swank:swank-expand
     'swank:swank-expand-with-context-inplace)
    (swank:swank-expand-1
     'swank:swank-expand-1-with-context-inplace)
    (swank:swank-macroexpand
     'swank:swank-macroexpand-with-context-inplace)
    (swank:swank-macroexpand-1
     'swank:swank-macroexpand-1-with-context-inplace)
    (swank:swank-compiler-macroexpand
     'swank:swank-compiler-macroexpand-with-context-inplace)
    (swank:swank-compiler-macroexpand-1
     'swank:swank-compiler-macroexpand-1-with-context-inplace)))

(defun my-eval-macroexpand-inplace (expander)
  (let* ((bounds (or (slime-bounds-of-sexp-at-point)
                     (error "No sexp at point"))))
    (lexical-let* ((start (copy-marker (car bounds)))
                   (end (copy-marker (cdr bounds)))
                   (point (point))
                   (package (slime-current-package))
                   (buffer (current-buffer)))
      (slime-eval-async
       `(,expander ,(my-sexp-for-macroexpansion bounds))
       (lambda (expansion)
         (with-current-buffer buffer
           (let ((buffer-read-only nil))
             (when (fboundp 'slime-remove-edits)
               (slime-remove-edits (point-min) (point-max)))
             (goto-char start)
             (delete-region start end)
             (slime-insert-indented expansion)
             (goto-char point))))))))

(defadvice slime-eval-macroexpand-inplace (around slime-macroexpand-context disable)
  (let ((updated-expander (my-slime-macroexpander-inplace (ad-get-arg 0))))
    (if updated-expander
        (progn
          (unless (my-walker-utils-loaded)
            (my-load-walker-utils))
          (my-eval-macroexpand-inplace updated-expander))
      ad-do-it)))

(defun my-macroexpand-with-context ()
  (interactive)
  (ad-enable-advice 'slime-eval-macroexpand 'around 'slime-macroexpand-context)
  (ad-activate 'slime-eval-macroexpand)
  (ad-enable-advice 'slime-eval-macroexpand-inplace 'around 'slime-macroexpand-context)
  (ad-activate 'slime-eval-macroexpand-inplace))

;(my-macroexpand-with-context)

swank.lisp.patch

diff --git a/swank.lisp b/swank.lisp
index 70418d0..dafed4d 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -3011,18 +3011,18 @@ the filename of the module (or nil if the file doesn't exist).")
 (defslimefun swank-expand (string)
   (apply-macro-expander #'expand string))
 
-(defun expand-1 (form)
-  (multiple-value-bind (expansion expanded?) (macroexpand-1 form)
+(defun expand-1 (form &optional env)
+  (multiple-value-bind (expansion expanded?) (macroexpand-1 form env)
     (if expanded?
         (values expansion t)
-        (compiler-macroexpand-1 form))))
+        (compiler-macroexpand-1 form env))))
 
-(defun expand (form)
-  (expand-repeatedly #'expand-1 form))
+(defun expand (form &optional env)
+  (expand-repeatedly #'expand-1 form env))
 
-(defun expand-repeatedly (expander form)
+(defun expand-repeatedly (expander form &optional env)
   (loop
-    (multiple-value-bind (expansion expanded?) (funcall expander form)
+    (multiple-value-bind (expansion expanded?) (funcall expander form env)
       (unless expanded? (return expansion))
       (setq form expansion))))