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 (defun context-coloring-node-program-p ()
418 "Guess whether the current file is a Node.js program."
420 ;; A shebang is a pretty obvious giveaway.
424 (goto-char (point-min))
425 (when (looking-at auto-mode-interpreter-regexp)
427 ;; Otherwise, perform static analysis.
429 (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
430 (catch 'node-program-p
437 ;; Infer based on inline linter configuration.
438 ((js2-comment-node-p node)
440 context-coloring-node-comment-regexp
441 (js2-node-string node)))
442 ;; Infer based on the prescence of certain variables.
443 ((and (js2-name-node-p node)
444 (let ((parent (js2-node-parent node)))
445 (not (and (js2-object-prop-node-p parent)
446 (eq node (js2-object-prop-node-left parent))))))
447 (let ((name (js2-name-node-name node))
448 (parent (js2-node-parent node)))
451 ;; Check whether this is "exports.something" or
453 ((js2-prop-get-node-p parent)
455 (eq node (js2-prop-get-node-left parent))
456 (or (string-equal name "exports")
457 (let* ((property (js2-prop-get-node-right parent))
458 (property-name (js2-name-node-name property)))
459 (and (string-equal name "module")
460 (string-equal property-name "exports"))))))
461 ;; Check whether it's a "require('module')" call.
462 ((js2-call-node-p parent)
463 (or (string-equal name "require"))))
464 (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
465 (defining-scope (js2-get-defining-scope
466 enclosing-scope name)))
467 ;; The variable also must be global.
468 (null defining-scope))))))
469 (throw 'node-program-p t))
470 ;; The `t' indicates to search children.
472 ;; Default to returning nil from the catch body.
475 (defcustom context-coloring-detect-node t
476 "If non-nil, use file-level scope for variables in Node.js."
478 :group 'context-coloring)
480 (defun context-coloring-js2-colorize ()
481 "Color the buffer using the `js2-mode'."
483 ;; Increase the initial level if we can detect Node.js.
484 ((and context-coloring-detect-node
485 (context-coloring-node-program-p))
486 (let ((context-coloring-initial-level 1))
487 (context-coloring-js2-colorize-ast)))
489 (context-coloring-js2-colorize-ast))))
492 ;;; Emacs Lisp colorization
494 (defsubst context-coloring-forward-sws ()
495 "Move forward through whitespace and comments."
496 (while (forward-comment 1)))
498 (defsubst context-coloring-elisp-forward-sws ()
499 "Move through whitespace and comments, coloring comments."
500 (let ((start (point)))
501 (context-coloring-forward-sws)
502 (context-coloring-colorize-comments-and-strings start (point))))
504 (defsubst context-coloring-elisp-forward-sexp ()
505 "Like `forward-sexp', coloring skipped comments and strings."
506 (let ((start (point)))
508 (context-coloring-elisp-colorize-comments-and-strings-in-region
511 (defsubst context-coloring-get-syntax-code ()
512 "Get the syntax code at point."
514 ;; Faster version of `syntax-after':
515 (aref (syntax-table) (char-after (point)))))
517 (defsubst context-coloring-exact-regexp (word)
518 "Create a regexp matching exactly WORD."
519 (concat "\\`" (regexp-quote word) "\\'"))
521 (defsubst context-coloring-exact-or-regexp (words)
522 "Create a regexp matching any exact word in WORDS."
523 (context-coloring-join
524 (mapcar #'context-coloring-exact-regexp words) "\\|"))
526 (defconst context-coloring-elisp-ignored-word-regexp
527 (context-coloring-join (list "\\`[-+]?[0-9]"
529 (context-coloring-exact-or-regexp
530 '("t" "nil" "." "?")))
532 "Match symbols that can't be bound as variables.")
534 (defconst context-coloring-WORD-CODE 2)
535 (defconst context-coloring-SYMBOL-CODE 3)
536 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
537 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
538 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
539 (defconst context-coloring-STRING-QUOTE-CODE 7)
540 (defconst context-coloring-ESCAPE-CODE 9)
541 (defconst context-coloring-COMMENT-START-CODE 11)
542 (defconst context-coloring-COMMENT-END-CODE 12)
544 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
545 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
546 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
547 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
548 (defconst context-coloring-AT-CHAR (string-to-char "@"))
549 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
551 (defsubst context-coloring-elisp-identifier-p (syntax-code)
552 "Check if SYNTAX-CODE is an elisp identifier constituent."
553 (or (= syntax-code context-coloring-WORD-CODE)
554 (= syntax-code context-coloring-SYMBOL-CODE)))
556 (defvar context-coloring-parse-interruptable-p t
557 "Set this to nil to force parse to continue until finished.")
559 (defconst context-coloring-elisp-sexps-per-pause 350
560 "Pause after this many iterations to check for user input.
561 If user input is pending, stop the parse. This makes for a
562 smoother user experience for large files.
564 This number should trigger pausing at about 60 frames per
567 (defvar context-coloring-elisp-sexp-count 0
568 "Current number of sexps leading up to the next pause.")
570 (defsubst context-coloring-elisp-increment-sexp-count ()
571 "Maybe check if the user interrupted the current parse."
572 (setq context-coloring-elisp-sexp-count
573 (1+ context-coloring-elisp-sexp-count))
574 (when (and (zerop (% context-coloring-elisp-sexp-count
575 context-coloring-elisp-sexps-per-pause))
576 context-coloring-parse-interruptable-p
578 (throw 'interrupted t)))
580 (defvar context-coloring-elisp-scope-stack '()
581 "List of scopes in the current parse.")
583 (defsubst context-coloring-elisp-make-scope (level)
584 "Make a scope object for LEVEL."
589 (defsubst context-coloring-elisp-scope-get-level (scope)
590 "Get the level of SCOPE object."
591 (plist-get scope :level))
593 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
594 "Add to SCOPE a VARIABLE."
595 (plist-put scope :variables (cons variable (plist-get scope :variables))))
597 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
598 "Check if SCOPE has VARIABLE."
599 (member variable (plist-get scope :variables)))
601 (defsubst context-coloring-elisp-get-variable-level (variable)
602 "Return the level of VARIABLE, or 0 if it isn't found."
603 (let* ((scope-stack context-coloring-elisp-scope-stack)
606 (while (and scope-stack (not level))
607 (setq scope (car scope-stack))
609 ((context-coloring-elisp-scope-has-variable scope variable)
610 (setq level (context-coloring-elisp-scope-get-level scope)))
612 (setq scope-stack (cdr scope-stack)))))
613 ;; Assume a global variable.
616 (defsubst context-coloring-elisp-get-current-scope-level ()
617 "Get the nesting level of the current scope."
619 ((car context-coloring-elisp-scope-stack)
620 (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
624 (defsubst context-coloring-elisp-push-scope ()
625 "Add a new scope to the bottom of the scope chain."
626 (push (context-coloring-elisp-make-scope
627 (1+ (context-coloring-elisp-get-current-scope-level)))
628 context-coloring-elisp-scope-stack))
630 (defsubst context-coloring-elisp-pop-scope ()
631 "Remove the scope on the bottom of the scope chain."
632 (pop context-coloring-elisp-scope-stack))
634 (defsubst context-coloring-elisp-add-variable (variable)
635 "Add VARIABLE to the current scope."
636 (context-coloring-elisp-scope-add-variable
637 (car context-coloring-elisp-scope-stack)
640 (defsubst context-coloring-elisp-parse-bindable (callback)
641 "Parse the symbol at point.
642 If the symbol can be bound, invoke CALLBACK with it."
643 (let* ((arg-string (buffer-substring-no-properties
645 (progn (context-coloring-elisp-forward-sexp)
647 (when (not (string-match-p
648 context-coloring-elisp-ignored-word-regexp
650 (funcall callback arg-string))))
652 (defun context-coloring-elisp-parse-let-varlist (type)
653 "Parse the list of variable initializers at point.
654 If TYPE is `let', all the variables are bound after all their
655 initializers are parsed; if TYPE is `let*', each variable is
656 bound immediately after its own initializer is parsed."
661 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
662 context-coloring-CLOSE-PARENTHESIS-CODE)
664 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
666 (context-coloring-elisp-forward-sws)
667 (setq syntax-code (context-coloring-get-syntax-code))
668 (when (context-coloring-elisp-identifier-p syntax-code)
669 (context-coloring-elisp-parse-bindable
672 (context-coloring-elisp-forward-sws)
673 (setq syntax-code (context-coloring-get-syntax-code))
674 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
675 (context-coloring-elisp-colorize-sexp)))
676 (context-coloring-elisp-forward-sws)
677 ;; Skip past the closing parenthesis.
679 ((context-coloring-elisp-identifier-p syntax-code)
680 (context-coloring-elisp-parse-bindable
682 (push var varlist))))
685 (context-coloring-elisp-forward-sexp)))
686 (when (eq type 'let*)
687 (context-coloring-elisp-add-variable (pop varlist)))
688 (context-coloring-elisp-forward-sws))
691 (context-coloring-elisp-add-variable (pop varlist))))
695 (defun context-coloring-elisp-parse-arglist ()
696 "Parse the list of function arguments at point."
700 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
701 context-coloring-CLOSE-PARENTHESIS-CODE)
703 ((context-coloring-elisp-identifier-p syntax-code)
704 (context-coloring-elisp-parse-bindable
706 (context-coloring-elisp-add-variable arg))))
709 (context-coloring-elisp-forward-sexp)))
710 (context-coloring-elisp-forward-sws))
714 (defun context-coloring-elisp-skip-callee-name ()
715 "Skip past the opening parenthesis and name of a function."
718 (context-coloring-elisp-forward-sws)
719 ;; Skip past the function name.
721 (context-coloring-elisp-forward-sws))
723 (defun context-coloring-elisp-colorize-scope (callback)
724 "Color the whole scope at point with its one color.
725 Handle a header in CALLBACK."
726 (let ((start (point))
727 (end (progn (forward-sexp)
729 (context-coloring-elisp-push-scope)
730 ;; Splash the whole thing in one color.
731 (context-coloring-colorize-region
734 (context-coloring-elisp-get-current-scope-level))
735 ;; Even if the parse is interrupted, this region should still be colored
737 (context-coloring-elisp-colorize-comments-and-strings-in-region
741 (context-coloring-elisp-skip-callee-name)
743 (context-coloring-elisp-colorize-region (point) (1- end))
746 (context-coloring-elisp-pop-scope)))
748 (defun context-coloring-elisp-parse-header (callback)
749 "Parse a function header at point with CALLBACK."
750 (when (= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
753 (defun context-coloring-elisp-colorize-defun-like (callback)
754 "Color the defun-like function at point.
755 Parse the header with CALLBACK."
756 (context-coloring-elisp-colorize-scope
758 (when (context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
759 ;; Color the defun's name with the top-level color.
760 (context-coloring-colorize-region
762 (progn (forward-sexp)
765 (context-coloring-elisp-forward-sws)
766 (context-coloring-elisp-parse-header callback)))))
768 (defun context-coloring-elisp-colorize-defun ()
769 "Color the `defun' at point."
770 (context-coloring-elisp-colorize-defun-like
771 'context-coloring-elisp-parse-arglist))
773 (defun context-coloring-elisp-colorize-defadvice ()
774 "Color the `defadvice' at point."
775 (context-coloring-elisp-colorize-defun-like
780 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
781 context-coloring-CLOSE-PARENTHESIS-CODE)
783 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
784 (context-coloring-elisp-parse-arglist))
787 (context-coloring-elisp-forward-sexp)))
788 (context-coloring-elisp-forward-sws))))))
790 (defun context-coloring-elisp-colorize-lambda-like (callback)
791 "Color the lambda-like function at point.
792 Parsing the header with CALLBACK."
793 (context-coloring-elisp-colorize-scope
795 (context-coloring-elisp-parse-header callback))))
797 (defun context-coloring-elisp-colorize-lambda ()
798 "Color the `lambda' at point."
799 (context-coloring-elisp-colorize-lambda-like
800 'context-coloring-elisp-parse-arglist))
802 (defun context-coloring-elisp-colorize-let ()
803 "Color the `let' at point."
804 (context-coloring-elisp-colorize-lambda-like
806 (context-coloring-elisp-parse-let-varlist 'let))))
808 (defun context-coloring-elisp-colorize-let* ()
809 "Color the `let*' at point."
810 (context-coloring-elisp-colorize-lambda-like
812 (context-coloring-elisp-parse-let-varlist 'let*))))
814 (defun context-coloring-elisp-colorize-cond ()
815 "Color the `cond' at point."
817 (context-coloring-elisp-skip-callee-name)
818 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
819 context-coloring-CLOSE-PARENTHESIS-CODE)
821 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
822 ;; Colorize inside the parens.
823 (let ((start (point)))
825 (context-coloring-elisp-colorize-region
826 (1+ start) (1- (point)))
831 (context-coloring-elisp-forward-sexp)))
832 (context-coloring-elisp-forward-sws))
836 (defun context-coloring-elisp-colorize-condition-case ()
837 "Color the `condition-case' at point."
842 (context-coloring-elisp-colorize-scope
844 (setq syntax-code (context-coloring-get-syntax-code))
845 ;; Gracefully ignore missing variables.
846 (when (context-coloring-elisp-identifier-p syntax-code)
847 (context-coloring-elisp-parse-bindable
848 (lambda (parsed-variable)
849 (setq variable parsed-variable)))
850 (context-coloring-elisp-forward-sws))
851 (context-coloring-elisp-colorize-sexp)
852 (context-coloring-elisp-forward-sws)
853 ;; Parse the handlers with the error variable in scope.
855 (context-coloring-elisp-add-variable variable))
856 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
857 context-coloring-CLOSE-PARENTHESIS-CODE)
859 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
860 (setq case-pos (point))
861 (context-coloring-elisp-forward-sexp)
862 (setq case-end (point))
866 (context-coloring-elisp-forward-sws)
867 (setq syntax-code (context-coloring-get-syntax-code))
868 (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
869 ;; Skip the condition name(s).
870 (context-coloring-elisp-forward-sexp)
871 ;; Color the remaining portion of the handler.
872 (context-coloring-elisp-colorize-region
879 (context-coloring-elisp-forward-sexp)))
880 (context-coloring-elisp-forward-sws))))))
882 (defun context-coloring-elisp-colorize-dolist ()
883 "Color the `dolist' at point."
886 (context-coloring-elisp-colorize-scope
888 (setq syntax-code (context-coloring-get-syntax-code))
889 (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
891 (context-coloring-elisp-forward-sws)
892 (while (/= (setq syntax-code (context-coloring-get-syntax-code))
893 context-coloring-CLOSE-PARENTHESIS-CODE)
896 (or (= index 0) (= index 2))
897 (context-coloring-elisp-identifier-p syntax-code))
898 ;; Add the first or third name to the scope.
899 (context-coloring-elisp-parse-bindable
901 (context-coloring-elisp-add-variable variable))))
904 (context-coloring-elisp-colorize-sexp)))
905 (context-coloring-elisp-forward-sws)
906 (setq index (1+ index)))
910 (defun context-coloring-elisp-colorize-quote ()
911 "Color the `quote' at point."
912 (let* ((start (point))
913 (end (progn (forward-sexp)
915 (context-coloring-colorize-region
918 (context-coloring-elisp-get-current-scope-level))
919 (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
921 (defvar context-coloring-elisp-callee-dispatch-hash-table
922 (let ((table (make-hash-table :test 'equal)))
923 (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
924 (puthash callee #'context-coloring-elisp-colorize-defun table))
925 (dolist (callee '("condition-case" "condition-case-unless-debug"))
926 (puthash callee #'context-coloring-elisp-colorize-condition-case table))
927 (dolist (callee '("dolist" "dotimes"))
928 (puthash callee #'context-coloring-elisp-colorize-dolist table))
929 (puthash "let" #'context-coloring-elisp-colorize-let table)
930 (puthash "let*" #'context-coloring-elisp-colorize-let* table)
931 (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
932 (puthash "cond" #'context-coloring-elisp-colorize-cond table)
933 (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
934 (puthash "quote" #'context-coloring-elisp-colorize-quote table)
935 (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
937 "Map function names to their coloring functions.")
939 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
940 "Color the sexp enclosed by parenthesis at point."
941 (context-coloring-elisp-increment-sexp-count)
942 (let* ((start (point))
943 (end (progn (forward-sexp)
945 (syntax-code (progn (goto-char start)
947 ;; Coloring is unnecessary here, it'll happen
949 (context-coloring-forward-sws)
950 (context-coloring-get-syntax-code)))
952 ;; Figure out if the sexp is a special form.
954 ((and (context-coloring-elisp-identifier-p syntax-code)
955 (setq dispatch-function (gethash
956 (buffer-substring-no-properties
958 (progn (forward-sexp)
960 context-coloring-elisp-callee-dispatch-hash-table)))
962 (funcall dispatch-function))
963 ;; Not a special form; just colorize the remaining region.
965 (context-coloring-colorize-region
968 (context-coloring-elisp-get-current-scope-level))
969 (context-coloring-elisp-colorize-region (point) (1- end))
972 (defun context-coloring-elisp-colorize-symbol ()
973 "Color the symbol at point."
974 (context-coloring-elisp-increment-sexp-count)
975 (let* ((symbol-pos (point))
976 (symbol-end (progn (forward-sexp)
978 (symbol-string (buffer-substring-no-properties
982 ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
984 (context-coloring-colorize-region
987 (context-coloring-elisp-get-variable-level
990 (defun context-coloring-elisp-colorize-backquote-form ()
991 "Color the backquote form at point."
992 (let ((start (point))
993 (end (progn (forward-sexp)
997 (while (> end (progn (forward-char)
999 (setq char (char-after))
1000 (when (= char context-coloring-COMMA-CHAR)
1002 (when (= (char-after) context-coloring-AT-CHAR)
1003 ;; If we don't do this "@" could be interpreted as a symbol.
1005 (context-coloring-elisp-forward-sws)
1006 (context-coloring-elisp-colorize-sexp)))
1007 ;; We could probably do this as part of the above loop but it'd be
1009 (context-coloring-elisp-colorize-comments-and-strings-in-region
1012 (defun context-coloring-elisp-colorize-backquote ()
1013 "Color the `backquote' at point."
1014 (context-coloring-elisp-skip-callee-name)
1015 (context-coloring-elisp-colorize-backquote-form)
1019 (defun context-coloring-elisp-colorize-expression-prefix ()
1020 "Color the expression prefix and expression at point.
1021 It could be a quoted or backquoted expression."
1022 (context-coloring-elisp-increment-sexp-count)
1024 ((/= (char-after) context-coloring-BACKTICK-CHAR)
1025 (context-coloring-elisp-forward-sexp))
1027 (context-coloring-elisp-colorize-backquote-form))))
1029 (defun context-coloring-elisp-colorize-comment ()
1030 "Color the comment at point."
1031 (context-coloring-elisp-increment-sexp-count)
1032 (context-coloring-elisp-forward-sws))
1034 (defun context-coloring-elisp-colorize-string ()
1035 "Color the string at point."
1036 (context-coloring-elisp-increment-sexp-count)
1037 (let ((start (point)))
1039 (context-coloring-colorize-comments-and-strings start (point))))
1041 ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
1042 ;; prefix, string quote, comment starters/enders and escape syntax classes only.
1044 (defun context-coloring-elisp-colorize-sexp ()
1045 "Color the sexp at point."
1046 (let ((syntax-code (context-coloring-get-syntax-code)))
1048 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1049 (context-coloring-elisp-colorize-parenthesized-sexp))
1050 ((context-coloring-elisp-identifier-p syntax-code)
1051 (context-coloring-elisp-colorize-symbol))
1052 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1053 (context-coloring-elisp-colorize-expression-prefix))
1054 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1055 (context-coloring-elisp-colorize-string))
1056 ((= syntax-code context-coloring-ESCAPE-CODE)
1057 (forward-char 2)))))
1059 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
1060 "Color comments and strings between START and END."
1063 (while (> end (progn (skip-syntax-forward "^\"<\\" end)
1065 (setq syntax-code (context-coloring-get-syntax-code))
1067 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1068 (context-coloring-elisp-colorize-string))
1069 ((= syntax-code context-coloring-COMMENT-START-CODE)
1070 (context-coloring-elisp-colorize-comment))
1071 ((= syntax-code context-coloring-ESCAPE-CODE)
1072 (forward-char 2))))))
1074 (defun context-coloring-elisp-colorize-region (start end)
1075 "Color everything between START and END."
1078 (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
1080 (setq syntax-code (context-coloring-get-syntax-code))
1082 ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1083 (context-coloring-elisp-colorize-parenthesized-sexp))
1084 ((context-coloring-elisp-identifier-p syntax-code)
1085 (context-coloring-elisp-colorize-symbol))
1086 ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1087 (context-coloring-elisp-colorize-expression-prefix))
1088 ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1089 (context-coloring-elisp-colorize-string))
1090 ((= syntax-code context-coloring-COMMENT-START-CODE)
1091 (context-coloring-elisp-colorize-comment))
1092 ((= syntax-code context-coloring-ESCAPE-CODE)
1093 (forward-char 2))))))
1095 (defun context-coloring-elisp-colorize-region-initially (start end)
1096 "Begin coloring everything between START and END."
1097 (setq context-coloring-elisp-sexp-count 0)
1098 (setq context-coloring-elisp-scope-stack '())
1099 (let ((inhibit-point-motion-hooks t)
1100 (case-fold-search nil)
1101 ;; This is a recursive-descent parser, so give it a big stack.
1102 (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
1103 (max-specpdl-size (max max-specpdl-size 3000)))
1104 (context-coloring-elisp-colorize-region start end)))
1106 (defun context-coloring-elisp-colorize-guard (callback)
1107 "Silently color in CALLBACK."
1108 (with-silent-modifications
1112 ;; Scan errors can happen virtually anywhere if parenthesis are
1113 ;; unbalanced. Just swallow them. (`progn' for test coverage.)
1114 (scan-error (progn))))))
1116 (defun context-coloring-elisp-colorize ()
1117 "Color the current Emacs Lisp buffer."
1119 (context-coloring-elisp-colorize-guard
1122 ;; Just colorize the changed region.
1123 (context-coloring-changed-p
1124 (let* ( ;; Prevent `beginning-of-defun' from making poor assumptions.
1125 (open-paren-in-column-0-is-defun-start nil)
1126 ;; Seek the beginning and end of the previous and next
1127 ;; offscreen defuns, so just enough is colored.
1128 (start (progn (goto-char context-coloring-changed-start)
1129 (while (and (< (point-min) (point))
1130 (pos-visible-in-window-p))
1132 (beginning-of-defun)
1134 (end (progn (goto-char context-coloring-changed-end)
1135 (while (and (> (point-max) (point))
1136 (pos-visible-in-window-p))
1140 (context-coloring-elisp-colorize-region-initially start end)
1141 ;; Fast coloring is nice, but if the code is not well-formed
1142 ;; (e.g. an unclosed string literal is parsed at any time) then
1143 ;; there could be leftover incorrectly-colored code offscreen. So
1144 ;; do a clean sweep as soon as appropriate.
1145 (context-coloring-schedule-coloring context-coloring-default-delay)))
1147 (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
1150 ;;; eval-expression colorization
1152 (defun context-coloring-eval-expression-match ()
1153 "Determine expression start in `eval-expression'."
1154 (string-match "\\`Eval: " (buffer-string)))
1156 (defun context-coloring-eval-expression-colorize ()
1157 "Color the `eval-expression' minibuffer prompt as elisp."
1159 (context-coloring-elisp-colorize-guard
1161 (context-coloring-elisp-colorize-region-initially
1163 (context-coloring-eval-expression-match)
1170 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
1171 "Map dispatch strategy names to their property lists.")
1173 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
1174 "Map major mode names to dispatch property lists.")
1176 (defvar context-coloring-dispatch-predicates '()
1177 "Functions which may return a dispatch.")
1179 (defun context-coloring-get-current-dispatch ()
1180 "Return the first dispatch appropriate for the current state."
1181 (let ((predicates context-coloring-dispatch-predicates)
1184 ;; Maybe a predicate will be satisfied and return a dispatch.
1185 (while (and predicates
1186 (not (setq dispatch (funcall (pop predicates))))))
1187 ;; If not, maybe a major mode (or a derivative) will define a dispatch.
1188 (when (not dispatch)
1190 (not (setq dispatch (gethash parent context-coloring-mode-hash-table)))
1191 (setq parent (get parent 'derived-mode-parent)))))
1194 (defun context-coloring-define-dispatch (symbol &rest properties)
1195 "Define a new dispatch named SYMBOL with PROPERTIES.
1197 A \"dispatch\" is a property list describing a strategy for
1200 PROPERTIES must include one of `:modes' or `:predicate', and a
1203 `:modes' - List of major modes this dispatch is valid for.
1205 `:predicate' - Function that determines if the dispatch is valid
1206 for any given state.
1208 `:colorizer' - Function that parses and colors the buffer.
1210 `:delay' - Delay between buffer update and colorization, to
1211 override `context-coloring-default-delay'.
1213 `:setup' - Arbitrary code to set up this dispatch when
1214 `context-coloring-mode' is enabled.
1216 `:teardown' - Arbitrary code to tear down this dispatch when
1217 `context-coloring-mode' is disabled."
1218 (let ((modes (plist-get properties :modes))
1219 (predicate (plist-get properties :predicate))
1220 (colorizer (plist-get properties :colorizer)))
1221 (when (null (or modes predicate))
1222 (error "No mode or predicate defined for dispatch"))
1223 (when (not colorizer)
1224 (error "No colorizer defined for dispatch"))
1225 (puthash symbol properties context-coloring-dispatch-hash-table)
1226 (dolist (mode modes)
1227 (puthash mode properties context-coloring-mode-hash-table))
1230 (when (funcall predicate)
1231 properties)) context-coloring-dispatch-predicates))))
1233 (defun context-coloring-dispatch ()
1234 "Determine how to color the current buffer, and color it."
1235 (let* ((dispatch (context-coloring-get-current-dispatch))
1236 (colorizer (plist-get dispatch :colorizer)))
1238 (funcall colorizer))))
1243 (defun context-coloring-colorize ()
1244 "Color the current buffer by function context."
1246 (context-coloring-update-maximum-face)
1247 (context-coloring-dispatch))
1249 (defun context-coloring-colorize-with-buffer (buffer)
1251 ;; Don't select deleted buffers.
1252 (when (get-buffer buffer)
1253 (with-current-buffer buffer
1254 (context-coloring-colorize))))
1257 ;;; Built-in dispatches
1259 (context-coloring-define-dispatch
1262 :colorizer #'context-coloring-js2-colorize
1265 (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
1268 (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
1270 (context-coloring-define-dispatch
1272 :modes '(emacs-lisp-mode)
1273 :colorizer #'context-coloring-elisp-colorize
1274 :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
1275 :setup #'context-coloring-setup-idle-change-detection
1276 :teardown #'context-coloring-teardown-idle-change-detection)
1278 ;; `eval-expression-minibuffer-setup-hook' is not available in Emacs 24.3, so
1279 ;; the backwards-compatible recommendation is to use `minibuffer-setup-hook' and
1280 ;; rely on this predicate instead.
1281 (defun context-coloring-eval-expression-predicate ()
1282 "Non-nil if the minibuffer is for `eval-expression'."
1283 ;; Kinda better than checking `this-command', because `this-command' changes.
1284 (context-coloring-eval-expression-match))
1286 (context-coloring-define-dispatch
1288 :predicate #'context-coloring-eval-expression-predicate
1289 :colorizer #'context-coloring-eval-expression-colorize
1291 :setup #'context-coloring-setup-idle-change-detection
1292 :teardown #'context-coloring-teardown-idle-change-detection)
1294 (defvar context-coloring-ignore-unavailable-predicates
1297 "Cases when \"unavailable\" messages are silenced.
1298 Necessary in editing states where coloring is only sometimes
1301 (defun context-coloring-ignore-unavailable-message-p ()
1302 "Determine if the unavailable message should be silenced."
1303 (let ((predicates context-coloring-ignore-unavailable-predicates)
1305 (while (and predicates
1307 (setq ignore-p (funcall (pop predicates))))
1314 (define-minor-mode context-coloring-mode
1315 "Toggle contextual code coloring.
1316 With a prefix argument ARG, enable Context Coloring mode if ARG
1317 is positive, and disable it otherwise. If called from Lisp,
1318 enable the mode if ARG is omitted or nil.
1320 Context Coloring mode is a buffer-local minor mode. When
1321 enabled, code is colored by scope. Scopes are colored
1322 hierarchically. Variables referenced from nested scopes retain
1323 the color of their defining scopes. Certain syntax, like
1324 comments and strings, is still colored with `font-lock'.
1326 The entire buffer is colored initially. Changes to the buffer
1329 Define your own colors by customizing faces like
1330 `context-coloring-level-N-face', where N is a number starting
1331 from 0. If no face is found on a custom theme nor the `user'
1332 theme, the defaults are used.
1334 New language / major mode support can be added with
1335 `context-coloring-define-dispatch', which see.
1337 Feature inspired by Douglas Crockford."
1340 (context-coloring-mode
1341 ;; Font lock is incompatible with this mode; the converse is also true.
1344 ;; ...but we do use font-lock functions here.
1345 (font-lock-set-defaults)
1346 ;; Safely change the value of this function as necessary.
1347 (make-local-variable 'font-lock-syntactic-face-function)
1348 (let ((dispatch (context-coloring-get-current-dispatch)))
1351 (let ((setup (plist-get dispatch :setup)))
1354 ;; Colorize once initially.
1355 (let ((context-coloring-parse-interruptable-p nil))
1356 (context-coloring-colorize))))
1357 ((not (context-coloring-ignore-unavailable-message-p))
1358 (message "Context coloring is unavailable here")))))
1360 (let ((dispatch (context-coloring-get-current-dispatch)))
1362 (let ((teardown (plist-get dispatch :teardown)))
1364 (funcall teardown)))))
1366 (jit-lock-mode t))))
1368 (provide 'context-coloring)
1370 ;;; context-coloring.el ends here