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
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 (geiser-popup--define xref
"*Geiser xref*" geiser-xref-mode
)
45 (defvar geiser-xref-mode-map
46 (let ((map (make-sparse-keymap)))
48 (set-keymap-parent map button-buffer-map
)
50 "Keymap for `geiser-xref-mode'.")
52 (define-derived-mode geiser-xref-mode nil
"Geiser Xref"
53 "Major mode for displaying cross-references.
54 \\{geiser-xref-mode-map}"
56 (set-syntax-table scheme-mode-syntax-table
)
57 (setq buffer-read-only t
))
62 (define-button-type 'geiser-xref--button
63 'action
'geiser-xref--button-action
64 'face
'geiser-font-lock-xref-link
67 (defun geiser-xref--button-action (button)
68 (let ((location (button-get button
'location
))
69 (name (button-get button
'name
)))
71 (geiser-edit--try-edit-location name
73 geiser-xref-follow-link-method
))))
75 (defun geiser-xref--insert-button (xref)
76 (let* ((location (cdr (assoc "location" xref
)))
77 (file (geiser-edit--location-file location
))
78 (signature (cdr (assoc "signature" xref
)))
79 (signature-txt (and signature
80 (geiser-autodoc--str* signature
)))
81 (module (cdr (assoc "module" xref
)))
86 (insert-text-button signature-txt
87 :type
'geiser-xref--button
90 'help-echo
(format "%s in %s"
91 (car signature
) file
))
92 (insert (format "%s" signature-txt
)))
93 (fill-region p
(point))
94 (save-excursion (goto-char p
) (indent-sexp))
97 (defun geiser-xref--module< (xr1 xr2
)
98 (let ((m1 (format "%s" (cdr (assoc "module" xr1
))))
99 (m2 (format "%s" (cdr (assoc "module" xr2
)))))
101 (string< (format "%s" (cdr (assoc "signature" xr1
)))
102 (format "%s" (cdr (assoc "signature" xr2
)))))
105 (t (string< (format "%s" m1
) (format "%s" m2
))))))
107 (defun geiser-xref--display-xrefs (header xrefs
)
108 (geiser-xref--with-buffer
110 (geiser--insert-with-face header
'geiser-font-lock-xref-header
)
113 (dolist (xref (sort xrefs
'geiser-xref--module
<))
114 (let ((module (format "%s" (cdr (assoc "module" xref
)))))
115 (when (not (equal module last-module
))
116 (insert "\n In module ")
117 (geiser--insert-with-face (format "%s" module
)
118 'geiser-font-lock-xref-header
)
120 (setq last-module module
))
121 (geiser-xref--insert-button xref
)))))
122 (geiser-xref--pop-to-buffer)
123 (goto-char (point-min)))
125 (defun geiser-xref--read-name (ask prompt
)
126 (let ((name (or (and (not ask
) (geiser--symbol-at-point))
127 (read-string prompt nil nil
(geiser--symbol-at-point)))))
128 (and name
(format "%s" name
))))
130 (defun geiser-xref--fetch-xrefs (ask kind rkind proc
)
131 (let* ((name (geiser-xref--read-name ask
(format "%s: " (capitalize kind
))))
132 (res (and name
(geiser-eval--send/result
133 `(:eval
(:ge
,proc
(quote (:scm
,name
))))))))
134 (message "Retrieving %ss list for '%s'..." rkind name
)
135 (if (or (not res
) (not (listp res
)))
136 (message "No %ss found for '%s'" rkind name
)
138 (geiser-xref--display-xrefs (format "%ss for '%s'"
146 (defun geiser-xref-generic-methods (&optional arg
)
147 "Display information about known methods of a given generic.
148 With prefix, ask for the name of the generic."
150 (geiser-xref--fetch-xrefs arg
"generic" "method" 'generic-methods
))
152 (defun geiser-xref-callers (&optional arg
)
153 "Display list of callers for procedure at point.
154 With prefix, ask for the procedure."
156 (geiser-xref--fetch-xrefs arg
"procedure" "caller" 'callers
))
158 (defun geiser-xref-callees (&optional arg
)
159 "Display list of callees for procedure at point.
160 With prefix, ask for the procedure."
162 (geiser-xref--fetch-xrefs arg
"procedure" "callee" 'callees
))
165 (provide 'geiser-xref
)