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 "20150713"))
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
188 :group 'context-coloring)
190 (make-obsolete-variable
191 'context-coloring-delay
192 'context-coloring-default-delay
195 (defun context-coloring-cancel-timer (timer)
198 (cancel-timer timer)))
200 (defun context-coloring-schedule-coloring (time)
201 "Schedule coloring to occur once after Emacs is idle for TIME."
202 (context-coloring-cancel-timer context-coloring-colorize-idle-timer)
203 (setq context-coloring-colorize-idle-timer
207 #'context-coloring-colorize-with-buffer
210 (defun context-coloring-setup-idle-change-detection ()
211 "Setup idle change detection."
212 (let ((dispatch (context-coloring-get-current-dispatch)))
214 'after-change-functions #'context-coloring-change-function nil t)
216 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
217 (setq context-coloring-maybe-colorize-idle-timer
219 (or (plist-get dispatch :delay) context-coloring-default-delay)
221 #'context-coloring-maybe-colorize-with-buffer
224 (defun context-coloring-teardown-idle-change-detection ()
225 "Teardown idle change detection."
226 (dolist (timer (list context-coloring-colorize-idle-timer
227 context-coloring-maybe-colorize-idle-timer))
228 (context-coloring-cancel-timer timer))
230 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
232 'after-change-functions #'context-coloring-change-function t))
235 ;;; Colorization utilities
237 (defsubst context-coloring-colorize-region (start end level)
238 "Color from START (inclusive) to END (exclusive) with LEVEL."
242 `(face ,(context-coloring-bounded-level-face level))))
244 (make-obsolete-variable
245 'context-coloring-comments-and-strings
246 "use `context-coloring-syntactic-comments' and
247 `context-coloring-syntactic-strings' instead."
250 (defcustom context-coloring-syntactic-comments t
251 "If non-nil, also color comments using `font-lock'."
253 :group 'context-coloring)
255 (defcustom context-coloring-syntactic-strings t
256 "If non-nil, also color strings using `font-lock'."
258 :group 'context-coloring)
260 (defun context-coloring-font-lock-syntactic-comment-function (state)
261 "Color a comment according to STATE."
262 (if (nth 3 state) nil font-lock-comment-face))
264 (defun context-coloring-font-lock-syntactic-string-function (state)
265 "Color a string according to STATE."
266 (if (nth 3 state) font-lock-string-face nil))
268 (defsubst context-coloring-colorize-comments-and-strings (&optional min max)
269 "Maybe color comments and strings in buffer from MIN to MAX.
270 MIN defaults to beginning of buffer. MAX defaults to end."
271 (when (or context-coloring-syntactic-comments
272 context-coloring-syntactic-strings)
273 (let ((min (or min (point-min)))
274 (max (or max (point-max)))
275 (font-lock-syntactic-face-function
277 ((and context-coloring-syntactic-comments
278 (not context-coloring-syntactic-strings))
279 #'context-coloring-font-lock-syntactic-comment-function)
280 ((and context-coloring-syntactic-strings
281 (not context-coloring-syntactic-comments))
282 #'context-coloring-font-lock-syntactic-string-function)
284 font-lock-syntactic-face-function))))
286 (font-lock-fontify-syntactically-region min max)
287 ;; TODO: Make configurable at the dispatch level.
288 (when (eq major-mode 'emacs-lisp-mode)
289 (font-lock-fontify-keywords-region min max))))))
291 (defcustom context-coloring-initial-level 0
292 "Scope level at which to start coloring.
294 If top-level variables and functions do not become global, but
295 are scoped to a file (as in Node.js), set this to `1'."
298 :group 'context-coloring)
301 ;;; JavaScript colorization
303 (defvar-local context-coloring-js2-scope-level-hash-table nil
304 "Associate `js2-scope' structures and with their scope
307 (defcustom context-coloring-javascript-block-scopes nil
308 "If non-nil, also color block scopes in the scope hierarchy in JavaScript.
310 The block-scoped `let' and `const' are introduced in ES6. Enable
311 this for ES6 code; disable it elsewhere."
314 :group 'context-coloring)
316 (make-obsolete-variable
317 'context-coloring-js-block-scopes
318 'context-coloring-javascript-block-scopes
321 (defsubst context-coloring-js2-scope-level (scope initial)
322 "Return the level of SCOPE, starting from INITIAL."
323 (cond ((gethash scope context-coloring-js2-scope-level-hash-table))
325 (let ((level initial)
326 (current-scope scope)
328 (while (and current-scope
329 (js2-node-parent current-scope)
330 (setq enclosing-scope
331 (js2-node-get-enclosing-scope current-scope)))
332 (when (or context-coloring-javascript-block-scopes
333 (let ((type (js2-scope-type current-scope)))
334 (or (= type js2-SCRIPT)
335 (= type js2-FUNCTION)
336 (= type js2-CATCH))))
337 (setq level (+ level 1)))
338 (setq current-scope enclosing-scope))
339 (puthash scope level context-coloring-js2-scope-level-hash-table)))))
341 (defsubst context-coloring-js2-local-name-node-p (node)
342 "Determine if NODE represents a local variable."
343 (and (js2-name-node-p node)
344 (let ((parent (js2-node-parent node)))
345 (not (or (and (js2-object-prop-node-p parent)
346 (eq node (js2-object-prop-node-left parent)))
347 (and (js2-prop-get-node-p parent)
348 ;; For nested property lookup, the node on the left is a
349 ;; `js2-prop-get-node', so this always works.
350 (eq node (js2-prop-get-node-right parent))))))))
352 (defvar-local context-coloring-point-max nil
353 "Cached value of `point-max'.")
355 (defsubst context-coloring-js2-colorize-node (node level)
356 "Color NODE with the color for LEVEL."
357 (let ((start (js2-node-abs-pos node)))
358 (context-coloring-colorize-region
362 (+ start (js2-node-len node))
363 ;; Somes nodes (like the ast when there is an unterminated multiline
364 ;; comment) will stretch to the value of `point-max'.
365 context-coloring-point-max)
368 (defun context-coloring-js2-colorize-ast ()
369 "Color the buffer using the `js2-mode' abstract syntax tree."
370 ;; Reset the hash table; the old one could be obsolete.
371 (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
372 (setq context-coloring-point-max (point-max))
373 (with-silent-modifications
380 (context-coloring-js2-colorize-node
382 (context-coloring-js2-scope-level node context-coloring-initial-level)))
383 ((context-coloring-js2-local-name-node-p node)
384 (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
385 (defining-scope (js2-get-defining-scope
387 (js2-name-node-name node))))
388 ;; The tree seems to be walked lexically, so an entire scope will
389 ;; be colored, including its name nodes, before they are reached.
390 ;; Coloring the nodes defined in that scope would be redundant, so
392 (when (not (eq defining-scope enclosing-scope))
393 (context-coloring-js2-colorize-node
395 ;; Use `0' as an initial level so global variables are always at
396 ;; the highest level (even if `context-coloring-initial-level'
397 ;; specifies an initial level for the rest of the code).
398 (context-coloring-js2-scope-level defining-scope 0))))))
399 ;; The `t' indicates to search children.
401 (context-coloring-colorize-comments-and-strings)))
403 (defconst context-coloring-node-comment-regexp
405 ;; Ensure the "//" or "/*" comment starts with the directive.
406 "\\(//[[:space:]]*\\|/\\*[[:space:]]*\\)"
407 ;; Support multiple directive formats.
409 ;; JSLint and JSHint support a JSON-like format.
410 "\\(jslint\\|jshint\\)[[:space:]].*?node:[[:space:]]*true"
412 ;; ESLint just specifies the option name.
413 "eslint-env[[:space:]].*?node"
415 "Match a comment body hinting at a Node.js program.")
417 ;; TODO: Add ES6 module detection.
418 (defun context-coloring-js2-top-level-local-p ()
419 "Guess whether top-level variables are local.
420 For instance, the current file could be a Node.js program."
422 ;; A shebang is a pretty obvious giveaway.
426 (goto-char (point-min))
427 (when (looking-at auto-mode-interpreter-regexp)
429 ;; Otherwise, perform static analysis.
431 (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
432 (catch 'node-program-p
439 ;; Infer based on inline linter configuration.
440 ((js2-comment-node-p node)
442 context-coloring-node-comment-regexp
443 (js2-node-string node)))
444 ;; Infer based on the prescence of certain variables.
445 ((and (js2-name-node-p node)
446 (let ((parent (js2-node-parent node)))
447 (not (and (js2-object-prop-node-p parent)
448 (eq node (js2-object-prop-node-left parent))))))
449 (let ((name (js2-name-node-name node))
450 (parent (js2-node-parent node)))
453 ;; Check whether this is "exports.something" or
455 ((js2-prop-get-node-p parent)
457 (eq node (js2-prop-get-node-left parent))
458 (or (string-equal name "exports")
459 (let* ((property (js2-prop-get-node-right parent))
460 (property-name (js2-name-node-name property)))
461 (and (string-equal name "module")
462 (string-equal property-name "exports"))))))
463 ;; Check whether it's a "require('module')" call.
464 ((js2-call-node-p parent)
465 (or (string-equal name "require"))))
466 (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
467 (defining-scope (js2-get-defining-scope
468 enclosing-scope name)))
469 ;; The variable also must be global.
470 (null defining-scope))))))
471 (throw 'node-program-p t))
472 ;; The `t' indicates to search children.
474 ;; Default to returning nil from the catch body.
477 (defcustom context-coloring-javascript-detect-top-level-scope t
478 "If non-nil, detect when to use file-level scope."
480 :group 'context-coloring)
482 (defun context-coloring-js2-colorize ()
483 "Color the buffer using the `js2-mode'."
485 ;; Increase the initial level if we should.
486 ((and context-coloring-javascript-detect-top-level-scope
487 (context-coloring-js2-top-level-local-p))
488 (let ((context-coloring-initial-level 1))
489 (context-coloring-js2-colorize-ast)))
491 (context-coloring-js2-colorize-ast))))
494 ;;; Emacs Lisp colorization
496 (defsubst context-coloring-forward-sws ()
497 "Move forward through whitespace and comments."
498 (while (forward-comment 1)))
500 (defsubst context-coloring-elisp-forward-sws ()
501 "Move through whitespace and comments, coloring comments."
502 (let ((start (point)))
503 (context-coloring-forward-sws)
504 (context-coloring-colorize-comments-and-strings start (point))))
506 (defsubst context-coloring-elisp-forward-sexp ()
507 "Skip/ignore missing sexps, coloring comments and strings."
508 (let ((start (point)))
511 (scan-error (context-coloring-forward-sws)))
512 (context-coloring-elisp-colorize-comments-and-strings-in-region
515 (defsubst context-coloring-get-syntax-code ()
516 "Get the syntax code at point."
518 ;; Faster version of `syntax-after':
519 (aref (syntax-table) (char-after (point)))))
521 (defsubst context-coloring-exact-regexp (word)
522 "Create a regexp matching exactly WORD."
523 (concat "\\`" (regexp-quote word) "\\'"))
525 (defsubst context-coloring-exact-or-regexp (words)
526 "Create a regexp matching any exact word in WORDS."
527 (context-coloring-join
528 (mapcar #'context-coloring-exact-regexp words) "\\|"))
530 (defconst context-coloring-elisp-ignored-word-regexp
531 (context-coloring-join (list "\\`[-+]?[0-9]"
533 (context-coloring-exact-or-regexp
534 '("t" "nil" "." "?")))
536 "Match symbols that can't be bound as variables.")
538 (defconst context-coloring-WORD-CODE 2)
539 (defconst context-coloring-SYMBOL-CODE 3)
540 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
541 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
542 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
543 (defconst context-coloring-STRING-QUOTE-CODE 7)
544 (defconst context-coloring-ESCAPE-CODE 9)
545 (defconst context-coloring-COMMENT-START-CODE 11)
546 (defconst context-coloring-COMMENT-END-CODE 12)
548 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
549 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
550 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
551 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
552 (defconst context-coloring-AT-CHAR (string-to-char "@"))
553 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
555 (defsubst context-coloring-elisp-identifier-p (syntax-code)
556 "Check if SYNTAX-CODE is an elisp identifier constituent."
557 (or (= syntax-code context-coloring-WORD-CODE)
558 (= syntax-code context-coloring-SYMBOL-CODE)))
560 (defvar context-coloring-parse-interruptable-p t
561 "Set this to nil to force parse to continue until finished.")
563 (defconst context-coloring-elisp-sexps-per-pause 350
564 "Pause after this many iterations to check for user input.
565 If user input is pending, stop the parse. This makes for a
566 smoother user experience for large files.
568 This number should trigger pausing at about 60 frames per
571 (defvar context-coloring-elisp-sexp-count 0
572 "Current number of sexps leading up to the next pause.")
574 (defsubst context-coloring-elisp-increment-sexp-count ()
575 "Maybe check if the user interrupted the current parse."
576 (setq context-coloring-elisp-sexp-count
577 (1+ context-coloring-elisp-sexp-count))
578 (when (and (zerop (% context-coloring-elisp-sexp-count
579 context-coloring-elisp-sexps-per-pause))
580 context-coloring-parse-interruptable-p
582 (throw 'interrupted t)))
584 (defvar context-coloring-elisp-scope-stack '()
585 "List of scopes in the current parse.")
587 (defsubst context-coloring-elisp-make-scope (level)
588 "Make a scope object for LEVEL."
593 (defsubst context-coloring-elisp-scope-get-level (scope)
594 "Get the level of SCOPE object."
595 (plist-get scope :level))
597 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
598 "Add to SCOPE a VARIABLE."
599 (plist-put scope :variables (cons variable (plist-get scope :variables))))
601 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
602 "Check if SCOPE has VARIABLE."
603 (member variable (plist-get scope :variables)))
605 (defsubst context-coloring-elisp-get-variable-level (variable)
606 "Return the level of VARIABLE, or 0 if it isn't found."
607 (let* ((scope-stack context-coloring-elisp-scope-stack)
610 (while (and scope-stack (not level))
611 (setq scope (car scope-stack))
613 ((context-coloring-elisp-scope-has-variable scope variable)
614 (setq level (context-coloring-elisp-scope-get-level scope)))
616 (setq scope-stack (cdr scope-stack)))))
617 ;; Assume a global variable.
620 (defsubst context-coloring-elisp-get-current-scope-level ()
621 "Get the nesting level of the current scope."
623 ((car context-coloring-elisp-scope-stack)
624 (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
628 (defsubst context-coloring-elisp-push-scope ()
629 "Add a new scope to the bottom of the scope chain."
630 (push (context-coloring-elisp-make-scope
631 (1+ (context-coloring-elisp-get-current-scope-level)))
632 context-coloring-elisp-scope-stack))
634 (defsubst context-coloring-elisp-pop-scope ()
635 "Remove the scope on the bottom of the scope chain."
636 (pop context-coloring-elisp-scope-stack))
638 (defsubst context-coloring-elisp-add-variable (variable)
639 "Add VARIABLE to the current scope."
640 (context-coloring-elisp-scope-add-variable
641 (car context-coloring-elisp-scope-stack)
644 (defsubst context-coloring-elisp-parse-bindable (callback)
645 "Parse the symbol at point.
646 If the symbol can be bound, invoke CALLBACK with it."
647 (let* ((arg-string (buffer-substring-no-properties
649 (progn (context-coloring-elisp-forward-sexp)
651 (when (not (string-match-p
652 context-coloring-elisp-ignored-word-regexp
654 (funcall callback arg-string))))
656 (defun context-coloring-elisp-parse-let-varlist (type)
657 "Parse the list of variable initializers at point.
658 If TYPE is `let', all the variables are bound after all their
659 initializers are parsed; if TYPE is `let*', each variable is
660 bound immediately after its own initializer is parsed."
665 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
666 context-coloring-CLOSE-PARENTHESIS-CODE)
668 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
670 (context-coloring-elisp-forward-sws)
671 (setq syntax-code (context-coloring-get-syntax-code))
672 (when (context-coloring-elisp-identifier-p syntax-code)
673 (context-coloring-elisp-parse-bindable
676 (context-coloring-elisp-forward-sws)
677 (setq syntax-code (context-coloring-get-syntax-code))
678 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
679 (context-coloring-elisp-colorize-sexp)))
680 (context-coloring-elisp-forward-sws)
681 ;; Skip past the closing parenthesis.
683 ((context-coloring-elisp-identifier-p syntax-code)
684 (context-coloring-elisp-parse-bindable
686 (push var varlist))))
689 (context-coloring-elisp-forward-sexp)))
690 (when (eq type 'let*)
691 (context-coloring-elisp-add-variable (pop varlist)))
692 (context-coloring-elisp-forward-sws))
695 (context-coloring-elisp-add-variable (pop varlist))))
699 (defun context-coloring-elisp-parse-arglist ()
700 "Parse the list of function arguments at point."
704 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
705 context-coloring-CLOSE-PARENTHESIS-CODE)
707 ((context-coloring-elisp-identifier-p syntax-code)
708 (context-coloring-elisp-parse-bindable
710 (context-coloring-elisp-add-variable arg))))
713 (context-coloring-elisp-forward-sexp)))
714 (context-coloring-elisp-forward-sws))
718 (defun context-coloring-elisp-skip-callee-name ()
719 "Skip past the opening parenthesis and name of a function."
722 (context-coloring-elisp-forward-sws)
723 ;; Skip past the function name.
725 (context-coloring-elisp-forward-sws))
727 (defun context-coloring-elisp-colorize-scope (callback)
728 "Color the whole scope at point with its one color.
729 Handle a header in CALLBACK."
730 (let ((start (point))
731 (end (progn (forward-sexp)
733 (context-coloring-elisp-push-scope)
734 ;; Splash the whole thing in one color.
735 (context-coloring-colorize-region
738 (context-coloring-elisp-get-current-scope-level))
739 ;; Even if the parse is interrupted, this region should still be colored
741 (context-coloring-elisp-colorize-comments-and-strings-in-region
745 (context-coloring-elisp-skip-callee-name)
747 (context-coloring-elisp-colorize-region (point) (1- end))
750 (context-coloring-elisp-pop-scope)))
752 (defun context-coloring-elisp-parse-header (callback)
753 "Parse a function header at point with CALLBACK."
754 (when (= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
757 (defun context-coloring-elisp-colorize-defun-like (callback)
758 "Color the defun-like function at point.
759 Parse the header with CALLBACK."
760 (context-coloring-elisp-colorize-scope
762 (when (context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
763 ;; Color the defun's name with the top-level color.
764 (context-coloring-colorize-region
766 (progn (forward-sexp)
769 (context-coloring-elisp-forward-sws)
770 (context-coloring-elisp-parse-header callback)))))
772 (defun context-coloring-elisp-colorize-defun ()
773 "Color the `defun' at point."
774 (context-coloring-elisp-colorize-defun-like
775 'context-coloring-elisp-parse-arglist))
777 (defun context-coloring-elisp-colorize-defadvice ()
778 "Color the `defadvice' at point."
779 (context-coloring-elisp-colorize-defun-like
784 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
785 context-coloring-CLOSE-PARENTHESIS-CODE)
787 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
788 (context-coloring-elisp-parse-arglist))
791 (context-coloring-elisp-forward-sexp)))
792 (context-coloring-elisp-forward-sws))))))
794 (defun context-coloring-elisp-colorize-lambda-like (callback)
795 "Color the lambda-like function at point.
796 Parsing the header with CALLBACK."
797 (context-coloring-elisp-colorize-scope
799 (context-coloring-elisp-parse-header callback))))
801 (defun context-coloring-elisp-colorize-lambda ()
802 "Color the `lambda' at point."
803 (context-coloring-elisp-colorize-lambda-like
804 'context-coloring-elisp-parse-arglist))
806 (defun context-coloring-elisp-colorize-let ()
807 "Color the `let' at point."
808 (context-coloring-elisp-colorize-lambda-like
810 (context-coloring-elisp-parse-let-varlist 'let))))
812 (defun context-coloring-elisp-colorize-let* ()
813 "Color the `let*' at point."
814 (context-coloring-elisp-colorize-lambda-like
816 (context-coloring-elisp-parse-let-varlist 'let*))))
818 (defun context-coloring-elisp-colorize-cond ()
819 "Color the `cond' at point."
821 (context-coloring-elisp-skip-callee-name)
822 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
823 context-coloring-CLOSE-PARENTHESIS-CODE)
825 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
826 ;; Colorize inside the parens.
827 (let ((start (point)))
829 (context-coloring-elisp-colorize-region
830 (1+ start) (1- (point)))
835 (context-coloring-elisp-forward-sexp)))
836 (context-coloring-elisp-forward-sws))
840 (defun context-coloring-elisp-colorize-condition-case ()
841 "Color the `condition-case' at point."
846 (context-coloring-elisp-colorize-scope
848 (setq syntax-code (context-coloring-get-syntax-code))
849 ;; Gracefully ignore missing variables.
850 (when (context-coloring-elisp-identifier-p syntax-code)
851 (context-coloring-elisp-parse-bindable
852 (lambda (parsed-variable)
853 (setq variable parsed-variable)))
854 (context-coloring-elisp-forward-sws))
855 (context-coloring-elisp-colorize-sexp)
856 (context-coloring-elisp-forward-sws)
857 ;; Parse the handlers with the error variable in scope.
859 (context-coloring-elisp-add-variable variable))
860 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
861 context-coloring-CLOSE-PARENTHESIS-CODE)
863 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
864 (setq case-pos (point))
865 (context-coloring-elisp-forward-sexp)
866 (setq case-end (point))
870 (context-coloring-elisp-forward-sws)
871 (setq syntax-code (context-coloring-get-syntax-code))
872 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
873 ;; Skip the condition name(s).
874 (context-coloring-elisp-forward-sexp)
875 ;; Color the remaining portion of the handler.
876 (context-coloring-elisp-colorize-region
883 (context-coloring-elisp-forward-sexp)))
884 (context-coloring-elisp-forward-sws))))))
886 (defun context-coloring-elisp-colorize-dolist ()
887 "Color the `dolist' at point."
890 (context-coloring-elisp-colorize-scope
892 (setq syntax-code (context-coloring-get-syntax-code))
893 (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
895 (context-coloring-elisp-forward-sws)
896 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
897 context-coloring-CLOSE-PARENTHESIS-CODE)
900 (or (= index 0) (= index 2))
901 (context-coloring-elisp-identifier-p syntax-code))
902 ;; Add the first or third name to the scope.
903 (context-coloring-elisp-parse-bindable
905 (context-coloring-elisp-add-variable variable))))
908 (context-coloring-elisp-colorize-sexp)))
909 (context-coloring-elisp-forward-sws)
910 (setq index (1+ index)))
914 (defun context-coloring-elisp-colorize-quote ()
915 "Color the `quote' at point."
916 (let* ((start (point))
917 (end (progn (forward-sexp)
919 (context-coloring-colorize-region
922 (context-coloring-elisp-get-current-scope-level))
923 (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
925 (defvar context-coloring-elisp-callee-dispatch-hash-table
926 (let ((table (make-hash-table :test 'equal)))
927 (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
928 (puthash callee #'context-coloring-elisp-colorize-defun table))
929 (dolist (callee '("condition-case" "condition-case-unless-debug"))
930 (puthash callee #'context-coloring-elisp-colorize-condition-case table))
931 (dolist (callee '("dolist" "dotimes"))
932 (puthash callee #'context-coloring-elisp-colorize-dolist table))
933 (puthash "let" #'context-coloring-elisp-colorize-let table)
934 (puthash "let*" #'context-coloring-elisp-colorize-let* table)
935 (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
936 (puthash "cond" #'context-coloring-elisp-colorize-cond table)
937 (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
938 (puthash "quote" #'context-coloring-elisp-colorize-quote table)
939 (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
941 "Map function names to their coloring functions.")
943 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
944 "Color the sexp enclosed by parenthesis at point."
945 (context-coloring-elisp-increment-sexp-count)
946 (let* ((start (point))
947 (end (progn (forward-sexp)
949 (syntax-code (progn (goto-char start)
951 ;; Coloring is unnecessary here, it'll happen
953 (context-coloring-forward-sws)
954 (context-coloring-get-syntax-code)))
956 ;; Figure out if the sexp is a special form.
958 ((and (context-coloring-elisp-identifier-p syntax-code)
959 (setq dispatch-function (gethash
960 (buffer-substring-no-properties
962 (progn (forward-sexp)
964 context-coloring-elisp-callee-dispatch-hash-table)))
966 (funcall dispatch-function))
967 ;; Not a special form; just colorize the remaining region.
969 (context-coloring-colorize-region
972 (context-coloring-elisp-get-current-scope-level))
973 (context-coloring-elisp-colorize-region (point) (1- end))
976 (defun context-coloring-elisp-colorize-symbol ()
977 "Color the symbol at point."
978 (context-coloring-elisp-increment-sexp-count)
979 (let* ((symbol-pos (point))
980 (symbol-end (progn (forward-sexp)
982 (symbol-string (buffer-substring-no-properties
986 ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
988 (context-coloring-colorize-region
991 (context-coloring-elisp-get-variable-level
994 (defun context-coloring-elisp-colorize-backquote-form ()
995 "Color the backquote form at point."
996 (let ((start (point))
997 (end (progn (forward-sexp)
1001 (while (> end (progn (forward-char)
1003 (setq char (char-after))
1004 (when (= char context-coloring-COMMA-CHAR)
1006 (when (= (char-after) context-coloring-AT-CHAR)
1007 ;; If we don't do this "@" could be interpreted as a symbol.
1009 (context-coloring-elisp-forward-sws)
1010 (context-coloring-elisp-colorize-sexp)))
1011 ;; We could probably do this as part of the above loop but it'd be
1013 (context-coloring-elisp-colorize-comments-and-strings-in-region
1016 (defun context-coloring-elisp-colorize-backquote ()
1017 "Color the `backquote' at point."
1018 (context-coloring-elisp-skip-callee-name)
1019 (context-coloring-elisp-colorize-backquote-form)
1023 (defun context-coloring-elisp-colorize-expression-prefix ()
1024 "Color the expression prefix and expression at point.
1025 It could be a quoted or backquoted expression."
1026 (context-coloring-elisp-increment-sexp-count)
1028 ((/= (char-after) context-coloring-BACKTICK-CHAR)
1029 (context-coloring-elisp-forward-sexp))
1031 (context-coloring-elisp-colorize-backquote-form))))
1033 (defun context-coloring-elisp-colorize-comment ()
1034 "Color the comment at point."
1035 (context-coloring-elisp-increment-sexp-count)
1036 (context-coloring-elisp-forward-sws))
1038 (defun context-coloring-elisp-colorize-string ()
1039 "Color the string at point."
1040 (context-coloring-elisp-increment-sexp-count)
1041 (let ((start (point)))
1043 (context-coloring-colorize-comments-and-strings start (point))))
1045 ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
1046 ;; prefix, string quote, comment starters/enders and escape syntax classes only.
1048 (defun context-coloring-elisp-colorize-sexp ()
1049 "Color the sexp at point."
1050 (let ((syntax-code (context-coloring-get-syntax-code)))
1052 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1053 (context-coloring-elisp-colorize-parenthesized-sexp))
1054 ((context-coloring-elisp-identifier-p syntax-code)
1055 (context-coloring-elisp-colorize-symbol))
1056 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1057 (context-coloring-elisp-colorize-expression-prefix))
1058 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1059 (context-coloring-elisp-colorize-string))
1060 ((= syntax-code context-coloring-ESCAPE-CODE)
1061 (forward-char 2)))))
1063 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
1064 "Color comments and strings between START and END."
1067 (while (> end (progn (skip-syntax-forward "^\"<\\" end)
1069 (setq syntax-code (context-coloring-get-syntax-code))
1071 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1072 (context-coloring-elisp-colorize-string))
1073 ((= syntax-code context-coloring-COMMENT-START-CODE)
1074 (context-coloring-elisp-colorize-comment))
1075 ((= syntax-code context-coloring-ESCAPE-CODE)
1076 (forward-char 2))))))
1078 (defun context-coloring-elisp-colorize-region (start end)
1079 "Color everything between START and END."
1082 (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
1084 (setq syntax-code (context-coloring-get-syntax-code))
1086 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1087 (context-coloring-elisp-colorize-parenthesized-sexp))
1088 ((context-coloring-elisp-identifier-p syntax-code)
1089 (context-coloring-elisp-colorize-symbol))
1090 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1091 (context-coloring-elisp-colorize-expression-prefix))
1092 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1093 (context-coloring-elisp-colorize-string))
1094 ((= syntax-code context-coloring-COMMENT-START-CODE)
1095 (context-coloring-elisp-colorize-comment))
1096 ((= syntax-code context-coloring-ESCAPE-CODE)
1097 (forward-char 2))))))
1099 (defun context-coloring-elisp-colorize-region-initially (start end)
1100 "Begin coloring everything between START and END."
1101 (setq context-coloring-elisp-sexp-count 0)
1102 (setq context-coloring-elisp-scope-stack '())
1103 (let ((inhibit-point-motion-hooks t)
1104 (case-fold-search nil)
1105 ;; This is a recursive-descent parser, so give it a big stack.
1106 (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
1107 (max-specpdl-size (max max-specpdl-size 3000)))
1108 (context-coloring-elisp-colorize-region start end)))
1110 (defun context-coloring-elisp-colorize-guard (callback)
1111 "Silently color in CALLBACK."
1112 (with-silent-modifications
1116 ;; Scan errors can happen virtually anywhere if parenthesis are
1117 ;; unbalanced. Just swallow them. (`progn' for test coverage.)
1118 (scan-error (progn))))))
1120 (defun context-coloring-elisp-colorize ()
1121 "Color the current Emacs Lisp buffer."
1123 (context-coloring-elisp-colorize-guard
1126 ;; Just colorize the changed region.
1127 (context-coloring-changed-p
1128 (let* ( ;; Prevent `beginning-of-defun' from making poor assumptions.
1129 (open-paren-in-column-0-is-defun-start nil)
1130 ;; Seek the beginning and end of the previous and next
1131 ;; offscreen defuns, so just enough is colored.
1132 (start (progn (goto-char context-coloring-changed-start)
1133 (while (and (< (point-min) (point))
1134 (pos-visible-in-window-p))
1136 (beginning-of-defun)
1138 (end (progn (goto-char context-coloring-changed-end)
1139 (while (and (> (point-max) (point))
1140 (pos-visible-in-window-p))
1144 (context-coloring-elisp-colorize-region-initially start end)
1145 ;; Fast coloring is nice, but if the code is not well-formed
1146 ;; (e.g. an unclosed string literal is parsed at any time) then
1147 ;; there could be leftover incorrectly-colored code offscreen. So
1148 ;; do a clean sweep as soon as appropriate.
1149 (context-coloring-schedule-coloring context-coloring-default-delay)))
1151 (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
1154 ;;; eval-expression colorization
1156 (defun context-coloring-eval-expression-match ()
1157 "Determine expression start in `eval-expression'."
1158 (string-match "\\`Eval: " (buffer-string)))
1160 (defun context-coloring-eval-expression-colorize ()
1161 "Color the `eval-expression' minibuffer prompt as elisp."
1163 (context-coloring-elisp-colorize-guard
1165 (context-coloring-elisp-colorize-region-initially
1167 (context-coloring-eval-expression-match)
1174 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
1175 "Map dispatch strategy names to their property lists.")
1177 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
1178 "Map major mode names to dispatch property lists.")
1180 (defvar context-coloring-dispatch-predicates '()
1181 "Functions which may return a dispatch.")
1183 (defun context-coloring-get-current-dispatch ()
1184 "Return the first dispatch appropriate for the current state."
1185 (let ((predicates context-coloring-dispatch-predicates)
1188 ;; Maybe a predicate will be satisfied and return a dispatch.
1189 (while (and predicates
1190 (not (setq dispatch (funcall (pop predicates))))))
1191 ;; If not, maybe a major mode (or a derivative) will define a dispatch.
1192 (when (not dispatch)
1194 (not (setq dispatch (gethash parent context-coloring-mode-hash-table)))
1195 (setq parent (get parent 'derived-mode-parent)))))
1198 (defun context-coloring-define-dispatch (symbol &rest properties)
1199 "Define a new dispatch named SYMBOL with PROPERTIES.
1201 A \"dispatch\" is a property list describing a strategy for
1204 PROPERTIES must include one of `:modes' or `:predicate', and a
1207 `:modes' - List of major modes this dispatch is valid for.
1209 `:predicate' - Function that determines if the dispatch is valid
1210 for any given state.
1212 `:colorizer' - Function that parses and colors the buffer.
1214 `:delay' - Delay between buffer update and colorization, to
1215 override `context-coloring-default-delay'.
1217 `:setup' - Arbitrary code to set up this dispatch when
1218 `context-coloring-mode' is enabled.
1220 `:teardown' - Arbitrary code to tear down this dispatch when
1221 `context-coloring-mode' is disabled."
1222 (let ((modes (plist-get properties :modes))
1223 (predicate (plist-get properties :predicate))
1224 (colorizer (plist-get properties :colorizer)))
1225 (when (null (or modes predicate))
1226 (error "No mode or predicate defined for dispatch"))
1227 (when (not colorizer)
1228 (error "No colorizer defined for dispatch"))
1229 (puthash symbol properties context-coloring-dispatch-hash-table)
1230 (dolist (mode modes)
1231 (puthash mode properties context-coloring-mode-hash-table))
1234 (when (funcall predicate)
1235 properties)) context-coloring-dispatch-predicates))))
1237 (defun context-coloring-dispatch ()
1238 "Determine how to color the current buffer, and color it."
1239 (let* ((dispatch (context-coloring-get-current-dispatch))
1240 (colorizer (plist-get dispatch :colorizer)))
1242 (funcall colorizer))))
1247 (defun context-coloring-colorize ()
1248 "Color the current buffer by function context."
1250 (context-coloring-update-maximum-face)
1251 (context-coloring-dispatch))
1253 (defun context-coloring-colorize-with-buffer (buffer)
1255 ;; Don't select deleted buffers.
1256 (when (get-buffer buffer)
1257 (with-current-buffer buffer
1258 (context-coloring-colorize))))
1261 ;;; Built-in dispatches
1263 (context-coloring-define-dispatch
1266 :colorizer #'context-coloring-js2-colorize
1269 (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
1272 (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
1274 (context-coloring-define-dispatch
1276 :modes '(emacs-lisp-mode)
1277 :colorizer #'context-coloring-elisp-colorize
1278 :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
1279 :setup #'context-coloring-setup-idle-change-detection
1280 :teardown #'context-coloring-teardown-idle-change-detection)
1282 ;; `eval-expression-minibuffer-setup-hook' is not available in Emacs 24.3, so
1283 ;; the backwards-compatible recommendation is to use `minibuffer-setup-hook' and
1284 ;; rely on this predicate instead.
1285 (defun context-coloring-eval-expression-predicate ()
1286 "Non-nil if the minibuffer is for `eval-expression'."
1287 ;; Kinda better than checking `this-command', because `this-command' changes.
1288 (context-coloring-eval-expression-match))
1290 (context-coloring-define-dispatch
1292 :predicate #'context-coloring-eval-expression-predicate
1293 :colorizer #'context-coloring-eval-expression-colorize
1295 :setup #'context-coloring-setup-idle-change-detection
1296 :teardown #'context-coloring-teardown-idle-change-detection)
1298 (defvar context-coloring-ignore-unavailable-predicates
1301 "Cases when \"unavailable\" messages are silenced.
1302 Necessary in editing states where coloring is only sometimes
1305 (defun context-coloring-ignore-unavailable-message-p ()
1306 "Determine if the unavailable message should be silenced."
1307 (let ((predicates context-coloring-ignore-unavailable-predicates)
1309 (while (and predicates
1311 (setq ignore-p (funcall (pop predicates))))
1318 (define-minor-mode context-coloring-mode
1319 "Toggle contextual code coloring.
1320 With a prefix argument ARG, enable Context Coloring mode if ARG
1321 is positive, and disable it otherwise. If called from Lisp,
1322 enable the mode if ARG is omitted or nil.
1324 Context Coloring mode is a buffer-local minor mode. When
1325 enabled, code is colored by scope. Scopes are colored
1326 hierarchically. Variables referenced from nested scopes retain
1327 the color of their defining scopes. Certain syntax, like
1328 comments and strings, is still colored with `font-lock'.
1330 The entire buffer is colored initially. Changes to the buffer
1333 Define your own colors by customizing faces like
1334 `context-coloring-level-N-face', where N is a number starting
1335 from 0. If no face is found on a custom theme nor the `user'
1336 theme, the defaults are used.
1338 New language / major mode support can be added with
1339 `context-coloring-define-dispatch', which see.
1341 Feature inspired by Douglas Crockford."
1344 (context-coloring-mode
1345 ;; Font lock is incompatible with this mode; the converse is also true.
1348 ;; ...but we do use font-lock functions here.
1349 (font-lock-set-defaults)
1350 ;; Safely change the value of this function as necessary.
1351 (make-local-variable 'font-lock-syntactic-face-function)
1352 (let ((dispatch (context-coloring-get-current-dispatch)))
1355 (let ((setup (plist-get dispatch :setup)))
1358 ;; Colorize once initially.
1359 (let ((context-coloring-parse-interruptable-p nil))
1360 (context-coloring-colorize))))
1361 ((not (context-coloring-ignore-unavailable-message-p))
1362 (message "Context coloring is unavailable here")))))
1364 (let ((dispatch (context-coloring-get-current-dispatch)))
1366 (let ((teardown (plist-get dispatch :teardown)))
1368 (funcall teardown)))))
1370 (jit-lock-mode t))))
1372 (provide 'context-coloring)
1374 ;;; context-coloring.el ends here