elisp/geiser-edit.el

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