1 ;;; geiser-doc.el -- accessing scheme-provided documentation
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio Ortega Ruiz
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>.
10 ;; Start date: Sat Feb 14, 2009 14:09
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
)
30 (defgroup geiser-doc nil
31 "Options for documentation buffers."
34 (geiser-custom--defface doc-title
35 'bold geiser-doc
"article titles in documentation buffers")
37 (geiser-custom--defface doc-link
38 'link geiser-doc
"links in documentation buffers")
40 (geiser-custom--defface doc-button
41 'button geiser-doc
"buttons in documentation buffers")
45 (geiser-impl--define-caller geiser-doc--external-help external-help
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.")
53 ;;; Documentation browser history:
55 (defvar geiser-doc-history-size
50)
56 (defvar geiser-doc--history nil
)
58 (defun geiser-doc--make-history ()
60 (make-ring geiser-doc-history-size
) ; previous
61 (make-ring geiser-doc-history-size
))) ; next
63 (setq geiser-doc--history
(geiser-doc--make-history))
65 (defvar session-globals-exclude
)
66 (eval-after-load "session"
67 '(add-to-list 'session-globals-exclude
'geiser-doc--history
))
69 (defsubst geiser-doc--history-current
()
70 (car geiser-doc--history
))
72 (defsubst geiser-doc--history-previous-link
()
73 (ring-ref (cadr geiser-doc--history
) 0))
75 (defsubst geiser-doc--history-next-link
()
76 (ring-ref (car (cddr geiser-doc--history
)) 0))
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
))
89 (defsubst geiser-doc--history-next-p
()
90 (not (ring-empty-p (nth 2 geiser-doc--history
))))
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))))
98 (defsubst geiser-doc--history-previous-p
()
99 (not (ring-empty-p (nth 1 geiser-doc--history
))))
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))))
110 (defsubst geiser-doc--make-link
(target module impl
)
111 (list target module impl
))
113 (defsubst geiser-doc--link-target
(link)
116 (defsubst geiser-doc--link-module
(link)
119 (defsubst geiser-doc--link-impl
(link)
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
129 (geiser-doc-module module impl
)
130 (let ((geiser-eval--get-module-function (lambda (x) module
)))
131 (geiser-doc-symbol target module impl
)))))))
133 (make-variable-buffer-local
134 (defvar geiser-doc--buffer-link nil
))
136 (defsubst geiser-doc--implementation
()
137 (geiser-doc--link-impl geiser-doc--buffer-link
))
139 (defun geiser-doc--button-action (button)
140 (let ((link (button-get button
'geiser-link
)))
141 (when link
(geiser-doc--follow-link link
))))
143 (define-button-type 'geiser-doc--button
144 'action
'geiser-doc--button-action
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
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
))
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
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
)))
181 (geiser-doc--external-help impl
185 (define-button-type 'geiser-doc--xbutton
186 'action
'geiser-doc--xbutton-action
187 'face
'geiser-font-lock-doc-button
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
196 'x-kind
(if manual
'manual
'source
))))
198 (defun geiser-doc--insert-xbuttons (impl)
199 (when (geiser-impl--method 'external-help impl
)
200 (geiser-doc--insert-xbutton t
)
202 (geiser-doc--insert-xbutton))
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]")
213 'help-echo
(format "Previous help item (%s)" what
)
214 'face
'geiser-font-lock-doc-button
218 ;;; Auxiliary functions:
220 (defun geiser-doc--manual-available-p ()
221 (geiser-impl--method 'external-help geiser-impl--implementation
))
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
)))
228 (defun geiser-doc--insert-title (title)
230 (insert (format "%s" title
))
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
)
237 (defun geiser-doc--insert-list (title lst module impl
)
239 (geiser-doc--insert-title title
)
243 (signature (cdr (assoc "signature" w
)))
244 (info (cdr (assoc "info" w
))))
247 (geiser-doc--insert-button name module impl signature
)
248 (geiser-doc--insert-button nil name impl
))
249 (when info
(insert (format " %s" info
)))
253 (defun geiser-doc--insert-footer (impl)
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))
263 (insert (make-string len ?\
)))
265 (geiser-doc--insert-nav-button nil
)
268 (geiser-doc--insert-nav-button t
))))
271 ;;; Documentation browser and mode:
273 (defun geiser-doc-edit-symbol-at-point ()
274 "Open definition of symbol at point."
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))))
283 (defvar geiser-doc-mode-map
284 (let ((map (make-sparse-keymap)))
285 (suppress-keymap map
)
286 (set-keymap-parent map button-buffer-map
)
288 "Keymap for `geiser-doc-mode'.")
290 (defun geiser-doc-switch-to-repl ()
292 (switch-to-geiser nil nil
(current-buffer)))
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
)
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))
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")
308 ("Edit symbol" ("." "\M-.") geiser-doc-edit-symbol-at-point
309 :enable
(geiser--symbol-at-point))
311 ("Kill item" "k" geiser-doc-kill-page
"Kill this page")
312 ("Clear history" "c" geiser-doc-clean-history
)
314 (custom "Browser options" geiser-doc
)
316 ("Quit" nil View-quit
))
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
))
327 (geiser-popup--define doc
"*Geiser documentation*" geiser-doc-mode
)
332 (defun geiser-doc--get-docstring (symbol module
)
333 (geiser-eval--send/result
334 `(:eval
(:ge symbol-documentation
',symbol
) ,module
)))
336 (defun geiser-doc--get-module-exports (module)
337 (geiser-eval--send/result
338 `(:eval
(:ge module-exports
'(:module
,module
)) :f
)))
340 (defun geiser-doc--buttonize-modules (impl)
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)
346 (geiser-doc--module (match-string 1)
350 (defun geiser-doc--render-docstring
351 (docstring symbol
&optional module impl
)
353 (geiser-doc--insert-title
354 (geiser-autodoc--str* (cdr (assoc "signature" docstring
))))
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
362 (geiser-doc--insert-footer impl
)
363 (goto-char (point-min)))
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))
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)))))
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)."
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
))))
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)."
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
395 (geiser-eval--get-module))))
397 (defconst geiser-doc--sections
'(("Procedures:" "procs")
399 ("Variables:" "vars")
400 ("Submodules:" "modules" t
)))
402 (defconst geiser-doc--sections-re
403 (format "^%s\n" (regexp-opt (mapcar 'car geiser-doc--sections
))))
405 (defun geiser-doc-module (&optional module impl
)
406 "Display information about a given module."
408 (let* ((impl (or impl geiser-impl--implementation
))
409 (module (geiser-doc--module (or module
410 (geiser-completion--read-module))
412 (msg (format "Retrieving documentation for %s ..." module
))
415 (geiser-doc--get-module-exports module
))))
417 (message "No information available for %s" module
)
418 (geiser-doc--with-buffer
420 (geiser-doc--insert-title (format "%s" module
))
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
)
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))))
435 (defun geiser-doc-next-section ()
436 "Move to next section in this page."
439 (re-search-forward geiser-doc--sections-re nil t
)
442 (defun geiser-doc-previous-section ()
443 "Move to previous section in this page."
445 (re-search-backward geiser-doc--sections-re nil t
))
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."
451 (let ((link (geiser-doc--history-next forget-current
)))
452 (unless link
(error "No next page"))
453 (geiser-doc--follow-link link
)))
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."
459 (let ((link (geiser-doc--history-previous forget-current
)))
460 (unless link
(error "No previous page"))
461 (geiser-doc--follow-link link
)))
463 (defun geiser-doc-kill-page ()
464 "Kill current page if a previous or next one exists."
467 (geiser-doc-previous t
)
468 (error (geiser-doc-next t
))))
470 (defun geiser-doc-refresh ()
471 "Refresh the contents of current page."
473 (when geiser-doc--buffer-link
474 (geiser-doc--follow-link geiser-doc--buffer-link
)))
476 (defun geiser-doc-clean-history ()
477 "Clean up the document browser history."
479 (when (y-or-n-p "Clean browsing history? ")
480 (setq geiser-doc--history
(geiser-doc--make-history))
481 (geiser-doc-refresh))
486 (provide 'geiser-doc
)