-
Notifications
You must be signed in to change notification settings - Fork 0
/
slime-references.el
143 lines (122 loc) · 5.04 KB
/
slime-references.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
(define-slime-contrib slime-references
"Clickable references to documentation (SBCL only)."
(:authors "Christophe Rhodes <csr21@cantab.net>"
"Luke Gorrie <luke@bluetail.com>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(ad-enable-advice 'slime-note.message 'after 'slime-note.message+references)
(ad-activate 'slime-note.message)
(setq slime-tree-printer 'slime-tree-print-with-references)
(add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
(:on-unload
(ad-disable-advice 'slime-note.message 'after 'slime-note.message+references)
(ad-deactivate 'slime-note.message)
(setq slime-tree-printer 'slime-tree-default-printer)
(remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)))
(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/"
"*The base URL of the SBCL manual, for documentation lookup."
:type 'string
:group 'slime-mode)
(defface sldb-reference-face
(list (list t '(:underline t)))
"Face for references."
:group 'slime-debugger)
;;;;; SBCL-style references
(defvar slime-references-local-keymap
(let ((map (make-sparse-keymap "local keymap for slime references")))
(define-key map [mouse-2] 'slime-lookup-reference-at-mouse)
(define-key map [return] 'slime-lookup-reference-at-point)
map))
(defun slime-reference-properties (reference)
"Return the properties for a reference.
Only add clickability to properties we actually know how to lookup."
(destructuring-bind (where type what) reference
(if (or (and (eq where :sbcl) (eq type :node))
(and (eq where :ansi-cl)
(memq type '(:function :special-operator :macro
:section :glossary :issue))))
`(slime-reference ,reference
font-lock-face sldb-reference-face
follow-link t
mouse-face highlight
help-echo "mouse-2: visit documentation."
keymap ,slime-references-local-keymap))))
(defun slime-insert-reference (reference)
"Insert documentation reference from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
(destructuring-bind (where type what) reference
(insert "\n" (slime-format-reference-source where) ", ")
(slime-insert-propertized (slime-reference-properties reference)
(slime-format-reference-node what))
(insert (format " [%s]" type))))
(defun slime-insert-references (references)
(when references
(insert "\nSee also:")
(slime-with-rigid-indentation 2
(mapc #'slime-insert-reference references))))
(defun slime-format-reference-source (where)
(case where
(:amop "The Art of the Metaobject Protocol")
(:ansi-cl "Common Lisp Hyperspec")
(:sbcl "SBCL Manual")
(t (format "%S" where))))
(defun slime-format-reference-node (what)
(if (listp what)
(mapconcat #'prin1-to-string what ".")
what))
(defun slime-lookup-reference-at-point ()
"Browse the documentation reference at point."
(interactive)
(let ((refs (get-text-property (point) 'slime-reference)))
(if (null refs)
(error "No references at point")
(destructuring-bind (where type what) refs
(case where
(:ansi-cl
(case type
(:section
(browse-url (funcall common-lisp-hyperspec-section-fun what)))
(:glossary
(browse-url (funcall common-lisp-glossary-fun what)))
(:issue
(browse-url (funcall 'common-lisp-issuex what)))
(t
(hyperspec-lookup what))))
(t
(let ((url (format "%s%s.html" slime-sbcl-manual-root
(subst-char-in-string ?\ ?\- what))))
(browse-url url))))))))
(defun slime-lookup-reference-at-mouse (event)
"Invoke the action pointed at by the mouse."
(interactive "e")
(destructuring-bind (mouse-1 (w pos . _) . _) event
(save-excursion
(goto-char pos)
(slime-lookup-reference-at-point))))
;;;;; Hook into *SLIME COMPILATION*
(defun slime-note.references (note)
(plist-get note :references))
;;; FIXME: `compilation-mode' will swallow the `mouse-face'
;;; etc. properties.
(defadvice slime-note.message (after slime-note.message+references)
(setq ad-return-value
(concat ad-return-value
(with-temp-buffer
(slime-insert-references
(slime-note.references (ad-get-arg 0)))
(buffer-string)))))
;;;;; Hook into slime-compiler-notes-tree
(defun slime-tree-print-with-references (tree)
;; for SBCL-style references
(slime-tree-default-printer tree)
(when-let (note (plist-get (slime-tree.plist tree) 'note))
(when-let (references (slime-note.references note))
(terpri (current-buffer))
(slime-insert-references references))))
;;;;; Hook into SLDB
(defun sldb-maybe-insert-references (extra)
(destructure-case extra
((:references references) (slime-insert-references references) t)
(t nil)))
(provide 'slime-references)