elisp/geiser-doc.el

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