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