|
| 1 | +(defpackage :lem-lisp-mode/macroexpand |
| 2 | + (:use :cl |
| 3 | + :alexandria |
| 4 | + :lem |
| 5 | + :lem-lisp-mode/internal) |
| 6 | + #+sbcl |
| 7 | + (:lock t)) |
| 8 | +(in-package :lem-lisp-mode/macroexpand) |
| 9 | + |
| 10 | +(define-attribute expand-attribute |
| 11 | + (t :background :base01)) |
| 12 | + |
| 13 | +(define-attribute subform-attribute |
| 14 | + (t :underline :base07 :bold t)) |
| 15 | + |
| 16 | +(define-minor-mode macrostep-mode |
| 17 | + (:name "Macrostep" |
| 18 | + :keymap *macrostep-mode-keymap* |
| 19 | + :enable-hook 'enable-macrostep |
| 20 | + :disable-hook 'disable-macrostep)) |
| 21 | + |
| 22 | +(define-key *lisp-mode-keymap* "C-c Return" 'lisp-macrostep-expand) |
| 23 | +(define-key *macrostep-mode-keymap* "q" 'lisp-macrostep-quit) |
| 24 | +(define-key *macrostep-mode-keymap* "Tab" 'lisp-macrostep-next) |
| 25 | +(define-key *macrostep-mode-keymap* "Shift-Tab" 'lisp-macrostep-previous) |
| 26 | +(define-key *macrostep-mode-keymap* "Return" 'lisp-macrostep-expand-next) |
| 27 | +(define-key *macrostep-mode-keymap* "Backspace" 'lisp-macrostep-undo) |
| 28 | +(define-key *lisp-mode-keymap* "C-c M-m" 'lisp-macroexpand-all) |
| 29 | + |
| 30 | +(defun enable-macrostep () |
| 31 | + (setf (buffer-read-only-p (current-buffer)) t)) |
| 32 | + |
| 33 | +(defun disable-macrostep () |
| 34 | + (setf (buffer-read-only-p (current-buffer)) nil) |
| 35 | + (clear-macrostep-overlays (current-buffer)) |
| 36 | + (clear-expanded-overlays (current-buffer)) |
| 37 | + (loop :while (pop-undo (current-buffer)))) |
| 38 | + |
| 39 | +(define-overlay-accessors subform-overlays |
| 40 | + :clear-function clear-macrostep-overlays |
| 41 | + :add-function add-subform-overlay) |
| 42 | + |
| 43 | +(define-overlay-accessors expanded-overlays |
| 44 | + :clear-function clear-expanded-overlays |
| 45 | + :add-function add-expanded-overlay) |
| 46 | + |
| 47 | +(defun make-subform-overlay (start end) |
| 48 | + (make-overlay start end 'subform-attribute)) |
| 49 | + |
| 50 | +(defun get-sorted-subform-overlays (buffer) |
| 51 | + (sort (copy-list (subform-overlays buffer)) |
| 52 | + #'point< |
| 53 | + :key #'overlay-start)) |
| 54 | + |
| 55 | +(defun point-within-subform-p (point) |
| 56 | + (loop :for overlay :in (get-sorted-subform-overlays (point-buffer point)) |
| 57 | + :when (point<= (overlay-start overlay) point (overlay-end overlay)) |
| 58 | + :return t)) |
| 59 | + |
| 60 | +(defun search-next-subform-overlay (point) |
| 61 | + (loop :with overlays := (get-sorted-subform-overlays (point-buffer point)) |
| 62 | + :for overlay :in overlays |
| 63 | + :when (point< point (overlay-start overlay)) |
| 64 | + :return overlay |
| 65 | + :finally (return (first overlays)))) |
| 66 | + |
| 67 | +(defun search-previous-subform-overlay (point) |
| 68 | + (loop :for (overlay next-overlay) :on (get-sorted-subform-overlays (point-buffer point)) |
| 69 | + :if (null next-overlay) |
| 70 | + :return overlay |
| 71 | + :if (point<= (overlay-end overlay) point (overlay-start next-overlay)) |
| 72 | + :return overlay)) |
| 73 | + |
| 74 | +(defun remove-overlays-within-points (start end) |
| 75 | + (loop :with buffer := (point-buffer start) |
| 76 | + :for overlay :in (get-sorted-subform-overlays buffer) |
| 77 | + :if (point<= start (overlay-start overlay) (overlay-end overlay) end) |
| 78 | + :collect overlay :into garbage-overlays |
| 79 | + :else |
| 80 | + :collect overlay :into alive-overlays |
| 81 | + :finally (map () #'delete-overlay garbage-overlays) |
| 82 | + (setf (subform-overlays buffer) alive-overlays))) |
| 83 | + |
| 84 | +(defun dump-subforms (buffer) |
| 85 | + (loop :for overlay :in (subform-overlays buffer) |
| 86 | + :collect (cons (position-at-point (overlay-start overlay)) |
| 87 | + (position-at-point (overlay-end overlay))))) |
| 88 | + |
| 89 | +(defun replace-at-points (start end string) |
| 90 | + (remove-overlays-within-points start end) |
| 91 | + (delete-between-points start end) |
| 92 | + (insert-string start string)) |
| 93 | + |
| 94 | +(defun positions-to-points (buffer start-pos end-pos) |
| 95 | + (with-point ((start (buffer-point buffer)) |
| 96 | + (end (buffer-point buffer))) |
| 97 | + (move-to-position start start-pos) |
| 98 | + (move-to-position end end-pos) |
| 99 | + (values start end))) |
| 100 | + |
| 101 | +(defun empty-undo-stack-p (buffer) |
| 102 | + (null (buffer-value buffer 'undo))) |
| 103 | + |
| 104 | +(defun pop-undo (buffer) |
| 105 | + (when (buffer-value buffer 'undo) |
| 106 | + (let ((*inhibit-read-only* t)) |
| 107 | + (destructuring-bind (start-pos end-pos string subforms is-mark) |
| 108 | + (pop (buffer-value buffer 'undo)) |
| 109 | + (multiple-value-bind (start end) |
| 110 | + (positions-to-points buffer start-pos end-pos) |
| 111 | + (replace-at-points start end string) |
| 112 | + (loop :for (start-pos . end-pos) :in subforms |
| 113 | + :do (multiple-value-bind (start end) |
| 114 | + (positions-to-points buffer start-pos end-pos) |
| 115 | + (add-subform-overlay buffer (make-subform-overlay start end)))) |
| 116 | + (move-point (buffer-point buffer) start) |
| 117 | + (unless is-mark |
| 118 | + (buffer-unmark buffer))))) |
| 119 | + t)) |
| 120 | + |
| 121 | +(defun push-undo (start end string subforms is-mark) |
| 122 | + (let ((buffer (point-buffer start)) |
| 123 | + (start-pos (position-at-point start)) |
| 124 | + (end-pos (position-at-point end))) |
| 125 | + (push (list start-pos end-pos string subforms is-mark) |
| 126 | + (buffer-value buffer 'undo)))) |
| 127 | + |
| 128 | +(defun replace-with-macrostep-expand (start end expansion-string subform-info) |
| 129 | + (let ((*inhibit-read-only* t) |
| 130 | + (buffer (point-buffer start))) |
| 131 | + (replace-at-points start end expansion-string) |
| 132 | + (add-expanded-overlay buffer (make-overlay start end 'expand-attribute)) |
| 133 | + (loop :for (name kind offset) :in subform-info |
| 134 | + :do (with-point ((point start)) |
| 135 | + (character-offset point offset) |
| 136 | + (assert (forward-down-list point t)) |
| 137 | + (with-point ((start point) |
| 138 | + (end point)) |
| 139 | + (when (form-offset end 1) |
| 140 | + (add-subform-overlay buffer (make-subform-overlay start end)))))) |
| 141 | + (indent-points start end))) |
| 142 | + |
| 143 | +(defun get-form-points (point) |
| 144 | + (maybe-beginning-of-string point) |
| 145 | + (unless (syntax-open-paren-char-p (character-at point)) |
| 146 | + (backward-up-list point) |
| 147 | + (skip-chars-backward point #'syntax-expr-prefix-char-p)) |
| 148 | + (values point |
| 149 | + (form-offset (copy-point point :temporary) 1))) |
| 150 | + |
| 151 | +(defmacro with-form-points ((start end point) &body body) |
| 152 | + (check-type start symbol) |
| 153 | + (check-type end symbol) |
| 154 | + `(multiple-value-bind (,start ,end) (get-form-points ,point) |
| 155 | + (with-point ((,start ,start :right-inserting) |
| 156 | + (,end ,end :left-inserting)) |
| 157 | + ,@body))) |
| 158 | + |
| 159 | +(defun get-context (point) |
| 160 | + (with-point ((start point) |
| 161 | + (end point)) |
| 162 | + (loop :while (backward-up-list start t)) |
| 163 | + (form-offset (move-point end start) 1) |
| 164 | + (list (points-to-string start point) |
| 165 | + (points-to-string point end)))) |
| 166 | + |
| 167 | +(defun macrostep-expand (point) |
| 168 | + (with-form-points (start end point) |
| 169 | + (let ((string (points-to-string start end)) |
| 170 | + (context (get-context point))) |
| 171 | + (destructuring-ecase |
| 172 | + (lisp-eval `(micros/macrostep:macrostep-expand-1 ,string t ',context)) |
| 173 | + ((:ok expansion-string subform-info) |
| 174 | + (let ((subforms (dump-subforms (point-buffer point))) |
| 175 | + (is-mark (buffer-modified-p (point-buffer point)))) |
| 176 | + (replace-with-macrostep-expand start end expansion-string subform-info) |
| 177 | + (push-undo start end string subforms is-mark)) |
| 178 | + (move-point point start) |
| 179 | + t) |
| 180 | + ((:error message) |
| 181 | + (show-message (format nil "Error: ~A" message)) |
| 182 | + nil))))) |
| 183 | + |
| 184 | +(defclass macrostep-advice () ()) |
| 185 | + |
| 186 | +(defmethod execute :before (mode (command macrostep-advice) argument) |
| 187 | + (unless (mode-active-p (current-buffer) 'macrostep-mode) |
| 188 | + (editor-error "macrostep is not activated."))) |
| 189 | + |
| 190 | +(define-command (lisp-macrostep-quit (:advice-classes macrostep-advice)) () () |
| 191 | + (macrostep-mode nil)) |
| 192 | + |
| 193 | +(define-command (lisp-macrostep-next (:advice-classes macrostep-advice)) () () |
| 194 | + (when-let (overlay (search-next-subform-overlay (current-point))) |
| 195 | + (move-point (current-point) (overlay-start overlay)))) |
| 196 | + |
| 197 | +(define-command (lisp-macrostep-previous (:advice-classes macrostep-advice)) () () |
| 198 | + (when-let (overlay (search-previous-subform-overlay (current-point))) |
| 199 | + (move-point (current-point) (overlay-start overlay)))) |
| 200 | + |
| 201 | +(define-command (lisp-macrostep-expand-next (:advice-classes macrostep-advice)) () () |
| 202 | + (unless (point-within-subform-p (current-point)) |
| 203 | + (lisp-macrostep-next)) |
| 204 | + (macrostep-expand (current-point))) |
| 205 | + |
| 206 | +(define-command (lisp-macrostep-undo (:advice-classes macrostep-advice)) () () |
| 207 | + (pop-undo (current-buffer)) |
| 208 | + (when (empty-undo-stack-p (current-buffer)) |
| 209 | + (macrostep-mode nil))) |
| 210 | + |
| 211 | +(defun display-help-p () |
| 212 | + (not (config :disable-macrostep-display-help))) |
| 213 | + |
| 214 | +(define-command lisp-macrostep-disable-help () () |
| 215 | + (setf (config :disable-macrostep-display-help) t)) |
| 216 | + |
| 217 | +(define-command lisp-macrostep-expand () () |
| 218 | + (when (macrostep-expand (current-point)) |
| 219 | + (macrostep-mode t) |
| 220 | + (when (display-help-p) |
| 221 | + (when (prompt-for-y-or-n-p |
| 222 | + ;; TODO: Prepare help and guide them from here. |
| 223 | + "Press \"q\" to undo. |
| 224 | +Do you want to disable this message in the future?" |
| 225 | + :gravity (make-instance 'lem/popup-window::gravity-cursor |
| 226 | + :offset-x 1 |
| 227 | + :offset-y 1)) |
| 228 | + (lisp-macrostep-disable-help))))) |
| 229 | + |
| 230 | +(defun guard () (error 'read-only-error)) |
| 231 | +(defmethod execute ((mode macrostep-mode) (command undo) argument) (guard)) |
| 232 | +(defmethod execute ((mode macrostep-mode) (command redo) argument) (guard)) |
| 233 | + |
| 234 | +(defun macroexpand-internal (expander) |
| 235 | + (let* ((self (eq (current-buffer) (get-buffer "*lisp-macroexpand*"))) |
| 236 | + (orig-package-name (buffer-package (current-buffer) "CL-USER")) |
| 237 | + (p (and self (copy-point (current-point) :temporary)))) |
| 238 | + (lisp-eval-async `(,expander ,(lem-lisp-mode/internal::form-string-at-point)) |
| 239 | + (lambda (string) |
| 240 | + (let ((buffer (make-buffer "*lisp-macroexpand*"))) |
| 241 | + (with-buffer-read-only buffer nil |
| 242 | + (unless self (erase-buffer buffer)) |
| 243 | + (change-buffer-mode buffer 'lisp-mode) |
| 244 | + (setf (buffer-package buffer) orig-package-name) |
| 245 | + (when self |
| 246 | + (move-point (current-point) p) |
| 247 | + (kill-sexp)) |
| 248 | + (insert-string (buffer-point buffer) |
| 249 | + string) |
| 250 | + (indent-points (buffer-start-point buffer) |
| 251 | + (buffer-end-point buffer)) |
| 252 | + (with-pop-up-typeout-window (s buffer) |
| 253 | + (declare (ignore s))) |
| 254 | + (when self |
| 255 | + (move-point (buffer-point buffer) p)))))))) |
| 256 | + |
| 257 | +(define-command lisp-macroexpand () () |
| 258 | + (check-connection) |
| 259 | + (macroexpand-internal 'micros:swank-macroexpand-1)) |
| 260 | + |
| 261 | +(define-command lisp-macroexpand-all () () |
| 262 | + (check-connection) |
| 263 | + (macroexpand-internal 'micros:swank-macroexpand-all)) |
0 commit comments