elisp/geiser-doc.el

   1 ;;; geiser-doc.el -- accessing scheme-provided documentation
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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 (caddr 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 ;;; Commands:
 271
 272 (defun geiser-doc--get-docstring (symbol module)
 273   (geiser-eval--send/result
 274    `(:eval (:ge symbol-documentation ',symbol) ,module)))
 275
 276 (defun geiser-doc--get-module-exports (module)
 277   (geiser-eval--send/result
 278    `(:eval (:ge module-exports '(:module ,module)) :f)))
 279
 280 (defun geiser-doc--buttonize-modules (impl)
 281   (save-excursion
 282     (goto-char (point-min))
 283     (while (re-search-forward "in module \\([^.\n]+\\)[.\n ]" nil t)
 284       (geiser-doc--make-module-button (match-beginning 1)
 285                                       (match-end 1)
 286                                       (geiser-doc--module (match-string 1)
 287                                                           impl)
 288                                       impl))))
 289
 290 (defun geiser-doc--render-docstring
 291   (docstring symbol &optional module impl)
 292   (erase-buffer)
 293   (geiser-doc--insert-title
 294    (geiser-autodoc--str* (cdr (assoc "signature" docstring))))
 295   (newline)
 296   (insert (or (cdr (assoc "docstring" docstring)) ""))
 297   (geiser-doc--buttonize-modules impl)
 298   (setq geiser-doc--buffer-link
 299         (geiser-doc--history-push (geiser-doc--make-link symbol
 300                                                          module
 301                                                          impl)))
 302   (geiser-doc--insert-footer impl)
 303   (goto-char (point-min)))
 304
 305 (defun geiser-doc-symbol (symbol &optional module impl)
 306   (let* ((impl (or impl geiser-impl--implementation))
 307          (module (geiser-doc--module (or module (geiser-eval--get-module))
 308                                      impl)))
 309     (let ((ds (geiser-doc--get-docstring symbol module)))
 310       (if (or (not ds) (not (listp ds)))
 311           (message "No documentation available for '%s'" symbol)
 312         (geiser-doc--with-buffer
 313           (geiser-doc--render-docstring ds symbol module impl))
 314         (geiser-doc--pop-to-buffer)))))
 315
 316 (defun geiser-doc-symbol-at-point (&optional arg)
 317   "Get docstring for symbol at point.
 318 With prefix argument, ask for symbol (with completion)."
 319   (interactive "P")
 320   (let ((symbol (or (and (not arg) (geiser--symbol-at-point))
 321                     (geiser-completion--read-symbol
 322                      "Symbol: " (geiser--symbol-at-point)))))
 323     (when symbol (geiser-doc-symbol symbol))))
 324
 325 (defun geiser-doc-look-up-manual (&optional arg)
 326   "Look up manual for symbol at point.
 327 With prefix argument, ask for the lookup symbol (with completion)."
 328   (interactive "P")
 329   (unless (geiser-doc--manual-available-p)
 330     (error "No manual available"))
 331   (let ((symbol (or (and (not arg) (geiser--symbol-at-point))
 332                     (geiser-completion--read-symbol "Symbol: "))))
 333     (geiser-doc--external-help geiser-impl--implementation
 334                                symbol
 335                                (geiser-eval--get-module))))
 336
 337 (defconst geiser-doc--sections '(("Procedures:" "procs")
 338                                  ("Syntax:" "syntax")
 339                                  ("Variables:" "vars")
 340                                  ("Submodules:" "modules" t)))
 341
 342 (defconst geiser-doc--sections-re
 343   (format "^%s\n" (regexp-opt (mapcar 'car geiser-doc--sections))))
 344
 345 (defun geiser-doc-module (&optional module impl)
 346   "Display information about a given module."
 347   (interactive)
 348   (let* ((impl (or impl geiser-impl--implementation))
 349          (module (geiser-doc--module (or module
 350                                          (geiser-completion--read-module))
 351                                      impl))
 352          (msg (format "Retrieving documentation for %s ..." module))
 353          (exports (progn
 354                     (message "%s" msg)
 355                     (geiser-doc--get-module-exports module))))
 356     (if (not exports)
 357         (message "No information available for %s" module)
 358       (geiser-doc--with-buffer
 359         (erase-buffer)
 360         (geiser-doc--insert-title (format "%s" module))
 361         (newline)
 362         (dolist (g geiser-doc--sections)
 363           (geiser-doc--insert-list (car g)
 364                                    (cdr (assoc (cadr g) exports))
 365                                    (and (not (cddr g)) module)
 366                                    impl))
 367         (setq geiser-doc--buffer-link
 368               (geiser-doc--history-push
 369                (geiser-doc--make-link nil module impl)))
 370         (geiser-doc--insert-footer impl)
 371         (goto-char (point-min)))
 372       (message "%s done" msg)
 373       (geiser-doc--pop-to-buffer))))
 374
 375 (defun geiser-doc-next-section ()
 376   "Move to next section in this page."
 377   (interactive)
 378   (forward-line)
 379   (re-search-forward geiser-doc--sections-re nil t)
 380   (forward-line -1))
 381
 382 (defun geiser-doc-previous-section ()
 383   "Move to previous section in this page."
 384   (interactive)
 385   (re-search-backward geiser-doc--sections-re nil t))
 386
 387 (defun geiser-doc-next (&optional forget-current)
 388   "Go to next page in documentation browser.
 389 With prefix, the current page is deleted from history."
 390   (interactive "P")
 391   (let ((link (geiser-doc--history-next forget-current)))
 392     (unless link (error "No next page"))
 393     (geiser-doc--follow-link link)))
 394
 395 (defun geiser-doc-previous (&optional forget-current)
 396   "Go to previous page in documentation browser.
 397 With prefix, the current page is deleted from history."
 398   (interactive "P")
 399   (let ((link (geiser-doc--history-previous forget-current)))
 400     (unless link (error "No previous page"))
 401     (geiser-doc--follow-link link)))
 402
 403 (defun geiser-doc-kill-page ()
 404   "Kill current page if a previous or next one exists."
 405   (interactive)
 406   (condition-case nil
 407       (geiser-doc-previous t)
 408     (error (geiser-doc-next t))))
 409
 410 (defun geiser-doc-refresh ()
 411   "Refresh the contents of current page."
 412   (interactive)
 413   (when geiser-doc--buffer-link
 414     (geiser-doc--follow-link geiser-doc--buffer-link)))
 415
 416 (defun geiser-doc-clean-history ()
 417   "Clean up the document browser history."
 418   (interactive)
 419   (when (y-or-n-p "Clean browsing history? ")
 420     (setq geiser-doc--history (geiser-doc--make-history))
 421     (geiser-doc-refresh))
 422   (message ""))
 423
 424 \f
 425 ;;; Documentation browser and mode:
 426
 427 (defun geiser-doc-edit-symbol-at-point ()
 428   "Open definition of symbol at point."
 429   (interactive)
 430   (let* ((impl (geiser-doc--implementation))
 431          (module (geiser-doc--module)))
 432     (unless (and impl module)
 433       (error "I don't know what module this buffer refers to."))
 434     (with--geiser-implementation impl
 435       (geiser-edit-symbol-at-point))))
 436
 437 (defvar geiser-doc-mode-map nil)
 438 (setq geiser-doc-mode-map
 439       (let ((map (make-sparse-keymap)))
 440         (suppress-keymap map)
 441         (set-keymap-parent map button-buffer-map)
 442         map))
 443
 444 (defun geiser-doc-switch-to-repl ()
 445   (interactive)
 446   (switch-to-geiser nil nil (current-buffer)))
 447
 448 (geiser-menu--defmenu doc geiser-doc-mode-map
 449   ("Next link" ("n") forward-button)
 450   ("Previous link" ("p") backward-button)
 451   ("Next section" ("N") geiser-doc-next-section)
 452   ("Previous section" ("P") geiser-doc-previous-section)
 453   --
 454   ("Next page" ("f") geiser-doc-next "Next item"
 455    :enable (geiser-doc--history-next-p))
 456   ("Previous page" ("b") geiser-doc-previous "Previous item"
 457    :enable (geiser-doc--history-previous-p))
 458   --
 459   ("Go to REPL" ("z" "\C-cz" "\C-c\C-z") geiser-doc-switch-to-repl)
 460   ("Refresh" ("g" "r") geiser-doc-refresh "Refresh current page")
 461   --
 462   ("Edit symbol" ("." "\M-.") geiser-doc-edit-symbol-at-point
 463    :enable (geiser--symbol-at-point))
 464   --
 465   ("Kill item" "k" geiser-doc-kill-page "Kill this page")
 466   ("Clear history" "c" geiser-doc-clean-history)
 467   --
 468   (custom "Browser options" geiser-doc)
 469   --
 470   ("Quit" nil View-quit))
 471
 472 (defun geiser-doc-mode ()
 473   "Major mode for browsing scheme documentation.
 474 \\{geiser-doc-mode-map}"
 475   (interactive)
 476   (kill-all-local-variables)
 477   (buffer-disable-undo)
 478   (setq truncate-lines t)
 479   (use-local-map geiser-doc-mode-map)
 480   (set-syntax-table scheme-mode-syntax-table)
 481   (setq mode-name "Geiser Doc")
 482   (setq major-mode 'geiser-doc-mode)
 483   (setq geiser-eval--get-module-function 'geiser-doc--module)
 484   (setq buffer-read-only t))
 485
 486 (geiser-popup--define doc "*Geiser documentation*" geiser-doc-mode)
 487
 488 \f
 489 (provide 'geiser-doc)