elisp/geiser-edit.el

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