1 ;; geiser-xref.el -- utilities for cross-referencing
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: Thu Mar 05, 2009 23:03
14 (require' geiser-edit
)
15 (require 'geiser-autodoc
)
16 (require 'geiser-eval
)
17 (require 'geiser-popup
)
18 (require 'geiser-custom
)
19 (require 'geiser-base
)
26 (defgroup geiser-xref nil
27 "Options for cross-referencing commands."
30 (geiser-edit--define-custom-visit
31 geiser-xref-follow-link-method geiser-xref
32 "How to visit buffers when following xrefs.")
34 (geiser-custom--defface xref-link
35 'link geiser-xref
"links in cross-reference buffers")
37 (geiser-custom--defface xref-header
38 'bold geiser-xref
"headers in cross-reference buffers")
43 (define-button-type 'geiser-xref--button
44 'action
'geiser-xref--button-action
45 'face
'geiser-font-lock-xref-link
48 (defun geiser-xref--button-action (button)
49 (let ((location (button-get button
'location
))
50 (name (button-get button
'name
)))
52 (geiser-edit--try-edit-location name
54 geiser-xref-follow-link-method
))))
56 (defun geiser-xref--insert-button (xref)
57 (let* ((location (cdr (assoc "location" xref
)))
58 (file (geiser-edit--location-file location
))
59 (signature (cdr (assoc "signature" xref
)))
60 (signature-txt (and signature
61 (geiser-autodoc--str* signature
)))
62 (module (cdr (assoc "module" xref
)))
67 (insert-text-button signature-txt
68 :type
'geiser-xref--button
71 'help-echo
(format "%s in %s"
72 (car signature
) file
))
73 (insert (format "%s" signature-txt
)))
74 (fill-region p
(point))
75 (save-excursion (goto-char p
) (indent-sexp))
78 (defun geiser-xref--module< (xr1 xr2
)
79 (let ((m1 (format "%s" (cdr (assoc "module" xr1
))))
80 (m2 (format "%s" (cdr (assoc "module" xr2
)))))
82 (string< (format "%s" (cdr (assoc "signature" xr1
)))
83 (format "%s" (cdr (assoc "signature" xr2
)))))
86 (t (string< (format "%s" m1
) (format "%s" m2
))))))
88 (defun geiser-xref--display-xrefs (header xrefs
)
89 (geiser-xref--with-buffer
91 (geiser--insert-with-face header
'geiser-font-lock-xref-header
)
94 (dolist (xref (sort xrefs
'geiser-xref--module
<))
95 (let ((module (format "%s" (cdr (assoc "module" xref
)))))
96 (when (not (equal module last-module
))
97 (insert "\n In module ")
98 (geiser--insert-with-face (format "%s" module
)
99 'geiser-font-lock-xref-header
)
101 (setq last-module module
))
102 (geiser-xref--insert-button xref
)))))
103 (geiser-xref--pop-to-buffer)
104 (goto-char (point-min)))
106 (defun geiser-xref--read-name (ask prompt
)
107 (let ((name (or (and (not ask
) (geiser--symbol-at-point))
108 (read-string prompt nil nil
(geiser--symbol-at-point)))))
109 (and name
(format "%s" name
))))
111 (defun geiser-xref--fetch-xrefs (ask kind rkind proc
)
112 (let* ((name (geiser-xref--read-name ask
(format "%s: " (capitalize kind
))))
113 (res (and name
(geiser-eval--send/result
114 `(:eval
(:ge
,proc
(quote (:scm
,name
))))))))
115 (message "Retrieving %ss list for '%s'..." rkind name
)
116 (if (or (not res
) (not (listp res
)))
117 (message "No %ss found for '%s'" rkind name
)
119 (geiser-xref--display-xrefs (format "%ss for '%s'"
127 (geiser-popup--define xref
"*Geiser xref*" geiser-xref-mode
)
129 (defvar geiser-xref-mode-map
130 (let ((map (make-sparse-keymap)))
131 (suppress-keymap map
)
132 (set-keymap-parent map button-buffer-map
)
135 (defun geiser-xref-mode ()
136 "Major mode for displaying cross-references.
137 \\{geiser-xref-mode-map}"
139 (kill-all-local-variables)
140 (buffer-disable-undo)
141 (use-local-map geiser-xref-mode-map
)
142 (set-syntax-table scheme-mode-syntax-table
)
143 (setq mode-name
"Geiser Xref")
144 (setq major-mode
'geiser-xref-mode
)
145 (setq buffer-read-only t
))
150 (defun geiser-xref-generic-methods (&optional arg
)
151 "Display information about known methods of a given generic.
152 With prefix, ask for the name of the generic."
154 (geiser-xref--fetch-xrefs arg
"generic" "method" 'generic-methods
))
156 (defun geiser-xref-callers (&optional arg
)
157 "Display list of callers for procedure at point.
158 With prefix, ask for the procedure."
160 (geiser-xref--fetch-xrefs arg
"procedure" "caller" 'callers
))
162 (defun geiser-xref-callees (&optional arg
)
163 "Display list of callees for procedure at point.
164 With prefix, ask for the procedure."
166 (geiser-xref--fetch-xrefs arg
"procedure" "callee" 'callees
))
169 (provide 'geiser-xref
)
170 ;;; geiser-xref.el ends here