geiser-edit.el (11955B)
1 ;;; geiser-edit.el -- scheme edit locations -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009, 2010, 2012, 2013, 2019-2022 Jose Antonio Ortega Ruiz 4 5 ;; This program is free software; you can redistribute it and/or 6 ;; modify it under the terms of the Modified BSD License. You should 7 ;; have received a copy of the license along with this program. If 8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. 9 10 ;; Start date: Wed Feb 11, 2009 21:07 11 12 13 ;;; Code: 14 15 (require 'geiser-completion) 16 (require 'geiser-eval) 17 (require 'geiser-custom) 18 (require 'geiser-base) 19 20 (require 'etags) 21 (eval-when-compile (require 'subr-x)) 22 23 24 ;;; Customization: 25 26 (defmacro geiser-edit--define-custom-visit (var group doc) 27 `(geiser-custom--defcustom ,var nil 28 ,doc 29 :group ',group 30 :type '(choice (const :tag "Other window" window) 31 (const :tag "Other frame" frame) 32 (const :tag "Current window" nil)))) 33 34 (geiser-edit--define-custom-visit 35 geiser-edit-symbol-method geiser-mode 36 "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point] 37 or following links in error buffers.") 38 39 (geiser-custom--defface error-link 40 'link geiser-debug "links in error buffers") 41 42 43 ;;; Auxiliary functions: 44 45 (defun geiser-edit--visit-file (file method) 46 (cond ((eq method 'window) (pop-to-buffer (find-file-noselect file t))) 47 ((eq method 'frame) (find-file-other-frame file)) 48 ((eq method 'noselect) (find-file-noselect file t)) 49 (t (find-file file)))) 50 51 (defsubst geiser-edit--location-name (loc) 52 (cdr (assoc "name" loc))) 53 54 (defsubst geiser-edit--location-file (loc) 55 (when-let ((file-name (cdr (assoc "file" loc)))) 56 (concat (or (file-remote-p default-directory) "") 57 file-name))) 58 59 (defsubst geiser-edit--to-number (x) 60 (cond ((numberp x) x) 61 ((stringp x) (string-to-number x)))) 62 63 (defsubst geiser-edit--location-line (loc) 64 (geiser-edit--to-number (cdr (assoc "line" loc)))) 65 66 (defsubst geiser-edit--location-column (loc) 67 (geiser-edit--to-number (cdr (assoc "column" loc)))) 68 69 (defsubst geiser-edit--location-char (loc) 70 (geiser-edit--to-number (cdr (assoc "char" loc)))) 71 72 (defsubst geiser-edit--make-location (name file line column) 73 (if (equal line "") 74 `(("name" . ,name) ("file" . ,file) ("char" . ,column)) 75 `(("name" . ,name) ("file" . ,file) ("line" . ,line) ("column" . ,column)))) 76 77 (defconst geiser-edit--def-re 78 (regexp-opt '("define" 79 "defmacro" 80 "define-macro" 81 "define-syntax" 82 "define-syntax-rule" 83 "-define-syntax" 84 "-define" 85 "define*" 86 "define-method" 87 "define-class" 88 "define-struct"))) 89 90 (defconst geiser-edit--def-re* 91 (regexp-opt '("define-syntaxes" "define-values"))) 92 93 (defsubst geiser-edit--def-re (thing) 94 (let ((sx (regexp-quote (format "%s" thing)))) 95 (format (concat "(%s[[:space:]]+\\(" 96 "(%s\\_>[^)]*)\\|" 97 "\\(\\_<%s\\_>\\) *\\([^\n]*?\\)[)\n]" 98 "\\)") 99 geiser-edit--def-re sx sx))) 100 101 (defsubst geiser-edit--def-re* (thing) 102 (format "(%s +([^)]*?\\_<%s\\_>" 103 geiser-edit--def-re* 104 (regexp-quote (format "%s" thing)))) 105 106 (defun geiser-edit--find-def (symbol &optional args) 107 (save-excursion 108 (goto-char (point-min)) 109 (when (or (re-search-forward (geiser-edit--def-re symbol) nil t) 110 (re-search-forward (geiser-edit--def-re* symbol) nil t)) 111 (cons (match-beginning 0) 112 (and args 113 (if (match-string 2) 114 (let* ((v (or (match-string 3) "")) 115 (v (and (not (string-blank-p v)) v))) 116 (concat (match-string 2) 117 (and v " => ") 118 v 119 (and v (string-prefix-p "(" v) " ..."))) 120 (match-string 1))))))) 121 122 (defsubst geiser-edit--symbol-re (thing) 123 (format "\\_<%s\\_>" (regexp-quote (format "%s" thing)))) 124 125 (defun geiser-edit--goto-location (symbol line col pos) 126 (cond ((numberp line) 127 (goto-char (point-min)) 128 (forward-line (max 0 (1- line)))) 129 ((numberp pos) (goto-char pos))) 130 (if (not col) 131 (when-let (pos (car (geiser-edit--find-def symbol))) 132 (goto-char pos)) 133 (beginning-of-line) 134 (forward-char col) 135 (cons (current-buffer) (point)))) 136 137 (defun geiser-edit--try-edit-location (symbol loc &optional method no-error) 138 (let ((symbol (or (geiser-edit--location-name loc) symbol)) 139 (file (geiser-edit--location-file loc)) 140 (line (geiser-edit--location-line loc)) 141 (col (geiser-edit--location-column loc)) 142 (pos (geiser-edit--location-char loc))) 143 (when file 144 (geiser-edit--visit-file file (or method geiser-edit-symbol-method))) 145 (or (geiser-edit--goto-location symbol line col pos) 146 file 147 (unless no-error 148 (error "Couldn't find location for '%s'" symbol))))) 149 150 (defsubst geiser-edit--try-edit (symbol ret &optional method no-error) 151 (geiser-edit--try-edit-location symbol 152 (geiser-eval--retort-result ret) 153 method 154 no-error)) 155 156 157 ;;; Links 158 159 (define-button-type 'geiser-edit--button 160 'action 'geiser-edit--button-action 161 'face 'geiser-font-lock-error-link 162 'follow-link t) 163 164 (defun geiser-edit--button-action (button) 165 (let ((loc (button-get button 'geiser-location)) 166 (method (button-get button 'geiser-method))) 167 (when loc (geiser-edit--try-edit-location nil loc method)))) 168 169 (defun geiser-edit--make-link (beg end file line col &optional method) 170 (make-button beg end 171 :type 'geiser-edit--button 172 'geiser-method method 173 'geiser-location 174 (geiser-edit--make-location 'error file line col) 175 'help-echo "Go to error location")) 176 177 (defconst geiser-edit--default-file-rx 178 "^[ \t]*\\([^<>:\n\"]+\\):\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?") 179 180 (defun geiser-edit--buttonize-files (&optional rx no-fill) 181 (let ((rx (or rx geiser-edit--default-file-rx)) 182 (fill-column (- (window-width) 2))) 183 (save-excursion 184 (while (re-search-forward rx nil t) 185 (geiser-edit--make-link (match-beginning 1) 186 (match-end 1) 187 (match-string 1) 188 (match-string 2) 189 (or (match-string 3) 0) 190 'window) 191 (unless no-fill (fill-region (match-end 0) (line-end-position))))))) 192 193 (defun geiser-edit--open-next (&optional n reset) 194 (interactive) 195 (let* ((n (or n 1)) 196 (nxt (if (< n 0) 'backward-button 'forward-button)) 197 (msg (if (< n 0) "previous" "next")) 198 (n (abs n)) 199 (p (point)) 200 (found nil)) 201 (when reset (goto-char (point-min))) 202 (while (> n 0) 203 (let ((b (ignore-errors (funcall nxt 1)))) 204 (unless b (setq n 0)) 205 (when (and b (eq (button-type b) 'geiser-edit--button)) 206 (setq n (- n 1)) 207 (when (<= n 0) 208 (setq found t) 209 (push-button (point)))))) 210 (unless found 211 (goto-char p) 212 (error "No %s error" msg)))) 213 214 215 ;;; Visibility 216 (defun geiser-edit--cloak (form) 217 (intern (format "geiser-edit-cloak-%s" form))) 218 219 (defun geiser-edit--hide (form) 220 (geiser-edit--show form) 221 (let ((cloak (geiser-edit--cloak form))) 222 (save-excursion 223 (goto-char (point-min)) 224 (while (re-search-forward (format "(%s\\b" form) nil t) 225 (let* ((beg (match-beginning 0)) 226 (end (progn (ignore-errors (goto-char beg) (forward-sexp)) 227 (point)))) 228 (when (> end beg) 229 (overlay-put (make-overlay beg end) 'invisible cloak))))) 230 (add-to-invisibility-spec (cons cloak t)))) 231 232 (defun geiser-edit--show (form) 233 (let ((cloak (geiser-edit--cloak form))) 234 (remove-overlays nil nil 'invisible cloak) 235 (remove-from-invisibility-spec (cons cloak t)))) 236 237 (defun geiser-edit--show-all () 238 (remove-overlays) 239 (setq buffer-invisibility-spec '(t))) 240 241 (defun geiser-edit--toggle-visibility (form) 242 (if (and (listp buffer-invisibility-spec) 243 (assoc (geiser-edit--cloak form) buffer-invisibility-spec)) 244 (geiser-edit--show form) 245 (geiser-edit--hide form))) 246 247 248 ;;; Commands: 249 250 (defvar geiser-edit--symbol-history nil) 251 252 (defun geiser-edit-symbol (symbol &optional method marker) 253 "Asks for a symbol to edit, with completion." 254 (interactive 255 (list (geiser-completion--read-symbol "Edit symbol: " 256 nil 257 geiser-edit--symbol-history))) 258 (let ((cmd `(:eval (:ge symbol-location ',symbol)))) 259 (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method) 260 (when marker (xref-push-marker-stack)))) 261 262 (defun geiser-edit-symbol-at-point (&optional arg) 263 "Visit the definition of the symbol at point. 264 With prefix, asks for the symbol to locate." 265 (interactive "P") 266 (let* ((symbol (or (and (not arg) (geiser--symbol-at-point)) 267 (geiser-completion--read-symbol "Edit symbol: "))) 268 (cmd `(:eval (:ge symbol-location ',symbol))) 269 (marker (point-marker)) 270 (ret (ignore-errors (geiser-eval--send/wait cmd)))) 271 (if (geiser-edit--try-edit symbol ret nil t) 272 (when marker (xref-push-marker-stack marker)) 273 (unless (geiser-edit-module-at-point t) 274 (error "Couldn't find location for '%s'" symbol))) 275 t)) 276 277 (defun geiser-pop-symbol-stack () 278 "Pop back to where \\[geiser-edit-symbol-at-point] was last invoked." 279 (interactive) 280 (if (fboundp 'xref-go-back) 281 (xref-go-back) 282 (with-no-warnings 283 (xref-pop-marker-stack)))) 284 285 (defun geiser-edit-module (module &optional method no-error) 286 "Asks for a module and opens it in a new buffer." 287 (interactive (list (geiser-completion--read-module))) 288 (let ((cmd `(:eval (:ge module-location '(:module ,module))))) 289 (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method no-error))) 290 291 (defun geiser-edit-module-at-point (&optional no-error) 292 "Opens a new window visiting the module at point." 293 (interactive) 294 (let ((marker (point-marker))) 295 (geiser-edit-module (or (geiser-completion--module-at-point) 296 (geiser-completion--read-module)) 297 nil no-error) 298 (when marker (xref-push-marker-stack marker)) 299 t)) 300 301 (defun geiser-insert-lambda (&optional full) 302 "Insert λ at point. With prefix, inserts (λ ())." 303 (interactive "P") 304 (if (not full) 305 (insert (make-char 'greek-iso8859-7 107)) 306 (insert "(" (make-char 'greek-iso8859-7 107) " ())") 307 (backward-char 2))) 308 309 (defun geiser-squarify (n) 310 "Toggle between () and [] for current form. 311 312 With numeric prefix, perform that many toggles, forward for 313 positive values and backward for negative." 314 (interactive "p") 315 (let ((pared (and (boundp 'paredit-mode) paredit-mode)) 316 (fwd (> n 0)) 317 (steps (abs n))) 318 (when (and pared (fboundp 'paredit-mode)) (paredit-mode -1)) 319 (unwind-protect 320 (save-excursion 321 (unless (looking-at-p "\\s(") (backward-up-list)) 322 (while (> steps 0) 323 (let ((p (point)) 324 (round (looking-at-p "("))) 325 (forward-sexp) 326 (backward-delete-char 1) 327 (insert (if round "]" ")")) 328 (goto-char p) 329 (delete-char 1) 330 (insert (if round "[" "(")) 331 (setq steps (1- steps)) 332 (backward-char) 333 (condition-case nil 334 (progn (when fwd (forward-sexp 2)) 335 (backward-sexp)) 336 (error (setq steps 0)))))) 337 (when (and pared (fboundp 'paredit-mode)) (paredit-mode 1))))) 338 339 340 341 (provide 'geiser-edit)