/[slime]/slime/contrib/slime-fontifying-fu.el
ViewVC logotype

Contents of /slime/contrib/slime-fontifying-fu.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Fri May 28 14:15:30 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.18: +1 -0 lines
Call provide at the end of the file.
* slime-c-p-c.el slime-fancy-inspector.el slime-fancy.el
slime-fontifying-fu.el slime-fuzzy.el slime-package-fu.el
slime-parse.el slime-presentations.el slime-references.el
slime-repl.el slime-scratch.el:
1
2 (define-slime-contrib slime-fontifying-fu
3 "Additional fontification tweaks:
4 Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros.
5 Fontify CHECK-FOO like CHECK-TYPE."
6 (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
7 (:license "GPL")
8 (:on-load
9 (font-lock-add-keywords
10 'lisp-mode slime-additional-font-lock-keywords)
11 (when slime-highlight-suppressed-forms
12 (slime-activate-font-lock-magic)))
13 (:on-unload
14 ;; FIXME: remove `slime-search-suppressed-forms', and remove the
15 ;; extend-region hook.
16 (font-lock-remove-keywords
17 'lisp-mode slime-additional-font-lock-keywords)))
18
19 ;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros.
20 ;;; Fontify CHECK-FOO like CHECK-TYPE.
21 (defvar slime-additional-font-lock-keywords
22 '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
23 ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
24 ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)
25 ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)))
26
27
28 ;;;; Specially fontify forms suppressed by a reader conditional.
29
30 (defcustom slime-highlight-suppressed-forms t
31 "Display forms disabled by reader conditionals as comments."
32 :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
33 :group 'slime-mode)
34
35 (defface slime-reader-conditional-face
36 (if (slime-face-inheritance-possible-p)
37 '((t (:inherit font-lock-comment-face)))
38 '((((background light)) (:foreground "DimGray" :bold t))
39 (((background dark)) (:foreground "LightGray" :bold t))))
40 "Face for compiler notes while selected."
41 :group 'slime-mode-faces)
42
43 (defvar slime-search-suppressed-forms-match-data (list nil nil))
44
45 (defun slime-search-suppressed-forms-internal (limit)
46 (when (search-forward-regexp slime-reader-conditionals-regexp limit t)
47 (let ((start (match-beginning 0)) ; save match data
48 (state (slime-current-parser-state)))
49 (if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
50 (slime-search-suppressed-forms-internal limit)
51 (let* ((char (char-before))
52 (expr (read (current-buffer)))
53 (val (slime-eval-feature-expression expr)))
54 (when (<= (point) limit)
55 (if (or (and (eq char ?+) (not val))
56 (and (eq char ?-) val))
57 ;; If `slime-extend-region-for-font-lock' did not
58 ;; fully extend the region, the assertion below may
59 ;; fail. This should only happen on XEmacs and older
60 ;; versions of GNU Emacs.
61 (ignore-errors
62 (forward-sexp) (backward-sexp)
63 ;; Try to suppress as far as possible.
64 (slime-forward-sexp)
65 (assert (<= (point) limit))
66 (let ((md (match-data nil slime-search-suppressed-forms-match-data)))
67 (setf (first md) start)
68 (setf (second md) (point))
69 (set-match-data md)
70 t))
71 (slime-search-suppressed-forms-internal limit))))))))
72
73 (defun slime-search-suppressed-forms (limit)
74 "Find reader conditionalized forms where the test is false."
75 (when (and slime-highlight-suppressed-forms
76 (slime-connected-p))
77 (let ((result 'retry))
78 (while (and (eq result 'retry) (<= (point) limit))
79 (condition-case condition
80 (setq result (slime-search-suppressed-forms-internal limit))
81 (end-of-file ; e.g. #+(
82 (setq result nil))
83 ;; We found a reader conditional we couldn't process for
84 ;; some reason; however, there may still be other reader
85 ;; conditionals before `limit'.
86 (invalid-read-syntax ; e.g. #+#.foo
87 (setq result 'retry))
88 (scan-error ; e.g. #+nil (foo ...
89 (setq result 'retry))
90 (slime-incorrect-feature-expression ; e.g. #+(not foo bar)
91 (setq result 'retry))
92 (slime-unknown-feature-expression ; e.g. #+(foo)
93 (setq result 'retry))
94 (error
95 (setq result nil)
96 (slime-display-warning
97 (concat "Caught error during fontification while searching for forms\n"
98 "that are suppressed by reader-conditionals. The error was: %S.")
99 condition))))
100 result)))
101
102
103 (defun slime-search-directly-preceding-reader-conditional ()
104 "Search for a directly preceding reader conditional. Return its
105 position, or nil."
106 ;;; We search for a preceding reader conditional. Then we check that
107 ;;; between the reader conditional and the point where we started is
108 ;;; no other intervening sexp, and we check that the reader
109 ;;; conditional is at the same nesting level.
110 (condition-case nil
111 (let* ((orig-pt (point)))
112 (when-let (reader-conditional-pt
113 (search-backward-regexp slime-reader-conditionals-regexp
114 ;; We restrict the search to the
115 ;; beginning of the /previous/ defun.
116 (save-excursion (beginning-of-defun) (point))
117 t))
118 (let* ((parser-state
119 (parse-partial-sexp (progn (goto-char (+ reader-conditional-pt 2))
120 (forward-sexp) ; skip feature expr.
121 (point))
122 orig-pt))
123 (paren-depth (car parser-state))
124 (last-sexp-pt (caddr parser-state)))
125 (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
126 (not last-sexp-pt)) ; no complete sexp in between?
127 reader-conditional-pt
128 nil))))
129 (scan-error nil))) ; improper feature expression
130
131
132 ;;; We'll push this onto `font-lock-extend-region-functions'. In past,
133 ;;; we didn't do so which made our reader-conditional font-lock magic
134 ;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
135 ;;; worked quite non-deterministic in general.)
136 ;;;
137 ;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
138 ;;;
139 ;;; We make sure that `font-lock-beg' and `font-lock-end' always point
140 ;;; to the beginning or end of a toplevel form. So we never miss a
141 ;;; reader-conditional, or point in mid of one.
142 (defun slime-extend-region-for-font-lock ()
143 (when slime-highlight-suppressed-forms
144 (condition-case c
145 (let (changedp)
146 (multiple-value-setq (changedp font-lock-beg font-lock-end)
147 (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
148 changedp)
149 (error
150 (slime-display-warning
151 (concat "Caught error when trying to extend the region for fontification.\n"
152 "The error was: %S\n"
153 "Further: font-lock-beg=%d, font-lock-end=%d.")
154 c font-lock-beg font-lock-end)))))
155
156 (when (fboundp 'syntax-ppss-toplevel-pos)
157 (defun slime-beginning-of-tlf ()
158 (when-let (pos (syntax-ppss-toplevel-pos (slime-current-parser-state)))
159 (goto-char pos))))
160
161 (unless (fboundp 'syntax-ppss-toplevel-pos)
162 (defun slime-beginning-of-tlf ()
163 (let* ((state (slime-current-parser-state))
164 (comment-start (nth 8 state)))
165 (when comment-start ; or string
166 (goto-char comment-start)
167 (setq state (slime-current-parser-state)))
168 (let ((depth (nth 0 state)))
169 (when (plusp depth)
170 (ignore-errors (up-list (- depth)))) ; ignore unbalanced parentheses
171 (when-let (upper-pt (nth 1 state))
172 (goto-char upper-pt)
173 (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
174 (goto-char upper-pt))))))))
175
176 (defun slime-compute-region-for-font-lock (orig-beg orig-end)
177 (let ((beg orig-beg)
178 (end orig-end))
179 (goto-char beg)
180 (inline (slime-beginning-of-tlf))
181 (assert (not (plusp (nth 0 (slime-current-parser-state)))))
182 (setq beg (let ((pt (point)))
183 (cond ((> (- beg pt) 20000) beg)
184 ((slime-search-directly-preceding-reader-conditional))
185 (t pt))))
186 (goto-char end)
187 (while (search-backward-regexp slime-reader-conditionals-regexp beg t)
188 (setq end (max end (save-excursion
189 (ignore-errors (slime-forward-reader-conditional))
190 (point)))))
191 (values (or (/= beg orig-beg) (/= end orig-end)) beg end)))
192
193
194 (defun slime-activate-font-lock-magic ()
195 (if (featurep 'xemacs)
196 (let ((pattern `((slime-search-suppressed-forms
197 (0 slime-reader-conditional-face t)))))
198 (dolist (sym '(lisp-font-lock-keywords
199 lisp-font-lock-keywords-1
200 lisp-font-lock-keywords-2))
201 (set sym (append (symbol-value sym) pattern))))
202 (font-lock-add-keywords
203 'lisp-mode
204 `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))
205
206 (add-hook 'lisp-mode-hook
207 #'(lambda ()
208 (add-hook 'font-lock-extend-region-functions
209 'slime-extend-region-for-font-lock t t)))))
210
211 (let ((byte-compile-warnings '()))
212 (mapc #'byte-compile
213 '(slime-extend-region-for-font-lock
214 slime-compute-region-for-font-lock
215 slime-search-directly-preceding-reader-conditional
216 slime-search-suppressed-forms
217 slime-beginning-of-tlf)))
218
219 ;;; Tests
220 (def-slime-test font-lock-magic (buffer-content)
221 "Some testing for the font-lock-magic. *YES* should be
222 highlighted as a suppressed form, *NO* should not."
223
224 '(("(defun *NO* (x y) (+ x y))")
225 ("(defun *NO*")
226 ("*NO*) #-(and) (*YES*) (*NO* *NO*")
227 ("\(
228 \(defun *NO*")
229 ("\)
230 \(defun *NO*
231 \(
232 \)")
233 ("#+#.foo
234 \(defun *NO* (x y) (+ x y))")
235 ("#+#.foo
236 \(defun *NO* (x ")
237 ("#+(
238 \(defun *NO* (x ")
239 ("#+(test)
240 \(defun *NO* (x ")
241
242 ("(eval-when (...)
243 \(defun *NO* (x ")
244
245 ("(eval-when (...)
246 #+(and)
247 \(defun *NO* (x ")
248
249 ("#-(and) (defun *YES* (x y) (+ x y))")
250 ("
251 #-(and) (defun *YES* (x y) (+ x y))
252 #+(and) (defun *NO* (x y) (+ x y))")
253
254 ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))")
255 ("#| #+(or) |# *NO*")
256 ("#| #+(or) x |# *NO*")
257 ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*")
258 ("#+#.foo (defun foo (bar))
259 #-(and) *YES* *NO* bar
260 ")
261 ("#+(foo) (defun foo (bar))
262 #-(and) *YES* *NO* bar")
263 ("#| #+(or) |# *NO* foo
264 #-(and) *YES* *NO*")
265 ("#- (and)
266 \(*YES*)
267 \(*NO*)
268 #-(and)
269 \(*YES*)
270 \(*NO*)")
271 ("#+nil (foo)
272
273 #-(and)
274 #+nil (
275 asdf *YES* a
276 fsdfad)
277
278 \( asdf *YES*
279
280 )
281 \(*NO*)
282
283 ")
284 ("*NO*
285
286 #-(and) \(progn
287 #-(and)
288 (defun *YES* ...)
289
290 #+(and)
291 (defun *YES* ...)
292
293 (defun *YES* ...)
294
295 *YES*
296
297 *YES*
298
299 *YES*
300
301 *YES*
302 \)
303
304 *NO*")
305 ("#-(not) *YES* *NO*
306
307 *NO*
308
309 #+(not) *NO* *NO*
310
311 *NO*
312
313 #+(not a b c) *NO* *NO*
314
315 *NO*"))
316 (slime-check-top-level)
317 (with-temp-buffer
318 (insert buffer-content)
319 (slime-initialize-lisp-buffer-for-test-suite
320 :autodoc t :font-lock-magic t)
321 ;; Can't use `font-lock-fontify-buffer' because for the case when
322 ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on
323 ;; actual display.
324 (font-lock-default-fontify-buffer)
325 (when (search-backward "*NO*" nil t)
326 (slime-test-expect "Not suppressed by reader conditional?"
327 'slime-reader-conditional-face
328 (get-text-property (point) 'face)
329 #'(lambda (x y) (not (eq x y)))))
330 (goto-char (point-max))
331 (when (search-backward "*YES*" nil t)
332 (slime-test-expect "Suppressed by reader conditional?"
333 'slime-reader-conditional-face
334 (get-text-property (point) 'face)))))
335
336 (defun* slime-initialize-lisp-buffer-for-test-suite
337 (&key (font-lock-magic t) (autodoc t))
338 (let ((hook lisp-mode-hook))
339 (unwind-protect
340 (progn
341 (set (make-local-variable 'slime-highlight-suppressed-forms)
342 font-lock-magic)
343 (setq lisp-mode-hook nil)
344 (lisp-mode)
345 (slime-mode 1)
346 (when (boundp 'slime-autodoc-mode)
347 (if autodoc
348 (slime-autodoc-mode 1)
349 (slime-autodoc-mode -1))))
350 (setq lisp-mode-hook hook))))
351
352 (provide 'slime-fontifying-fu)

  ViewVC Help
Powered by ViewVC 1.1.5