[nongnu] elpa/macrostep 874c790 058/110: WIP: smarter SLIME macroexpansion

[ELPA Syncer]

branch: elpa/macrostep
commit 874c7907340c46d0ca2eb9d0516e9e16ca375b4c
Author: joddie <jonxfield@gmail.com>
Commit: joddie <jonxfield@gmail.com>

    WIP: smarter SLIME macroexpansion
---
 macrostep.el         | 109 +++++++++++++++++++++++++--------------------------
 swank-macrostep.lisp |  98 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 151 insertions(+), 56 deletions(-)

diff --git a/macrostep.el b/macrostep.el
index 3816eb1..b0c4aab 100644
--- a/macrostep.el
+++ b/macrostep.el
@@ -912,64 +912,61 @@ expansion will not be fontified.  See also
 ;;;###autoload
 (add-hook 'slime-mode-hook #'macrostep-slime-mode-hook)
 
-(defun macrostep-slime-expand-1 (sexp)
-  (cl-ecase (macrostep-slime-macro-form-p sexp)
-    (macro
-     (slime-eval `(swank:swank-macroexpand-1 ,sexp)))
-    (compiler-macro
-     (slime-eval `(swank:swank-compiler-macroexpand-1 ,sexp)))))
-
-(defun macrostep-slime-insert (expansion)
-  "Insert EXPANSION at point, indenting to match the current column."
-  (let* ((indent-string (concat "\n" (make-string (current-column) ? )))
-         (expansion (replace-regexp-in-string "\n" indent-string expansion))
-         (start (point)))
-    (insert expansion)
-    (macrostep-slime--propertize-macros start (point))))
-
-(defun macrostep-slime--propertize-macros (start end)
+(defun macrostep-slime-expand-1 (string)
+  (slime-eval `(swank-macrostep:macrostep-expand-1 ,string nil)))
+
+(defun macrostep-slime-insert (result)
+  "Insert RESULT at point, indenting to match the current column."
+  (cl-destructuring-bind (expansion substitutions) result
+    (let* ((indent-string (concat "\n" (make-string (current-column) ? )))
+           (expansion (replace-regexp-in-string "\n" indent-string expansion))
+           (start (point)))
+      (insert expansion)
+      (macrostep-slime--propertize-macros start (point) substitutions))))
+
+(defun macrostep-slime--propertize-macros (start end substitutions)
   "Put text properties on macro forms between START and END."
-  (save-excursion
-    (goto-char start)
-    (while (search-forward-regexp (rx (submatch "(")
-                                      (submatch
-                                       (+ (or (syntax word)
-                                              (syntax symbol)))))
-                                  end t)
-      (let ((paren-begin (match-beginning 1)) (paren-end (match-end 1))
-            (symbol-begin (match-beginning 2)) (symbol-end (match-end 2)))
-        (save-excursion
-          (let* ((sexp (concat "(" (match-string 2) ")"))  ; FIXME HACK
-                 (macro-type (macrostep-slime-macro-form-p sexp)))
-            (when macro-type
-              (put-text-property paren-begin paren-end
-                                 'macrostep-macro-start t)
-              (put-text-property symbol-begin symbol-end
-                                 'font-lock-face
-                                 (cl-ecase macro-type
-                                   (macro
-                                    'macrostep-macro-face)
-                                   (compiler-macro
-                                    'macrostep-compiler-macro-face))))))))))
-
-(defun macrostep-slime-macro-form-p (form)
+  (when substitutions
+    (let ((regexp
+           (rx-to-string
+            `(: (submatch "(")
+                (submatch
+                 (or ,@(mapcar #'car substitutions)))))))
+      (save-excursion
+        (goto-char start)
+        (while (search-forward-regexp regexp end t)
+          (replace-match (assoc-default (match-string 2) substitutions)
+                         t t nil 2)
+          (put-text-property (match-beginning 1) (match-end 1)
+                             'macrostep-macro-start t)
+          (put-text-property (match-beginning 2) (match-end 2)
+                             'font-lock-face
+                             'macrostep-macro-face))))))
+
+(defun macrostep-slime-macro-form-p (string)
   (slime-eval
-   `(swank::with-buffer-syntax ()
-      (cl:let ((sexp (cl:read-from-string ,form))
-               (expand-compiler-macros ,macrostep-expand-compiler-macros))
-        (cl:cond
-          ((cl:or (cl:not (cl:consp sexp))
-                  (cl:not (cl:symbolp (cl:car sexp))))
-           nil)
-          ((cl:eq (cl:car sexp) 'cl:lambda)
-           nil)
-          ((cl:macro-function (cl:car sexp))
-           'macro)
-          ((cl:and expand-compiler-macros
-                   (cl:compiler-macro-function (cl:car sexp)))
-           'compiler-macro)
-          (t
-           nil))))))
+   `(swank-macrostep:macro-form-p ,string nil)))
+
+(defun macrostep-slime-environment-at-point ()
+  (save-excursion
+    (condition-case err
+        (progn
+          (backward-up-list)
+          (let ((enclosing-environment
+                 (macrostep-slime-environment-at-point)))
+            (if (looking-at (rx "(macrolet"))
+                (let ((binding-list
+                       (save-excursion
+                         (down-list)
+                         (forward-sexp)
+                         (skip-syntax-forward "-")
+                         (slime-sexp-at-point))))
+                  (cons binding-list enclosing-environment))
+              enclosing-environment)))
+      (scan-error
+       (if macrostep-expansion-buffer
+           macrostep-outer-environment
+         nil)))))
 
 
 (provide 'macrostep)
diff --git a/swank-macrostep.lisp b/swank-macrostep.lisp
new file mode 100644
index 0000000..e5b2310
--- /dev/null
+++ b/swank-macrostep.lisp
@@ -0,0 +1,98 @@
+
+(defpackage swank-macrostep
+  (:use cl swank)
+  (:import-from swank
+                #:with-buffer-syntax
+                #:to-string
+                #:macroexpand-all)
+  (:export #:macrostep-expand-1
+           #:macro-form-p))
+
+(in-package #:swank-macrostep)
+
+(defun macrostep-expand-1 (string binding-strings &optional compiler-macros?)
+  (with-buffer-syntax ()
+    (let* ((form (read-from-string string))
+           (bindings (mapcar #'read-from-string binding-strings))
+           (env (compute-environment bindings)))
+      (case (macro-form-type form env compiler-macros?)
+        (macro
+         (multiple-value-bind (expansion substitutions)
+             (substitute-macros (macroexpand-1 form env))
+           (list
+            (to-string expansion)
+            (loop for (replacement . original) in substitutions
+                 collect (cons (to-string replacement)
+                               (to-string original))))))
+        (compiler-macro
+         (error "Not implemented"))
+        (t
+         (error "Not a macro form"))))))
+
+(defun macro-form-p (string binding-strings &optional compiler-macros?)
+  (with-buffer-syntax ()
+    (let* ((form (read-from-string string))
+           (bindings (mapcar #'read-from-string binding-strings))
+           (env (compute-environment bindings)))
+      (macro-form-type form env compiler-macros?))))
+
+(defun macro-form-type (sexp environment compiler-macros?)
+  (cond
+    ((or (not (consp sexp))
+         (not (symbolp (car sexp))))
+     nil)
+    ((macro-function (car sexp) environment)
+     'macro)
+    ((and compiler-macros?
+          (compiler-macro-function (car sexp) environment))
+     'compiler-macro)
+    (t
+     nil)))
+
+(defun compute-environment (binding-forms)
+  (eval (make-environment-extractor
+         (mapcar #'read-from-string binding-forms))))
+
+(defun make-environment-extractor (binding-lists)
+  (if (null binding-lists)
+      (let ((return-env (gensym)))
+        `(macrolet ((,return-env (&environment env) env))
+           (,return-env)))
+    (let ((binding-list (car binding-lists))
+          (subexpression (make-environment-extractor (cdr binding-lists))))
+      `(macrolet ,binding-list ,subexpression))))
+
+(defun substitute-macros (form)
+  (let ((forms (collect-macro-forms form)))
+    (substitute-macro-forms form forms)))
+
+(defun collect-macro-forms (form)
+  (let* ((real-macroexpand-hook *macroexpand-hook*)
+         (macro-forms '())
+         (*macroexpand-hook*
+          (lambda (macro-function form environment)
+            (setq macro-forms
+                  (cons form macro-forms))
+            (funcall real-macroexpand-hook macro-function form environment))))
+    (macroexpand-all form)
+    macro-forms))
+
+(defun substitute-macro-forms (form forms)
+  (cond ((not (consp form))
+         (values form nil))
+        ((member form forms :test 'eq)
+         (multiple-value-bind (rest replacements)
+             (substitute-macro-forms (cdr form) forms)
+           (let ((replacement (gensym)))
+             (values
+              (cons replacement rest)
+              (cons (cons replacement (car form))
+                    replacements)))))
+        (t
+         (multiple-value-bind (car replacements-1)
+             (substitute-macro-forms (car form) forms)
+           (multiple-value-bind (cdr replacements-2)
+               (substitute-macro-forms (cdr form) forms)
+             (values
+              (cons car cdr)
+              (append replacements-1 replacements-2)))))))