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