elisp/geiser-edit.el

   1 ;;; geiser-edit.el -- scheme edit locations
   2
   3 ;; Copyright (C) 2009, 2010 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   "^\\([^<>:\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
 185 \f
 186 ;;; Commands:
 187
 188 (defvar geiser-edit--symbol-history nil)
 189
 190 (defun geiser-edit-symbol (symbol &optional method marker)
 191   "Asks for a symbol to edit, with completion."
 192   (interactive
 193    (list (geiser-completion--read-symbol "Edit symbol: "
 194                                          nil
 195                                          geiser-edit--symbol-history)))
 196   (let ((cmd `(:eval ((:ge symbol-location) ',symbol))))
 197     (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method)
 198     (when marker (ring-insert find-tag-marker-ring marker))))
 199
 200 (defun geiser-edit-symbol-at-point (&optional arg)
 201   "Opens a new window visiting the definition of the symbol at point.
 202 With prefix, asks for the symbol to edit."
 203   (interactive "P")
 204   (let* ((symbol (or (and (not arg) (symbol-at-point))
 205                      (geiser-completion--read-symbol "Edit symbol: ")))
 206          (cmd `(:eval ((:ge symbol-location) ',symbol)))
 207          (marker (point-marker)))
 208     (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd))
 209     (when marker (ring-insert find-tag-marker-ring marker))))
 210
 211 (defun geiser-pop-symbol-stack ()
 212   "Pop back to where \\[geiser-edit-symbol-at-point] was last invoked."
 213   (interactive)
 214   (condition-case nil
 215       (pop-tag-mark)
 216     (error "No previous location for find symbol invocation")))
 217
 218 (defun geiser-edit-module (module &optional method)
 219   "Asks for a module and opens it in a new buffer."
 220   (interactive (list (geiser-completion--read-module)))
 221   (let ((cmd `(:eval ((:ge module-location) (:module ,module)))))
 222     (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method)))
 223
 224 \f
 225 (provide 'geiser-edit)
 226 ;;; geiser-edit.el ends here