elisp/geiser-doc.el

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