File: slime-references.el

package info (click to toggle)
slime 1:20080223.dfsg-1
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 2,600 kB
  • ctags: 3,345
  • sloc: lisp: 30,707; sh: 163; makefile: 119; awk: 10
file content (135 lines) | stat: -rw-r--r-- 4,717 bytes parent folder | download
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
;;; slime-references.el --- Clickable references to documentation (SBCL only)
;;
;; Authors: Christophe Rhodes  <csr21@cantab.net>
;;          Luke Gorrie  <luke@bluetail.com>
;;
;; License: GNU GPL (same license as Emacs)
;;
;;;

(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)

(defun slime-note.references (note)
  (plist-get note :references))

(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))
      (princ "See also:" (current-buffer))
      (terpri (current-buffer))
      (slime-tree-insert-references references))))

(defun slime-tree-insert-references (references)
  "Insert documentation references from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
  (loop for refs on references
        for ref = (car refs)
        do
        (destructuring-bind (where type what) ref
          ;; FIXME: this is poorly factored, and shares some code and
          ;; data with sldb that it shouldn't: notably
          ;; sldb-reference-face.  Probably the names of
          ;; sldb-reference-foo should be altered to be not sldb
          ;; specific.
          (insert "  " (sldb-format-reference-source where) ", ")
          (slime-insert-propertized (sldb-reference-properties ref)
                                    (sldb-format-reference-node what))
          (insert (format " [%s]" type))
          (when (cdr refs)
            (terpri (current-buffer))))))


;;;;; SLDB references (rather SBCL specific)

(defun sldb-insert-references (references)
  "Insert documentation references from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
  (dolist (ref references)
    (destructuring-bind (where type what) ref
      (insert "\n" (sldb-format-reference-source where) ", ")
      (slime-insert-propertized (sldb-reference-properties ref)
				(sldb-format-reference-node what))
      (insert (format " [%s]" type)))))

(defun sldb-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))))
        `(sldb-default-action
          sldb-lookup-reference
          ;; FIXME: this is a hack!  slime-compiler-notes and sldb are a
          ;; little too intimately entwined.
          slime-compiler-notes-default-action sldb-lookup-reference
          sldb-reference ,reference
          face sldb-reference-face
          mouse-face highlight))))

(defun sldb-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 sldb-format-reference-node (what)
  (if (listp what)
      (mapconcat #'prin1-to-string what ".")
    what))

(defun sldb-lookup-reference ()
  "Browse the documentation reference at point."
  (destructuring-bind (where type what)
      (get-text-property (point) 'sldb-reference)
    (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 sldb-maybe-insert-references (extra)
  (destructure-case extra
    ((:references references)
     (when references
       (insert "\nSee also:")
       (slime-with-rigid-indentation 2
	 (sldb-insert-references references)))
     t)
    (t nil)))


;;; Initialization

(defun slime-references-init ()
  (setq slime-tree-printer 'slime-tree-print-with-references)
  (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))

(defun slime-references-unload ()
  (setq slime-tree-printer 'slime-tree-default-printer)
  (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
  
(provide 'slime-references)