1 ;;; flylisp.el --- Color unbalanced parentheses and parentheses inconsistent with indentation -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
5 ;; Author: Barry O'Reilly <gundaetiapo@gmail.com>
7 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.4"))
9 ;; This program is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; This program is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;; Colors mismatched open parentheses with fl-mismatched-face, red by
25 ;; default. Works reliably after Emacs 24.3, in which bug 16247 is
28 ;; Also colors open and close parentheses which are inconsistent with
29 ;; the indentation of lines between them with fl-inconsistent-face,
30 ;; orange by default. This is useful for the Lisp programmer who
31 ;; infers a close paren's location from the open paren and
32 ;; indentation. The coloring serves as a warning that the indentation
33 ;; misleads about where the close paren is. It may also help to
34 ;; localize the mistake, whether due to a misindented line or a
37 ;; As an example, consider:
44 ;; (aaa ...) and (ccc ...) are consistent, so are not colored.
45 ;; (bbb ...) is inconsistent because the indentation of fff is
46 ;; inconsistent with the actual location of the close paren. The open
47 ;; and close paren are thus colored with the fl-inconsistent-face.
48 ;; This example also shows that multi line strings don't cause an
51 ;; Currently, the package only detects close parens that are after the
52 ;; place indentation would predict. A planned feature is to also
53 ;; indicate when the close paren is before.
55 ;; Also planned is to color mismatched close parens.
59 ;; TODO: Algorithm doesn't account for close paren which is too soon.
65 ;; (abc ...) are inconsistent parens because (ghi) is indented too far
67 ;; TODO: implement mismatched close parens
71 ;; ;; Expect (abc ...) is consistent, (def ...) is inconsistent:
72 ;; (abc a-symbol (a-func-call "word-a
76 ;; ;; Expect (when ...) is inconsistent:
79 ;; ;; After change, expect (when ...) is consistent and last paren mismatched:
83 ;; Given (a ...) inconsistent, change to (a ...(), and verify close
84 ;; paren is consistent.
90 "Color unbalanced parentheses and parentheses inconsistent with indentation."
92 :group 'paren-matching)
94 (defgroup flylisp-faces nil
95 "Faces for flylisp package. "
99 (defface fl-inconsistent-face
100 '((((class color) (background light))
101 :foreground "dark orange")
102 (((class color) (background dark))
103 :foreground "orange"))
104 "Face applied to matching open and close parens whose placement
105 is inconsistent with indentation."
106 :group 'flylisp-faces)
108 (defface fl-mismatched-face
109 '((((class color) (background light))
110 :foreground "dark red")
111 (((class color) (background dark))
113 "Face applied to a paren who has no match."
114 :group 'flylisp-faces)
116 ;; An open paren and algorithmic data about it.
118 ;; position is the position in the buffer of the open paren
122 ;; - the position before the matching close paren
123 ;; - the symbol 'mismatched if no matching close paren exists
125 ;; column is the displayed column of the open paren in its logical
126 ;; line of the buffer
128 ;; inconsistent is whether the open paren's close paren is
129 ;; inconsistent with the indentation within the list defined by the
130 ;; parens. It is one of:
131 ;; - nil if unknown or consistent
132 ;; - an integer offset from the open position to the position of the
133 ;; first inconsistency. This offset is also cached in the open
134 ;; paren text properties for performance.
135 (cl-defstruct fl--Open position close column inconsistent)
137 (defsubst fl--colorize-inconsistent (open-obj)
138 "Colorize the fl--Open OPEN-OBJ as inconsistent."
139 (add-text-properties (fl--Open-position open-obj)
140 (1+ (fl--Open-position open-obj))
142 ,(fl--Open-inconsistent open-obj)
147 (add-text-properties (fl--Open-close open-obj)
148 (1+ (fl--Open-close open-obj))
154 (defsubst fl--line-check-opens (open-stack)
155 "Check fl--Open objects of the OPEN-STACK list for
158 The inconsistent==nil elements of OPEN-STACK must have columns
159 that are strictly decreasing moving towards the tail (a necessary
160 but not sufficient condition for being consistent). The
161 implementation optimizes on this assumption.
163 Call with point on the line being checked; puts point on the next
165 (let ((indent-pos (progn (back-to-indentation)
167 (indent-column (current-column))
168 (line-end (progn (end-of-line)
170 ;; Assess open-objs against indent-column
171 (unless (eq indent-pos line-end) ; Skip whitespace lines
172 ;; Since we're only interested in marking Opens inconsistent,
173 ;; the open-stack's documented property allows the iteration to
174 ;; stop at the first inconsistent==nil Open with small enough
176 (while (and open-stack
177 (or (fl--Open-inconsistent (car open-stack))
179 (fl--Open-column (car open-stack)))))
180 ;; Check fl--Open-inconsistent to avoid excessive
181 ;; syntax-ppss when there's a lot of bad
183 (unless (or (fl--Open-inconsistent (car open-stack))
184 ;; Multi line strings don't cause inconsistency
185 (nth 3 (syntax-ppss indent-pos)))
186 (setf (fl--Open-inconsistent (car open-stack))
187 (- indent-pos (fl--Open-position (car open-stack)))))
189 ;; Go to next line. Since we already know line-end, use it
190 ;; instead of rescanning the line
192 ;; goto-char tolerates going beyond EOB
193 (goto-char (1+ line-end))))
195 (defsubst fl--region-check-opens (downward-objs
197 "Check inputted parens in a region for inconsistency, first
198 going down in sexp depth then up per the DOWNWARD-OBJS and
201 Point must be at the start of the region to process and will end
204 DOWNWARD-OBJS is a list of fl--Open objects. Each must be a
205 parent of the next in the list.
207 UPWARD-OBJS is a list of fl--Open objects. Each must be a child
208 of the next in the list."
210 (fl--line-check-opens upward-objs)
211 (while (and downward-objs
212 (< (fl--Open-position (car downward-objs))
214 (push (pop downward-objs)
216 (while (and upward-objs
217 (number-or-marker-p (fl--Open-close (car upward-objs))))
218 (fl--line-check-opens upward-objs)
219 (while (and upward-objs
220 (number-or-marker-p (fl--Open-close (car upward-objs)))
221 (< (fl--Open-close (car upward-objs))
225 (defsubst fl--set-closes (open-obj-list)
226 "Sets the close attribute of each element of OPEN-OBJ-LIST.
228 OPEN-OBJ-LIST is a list of fl--Open. Each must be a child of the
229 next in the list. This is used to scan-lists efficiently."
230 ;; Note: Because fl--Open-position values come from (nth 9
231 ;; (syntax-ppss)), we know they are not inside a string or comment.
232 ;; Thus buf-pos inits to a valid position to start scan-lists from.
233 (let ((buf-pos (and open-obj-list
234 ;; scan_lists tolerates buf-pos past EOB
235 (1+ (fl--Open-position (car open-obj-list))))))
236 (dolist (open-i open-obj-list)
238 (setq buf-pos (condition-case nil
239 (scan-lists buf-pos 1 1)
241 (setf (fl--Open-close open-i) (if buf-pos
245 (defun fl-propertize-region (start end)
247 ;; In order to correctly remove faces from parens that changed
248 ;; from multiline to uniline, we clear all parens in the JIT lock
249 ;; region to start with.
250 (fl-unpropertize-region start end)
251 (let* ((timing-info (list (current-time)))
252 (start-ps (syntax-ppss start))
253 ;; Open positions, outer to inner
254 (ps-opens (nth 9 start-ps))
255 ;; fl--Open objects, positions inner to outer
257 (push (current-time) timing-info)
258 ;; Process the broader region spanned by ps-opens. Consider only
259 ;; the ps-opens, not their children which lie entirely outside
260 ;; the JIT lock region.
262 ;; We mostly avoid further sexp parsing in the broader region,
263 ;; except to check for a multiline string just before setting
265 (dolist (ps-open-i ps-opens)
266 (push (make-fl--Open :position
270 (goto-char ps-open-i)
273 (push (current-time) timing-info)
274 ;; Filter out parens which don't need consideration outside the
275 ;; JIT lock region. The ones that do are currently fontified as
276 ;; inconsistent, and could become consistent if all its enclosed
277 ;; lines are checked.
279 ;; In addition to filtering, this passage sets close positions
280 ;; and may reapply the inconsistency-face to some close parens
281 ;; which were just cleared.
283 (let* ((objs-head (cons nil open-objs))
284 (prev-open objs-head)
285 (open-i (cdr objs-head))
286 ;; Whether we've called fl--set-closes
288 ;; fl--set-closes is fairly expensive when near the
289 ;; beginning of a long Lisp function. We can avoid
290 ;; calling it if all open-objs are propertized as
291 ;; consistent or mismatched.
294 (let* ((inconsistency-offset
295 (get-text-property (fl--Open-position (car open-i))
298 (and inconsistency-offset
299 (+ (fl--Open-position (car open-i))
300 inconsistency-offset))))
301 (if (or (not inconsistency-pos)
302 ;; Always nil so as "or" evaluation continues
304 ;; Lazy one-time call
305 (fl--set-closes open-objs)
306 (not (setq closes-set t)))
307 ;; Spot check using the cached offset to
308 ;; possibly avoid a complete check in
309 ;; fl--region-check-opens for open-i.
311 ;; Because of buffer changes,
312 ;; inconsistency-pos is not necessarily
313 ;; the original. Just do a valid check.
314 (and (< (fl--Open-position (car open-i))
316 (number-or-marker-p (fl--Open-close (car open-i)))
317 (<= inconsistency-pos
318 (fl--Open-close (car open-i)))
320 (goto-char inconsistency-pos)
321 (fl--line-check-opens (list (car open-i)))
322 (when (fl--Open-inconsistent (car open-i))
323 (fl--colorize-inconsistent (car open-i))
325 ;; Remove (car open-i) from list
326 (setcdr prev-open (cdr open-i))
330 (push (current-time) timing-info)
332 ;; Check lists beginning before JIT lock's region (could
333 ;; scan to after JIT lock's region)
334 (let ((open-objs-reversed (reverse open-objs)))
335 (goto-char (fl--Open-position (car open-objs-reversed)))
336 (fl--region-check-opens open-objs-reversed
338 (push (current-time) timing-info)
340 ;; Process within the inputted JIT lock region
341 (let* (;; Sparse vector of open paren data, indexed by position
342 ;; in buffer minus start. This benchmarked better than
343 ;; keeping a stack of fl--Open objects updated from the
344 ;; parse states of syntax-ppss.
345 (open-paren-table (make-vector (- end start) nil)))
346 (while (< (point) end)
347 (let ((indent-pos (progn (back-to-indentation)
349 ;; Column at which text starts on the line
350 (indent-column (current-column))
351 (line-ppss (syntax-ppss))
352 (line-end (progn (end-of-line)
354 ;; Skip whitespace only lines and lines beginning inside
356 (unless (or (eq indent-pos line-end)
358 ;; Iterate over list of unclosed open parens
359 (dolist (open-pos (nth 9 line-ppss))
360 ;; Skip the already processed ones outside the region
361 (when (<= start open-pos)
362 (let ((open-obj (or (aref open-paren-table
371 (aset open-paren-table
374 (when (<= indent-column
375 (fl--Open-column open-obj))
376 (setf (fl--Open-inconsistent open-obj)
377 (- indent-pos (fl--Open-position open-obj))))))))
378 ;; Go to next line. Since we already know line-end, use it
379 ;; instead of rescanning the line
380 (goto-char (1+ line-end))))
381 (push (current-time) timing-info)
382 ;; Process parens beginning in the JIT lock region but extending after
384 ;; Note: the reason we don't filter fl--Open after the JIT
385 ;; lock region, as we did for the region before it, is mostly
386 ;; because of the directionality of redisplay from BOB to EOB.
387 ;; If we allow subsequent fl-propertize-region to propertize
388 ;; the open parens in the current JIT lock region, it wouldn't
389 ;; show to the user because by then redisplay has finished
390 ;; this JIT lock region. An additional consideration is that
391 ;; the coloring of the open paren is of more interest than the
393 (let ((ps-opens (nth 9 (syntax-ppss end)))
394 ;; Inner to outer going towards the tail
396 (dolist (ps-open-i ps-opens)
397 (when (<= start ps-open-i)
398 (push (or (aref open-paren-table
400 ;; Open parens on the last line of the JIT
401 ;; lock region don't have a fl--Open object
407 (goto-char ps-open-i)
410 (aset open-paren-table
414 (push (current-time) timing-info)
415 (fl--set-closes open-obj-list)
416 (push (current-time) timing-info)
418 (fl--region-check-opens nil open-obj-list))
419 (push (current-time) timing-info)
420 (dolist (open-i open-objs)
421 ;; Set close position
423 ;; Note: We do it here instead of when it was made so as
424 ;; some benefit from the fl--set-closes function's buffer
425 ;; scanning optimization. The lists processed here are
426 ;; opened and closed within JIT lock's region, so the less
427 ;; efficient buffer scanning is not a big deal.
428 (unless (fl--Open-close open-i)
429 (setf (fl--Open-close open-i)
431 (1- (scan-lists (fl--Open-position open-i) 1 0))
432 (scan-error 'mismatched))))
433 ;; Apply the font color via text properties
434 (with-silent-modifications
435 (if (eq 'mismatched (fl--Open-close open-i))
436 (add-text-properties (fl--Open-position open-i)
437 (1+ (fl--Open-position open-i))
442 (if (fl--Open-inconsistent open-i)
443 (fl--colorize-inconsistent open-i)
444 (dolist (pos-i (list (fl--Open-position open-i)
445 (fl--Open-close open-i)))
446 (remove-text-properties pos-i
454 (push (current-time) timing-info)
455 ;; (my-msg "fl-propertize-region start=%s end=%s timing: %s"
457 ;; (my-time-diffs (nreverse timing-info)))
460 (defun fl-unpropertize-region (start end)
462 ;; remove-text-properties errors if (1+ (point)) is past EOB, so
464 (let ((end (min (1- (point-max))
466 (while (< (point) end)
467 (skip-syntax-forward "^()" end)
468 (remove-text-properties (point)
470 '(fl-inconsistency nil
475 (defvar jit-lock-start)
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