/[slime]/slime/contrib/slime-compiler-notes-tree.el
ViewVC logotype

Contents of /slime/contrib/slime-compiler-notes-tree.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Fri May 28 19:13:17 2010 UTC (3 years, 10 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-2-3, FAIRLY-STABLE, byte-stream, SLIME-2-2, HEAD
Changes since 1.6: +1 -0 lines
Call provide at the end of the file.

* slime-asdf.el slime-banner.el slime-clipboard.el
slime-compiler-notes-tree.el slime-enclosing-context.el
slime-highlight-edits.el slime-hyperdoc.el slime-indentation.el
slime-mdot-fu.el slime-motd.el slime-mrepl.el
slime-presentation-streams.el slime-sbcl-exts.el slime-snapshot.el
slime-sprof.el slime-tramp.el slime-typeout-frame.el
slime-xref-browser.el:
1
2 (define-slime-contrib slime-compiler-notes-tree
3 "Display compiler messages in tree layout.
4
5 M-x slime-list-compiler-notes display the compiler notes in a tree
6 grouped by severity.
7
8 `slime-maybe-list-compiler-notes' can be used as
9 `slime-compilation-finished-hook'.
10 "
11 (:authors "Helmut Eller <heller@common-lisp.net>")
12 (:license "GPL"))
13
14 (defun slime-maybe-list-compiler-notes (notes)
15 "Show the compiler notes if appropriate."
16 ;; don't pop up a buffer if all notes are already annotated in the
17 ;; buffer itself
18 (unless (every #'slime-note-has-location-p notes)
19 (slime-list-compiler-notes notes)))
20
21 (defun slime-list-compiler-notes (notes)
22 "Show the compiler notes NOTES in tree view."
23 (interactive (list (slime-compiler-notes)))
24 (with-temp-message "Preparing compiler note tree..."
25 (slime-with-popup-buffer ((slime-buffer-name :notes)
26 :mode 'slime-compiler-notes-mode)
27 (when (null notes)
28 (insert "[no notes]"))
29 (let ((collapsed-p))
30 (dolist (tree (slime-compiler-notes-to-tree notes))
31 (when (slime-tree.collapsed-p tree) (setf collapsed-p t))
32 (slime-tree-insert tree "")
33 (insert "\n"))
34 (goto-char (point-min))))))
35
36 (defvar slime-tree-printer 'slime-tree-default-printer)
37
38 (defun slime-tree-for-note (note)
39 (make-slime-tree :item (slime-note.message note)
40 :plist (list 'note note)
41 :print-fn slime-tree-printer))
42
43 (defun slime-tree-for-severity (severity notes collapsed-p)
44 (make-slime-tree :item (format "%s (%d)"
45 (slime-severity-label severity)
46 (length notes))
47 :kids (mapcar #'slime-tree-for-note notes)
48 :collapsed-p collapsed-p))
49
50 (defun slime-compiler-notes-to-tree (notes)
51 (let* ((alist (slime-alistify notes #'slime-note.severity #'eq))
52 (collapsed-p (slime-length> alist 1)))
53 (loop for (severity . notes) in alist
54 collect (slime-tree-for-severity severity notes
55 collapsed-p))))
56
57 (defvar slime-compiler-notes-mode-map)
58
59 (define-derived-mode slime-compiler-notes-mode fundamental-mode
60 "Compiler-Notes"
61 "\\<slime-compiler-notes-mode-map>\
62 \\{slime-compiler-notes-mode-map}
63 \\{slime-popup-buffer-mode-map}
64 "
65 (slime-set-truncate-lines))
66
67 (slime-define-keys slime-compiler-notes-mode-map
68 ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details)
69 ([return] 'slime-compiler-notes-default-action-or-show-details)
70 ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse))
71
72 (defun slime-compiler-notes-default-action-or-show-details/mouse (event)
73 "Invoke the action pointed at by the mouse, or show details."
74 (interactive "e")
75 (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event
76 (save-excursion
77 (goto-char pos)
78 (let ((fn (get-text-property (point)
79 'slime-compiler-notes-default-action)))
80 (if fn (funcall fn) (slime-compiler-notes-show-details))))))
81
82 (defun slime-compiler-notes-default-action-or-show-details ()
83 "Invoke the action at point, or show details."
84 (interactive)
85 (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action)))
86 (if fn (funcall fn) (slime-compiler-notes-show-details))))
87
88 (defun slime-compiler-notes-show-details ()
89 (interactive)
90 (let* ((tree (slime-tree-at-point))
91 (note (plist-get (slime-tree.plist tree) 'note))
92 (inhibit-read-only t))
93 (cond ((not (slime-tree-leaf-p tree))
94 (slime-tree-toggle tree))
95 (t
96 (slime-show-source-location (slime-note.location note) t)))))
97
98
99 ;;;;;; Tree Widget
100
101 (defstruct (slime-tree (:conc-name slime-tree.))
102 item
103 (print-fn #'slime-tree-default-printer :type function)
104 (kids '() :type list)
105 (collapsed-p t :type boolean)
106 (prefix "" :type string)
107 (start-mark nil)
108 (end-mark nil)
109 (plist '() :type list))
110
111 (defun slime-tree-leaf-p (tree)
112 (not (slime-tree.kids tree)))
113
114 (defun slime-tree-default-printer (tree)
115 (princ (slime-tree.item tree) (current-buffer)))
116
117 (defun slime-tree-decoration (tree)
118 (cond ((slime-tree-leaf-p tree) "-- ")
119 ((slime-tree.collapsed-p tree) "[+] ")
120 (t "-+ ")))
121
122 (defun slime-tree-insert-list (list prefix)
123 "Insert a list of trees."
124 (loop for (elt . rest) on list
125 do (cond (rest
126 (insert prefix " |")
127 (slime-tree-insert elt (concat prefix " |"))
128 (insert "\n"))
129 (t
130 (insert prefix " `")
131 (slime-tree-insert elt (concat prefix " "))))))
132
133 (defun slime-tree-insert-decoration (tree)
134 (insert (slime-tree-decoration tree)))
135
136 (defun slime-tree-indent-item (start end prefix)
137 "Insert PREFIX at the beginning of each but the first line.
138 This is used for labels spanning multiple lines."
139 (save-excursion
140 (goto-char end)
141 (beginning-of-line)
142 (while (< start (point))
143 (insert-before-markers prefix)
144 (forward-line -1))))
145
146 (defun slime-tree-insert (tree prefix)
147 "Insert TREE prefixed with PREFIX at point."
148 (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree
149 (let ((line-start (line-beginning-position)))
150 (setf start-mark (point-marker))
151 (slime-tree-insert-decoration tree)
152 (funcall print-fn tree)
153 (slime-tree-indent-item start-mark (point) (concat prefix " "))
154 (add-text-properties line-start (point) (list 'slime-tree tree))
155 (set-marker-insertion-type start-mark t)
156 (when (and kids (not collapsed-p))
157 (terpri (current-buffer))
158 (slime-tree-insert-list kids prefix))
159 (setf (slime-tree.prefix tree) prefix)
160 (setf end-mark (point-marker)))))
161
162 (defun slime-tree-at-point ()
163 (cond ((get-text-property (point) 'slime-tree))
164 (t (error "No tree at point"))))
165
166 (defun slime-tree-delete (tree)
167 "Delete the region for TREE."
168 (delete-region (slime-tree.start-mark tree)
169 (slime-tree.end-mark tree)))
170
171 (defun slime-tree-toggle (tree)
172 "Toggle the visibility of TREE's children."
173 (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree
174 (setf collapsed-p (not collapsed-p))
175 (slime-tree-delete tree)
176 (insert-before-markers " ") ; move parent's end-mark
177 (backward-char 1)
178 (slime-tree-insert tree prefix)
179 (delete-char 1)
180 (goto-char start-mark)))
181
182 (provide 'slime-compiler-notes-tree)

  ViewVC Help
Powered by ViewVC 1.1.5