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 (defconst context-coloring-WORD-CODE 2)
497 (defconst context-coloring-SYMBOL-CODE 3)
498 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
499 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
500 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
501 (defconst context-coloring-STRING-QUOTE-CODE 7)
502 (defconst context-coloring-ESCAPE-CODE 9)
503 (defconst context-coloring-COMMENT-START-CODE 11)
504 (defconst context-coloring-COMMENT-END-CODE 12)
506 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
507 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
508 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
509 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
510 (defconst context-coloring-AT-CHAR (string-to-char "@"))
511 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
513 (defsubst context-coloring-get-syntax-code ()
514 "Get the syntax code at point."
516 ;; Faster version of `syntax-after':
517 (aref (syntax-table) (char-after (point)))))
519 (defsubst context-coloring-forward-sws ()
520 "Move forward through whitespace and comments."
521 (while (forward-comment 1)))
523 (defsubst context-coloring-elisp-forward-sws ()
524 "Move through whitespace and comments, coloring comments."
525 (let ((start (point)))
526 (context-coloring-forward-sws)
527 (context-coloring-colorize-comments-and-strings start (point))))
529 (defsubst context-coloring-elisp-forward-sexp ()
530 "Skip/ignore missing sexps, coloring comments and strings."
531 (let ((start (point)))
532 (when (= (context-coloring-get-syntax-code)
533 context-coloring-EXPRESSION-PREFIX-CODE)
534 ;; `forward-sexp' does not skip an unfinished expression (e.g. when the
535 ;; name of a symbol or the parentheses of a list do not follow a single
540 (scan-error (context-coloring-forward-sws)))
541 (context-coloring-elisp-colorize-comments-and-strings-in-region
544 (defsubst context-coloring-exact-regexp (word)
545 "Create a regexp matching exactly WORD."
546 (concat "\\`" (regexp-quote word) "\\'"))
548 (defsubst context-coloring-exact-or-regexp (words)
549 "Create a regexp matching any exact word in WORDS."
550 (context-coloring-join
551 (mapcar #'context-coloring-exact-regexp words) "\\|"))
553 (defconst context-coloring-elisp-ignored-word-regexp
554 (context-coloring-join (list "\\`[-+]?[0-9]"
556 (context-coloring-exact-or-regexp
557 '("t" "nil" "." "?")))
559 "Match symbols that can't be bound as variables.")
561 (defsubst context-coloring-elisp-identifier-p (syntax-code)
562 "Check if SYNTAX-CODE is an elisp identifier constituent."
563 (or (= syntax-code context-coloring-WORD-CODE)
564 (= syntax-code context-coloring-SYMBOL-CODE)))
566 (defvar context-coloring-parse-interruptable-p t
567 "Set this to nil to force parse to continue until finished.")
569 (defconst context-coloring-elisp-sexps-per-pause 350
570 "Pause after this many iterations to check for user input.
571 If user input is pending, stop the parse. This makes for a
572 smoother user experience for large files.
574 This number should trigger pausing at about 60 frames per
577 (defvar context-coloring-elisp-sexp-count 0
578 "Current number of sexps leading up to the next pause.")
580 (defsubst context-coloring-elisp-increment-sexp-count ()
581 "Maybe check if the user interrupted the current parse."
582 (setq context-coloring-elisp-sexp-count
583 (1+ context-coloring-elisp-sexp-count))
584 (when (and (zerop (% context-coloring-elisp-sexp-count
585 context-coloring-elisp-sexps-per-pause))
586 context-coloring-parse-interruptable-p
588 (throw 'interrupted t)))
590 (defvar context-coloring-elisp-scope-stack '()
591 "List of scopes in the current parse.")
593 (defsubst context-coloring-elisp-make-scope (level)
594 "Make a scope object for LEVEL."
599 (defsubst context-coloring-elisp-scope-get-level (scope)
600 "Get the level of SCOPE object."
601 (plist-get scope :level))
603 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
604 "Add to SCOPE a VARIABLE."
605 (plist-put scope :variables (cons variable (plist-get scope :variables))))
607 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
608 "Check if SCOPE has VARIABLE."
609 (member variable (plist-get scope :variables)))
611 (defsubst context-coloring-elisp-get-variable-level (variable)
612 "Return the level of VARIABLE, or 0 if it isn't found."
613 (let* ((scope-stack context-coloring-elisp-scope-stack)
616 (while (and scope-stack (not level))
617 (setq scope (car scope-stack))
619 ((context-coloring-elisp-scope-has-variable scope variable)
620 (setq level (context-coloring-elisp-scope-get-level scope)))
622 (setq scope-stack (cdr scope-stack)))))
623 ;; Assume a global variable.
626 (defsubst context-coloring-elisp-get-current-scope-level ()
627 "Get the nesting level of the current scope."
629 ((car context-coloring-elisp-scope-stack)
630 (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
634 (defsubst context-coloring-elisp-push-scope ()
635 "Add a new scope to the bottom of the scope chain."
636 (push (context-coloring-elisp-make-scope
637 (1+ (context-coloring-elisp-get-current-scope-level)))
638 context-coloring-elisp-scope-stack))
640 (defsubst context-coloring-elisp-pop-scope ()
641 "Remove the scope on the bottom of the scope chain."
642 (pop context-coloring-elisp-scope-stack))
644 (defsubst context-coloring-elisp-add-variable (variable)
645 "Add VARIABLE to the current scope."
646 (context-coloring-elisp-scope-add-variable
647 (car context-coloring-elisp-scope-stack)
650 (defsubst context-coloring-elisp-parse-bindable (callback)
651 "Parse the symbol at point.
652 If the symbol can be bound, invoke CALLBACK with it."
653 (let* ((arg-string (buffer-substring-no-properties
655 (progn (context-coloring-elisp-forward-sexp)
657 (when (not (string-match-p
658 context-coloring-elisp-ignored-word-regexp
660 (funcall callback arg-string))))
662 (defun context-coloring-elisp-parse-let-varlist (type)
663 "Parse the list of variable initializers at point.
664 If TYPE is `let', all the variables are bound after all their
665 initializers are parsed; if TYPE is `let*', each variable is
666 bound immediately after its own initializer is parsed."
671 (context-coloring-elisp-forward-sws)
672 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
673 context-coloring-CLOSE-PARENTHESIS-CODE)
675 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
677 (context-coloring-elisp-forward-sws)
678 (setq syntax-code (context-coloring-get-syntax-code))
679 (when (context-coloring-elisp-identifier-p syntax-code)
680 (context-coloring-elisp-parse-bindable
683 (context-coloring-elisp-forward-sws)
684 (setq syntax-code (context-coloring-get-syntax-code))
685 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
686 (context-coloring-elisp-colorize-sexp)))
687 (context-coloring-elisp-forward-sws)
688 ;; Skip past the closing parenthesis.
690 ((context-coloring-elisp-identifier-p syntax-code)
691 (context-coloring-elisp-parse-bindable
693 (push var varlist))))
696 (context-coloring-elisp-forward-sexp)))
697 (when (eq type 'let*)
698 (context-coloring-elisp-add-variable (pop varlist)))
699 (context-coloring-elisp-forward-sws))
702 (context-coloring-elisp-add-variable (pop varlist))))
706 (defun context-coloring-elisp-parse-arglist ()
707 "Parse the list of function arguments at point."
711 (context-coloring-elisp-forward-sws)
712 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
713 context-coloring-CLOSE-PARENTHESIS-CODE)
715 ((context-coloring-elisp-identifier-p syntax-code)
716 (context-coloring-elisp-parse-bindable
718 (context-coloring-elisp-add-variable arg))))
721 (context-coloring-elisp-forward-sexp)))
722 (context-coloring-elisp-forward-sws))
726 (defun context-coloring-elisp-skip-callee-name ()
727 "Skip past the opening parenthesis and name of a function."
730 (context-coloring-elisp-forward-sws)
731 ;; Skip past the function name.
733 (context-coloring-elisp-forward-sws))
735 (defun context-coloring-elisp-colorize-scope (callback)
736 "Color the whole scope at point with its one color.
737 Handle a header in CALLBACK."
738 (let ((start (point))
739 (end (progn (forward-sexp)
741 (context-coloring-elisp-push-scope)
742 ;; Splash the whole thing in one color.
743 (context-coloring-colorize-region
746 (context-coloring-elisp-get-current-scope-level))
747 ;; Even if the parse is interrupted, this region should still be colored
749 (context-coloring-elisp-colorize-comments-and-strings-in-region
753 (context-coloring-elisp-skip-callee-name)
755 (context-coloring-elisp-colorize-region (point) (1- end))
758 (context-coloring-elisp-pop-scope)))
760 (defun context-coloring-elisp-parse-header (callback)
761 "Parse a function header at point with CALLBACK."
762 (when (= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
765 (defun context-coloring-elisp-colorize-defun-like (callback)
766 "Color the defun-like function at point.
767 Parse the header with CALLBACK."
768 (context-coloring-elisp-colorize-scope
770 (when (context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
771 ;; Color the defun's name with the top-level color.
772 (context-coloring-colorize-region
774 (progn (forward-sexp)
777 (context-coloring-elisp-forward-sws)
778 (context-coloring-elisp-parse-header callback)))))
780 (defun context-coloring-elisp-colorize-defun ()
781 "Color the `defun' at point."
782 (context-coloring-elisp-colorize-defun-like
783 'context-coloring-elisp-parse-arglist))
785 (defun context-coloring-elisp-colorize-defadvice ()
786 "Color the `defadvice' at point."
787 (context-coloring-elisp-colorize-defun-like
792 (context-coloring-elisp-forward-sws)
793 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
794 context-coloring-CLOSE-PARENTHESIS-CODE)
796 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
797 (context-coloring-elisp-parse-arglist))
800 (context-coloring-elisp-forward-sexp)))
801 (context-coloring-elisp-forward-sws))))))
803 (defun context-coloring-elisp-colorize-lambda-like (callback)
804 "Color the lambda-like function at point.
805 Parsing the header with CALLBACK."
806 (context-coloring-elisp-colorize-scope
808 (context-coloring-elisp-parse-header callback))))
810 (defun context-coloring-elisp-colorize-lambda ()
811 "Color the `lambda' at point."
812 (context-coloring-elisp-colorize-lambda-like
813 'context-coloring-elisp-parse-arglist))
815 (defun context-coloring-elisp-colorize-let ()
816 "Color the `let' at point."
817 (context-coloring-elisp-colorize-lambda-like
819 (context-coloring-elisp-parse-let-varlist 'let))))
821 (defun context-coloring-elisp-colorize-let* ()
822 "Color the `let*' at point."
823 (context-coloring-elisp-colorize-lambda-like
825 (context-coloring-elisp-parse-let-varlist 'let*))))
827 (defun context-coloring-elisp-colorize-macroexp-let2 ()
828 "Color the `macroexp-let2' at point."
831 (context-coloring-elisp-colorize-scope
835 (setq syntax-code (context-coloring-get-syntax-code))
836 (context-coloring-elisp-identifier-p syntax-code))
838 (context-coloring-elisp-colorize-sexp)
839 (context-coloring-elisp-forward-sws)
840 (setq syntax-code (context-coloring-get-syntax-code))
841 (context-coloring-elisp-identifier-p syntax-code))
843 (context-coloring-elisp-parse-bindable
844 (lambda (parsed-variable)
845 (setq variable parsed-variable)))
846 (context-coloring-elisp-forward-sws)
848 (context-coloring-elisp-add-variable variable))))))))
850 (defun context-coloring-elisp-colorize-cond ()
851 "Color the `cond' at point."
853 (context-coloring-elisp-skip-callee-name)
854 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
855 context-coloring-CLOSE-PARENTHESIS-CODE)
857 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
858 ;; Colorize inside the parens.
859 (let ((start (point)))
861 (context-coloring-elisp-colorize-region
862 (1+ start) (1- (point)))
867 (context-coloring-elisp-forward-sexp)))
868 (context-coloring-elisp-forward-sws))
872 (defun context-coloring-elisp-colorize-condition-case ()
873 "Color the `condition-case' at point."
878 (context-coloring-elisp-colorize-scope
880 (setq syntax-code (context-coloring-get-syntax-code))
881 ;; Gracefully ignore missing variables.
882 (when (context-coloring-elisp-identifier-p syntax-code)
883 (context-coloring-elisp-parse-bindable
884 (lambda (parsed-variable)
885 (setq variable parsed-variable)))
886 (context-coloring-elisp-forward-sws))
887 (context-coloring-elisp-colorize-sexp)
888 (context-coloring-elisp-forward-sws)
889 ;; Parse the handlers with the error variable in scope.
891 (context-coloring-elisp-add-variable variable))
892 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
893 context-coloring-CLOSE-PARENTHESIS-CODE)
895 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
896 (setq case-pos (point))
897 (context-coloring-elisp-forward-sexp)
898 (setq case-end (point))
902 (context-coloring-elisp-forward-sws)
903 (setq syntax-code (context-coloring-get-syntax-code))
904 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
905 ;; Skip the condition name(s).
906 (context-coloring-elisp-forward-sexp)
907 ;; Color the remaining portion of the handler.
908 (context-coloring-elisp-colorize-region
915 (context-coloring-elisp-forward-sexp)))
916 (context-coloring-elisp-forward-sws))))))
918 (defun context-coloring-elisp-colorize-dolist ()
919 "Color the `dolist' at point."
922 (context-coloring-elisp-colorize-scope
924 (setq syntax-code (context-coloring-get-syntax-code))
925 (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
927 (context-coloring-elisp-forward-sws)
928 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
929 context-coloring-CLOSE-PARENTHESIS-CODE)
932 (or (= index 0) (= index 2))
933 (context-coloring-elisp-identifier-p syntax-code))
934 ;; Add the first or third name to the scope.
935 (context-coloring-elisp-parse-bindable
937 (context-coloring-elisp-add-variable variable))))
940 (context-coloring-elisp-colorize-sexp)))
941 (context-coloring-elisp-forward-sws)
942 (setq index (1+ index)))
946 (defun context-coloring-elisp-colorize-quote ()
947 "Color the `quote' at point."
948 (let* ((start (point))
949 (end (progn (forward-sexp)
951 (context-coloring-colorize-region
954 (context-coloring-elisp-get-current-scope-level))
955 (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
957 (defvar context-coloring-elisp-callee-dispatch-hash-table
958 (let ((table (make-hash-table :test 'equal)))
959 (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
960 (puthash callee #'context-coloring-elisp-colorize-defun table))
961 (dolist (callee '("condition-case" "condition-case-unless-debug"))
962 (puthash callee #'context-coloring-elisp-colorize-condition-case table))
963 (dolist (callee '("dolist" "dotimes"))
964 (puthash callee #'context-coloring-elisp-colorize-dolist table))
965 (dolist (callee '("let" "gv-letplace"))
966 (puthash callee #'context-coloring-elisp-colorize-let table))
967 (puthash "let*" #'context-coloring-elisp-colorize-let* table)
968 (puthash "macroexp-let2" #'context-coloring-elisp-colorize-macroexp-let2 table)
969 (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
970 (puthash "cond" #'context-coloring-elisp-colorize-cond table)
971 (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
972 (puthash "quote" #'context-coloring-elisp-colorize-quote table)
973 (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
975 "Map function names to their coloring functions.")
977 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
978 "Color the sexp enclosed by parenthesis at point."
979 (context-coloring-elisp-increment-sexp-count)
980 (let* ((start (point))
981 (end (progn (forward-sexp)
983 (syntax-code (progn (goto-char start)
985 ;; Coloring is unnecessary here, it'll happen
987 (context-coloring-forward-sws)
988 (context-coloring-get-syntax-code)))
990 ;; Figure out if the sexp is a special form.
992 ((and (context-coloring-elisp-identifier-p syntax-code)
993 (setq dispatch-function (gethash
994 (buffer-substring-no-properties
996 (progn (forward-sexp)
998 context-coloring-elisp-callee-dispatch-hash-table)))
1000 (funcall dispatch-function))
1001 ;; Not a special form; just colorize the remaining region.
1003 (context-coloring-colorize-region
1006 (context-coloring-elisp-get-current-scope-level))
1007 (context-coloring-elisp-colorize-region (point) (1- end))
1010 (defun context-coloring-elisp-colorize-symbol ()
1011 "Color the symbol at point."
1012 (context-coloring-elisp-increment-sexp-count)
1013 (let* ((symbol-pos (point))
1014 (symbol-end (progn (forward-sexp)
1016 (symbol-string (buffer-substring-no-properties
1020 ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
1022 (context-coloring-colorize-region
1025 (context-coloring-elisp-get-variable-level
1028 (defun context-coloring-elisp-colorize-backquote-form ()
1029 "Color the backquote form at point."
1030 (let ((start (point))
1031 (end (progn (forward-sexp)
1035 (while (> end (progn (forward-char)
1037 (setq char (char-after))
1038 (when (= char context-coloring-COMMA-CHAR)
1040 (when (= (char-after) context-coloring-AT-CHAR)
1041 ;; If we don't do this "@" could be interpreted as a symbol.
1043 (context-coloring-elisp-forward-sws)
1044 (context-coloring-elisp-colorize-sexp)))
1045 ;; We could probably do this as part of the above loop but it'd be
1047 (context-coloring-elisp-colorize-comments-and-strings-in-region
1050 (defun context-coloring-elisp-colorize-backquote ()
1051 "Color the `backquote' at point."
1052 (context-coloring-elisp-skip-callee-name)
1053 (context-coloring-elisp-colorize-backquote-form)
1057 (defun context-coloring-elisp-colorize-expression-prefix ()
1058 "Color the expression prefix and expression at point.
1059 It could be a quoted or backquoted expression."
1060 (context-coloring-elisp-increment-sexp-count)
1062 ((/= (char-after) context-coloring-BACKTICK-CHAR)
1063 (context-coloring-elisp-forward-sexp))
1065 (context-coloring-elisp-colorize-backquote-form))))
1067 (defun context-coloring-elisp-colorize-comment ()
1068 "Color the comment at point."
1069 (context-coloring-elisp-increment-sexp-count)
1070 (context-coloring-elisp-forward-sws))
1072 (defun context-coloring-elisp-colorize-string ()
1073 "Color the string at point."
1074 (context-coloring-elisp-increment-sexp-count)
1075 (let ((start (point)))
1077 (context-coloring-colorize-comments-and-strings start (point))))
1079 ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
1080 ;; prefix, string quote, comment starters/enders and escape syntax classes only.
1082 (defun context-coloring-elisp-colorize-sexp ()
1083 "Color the sexp at point."
1084 (let ((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-ESCAPE-CODE)
1095 (forward-char 2)))))
1097 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
1098 "Color comments and strings between START and END."
1101 (while (> end (progn (skip-syntax-forward "^\"<\\" end)
1103 (setq syntax-code (context-coloring-get-syntax-code))
1105 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1106 (context-coloring-elisp-colorize-string))
1107 ((= syntax-code context-coloring-COMMENT-START-CODE)
1108 (context-coloring-elisp-colorize-comment))
1109 ((= syntax-code context-coloring-ESCAPE-CODE)
1110 (forward-char 2))))))
1112 (defun context-coloring-elisp-colorize-region (start end)
1113 "Color everything between START and END."
1116 (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
1118 (setq syntax-code (context-coloring-get-syntax-code))
1120 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1121 (context-coloring-elisp-colorize-parenthesized-sexp))
1122 ((context-coloring-elisp-identifier-p syntax-code)
1123 (context-coloring-elisp-colorize-symbol))
1124 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1125 (context-coloring-elisp-colorize-expression-prefix))
1126 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1127 (context-coloring-elisp-colorize-string))
1128 ((= syntax-code context-coloring-COMMENT-START-CODE)
1129 (context-coloring-elisp-colorize-comment))
1130 ((= syntax-code context-coloring-ESCAPE-CODE)
1131 (forward-char 2))))))
1133 (defun context-coloring-elisp-colorize-region-initially (start end)
1134 "Begin coloring everything between START and END."
1135 (setq context-coloring-elisp-sexp-count 0)
1136 (setq context-coloring-elisp-scope-stack '())
1137 (let ((inhibit-point-motion-hooks t)
1138 (case-fold-search nil)
1139 ;; This is a recursive-descent parser, so give it a big stack.
1140 (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
1141 (max-specpdl-size (max max-specpdl-size 3000)))
1142 (context-coloring-elisp-colorize-region start end)))
1144 (defun context-coloring-elisp-colorize-guard (callback)
1145 "Silently color in CALLBACK."
1146 (with-silent-modifications
1150 ;; Scan errors can happen virtually anywhere if parenthesis are
1151 ;; unbalanced. Just swallow them. (`progn' for test coverage.)
1152 (scan-error (progn))))))
1154 (defun context-coloring-elisp-colorize ()
1155 "Color the current Emacs Lisp buffer."
1157 (context-coloring-elisp-colorize-guard
1160 ;; Just colorize the changed region.
1161 (context-coloring-changed-p
1162 (let* ( ;; Prevent `beginning-of-defun' from making poor assumptions.
1163 (open-paren-in-column-0-is-defun-start nil)
1164 ;; Seek the beginning and end of the previous and next
1165 ;; offscreen defuns, so just enough is colored.
1166 (start (progn (goto-char context-coloring-changed-start)
1167 (while (and (< (point-min) (point))
1168 (pos-visible-in-window-p))
1170 (beginning-of-defun)
1172 (end (progn (goto-char context-coloring-changed-end)
1173 (while (and (> (point-max) (point))
1174 (pos-visible-in-window-p))
1178 (context-coloring-elisp-colorize-region-initially start end)
1179 ;; Fast coloring is nice, but if the code is not well-formed
1180 ;; (e.g. an unclosed string literal is parsed at any time) then
1181 ;; there could be leftover incorrectly-colored code offscreen. So
1182 ;; do a clean sweep as soon as appropriate.
1183 (context-coloring-schedule-coloring context-coloring-default-delay)))
1185 (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
1188 ;;; eval-expression colorization
1190 (defun context-coloring-eval-expression-match ()
1191 "Determine expression start in `eval-expression'."
1192 (string-match "\\`Eval: " (buffer-string)))
1194 (defun context-coloring-eval-expression-colorize ()
1195 "Color the `eval-expression' minibuffer prompt as elisp."
1197 (context-coloring-elisp-colorize-guard
1199 (context-coloring-elisp-colorize-region-initially
1201 (context-coloring-eval-expression-match)
1208 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
1209 "Map dispatch strategy names to their property lists.")
1211 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
1212 "Map major mode names to dispatch property lists.")
1214 (defvar context-coloring-dispatch-predicates '()
1215 "Functions which may return a dispatch.")
1217 (defun context-coloring-get-current-dispatch ()
1218 "Return the first dispatch appropriate for the current state."
1219 (let ((predicates context-coloring-dispatch-predicates)
1222 ;; Maybe a predicate will be satisfied and return a dispatch.
1223 (while (and predicates
1224 (not (setq dispatch (funcall (pop predicates))))))
1225 ;; If not, maybe a major mode (or a derivative) will define a dispatch.
1226 (when (not dispatch)
1228 (not (setq dispatch (gethash parent context-coloring-mode-hash-table)))
1229 (setq parent (get parent 'derived-mode-parent)))))
1232 (defun context-coloring-define-dispatch (symbol &rest properties)
1233 "Define a new dispatch named SYMBOL with PROPERTIES.
1235 A \"dispatch\" is a property list describing a strategy for
1238 PROPERTIES must include one of `:modes' or `:predicate', and a
1241 `:modes' - List of major modes this dispatch is valid for.
1243 `:predicate' - Function that determines if the dispatch is valid
1244 for any given state.
1246 `:colorizer' - Function that parses and colors the buffer.
1248 `:delay' - Delay between buffer update and colorization, to
1249 override `context-coloring-default-delay'.
1251 `:setup' - Arbitrary code to set up this dispatch when
1252 `context-coloring-mode' is enabled.
1254 `:teardown' - Arbitrary code to tear down this dispatch when
1255 `context-coloring-mode' is disabled."
1256 (let ((modes (plist-get properties :modes))
1257 (predicate (plist-get properties :predicate))
1258 (colorizer (plist-get properties :colorizer)))
1259 (when (null (or modes predicate))
1260 (error "No mode or predicate defined for dispatch"))
1261 (when (not colorizer)
1262 (error "No colorizer defined for dispatch"))
1263 (puthash symbol properties context-coloring-dispatch-hash-table)
1264 (dolist (mode modes)
1265 (puthash mode properties context-coloring-mode-hash-table))
1268 (when (funcall predicate)
1269 properties)) context-coloring-dispatch-predicates))))
1271 (defun context-coloring-dispatch ()
1272 "Determine how to color the current buffer, and color it."
1273 (let* ((dispatch (context-coloring-get-current-dispatch))
1274 (colorizer (plist-get dispatch :colorizer)))
1276 (funcall colorizer))))
1281 (defun context-coloring-colorize ()
1282 "Color the current buffer by function context."
1284 (context-coloring-update-maximum-face)
1285 (context-coloring-dispatch))
1287 (defun context-coloring-colorize-with-buffer (buffer)
1289 ;; Don't select deleted buffers.
1290 (when (get-buffer buffer)
1291 (with-current-buffer buffer
1292 (context-coloring-colorize))))
1295 ;;; Built-in dispatches
1297 (context-coloring-define-dispatch
1300 :colorizer #'context-coloring-js2-colorize
1303 (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
1306 (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
1308 (context-coloring-define-dispatch
1310 :modes '(emacs-lisp-mode)
1311 :colorizer #'context-coloring-elisp-colorize
1312 :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
1313 :setup #'context-coloring-setup-idle-change-detection
1314 :teardown #'context-coloring-teardown-idle-change-detection)
1316 ;; `eval-expression-minibuffer-setup-hook' is not available in Emacs 24.3, so
1317 ;; the backwards-compatible recommendation is to use `minibuffer-setup-hook' and
1318 ;; rely on this predicate instead.
1319 (defun context-coloring-eval-expression-predicate ()
1320 "Non-nil if the minibuffer is for `eval-expression'."
1321 ;; Kinda better than checking `this-command', because `this-command' changes.
1322 (context-coloring-eval-expression-match))
1324 (context-coloring-define-dispatch
1326 :predicate #'context-coloring-eval-expression-predicate
1327 :colorizer #'context-coloring-eval-expression-colorize
1329 :setup #'context-coloring-setup-idle-change-detection
1330 :teardown #'context-coloring-teardown-idle-change-detection)
1332 (defvar context-coloring-ignore-unavailable-predicates
1335 "Cases when \"unavailable\" messages are silenced.
1336 Necessary in editing states where coloring is only sometimes
1339 (defun context-coloring-ignore-unavailable-message-p ()
1340 "Determine if the unavailable message should be silenced."
1341 (let ((predicates context-coloring-ignore-unavailable-predicates)
1343 (while (and predicates
1345 (setq ignore-p (funcall (pop predicates))))
1352 (define-minor-mode context-coloring-mode
1353 "Toggle contextual code coloring.
1354 With a prefix argument ARG, enable Context Coloring mode if ARG
1355 is positive, and disable it otherwise. If called from Lisp,
1356 enable the mode if ARG is omitted or nil.
1358 Context Coloring mode is a buffer-local minor mode. When
1359 enabled, code is colored by scope. Scopes are colored
1360 hierarchically. Variables referenced from nested scopes retain
1361 the color of their defining scopes. Certain syntax, like
1362 comments and strings, is still colored with `font-lock'.
1364 The entire buffer is colored initially. Changes to the buffer
1367 Define your own colors by customizing faces like
1368 `context-coloring-level-N-face', where N is a number starting
1369 from 0. If no face is found on a custom theme nor the `user'
1370 theme, the defaults are used.
1372 New language / major mode support can be added with
1373 `context-coloring-define-dispatch', which see.
1375 Feature inspired by Douglas Crockford."
1378 (context-coloring-mode
1379 ;; Font lock is incompatible with this mode; the converse is also true.
1382 ;; ...but we do use font-lock functions here.
1383 (font-lock-set-defaults)
1384 ;; Safely change the value of this function as necessary.
1385 (make-local-variable 'font-lock-syntactic-face-function)
1386 (let ((dispatch (context-coloring-get-current-dispatch)))
1389 (let ((setup (plist-get dispatch :setup)))
1392 ;; Colorize once initially.
1393 (let ((context-coloring-parse-interruptable-p nil))
1394 (context-coloring-colorize))))
1395 ((not (context-coloring-ignore-unavailable-message-p))
1396 (message "Context coloring is unavailable here")))))
1398 (let ((dispatch (context-coloring-get-current-dispatch)))
1400 (let ((teardown (plist-get dispatch :teardown)))
1402 (funcall teardown)))))
1404 (jit-lock-mode t))))
1406 (provide 'context-coloring)
1408 ;;; context-coloring.el ends here