geiser-xref.el (5616B)
1 ;;; geiser-xref.el -- utilities for cross-referencing -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009, 2010, 2012, 2022 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 13 ;;; Code: 14 15 (require' geiser-edit) 16 (require 'geiser-autodoc) 17 (require 'geiser-eval) 18 (require 'geiser-popup) 19 (require 'geiser-custom) 20 (require 'geiser-base) 21 22 (require 'button) 23 (require 'lisp-mode) 24 25 26 ;;; Customization: 27 (defgroup geiser-xref nil 28 "Options for cross-referencing commands." 29 :group 'geiser) 30 31 (geiser-edit--define-custom-visit 32 geiser-xref-follow-link-method geiser-xref 33 "How to visit buffers when following xrefs.") 34 35 (geiser-custom--defface xref-link 36 'link geiser-xref "links in cross-reference buffers") 37 38 (geiser-custom--defface xref-header 39 'bold geiser-xref "headers in cross-reference buffers") 40 41 42 ;;; Buffer and mode: 43 44 (geiser-popup--define xref "*Geiser Xref*" geiser-xref-mode) 45 46 (defvar geiser-xref-mode-map 47 (let ((map (make-sparse-keymap))) 48 (suppress-keymap map) 49 (set-keymap-parent map button-buffer-map) 50 map) 51 "Keymap for `geiser-xref-mode'.") 52 53 (define-derived-mode geiser-xref-mode nil "Geiser Xref" 54 "Major mode for displaying cross-references. 55 \\{geiser-xref-mode-map}" 56 (buffer-disable-undo) 57 (set-syntax-table scheme-mode-syntax-table) 58 (setq buffer-read-only t)) 59 60 61 ;;; Ref button: 62 63 (define-button-type 'geiser-xref--button 64 'action 'geiser-xref--button-action 65 'face 'geiser-font-lock-xref-link 66 'follow-link t) 67 68 (defun geiser-xref--button-action (button) 69 (let ((location (button-get button 'location)) 70 (name (button-get button 'name))) 71 (when location 72 (geiser-edit--try-edit-location name 73 location 74 geiser-xref-follow-link-method)))) 75 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 (p (point))) 83 (when signature 84 (insert " - ") 85 (if (stringp file) 86 (insert-text-button signature-txt 87 :type 'geiser-xref--button 88 'location location 89 'name (car signature) 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)) 95 (newline)))) 96 97 (defun geiser-xref--module< (xr1 xr2) 98 (let ((m1 (format "%s" (cdr (assoc "module" xr1)))) 99 (m2 (format "%s" (cdr (assoc "module" xr2))))) 100 (cond ((equal m1 m2) 101 (string< (format "%s" (cdr (assoc "signature" xr1))) 102 (format "%s" (cdr (assoc "signature" xr2))))) 103 ((null m1) (not m2)) 104 ((null m2)) 105 (t (string< (format "%s" m1) (format "%s" m2)))))) 106 107 (defun geiser-xref--display-xrefs (header xrefs) 108 (geiser-xref--with-buffer 109 (erase-buffer) 110 (geiser--insert-with-face header 'geiser-font-lock-xref-header) 111 (newline) 112 (let ((last-module)) 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) 119 (newline 2) 120 (setq last-module module)) 121 (geiser-xref--insert-button xref))))) 122 (geiser-xref--pop-to-buffer) 123 (goto-char (point-min))) 124 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)))) 129 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) 137 (message "") 138 (geiser-xref--display-xrefs (format "%ss for '%s'" 139 (capitalize rkind) 140 name) 141 res)))) 142 143 144 ;;; Commands: 145 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." 149 (interactive "P") 150 (geiser-xref--fetch-xrefs arg "generic" "method" 'generic-methods)) 151 152 (defun geiser-xref-callers (&optional arg) 153 "Display list of callers for procedure at point. 154 With prefix, ask for the procedure." 155 (interactive "P") 156 (geiser-xref--fetch-xrefs arg "procedure" "caller" 'callers)) 157 158 (defun geiser-xref-callees (&optional arg) 159 "Display list of callees for procedure at point. 160 With prefix, ask for the procedure." 161 (interactive "P") 162 (geiser-xref--fetch-xrefs arg "procedure" "callee" 'callees)) 163 164 165 (provide 'geiser-xref)