elisp/geiser-xref.el

   1 ;; geiser-xref.el -- utilities for cross-referencing
   2
   3 ;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
   4
   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>.
   9
  10 ;; Start date: Thu Mar 05, 2009 23:03
  11
  12 \f
  13
  14 (require' geiser-edit)
  15 (require 'geiser-autodoc)
  16 (require 'geiser-eval)
  17 (require 'geiser-popup)
  18 (require 'geiser-custom)
  19 (require 'geiser-base)
  20
  21 (require 'button)
  22 (require 'lisp-mode)
  23
  24 \f
  25 ;;; Customization:
  26 (defgroup geiser-xref nil
  27   "Options for cross-referencing commands."
  28   :group 'geiser)
  29
  30 (geiser-edit--define-custom-visit
  31  geiser-xref-follow-link-method geiser-xref
  32  "How to visit buffers when following xrefs.")
  33
  34 (geiser-custom--defface xref-link
  35   'link geiser-xref "links in cross-reference buffers")
  36
  37 (geiser-custom--defface xref-header
  38   'bold geiser-xref "headers in cross-reference buffers")
  39
  40 \f
  41 ;;; Buffer and mode:
  42
  43 (geiser-popup--define xref "*Geiser xref*" geiser-xref-mode)
  44
  45 (defvar geiser-xref-mode-map
  46   (let ((map (make-sparse-keymap)))
  47     (suppress-keymap map)
  48     (set-keymap-parent map button-buffer-map)
  49     map))
  50
  51 (defun geiser-xref-mode ()
  52   "Major mode for displaying cross-references.
  53 \\{geiser-xref-mode-map}"
  54   (interactive)
  55   (kill-all-local-variables)
  56   (buffer-disable-undo)
  57   (use-local-map geiser-xref-mode-map)
  58   (set-syntax-table scheme-mode-syntax-table)
  59   (setq mode-name "Geiser Xref")
  60   (setq major-mode 'geiser-xref-mode)
  61   (setq buffer-read-only t))
  62
  63 \f
  64 ;;; Ref button:
  65
  66 (define-button-type 'geiser-xref--button
  67   'action 'geiser-xref--button-action
  68   'face 'geiser-font-lock-xref-link
  69   'follow-link t)
  70
  71 (defun geiser-xref--button-action (button)
  72   (let ((location (button-get button 'location))
  73         (name (button-get button 'name)))
  74     (when location
  75       (geiser-edit--try-edit-location name
  76                                       location
  77                                       geiser-xref-follow-link-method))))
  78
  79 (defun geiser-xref--insert-button (xref)
  80   (let* ((location (cdr (assoc "location" xref)))
  81          (file (geiser-edit--location-file location))
  82          (signature (cdr (assoc "signature" xref)))
  83          (signature-txt (and signature
  84                              (geiser-autodoc--str* signature)))
  85          (module (cdr (assoc "module" xref)))
  86          (p (point)))
  87     (when signature
  88       (insert "   - ")
  89       (if (stringp file)
  90           (insert-text-button signature-txt
  91                               :type 'geiser-xref--button
  92                               'location location
  93                               'name (car signature)
  94                               'help-echo (format "%s in %s"
  95                                                  (car signature) file))
  96         (insert (format "%s" signature-txt)))
  97       (fill-region p (point))
  98       (save-excursion (goto-char p) (indent-sexp))
  99       (newline))))
 100
 101 (defun geiser-xref--module< (xr1 xr2)
 102   (let ((m1 (format "%s" (cdr (assoc "module" xr1))))
 103         (m2 (format "%s" (cdr (assoc "module" xr2)))))
 104     (cond ((equal m1 m2)
 105            (string< (format "%s" (cdr (assoc "signature" xr1)))
 106                     (format "%s" (cdr (assoc "signature" xr2)))))
 107           ((null m1) (not m2))
 108           ((null m2))
 109           (t (string< (format "%s" m1) (format "%s" m2))))))
 110
 111 (defun geiser-xref--display-xrefs (header xrefs)
 112   (geiser-xref--with-buffer
 113    (erase-buffer)
 114    (geiser--insert-with-face header 'geiser-font-lock-xref-header)
 115    (newline)
 116    (let ((last-module))
 117      (dolist (xref (sort xrefs 'geiser-xref--module<))
 118        (let ((module (format "%s" (cdr (assoc "module" xref)))))
 119          (when (not (equal module last-module))
 120            (insert "\n  In module ")
 121            (geiser--insert-with-face (format "%s" module)
 122                                      'geiser-font-lock-xref-header)
 123            (newline 2)
 124            (setq last-module module))
 125          (geiser-xref--insert-button xref)))))
 126   (geiser-xref--pop-to-buffer)
 127   (goto-char (point-min)))
 128
 129 (defun geiser-xref--read-name (ask prompt)
 130   (let ((name (or (and (not ask) (geiser--symbol-at-point))
 131                   (read-string prompt nil nil (geiser--symbol-at-point)))))
 132     (and name (format "%s" name))))
 133
 134 (defun geiser-xref--fetch-xrefs (ask kind rkind proc)
 135   (let* ((name (geiser-xref--read-name ask (format "%s: " (capitalize kind))))
 136          (res (and name (geiser-eval--send/result
 137                          `(:eval (:ge ,proc (quote (:scm ,name))))))))
 138     (message "Retrieving %ss list for '%s'..." rkind name)
 139     (if (or (not res) (not (listp res)))
 140         (message "No %ss found for '%s'" rkind name)
 141       (message "")
 142       (geiser-xref--display-xrefs (format "%ss for '%s'"
 143                                           (capitalize rkind)
 144                                           name)
 145                                   res))))
 146
 147 \f
 148 ;;; Commands:
 149
 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."
 153   (interactive "P")
 154   (geiser-xref--fetch-xrefs arg "generic" "method" 'generic-methods))
 155
 156 (defun geiser-xref-callers (&optional arg)
 157   "Display list of callers for procedure at point.
 158 With prefix, ask for the procedure."
 159   (interactive "P")
 160   (geiser-xref--fetch-xrefs arg "procedure" "caller" 'callers))
 161
 162 (defun geiser-xref-callees (&optional arg)
 163   "Display list of callees for procedure at point.
 164 With prefix, ask for the procedure."
 165   (interactive "P")
 166   (geiser-xref--fetch-xrefs arg "procedure" "callee" 'callees))
 167
 168 \f
 169 (provide 'geiser-xref)