1 ;;; geiser-edit.el -- scheme edit locations
3 ;; Copyright (C) 2009, 2010, 2012, 2013 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 "^[ \t]*\\([^<>:\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
))))
186 (defun geiser-edit--cloak (form)
187 (intern (format "geiser-edit-cloak-%s" form
)))
189 (defun geiser-edit--hide (form)
190 (geiser-edit--show form
)
191 (let ((cloak (geiser-edit--cloak form
)))
193 (goto-char (point-min))
194 (while (re-search-forward (format "(%s\\b" form
) nil t
)
195 (let* ((beg (match-beginning 0))
196 (end (progn (ignore-errors (goto-char beg
) (forward-sexp))
199 (overlay-put (make-overlay beg end
) 'invisible cloak
)))))
200 (add-to-invisibility-spec (cons cloak t
))))
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
))))
207 (defun geiser-edit--show-all ()
209 (setq buffer-invisibility-spec
'(t)))
211 (defun geiser-edit--toggle-visibility (form)
212 (if (and (listp buffer-invisibility-spec
)
213 (assoc (geiser-edit--cloak form
) buffer-invisibility-spec
))
214 (geiser-edit--show form
)
215 (geiser-edit--hide form
)))
220 (defvar geiser-edit--symbol-history nil
)
222 (defun geiser-edit-symbol (symbol &optional method marker
)
223 "Asks for a symbol to edit, with completion."
225 (list (geiser-completion--read-symbol "Edit symbol: "
227 geiser-edit--symbol-history
)))
228 (let ((cmd `(:eval
(:ge symbol-location
',symbol
))))
229 (geiser-edit--try-edit symbol
(geiser-eval--send/wait cmd
) method
)
230 (when marker
(ring-insert find-tag-marker-ring marker
))))
232 (defun geiser-edit-symbol-at-point (&optional arg
)
233 "Opens a new window visiting the definition of the symbol at point.
234 With prefix, asks for the symbol to edit."
236 (let* ((symbol (or (and (not arg
) (geiser--symbol-at-point))
237 (geiser-completion--read-symbol "Edit symbol: ")))
238 (cmd `(:eval
(:ge symbol-location
',symbol
)))
239 (marker (point-marker)))
241 (progn (geiser-edit--try-edit symbol
(geiser-eval--send/wait cmd
))
242 (when marker
(ring-insert find-tag-marker-ring marker
)))
243 (error (condition-case nil
244 (geiser-edit-module-at-point)
245 (error (error (error-message-string err
))))))))
247 (defun geiser-pop-symbol-stack ()
248 "Pop back to where \\[geiser-edit-symbol-at-point] was last invoked."
252 (error "No previous location for find symbol invocation")))
254 (defun geiser-edit-module (module &optional method
)
255 "Asks for a module and opens it in a new buffer."
256 (interactive (list (geiser-completion--read-module)))
257 (let ((cmd `(:eval
(:ge module-location
'(:module
,module
)))))
258 (geiser-edit--try-edit module
(geiser-eval--send/wait cmd
) method
)))
261 (defun geiser-edit-module-at-point ()
262 "Opens a new window visiting the module at point."
264 (let ((marker (point-marker)))
265 (geiser-edit-module (or (geiser-completion--module-at-point)
266 (geiser-completion--read-module)))
267 (when marker
(ring-insert find-tag-marker-ring marker
))))
271 (provide 'geiser-edit
)