geiser-doc.el (18402B)
1 ;;; geiser-doc.el -- accessing scheme-provided documentation -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2016, 2021-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: Sat Feb 14, 2009 14:09 11 12 13 ;;; Code: 14 15 (require 'geiser-edit) 16 (require 'geiser-impl) 17 (require 'geiser-completion) 18 (require 'geiser-autodoc) 19 (require 'geiser-eval) 20 (require 'geiser-syntax) 21 (require 'geiser-menu) 22 (require 'geiser-popup) 23 (require 'geiser-custom) 24 (require 'geiser-base) 25 26 (require 'button) 27 (eval-when-compile (require 'subr-x)) 28 29 30 ;;; Customization: 31 32 (defgroup geiser-doc nil 33 "Options for documentation buffers." 34 :group 'geiser) 35 36 (geiser-custom--defface doc-title 37 'bold geiser-doc "article titles in documentation buffers") 38 39 (geiser-custom--defface doc-link 40 'link geiser-doc "links in documentation buffers") 41 42 (geiser-custom--defface doc-button 43 'button geiser-doc "buttons in documentation buffers") 44 45 46 ;;; Implementation 47 (geiser-impl--define-caller geiser-doc--external-help external-help 48 (symbol module) 49 "By default, Geiser will display help about an identifier in a 50 help buffer, after collecting the associated signature and 51 docstring. You can provide an alternative function for displaying 52 help (e.g. browse an HTML page) implementing this method.") 53 54 (geiser-impl--define-caller geiser-doc--display-docstring 55 display-docstring (ret) 56 "This method receives the result of calling the geiser scheme 57 procedure symbol-documentation and should display it in the 58 current buffer. By default, geiser looks for the value of the 59 key docstring in the result, assumed to be an alist, and inserts 60 it verbatim at point if it's a string. Providing an 61 implementation of this method may be useful if displaying the 62 info returned by the scheme side (display-docstring) needs more 63 elaboration on emacs' side. This method should return a truthy 64 value if the default action should be skipped.") 65 66 67 ;;; Documentation browser history: 68 69 (defvar geiser-doc-history-size 50) 70 (defvar geiser-doc--history nil) 71 72 (defun geiser-doc--make-history () 73 (list nil ; current 74 (make-ring geiser-doc-history-size) ; previous 75 (make-ring geiser-doc-history-size))) ; next 76 77 (setq geiser-doc--history (geiser-doc--make-history)) 78 79 (defsubst geiser-doc--history-current () 80 (car geiser-doc--history)) 81 82 (defsubst geiser-doc--history-previous-link () 83 (ring-ref (cadr geiser-doc--history) 0)) 84 85 (defsubst geiser-doc--history-next-link () 86 (ring-ref (car (cddr geiser-doc--history)) 0)) 87 88 (defun geiser-doc--history-push (link) 89 (unless (or (null link) (equal link (geiser-doc--history-current))) 90 (when (not (null (geiser-doc--history-current))) 91 (let ((next (geiser-doc--history-next))) 92 (unless (equal link next) 93 (when next (geiser-doc--history-previous)) 94 (ring-insert (nth 1 geiser-doc--history) 95 (car geiser-doc--history))))) 96 (setcar geiser-doc--history link)) 97 link) 98 99 (defsubst geiser-doc--history-next-p () 100 (not (ring-empty-p (nth 2 geiser-doc--history)))) 101 102 (defun geiser-doc--history-next (&optional forget-current) 103 (when (geiser-doc--history-next-p) 104 (when (and (car geiser-doc--history) (not forget-current)) 105 (ring-insert (nth 1 geiser-doc--history) (car geiser-doc--history))) 106 (setcar geiser-doc--history (ring-remove (nth 2 geiser-doc--history) 0)))) 107 108 (defsubst geiser-doc--history-previous-p () 109 (not (ring-empty-p (nth 1 geiser-doc--history)))) 110 111 (defun geiser-doc--history-previous (&optional forget-current) 112 (when (geiser-doc--history-previous-p) 113 (when (and (car geiser-doc--history) (not forget-current)) 114 (ring-insert (nth 2 geiser-doc--history) (car geiser-doc--history))) 115 (setcar geiser-doc--history (ring-remove (nth 1 geiser-doc--history) 0)))) 116 117 118 ;;; Links 119 120 (defsubst geiser-doc--make-link (target module impl) 121 (list target module impl)) 122 123 (defsubst geiser-doc--link-target (link) 124 (nth 0 link)) 125 126 (defsubst geiser-doc--link-module (link) 127 (nth 1 link)) 128 129 (defsubst geiser-doc--link-impl (link) 130 (nth 2 link)) 131 132 (defun geiser-doc--follow-link (link) 133 (let ((target (geiser-doc--link-target link)) 134 (module (geiser-doc--link-module link)) 135 (impl (geiser-doc--link-impl link))) 136 (when (and (or target module) impl) 137 (with--geiser-implementation impl 138 (if (null target) 139 (geiser-doc-module module impl) 140 (let ((geiser-eval--get-module-function (lambda (_) module))) 141 (geiser-doc-symbol target module impl))))))) 142 143 (defvar-local geiser-doc--buffer-link nil) 144 145 (defsubst geiser-doc--implementation () 146 (geiser-doc--link-impl geiser-doc--buffer-link)) 147 148 (defun geiser-doc--button-action (button) 149 (let ((link (button-get button 'geiser-link))) 150 (when link (geiser-doc--follow-link link)))) 151 152 (define-button-type 'geiser-doc--button 153 'action 'geiser-doc--button-action 154 'follow-link t) 155 156 (defun geiser-doc--make-module-button (beg end module impl) 157 (let ((link (geiser-doc--make-link nil module impl)) 158 (help (format "Help for module %s" module))) 159 (make-text-button beg end :type 'geiser-doc--button 160 'face 'geiser-font-lock-doc-link 161 'geiser-link link 162 'help-echo help))) 163 164 (defun geiser-doc--insert-button (target module impl &optional sign) 165 (let* ((link (geiser-doc--make-link target module impl)) 166 (sign (when sign (if (listp sign) sign (list target)))) 167 (text (format "%s" (or (and sign (geiser-autodoc--str* sign)) 168 target 169 module))) 170 (help (format "%smodule %s" 171 (if target (format "%s in " target) "") 172 (or module "<unknown>")))) 173 (insert-text-button text 174 :type 'geiser-doc--button 175 'face 'geiser-font-lock-doc-link 176 'geiser-link link 177 'help-echo help))) 178 179 (defun geiser-doc-goto-source () 180 "Go to the definition of this item." 181 (interactive) 182 (when-let (link geiser-doc--buffer-link) 183 (with--geiser-implementation (geiser-doc--link-impl link) 184 (if-let (target (geiser-doc--link-target link)) 185 (geiser-edit-symbol target nil (point-marker)) 186 (geiser-edit-module (geiser-doc--link-module link)))))) 187 188 (defun geiser-doc-goto-manual () 189 "Go to the manual for this item." 190 (interactive) 191 (when-let (link geiser-doc--buffer-link) 192 (let ((tm (geiser-doc--link-target link)) 193 (mod (geiser-doc--link-module link)) 194 (impl (geiser-doc--link-impl link))) 195 (geiser-doc--external-help impl (or tm mod) mod)))) 196 197 (defun geiser-doc--xbutton-action (button) 198 (let ((k (button-get button 'x-kind))) 199 (cond ((eq 'source k) (geiser-doc-goto-source)) 200 ((eq 'manual k) (geiser-doc-goto-manual))))) 201 202 (define-button-type 'geiser-doc--xbutton 203 'action 'geiser-doc--xbutton-action 204 'face 'geiser-font-lock-doc-button 205 'follow-link t) 206 207 (defun geiser-doc--insert-xbutton (&optional manual) 208 (let ((label (if manual "[manual]" "[source]")) 209 (help (if manual "Look up in Scheme manual" "Go to definition"))) 210 (insert-text-button label 211 :type 'geiser-doc--xbutton 212 'help-echo help 213 'x-kind (if manual 'manual 'source)))) 214 215 (defun geiser-doc--insert-xbuttons (impl) 216 (when (geiser-impl--method 'external-help impl) 217 (geiser-doc--insert-xbutton t) 218 (insert " ")) 219 (geiser-doc--insert-xbutton)) 220 221 (defun geiser-doc--insert-nav-button (next) 222 (let* ((lnk (if next (geiser-doc--history-next-link) 223 (geiser-doc--history-previous-link))) 224 (what (geiser-doc--link-target lnk)) 225 (what (or what (geiser-doc--link-module lnk))) 226 (action (if next '(lambda (b) (geiser-doc-next)) 227 '(lambda (b) (geiser-doc-previous))))) 228 (insert-text-button (if next "[forward]" "[back]") 229 'action action 230 'help-echo (format "Previous help item (%s)" what) 231 'face 'geiser-font-lock-doc-button 232 'follow-link t))) 233 234 235 ;;; Auxiliary functions: 236 237 (defun geiser-doc--manual-available-p () 238 (geiser-impl--method 'external-help geiser-impl--implementation)) 239 240 (defun geiser-doc--module (&optional mod impl) 241 (let ((impl (or impl (geiser-doc--link-impl geiser-doc--buffer-link))) 242 (mod (or mod (geiser-doc--link-module geiser-doc--buffer-link)))) 243 (geiser-impl--call-method 'find-module impl mod))) 244 245 (defun geiser-doc--insert-title (title) 246 (let ((p (point))) 247 (insert (format "%s" title)) 248 (fill-paragraph nil) 249 (let ((indent-line-function 'lisp-indent-line)) 250 (indent-region p (point))) 251 (put-text-property p (point) 'face 'geiser-font-lock-doc-title) 252 (newline))) 253 254 (defun geiser-doc--insert-list (title lst module impl) 255 (when lst 256 (geiser-doc--insert-title title) 257 (newline) 258 (dolist (w lst) 259 (let ((name (car w)) 260 (signature (cdr (assoc "signature" w))) 261 (info (cdr (assoc "info" w)))) 262 (insert "\t- ") 263 (if module 264 (geiser-doc--insert-button name module impl signature) 265 (geiser-doc--insert-button nil name impl)) 266 (when info (insert (format " %s" info))) 267 (newline))) 268 (newline))) 269 270 (defun geiser-doc--insert-footer (impl) 271 (newline 2) 272 (geiser-doc--insert-xbuttons impl) 273 (let* ((prev (and (geiser-doc--history-previous-p) 8)) 274 (nxt (and (geiser-doc--history-next-p) 10)) 275 (len (max 1 (- (window-width) 276 (- (point) (line-beginning-position)) 277 (or prev 0) 278 (or nxt 0))))) 279 (when (or prev nxt) 280 (insert (make-string len ?\ ))) 281 (when prev 282 (geiser-doc--insert-nav-button nil) 283 (insert " ")) 284 (when nxt 285 (geiser-doc--insert-nav-button t)))) 286 287 288 ;;; Documentation browser and mode: 289 290 (defun geiser-doc-edit-symbol-at-point () 291 "Open definition of symbol at point." 292 (interactive) 293 (let* ((impl (geiser-doc--implementation)) 294 (module (geiser-doc--module))) 295 (unless (and impl module) 296 (error "I don't know what module this buffer refers to.")) 297 (with--geiser-implementation impl 298 (geiser-edit-symbol-at-point)))) 299 300 (defvar geiser-doc-mode-map 301 (let ((map (make-sparse-keymap))) 302 (suppress-keymap map) 303 (set-keymap-parent map button-buffer-map) 304 map) 305 "Keymap for `geiser-doc-mode'.") 306 307 (declare-function geiser-repl--switch-to-repl "geiser-repl") 308 309 (defun geiser-doc-switch-to-repl () 310 (interactive) 311 (geiser-repl--switch-to-repl)) 312 313 (geiser-menu--defmenu doc geiser-doc-mode-map 314 ("Next link" ("n") forward-button) 315 ("Previous link" ("p") backward-button) 316 ("Next section" ("N") geiser-doc-next-section) 317 ("Previous section" ("P") geiser-doc-previous-section) 318 -- 319 ("Next page" ("f") geiser-doc-next "Next item" 320 :enable (geiser-doc--history-next-p)) 321 ("Previous page" ("b") geiser-doc-previous "Previous item" 322 :enable (geiser-doc--history-previous-p)) 323 -- 324 ("Go to REPL" ("z" "\C-cz" "\C-c\C-z") geiser-doc-switch-to-repl) 325 ("Refresh" ("g" "r") geiser-doc-refresh "Refresh current page") 326 -- 327 ("Edit symbol" ("." "\M-.") geiser-doc-edit-symbol-at-point 328 :enable (geiser--symbol-at-point)) 329 ("View source" ("s") geiser-doc-goto-source) 330 ("View manual" ("m" "h") geiser-doc-goto-manual) 331 -- 332 ("Kill item" "k" geiser-doc-kill-page "Kill this page") 333 ("Clear history" "c" geiser-doc-clean-history) 334 -- 335 (custom "Browser options" geiser-doc) 336 -- 337 ("Quit" nil View-quit)) 338 339 (define-derived-mode geiser-doc-mode nil "Geiser Doc" 340 "Major mode for browsing scheme documentation. 341 \\{geiser-doc-mode-map}" 342 (buffer-disable-undo) 343 (setq truncate-lines t) 344 (set-syntax-table scheme-mode-syntax-table) 345 (setq geiser-eval--get-module-function 'geiser-doc--module) 346 (setq buffer-read-only t)) 347 348 (geiser-popup--define doc "*Geiser Documentation*" geiser-doc-mode) 349 350 351 ;;; Commands: 352 353 (defun geiser-doc--get-docstring (symbol module) 354 (geiser-eval--send/result 355 `(:eval (:ge symbol-documentation ',symbol) ,module))) 356 357 (defun geiser-doc--get-module-exports (module) 358 (geiser-eval--send/result 359 `(:eval (:ge module-exports '(:module ,module)) :f))) 360 361 (defun geiser-doc--buttonize-modules (impl) 362 (save-excursion 363 (goto-char (point-min)) 364 (while (re-search-forward "in module \\([^.\n]+\\)[.\n ]" nil t) 365 (geiser-doc--make-module-button (match-beginning 1) 366 (match-end 1) 367 (geiser-doc--module (match-string 1) 368 impl) 369 impl)))) 370 371 (defun geiser-doc--render-docstring (docstring symbol &optional module impl) 372 (erase-buffer) 373 (geiser-doc--insert-title 374 (geiser-autodoc--str* (cdr (assoc "signature" docstring)))) 375 (newline) 376 (or (geiser-doc--display-docstring impl docstring) 377 (insert (or (cdr (assoc "docstring" docstring)) ""))) 378 (geiser-doc--buttonize-modules impl) 379 (setq geiser-doc--buffer-link 380 (geiser-doc--history-push (geiser-doc--make-link symbol 381 module 382 impl))) 383 (geiser-doc--insert-footer impl) 384 (goto-char (point-min))) 385 386 (defun geiser-doc-symbol (symbol &optional module impl) 387 (let* ((impl (or impl geiser-impl--implementation)) 388 (module (geiser-doc--module (or module (geiser-eval--get-module)) 389 impl))) 390 (let ((ds (geiser-doc--get-docstring symbol module))) 391 (if (or (not ds) (not (listp ds))) 392 (message "No documentation available for '%s'" symbol) 393 (geiser-doc--with-buffer 394 (geiser-doc--render-docstring ds symbol module impl)) 395 (geiser-doc--pop-to-buffer))))) 396 397 (defun geiser-doc-symbol-at-point (&optional arg) 398 "Get docstring for symbol at point. 399 With prefix argument, ask for symbol (with completion)." 400 (interactive "P") 401 (let ((symbol (or (and (not arg) (geiser--symbol-at-point)) 402 (geiser-completion--read-symbol 403 "Symbol: " (geiser--symbol-at-point))))) 404 (when symbol (geiser-doc-symbol symbol)))) 405 406 (defun geiser-doc-manual-for-symbol (symbol) 407 (geiser-doc--external-help geiser-impl--implementation 408 symbol 409 (geiser-eval--get-module))) 410 411 (defun geiser-doc-look-up-manual (&optional arg) 412 "Look up manual for symbol at point. 413 With prefix argument, ask for the lookup symbol (with completion)." 414 (interactive "P") 415 (unless (geiser-doc--manual-available-p) 416 (error "No manual available")) 417 (let ((symbol (or (and (not arg) (geiser--symbol-at-point)) 418 (geiser-completion--read-symbol "Symbol: ")))) 419 (geiser-doc-manual-for-symbol symbol))) 420 421 (defconst geiser-doc--sections '(("Procedures:" "procs") 422 ("Syntax:" "syntax") 423 ("Variables:" "vars") 424 ("Submodules:" "modules" t))) 425 426 (defconst geiser-doc--sections-re 427 (format "^%s\n" (regexp-opt (mapcar 'car geiser-doc--sections)))) 428 429 (defun geiser-doc-module (&optional module impl) 430 "Display information about a given module." 431 (interactive) 432 (let* ((impl (or impl geiser-impl--implementation)) 433 (module (geiser-doc--module (or module 434 (geiser-completion--read-module)) 435 impl)) 436 (msg (format "Retrieving documentation for %s ..." module)) 437 (exports (progn 438 (message "%s" msg) 439 (geiser-doc--get-module-exports module)))) 440 (if (not exports) 441 (message "No information available for %s" module) 442 (geiser-doc--with-buffer 443 (erase-buffer) 444 (geiser-doc--insert-title (format "%s" module)) 445 (newline) 446 (dolist (g geiser-doc--sections) 447 (geiser-doc--insert-list (car g) 448 (cdr (assoc (cadr g) exports)) 449 (and (not (cddr g)) module) 450 impl)) 451 (setq geiser-doc--buffer-link 452 (geiser-doc--history-push 453 (geiser-doc--make-link nil module impl))) 454 (geiser-doc--insert-footer impl) 455 (goto-char (point-min))) 456 (message "%s done" msg) 457 (geiser-doc--pop-to-buffer)))) 458 459 (defun geiser-doc-next-section () 460 "Move to next section in this page." 461 (interactive) 462 (forward-line) 463 (re-search-forward geiser-doc--sections-re nil t) 464 (forward-line -1)) 465 466 (defun geiser-doc-previous-section () 467 "Move to previous section in this page." 468 (interactive) 469 (re-search-backward geiser-doc--sections-re nil t)) 470 471 (defun geiser-doc-next (&optional forget-current) 472 "Go to next page in documentation browser. 473 With prefix, the current page is deleted from history." 474 (interactive "P") 475 (let ((link (geiser-doc--history-next forget-current))) 476 (unless link (error "No next page")) 477 (geiser-doc--follow-link link))) 478 479 (defun geiser-doc-previous (&optional forget-current) 480 "Go to previous page in documentation browser. 481 With prefix, the current page is deleted from history." 482 (interactive "P") 483 (let ((link (geiser-doc--history-previous forget-current))) 484 (unless link (error "No previous page")) 485 (geiser-doc--follow-link link))) 486 487 (defun geiser-doc-kill-page () 488 "Kill current page if a previous or next one exists." 489 (interactive) 490 (condition-case nil 491 (geiser-doc-previous t) 492 (error (geiser-doc-next t)))) 493 494 (defun geiser-doc-refresh () 495 "Refresh the contents of current page." 496 (interactive) 497 (when geiser-doc--buffer-link 498 (geiser-doc--follow-link geiser-doc--buffer-link))) 499 500 (defun geiser-doc-clean-history () 501 "Clean up the document browser history." 502 (interactive) 503 (when (y-or-n-p "Clean browsing history? ") 504 (setq geiser-doc--history (geiser-doc--make-history)) 505 (geiser-doc-refresh)) 506 (message "")) 507 508 509 510 (provide 'geiser-doc)