1 ;;; context-coloring.el --- Highlight by scope -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
5 ;; Author: Jackson Ray Hamilton <jackson@jacksonrayhamilton.com>
7 ;; Keywords: convenience faces tools
8 ;; Package-Requires: ((emacs "24.3") (js2-mode "20150126"))
9 ;; URL: https://github.com/jacksonrayhamilton/context-coloring
11 ;; This file is part of GNU Emacs.
13 ;; This program is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
28 ;; Highlights code by scope. Top-level scopes are one color, second-level
29 ;; scopes are another color, and so on. Variables retain the color of the scope
30 ;; in which they are defined. A variable defined in an outer scope referenced
31 ;; by an inner scope is colored the same as the outer scope.
33 ;; By default, comments and strings are still highlighted syntactically.
42 (defun context-coloring-join (strings delimiter)
43 "Join a list of STRINGS with the string DELIMITER."
44 (mapconcat #'identity strings delimiter))
49 (defun context-coloring-defface (level light dark tty)
50 "Define a face for LEVEL with LIGHT, DARK and TTY colors."
51 (let ((face (intern (format "context-coloring-level-%s-face" level)))
52 (doc (format "Context coloring face, level %s." level)))
55 `((((type tty)) (:foreground ,tty))
56 (((background light)) (:foreground ,light))
57 (((background dark)) (:foreground ,dark)))
59 :group 'context-coloring)))
61 ;; Provide some default colors based off Emacs's defaults.
62 (context-coloring-defface 0 "#000000" "#ffffff" nil)
63 (context-coloring-defface 1 "#008b8b" "#00ffff" "yellow")
64 (context-coloring-defface 2 "#0000ff" "#87cefa" "green")
65 (context-coloring-defface 3 "#483d8b" "#b0c4de" "cyan")
66 (context-coloring-defface 4 "#a020f0" "#eedd82" "blue")
67 (context-coloring-defface 5 "#a0522d" "#98fb98" "magenta")
68 (context-coloring-defface 6 "#228b22" "#7fffd4" "red")
69 (context-coloring-defface 7 "#3f3f3f" "#cdcdcd" nil)
71 (defconst context-coloring-default-maximum-face 7
72 "Maximum face when there are no custom faces.")
74 ;; Create placeholder faces for users and theme authors.
76 (let* ((level (+ level 8))
77 (face (intern (format "context-coloring-level-%s-face" level)))
78 (doc (format "Context coloring face, level %s." level)))
79 (custom-declare-face face nil doc :group 'context-coloring)))
81 (defvar-local context-coloring-maximum-face nil
82 "Dynamic index of the highest face available for coloring.")
84 (defsubst context-coloring-level-face (level)
85 "Return symbol for face with LEVEL."
86 ;; `concat' is faster than `format' here.
88 (concat "context-coloring-level-" (number-to-string level) "-face")))
90 (defsubst context-coloring-bounded-level-face (level)
91 "Return symbol for face with LEVEL, bounded by the maximum."
92 (context-coloring-level-face (min level context-coloring-maximum-face)))
94 (defconst context-coloring-level-face-regexp
95 "context-coloring-level-\\([[:digit:]]+\\)-face"
96 "Extract a level from a face.")
98 (defun context-coloring-theme-highest-level (theme)
99 "Return the highest coloring level for THEME, or -1."
100 (let* ((settings (get theme 'theme-settings))
106 (and (eq (nth 0 (car tail)) 'theme-face)
107 (setq face-string (symbol-name (nth 1 (car tail))))
109 context-coloring-level-face-regexp
111 (setq number (string-to-number
112 (substring face-string
117 (setq tail (cdr tail)))
120 (defun context-coloring-update-maximum-face ()
121 "Save the highest possible face for the current theme."
122 (let ((themes (append custom-enabled-themes '(user)))
127 (setq theme (car themes))
128 (setq themes (cdr themes))
129 (setq highest-level (context-coloring-theme-highest-level theme))
130 (setq continue (and themes (= highest-level -1))))
131 (setq context-coloring-maximum-face
133 ((= highest-level -1)
134 context-coloring-default-maximum-face)
141 (defvar-local context-coloring-changed-p nil
142 "Indication that the buffer has changed recently, which implies
143 that it should be colored again by
144 `context-coloring-maybe-colorize-idle-timer' if that timer is
147 (defvar-local context-coloring-changed-start nil
148 "Beginning of last text that changed.")
150 (defvar-local context-coloring-changed-end nil
151 "End of last text that changed.")
153 (defvar-local context-coloring-changed-length nil
154 "Length of last text that changed.")
156 (defun context-coloring-change-function (start end length)
157 "Register a change so that a buffer can be colorized soon.
159 START, END and LENGTH are recorded for later use."
160 ;; Tokenization is obsolete if there was a change.
161 (setq context-coloring-changed-start start)
162 (setq context-coloring-changed-end end)
163 (setq context-coloring-changed-length length)
164 (setq context-coloring-changed-p t))
166 (defun context-coloring-maybe-colorize-with-buffer (buffer)
167 "Color BUFFER and if it has changed."
168 (when (and (eq buffer (current-buffer))
169 context-coloring-changed-p)
170 (context-coloring-colorize-with-buffer buffer)
171 (setq context-coloring-changed-p nil)
172 (setq context-coloring-changed-start nil)
173 (setq context-coloring-changed-end nil)
174 (setq context-coloring-changed-length nil)))
176 (defvar-local context-coloring-maybe-colorize-idle-timer nil
177 "The currently-running idle timer for conditional coloring.")
179 (defvar-local context-coloring-colorize-idle-timer nil
180 "The currently-running idle timer for unconditional coloring.")
182 (defcustom context-coloring-default-delay 0.25
183 "Default delay between a buffer update and colorization.
185 Increase this if your machine is high-performing. Decrease it if
187 :group 'context-coloring)
189 (make-obsolete-variable
190 'context-coloring-delay
191 'context-coloring-default-delay
194 (defun context-coloring-cancel-timer (timer)
197 (cancel-timer timer)))
199 (defun context-coloring-schedule-coloring (time)
200 "Schedule coloring to occur once after Emacs is idle for TIME."
201 (context-coloring-cancel-timer context-coloring-colorize-idle-timer)
202 (setq context-coloring-colorize-idle-timer
206 #'context-coloring-colorize-with-buffer
209 (defun context-coloring-setup-idle-change-detection ()
210 "Setup idle change detection."
211 (let ((dispatch (context-coloring-get-current-dispatch)))
213 'after-change-functions #'context-coloring-change-function nil t)
215 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
216 (setq context-coloring-maybe-colorize-idle-timer
218 (or (plist-get dispatch :delay) context-coloring-default-delay)
220 #'context-coloring-maybe-colorize-with-buffer
223 (defun context-coloring-teardown-idle-change-detection ()
224 "Teardown idle change detection."
225 (dolist (timer (list context-coloring-colorize-idle-timer
226 context-coloring-maybe-colorize-idle-timer))
227 (context-coloring-cancel-timer timer))
229 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
231 'after-change-functions #'context-coloring-change-function t))
234 ;;; Colorization utilities
236 (defsubst context-coloring-colorize-region (start end level)
237 "Color from START (inclusive) to END (exclusive) with LEVEL."
241 `(face ,(context-coloring-bounded-level-face level))))
243 (make-obsolete-variable
244 'context-coloring-comments-and-strings
245 "use `context-coloring-syntactic-comments' and
246 `context-coloring-syntactic-strings' instead."
249 (defcustom context-coloring-syntactic-comments t
250 "If non-nil, also color comments using `font-lock'."
251 :group 'context-coloring)
253 (defcustom context-coloring-syntactic-strings t
254 "If non-nil, also color strings using `font-lock'."
255 :group 'context-coloring)
257 (defun context-coloring-font-lock-syntactic-comment-function (state)
258 "Color a comment according to STATE."
259 (if (nth 3 state) nil font-lock-comment-face))
261 (defun context-coloring-font-lock-syntactic-string-function (state)
262 "Color a string according to STATE."
263 (if (nth 3 state) font-lock-string-face nil))
265 (defsubst context-coloring-colorize-comments-and-strings (&optional min max)
266 "Maybe color comments and strings in buffer from MIN to MAX.
267 MIN defaults to beginning of buffer. MAX defaults to end."
268 (when (or context-coloring-syntactic-comments
269 context-coloring-syntactic-strings)
270 (let ((min (or min (point-min)))
271 (max (or max (point-max)))
272 (font-lock-syntactic-face-function
274 ((and context-coloring-syntactic-comments
275 (not context-coloring-syntactic-strings))
276 #'context-coloring-font-lock-syntactic-comment-function)
277 ((and context-coloring-syntactic-strings
278 (not context-coloring-syntactic-comments))
279 #'context-coloring-font-lock-syntactic-string-function)
281 font-lock-syntactic-face-function))))
283 (font-lock-fontify-syntactically-region min max)
284 ;; TODO: Make configurable at the dispatch level.
285 (when (eq major-mode 'emacs-lisp-mode)
286 (font-lock-fontify-keywords-region min max))))))
289 ;;; js2-mode colorization
291 (defvar-local context-coloring-js2-scope-level-hash-table nil
292 "Associate `js2-scope' structures and with their scope
295 (defcustom context-coloring-javascript-block-scopes nil
296 "If non-nil, also color block scopes in the scope hierarchy in JavaScript.
298 The block-scoped `let' and `const' are introduced in ES6. Enable
299 this for ES6 code; disable it elsewhere."
300 :group 'context-coloring)
302 (make-obsolete-variable
303 'context-coloring-js-block-scopes
304 'context-coloring-javascript-block-scopes
307 (defsubst context-coloring-js2-scope-level (scope)
308 "Return the level of SCOPE."
309 (cond ((gethash scope context-coloring-js2-scope-level-hash-table))
312 (current-scope scope)
314 (while (and current-scope
315 (js2-node-parent current-scope)
316 (setq enclosing-scope
317 (js2-node-get-enclosing-scope current-scope)))
318 (when (or context-coloring-javascript-block-scopes
319 (let ((type (js2-scope-type current-scope)))
320 (or (= type js2-SCRIPT)
321 (= type js2-FUNCTION)
322 (= type js2-CATCH))))
323 (setq level (+ level 1)))
324 (setq current-scope enclosing-scope))
325 (puthash scope level context-coloring-js2-scope-level-hash-table)))))
327 (defsubst context-coloring-js2-local-name-node-p (node)
328 "Determine if NODE represents a local variable."
329 (and (js2-name-node-p node)
330 (let ((parent (js2-node-parent node)))
331 (not (or (and (js2-object-prop-node-p parent)
332 (eq node (js2-object-prop-node-left parent)))
333 (and (js2-prop-get-node-p parent)
334 ;; For nested property lookup, the node on the left is a
335 ;; `js2-prop-get-node', so this always works.
336 (eq node (js2-prop-get-node-right parent))))))))
338 (defvar-local context-coloring-point-max nil
339 "Cached value of `point-max'.")
341 (defsubst context-coloring-js2-colorize-node (node level)
342 "Color NODE with the color for LEVEL."
343 (let ((start (js2-node-abs-pos node)))
344 (context-coloring-colorize-region
348 (+ start (js2-node-len node))
349 ;; Somes nodes (like the ast when there is an unterminated multiline
350 ;; comment) will stretch to the value of `point-max'.
351 context-coloring-point-max)
354 (defun context-coloring-js2-colorize ()
355 "Color the buffer using the `js2-mode' abstract syntax tree."
356 ;; Reset the hash table; the old one could be obsolete.
357 (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
358 (setq context-coloring-point-max (point-max))
359 (with-silent-modifications
366 (context-coloring-js2-colorize-node
368 (context-coloring-js2-scope-level node)))
369 ((context-coloring-js2-local-name-node-p node)
370 (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
371 (defining-scope (js2-get-defining-scope
373 (js2-name-node-name node))))
374 ;; The tree seems to be walked lexically, so an entire scope will
375 ;; be colored, including its name nodes, before they are reached.
376 ;; Coloring the nodes defined in that scope would be redundant, so
378 (when (not (eq defining-scope enclosing-scope))
379 (context-coloring-js2-colorize-node
381 (context-coloring-js2-scope-level defining-scope))))))
382 ;; The `t' indicates to search children.
384 (context-coloring-colorize-comments-and-strings)))
387 ;;; Emacs Lisp colorization
389 (defsubst context-coloring-forward-sws ()
390 "Move forward through whitespace and comments."
391 (while (forward-comment 1)))
393 (defsubst context-coloring-elisp-forward-sws ()
394 "Move through whitespace and comments, coloring comments."
395 (let ((start (point)))
396 (context-coloring-forward-sws)
397 (context-coloring-colorize-comments-and-strings start (point))))
399 (defsubst context-coloring-elisp-forward-sexp ()
400 "Like `forward-sexp', coloring skipped comments and strings."
401 (let ((start (point)))
403 (context-coloring-elisp-colorize-comments-and-strings-in-region
406 (defsubst context-coloring-get-syntax-code ()
407 "Get the syntax code at point."
409 ;; Faster version of `syntax-after':
410 (aref (syntax-table) (char-after (point)))))
412 (defsubst context-coloring-exact-regexp (word)
413 "Create a regexp matching exactly WORD."
414 (concat "\\`" (regexp-quote word) "\\'"))
416 (defsubst context-coloring-exact-or-regexp (words)
417 "Create a regexp matching any exact word in WORDS."
418 (context-coloring-join
419 (mapcar #'context-coloring-exact-regexp words) "\\|"))
421 (defconst context-coloring-elisp-ignored-word-regexp
422 (context-coloring-join (list "\\`[-+]?[0-9]"
424 (context-coloring-exact-or-regexp
425 '("t" "nil" "." "?")))
427 "Match symbols that can't be bound as variables.")
429 (defconst context-coloring-WORD-CODE 2)
430 (defconst context-coloring-SYMBOL-CODE 3)
431 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
432 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
433 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
434 (defconst context-coloring-STRING-QUOTE-CODE 7)
435 (defconst context-coloring-ESCAPE-CODE 9)
436 (defconst context-coloring-COMMENT-START-CODE 11)
437 (defconst context-coloring-COMMENT-END-CODE 12)
439 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
440 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
441 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
442 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
443 (defconst context-coloring-AT-CHAR (string-to-char "@"))
444 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
446 (defsubst context-coloring-elisp-identifier-p (syntax-code)
447 "Check if SYNTAX-CODE is an elisp identifier constituent."
448 (or (= syntax-code context-coloring-WORD-CODE)
449 (= syntax-code context-coloring-SYMBOL-CODE)))
451 (defvar context-coloring-parse-interruptable-p t
452 "Set this to nil to force parse to continue until finished.")
454 (defconst context-coloring-elisp-sexps-per-pause 350
455 "Pause after this many iterations to check for user input.
456 If user input is pending, stop the parse. This makes for a
457 smoother user experience for large files.
459 This number should trigger pausing at about 60 frames per
462 (defvar context-coloring-elisp-sexp-count 0
463 "Current number of sexps leading up to the next pause.")
465 (defsubst context-coloring-elisp-increment-sexp-count ()
466 "Maybe check if the user interrupted the current parse."
467 (setq context-coloring-elisp-sexp-count
468 (1+ context-coloring-elisp-sexp-count))
469 (when (and (zerop (% context-coloring-elisp-sexp-count
470 context-coloring-elisp-sexps-per-pause))
471 context-coloring-parse-interruptable-p
473 (throw 'interrupted t)))
475 (defvar context-coloring-elisp-scope-stack '()
476 "List of scopes in the current parse.")
478 (defsubst context-coloring-elisp-make-scope (level)
479 "Make a scope object for LEVEL."
484 (defsubst context-coloring-elisp-scope-get-level (scope)
485 "Get the level of SCOPE object."
486 (plist-get scope :level))
488 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
489 "Add to SCOPE a VARIABLE."
490 (plist-put scope :variables (cons variable (plist-get scope :variables))))
492 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
493 "Check if SCOPE has VARIABLE."
494 (member variable (plist-get scope :variables)))
496 (defsubst context-coloring-elisp-get-variable-level (variable)
497 "Return the level of VARIABLE, or 0 if it isn't found."
498 (let* ((scope-stack context-coloring-elisp-scope-stack)
501 (while (and scope-stack (not level))
502 (setq scope (car scope-stack))
504 ((context-coloring-elisp-scope-has-variable scope variable)
505 (setq level (context-coloring-elisp-scope-get-level scope)))
507 (setq scope-stack (cdr scope-stack)))))
508 ;; Assume a global variable.
511 (defsubst context-coloring-elisp-get-current-scope-level ()
512 "Get the nesting level of the current scope."
514 ((car context-coloring-elisp-scope-stack)
515 (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
519 (defsubst context-coloring-elisp-push-scope ()
520 "Add a new scope to the bottom of the scope chain."
521 (push (context-coloring-elisp-make-scope
522 (1+ (context-coloring-elisp-get-current-scope-level)))
523 context-coloring-elisp-scope-stack))
525 (defsubst context-coloring-elisp-pop-scope ()
526 "Remove the scope on the bottom of the scope chain."
527 (pop context-coloring-elisp-scope-stack))
529 (defsubst context-coloring-elisp-add-variable (variable)
530 "Add VARIABLE to the current scope."
531 (context-coloring-elisp-scope-add-variable
532 (car context-coloring-elisp-scope-stack)
535 (defsubst context-coloring-elisp-parse-bindable (callback)
536 "Parse the symbol at point.
537 If the symbol can be bound, invoke CALLBACK with it."
538 (let* ((arg-string (buffer-substring-no-properties
540 (progn (context-coloring-elisp-forward-sexp)
542 (when (not (string-match-p
543 context-coloring-elisp-ignored-word-regexp
545 (funcall callback arg-string))))
547 (defun context-coloring-elisp-parse-let-varlist (type)
548 "Parse the list of variable initializers at point.
549 If TYPE is `let', all the variables are bound after all their
550 initializers are parsed; if TYPE is `let*', each variable is
551 bound immediately after its own initializer is parsed."
556 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
557 context-coloring-CLOSE-PARENTHESIS-CODE)
559 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
561 (context-coloring-elisp-forward-sws)
562 (setq syntax-code (context-coloring-get-syntax-code))
563 (when (context-coloring-elisp-identifier-p syntax-code)
564 (context-coloring-elisp-parse-bindable
567 (context-coloring-elisp-forward-sws)
568 (setq syntax-code (context-coloring-get-syntax-code))
569 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
570 (context-coloring-elisp-colorize-sexp)))
571 (context-coloring-elisp-forward-sws)
572 ;; Skip past the closing parenthesis.
574 ((context-coloring-elisp-identifier-p syntax-code)
575 (context-coloring-elisp-parse-bindable
577 (push var varlist))))
580 (context-coloring-elisp-forward-sexp)))
581 (when (eq type 'let*)
582 (context-coloring-elisp-add-variable (pop varlist)))
583 (context-coloring-elisp-forward-sws))
586 (context-coloring-elisp-add-variable (pop varlist))))
590 (defun context-coloring-elisp-parse-arglist ()
591 "Parse the list of function arguments at point."
595 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
596 context-coloring-CLOSE-PARENTHESIS-CODE)
598 ((context-coloring-elisp-identifier-p syntax-code)
599 (context-coloring-elisp-parse-bindable
601 (context-coloring-elisp-add-variable arg))))
604 (context-coloring-elisp-forward-sexp)))
605 (context-coloring-elisp-forward-sws))
609 (defun context-coloring-elisp-skip-callee-name ()
610 "Skip past the opening parenthesis and name of a function."
613 (context-coloring-elisp-forward-sws)
614 ;; Skip past the function name.
616 (context-coloring-elisp-forward-sws))
618 (defun context-coloring-elisp-colorize-scope (callback)
619 "Color the whole scope at point with its one color.
620 Handle a header in CALLBACK."
621 (let ((start (point))
622 (end (progn (forward-sexp)
624 (context-coloring-elisp-push-scope)
625 ;; Splash the whole thing in one color.
626 (context-coloring-colorize-region
629 (context-coloring-elisp-get-current-scope-level))
630 ;; Even if the parse is interrupted, this region should still be colored
632 (context-coloring-elisp-colorize-comments-and-strings-in-region
636 (context-coloring-elisp-skip-callee-name)
638 (context-coloring-elisp-colorize-region (point) (1- end))
641 (context-coloring-elisp-pop-scope)))
643 (defun context-coloring-elisp-parse-header (callback)
644 "Parse a function header at point with CALLBACK."
645 (when (= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
648 (defun context-coloring-elisp-colorize-defun-like (callback)
649 "Color the defun-like function at point.
650 Parse the header with CALLBACK."
651 (context-coloring-elisp-colorize-scope
653 (when (context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
654 ;; Color the defun's name with the top-level color.
655 (context-coloring-colorize-region
657 (progn (forward-sexp)
660 (context-coloring-elisp-forward-sws)
661 (context-coloring-elisp-parse-header callback)))))
663 (defun context-coloring-elisp-colorize-defun ()
664 "Color the `defun' at point."
665 (context-coloring-elisp-colorize-defun-like
666 'context-coloring-elisp-parse-arglist))
668 (defun context-coloring-elisp-colorize-defadvice ()
669 "Color the `defadvice' at point."
670 (context-coloring-elisp-colorize-defun-like
675 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
676 context-coloring-CLOSE-PARENTHESIS-CODE)
678 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
679 (context-coloring-elisp-parse-arglist))
682 (context-coloring-elisp-forward-sexp)))
683 (context-coloring-elisp-forward-sws))))))
685 (defun context-coloring-elisp-colorize-lambda-like (callback)
686 "Color the lambda-like function at point.
687 Parsing the header with CALLBACK."
688 (context-coloring-elisp-colorize-scope
690 (context-coloring-elisp-parse-header callback))))
692 (defun context-coloring-elisp-colorize-lambda ()
693 "Color the `lambda' at point."
694 (context-coloring-elisp-colorize-lambda-like
695 'context-coloring-elisp-parse-arglist))
697 (defun context-coloring-elisp-colorize-let ()
698 "Color the `let' at point."
699 (context-coloring-elisp-colorize-lambda-like
701 (context-coloring-elisp-parse-let-varlist 'let))))
703 (defun context-coloring-elisp-colorize-let* ()
704 "Color the `let*' at point."
705 (context-coloring-elisp-colorize-lambda-like
707 (context-coloring-elisp-parse-let-varlist 'let*))))
709 (defun context-coloring-elisp-colorize-cond ()
710 "Color the `cond' at point."
712 (context-coloring-elisp-skip-callee-name)
713 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
714 context-coloring-CLOSE-PARENTHESIS-CODE)
716 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
717 ;; Colorize inside the parens.
718 (let ((start (point)))
720 (context-coloring-elisp-colorize-region
721 (1+ start) (1- (point)))
726 (context-coloring-elisp-forward-sexp)))
727 (context-coloring-elisp-forward-sws))
731 (defun context-coloring-elisp-colorize-condition-case ()
732 "Color the `condition-case' at point."
737 (context-coloring-elisp-colorize-scope
739 (setq syntax-code (context-coloring-get-syntax-code))
740 ;; Gracefully ignore missing variables.
741 (when (context-coloring-elisp-identifier-p syntax-code)
742 (context-coloring-elisp-parse-bindable
743 (lambda (parsed-variable)
744 (setq variable parsed-variable)))
745 (context-coloring-elisp-forward-sws))
746 (context-coloring-elisp-colorize-sexp)
747 (context-coloring-elisp-forward-sws)
748 ;; Parse the handlers with the error variable in scope.
750 (context-coloring-elisp-add-variable variable))
751 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
752 context-coloring-CLOSE-PARENTHESIS-CODE)
754 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
755 (setq case-pos (point))
756 (context-coloring-elisp-forward-sexp)
757 (setq case-end (point))
761 (context-coloring-elisp-forward-sws)
762 (setq syntax-code (context-coloring-get-syntax-code))
763 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
764 ;; Skip the condition name(s).
765 (context-coloring-elisp-forward-sexp)
766 ;; Color the remaining portion of the handler.
767 (context-coloring-elisp-colorize-region
774 (context-coloring-elisp-forward-sexp)))
775 (context-coloring-elisp-forward-sws))))))
777 (defun context-coloring-elisp-colorize-dolist ()
778 "Color the `dolist' at point."
781 (context-coloring-elisp-colorize-scope
783 (setq syntax-code (context-coloring-get-syntax-code))
784 (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
786 (context-coloring-elisp-forward-sws)
787 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
788 context-coloring-CLOSE-PARENTHESIS-CODE)
791 (or (= index 0) (= index 2))
792 (context-coloring-elisp-identifier-p syntax-code))
793 ;; Add the first or third name to the scope.
794 (context-coloring-elisp-parse-bindable
796 (context-coloring-elisp-add-variable variable))))
799 (context-coloring-elisp-colorize-sexp)))
800 (context-coloring-elisp-forward-sws)
801 (setq index (1+ index)))
805 (defun context-coloring-elisp-colorize-quote ()
806 "Color the `quote' at point."
807 (let* ((start (point))
808 (end (progn (forward-sexp)
810 (context-coloring-colorize-region
813 (context-coloring-elisp-get-current-scope-level))
814 (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
816 (defvar context-coloring-elisp-callee-dispatch-hash-table
817 (let ((table (make-hash-table :test 'equal)))
818 (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
819 (puthash callee #'context-coloring-elisp-colorize-defun table))
820 (dolist (callee '("condition-case" "condition-case-unless-debug"))
821 (puthash callee #'context-coloring-elisp-colorize-condition-case table))
822 (dolist (callee '("dolist" "dotimes"))
823 (puthash callee #'context-coloring-elisp-colorize-dolist table))
824 (puthash "let" #'context-coloring-elisp-colorize-let table)
825 (puthash "let*" #'context-coloring-elisp-colorize-let* table)
826 (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
827 (puthash "cond" #'context-coloring-elisp-colorize-cond table)
828 (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
829 (puthash "quote" #'context-coloring-elisp-colorize-quote table)
830 (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
832 "Map function names to their coloring functions.")
834 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
835 "Color the sexp enclosed by parenthesis at point."
836 (context-coloring-elisp-increment-sexp-count)
837 (let* ((start (point))
838 (end (progn (forward-sexp)
840 (syntax-code (progn (goto-char start)
842 ;; Coloring is unnecessary here, it'll happen
844 (context-coloring-forward-sws)
845 (context-coloring-get-syntax-code)))
847 ;; Figure out if the sexp is a special form.
849 ((and (context-coloring-elisp-identifier-p syntax-code)
850 (setq dispatch-function (gethash
851 (buffer-substring-no-properties
853 (progn (forward-sexp)
855 context-coloring-elisp-callee-dispatch-hash-table)))
857 (funcall dispatch-function))
858 ;; Not a special form; just colorize the remaining region.
860 (context-coloring-colorize-region
863 (context-coloring-elisp-get-current-scope-level))
864 (context-coloring-elisp-colorize-region (point) (1- end))
867 (defun context-coloring-elisp-colorize-symbol ()
868 "Color the symbol at point."
869 (context-coloring-elisp-increment-sexp-count)
870 (let* ((symbol-pos (point))
871 (symbol-end (progn (forward-sexp)
873 (symbol-string (buffer-substring-no-properties
877 ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
879 (context-coloring-colorize-region
882 (context-coloring-elisp-get-variable-level
885 (defun context-coloring-elisp-colorize-backquote-form ()
886 "Color the backquote form at point."
887 (let ((start (point))
888 (end (progn (forward-sexp)
892 (while (> end (progn (forward-char)
894 (setq char (char-after))
895 (when (= char context-coloring-COMMA-CHAR)
897 (when (= (char-after) context-coloring-AT-CHAR)
898 ;; If we don't do this "@" could be interpreted as a symbol.
900 (context-coloring-elisp-forward-sws)
901 (context-coloring-elisp-colorize-sexp)))
902 ;; We could probably do this as part of the above loop but it'd be
904 (context-coloring-elisp-colorize-comments-and-strings-in-region
907 (defun context-coloring-elisp-colorize-backquote ()
908 "Color the `backquote' at point."
909 (context-coloring-elisp-skip-callee-name)
910 (context-coloring-elisp-colorize-backquote-form)
914 (defun context-coloring-elisp-colorize-expression-prefix ()
915 "Color the expression prefix and expression at point.
916 It could be a quoted or backquoted expression."
917 (context-coloring-elisp-increment-sexp-count)
919 ((/= (char-after) context-coloring-BACKTICK-CHAR)
920 (context-coloring-elisp-forward-sexp))
922 (context-coloring-elisp-colorize-backquote-form))))
924 (defun context-coloring-elisp-colorize-comment ()
925 "Color the comment at point."
926 (context-coloring-elisp-increment-sexp-count)
927 (context-coloring-elisp-forward-sws))
929 (defun context-coloring-elisp-colorize-string ()
930 "Color the string at point."
931 (context-coloring-elisp-increment-sexp-count)
932 (let ((start (point)))
934 (context-coloring-colorize-comments-and-strings start (point))))
936 ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
937 ;; prefix, string quote, comment starters/enders and escape syntax classes only.
939 (defun context-coloring-elisp-colorize-sexp ()
940 "Color the sexp at point."
941 (let ((syntax-code (context-coloring-get-syntax-code)))
943 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
944 (context-coloring-elisp-colorize-parenthesized-sexp))
945 ((context-coloring-elisp-identifier-p syntax-code)
946 (context-coloring-elisp-colorize-symbol))
947 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
948 (context-coloring-elisp-colorize-expression-prefix))
949 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
950 (context-coloring-elisp-colorize-string))
951 ((= syntax-code context-coloring-ESCAPE-CODE)
954 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
955 "Color comments and strings between START and END."
958 (while (> end (progn (skip-syntax-forward "^\"<\\" end)
960 (setq syntax-code (context-coloring-get-syntax-code))
962 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
963 (context-coloring-elisp-colorize-string))
964 ((= syntax-code context-coloring-COMMENT-START-CODE)
965 (context-coloring-elisp-colorize-comment))
966 ((= syntax-code context-coloring-ESCAPE-CODE)
967 (forward-char 2))))))
969 (defun context-coloring-elisp-colorize-region (start end)
970 "Color everything between START and END."
973 (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
975 (setq syntax-code (context-coloring-get-syntax-code))
977 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
978 (context-coloring-elisp-colorize-parenthesized-sexp))
979 ((context-coloring-elisp-identifier-p syntax-code)
980 (context-coloring-elisp-colorize-symbol))
981 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
982 (context-coloring-elisp-colorize-expression-prefix))
983 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
984 (context-coloring-elisp-colorize-string))
985 ((= syntax-code context-coloring-COMMENT-START-CODE)
986 (context-coloring-elisp-colorize-comment))
987 ((= syntax-code context-coloring-ESCAPE-CODE)
988 (forward-char 2))))))
990 (defun context-coloring-elisp-colorize-region-initially (start end)
991 "Begin coloring everything between START and END."
992 (setq context-coloring-elisp-sexp-count 0)
993 (setq context-coloring-elisp-scope-stack '())
994 (let ((inhibit-point-motion-hooks t)
995 (case-fold-search nil)
996 ;; This is a recursive-descent parser, so give it a big stack.
997 (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
998 (max-specpdl-size (max max-specpdl-size 3000)))
999 (context-coloring-elisp-colorize-region start end)))
1001 (defun context-coloring-elisp-colorize-guard (callback)
1002 "Silently color in CALLBACK."
1003 (with-silent-modifications
1007 ;; Scan errors can happen virtually anywhere if parenthesis are
1008 ;; unbalanced. Just swallow them. (`progn' for test coverage.)
1009 (scan-error (progn))))))
1011 (defun context-coloring-elisp-colorize ()
1012 "Color the current Emacs Lisp buffer."
1014 (context-coloring-elisp-colorize-guard
1017 ;; Just colorize the changed region.
1018 (context-coloring-changed-p
1019 (let* ( ;; Prevent `beginning-of-defun' from making poor assumptions.
1020 (open-paren-in-column-0-is-defun-start nil)
1021 ;; Seek the beginning and end of the previous and next
1022 ;; offscreen defuns, so just enough is colored.
1023 (start (progn (goto-char context-coloring-changed-start)
1024 (while (and (< (point-min) (point))
1025 (pos-visible-in-window-p))
1027 (beginning-of-defun)
1029 (end (progn (goto-char context-coloring-changed-end)
1030 (while (and (> (point-max) (point))
1031 (pos-visible-in-window-p))
1035 (context-coloring-elisp-colorize-region-initially start end)
1036 ;; Fast coloring is nice, but if the code is not well-formed
1037 ;; (e.g. an unclosed string literal is parsed at any time) then
1038 ;; there could be leftover incorrectly-colored code offscreen. So
1039 ;; do a clean sweep as soon as appropriate.
1040 (context-coloring-schedule-coloring context-coloring-default-delay)))
1042 (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
1045 ;;; eval-expression colorization
1047 (defun context-coloring-eval-expression-match ()
1048 "Determine expression start in `eval-expression'."
1049 (string-match "\\`Eval: " (buffer-string)))
1051 (defun context-coloring-eval-expression-colorize ()
1052 "Color the `eval-expression' minibuffer prompt as elisp."
1054 (context-coloring-elisp-colorize-guard
1056 (context-coloring-elisp-colorize-region-initially
1058 (context-coloring-eval-expression-match)
1065 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
1066 "Map dispatch strategy names to their property lists.")
1068 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
1069 "Map major mode names to dispatch property lists.")
1071 (defvar context-coloring-dispatch-predicates '()
1072 "Functions which may return a dispatch.")
1074 (defun context-coloring-get-current-dispatch ()
1075 "Return the first dispatch appropriate for the current state."
1076 (let ((predicates context-coloring-dispatch-predicates)
1079 ;; Maybe a predicate will be satisfied and return a dispatch.
1080 (while (and predicates
1081 (not (setq dispatch (funcall (pop predicates))))))
1082 ;; If not, maybe a major mode (or a derivative) will define a dispatch.
1083 (when (not dispatch)
1085 (not (setq dispatch (gethash parent context-coloring-mode-hash-table)))
1086 (setq parent (get parent 'derived-mode-parent)))))
1089 (defun context-coloring-define-dispatch (symbol &rest properties)
1090 "Define a new dispatch named SYMBOL with PROPERTIES.
1092 A \"dispatch\" is a property list describing a strategy for
1095 PROPERTIES must include one of `:modes' or `:predicate', and a
1098 `:modes' - List of major modes this dispatch is valid for.
1100 `:predicate' - Function that determines if the dispatch is valid
1101 for any given state.
1103 `:colorizer' - Function that parses and colors the buffer.
1105 `:delay' - Delay between buffer update and colorization, to
1106 override `context-coloring-default-delay'.
1108 `:setup' - Arbitrary code to set up this dispatch when
1109 `context-coloring-mode' is enabled.
1111 `:teardown' - Arbitrary code to tear down this dispatch when
1112 `context-coloring-mode' is disabled."
1113 (let ((modes (plist-get properties :modes))
1114 (predicate (plist-get properties :predicate))
1115 (colorizer (plist-get properties :colorizer)))
1116 (when (null (or modes predicate))
1117 (error "No mode or predicate defined for dispatch"))
1118 (when (not colorizer)
1119 (error "No colorizer defined for dispatch"))
1120 (puthash symbol properties context-coloring-dispatch-hash-table)
1121 (dolist (mode modes)
1122 (puthash mode properties context-coloring-mode-hash-table))
1125 (when (funcall predicate)
1126 properties)) context-coloring-dispatch-predicates))))
1128 (defun context-coloring-dispatch ()
1129 "Determine how to color the current buffer, and color it."
1130 (let* ((dispatch (context-coloring-get-current-dispatch))
1131 (colorizer (plist-get dispatch :colorizer)))
1133 (funcall colorizer))))
1138 (defun context-coloring-colorize ()
1139 "Color the current buffer by function context."
1141 (context-coloring-update-maximum-face)
1142 (context-coloring-dispatch))
1144 (defun context-coloring-colorize-with-buffer (buffer)
1146 ;; Don't select deleted buffers.
1147 (when (get-buffer buffer)
1148 (with-current-buffer buffer
1149 (context-coloring-colorize))))
1152 ;;; Built-in dispatches
1154 (context-coloring-define-dispatch
1157 :colorizer #'context-coloring-js2-colorize
1160 (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
1163 (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
1165 (context-coloring-define-dispatch
1167 :modes '(emacs-lisp-mode)
1168 :colorizer #'context-coloring-elisp-colorize
1169 :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
1170 :setup #'context-coloring-setup-idle-change-detection
1171 :teardown #'context-coloring-teardown-idle-change-detection)
1173 ;; `eval-expression-minibuffer-setup-hook' is not available in Emacs 24.3, so
1174 ;; the backwards-compatible recommendation is to use `minibuffer-setup-hook' and
1175 ;; rely on this predicate instead.
1176 (defun context-coloring-eval-expression-predicate ()
1177 "Non-nil if the minibuffer is for `eval-expression'."
1178 ;; Kinda better than checking `this-command', because `this-command' changes.
1179 (context-coloring-eval-expression-match))
1181 (context-coloring-define-dispatch
1183 :predicate #'context-coloring-eval-expression-predicate
1184 :colorizer #'context-coloring-eval-expression-colorize
1186 :setup #'context-coloring-setup-idle-change-detection
1187 :teardown #'context-coloring-teardown-idle-change-detection)
1189 (defvar context-coloring-ignore-unavailable-predicates
1192 "Cases when \"unavailable\" messages are silenced.
1193 Necessary in editing states where coloring is only sometimes
1196 (defun context-coloring-ignore-unavailable-message-p ()
1197 "Determine if the unavailable message should be silenced."
1198 (let ((predicates context-coloring-ignore-unavailable-predicates)
1200 (while (and predicates
1202 (setq ignore-p (funcall (pop predicates))))
1209 (define-minor-mode context-coloring-mode
1210 "Toggle contextual code coloring.
1211 With a prefix argument ARG, enable Context Coloring mode if ARG
1212 is positive, and disable it otherwise. If called from Lisp,
1213 enable the mode if ARG is omitted or nil.
1215 Context Coloring mode is a buffer-local minor mode. When
1216 enabled, code is colored by scope. Scopes are colored
1217 hierarchically. Variables referenced from nested scopes retain
1218 the color of their defining scopes. Certain syntax, like
1219 comments and strings, is still colored with `font-lock'.
1221 The entire buffer is colored initially. Changes to the buffer
1224 Define your own colors by customizing faces like
1225 `context-coloring-level-N-face', where N is a number starting
1226 from 0. If no face is found on a custom theme nor the `user'
1227 theme, the defaults are used.
1229 New language / major mode support can be added with
1230 `context-coloring-define-dispatch', which see.
1232 Feature inspired by Douglas Crockford."
1235 (context-coloring-mode
1236 ;; Font lock is incompatible with this mode; the converse is also true.
1239 ;; ...but we do use font-lock functions here.
1240 (font-lock-set-defaults)
1241 ;; Safely change the value of this function as necessary.
1242 (make-local-variable 'font-lock-syntactic-face-function)
1243 (let ((dispatch (context-coloring-get-current-dispatch)))
1246 (let ((setup (plist-get dispatch :setup)))
1249 ;; Colorize once initially.
1250 (let ((context-coloring-parse-interruptable-p nil))
1251 (context-coloring-colorize))))
1252 ((not (context-coloring-ignore-unavailable-message-p))
1253 (message "Context coloring is unavailable here")))))
1255 (let ((dispatch (context-coloring-get-current-dispatch)))
1257 (let ((teardown (plist-get dispatch :teardown)))
1259 (funcall teardown)))))
1261 (jit-lock-mode t))))
1263 (provide 'context-coloring)
1265 ;;; context-coloring.el ends here