1 ;;; geiser-xref.el -- utilities for cross-referencing
3 ;; Copyright (C) 2009, 2010, 2012 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
15 (require' geiser-edit
)
16 (require 'geiser-autodoc
)
17 (require 'geiser-eval
)
18 (require 'geiser-popup
)
19 (require 'geiser-custom
)
20 (require 'geiser-base
)
27 (defgroup geiser-xref nil
28 "Options for cross-referencing commands."
31 (geiser-edit--define-custom-visit
32 geiser-xref-follow-link-method geiser-xref
33 "How to visit buffers when following xrefs.")
35 (geiser-custom--defface xref-link
36 'link geiser-xref
"links in cross-reference buffers")
38 (geiser-custom--defface xref-header
39 'bold geiser-xref
"headers in cross-reference buffers")
44 (geiser-popup--define xref
"*Geiser xref*" geiser-xref-mode
)
46 (defvar geiser-xref-mode-map
47 (let ((map (make-sparse-keymap)))
49 (set-keymap-parent map button-buffer-map
)
51 "Keymap for `geiser-xref-mode'.")
53 (define-derived-mode geiser-xref-mode nil
"Geiser Xref"
54 "Major mode for displaying cross-references.
55 \\{geiser-xref-mode-map}"
57 (set-syntax-table scheme-mode-syntax-table
)
58 (setq buffer-read-only t
))
63 (define-button-type 'geiser-xref--button
64 'action
'geiser-xref--button-action
65 'face
'geiser-font-lock-xref-link
68 (defun geiser-xref--button-action (button)
69 (let ((location (button-get button
'location
))
70 (name (button-get button
'name
)))
72 (geiser-edit--try-edit-location name
74 geiser-xref-follow-link-method
))))
76 (defun geiser-xref--insert-button (xref)
77 (let* ((location (cdr (assoc "location" xref
)))
78 (file (geiser-edit--location-file location
))
79 (signature (cdr (assoc "signature" xref
)))
80 (signature-txt (and signature
81 (geiser-autodoc--str* signature
)))
82 (module (cdr (assoc "module" xref
)))
87 (insert-text-button signature-txt
88 :type
'geiser-xref--button
91 'help-echo
(format "%s in %s"
92 (car signature
) file
))
93 (insert (format "%s" signature-txt
)))
94 (fill-region p
(point))
95 (save-excursion (goto-char p
) (indent-sexp))
98 (defun geiser-xref--module< (xr1 xr2
)
99 (let ((m1 (format "%s" (cdr (assoc "module" xr1
))))
100 (m2 (format "%s" (cdr (assoc "module" xr2
)))))
102 (string< (format "%s" (cdr (assoc "signature" xr1
)))
103 (format "%s" (cdr (assoc "signature" xr2
)))))
106 (t (string< (format "%s" m1
) (format "%s" m2
))))))
108 (defun geiser-xref--display-xrefs (header xrefs
)
109 (geiser-xref--with-buffer
111 (geiser--insert-with-face header
'geiser-font-lock-xref-header
)
114 (dolist (xref (sort xrefs
'geiser-xref--module
<))
115 (let ((module (format "%s" (cdr (assoc "module" xref
)))))
116 (when (not (equal module last-module
))
117 (insert "\n In module ")
118 (geiser--insert-with-face (format "%s" module
)
119 'geiser-font-lock-xref-header
)
121 (setq last-module module
))
122 (geiser-xref--insert-button xref
)))))
123 (geiser-xref--pop-to-buffer)
124 (goto-char (point-min)))
126 (defun geiser-xref--read-name (ask prompt
)
127 (let ((name (or (and (not ask
) (geiser--symbol-at-point))
128 (read-string prompt nil nil
(geiser--symbol-at-point)))))
129 (and name
(format "%s" name
))))
131 (defun geiser-xref--fetch-xrefs (ask kind rkind proc
)
132 (let* ((name (geiser-xref--read-name ask
(format "%s: " (capitalize kind
))))
133 (res (and name
(geiser-eval--send/result
134 `(:eval
(:ge
,proc
(quote (:scm
,name
))))))))
135 (message "Retrieving %ss list for '%s'..." rkind name
)
136 (if (or (not res
) (not (listp res
)))
137 (message "No %ss found for '%s'" rkind name
)
139 (geiser-xref--display-xrefs (format "%ss for '%s'"
147 (defun geiser-xref-generic-methods (&optional arg
)
148 "Display information about known methods of a given generic.
149 With prefix, ask for the name of the generic."
151 (geiser-xref--fetch-xrefs arg
"generic" "method" 'generic-methods
))
153 (defun geiser-xref-callers (&optional arg
)
154 "Display list of callers for procedure at point.
155 With prefix, ask for the procedure."
157 (geiser-xref--fetch-xrefs arg
"procedure" "caller" 'callers
))
159 (defun geiser-xref-callees (&optional arg
)
160 "Display list of callees for procedure at point.
161 With prefix, ask for the procedure."
163 (geiser-xref--fetch-xrefs arg
"procedure" "callee" 'callees
))
166 (provide 'geiser-xref
)