1 ;;; flylisp.el --- Color unbalanced parentheses and parentheses inconsistent with indentation -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
5 ;; Author: Barry O'Reilly <gundaetiapo@gmail.com>
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23 ;; Colors mismatched open parentheses with fl-mismatched-face, red by
26 ;; Also colors open and close parentheses which are inconsistent with
27 ;; the indentation of lines between them with fl-inconsistent-face,
28 ;; orange by default. This is useful for the Lisp programmer who
29 ;; infers a close paren's location from the open paren and
30 ;; indentation. The coloring serves as a warning that the indentation
31 ;; misleads about where the close paren is. It may also help to
32 ;; localize the mistake, whether due to a misindented line or a
35 ;; As an example, consider:
42 ;; (aaa ...) and (ccc ...) are consistent, so are not colored.
43 ;; (bbb ...) is inconsistent because the indentation of fff is
44 ;; inconsistent with the actual location of the close paren. The open
45 ;; and close paren are thus colored with the fl-inconsistent-face.
46 ;; This example also shows that multi line strings don't cause an
49 ;; Currently, the package only detects close parens that are after the
50 ;; place indentation would predict. A planned feature is to also
51 ;; indicate when the close paren is before.
53 ;; Also planned is to color mismatched close parens.
57 ;; TODO: There are display problems with mismatched parens, due to the
58 ;; region not expanding enough, in turn due to an apparent syntax-ppss
59 ;; bug. See Emacs bug 16247.
61 ;; TODO: Algorithm doesn't account for close paren which is too soon.
67 ;; (abc ...) are inconsistent parens because (ghi) is indented too far
69 ;; TODO: implement mismatched close parens
73 ;; ;; Expect (abc ...) is consistent, (def ...) is inconsistent:
74 ;; (abc a-symbol (a-func-call "word-a
78 ;; ;; Expect (when ...) is inconsistent:
81 ;; ;; After change, expect (when ...) is consistent and last paren mismatched:
85 ;; Given (a ...) inconsistent, change to (a ...(), and verify close
86 ;; paren is consistent.
92 "Color unbalanced parentheses and parentheses inconsistent with indentation."
94 :group 'paren-matching)
96 (defgroup flylisp-faces nil
97 "Faces for flylisp package. "
101 (defface fl-inconsistent-face
102 '((((class color) (background light))
103 :foreground "dark orange")
104 (((class color) (background dark))
105 :foreground "orange"))
106 "Face applied to matching open and close parens whose placement
107 is inconsistent with indentation."
108 :group 'flylisp-faces)
110 (defface fl-mismatched-face
111 '((((class color) (background light))
112 :foreground "dark red")
113 (((class color) (background dark))
115 "Face applied to a paren who has no match."
116 :group 'flylisp-faces)
118 ;; An open paren and algorithmic data about it.
120 ;; position is the position in the buffer of the open paren
124 ;; - the position before the matching close paren
125 ;; - the symbol 'mismatched if no matching close paren exists
127 ;; column is the displayed column of the open paren in its logical
128 ;; line of the buffer
130 ;; inconsistent is whether the open paren's close paren is
131 ;; inconsistent with the indentation within the list defined by the
132 ;; parens. It is one of:
133 ;; - nil if unknown or consistent
134 ;; - an integer offset from the open position to the position of the
135 ;; first inconsistency. This offset is also cached in the open
136 ;; paren text properties for performance.
137 (cl-defstruct fl--Open position close column inconsistent)
139 (defsubst fl--colorize-inconsistent (open-obj)
140 "Colorize the fl--Open OPEN-OBJ as inconsistent."
141 (add-text-properties (fl--Open-position open-obj)
142 (1+ (fl--Open-position open-obj))
144 ,(fl--Open-inconsistent open-obj)
149 (add-text-properties (fl--Open-close open-obj)
150 (1+ (fl--Open-close open-obj))
156 (defsubst fl--line-check-opens (open-stack)
157 "Check fl--Open objects of the OPEN-STACK list for
160 The inconsistent==nil elements of OPEN-STACK must have columns
161 that are strictly decreasing moving towards the tail (a necessary
162 but not sufficient condition for being consistent). The
163 implementation optimizes on this assumption.
165 Call with point on the line being checked; puts point on the next
167 (let ((indent-pos (progn (back-to-indentation)
169 (indent-column (current-column))
170 (line-end (progn (end-of-line)
172 ;; Assess open-objs against indent-column
173 (unless (eq indent-pos line-end) ; Skip whitespace lines
174 ;; Since we're only interested in marking Opens inconsistent,
175 ;; the open-stack's documented property allows the iteration to
176 ;; stop at the first inconsistent==nil Open with small enough
178 (while (and open-stack
179 (or (fl--Open-inconsistent (car open-stack))
181 (fl--Open-column (car open-stack)))))
182 ;; Check fl--Open-inconsistent to avoid excessive
183 ;; syntax-ppss when there's a lot of bad
185 (unless (or (fl--Open-inconsistent (car open-stack))
186 ;; Multi line strings don't cause inconsistency
187 (nth 3 (syntax-ppss indent-pos)))
188 (setf (fl--Open-inconsistent (car open-stack))
189 (- indent-pos (fl--Open-position (car open-stack)))))
191 ;; Go to next line. Since we already know line-end, use it
192 ;; instead of rescanning the line
194 ;; goto-char tolerates going beyond EOB
195 (goto-char (1+ line-end))))
197 (defsubst fl--region-check-opens (downward-objs
199 "Check inputted parens in a region for inconsistency, first
200 going down in sexp depth then up per the DOWNWARD-OBJS and
203 Point must be at the start of the region to process and will end
206 DOWNWARD-OBJS is a list of fl--Open objects. Each must be a
207 parent of the next in the list.
209 UPWARD-OBJS is a list of fl--Open objects. Each must be a child
210 of the next in the list."
212 (fl--line-check-opens upward-objs)
213 (while (and downward-objs
214 (< (fl--Open-position (car downward-objs))
216 (push (pop downward-objs)
218 (while (and upward-objs
219 (number-or-marker-p (fl--Open-close (car upward-objs))))
220 (fl--line-check-opens upward-objs)
221 (while (and upward-objs
222 (number-or-marker-p (fl--Open-close (car upward-objs)))
223 (< (fl--Open-close (car upward-objs))
227 (defsubst fl--set-closes (open-obj-list)
228 "Sets the close attribute of each element of OPEN-OBJ-LIST.
230 OPEN-OBJ-LIST is a list of fl--Open. Each must be a child of the
231 next in the list. This is used to scan-lists efficiently."
232 ;; Note: Because fl--Open-position values come from (nth 9
233 ;; (syntax-ppss)), we know they are not inside a string or comment.
234 ;; Thus buf-pos inits to a valid position to start scan-lists from.
235 (let ((buf-pos (and open-obj-list
236 ;; scan_lists tolerates buf-pos past EOB
237 (1+ (fl--Open-position (car open-obj-list))))))
238 (dolist (open-i open-obj-list)
240 (setq buf-pos (condition-case nil
241 (scan-lists buf-pos 1 1)
243 (setf (fl--Open-close open-i) (if buf-pos
247 (defun fl-propertize-region (start end)
249 ;; In order to correctly remove faces from parens that changed
250 ;; from multiline to uniline, we clear all parens in the JIT lock
251 ;; region to start with.
252 (fl-unpropertize-region start end)
253 (let* ((timing-info (list (current-time)))
254 (start-ps (syntax-ppss start))
255 ;; Open positions, outer to inner
256 (ps-opens (nth 9 start-ps))
257 ;; fl--Open objects, positions inner to outer
259 (push (current-time) timing-info)
260 ;; Process the broader region spanned by ps-opens. Consider only
261 ;; the ps-opens, not their children which lie entirely outside
262 ;; the JIT lock region.
264 ;; We mostly avoid further sexp parsing in the broader region,
265 ;; except to check for a multiline string just before setting
267 (dolist (ps-open-i ps-opens)
268 (push (make-fl--Open :position
272 (goto-char ps-open-i)
275 (push (current-time) timing-info)
276 ;; Filter out parens which don't need consideration outside the
277 ;; JIT lock region. The ones that do are currently fontified as
278 ;; inconsistent, and could become consistent if all its enclosed
279 ;; lines are checked.
281 ;; In addition to filtering, this passage sets close positions
282 ;; and may reapply the inconsistency-face to some close parens
283 ;; which were just cleared.
285 (let* ((objs-head (cons nil open-objs))
286 (prev-open objs-head)
287 (open-i (cdr objs-head))
288 ;; Whether we've called fl--set-closes
290 ;; fl--set-closes is fairly expensive when near the
291 ;; beginning of a long Lisp function. We can avoid
292 ;; calling it if all open-objs are propertized as
293 ;; consistent or mismatched.
296 (let* ((inconsistency-offset
297 (get-text-property (fl--Open-position (car open-i))
300 (and inconsistency-offset
301 (+ (fl--Open-position (car open-i))
302 inconsistency-offset))))
303 (if (or (not inconsistency-pos)
304 ;; Always nil so as "or" evaluation continues
306 ;; Lazy one-time call
307 (fl--set-closes open-objs)
308 (not (setq closes-set t)))
309 ;; Spot check using the cached offset to
310 ;; possibly avoid a complete check in
311 ;; fl--region-check-opens for open-i.
313 ;; Because of buffer changes,
314 ;; inconsistency-pos is not necessarily
315 ;; the original. Just do a valid check.
316 (and (< (fl--Open-position (car open-i))
318 (number-or-marker-p (fl--Open-close (car open-i)))
319 (<= inconsistency-pos
320 (fl--Open-close (car open-i)))
322 (goto-char inconsistency-pos)
323 (fl--line-check-opens (list (car open-i)))
324 (when (fl--Open-inconsistent (car open-i))
325 (fl--colorize-inconsistent (car open-i))
327 ;; Remove (car open-i) from list
328 (setcdr prev-open (cdr open-i))
332 (push (current-time) timing-info)
334 ;; Check lists beginning before JIT lock's region (could
335 ;; scan to after JIT lock's region)
336 (let ((open-objs-reversed (reverse open-objs)))
337 (goto-char (fl--Open-position (car open-objs-reversed)))
338 (fl--region-check-opens open-objs-reversed
340 (push (current-time) timing-info)
342 ;; Process within the inputted JIT lock region
343 (let* (;; Sparse vector of open paren data, indexed by position
344 ;; in buffer minus start. This benchmarked better than
345 ;; keeping a stack of fl--Open objects updated from the
346 ;; parse states of syntax-ppss.
347 (open-paren-table (make-vector (- end start) nil)))
348 (while (< (point) end)
349 (let ((indent-pos (progn (back-to-indentation)
351 ;; Column at which text starts on the line
352 (indent-column (current-column))
353 (line-ppss (syntax-ppss))
354 (line-end (progn (end-of-line)
356 ;; Skip whitespace only lines and lines beginning inside
358 (unless (or (eq indent-pos line-end)
360 ;; Iterate over list of unclosed open parens
361 (dolist (open-pos (nth 9 line-ppss))
362 ;; Skip the already processed ones outside the region
363 (when (<= start open-pos)
364 (let ((open-obj (or (aref open-paren-table
373 (aset open-paren-table
376 (when (<= indent-column
377 (fl--Open-column open-obj))
378 (setf (fl--Open-inconsistent open-obj)
379 (- indent-pos (fl--Open-position open-obj))))))))
380 ;; Go to next line. Since we already know line-end, use it
381 ;; instead of rescanning the line
382 (goto-char (1+ line-end))))
383 (push (current-time) timing-info)
384 ;; Process parens beginning in the JIT lock region but extending after
386 ;; Note: the reason we don't filter fl--Open after the JIT
387 ;; lock region, as we did for the region before it, is mostly
388 ;; because of the directionality of redisplay from BOB to EOB.
389 ;; If we allow subsequent fl-propertize-region to propertize
390 ;; the open parens in the current JIT lock region, it wouldn't
391 ;; show to the user because by then redisplay has finished
392 ;; this JIT lock region. An additional consideration is that
393 ;; the coloring of the open paren is of more interest than the
395 (let ((ps-opens (nth 9 (syntax-ppss end)))
396 ;; Inner to outer going towards the tail
398 (dolist (ps-open-i ps-opens)
399 (when (<= start ps-open-i)
400 (push (or (aref open-paren-table
402 ;; Open parens on the last line of the JIT
403 ;; lock region don't have a fl--Open object
409 (goto-char ps-open-i)
412 (aset open-paren-table
416 (push (current-time) timing-info)
417 (fl--set-closes open-obj-list)
418 (push (current-time) timing-info)
420 (fl--region-check-opens nil open-obj-list))
421 (push (current-time) timing-info)
422 (dolist (open-i open-objs)
423 ;; Set close position
425 ;; Note: We do it here instead of when it was made so as
426 ;; some benefit from the fl--set-closes function's buffer
427 ;; scanning optimization. The lists processed here are
428 ;; opened and closed within JIT lock's region, so the less
429 ;; efficient buffer scanning is not a big deal.
430 (unless (fl--Open-close open-i)
431 (setf (fl--Open-close open-i)
433 (1- (scan-lists (fl--Open-position open-i) 1 0))
434 (scan-error 'mismatched))))
435 ;; Apply the font color via text properties
436 (with-silent-modifications
437 (if (eq 'mismatched (fl--Open-close open-i))
438 (add-text-properties (fl--Open-position open-i)
439 (1+ (fl--Open-position open-i))
444 (if (fl--Open-inconsistent open-i)
445 (fl--colorize-inconsistent open-i)
446 (dolist (pos-i (list (fl--Open-position open-i)
447 (fl--Open-close open-i)))
448 (remove-text-properties pos-i
456 (push (current-time) timing-info)
457 ;; (my-msg "fl-propertize-region start=%s end=%s timing: %s"
459 ;; (my-time-diffs (nreverse timing-info)))
462 (defun fl-unpropertize-region (start end)
464 ;; remove-text-properties errors if (1+ (point)) is past EOB, so
466 (let ((end (min (1- (point-max))
468 (while (< (point) end)
469 (skip-syntax-forward "^()" end)
470 (remove-text-properties (point)
472 '(fl-inconsistency nil
477 (defsubst flylisp-extend-region-after-change (start _end _old-len)
478 ;; It seems redisplay works its way from before start to after end,
479 ;; so it's more important to expand the start in order to get
480 ;; correct redisplays.
483 (or (syntax-ppss-toplevel-pos (syntax-ppss start))
486 (define-minor-mode flylisp-mode
487 "Color unbalanced parentheses and parentheses inconsistent with
492 (jit-lock-register 'fl-propertize-region t)
493 (add-hook 'jit-lock-after-change-extend-region-functions
494 #'flylisp-extend-region-after-change
497 (remove-hook 'jit-lock-after-change-extend-region-functions
498 #'flylisp-extend-region-after-change
500 (jit-lock-unregister 'fl-propertize-region)
502 (fl-unpropertize-region (point-min) (point-max)))))
506 ;;; flylisp.el ends here