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 ;;; Documentation browser history:
  45
  46 (defvar geiser-doc-history-size 50)
  47
  48 (defun geiser-doc--make-history ()
  49   (list nil                                   ; current
  50         (make-ring geiser-doc-history-size)   ; previous
  51         (make-ring geiser-doc-history-size))) ; next
  52
  53 (defsubst geiser-doc--history-current ()
  54   (car geiser-doc--history))
  55
  56 (defun geiser-doc--history-push (link)
  57   (unless (or (null link) (equal link (geiser-doc--history-current)))
  58     (when (not (null (geiser-doc--history-current)))
  59       (let ((next (geiser-doc--history-next)))
  60         (unless (equal link next)
  61           (when next (geiser-doc--history-previous))
  62           (ring-insert (nth 1 geiser-doc--history)
  63                        (car geiser-doc--history)))))
  64     (setcar geiser-doc--history link))
  65   link)
  66
  67 (defsubst geiser-doc--history-next-p ()
  68   (not (ring-empty-p (nth 2 geiser-doc--history))))
  69
  70 (defun geiser-doc--history-next (&optional forget-current)
  71   (when (geiser-doc--history-next-p)
  72     (when (and (car geiser-doc--history) (not forget-current))
  73       (ring-insert (nth 1 geiser-doc--history) (car geiser-doc--history)))
  74     (setcar geiser-doc--history (ring-remove (nth 2 geiser-doc--history) 0))))
  75
  76 (defsubst geiser-doc--history-previous-p ()
  77   (not (ring-empty-p (nth 1 geiser-doc--history))))
  78
  79 (defun geiser-doc--history-previous (&optional forget-current)
  80   (when (geiser-doc--history-previous-p)
  81     (when (and (car geiser-doc--history) (not forget-current))
  82       (ring-insert (nth 2 geiser-doc--history) (car geiser-doc--history)))
  83     (setcar geiser-doc--history (ring-remove (nth 1 geiser-doc--history) 0))))
  84
  85 (defvar geiser-doc--history nil)
  86 (setq geiser-doc--history (geiser-doc--make-history))
  87
  88 \f
  89 ;;; Links
  90
  91 (defsubst geiser-doc--make-link (target module impl)
  92   (list target module impl))
  93
  94 (defsubst geiser-doc--link-target (link)
  95   (nth 0 link))
  96
  97 (defsubst geiser-doc--link-module (link)
  98   (nth 1 link))
  99
 100 (defsubst geiser-doc--link-impl (link)
 101   (nth 2 link))
 102
 103 (defun geiser-doc--follow-link (link)
 104   (let ((target (geiser-doc--link-target link))
 105         (module (geiser-doc--link-module link))
 106         (impl (geiser-doc--link-impl link)))
 107     (when (and (or target module) impl)
 108       (with--geiser-implementation impl
 109         (if (null target)
 110             (geiser-doc-module module impl)
 111           (geiser-doc-symbol target module impl))))))
 112
 113 (make-variable-buffer-local
 114  (defvar geiser-doc--buffer-link nil))
 115
 116 (defsubst geiser-doc--implementation ()
 117   (geiser-doc--link-impl geiser-doc--buffer-link))
 118
 119 (defun geiser-doc--button-action (button)
 120   (let ((link (button-get button 'geiser-link)))
 121     (when link (geiser-doc--follow-link link))))
 122
 123 (define-button-type 'geiser-doc--button
 124   'action 'geiser-doc--button-action
 125   'face 'geiser-font-lock-doc-link
 126   'follow-link t)
 127
 128 (defun geiser-doc--insert-button (target module impl)
 129   (let ((link (geiser-doc--make-link target module impl))
 130         (text (format "%s" (or target module)))
 131         (help (format "%smodule %s"
 132                       (if target (format "%s in " target) "")
 133                       (or module "<unknown>"))))
 134     (insert-text-button text
 135                         :type 'geiser-doc--button
 136                         'geiser-link link
 137                         'help-echo help)))
 138
 139 (defun geiser-doc--xbutton-action (button)
 140   (when geiser-doc--buffer-link
 141     (let ((kind (or (button-get button 'x-kind) 'source))
 142           (target (geiser-doc--link-target geiser-doc--buffer-link))
 143           (module (geiser-doc--link-module geiser-doc--buffer-link))
 144           (impl (geiser-doc--link-impl geiser-doc--buffer-link)))
 145       (with--geiser-implementation impl
 146         (if (eq kind 'source)
 147             (if target (geiser-edit-symbol target nil (point-marker))
 148               (geiser-edit-module module)))))))
 149
 150 (define-button-type 'geiser-doc--xbutton
 151   'action 'geiser-doc--xbutton-action
 152   'face 'geiser-font-lock-doc-button
 153   'follow-link t)
 154
 155 (defun geiser-doc--insert-xbutton (&optional manual)
 156   (insert-text-button (if manual "[manual]" "[source]")
 157                       :type 'geiser-doc--xbutton
 158                       'x-kind (if manual 'manual 'source)))
 159
 160 (defun geiser-doc--insert-xbuttons ()
 161   (geiser-doc--insert-xbutton))
 162
 163 (defun geiser-doc--insert-footer ()
 164   (newline 3)
 165   (when (geiser-doc--history-previous-p)
 166     (insert-text-button "[back]"
 167                         'action '(lambda (b) (geiser-doc-previous))
 168                         'face 'geiser-font-lock-doc-button
 169                         'follow-link t)
 170     (insert "  "))
 171   (when (geiser-doc--history-next-p)
 172     (insert-text-button "[forward]"
 173                         'action '(lambda (b) (geiser-doc-next))
 174                         'face 'geiser-font-lock-doc-button
 175                         'follow-link t)))
 176
 177 \f
 178 ;;; Auxiliary functions:
 179
 180 (defun geiser-doc--insert-title (title &optional top)
 181   (let ((p (point)))
 182     (if (not (listp title))
 183         (insert (format "%s" title))
 184       (insert "(" (format "%s" (car title)))
 185       (dolist (a (cdr title))
 186         (insert " " (if (eq a '\#:rest) "." (format "%s" a))))
 187       (insert ")"))
 188     (put-text-property p (point) 'face 'geiser-font-lock-doc-title)
 189     (when top
 190       (let ((len (max 1 (- (window-width)
 191                            (- (point) (line-beginning-position))
 192                            10))))
 193         (insert (make-string len ?\ ))
 194         (geiser-doc--insert-xbuttons)))
 195     (newline)))
 196
 197 (defun geiser-doc--insert-list (title lst module impl)
 198   (when lst
 199     (geiser-doc--insert-title title)
 200     (newline)
 201     (dolist (w lst)
 202       (let ((name (if (listp w) (car w) w))
 203             (info (and (listp w) (cdr w))))
 204         (insert (format "\t- "))
 205         (if module
 206             (geiser-doc--insert-button name module impl)
 207           (geiser-doc--insert-button nil name impl))
 208         (when info (insert (format "  %s" info)))
 209         (newline)))
 210     (newline)))
 211
 212 \f
 213 ;;; Commands:
 214
 215 (geiser-impl--define-caller geiser-doc--external-help display-help
 216   (symbol module)
 217   "By default, Geiser will display help about an identifier in a
 218 help buffer, after collecting the associated signature and
 219 docstring. You can provide an alternative function for displaying
 220 help (e.g. browse an HTML page) implementing this method.")
 221
 222 (defun geiser-doc--get-docstring (symbol module)
 223   (geiser-eval--send/result
 224    `(:eval (:ge symbol-documentation ',symbol) ,module)))
 225
 226 (defun geiser-doc--get-module-exports (module)
 227   (geiser-eval--send/result
 228    `(:eval (:ge module-exports '(:module ,module)))))
 229
 230 (defun geiser-doc-symbol (symbol &optional module impl)
 231   (let ((module (or module (geiser-eval--get-module)))
 232         (impl (or impl geiser-impl--implementation)))
 233     (unless (geiser-doc--external-help impl symbol module)
 234       (let ((ds (geiser-doc--get-docstring symbol module)))
 235         (if (or (not ds) (not (listp ds)))
 236             (message "No documentation available for '%s'" symbol)
 237           (geiser-doc--with-buffer
 238             (erase-buffer)
 239             (geiser-doc--insert-title
 240              (geiser-autodoc--str (list (symbol-name symbol) 0)
 241                                   (cdr (assoc 'signature ds)))
 242              t)
 243             (newline)
 244             (insert (or (cdr (assoc 'docstring ds)) ""))
 245             (setq geiser-doc--buffer-link
 246                   (geiser-doc--history-push
 247                    (geiser-doc--make-link symbol module impl)))
 248             (geiser-doc--insert-footer)
 249             (goto-char (point-min)))
 250           (geiser-doc--pop-to-buffer))))))
 251
 252 (defun geiser-doc-symbol-at-point (&optional arg)
 253   "Get docstring for symbol at point.
 254 With prefix argument, ask for symbol (with completion)."
 255   (interactive "P")
 256   (let ((symbol (or (and (not arg) (symbol-at-point))
 257                     (geiser-completion--read-symbol "Symbol: "
 258                                                     (symbol-at-point)))))
 259     (when symbol (geiser-doc-symbol symbol))))
 260
 261 (defun geiser-doc-module (&optional module impl)
 262   "Display information about a given module."
 263   (interactive)
 264   (let* ((module (or module (geiser-completion--read-module)))
 265          (exports (geiser-doc--get-module-exports module))
 266          (impl (or impl geiser-impl--implementation)))
 267     (if (not exports)
 268         (message "No information available for %s" module)
 269       (geiser-doc--with-buffer
 270         (erase-buffer)
 271         (geiser-doc--insert-title (format "%s" module) t)
 272         (newline)
 273         (dolist (g '(("Procedures:" . procs)
 274                      ("Variables:" . vars)
 275                      ("Syntax:" . syntax)))
 276           (geiser-doc--insert-list (car g)
 277                                    (cdr (assoc (cdr g) exports))
 278                                    module
 279                                    impl))
 280         (geiser-doc--insert-list "Submodules:"
 281                                  (cdr (assoc 'modules exports))
 282                                  nil
 283                                  impl)
 284         (setq geiser-doc--buffer-link
 285               (geiser-doc--history-push
 286                (geiser-doc--make-link nil module impl)))
 287         (geiser-doc--insert-footer)
 288         (goto-char (point-min)))
 289       (geiser-doc--pop-to-buffer))))
 290
 291 (defun geiser-doc-next (&optional forget-current)
 292   "Go to next page in documentation browser.
 293 With prefix, the current page is deleted from history."
 294   (interactive "P")
 295   (let ((link (geiser-doc--history-next forget-current)))
 296     (unless link (error "No next page"))
 297     (geiser-doc--follow-link link)))
 298
 299 (defun geiser-doc-previous (&optional forget-current)
 300   "Go to previous page in documentation browser.
 301 With prefix, the current page is deleted from history."
 302   (interactive "P")
 303   (let ((link (geiser-doc--history-previous forget-current)))
 304     (unless link (error "No previous page"))
 305     (geiser-doc--follow-link link)))
 306
 307 (defun geiser-doc-kill-page ()
 308   "Kill current page if a previous or next one exists."
 309   (interactive)
 310   (condition-case nil
 311       (geiser-doc-previous t)
 312     (error (geiser-doc-next t))))
 313
 314 (defun geiser-doc-refresh ()
 315   "Refresh the contents of current page."
 316   (interactive)
 317   (when geiser-doc--buffer-link
 318     (geiser-doc--follow-link geiser-doc--buffer-link)))
 319
 320 (defun geiser-doc-clean-history ()
 321   "Clean up the document browser history."
 322   (interactive)
 323   (when (y-or-n-p "Clean browsing history? ")
 324     (setq geiser-doc--history (geiser-doc--make-history))
 325     (geiser-doc-refresh))
 326   (message ""))
 327
 328 \f
 329 ;;; Documentation browser and mode:
 330
 331 (defsubst geiser-doc--module ()
 332   (geiser-impl--call-method
 333    'find-module
 334    (geiser-doc--implementation)
 335    (geiser-doc--link-module geiser-doc--buffer-link)))
 336
 337 (defun geiser-doc-edit-symbol-at-point ()
 338   "Open definition of symbol at point."
 339   (interactive)
 340   (let* ((impl (geiser-doc--implementation))
 341          (module (geiser-doc--module)))
 342     (unless (and impl module)
 343       (error "I don't know what module this buffer refers to."))
 344     (with--geiser-implementation impl
 345       (let ((geiser-eval--get-module-function (lambda (&rest x) module)))
 346         (geiser-edit-symbol-at-point)))))
 347
 348 (defvar geiser-doc-mode-map nil)
 349 (setq geiser-doc-mode-map
 350       (let ((map (make-sparse-keymap)))
 351         (suppress-keymap map)
 352         (set-keymap-parent map button-buffer-map)
 353         map))
 354
 355 (defun geiser-doc-switch-to-repl ()
 356   (interactive)
 357   (switch-to-geiser nil nil (current-buffer)))
 358
 359 (geiser-menu--defmenu doc geiser-doc-mode-map
 360   ("Next page" ("n" "f") geiser-doc-next "Next item"
 361    :enable (geiser-doc--history-next-p))
 362   ("Previous page" ("p" "b") geiser-doc-previous "Previous item"
 363    :enable (geiser-doc--history-previous-p))
 364   ("Next link" nil forward-button)
 365   ("Previous link" nil backward-button)
 366   ("Go to REPL" ("z" "\C-cz" "\C-c\C-z") geiser-doc-switch-to-repl)
 367   ("Refresh" ("g" "r") geiser-doc-refresh "Refresh current page")
 368   --
 369   ("Edit symbol" ("." "\M-.") geiser-doc-edit-symbol-at-point
 370    :enable (symbol-at-point))
 371   --
 372   ("Kill item" "k" geiser-doc-kill-page "Kill this page")
 373   ("Clear history" "c" geiser-doc-clean-history)
 374   --
 375   (custom "Browser options" geiser-doc)
 376   --
 377   ("Quit" nil View-quit))
 378
 379 (defun geiser-doc-mode ()
 380   "Major mode for browsing scheme documentation.
 381 \\{geiser-doc-mode-map}"
 382   (interactive)
 383   (kill-all-local-variables)
 384   (buffer-disable-undo)
 385   (setq truncate-lines t)
 386   (use-local-map geiser-doc-mode-map)
 387   (set-syntax-table scheme-mode-syntax-table)
 388   (setq mode-name "Geiser Doc")
 389   (setq major-mode 'geiser-doc-mode)
 390   (setq buffer-read-only t))
 391
 392 (geiser-popup--define doc "*Geiser documentation*" geiser-doc-mode)
 393
 394 \f
 395 (provide 'geiser-doc)
 396 ;;; geiser-doc.el ends here