1 ;;; context-coloring.el --- Highlight by scope -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
5 ;; Author: Jackson Ray Hamilton <jackson@jacksonrayhamilton.com>
7 ;; Keywords: convenience faces tools
8 ;; Package-Requires: ((emacs "24.3"))
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.
40 (defun context-coloring-join (strings delimiter)
41 "Join a list of STRINGS with the string DELIMITER."
42 (mapconcat #'identity strings delimiter))
47 (defun context-coloring-defface (level light dark tty)
48 "Define a face for LEVEL with LIGHT, DARK and TTY colors."
49 (let ((face (intern (format "context-coloring-level-%s-face" level)))
50 (doc (format "Context coloring face, level %s." level)))
53 `((((type tty)) (:foreground ,tty))
54 (((background light)) (:foreground ,light))
55 (((background dark)) (:foreground ,dark)))
57 :group 'context-coloring)))
59 ;; Provide some default colors based off Emacs's defaults.
60 (context-coloring-defface 0 "#000000" "#ffffff" nil)
61 (context-coloring-defface 1 "#008b8b" "#00ffff" "yellow")
62 (context-coloring-defface 2 "#0000ff" "#87cefa" "green")
63 (context-coloring-defface 3 "#483d8b" "#b0c4de" "cyan")
64 (context-coloring-defface 4 "#a020f0" "#eedd82" "blue")
65 (context-coloring-defface 5 "#a0522d" "#98fb98" "magenta")
66 (context-coloring-defface 6 "#228b22" "#7fffd4" "red")
67 (context-coloring-defface 7 "#3f3f3f" "#cdcdcd" nil)
69 (defconst context-coloring-default-maximum-face 7
70 "Maximum face when there are no custom faces.")
72 ;; Create placeholder faces for users and theme authors.
74 (let* ((level (+ level 8))
75 (face (intern (format "context-coloring-level-%s-face" level)))
76 (doc (format "Context coloring face, level %s." level)))
77 (custom-declare-face face nil doc :group 'context-coloring)))
79 (defvar-local context-coloring-maximum-face nil
80 "Dynamic index of the highest face available for coloring.")
82 (defsubst context-coloring-level-face (level)
83 "Return symbol for face with LEVEL."
84 ;; `concat' is faster than `format' here.
86 (concat "context-coloring-level-" (number-to-string level) "-face")))
88 (defsubst context-coloring-bounded-level-face (level)
89 "Return symbol for face with LEVEL, bounded by the maximum."
90 (context-coloring-level-face (min level context-coloring-maximum-face)))
92 (defconst context-coloring-level-face-regexp
93 "context-coloring-level-\\([[:digit:]]+\\)-face"
94 "Extract a level from a face.")
96 (defun context-coloring-theme-highest-level (theme)
97 "Return the highest coloring level for THEME, or -1."
98 (let* ((settings (get theme 'theme-settings))
104 (and (eq (nth 0 (car tail)) 'theme-face)
105 (setq face-string (symbol-name (nth 1 (car tail))))
107 context-coloring-level-face-regexp
109 (setq number (string-to-number
110 (substring face-string
115 (setq tail (cdr tail)))
118 (defun context-coloring-update-maximum-face ()
119 "Save the highest possible face for the current theme."
120 (let ((themes (append custom-enabled-themes '(user)))
125 (setq theme (car themes))
126 (setq themes (cdr themes))
127 (setq highest-level (context-coloring-theme-highest-level theme))
128 (setq continue (and themes (= highest-level -1))))
129 (setq context-coloring-maximum-face
131 ((= highest-level -1)
132 context-coloring-default-maximum-face)
139 (defvar-local context-coloring-changed-p nil
140 "Indication that the buffer has changed recently, which implies
141 that it should be colored again by
142 `context-coloring-maybe-colorize-idle-timer' if that timer is
145 (defvar-local context-coloring-changed-start nil
146 "Beginning of last text that changed.")
148 (defvar-local context-coloring-changed-end nil
149 "End of last text that changed.")
151 (defvar-local context-coloring-changed-length nil
152 "Length of last text that changed.")
154 (defun context-coloring-change-function (start end length)
155 "Register a change so that a buffer can be colorized soon.
157 START, END and LENGTH are recorded for later use."
158 ;; Tokenization is obsolete if there was a change.
159 (setq context-coloring-changed-start start)
160 (setq context-coloring-changed-end end)
161 (setq context-coloring-changed-length length)
162 (setq context-coloring-changed-p t))
164 (defun context-coloring-maybe-colorize-with-buffer (buffer)
165 "Color BUFFER and if it has changed."
166 (when (and (eq buffer (current-buffer))
167 context-coloring-changed-p)
168 (context-coloring-colorize-with-buffer buffer)
169 (setq context-coloring-changed-p nil)
170 (setq context-coloring-changed-start nil)
171 (setq context-coloring-changed-end nil)
172 (setq context-coloring-changed-length nil)))
174 (defvar-local context-coloring-maybe-colorize-idle-timer nil
175 "The currently-running idle timer for conditional coloring.")
177 (defvar-local context-coloring-colorize-idle-timer nil
178 "The currently-running idle timer for unconditional coloring.")
180 (defcustom context-coloring-default-delay 0.25
181 "Default delay between a buffer update and colorization.
183 Increase this if your machine is high-performing. Decrease it if
186 :group 'context-coloring)
188 (defun context-coloring-cancel-timer (timer)
191 (cancel-timer timer)))
193 (defun context-coloring-schedule-coloring (time)
194 "Schedule coloring to occur once after Emacs is idle for TIME."
195 (context-coloring-cancel-timer context-coloring-colorize-idle-timer)
196 (setq context-coloring-colorize-idle-timer
200 #'context-coloring-colorize-with-buffer
203 (defun context-coloring-setup-idle-change-detection ()
204 "Setup idle change detection."
205 (let ((dispatch (context-coloring-get-current-dispatch)))
207 'after-change-functions #'context-coloring-change-function nil t)
209 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
210 (setq context-coloring-maybe-colorize-idle-timer
212 (or (plist-get dispatch :delay) context-coloring-default-delay)
214 #'context-coloring-maybe-colorize-with-buffer
217 (defun context-coloring-teardown-idle-change-detection ()
218 "Teardown idle change detection."
219 (dolist (timer (list context-coloring-colorize-idle-timer
220 context-coloring-maybe-colorize-idle-timer))
221 (context-coloring-cancel-timer timer))
223 'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
225 'after-change-functions #'context-coloring-change-function t))
228 ;;; Colorization utilities
230 (defsubst context-coloring-colorize-region (start end level)
231 "Color from START (inclusive) to END (exclusive) with LEVEL."
235 `(face ,(context-coloring-bounded-level-face level))))
237 (defcustom context-coloring-syntactic-comments t
238 "If non-nil, also color comments using `font-lock'."
240 :group 'context-coloring)
242 (defcustom context-coloring-syntactic-strings t
243 "If non-nil, also color strings using `font-lock'."
245 :group 'context-coloring)
247 (defun context-coloring-font-lock-syntactic-comment-function (state)
248 "Color a comment according to STATE."
249 (if (nth 3 state) nil font-lock-comment-face))
251 (defun context-coloring-font-lock-syntactic-string-function (state)
252 "Color a string according to STATE."
253 (if (nth 3 state) font-lock-string-face nil))
255 (defsubst context-coloring-colorize-comments-and-strings (&optional min max keywords-p)
256 "Maybe color comments and strings in buffer from MIN to MAX.
257 MIN defaults to beginning of buffer. MAX defaults to end. If
258 KEYWORDS-P is non-nil, also color keywords from MIN to MAX."
259 (when (or context-coloring-syntactic-comments
260 context-coloring-syntactic-strings)
261 (let ((min (or min (point-min)))
262 (max (or max (point-max)))
263 (font-lock-syntactic-face-function
265 ((and context-coloring-syntactic-comments
266 (not context-coloring-syntactic-strings))
267 #'context-coloring-font-lock-syntactic-comment-function)
268 ((and context-coloring-syntactic-strings
269 (not context-coloring-syntactic-comments))
270 #'context-coloring-font-lock-syntactic-string-function)
272 font-lock-syntactic-face-function))))
274 (font-lock-fontify-syntactically-region min max)
276 (font-lock-fontify-keywords-region min max))))))
278 (defcustom context-coloring-initial-level 0
279 "Scope level at which to start coloring.
281 If top-level variables and functions do not become global, but
282 are scoped to a file (as in Node.js), set this to 1."
285 :group 'context-coloring)
291 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
292 "Map dispatch strategy names to their property lists.
294 A \"dispatch\" is a property list describing a strategy for
297 Its properties must include one of `:modes' or `:predicate', and
300 `:modes' - List of major modes this dispatch is valid for.
302 `:predicate' - Function that determines if the dispatch is valid
305 `:colorizer' - Function that parses and colors the buffer.
307 `:delay' - Delay between buffer update and colorization, to
308 override `context-coloring-default-delay'.
310 `:setup' - Arbitrary code to set up this dispatch when
311 `context-coloring-mode' is enabled.
313 `:teardown' - Arbitrary code to tear down this dispatch when
314 `context-coloring-mode' is disabled.")
316 (defun context-coloring-find-dispatch (predicate)
317 "Find the first dispatch satisfying PREDICATE."
321 (when (and (not found)
322 (funcall predicate dispatch))
323 (setq found dispatch)))
324 context-coloring-dispatch-hash-table)
327 (defun context-coloring-get-current-dispatch ()
328 "Return the first dispatch appropriate for the current state."
330 ;; Maybe a predicate will be satisfied.
331 ((context-coloring-find-dispatch
333 (let ((predicate (plist-get dispatch :predicate)))
334 (and predicate (funcall predicate))))))
335 ;; If not, maybe a major mode (or a derivative) will.
336 ((context-coloring-find-dispatch
338 (let ((modes (plist-get dispatch :modes))
340 (while (and modes (not match))
341 (setq match (eq (pop modes) major-mode)))
344 (defun context-coloring-before-colorize ()
345 "Set up environment for colorization."
346 (context-coloring-update-maximum-face))
348 (defun context-coloring-dispatch ()
349 "Determine how to color the current buffer, and color it."
350 (let* ((dispatch (context-coloring-get-current-dispatch))
351 (colorizer (plist-get dispatch :colorizer)))
352 (context-coloring-before-colorize)
355 (funcall colorizer)))))
360 (defun context-coloring-colorize ()
361 "Color the current buffer by function context."
363 (context-coloring-dispatch))
365 (defun context-coloring-colorize-with-buffer (buffer)
367 ;; Don't select deleted buffers.
368 (when (get-buffer buffer)
369 (with-current-buffer buffer
370 (context-coloring-colorize))))
375 (defvar context-coloring-ignore-unavailable-predicates
378 "Cases when \"unavailable\" messages are silenced.
379 Necessary in editing states where coloring is only sometimes
382 (defun context-coloring-ignore-unavailable-message-p ()
383 "Determine if the unavailable message should be silenced."
384 (let ((predicates context-coloring-ignore-unavailable-predicates)
386 (while (and predicates
388 (setq ignore-p (funcall (pop predicates))))
391 (defvar context-coloring-interruptable-p t
392 "When non-nil, coloring may be interrupted by user input.")
395 (define-minor-mode context-coloring-mode
396 "Toggle contextual code coloring.
397 With a prefix argument ARG, enable Context Coloring mode if ARG
398 is positive, and disable it otherwise. If called from Lisp,
399 enable the mode if ARG is omitted or nil.
401 Context Coloring mode is a buffer-local minor mode. When
402 enabled, code is colored by scope. Scopes are colored
403 hierarchically. Variables referenced from nested scopes retain
404 the color of their defining scopes. Certain syntax, like
405 comments and strings, is still colored with `font-lock'.
407 The entire buffer is colored initially. Changes to the buffer
410 Define your own colors by customizing faces like
411 `context-coloring-level-N-face', where N is a number starting
412 from 0. If no face is found on a custom theme nor the `user'
413 theme, the defaults are used.
415 New language / major mode support can be added with
416 `context-coloring-define-dispatch', which see.
418 Feature inspired by Douglas Crockford."
421 (context-coloring-mode
422 (let ((dispatch (context-coloring-get-current-dispatch)))
425 ;; Font lock is incompatible with this mode; the converse is also true.
427 ;; ...but we do use font-lock functions here.
428 (font-lock-set-defaults)
429 ;; Safely change the value of this function as necessary.
430 (make-local-variable 'font-lock-syntactic-face-function)
431 (let ((setup (plist-get dispatch :setup)))
434 ;; Colorize once initially.
435 (let ((context-coloring-interruptable-p nil))
436 (context-coloring-colorize))))
437 ((not (context-coloring-ignore-unavailable-message-p))
438 (message "Context coloring is unavailable here")))))
440 (let ((dispatch (context-coloring-get-current-dispatch)))
442 (let ((teardown (plist-get dispatch :teardown)))
444 (funcall teardown)))))
445 (turn-on-font-lock-if-desired))))
447 (provide 'context-coloring)
449 ;;; context-coloring.el ends here