code.delx.au - gnu-emacs-elpa/blob - context-coloring.el

   1 ;;; context-coloring.el --- Highlight by scope  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014-2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Jackson Ray Hamilton <jackson@jacksonrayhamilton.com>
   6 ;; Version: 7.0.0
   7 ;; Keywords: convenience faces tools
   8 ;; Package-Requires: ((emacs "24.3") (js2-mode "20150713"))
   9 ;; URL: https://github.com/jacksonrayhamilton/context-coloring
  10
  11 ;; This file is part of GNU Emacs.
  12
  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.
  17
  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.
  22
  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/>.
  25
  26 ;;; Commentary:
  27
  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.
  32
  33 ;; By default, comments and strings are still highlighted syntactically.
  34
  35 ;;; Code:
  36
  37 (require 'js2-mode)
  38
  39
  40 ;;; Utilities
  41
  42 (defun context-coloring-join (strings delimiter)
  43   "Join a list of STRINGS with the string DELIMITER."
  44   (mapconcat #'identity strings delimiter))
  45
  46
  47 ;;; Faces
  48
  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)))
  53     (custom-declare-face
  54      face
  55      `((((type tty)) (:foreground ,tty))
  56        (((background light)) (:foreground ,light))
  57        (((background dark)) (:foreground ,dark)))
  58      doc
  59      :group 'context-coloring)))
  60
  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)
  70
  71 (defconst context-coloring-default-maximum-face 7
  72   "Maximum face when there are no custom faces.")
  73
  74 ;; Create placeholder faces for users and theme authors.
  75 (dotimes (level 18)
  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)))
  80
  81 (defvar-local context-coloring-maximum-face nil
  82   "Dynamic index of the highest face available for coloring.")
  83
  84 (defsubst context-coloring-level-face (level)
  85   "Return symbol for face with LEVEL."
  86   ;; `concat' is faster than `format' here.
  87   (intern-soft
  88    (concat "context-coloring-level-" (number-to-string level) "-face")))
  89
  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)))
  93
  94 (defconst context-coloring-level-face-regexp
  95   "context-coloring-level-\\([[:digit:]]+\\)-face"
  96   "Extract a level from a face.")
  97
  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))
 101          (tail settings)
 102          face-string
 103          number
 104          (found -1))
 105     (while tail
 106       (and (eq (nth 0 (car tail)) 'theme-face)
 107            (setq face-string (symbol-name (nth 1 (car tail))))
 108            (string-match
 109             context-coloring-level-face-regexp
 110             face-string)
 111            (setq number (string-to-number
 112                          (substring face-string
 113                                     (match-beginning 1)
 114                                     (match-end 1))))
 115            (> number found)
 116            (setq found number))
 117       (setq tail (cdr tail)))
 118     found))
 119
 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)))
 123         (continue t)
 124         theme
 125         highest-level)
 126     (while continue
 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
 132           (cond
 133            ((= highest-level -1)
 134             context-coloring-default-maximum-face)
 135            (t
 136             highest-level)))))
 137
 138
 139 ;;; Change detection
 140
 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
 145 being used.")
 146
 147 (defvar-local context-coloring-changed-start nil
 148   "Beginning of last text that changed.")
 149
 150 (defvar-local context-coloring-changed-end nil
 151   "End of last text that changed.")
 152
 153 (defvar-local context-coloring-changed-length nil
 154   "Length of last text that changed.")
 155
 156 (defun context-coloring-change-function (start end length)
 157   "Register a change so that a buffer can be colorized soon.
 158
 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))
 165
 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)))
 175
 176 (defvar-local context-coloring-maybe-colorize-idle-timer nil
 177   "The currently-running idle timer for conditional coloring.")
 178
 179 (defvar-local context-coloring-colorize-idle-timer nil
 180   "The currently-running idle timer for unconditional coloring.")
 181
 182 (defcustom context-coloring-default-delay 0.25
 183   "Default delay between a buffer update and colorization.
 184
 185 Increase this if your machine is high-performing.  Decrease it if
 186 it ain't."
 187   :type 'float
 188   :group 'context-coloring)
 189
 190 (make-obsolete-variable
 191  'context-coloring-delay
 192  'context-coloring-default-delay
 193  "6.4.0")
 194
 195 (defun context-coloring-cancel-timer (timer)
 196   "Cancel TIMER."
 197   (when timer
 198     (cancel-timer timer)))
 199
 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
 204         (run-with-idle-timer
 205          time
 206          nil
 207          #'context-coloring-colorize-with-buffer
 208          (current-buffer))))
 209
 210 (defun context-coloring-setup-idle-change-detection ()
 211   "Setup idle change detection."
 212   (let ((dispatch (context-coloring-get-current-dispatch)))
 213     (add-hook
 214      'after-change-functions #'context-coloring-change-function nil t)
 215     (add-hook
 216      'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
 217     (setq context-coloring-maybe-colorize-idle-timer
 218           (run-with-idle-timer
 219            (or (plist-get dispatch :delay) context-coloring-default-delay)
 220            t
 221            #'context-coloring-maybe-colorize-with-buffer
 222            (current-buffer)))))
 223
 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))
 229   (remove-hook
 230    'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
 231   (remove-hook
 232    'after-change-functions #'context-coloring-change-function t))
 233
 234
 235 ;;; Colorization utilities
 236
 237 (defsubst context-coloring-colorize-region (start end level)
 238   "Color from START (inclusive) to END (exclusive) with LEVEL."
 239   (add-text-properties
 240    start
 241    end
 242    `(face ,(context-coloring-bounded-level-face level))))
 243
 244 (make-obsolete-variable
 245  'context-coloring-comments-and-strings
 246  "use `context-coloring-syntactic-comments' and
 247  `context-coloring-syntactic-strings' instead."
 248  "6.1.0")
 249
 250 (defcustom context-coloring-syntactic-comments t
 251   "If non-nil, also color comments using `font-lock'."
 252   :type 'boolean
 253   :group 'context-coloring)
 254
 255 (defcustom context-coloring-syntactic-strings t
 256   "If non-nil, also color strings using `font-lock'."
 257   :type 'boolean
 258   :group 'context-coloring)
 259
 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))
 263
 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))
 267
 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
 276            (cond
 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)
 283             (t
 284              font-lock-syntactic-face-function))))
 285       (save-excursion
 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))))))
 290
 291 (defcustom context-coloring-initial-level 0
 292   "Scope level at which to start coloring.
 293
 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'."
 296   :type 'integer
 297   :safe #'integerp
 298   :group 'context-coloring)
 299
 300
 301 ;;; Node.js colorization
 302
 303 (defconst context-coloring-node-comment-regexp
 304   (concat
 305    ;; Ensure the "//" or "/*" comment starts with the directive.
 306    "\\(//[[:space:]]*\\|/\\*[[:space:]]*\\)"
 307    ;; Support multiple directive formats.
 308    "\\("
 309    ;; JSLint and JSHint support a JSON-like format.
 310    "\\(jslint\\|jshint\\)[[:space:]].*?node:[[:space:]]*true"
 311    "\\|"
 312    ;; ESLint just specifies the option name.
 313    "eslint-env[[:space:]].*?node"
 314    "\\)")
 315   "Match a comment body hinting at a Node.js program.")
 316
 317 (defun context-coloring-node-program-p ()
 318   "Guess whether the current file is a Node.js program."
 319   (or
 320    ;; A shebang is a pretty obvious giveaway.
 321    (string-equal
 322     "node"
 323     (save-excursion
 324       (goto-char (point-min))
 325       (when (looking-at auto-mode-interpreter-regexp)
 326         (match-string 2))))
 327    ;; Otherwise, perform static analysis.
 328    (catch 'node-program-p
 329      (js2-visit-ast
 330       js2-mode-ast
 331       (lambda (node end-p)
 332         (when (null end-p)
 333           (when
 334               (cond
 335                ;; Infer based on inline linter configuration.
 336                ((js2-comment-node-p node)
 337                 (string-match-p
 338                  context-coloring-node-comment-regexp
 339                  (js2-node-string node)))
 340                ;; Infer based on the prescence of certain variables.
 341                ((and (js2-name-node-p node)
 342                      (let ((parent (js2-node-parent node)))
 343                        (not (and (js2-object-prop-node-p parent)
 344                                  (eq node (js2-object-prop-node-left parent))))))
 345                 (let ((name (js2-name-node-name node))
 346                       (parent (js2-node-parent node)))
 347                   (cond
 348                    ;; Check whether this is "exports.something" or
 349                    ;; "module.exports".
 350                    ((js2-prop-get-node-p parent)
 351                     (and
 352                      (eq node (js2-prop-get-node-left parent))
 353                      (or (string-equal name "exports")
 354                          (let* ((property (js2-prop-get-node-right parent))
 355                                 (property-name (js2-name-node-name property)))
 356                            (or (and (string-equal name "module")
 357                                     (string-equal property-name "exports")))))))
 358                    ;; Check whether it's a "require('module')" call.
 359                    ((js2-call-node-p parent)
 360                     (or (string-equal name "require")))))))
 361             (throw 'node-program-p t))
 362           ;; The `t' indicates to search children.
 363           t)))
 364      ;; Default to returning nil from the catch body.
 365      nil)))
 366
 367 (defcustom context-coloring-detect-node t
 368   "If non-nil, use file-level scope for variables in Node.js."
 369   :type 'boolean
 370   :group 'context-coloring)
 371
 372
 373 ;;; JavaScript colorization
 374
 375 (defvar-local context-coloring-js2-scope-level-hash-table nil
 376   "Associate `js2-scope' structures and with their scope
 377   levels.")
 378
 379 (defcustom context-coloring-javascript-block-scopes nil
 380   "If non-nil, also color block scopes in the scope hierarchy in JavaScript.
 381
 382 The block-scoped `let' and `const' are introduced in ES6.  Enable
 383 this for ES6 code; disable it elsewhere."
 384   :type 'boolean
 385   :safe #'booleanp
 386   :group 'context-coloring)
 387
 388 (make-obsolete-variable
 389  'context-coloring-js-block-scopes
 390  'context-coloring-javascript-block-scopes
 391  "7.0.0")
 392
 393 (defsubst context-coloring-js2-scope-level (scope initial)
 394   "Return the level of SCOPE, starting from INITIAL."
 395   (cond ((gethash scope context-coloring-js2-scope-level-hash-table))
 396         (t
 397          (let ((level initial)
 398                (current-scope scope)
 399                enclosing-scope)
 400            (while (and current-scope
 401                        (js2-node-parent current-scope)
 402                        (setq enclosing-scope
 403                              (js2-node-get-enclosing-scope current-scope)))
 404              (when (or context-coloring-javascript-block-scopes
 405                        (let ((type (js2-scope-type current-scope)))
 406                          (or (= type js2-SCRIPT)
 407                              (= type js2-FUNCTION)
 408                              (= type js2-CATCH))))
 409                (setq level (+ level 1)))
 410              (setq current-scope enclosing-scope))
 411            (puthash scope level context-coloring-js2-scope-level-hash-table)))))
 412
 413 (defsubst context-coloring-js2-local-name-node-p (node)
 414   "Determine if NODE represents a local variable."
 415   (and (js2-name-node-p node)
 416        (let ((parent (js2-node-parent node)))
 417          (not (or (and (js2-object-prop-node-p parent)
 418                        (eq node (js2-object-prop-node-left parent)))
 419                   (and (js2-prop-get-node-p parent)
 420                        ;; For nested property lookup, the node on the left is a
 421                        ;; `js2-prop-get-node', so this always works.
 422                        (eq node (js2-prop-get-node-right parent))))))))
 423
 424 (defvar-local context-coloring-point-max nil
 425   "Cached value of `point-max'.")
 426
 427 (defsubst context-coloring-js2-colorize-node (node level)
 428   "Color NODE with the color for LEVEL."
 429   (let ((start (js2-node-abs-pos node)))
 430     (context-coloring-colorize-region
 431      start
 432      (min
 433       ;; End
 434       (+ start (js2-node-len node))
 435       ;; Somes nodes (like the ast when there is an unterminated multiline
 436       ;; comment) will stretch to the value of `point-max'.
 437       context-coloring-point-max)
 438      level)))
 439
 440 (defun context-coloring-js2-colorize-ast ()
 441   "Color the buffer using the `js2-mode' abstract syntax tree."
 442   ;; Reset the hash table; the old one could be obsolete.
 443   (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
 444   (setq context-coloring-point-max (point-max))
 445   (with-silent-modifications
 446     (js2-visit-ast
 447      js2-mode-ast
 448      (lambda (node end-p)
 449        (when (null end-p)
 450          (cond
 451           ((js2-scope-p node)
 452            (context-coloring-js2-colorize-node
 453             node
 454             (context-coloring-js2-scope-level node context-coloring-initial-level)))
 455           ((context-coloring-js2-local-name-node-p node)
 456            (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
 457                   (defining-scope (js2-get-defining-scope
 458                                    enclosing-scope
 459                                    (js2-name-node-name node))))
 460              ;; The tree seems to be walked lexically, so an entire scope will
 461              ;; be colored, including its name nodes, before they are reached.
 462              ;; Coloring the nodes defined in that scope would be redundant, so
 463              ;; don't do it.
 464              (when (not (eq defining-scope enclosing-scope))
 465                (context-coloring-js2-colorize-node
 466                 node
 467                 ;; Use `0' as an initial level so global variables are always at
 468                 ;; the highest level (even if `context-coloring-initial-level'
 469                 ;; specifies an initial level for the rest of the code).
 470                 (context-coloring-js2-scope-level defining-scope 0))))))
 471          ;; The `t' indicates to search children.
 472          t)))
 473     (context-coloring-colorize-comments-and-strings)))
 474
 475 (defun context-coloring-js2-colorize ()
 476   "Color the buffer using the `js2-mode'."
 477   (cond
 478    ;; Increase the initial level if we can detect Node.js.
 479    ((and context-coloring-detect-node
 480          (context-coloring-node-program-p))
 481     (let ((context-coloring-initial-level 1))
 482       (context-coloring-js2-colorize-ast)))
 483    (t
 484     (context-coloring-js2-colorize-ast))))
 485
 486
 487 ;;; Emacs Lisp colorization
 488
 489 (defsubst context-coloring-forward-sws ()
 490   "Move forward through whitespace and comments."
 491   (while (forward-comment 1)))
 492
 493 (defsubst context-coloring-elisp-forward-sws ()
 494   "Move through whitespace and comments, coloring comments."
 495   (let ((start (point)))
 496     (context-coloring-forward-sws)
 497     (context-coloring-colorize-comments-and-strings start (point))))
 498
 499 (defsubst context-coloring-elisp-forward-sexp ()
 500   "Like `forward-sexp', coloring skipped comments and strings."
 501   (let ((start (point)))
 502     (forward-sexp)
 503     (context-coloring-elisp-colorize-comments-and-strings-in-region
 504      start (point))))
 505
 506 (defsubst context-coloring-get-syntax-code ()
 507   "Get the syntax code at point."
 508   (syntax-class
 509    ;; Faster version of `syntax-after':
 510    (aref (syntax-table) (char-after (point)))))
 511
 512 (defsubst context-coloring-exact-regexp (word)
 513   "Create a regexp matching exactly WORD."
 514   (concat "\\`" (regexp-quote word) "\\'"))
 515
 516 (defsubst context-coloring-exact-or-regexp (words)
 517   "Create a regexp matching any exact word in WORDS."
 518   (context-coloring-join
 519    (mapcar #'context-coloring-exact-regexp words) "\\|"))
 520
 521 (defconst context-coloring-elisp-ignored-word-regexp
 522   (context-coloring-join (list "\\`[-+]?[0-9]"
 523                                "\\`[&:].+"
 524                                (context-coloring-exact-or-regexp
 525                                 '("t" "nil" "." "?")))
 526                          "\\|")
 527   "Match symbols that can't be bound as variables.")
 528
 529 (defconst context-coloring-WORD-CODE 2)
 530 (defconst context-coloring-SYMBOL-CODE 3)
 531 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
 532 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
 533 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
 534 (defconst context-coloring-STRING-QUOTE-CODE 7)
 535 (defconst context-coloring-ESCAPE-CODE 9)
 536 (defconst context-coloring-COMMENT-START-CODE 11)
 537 (defconst context-coloring-COMMENT-END-CODE 12)
 538
 539 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
 540 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
 541 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
 542 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
 543 (defconst context-coloring-AT-CHAR (string-to-char "@"))
 544 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
 545
 546 (defsubst context-coloring-elisp-identifier-p (syntax-code)
 547   "Check if SYNTAX-CODE is an elisp identifier constituent."
 548   (or (= syntax-code context-coloring-WORD-CODE)
 549       (= syntax-code context-coloring-SYMBOL-CODE)))
 550
 551 (defvar context-coloring-parse-interruptable-p t
 552   "Set this to nil to force parse to continue until finished.")
 553
 554 (defconst context-coloring-elisp-sexps-per-pause 350
 555   "Pause after this many iterations to check for user input.
 556 If user input is pending, stop the parse.  This makes for a
 557 smoother user experience for large files.
 558
 559 This number should trigger pausing at about 60 frames per
 560 second.")
 561
 562 (defvar context-coloring-elisp-sexp-count 0
 563   "Current number of sexps leading up to the next pause.")
 564
 565 (defsubst context-coloring-elisp-increment-sexp-count ()
 566   "Maybe check if the user interrupted the current parse."
 567   (setq context-coloring-elisp-sexp-count
 568         (1+ context-coloring-elisp-sexp-count))
 569   (when (and (zerop (% context-coloring-elisp-sexp-count
 570                        context-coloring-elisp-sexps-per-pause))
 571              context-coloring-parse-interruptable-p
 572              (input-pending-p))
 573     (throw 'interrupted t)))
 574
 575 (defvar context-coloring-elisp-scope-stack '()
 576   "List of scopes in the current parse.")
 577
 578 (defsubst context-coloring-elisp-make-scope (level)
 579   "Make a scope object for LEVEL."
 580   (list
 581    :level level
 582    :variables '()))
 583
 584 (defsubst context-coloring-elisp-scope-get-level (scope)
 585   "Get the level of SCOPE object."
 586   (plist-get scope :level))
 587
 588 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
 589   "Add to SCOPE a VARIABLE."
 590   (plist-put scope :variables (cons variable (plist-get scope :variables))))
 591
 592 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
 593   "Check if SCOPE has VARIABLE."
 594   (member variable (plist-get scope :variables)))
 595
 596 (defsubst context-coloring-elisp-get-variable-level (variable)
 597   "Return the level of VARIABLE, or 0 if it isn't found."
 598   (let* ((scope-stack context-coloring-elisp-scope-stack)
 599          scope
 600          level)
 601     (while (and scope-stack (not level))
 602       (setq scope (car scope-stack))
 603       (cond
 604        ((context-coloring-elisp-scope-has-variable scope variable)
 605         (setq level (context-coloring-elisp-scope-get-level scope)))
 606        (t
 607         (setq scope-stack (cdr scope-stack)))))
 608     ;; Assume a global variable.
 609     (or level 0)))
 610
 611 (defsubst context-coloring-elisp-get-current-scope-level ()
 612   "Get the nesting level of the current scope."
 613   (cond
 614    ((car context-coloring-elisp-scope-stack)
 615     (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
 616    (t
 617     0)))
 618
 619 (defsubst context-coloring-elisp-push-scope ()
 620   "Add a new scope to the bottom of the scope chain."
 621   (push (context-coloring-elisp-make-scope
 622          (1+ (context-coloring-elisp-get-current-scope-level)))
 623         context-coloring-elisp-scope-stack))
 624
 625 (defsubst context-coloring-elisp-pop-scope ()
 626   "Remove the scope on the bottom of the scope chain."
 627   (pop context-coloring-elisp-scope-stack))
 628
 629 (defsubst context-coloring-elisp-add-variable (variable)
 630   "Add VARIABLE to the current scope."
 631   (context-coloring-elisp-scope-add-variable
 632    (car context-coloring-elisp-scope-stack)
 633    variable))
 634
 635 (defsubst context-coloring-elisp-parse-bindable (callback)
 636   "Parse the symbol at point.
 637 If the symbol can be bound, invoke CALLBACK with it."
 638   (let* ((arg-string (buffer-substring-no-properties
 639                       (point)
 640                       (progn (context-coloring-elisp-forward-sexp)
 641                              (point)))))
 642     (when (not (string-match-p
 643                 context-coloring-elisp-ignored-word-regexp
 644                 arg-string))
 645       (funcall callback arg-string))))
 646
 647 (defun context-coloring-elisp-parse-let-varlist (type)
 648   "Parse the list of variable initializers at point.
 649 If TYPE is `let', all the variables are bound after all their
 650 initializers are parsed; if TYPE is `let*', each variable is
 651 bound immediately after its own initializer is parsed."
 652   (let ((varlist '())
 653         syntax-code)
 654     ;; Enter.
 655     (forward-char)
 656     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 657                context-coloring-CLOSE-PARENTHESIS-CODE)
 658       (cond
 659        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 660         (forward-char)
 661         (context-coloring-elisp-forward-sws)
 662         (setq syntax-code (context-coloring-get-syntax-code))
 663         (when (context-coloring-elisp-identifier-p syntax-code)
 664           (context-coloring-elisp-parse-bindable
 665            (lambda (var)
 666              (push var varlist)))
 667           (context-coloring-elisp-forward-sws)
 668           (setq syntax-code (context-coloring-get-syntax-code))
 669           (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
 670             (context-coloring-elisp-colorize-sexp)))
 671         (context-coloring-elisp-forward-sws)
 672         ;; Skip past the closing parenthesis.
 673         (forward-char))
 674        ((context-coloring-elisp-identifier-p syntax-code)
 675         (context-coloring-elisp-parse-bindable
 676          (lambda (var)
 677            (push var varlist))))
 678        (t
 679         ;; Ignore artifacts.
 680         (context-coloring-elisp-forward-sexp)))
 681       (when (eq type 'let*)
 682         (context-coloring-elisp-add-variable (pop varlist)))
 683       (context-coloring-elisp-forward-sws))
 684     (when (eq type 'let)
 685       (while varlist
 686         (context-coloring-elisp-add-variable (pop varlist))))
 687     ;; Exit.
 688     (forward-char)))
 689
 690 (defun context-coloring-elisp-parse-arglist ()
 691   "Parse the list of function arguments at point."
 692   (let (syntax-code)
 693     ;; Enter.
 694     (forward-char)
 695     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 696                context-coloring-CLOSE-PARENTHESIS-CODE)
 697       (cond
 698        ((context-coloring-elisp-identifier-p syntax-code)
 699         (context-coloring-elisp-parse-bindable
 700          (lambda (arg)
 701            (context-coloring-elisp-add-variable arg))))
 702        (t
 703         ;; Ignore artifacts.
 704         (context-coloring-elisp-forward-sexp)))
 705       (context-coloring-elisp-forward-sws))
 706     ;; Exit.
 707     (forward-char)))
 708
 709 (defun context-coloring-elisp-skip-callee-name ()
 710   "Skip past the opening parenthesis and name of a function."
 711   ;; Enter.
 712   (forward-char)
 713   (context-coloring-elisp-forward-sws)
 714   ;; Skip past the function name.
 715   (forward-sexp)
 716   (context-coloring-elisp-forward-sws))
 717
 718 (defun context-coloring-elisp-colorize-scope (callback)
 719   "Color the whole scope at point with its one color.
 720 Handle a header in CALLBACK."
 721   (let ((start (point))
 722         (end (progn (forward-sexp)
 723                     (point))))
 724     (context-coloring-elisp-push-scope)
 725     ;; Splash the whole thing in one color.
 726     (context-coloring-colorize-region
 727      start
 728      end
 729      (context-coloring-elisp-get-current-scope-level))
 730     ;; Even if the parse is interrupted, this region should still be colored
 731     ;; syntactically.
 732     (context-coloring-elisp-colorize-comments-and-strings-in-region
 733      start
 734      end)
 735     (goto-char start)
 736     (context-coloring-elisp-skip-callee-name)
 737     (funcall callback)
 738     (context-coloring-elisp-colorize-region (point) (1- end))
 739     ;; Exit.
 740     (forward-char)
 741     (context-coloring-elisp-pop-scope)))
 742
 743 (defun context-coloring-elisp-parse-header (callback)
 744   "Parse a function header at point with CALLBACK."
 745   (when (= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
 746     (funcall callback)))
 747
 748 (defun context-coloring-elisp-colorize-defun-like (callback)
 749   "Color the defun-like function at point.
 750 Parse the header with CALLBACK."
 751   (context-coloring-elisp-colorize-scope
 752    (lambda ()
 753      (when (context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
 754        ;; Color the defun's name with the top-level color.
 755        (context-coloring-colorize-region
 756         (point)
 757         (progn (forward-sexp)
 758                (point))
 759         0)
 760        (context-coloring-elisp-forward-sws)
 761        (context-coloring-elisp-parse-header callback)))))
 762
 763 (defun context-coloring-elisp-colorize-defun ()
 764   "Color the `defun' at point."
 765   (context-coloring-elisp-colorize-defun-like
 766    'context-coloring-elisp-parse-arglist))
 767
 768 (defun context-coloring-elisp-colorize-defadvice ()
 769   "Color the `defadvice' at point."
 770   (context-coloring-elisp-colorize-defun-like
 771    (lambda ()
 772      (let (syntax-code)
 773        ;; Enter.
 774        (forward-char)
 775        (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 776                   context-coloring-CLOSE-PARENTHESIS-CODE)
 777          (cond
 778           ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 779            (context-coloring-elisp-parse-arglist))
 780           (t
 781            ;; Ignore artifacts.
 782            (context-coloring-elisp-forward-sexp)))
 783          (context-coloring-elisp-forward-sws))))))
 784
 785 (defun context-coloring-elisp-colorize-lambda-like (callback)
 786   "Color the lambda-like function at point.
 787 Parsing the header with CALLBACK."
 788   (context-coloring-elisp-colorize-scope
 789    (lambda ()
 790      (context-coloring-elisp-parse-header callback))))
 791
 792 (defun context-coloring-elisp-colorize-lambda ()
 793   "Color the `lambda' at point."
 794   (context-coloring-elisp-colorize-lambda-like
 795    'context-coloring-elisp-parse-arglist))
 796
 797 (defun context-coloring-elisp-colorize-let ()
 798   "Color the `let' at point."
 799   (context-coloring-elisp-colorize-lambda-like
 800    (lambda ()
 801      (context-coloring-elisp-parse-let-varlist 'let))))
 802
 803 (defun context-coloring-elisp-colorize-let* ()
 804   "Color the `let*' at point."
 805   (context-coloring-elisp-colorize-lambda-like
 806    (lambda ()
 807      (context-coloring-elisp-parse-let-varlist 'let*))))
 808
 809 (defun context-coloring-elisp-colorize-cond ()
 810   "Color the `cond' at point."
 811   (let (syntax-code)
 812     (context-coloring-elisp-skip-callee-name)
 813     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 814                context-coloring-CLOSE-PARENTHESIS-CODE)
 815       (cond
 816        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 817         ;; Colorize inside the parens.
 818         (let ((start (point)))
 819           (forward-sexp)
 820           (context-coloring-elisp-colorize-region
 821            (1+ start) (1- (point)))
 822           ;; Exit.
 823           (forward-char)))
 824        (t
 825         ;; Ignore artifacts.
 826         (context-coloring-elisp-forward-sexp)))
 827       (context-coloring-elisp-forward-sws))
 828     ;; Exit.
 829     (forward-char)))
 830
 831 (defun context-coloring-elisp-colorize-condition-case ()
 832   "Color the `condition-case' at point."
 833   (let (syntax-code
 834         variable
 835         case-pos
 836         case-end)
 837     (context-coloring-elisp-colorize-scope
 838      (lambda ()
 839        (setq syntax-code (context-coloring-get-syntax-code))
 840        ;; Gracefully ignore missing variables.
 841        (when (context-coloring-elisp-identifier-p syntax-code)
 842          (context-coloring-elisp-parse-bindable
 843           (lambda (parsed-variable)
 844             (setq variable parsed-variable)))
 845          (context-coloring-elisp-forward-sws))
 846        (context-coloring-elisp-colorize-sexp)
 847        (context-coloring-elisp-forward-sws)
 848        ;; Parse the handlers with the error variable in scope.
 849        (when variable
 850          (context-coloring-elisp-add-variable variable))
 851        (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 852                   context-coloring-CLOSE-PARENTHESIS-CODE)
 853          (cond
 854           ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 855            (setq case-pos (point))
 856            (context-coloring-elisp-forward-sexp)
 857            (setq case-end (point))
 858            (goto-char case-pos)
 859            ;; Enter.
 860            (forward-char)
 861            (context-coloring-elisp-forward-sws)
 862            (setq syntax-code (context-coloring-get-syntax-code))
 863            (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
 864              ;; Skip the condition name(s).
 865              (context-coloring-elisp-forward-sexp)
 866              ;; Color the remaining portion of the handler.
 867              (context-coloring-elisp-colorize-region
 868               (point)
 869               (1- case-end)))
 870            ;; Exit.
 871            (forward-char))
 872           (t
 873            ;; Ignore artifacts.
 874            (context-coloring-elisp-forward-sexp)))
 875          (context-coloring-elisp-forward-sws))))))
 876
 877 (defun context-coloring-elisp-colorize-dolist ()
 878   "Color the `dolist' at point."
 879   (let (syntax-code
 880         (index 0))
 881     (context-coloring-elisp-colorize-scope
 882      (lambda ()
 883        (setq syntax-code (context-coloring-get-syntax-code))
 884        (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 885          (forward-char)
 886          (context-coloring-elisp-forward-sws)
 887          (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 888                     context-coloring-CLOSE-PARENTHESIS-CODE)
 889            (cond
 890             ((and
 891               (or (= index 0) (= index 2))
 892               (context-coloring-elisp-identifier-p syntax-code))
 893              ;; Add the first or third name to the scope.
 894              (context-coloring-elisp-parse-bindable
 895               (lambda (variable)
 896                 (context-coloring-elisp-add-variable variable))))
 897             (t
 898              ;; Color artifacts.
 899              (context-coloring-elisp-colorize-sexp)))
 900            (context-coloring-elisp-forward-sws)
 901            (setq index (1+ index)))
 902          ;; Exit.
 903          (forward-char))))))
 904
 905 (defun context-coloring-elisp-colorize-quote ()
 906   "Color the `quote' at point."
 907   (let* ((start (point))
 908          (end (progn (forward-sexp)
 909                      (point))))
 910     (context-coloring-colorize-region
 911      start
 912      end
 913      (context-coloring-elisp-get-current-scope-level))
 914     (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
 915
 916 (defvar context-coloring-elisp-callee-dispatch-hash-table
 917   (let ((table (make-hash-table :test 'equal)))
 918     (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
 919       (puthash callee #'context-coloring-elisp-colorize-defun table))
 920     (dolist (callee '("condition-case" "condition-case-unless-debug"))
 921       (puthash callee #'context-coloring-elisp-colorize-condition-case table))
 922     (dolist (callee '("dolist" "dotimes"))
 923       (puthash callee #'context-coloring-elisp-colorize-dolist table))
 924     (puthash "let" #'context-coloring-elisp-colorize-let table)
 925     (puthash "let*" #'context-coloring-elisp-colorize-let* table)
 926     (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
 927     (puthash "cond" #'context-coloring-elisp-colorize-cond table)
 928     (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
 929     (puthash "quote" #'context-coloring-elisp-colorize-quote table)
 930     (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
 931     table)
 932   "Map function names to their coloring functions.")
 933
 934 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
 935   "Color the sexp enclosed by parenthesis at point."
 936   (context-coloring-elisp-increment-sexp-count)
 937   (let* ((start (point))
 938          (end (progn (forward-sexp)
 939                      (point)))
 940          (syntax-code (progn (goto-char start)
 941                              (forward-char)
 942                              ;; Coloring is unnecessary here, it'll happen
 943                              ;; presently.
 944                              (context-coloring-forward-sws)
 945                              (context-coloring-get-syntax-code)))
 946          dispatch-function)
 947     ;; Figure out if the sexp is a special form.
 948     (cond
 949      ((and (context-coloring-elisp-identifier-p syntax-code)
 950            (setq dispatch-function (gethash
 951                                     (buffer-substring-no-properties
 952                                      (point)
 953                                      (progn (forward-sexp)
 954                                             (point)))
 955                                     context-coloring-elisp-callee-dispatch-hash-table)))
 956       (goto-char start)
 957       (funcall dispatch-function))
 958      ;; Not a special form; just colorize the remaining region.
 959      (t
 960       (context-coloring-colorize-region
 961        start
 962        end
 963        (context-coloring-elisp-get-current-scope-level))
 964       (context-coloring-elisp-colorize-region (point) (1- end))
 965       (forward-char)))))
 966
 967 (defun context-coloring-elisp-colorize-symbol ()
 968   "Color the symbol at point."
 969   (context-coloring-elisp-increment-sexp-count)
 970   (let* ((symbol-pos (point))
 971          (symbol-end (progn (forward-sexp)
 972                             (point)))
 973          (symbol-string (buffer-substring-no-properties
 974                          symbol-pos
 975                          symbol-end)))
 976     (cond
 977      ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
 978      (t
 979       (context-coloring-colorize-region
 980        symbol-pos
 981        symbol-end
 982        (context-coloring-elisp-get-variable-level
 983         symbol-string))))))
 984
 985 (defun context-coloring-elisp-colorize-backquote-form ()
 986   "Color the backquote form at point."
 987   (let ((start (point))
 988         (end (progn (forward-sexp)
 989                     (point)))
 990         char)
 991     (goto-char start)
 992     (while (> end (progn (forward-char)
 993                          (point)))
 994       (setq char (char-after))
 995       (when (= char context-coloring-COMMA-CHAR)
 996         (forward-char)
 997         (when (= (char-after) context-coloring-AT-CHAR)
 998           ;; If we don't do this "@" could be interpreted as a symbol.
 999           (forward-char))
1000         (context-coloring-elisp-forward-sws)
1001         (context-coloring-elisp-colorize-sexp)))
1002     ;; We could probably do this as part of the above loop but it'd be
1003     ;; repetitive.
1004     (context-coloring-elisp-colorize-comments-and-strings-in-region
1005      start end)))
1006
1007 (defun context-coloring-elisp-colorize-backquote ()
1008   "Color the `backquote' at point."
1009   (context-coloring-elisp-skip-callee-name)
1010   (context-coloring-elisp-colorize-backquote-form)
1011   ;; Exit.
1012   (forward-char))
1013
1014 (defun context-coloring-elisp-colorize-expression-prefix ()
1015   "Color the expression prefix and expression at point.
1016 It could be a quoted or backquoted expression."
1017   (context-coloring-elisp-increment-sexp-count)
1018   (cond
1019    ((/= (char-after) context-coloring-BACKTICK-CHAR)
1020     (context-coloring-elisp-forward-sexp))
1021    (t
1022     (context-coloring-elisp-colorize-backquote-form))))
1023
1024 (defun context-coloring-elisp-colorize-comment ()
1025   "Color the comment at point."
1026   (context-coloring-elisp-increment-sexp-count)
1027   (context-coloring-elisp-forward-sws))
1028
1029 (defun context-coloring-elisp-colorize-string ()
1030   "Color the string at point."
1031   (context-coloring-elisp-increment-sexp-count)
1032   (let ((start (point)))
1033     (forward-sexp)
1034     (context-coloring-colorize-comments-and-strings start (point))))
1035
1036 ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
1037 ;; prefix, string quote, comment starters/enders and escape syntax classes only.
1038
1039 (defun context-coloring-elisp-colorize-sexp ()
1040   "Color the sexp at point."
1041   (let ((syntax-code (context-coloring-get-syntax-code)))
1042     (cond
1043      ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1044       (context-coloring-elisp-colorize-parenthesized-sexp))
1045      ((context-coloring-elisp-identifier-p syntax-code)
1046       (context-coloring-elisp-colorize-symbol))
1047      ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1048       (context-coloring-elisp-colorize-expression-prefix))
1049      ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1050       (context-coloring-elisp-colorize-string))
1051      ((= syntax-code context-coloring-ESCAPE-CODE)
1052       (forward-char 2)))))
1053
1054 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
1055   "Color comments and strings between START and END."
1056   (let (syntax-code)
1057     (goto-char start)
1058     (while (> end (progn (skip-syntax-forward "^\"<\\" end)
1059                          (point)))
1060       (setq syntax-code (context-coloring-get-syntax-code))
1061       (cond
1062        ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1063         (context-coloring-elisp-colorize-string))
1064        ((= syntax-code context-coloring-COMMENT-START-CODE)
1065         (context-coloring-elisp-colorize-comment))
1066        ((= syntax-code context-coloring-ESCAPE-CODE)
1067         (forward-char 2))))))
1068
1069 (defun context-coloring-elisp-colorize-region (start end)
1070   "Color everything between START and END."
1071   (let (syntax-code)
1072     (goto-char start)
1073     (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
1074                          (point)))
1075       (setq syntax-code (context-coloring-get-syntax-code))
1076       (cond
1077        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
1078         (context-coloring-elisp-colorize-parenthesized-sexp))
1079        ((context-coloring-elisp-identifier-p syntax-code)
1080         (context-coloring-elisp-colorize-symbol))
1081        ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
1082         (context-coloring-elisp-colorize-expression-prefix))
1083        ((= syntax-code context-coloring-STRING-QUOTE-CODE)
1084         (context-coloring-elisp-colorize-string))
1085        ((= syntax-code context-coloring-COMMENT-START-CODE)
1086         (context-coloring-elisp-colorize-comment))
1087        ((= syntax-code context-coloring-ESCAPE-CODE)
1088         (forward-char 2))))))
1089
1090 (defun context-coloring-elisp-colorize-region-initially (start end)
1091   "Begin coloring everything between START and END."
1092   (setq context-coloring-elisp-sexp-count 0)
1093   (setq context-coloring-elisp-scope-stack '())
1094   (let ((inhibit-point-motion-hooks t)
1095         (case-fold-search nil)
1096         ;; This is a recursive-descent parser, so give it a big stack.
1097         (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
1098         (max-specpdl-size (max max-specpdl-size 3000)))
1099     (context-coloring-elisp-colorize-region start end)))
1100
1101 (defun context-coloring-elisp-colorize-guard (callback)
1102   "Silently color in CALLBACK."
1103   (with-silent-modifications
1104     (save-excursion
1105       (condition-case nil
1106           (funcall callback)
1107         ;; Scan errors can happen virtually anywhere if parenthesis are
1108         ;; unbalanced.  Just swallow them.  (`progn' for test coverage.)
1109         (scan-error (progn))))))
1110
1111 (defun context-coloring-elisp-colorize ()
1112   "Color the current Emacs Lisp buffer."
1113   (interactive)
1114   (context-coloring-elisp-colorize-guard
1115    (lambda ()
1116      (cond
1117       ;; Just colorize the changed region.
1118       (context-coloring-changed-p
1119        (let* ( ;; Prevent `beginning-of-defun' from making poor assumptions.
1120               (open-paren-in-column-0-is-defun-start nil)
1121               ;; Seek the beginning and end of the previous and next
1122               ;; offscreen defuns, so just enough is colored.
1123               (start (progn (goto-char context-coloring-changed-start)
1124                             (while (and (< (point-min) (point))
1125                                         (pos-visible-in-window-p))
1126                               (end-of-line 0))
1127                             (beginning-of-defun)
1128                             (point)))
1129               (end (progn (goto-char context-coloring-changed-end)
1130                           (while (and (> (point-max) (point))
1131                                       (pos-visible-in-window-p))
1132                             (forward-line 1))
1133                           (end-of-defun)
1134                           (point))))
1135          (context-coloring-elisp-colorize-region-initially start end)
1136          ;; Fast coloring is nice, but if the code is not well-formed
1137          ;; (e.g. an unclosed string literal is parsed at any time) then
1138          ;; there could be leftover incorrectly-colored code offscreen.  So
1139          ;; do a clean sweep as soon as appropriate.
1140          (context-coloring-schedule-coloring context-coloring-default-delay)))
1141       (t
1142        (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
1143
1144
1145 ;;; eval-expression colorization
1146
1147 (defun context-coloring-eval-expression-match ()
1148   "Determine expression start in `eval-expression'."
1149   (string-match "\\`Eval: " (buffer-string)))
1150
1151 (defun context-coloring-eval-expression-colorize ()
1152   "Color the `eval-expression' minibuffer prompt as elisp."
1153   (interactive)
1154   (context-coloring-elisp-colorize-guard
1155    (lambda ()
1156      (context-coloring-elisp-colorize-region-initially
1157       (progn
1158         (context-coloring-eval-expression-match)
1159         (1+ (match-end 0)))
1160       (point-max)))))
1161
1162
1163 ;;; Dispatch
1164
1165 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
1166   "Map dispatch strategy names to their property lists.")
1167
1168 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
1169   "Map major mode names to dispatch property lists.")
1170
1171 (defvar context-coloring-dispatch-predicates '()
1172   "Functions which may return a dispatch.")
1173
1174 (defun context-coloring-get-current-dispatch ()
1175   "Return the first dispatch appropriate for the current state."
1176   (let ((predicates context-coloring-dispatch-predicates)
1177         (parent major-mode)
1178         dispatch)
1179     ;; Maybe a predicate will be satisfied and return a dispatch.
1180     (while (and predicates
1181                 (not (setq dispatch (funcall (pop predicates))))))
1182     ;; If not, maybe a major mode (or a derivative) will define a dispatch.
1183     (when (not dispatch)
1184       (while (and parent
1185                   (not (setq dispatch (gethash parent context-coloring-mode-hash-table)))
1186                   (setq parent (get parent 'derived-mode-parent)))))
1187     dispatch))
1188
1189 (defun context-coloring-define-dispatch (symbol &rest properties)
1190   "Define a new dispatch named SYMBOL with PROPERTIES.
1191
1192 A \"dispatch\" is a property list describing a strategy for
1193 coloring a buffer.
1194
1195 PROPERTIES must include one of `:modes' or `:predicate', and a
1196 `:colorizer'.
1197
1198 `:modes' - List of major modes this dispatch is valid for.
1199
1200 `:predicate' - Function that determines if the dispatch is valid
1201 for any given state.
1202
1203 `:colorizer' - Function that parses and colors the buffer.
1204
1205 `:delay' - Delay between buffer update and colorization, to
1206 override `context-coloring-default-delay'.
1207
1208 `:setup' - Arbitrary code to set up this dispatch when
1209 `context-coloring-mode' is enabled.
1210
1211 `:teardown' - Arbitrary code to tear down this dispatch when
1212 `context-coloring-mode' is disabled."
1213   (let ((modes (plist-get properties :modes))
1214         (predicate (plist-get properties :predicate))
1215         (colorizer (plist-get properties :colorizer)))
1216     (when (null (or modes predicate))
1217       (error "No mode or predicate defined for dispatch"))
1218     (when (not colorizer)
1219       (error "No colorizer defined for dispatch"))
1220     (puthash symbol properties context-coloring-dispatch-hash-table)
1221     (dolist (mode modes)
1222       (puthash mode properties context-coloring-mode-hash-table))
1223     (when predicate
1224       (push (lambda ()
1225               (when (funcall predicate)
1226                 properties)) context-coloring-dispatch-predicates))))
1227
1228 (defun context-coloring-dispatch ()
1229   "Determine how to color the current buffer, and color it."
1230   (let* ((dispatch (context-coloring-get-current-dispatch))
1231          (colorizer (plist-get dispatch :colorizer)))
1232     (catch 'interrupted
1233       (funcall colorizer))))
1234
1235
1236 ;;; Colorization
1237
1238 (defun context-coloring-colorize ()
1239   "Color the current buffer by function context."
1240   (interactive)
1241   (context-coloring-update-maximum-face)
1242   (context-coloring-dispatch))
1243
1244 (defun context-coloring-colorize-with-buffer (buffer)
1245   "Color BUFFER."
1246   ;; Don't select deleted buffers.
1247   (when (get-buffer buffer)
1248     (with-current-buffer buffer
1249       (context-coloring-colorize))))
1250
1251
1252 ;;; Built-in dispatches
1253
1254 (context-coloring-define-dispatch
1255  'javascript
1256  :modes '(js2-mode)
1257  :colorizer #'context-coloring-js2-colorize
1258  :setup
1259  (lambda ()
1260    (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
1261  :teardown
1262  (lambda ()
1263    (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
1264
1265 (context-coloring-define-dispatch
1266  'emacs-lisp
1267  :modes '(emacs-lisp-mode)
1268  :colorizer #'context-coloring-elisp-colorize
1269  :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
1270  :setup #'context-coloring-setup-idle-change-detection
1271  :teardown #'context-coloring-teardown-idle-change-detection)
1272
1273 ;; `eval-expression-minibuffer-setup-hook' is not available in Emacs 24.3, so
1274 ;; the backwards-compatible recommendation is to use `minibuffer-setup-hook' and
1275 ;; rely on this predicate instead.
1276 (defun context-coloring-eval-expression-predicate ()
1277   "Non-nil if the minibuffer is for `eval-expression'."
1278   ;; Kinda better than checking `this-command', because `this-command' changes.
1279   (context-coloring-eval-expression-match))
1280
1281 (context-coloring-define-dispatch
1282  'eval-expression
1283  :predicate #'context-coloring-eval-expression-predicate
1284  :colorizer #'context-coloring-eval-expression-colorize
1285  :delay 0.016
1286  :setup #'context-coloring-setup-idle-change-detection
1287  :teardown #'context-coloring-teardown-idle-change-detection)
1288
1289 (defvar context-coloring-ignore-unavailable-predicates
1290   (list
1291    #'minibufferp)
1292   "Cases when \"unavailable\" messages are silenced.
1293 Necessary in editing states where coloring is only sometimes
1294 permissible.")
1295
1296 (defun context-coloring-ignore-unavailable-message-p ()
1297   "Determine if the unavailable message should be silenced."
1298   (let ((predicates context-coloring-ignore-unavailable-predicates)
1299         (ignore-p nil))
1300     (while (and predicates
1301                 (not ignore-p))
1302       (setq ignore-p (funcall (pop predicates))))
1303     ignore-p))
1304
1305
1306 ;;; Minor mode
1307
1308 ;;;###autoload
1309 (define-minor-mode context-coloring-mode
1310   "Toggle contextual code coloring.
1311 With a prefix argument ARG, enable Context Coloring mode if ARG
1312 is positive, and disable it otherwise.  If called from Lisp,
1313 enable the mode if ARG is omitted or nil.
1314
1315 Context Coloring mode is a buffer-local minor mode.  When
1316 enabled, code is colored by scope.  Scopes are colored
1317 hierarchically.  Variables referenced from nested scopes retain
1318 the color of their defining scopes.  Certain syntax, like
1319 comments and strings, is still colored with `font-lock'.
1320
1321 The entire buffer is colored initially.  Changes to the buffer
1322 trigger recoloring.
1323
1324 Define your own colors by customizing faces like
1325 `context-coloring-level-N-face', where N is a number starting
1326 from 0.  If no face is found on a custom theme nor the `user'
1327 theme, the defaults are used.
1328
1329 New language / major mode support can be added with
1330 `context-coloring-define-dispatch', which see.
1331
1332 Feature inspired by Douglas Crockford."
1333   nil " Context" nil
1334   (cond
1335    (context-coloring-mode
1336     ;; Font lock is incompatible with this mode; the converse is also true.
1337     (font-lock-mode 0)
1338     (jit-lock-mode nil)
1339     ;; ...but we do use font-lock functions here.
1340     (font-lock-set-defaults)
1341     ;; Safely change the value of this function as necessary.
1342     (make-local-variable 'font-lock-syntactic-face-function)
1343     (let ((dispatch (context-coloring-get-current-dispatch)))
1344       (cond
1345        (dispatch
1346         (let ((setup (plist-get dispatch :setup)))
1347           (when setup
1348             (funcall setup))
1349           ;; Colorize once initially.
1350           (let ((context-coloring-parse-interruptable-p nil))
1351             (context-coloring-colorize))))
1352        ((not (context-coloring-ignore-unavailable-message-p))
1353         (message "Context coloring is unavailable here")))))
1354    (t
1355     (let ((dispatch (context-coloring-get-current-dispatch)))
1356       (when dispatch
1357         (let ((teardown (plist-get dispatch :teardown)))
1358           (when teardown
1359             (funcall teardown)))))
1360     (font-lock-mode)
1361     (jit-lock-mode t))))
1362
1363 (provide 'context-coloring)
1364
1365 ;;; context-coloring.el ends here