1 ;;; geiser-edit.el -- scheme edit locations
3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
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>.
10 ;; Start date: Wed Feb 11, 2009 21:07
14 (require 'geiser-completion
)
15 (require 'geiser-eval
)
16 (require 'geiser-custom
)
17 (require 'geiser-base
)
24 (defmacro geiser-edit--define-custom-visit
(var group doc
)
25 `(geiser-custom--defcustom ,var nil
28 :type
'(choice (const :tag
"Other window" window
)
29 (const :tag
"Other frame" frame
)
30 (const :tag
"Current window" nil
))))
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.")
37 (geiser-custom--defface error-link
38 'link geiser-debug
"links in error buffers")
41 ;;; Auxiliar functions:
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
))))
49 (defsubst geiser-edit--location-name
(loc)
50 (cdr (assoc 'name loc
)))
52 (defsubst geiser-edit--location-file
(loc)
53 (cdr (assoc 'file loc
)))
55 (defsubst geiser-edit--to-number
(x)
57 ((stringp x
) (string-to-number x
))))
59 (defsubst geiser-edit--location-line
(loc)
60 (geiser-edit--to-number (cdr (assoc 'line loc
))))
62 (defsubst geiser-edit--location-column
(loc)
63 (geiser-edit--to-number (cdr (assoc 'column loc
))))
65 (defsubst geiser-edit--make-location
(name file line column
)
66 `((name .
,name
) (file .
,file
) (line .
,line
) (column .
,column
)))
68 (defconst geiser-edit--def-re
69 (regexp-opt '("define"
81 (defconst geiser-edit--def-re
*
82 (regexp-opt '("define-syntaxes" "define-values")))
84 (defsubst geiser-edit--def-re
(thing)
85 (format "(%s +(?%s\\_>"
87 (regexp-quote (format "%s" thing
))))
89 (defsubst geiser-edit--def-re
* (thing)
90 (format "(%s +([^)]*?\\_<%s\\_>"
92 (regexp-quote (format "%s" thing
))))
94 (defsubst geiser-edit--symbol-re
(thing)
95 (format "\\_<%s\\_>" (regexp-quote (format "%s" thing
))))
97 (defun geiser-edit--goto-line (symbol line
)
98 (goto-char (point-min))
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)))))
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
)
119 (cons (current-buffer) (point))))
121 (defsubst geiser-edit--try-edit
(symbol ret
&optional method
)
122 (geiser-edit--try-edit-location symbol
123 (geiser-eval--retort-result ret
)
129 (define-button-type 'geiser-edit--button
130 'action
'geiser-edit--button-action
131 'face
'geiser-font-lock-error-link
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
))))
139 (defun geiser-edit--make-link (beg end file line col
&optional method
)
141 :type
'geiser-edit--button
142 'geiser-method method
144 (geiser-edit--make-location 'error file line col
)
145 'help-echo
"Go to error location"))
147 (defconst geiser-edit--default-file-rx
148 "^\\([^<>:\n\"]+\\):\\([0-9]+\\):\\([0-9]+\\)")
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)))
154 (while (re-search-forward rx nil t
)
155 (geiser-edit--make-link (match-beginning 1)
161 (unless no-fill
(fill-region (match-end 0) (point-at-eol)))))))
163 (defun geiser-edit--open-next (&optional n reset
)
166 (nxt (if (< n
0) 'backward-button
'forward-button
))
167 (msg (if (< n
0) "previous" "next"))
171 (when reset
(goto-char (point-min)))
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
))
179 (push-button (point))))))
182 (error "No %s error" msg
))))
188 (defvar geiser-edit--symbol-history nil
)
190 (defun geiser-edit-symbol (symbol &optional method marker
)
191 "Asks for a symbol to edit, with completion."
193 (list (geiser-completion--read-symbol "Edit symbol: "
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
))))
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."
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
))))
211 (defun geiser-pop-symbol-stack ()
212 "Pop back to where \\[geiser-edit-symbol-at-point] was last invoked."
216 (error "No previous location for find symbol invocation")))
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
)))
225 (provide 'geiser-edit
)
226 ;;; geiser-edit.el ends here