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: 6.2.1
   7 ;; Keywords: convenience faces tools
   8 ;; Package-Requires: ((emacs "24") (js2-mode "20150126"))
   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 ;; To use with js2-mode, add the following to your init file:
  36
  37 ;; (require 'context-coloring)
  38 ;; (add-hook 'js2-mode-hook 'context-coloring-mode)
  39
  40 ;; To use with js-mode or js3-mode, install Node.js 0.10+ and the scopifier
  41 ;; executable:
  42
  43 ;; $ npm install -g scopifier
  44
  45 ;;; Code:
  46
  47 (require 'js2-mode)
  48
  49
  50 ;;; Local variables
  51
  52 (defvar-local context-coloring-buffer nil
  53   "Reference to this buffer (for timers).")
  54
  55
  56 ;;; Utilities
  57
  58 (defun context-coloring-join (strings delimiter)
  59   "Join a list of STRINGS with the string DELIMITER."
  60   (mapconcat 'identity strings delimiter))
  61
  62 (defsubst context-coloring-trim-right (string)
  63   "Remove leading whitespace from STRING."
  64   (if (string-match "[ \t\n\r]+\\'" string)
  65       (replace-match "" t t string)
  66     string))
  67
  68 (defsubst context-coloring-trim-left (string)
  69   "Remove trailing whitespace from STRING."
  70   (if (string-match "\\`[ \t\n\r]+" string)
  71       (replace-match "" t t string)
  72     string))
  73
  74 (defsubst context-coloring-trim (string)
  75   "Remove leading and trailing whitespace from STRING."
  76   (context-coloring-trim-left (context-coloring-trim-right string)))
  77
  78
  79 ;;; Faces
  80
  81 (defun context-coloring-defface (level tty light dark)
  82   "Define a face for LEVEL with colors for TTY, LIGHT and DARK
  83 backgrounds."
  84   (let ((face (intern (format "context-coloring-level-%s-face" level)))
  85         (doc (format "Context coloring face, level %s." level)))
  86     (custom-declare-face
  87      face
  88      `((((type tty)) (:foreground ,tty))
  89        (((background light)) (:foreground ,light))
  90        (((background dark)) (:foreground ,dark)))
  91      doc
  92      :group 'context-coloring)))
  93
  94 (defun context-coloring-defface-neutral (level)
  95   "Define a face for LEVEL with the default neutral colors."
  96   (context-coloring-defface level nil "#3f3f3f" "#cdcdcd"))
  97
  98 (context-coloring-defface 0 nil       "#000000" "#ffffff")
  99 (context-coloring-defface 1 "yellow"  "#008b8b" "#00ffff")
 100 (context-coloring-defface 2 "green"   "#0000ff" "#87cefa")
 101 (context-coloring-defface 3 "cyan"    "#483d8b" "#b0c4de")
 102 (context-coloring-defface 4 "blue"    "#a020f0" "#eedd82")
 103 (context-coloring-defface 5 "magenta" "#a0522d" "#98fb98")
 104 (context-coloring-defface 6 "red"     "#228b22" "#7fffd4")
 105 (context-coloring-defface-neutral 7)
 106
 107 (defvar context-coloring-maximum-face nil
 108   "Index of the highest face available for coloring.")
 109
 110 (defvar context-coloring-original-maximum-face nil
 111   "Fallback value for `context-coloring-maximum-face' when all
 112   themes have been disabled.")
 113
 114 (setq context-coloring-maximum-face 7)
 115
 116 (setq context-coloring-original-maximum-face
 117       context-coloring-maximum-face)
 118
 119 ;; Theme authors can have up to 26 levels: 1 (0th) for globals, 24 (1st-24th)
 120 ;; for nested levels, and 1 (25th) for infinity.
 121 (dotimes (number 18)
 122   (context-coloring-defface-neutral (+ number context-coloring-maximum-face 1)))
 123
 124
 125 ;;; Face functions
 126
 127 (defsubst context-coloring-level-face (level)
 128   "Return the symbol for a face with LEVEL."
 129   ;; `concat' is faster than `format' here.
 130   (intern-soft
 131    (concat "context-coloring-level-" (number-to-string level) "-face")))
 132
 133 (defsubst context-coloring-bounded-level-face (level)
 134   "Return the symbol for a face with LEVEL, bounded by
 135 `context-coloring-maximum-face'."
 136   (context-coloring-level-face (min level context-coloring-maximum-face)))
 137
 138
 139 ;;; Colorization utilities
 140
 141 (defsubst context-coloring-colorize-region (start end level)
 142   "Color characters from the 1-indexed START point (inclusive) to
 143 the END point (exclusive) with the face corresponding to LEVEL."
 144   (add-text-properties
 145    start
 146    end
 147    `(face ,(context-coloring-bounded-level-face level))))
 148
 149 (defcustom context-coloring-comments-and-strings nil
 150   "If non-nil, also color comments and strings using `font-lock'."
 151   :group 'context-coloring)
 152
 153 (make-obsolete-variable
 154  'context-coloring-comments-and-strings
 155  "use `context-coloring-syntactic-comments' and
 156  `context-coloring-syntactic-strings' instead."
 157  "6.1.0")
 158
 159 (defcustom context-coloring-syntactic-comments t
 160   "If non-nil, also color comments using `font-lock'."
 161   :group 'context-coloring)
 162
 163 (defcustom context-coloring-syntactic-strings t
 164   "If non-nil, also color strings using `font-lock'."
 165   :group 'context-coloring)
 166
 167 (defun context-coloring-font-lock-syntactic-comment-function (state)
 168   "Tell `font-lock' to color a comment but not a string."
 169   (if (nth 3 state) nil font-lock-comment-face))
 170
 171 (defun context-coloring-font-lock-syntactic-string-function (state)
 172   "Tell `font-lock' to color a string but not a comment."
 173   (if (nth 3 state) font-lock-string-face nil))
 174
 175 (defsubst context-coloring-maybe-colorize-comments-and-strings ()
 176   "Color the current buffer's comments and strings if
 177 `context-coloring-comments-and-strings' is non-nil."
 178   (when (or context-coloring-comments-and-strings
 179             context-coloring-syntactic-comments
 180             context-coloring-syntactic-strings)
 181     (let ((old-function font-lock-syntactic-face-function)
 182           saved-function-p)
 183       (cond
 184        ((and context-coloring-syntactic-comments
 185              (not context-coloring-syntactic-strings))
 186         (setq font-lock-syntactic-face-function
 187               'context-coloring-font-lock-syntactic-comment-function)
 188         (setq saved-function-p t))
 189        ((and context-coloring-syntactic-strings
 190              (not context-coloring-syntactic-comments))
 191         (setq font-lock-syntactic-face-function
 192               'context-coloring-font-lock-syntactic-string-function)
 193         (setq saved-function-p t)))
 194       (save-excursion
 195         (font-lock-fontify-syntactically-region (point-min) (point-max)))
 196       (when saved-function-p
 197         (setq font-lock-syntactic-face-function old-function)))))
 198
 199
 200 ;;; js2-mode colorization
 201
 202 (defvar-local context-coloring-js2-scope-level-hash-table nil
 203   "Associate `js2-scope' structures and with their scope
 204   levels.")
 205
 206 (defcustom context-coloring-js-block-scopes nil
 207   "If non-nil, also color block scopes in the scope hierarchy in JavaScript.
 208
 209 The block-scoped `let' and `const' are introduced in ES6.  Enable
 210 this for ES6 code; disable it elsewhere.
 211
 212 Supported modes: `js2-mode'"
 213   :group 'context-coloring)
 214
 215 (defsubst context-coloring-js2-scope-level (scope)
 216   "Return the level of SCOPE."
 217   (cond ((gethash scope context-coloring-js2-scope-level-hash-table))
 218         (t
 219          (let ((level 0)
 220                (current-scope scope)
 221                enclosing-scope)
 222            (while (and current-scope
 223                        (js2-node-parent current-scope)
 224                        (setq enclosing-scope
 225                              (js2-node-get-enclosing-scope current-scope)))
 226              (when (or context-coloring-js-block-scopes
 227                        (let ((type (js2-scope-type current-scope)))
 228                          (or (= type js2-SCRIPT)
 229                              (= type js2-FUNCTION)
 230                              (= type js2-CATCH))))
 231                (setq level (+ level 1)))
 232              (setq current-scope enclosing-scope))
 233            (puthash scope level context-coloring-js2-scope-level-hash-table)))))
 234
 235 (defsubst context-coloring-js2-local-name-node-p (node)
 236   "Determine if NODE is a `js2-name-node' representing a local
 237 variable."
 238   (and (js2-name-node-p node)
 239        (let ((parent (js2-node-parent node)))
 240          (not (or (and (js2-object-prop-node-p parent)
 241                        (eq node (js2-object-prop-node-left parent)))
 242                   (and (js2-prop-get-node-p parent)
 243                        ;; For nested property lookup, the node on the left is a
 244                        ;; `js2-prop-get-node', so this always works.
 245                        (eq node (js2-prop-get-node-right parent))))))))
 246
 247 (defvar-local context-coloring-point-max nil
 248   "Cached value of `point-max'.")
 249
 250 (defsubst context-coloring-js2-colorize-node (node level)
 251   "Color NODE with the color for LEVEL."
 252   (let ((start (js2-node-abs-pos node)))
 253     (context-coloring-colorize-region
 254      start
 255      (min
 256       ;; End
 257       (+ start (js2-node-len node))
 258       ;; Somes nodes (like the ast when there is an unterminated multiline
 259       ;; comment) will stretch to the value of `point-max'.
 260       context-coloring-point-max)
 261      level)))
 262
 263 (defun context-coloring-js2-colorize ()
 264   "Color the current buffer using the abstract syntax tree
 265 generated by `js2-mode'."
 266   ;; Reset the hash table; the old one could be obsolete.
 267   (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test 'eq))
 268   (setq context-coloring-point-max (point-max))
 269   (with-silent-modifications
 270     (js2-visit-ast
 271      js2-mode-ast
 272      (lambda (node end-p)
 273        (when (null end-p)
 274          (cond
 275           ((js2-scope-p node)
 276            (context-coloring-js2-colorize-node
 277             node
 278             (context-coloring-js2-scope-level node)))
 279           ((context-coloring-js2-local-name-node-p node)
 280            (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
 281                   (defining-scope (js2-get-defining-scope
 282                                    enclosing-scope
 283                                    (js2-name-node-name node))))
 284              ;; The tree seems to be walked lexically, so an entire scope will
 285              ;; be colored, including its name nodes, before they are reached.
 286              ;; Coloring the nodes defined in that scope would be redundant, so
 287              ;; don't do it.
 288              (when (not (eq defining-scope enclosing-scope))
 289                (context-coloring-js2-colorize-node
 290                 node
 291                 (context-coloring-js2-scope-level defining-scope))))))
 292          ;; The `t' indicates to search children.
 293          t)))
 294     (context-coloring-maybe-colorize-comments-and-strings)))
 295
 296
 297 ;;; Emacs Lisp colorization
 298
 299 (defun context-coloring-make-scope (depth level)
 300   (list
 301    :depth depth
 302    :level level
 303    :variables (make-hash-table)))
 304
 305 (defun context-coloring-scope-get-depth (scope)
 306   (plist-get scope :depth))
 307
 308 (defun context-coloring-scope-get-level (scope)
 309   (plist-get scope :level))
 310
 311 (defun context-coloring-scope-add-variable (scope variable)
 312   (puthash variable t (plist-get scope :variables)))
 313
 314 (defun context-coloring-scope-get-variable (scope variable)
 315   (gethash variable (plist-get scope :variables)))
 316
 317 (defun context-coloring-get-variable-level (scope-stack variable)
 318   (let* (scope
 319          level)
 320     (while (and scope-stack (not level))
 321       (setq scope (car scope-stack))
 322       (cond
 323        ((context-coloring-scope-get-variable scope variable)
 324         (setq level (context-coloring-scope-get-level scope)))
 325        (t
 326         (setq scope-stack (cdr scope-stack)))))
 327     ;; Assume global
 328     (or level 0)))
 329
 330 (defun context-coloring-make-backtick (end enabled)
 331   (list
 332    :end end
 333    :enabled enabled))
 334
 335 (defun context-coloring-backtick-get-end (backtick)
 336   (plist-get backtick :end))
 337
 338 (defun context-coloring-backtick-get-enabled (backtick)
 339   (plist-get backtick :enabled))
 340
 341 (defun context-coloring-backtick-enabled-p (backtick-stack)
 342   (context-coloring-backtick-get-enabled (car backtick-stack)))
 343
 344 (defun context-coloring-make-let-value (end)
 345   (list
 346    :end end))
 347
 348 (defun context-coloring-let-value-get-end (let-value)
 349   (plist-get let-value :end))
 350
 351 (defun context-coloring-emacs-lisp-identifier-syntax-p (syntax-code)
 352   (or (= 2 syntax-code)
 353       (= 3 syntax-code)))
 354
 355 (defun context-coloring-forward-sws ()
 356   "Move forward through whitespace and comments."
 357   (while (forward-comment 1)))
 358
 359 (defun context-coloring-at-open-parenthesis ()
 360   (= 4 (logand #xFFFF (car (syntax-after (point))))))
 361
 362 (defun context-coloring-emacs-lisp-colorize ()
 363   "Color the current buffer by parsing emacs lisp sexps."
 364   (with-silent-modifications
 365     (save-excursion
 366       ;; TODO: Can probably make this lazy to the nearest defun
 367       (goto-char (point-min))
 368       (let* ((inhibit-point-motion-hooks t)
 369              (end (point-max))
 370              (last-ppss-pos (point))
 371              (ppss (syntax-ppss))
 372              (scope-stack `(,(context-coloring-make-scope -1 0))) ; -1 never matches a depth
 373              (backtick-stack `(,(context-coloring-make-backtick -1 nil)))
 374              (let-value-stack `(,(context-coloring-make-let-value -1)))
 375              one-word-found-p
 376              in-defun-p
 377              in-lambda-p
 378              in-let-p
 379              in-let*-p
 380              defun-arglist
 381              defun-arg
 382              let-varlist
 383              let-var
 384              variable
 385              variable-end
 386              variable-string
 387              variable-scope-level
 388              token-pos
 389              token-syntax
 390              token-syntax-code
 391              token-char
 392              child-0-pos
 393              child-0-end
 394              child-0-syntax
 395              child-0-syntax-code
 396              child-0-string
 397              child-1-pos
 398              child-1-end
 399              child-1-syntax
 400              child-1-syntax-code
 401              child-2-end)
 402         (while (> end (progn (skip-syntax-forward "^()w_'" end)
 403                              (point)))
 404           (setq token-pos (point))
 405           (setq token-syntax (syntax-after token-pos))
 406           (setq ppss (parse-partial-sexp last-ppss-pos token-pos nil nil ppss))
 407           (setq last-ppss-pos token-pos)
 408           ;; `skip-syntax-forward' leaves the point at the delimiter, move past
 409           ;; it.
 410           (setq token-syntax-code (logand #xFFFF (car token-syntax)))
 411           (setq token-char (string-to-char (buffer-substring-no-properties
 412                                             token-pos
 413                                             (1+ token-pos))))
 414           (cond
 415
 416            ;; Resolve invalid state
 417            ((cond
 418              ;; Inside string?
 419              ((nth 3 ppss)
 420               (skip-syntax-forward "^\"" end)
 421               (forward-char)
 422               t)
 423              ;; Inside comment?
 424              ((nth 4 ppss)
 425               (skip-syntax-forward "^>" end) ; comment ender
 426               t)))
 427
 428            ;; Expression prefix
 429            ;; Has to come first in case of commas
 430            ((= 6 token-syntax-code)
 431             (forward-char)
 432             (cond
 433              ;; Just outright skip top-level symbols
 434              ((not (or (cadr backtick-stack)
 435                        (= token-char 96))) ; 96 = '`'
 436               (goto-char (scan-sexps (point) 1)))
 437              ((or (= token-char 96)  ; 96 = '`'
 438                   (= token-char 44)) ; 44 = ','
 439               ;; Have to manage backticks
 440               (setq backtick-stack (cons (context-coloring-make-backtick
 441                                           (scan-sexps (point) 1) ; End of the backtick
 442                                           (= token-char 96)) ; 96 = '`'
 443                                          backtick-stack)))))
 444
 445            ;; End backtick
 446            ((and (cadr backtick-stack)
 447                  (>= (point) (context-coloring-backtick-get-end (car backtick-stack))))
 448             (setq backtick-stack (cdr backtick-stack)))
 449
 450            ;; Restricted by backtick
 451            ((and (cadr backtick-stack)
 452                  (context-coloring-backtick-enabled-p backtick-stack))
 453             (forward-char))
 454
 455            ;; Opening delimiter
 456            ((= 4 token-syntax-code)
 457             (forward-char)
 458             ;; Lookahead for scopes / function calls
 459             (context-coloring-forward-sws)
 460             (setq child-0-pos (point))
 461             (setq child-0-syntax (syntax-after child-0-pos))
 462             (setq child-0-syntax-code (logand #xFFFF (car child-0-syntax)))
 463             (cond
 464              ;; Word
 465              ((context-coloring-emacs-lisp-identifier-syntax-p child-0-syntax-code)
 466               (setq one-word-found-p t)
 467               (setq child-0-end (scan-sexps child-0-pos 1))
 468               (setq child-0-string (buffer-substring-no-properties child-0-pos child-0-end))
 469               (cond
 470                ((string-match-p
 471                  "\\`defun\\'\\|\\`defmacro\\'\\|\\`defsubst\\'"
 472                  child-0-string)
 473                 (setq in-defun-p t))
 474                ((string-match-p "\\`lambda\\'" child-0-string)
 475                 (setq in-lambda-p t))
 476                ((string-match-p "\\`let\\'" child-0-string)
 477                 (setq in-let-p t))
 478                ((string-match-p "\\`let\\*\\'" child-0-string)
 479                 (setq in-let*-p t)))))
 480             (when (or in-defun-p
 481                       in-lambda-p
 482                       in-let-p
 483                       in-let*-p)
 484               (setq scope-stack (cons (context-coloring-make-scope
 485                                        (nth 0 ppss)
 486                                        (1+ (context-coloring-scope-get-level
 487                                             (car scope-stack))))
 488                                       scope-stack)))
 489             ;; TODO: Probably redundant and wasteful
 490             (context-coloring-colorize-region token-pos
 491                                               (scan-sexps token-pos 1)
 492                                               (context-coloring-scope-get-level
 493                                                (car scope-stack)))
 494             (cond
 495              ((or in-defun-p
 496                   in-lambda-p)
 497               (goto-char child-0-end)
 498               (when in-defun-p
 499                 ;; Lookahead for defun name
 500                 (context-coloring-forward-sws)
 501                 (setq child-1-pos (point))
 502                 (setq child-1-syntax (syntax-after child-1-pos))
 503                 (setq child-1-syntax-code (logand #xFFFF (car child-1-syntax)))
 504                 (cond
 505                  ;; Word
 506                  ((context-coloring-emacs-lisp-identifier-syntax-p child-1-syntax-code)
 507                   (setq child-1-end (scan-sexps child-1-pos 1))
 508                   ;; defuns are global so use level 0
 509                   (context-coloring-colorize-region child-1-pos child-1-end 0)
 510                   (goto-char child-1-end))))
 511               ;; Lookahead for parameters
 512               (context-coloring-forward-sws)
 513               (when (context-coloring-at-open-parenthesis)
 514                 ;; Actually it should be `child-1-end' for `lambda'.
 515                 (setq child-2-end (scan-sexps (point) 1))
 516                 (setq defun-arglist (read (buffer-substring-no-properties
 517                                            (point)
 518                                            child-2-end)))
 519                 (while defun-arglist
 520                   (setq defun-arg (car defun-arglist))
 521                   (when (and (symbolp defun-arg)
 522                              (string-match-p "\\`[^&:]" (symbol-name defun-arg)))
 523                     (context-coloring-scope-add-variable
 524                      (car scope-stack)
 525                      defun-arg))
 526                   (setq defun-arglist (cdr defun-arglist)))
 527                 (goto-char child-2-end))
 528               ;; Cleanup
 529               (setq in-defun-p nil)
 530               (setq in-lambda-p nil))
 531              ((or in-let-p
 532                   in-let*-p)
 533               (goto-char child-0-end)
 534               ;; Lookahead for bindings
 535               (context-coloring-forward-sws)
 536               (setq child-1-pos (point))
 537               (setq child-1-syntax (syntax-after child-1-pos))
 538               (setq child-1-syntax-code (logand #xFFFF (car child-1-syntax)))
 539               (when (= 4 child-1-syntax-code)
 540                 (setq child-1-end (scan-sexps (point) 1))
 541                 (setq let-varlist (read (buffer-substring-no-properties
 542                                          (point)
 543                                          child-1-end)))
 544                 (while let-varlist
 545                   (setq let-var (car let-varlist))
 546                   (cond
 547                    ((symbolp let-var)
 548                     (context-coloring-scope-add-variable
 549                      (car scope-stack)
 550                      let-var))
 551                    ((listp let-var)
 552                     (context-coloring-scope-add-variable
 553                      (car scope-stack)
 554                      (car let-var))
 555                     ;; TODO: Recurse or use stack to eval var value
 556                     ))
 557                   (setq let-varlist (cdr let-varlist)))
 558                 (goto-char child-1-end))
 559               ;; Cleanup
 560               (setq in-let-p nil)
 561               (setq in-let*-p nil))
 562              (t
 563               (goto-char (cond
 564                           ;; If there was a word, continue parsing after it.
 565                           (one-word-found-p
 566                            (1+ child-0-end))
 567                           (t
 568                            (1+ token-pos))))))
 569             ;; Cleanup
 570             (setq one-word-found-p nil))
 571
 572            ;; Word (variable)
 573            ((context-coloring-emacs-lisp-identifier-syntax-p token-syntax-code)
 574             (setq variable-end (scan-sexps (point) 1))
 575             (setq variable-string (buffer-substring-no-properties
 576                                    token-pos
 577                                    variable-end))
 578             (cond
 579              ;; Ignore constants such as numbers, keywords, t, nil. These can't
 580              ;; be rebound, so they should be treated like syntax.
 581              ((string-match-p "\\`[-+]?[0-9]\\|\\`t\\'\\|\\`nil\\'" variable-string))
 582              ((keywordp (read variable-string)))
 583              (t
 584               (setq variable (intern variable-string))
 585               (setq variable-scope-level
 586                     (context-coloring-get-variable-level scope-stack variable))
 587               (when (/= variable-scope-level (context-coloring-scope-get-level
 588                                               (car scope-stack)))
 589                 (context-coloring-colorize-region
 590                  token-pos
 591                  variable-end
 592                  variable-scope-level))))
 593             (goto-char variable-end))
 594
 595            ;; Closing delimiter
 596            ((= 5 token-syntax-code)
 597             (forward-char)
 598             ;; End scope
 599             (setq ppss (parse-partial-sexp last-ppss-pos (point) nil nil ppss))
 600             (setq last-ppss-pos (point))
 601             (when (= (nth 0 ppss) (context-coloring-scope-get-depth (car scope-stack)))
 602               (setq scope-stack (cdr scope-stack))))
 603
 604            ))))
 605     (context-coloring-maybe-colorize-comments-and-strings)))
 606
 607
 608 ;;; Shell command scopification / colorization
 609
 610 (defun context-coloring-apply-tokens (tokens)
 611   "Process a vector of TOKENS to apply context-based coloring to
 612 the current buffer.  Tokens are 3 integers: start, end, level.
 613 The vector is flat, with a new token occurring after every 3rd
 614 element."
 615   (with-silent-modifications
 616     (let ((i 0)
 617           (len (length tokens)))
 618       (while (< i len)
 619         (context-coloring-colorize-region
 620          (elt tokens i)
 621          (elt tokens (+ i 1))
 622          (elt tokens (+ i 2)))
 623         (setq i (+ i 3))))
 624     (context-coloring-maybe-colorize-comments-and-strings)))
 625
 626 (defun context-coloring-parse-array (array)
 627   "Parse ARRAY as a flat JSON array of numbers."
 628   (let ((braceless (substring (context-coloring-trim array) 1 -1)))
 629     (cond
 630      ((> (length braceless) 0)
 631       (vconcat
 632        (mapcar 'string-to-number (split-string braceless ","))))
 633      (t
 634       (vector)))))
 635
 636 (defvar-local context-coloring-scopifier-process nil
 637   "The single scopifier process that can be running.")
 638
 639 (defun context-coloring-kill-scopifier ()
 640   "Kill the currently-running scopifier process."
 641   (when (not (null context-coloring-scopifier-process))
 642     (delete-process context-coloring-scopifier-process)
 643     (setq context-coloring-scopifier-process nil)))
 644
 645 (defun context-coloring-scopify-shell-command (command callback)
 646   "Invoke a scopifier via COMMAND, read its response
 647 asynchronously and invoke CALLBACK with its output."
 648
 649   ;; Prior running tokenization is implicitly obsolete if this function is
 650   ;; called.
 651   (context-coloring-kill-scopifier)
 652
 653   ;; Start the process.
 654   (setq context-coloring-scopifier-process
 655         (start-process-shell-command "scopifier" nil command))
 656
 657   (let ((output ""))
 658
 659     ;; The process may produce output in multiple chunks.  This filter
 660     ;; accumulates the chunks into a message.
 661     (set-process-filter
 662      context-coloring-scopifier-process
 663      (lambda (_process chunk)
 664        (setq output (concat output chunk))))
 665
 666     ;; When the process's message is complete, this sentinel parses it as JSON
 667     ;; and applies the tokens to the buffer.
 668     (set-process-sentinel
 669      context-coloring-scopifier-process
 670      (lambda (_process event)
 671        (when (equal "finished\n" event)
 672          (funcall callback output))))))
 673
 674 (defun context-coloring-send-buffer-to-scopifier ()
 675   "Give the scopifier process its input so it can begin
 676 scopifying."
 677   (process-send-region
 678    context-coloring-scopifier-process
 679    (point-min) (point-max))
 680   (process-send-eof
 681    context-coloring-scopifier-process))
 682
 683 (defun context-coloring-scopify-and-colorize (command &optional callback)
 684   "Invoke a scopifier via COMMAND with the current buffer's contents,
 685 read the scopifier's response asynchronously and apply a parsed
 686 list of tokens to `context-coloring-apply-tokens'.
 687
 688 Invoke CALLBACK when complete."
 689   (let ((buffer context-coloring-buffer))
 690     (context-coloring-scopify-shell-command
 691      command
 692      (lambda (output)
 693        (let ((tokens (context-coloring-parse-array output)))
 694          (with-current-buffer buffer
 695            (context-coloring-apply-tokens tokens))
 696          (setq context-coloring-scopifier-process nil)
 697          (when callback (funcall callback))))))
 698   (context-coloring-send-buffer-to-scopifier))
 699
 700
 701 ;;; Dispatch
 702
 703 (defvar context-coloring-dispatch-hash-table (make-hash-table :test 'eq)
 704   "Map dispatch strategy names to their corresponding property
 705   lists, which contain details about the strategies.")
 706
 707 (defvar context-coloring-mode-hash-table (make-hash-table :test 'eq)
 708   "Map major mode names to dispatch property lists.")
 709
 710 (defun context-coloring-define-dispatch (symbol &rest properties)
 711   "Define a new dispatch named SYMBOL with PROPERTIES.
 712
 713 A \"dispatch\" is a property list describing a strategy for
 714 coloring a buffer.  There are three possible strategies: Parse
 715 and color in a single function (`:colorizer'), parse in a
 716 function that returns scope data (`:scopifier'), or parse with a
 717 shell command that returns scope data (`:command').  In the
 718 latter two cases, the scope data will be used to automatically
 719 color the buffer.
 720
 721 PROPERTIES must include `:modes' and one of `:colorizer',
 722 `:scopifier' or `:command'.
 723
 724 `:modes' - List of major modes this dispatch is valid for.
 725
 726 `:colorizer' - Symbol referring to a function that parses and
 727 colors the buffer.
 728
 729 `:scopifier' - Symbol referring to a function that parses the
 730 buffer a returns a flat vector of start, end and level data.
 731
 732 `:executable' - Optional name of an executable required by
 733 `:command'.
 734
 735 `:command' - Shell command to execute with the current buffer
 736 sent via stdin, and with a flat JSON array of start, end and
 737 level data returned via stdout.
 738
 739 `:version' - Minimum required version that should be printed when
 740 executing `:command' with a \"--version\" flag.  The version
 741 should be numeric, e.g. \"2\", \"19700101\", \"1.2.3\",
 742 \"v1.2.3\" etc.
 743
 744 `:setup' - Arbitrary code to set up this dispatch when
 745 `context-coloring-mode' is enabled.
 746
 747 `:teardown' - Arbitrary code to tear down this dispatch when
 748 `context-coloring-mode' is disabled."
 749   (let ((modes (plist-get properties :modes))
 750         (colorizer (plist-get properties :colorizer))
 751         (scopifier (plist-get properties :scopifier))
 752         (command (plist-get properties :command)))
 753     (when (null modes)
 754       (error "No mode defined for dispatch"))
 755     (when (not (or colorizer
 756                    scopifier
 757                    command))
 758       (error "No colorizer, scopifier or command defined for dispatch"))
 759     (puthash symbol properties context-coloring-dispatch-hash-table)
 760     (dolist (mode modes)
 761       (when (null (gethash mode context-coloring-mode-hash-table))
 762         (puthash mode properties context-coloring-mode-hash-table)))))
 763
 764 (context-coloring-define-dispatch
 765  'javascript-node
 766  :modes '(js-mode js3-mode)
 767  :executable "scopifier"
 768  :command "scopifier"
 769  :version "v1.1.1")
 770
 771 (context-coloring-define-dispatch
 772  'javascript-js2
 773  :modes '(js2-mode)
 774  :colorizer 'context-coloring-js2-colorize
 775  :setup
 776  (lambda ()
 777    (add-hook 'js2-post-parse-callbacks 'context-coloring-colorize nil t))
 778  :teardown
 779  (lambda ()
 780    (remove-hook 'js2-post-parse-callbacks 'context-coloring-colorize t)))
 781
 782 (context-coloring-define-dispatch
 783  'emacs-lisp
 784  :modes '(emacs-lisp-mode)
 785  :colorizer 'context-coloring-emacs-lisp-colorize)
 786
 787 (defun context-coloring-dispatch (&optional callback)
 788   "Determine the optimal track for scopification / coloring of
 789 the current buffer, then execute it.
 790
 791 Invoke CALLBACK when complete.  It is invoked synchronously for
 792 elisp tracks, and asynchronously for shell command tracks."
 793   (let ((dispatch (gethash major-mode context-coloring-mode-hash-table))
 794         colorizer
 795         scopifier
 796         command)
 797     (cond
 798      ((setq colorizer (plist-get dispatch :colorizer))
 799       (funcall colorizer)
 800       (when callback (funcall callback)))
 801      ((setq scopifier (plist-get dispatch :scopifier))
 802       (context-coloring-apply-tokens (funcall scopifier))
 803       (when callback (funcall callback)))
 804      ((setq command (plist-get dispatch :command))
 805       (context-coloring-scopify-and-colorize command callback)))))
 806
 807
 808 ;;; Colorization
 809
 810 (defvar context-coloring-colorize-hook nil
 811   "Hooks to run after coloring a buffer.")
 812
 813 (defun context-coloring-colorize (&optional callback)
 814   "Color the current buffer by function context.
 815
 816 Invoke CALLBACK when complete; see `context-coloring-dispatch'."
 817   (interactive)
 818   (context-coloring-dispatch
 819    (lambda ()
 820      (when callback (funcall callback))
 821      (run-hooks 'context-coloring-colorize-hook))))
 822
 823 (defvar-local context-coloring-changed nil
 824   "Indication that the buffer has changed recently, which implies
 825 that it should be colored again by
 826 `context-coloring-colorize-idle-timer' if that timer is being
 827 used.")
 828
 829 (defun context-coloring-change-function (_start _end _length)
 830   "Register a change so that a buffer can be colorized soon."
 831   ;; Tokenization is obsolete if there was a change.
 832   (context-coloring-kill-scopifier)
 833   (setq context-coloring-changed t))
 834
 835 (defun context-coloring-maybe-colorize ()
 836   "Colorize the current buffer if it has changed."
 837   (when (and (eq context-coloring-buffer (window-buffer (selected-window)))
 838              context-coloring-changed)
 839     (setq context-coloring-changed nil)
 840     (context-coloring-colorize)))
 841
 842
 843 ;;; Versioning
 844
 845 (defun context-coloring-parse-version (string)
 846   "Extract segments of a version STRING into a list.  \"v1.0.0\"
 847 produces (1 0 0), \"19700101\" produces (19700101), etc."
 848   (let (version)
 849     (while (string-match "[0-9]+" string)
 850       (setq version (append version
 851                             (list (string-to-number (match-string 0 string)))))
 852       (setq string (substring string (match-end 0))))
 853     version))
 854
 855 (defun context-coloring-check-version (expected actual)
 856   "Check that version EXPECTED is less than or equal to ACTUAL."
 857   (let ((expected (context-coloring-parse-version expected))
 858         (actual (context-coloring-parse-version actual))
 859         (continue t)
 860         (acceptable t))
 861     (while (and continue expected)
 862       (let ((an-expected (car expected))
 863             (an-actual (car actual)))
 864         (cond
 865          ((> an-actual an-expected)
 866           (setq acceptable t)
 867           (setq continue nil))
 868          ((< an-actual an-expected)
 869           (setq acceptable nil)
 870           (setq continue nil))))
 871       (setq expected (cdr expected))
 872       (setq actual (cdr actual)))
 873     acceptable))
 874
 875 (defvar context-coloring-check-scopifier-version-hook nil
 876   "Hooks to run after checking the scopifier version.")
 877
 878 (defun context-coloring-check-scopifier-version (&optional callback)
 879   "Asynchronously invoke CALLBACK with a predicate indicating
 880 whether the current scopifier version satisfies the minimum
 881 version number required for the current major mode."
 882   (let ((dispatch (gethash major-mode context-coloring-mode-hash-table)))
 883     (when dispatch
 884       (let ((version (plist-get dispatch :version))
 885             (command (plist-get dispatch :command)))
 886         (context-coloring-scopify-shell-command
 887          (context-coloring-join (list command "--version") " ")
 888          (lambda (output)
 889            (if (context-coloring-check-version version output)
 890                (progn
 891                  (when callback (funcall callback t)))
 892              (when callback (funcall callback nil)))
 893            (run-hooks 'context-coloring-check-scopifier-version-hook)))))))
 894
 895
 896 ;;; Themes
 897
 898 (defvar context-coloring-theme-hash-table (make-hash-table :test 'eq)
 899   "Map theme names to theme properties.")
 900
 901 (defun context-coloring-theme-p (theme)
 902   "Return t if THEME is defined, nil otherwise."
 903   (and (gethash theme context-coloring-theme-hash-table)))
 904
 905 (defconst context-coloring-level-face-regexp
 906   "context-coloring-level-\\([[:digit:]]+\\)-face"
 907   "Extract a level from a face.")
 908
 909 (defvar context-coloring-originally-set-theme-hash-table
 910   (make-hash-table :test 'eq)
 911   "Cache custom themes who originally set their own
 912   `context-coloring-level-N-face' faces.")
 913
 914 (defun context-coloring-theme-originally-set-p (theme)
 915   "Return t if there is a `context-coloring-level-N-face'
 916 originally set for THEME, nil otherwise."
 917   (let (originally-set)
 918     (cond
 919      ;; `setq' might return a non-nil value for the sake of this `cond'.
 920      ((setq
 921        originally-set
 922        (gethash
 923         theme
 924         context-coloring-originally-set-theme-hash-table))
 925       (eq originally-set 'yes))
 926      (t
 927       (let* ((settings (get theme 'theme-settings))
 928              (tail settings)
 929              found)
 930         (while (and tail (not found))
 931           (and (eq (nth 0 (car tail)) 'theme-face)
 932                (string-match
 933                 context-coloring-level-face-regexp
 934                 (symbol-name (nth 1 (car tail))))
 935                (setq found t))
 936           (setq tail (cdr tail)))
 937         found)))))
 938
 939 (defun context-coloring-cache-originally-set (theme originally-set)
 940   "Remember if THEME had colors originally set for it.  If
 941 ORIGINALLY-SET is non-nil, it did, otherwise it didn't."
 942   ;; Caching whether a theme was originally set is kind of dirty, but we have to
 943   ;; do it to remember the past state of the theme.  There are probably some
 944   ;; edge cases where caching will be an issue, but they are probably rare.
 945   (puthash
 946    theme
 947    (if originally-set 'yes 'no)
 948    context-coloring-originally-set-theme-hash-table))
 949
 950 (defun context-coloring-warn-theme-originally-set (theme)
 951   "Warn the user that the colors for THEME are already originally
 952 set."
 953   (warn "Context coloring colors for theme `%s' are already defined" theme))
 954
 955 (defun context-coloring-theme-highest-level (theme)
 956   "Return the highest level N of a face like
 957 `context-coloring-level-N-face' set for THEME, or `-1' if there
 958 is none."
 959   (let* ((settings (get theme 'theme-settings))
 960          (tail settings)
 961          face-string
 962          number
 963          (found -1))
 964     (while tail
 965       (and (eq (nth 0 (car tail)) 'theme-face)
 966            (setq face-string (symbol-name (nth 1 (car tail))))
 967            (string-match
 968             context-coloring-level-face-regexp
 969             face-string)
 970            (setq number (string-to-number
 971                          (substring face-string
 972                                     (match-beginning 1)
 973                                     (match-end 1))))
 974            (> number found)
 975            (setq found number))
 976       (setq tail (cdr tail)))
 977     found))
 978
 979 (defun context-coloring-apply-theme (theme)
 980   "Apply THEME's properties to its respective custom theme,
 981 which must already exist and which *should* already be enabled."
 982   (let* ((properties (gethash theme context-coloring-theme-hash-table))
 983          (colors (plist-get properties :colors))
 984          (level -1))
 985     ;; Only clobber when we have to.
 986     (when (custom-theme-enabled-p theme)
 987       (setq context-coloring-maximum-face (- (length colors) 1)))
 988     (apply
 989      'custom-theme-set-faces
 990      theme
 991      (mapcar
 992       (lambda (color)
 993         (setq level (+ level 1))
 994         `(,(context-coloring-level-face level) ((t (:foreground ,color)))))
 995       colors))))
 996
 997 (defun context-coloring-define-theme (theme &rest properties)
 998   "Define a context theme named THEME for coloring scope levels.
 999
1000 PROPERTIES is a property list specifiying the following details:
1001
1002 `:aliases': List of symbols of other custom themes that these
1003 colors are applicable to.
1004
1005 `:colors': List of colors that this context theme uses.
1006
1007 `:override': If non-nil, this context theme is intentionally
1008 overriding colors set by a custom theme.  Don't set this non-nil
1009 unless there is a custom theme you want to use which sets
1010 `context-coloring-level-N-face' faces that you want to replace.
1011
1012 `:recede': If non-nil, this context theme should not apply its
1013 colors if a custom theme already sets
1014 `context-coloring-level-N-face' faces.  This option is
1015 optimistic; set this non-nil if you would rather confer the duty
1016 of picking colors to a custom theme author (if / when he ever
1017 gets around to it).
1018
1019 By default, context themes will always override custom themes,
1020 even if those custom themes set `context-coloring-level-N-face'
1021 faces.  If a context theme does override a custom theme, a
1022 warning will be raised, at which point you may want to enable the
1023 `:override' option, or just delete your context theme and opt to
1024 use your custom theme's author's colors instead.
1025
1026 Context themes only work for the custom theme with the highest
1027 precedence, i.e. the car of `custom-enabled-themes'."
1028   (let ((aliases (plist-get properties :aliases))
1029         (override (plist-get properties :override))
1030         (recede (plist-get properties :recede)))
1031     (dolist (name (append `(,theme) aliases))
1032       (puthash name properties context-coloring-theme-hash-table)
1033       (when (custom-theme-p name)
1034         (let ((originally-set (context-coloring-theme-originally-set-p name)))
1035           (context-coloring-cache-originally-set name originally-set)
1036           ;; In the particular case when you innocently define colors that a
1037           ;; custom theme originally set, warn.  Arguably this only has to be
1038           ;; done at enable time, but it is probably more useful to do it at
1039           ;; definition time for prompter feedback.
1040           (when (and originally-set
1041                      (not recede)
1042                      (not override))
1043             (context-coloring-warn-theme-originally-set name))
1044           ;; Set (or overwrite) colors.
1045           (when (not (and originally-set
1046                           recede))
1047             (context-coloring-apply-theme name)))))))
1048
1049 (defun context-coloring-enable-theme (theme)
1050   "Apply THEME if its colors are not already set, else just set
1051 `context-coloring-maximum-face' to the correct value for THEME."
1052   (let* ((properties (gethash theme context-coloring-theme-hash-table))
1053          (recede (plist-get properties :recede))
1054          (override (plist-get properties :override)))
1055     (cond
1056      (recede
1057       (let ((highest-level (context-coloring-theme-highest-level theme)))
1058         (cond
1059          ;; This can be true whether originally set by a custom theme or by a
1060          ;; context theme.
1061          ((> highest-level -1)
1062           (setq context-coloring-maximum-face highest-level))
1063          ;; It is possible that the corresponding custom theme did not exist at
1064          ;; the time of defining this context theme, and in that case the above
1065          ;; condition proves the custom theme did not originally set any faces,
1066          ;; so we have license to apply the context theme for the first time
1067          ;; here.
1068          (t
1069           (context-coloring-apply-theme theme)))))
1070      (t
1071       (let ((originally-set (context-coloring-theme-originally-set-p theme)))
1072         ;; Cache now in case the context theme was defined after the custom
1073         ;; theme.
1074         (context-coloring-cache-originally-set theme originally-set)
1075         (when (and originally-set
1076                    (not override))
1077           (context-coloring-warn-theme-originally-set theme))
1078         (context-coloring-apply-theme theme))))))
1079
1080 (defadvice enable-theme (after context-coloring-enable-theme (theme) activate)
1081   "Enable colors for context themes just-in-time."
1082   (when (and (not (eq theme 'user)) ; Called internally by `enable-theme'.
1083              (custom-theme-p theme) ; Guard against non-existent themes.
1084              (context-coloring-theme-p theme))
1085     (when (= (length custom-enabled-themes) 1)
1086       ;; Cache because we can't reliably figure it out in reverse.
1087       (setq context-coloring-original-maximum-face
1088             context-coloring-maximum-face))
1089     (context-coloring-enable-theme theme)))
1090
1091 (defadvice disable-theme (after context-coloring-disable-theme (theme) activate)
1092   "Update `context-coloring-maximum-face'."
1093   (when (custom-theme-p theme) ; Guard against non-existent themes.
1094     (let ((enabled-theme (car custom-enabled-themes)))
1095       (if (context-coloring-theme-p enabled-theme)
1096           (progn
1097             (context-coloring-enable-theme enabled-theme))
1098         ;; Assume we are back to no theme; act as if nothing ever happened.
1099         ;; This is still prone to intervention, but rather extraordinarily.
1100         (setq context-coloring-maximum-face
1101               context-coloring-original-maximum-face)))))
1102
1103 (context-coloring-define-theme
1104  'ample
1105  :recede t
1106  :colors '("#bdbdb3"
1107            "#baba36"
1108            "#6aaf50"
1109            "#5180b3"
1110            "#ab75c3"
1111            "#cd7542"
1112            "#df9522"
1113            "#454545"))
1114
1115 (context-coloring-define-theme
1116  'anti-zenburn
1117  :recede t
1118  :colors '("#232333"
1119            "#6c1f1c"
1120            "#401440"
1121            "#0f2050"
1122            "#205070"
1123            "#336c6c"
1124            "#23733c"
1125            "#6b400c"
1126            "#603a60"
1127            "#2f4070"
1128            "#235c5c"))
1129
1130 (context-coloring-define-theme
1131  'grandshell
1132  :recede t
1133  :colors '("#bebebe"
1134            "#5af2ee"
1135            "#b2baf6"
1136            "#f09fff"
1137            "#efc334"
1138            "#f6df92"
1139            "#acfb5a"
1140            "#888888"))
1141
1142 (context-coloring-define-theme
1143  'leuven
1144  :recede t
1145  :colors '("#333333"
1146            "#0000ff"
1147            "#6434a3"
1148            "#ba36a5"
1149            "#d0372d"
1150            "#036a07"
1151            "#006699"
1152            "#006fe0"
1153            "#808080"))
1154
1155 (context-coloring-define-theme
1156  'monokai
1157  :recede t
1158  :colors '("#f8f8f2"
1159            "#66d9ef"
1160            "#a1efe4"
1161            "#a6e22e"
1162            "#e6db74"
1163            "#fd971f"
1164            "#f92672"
1165            "#fd5ff0"
1166            "#ae81ff"))
1167
1168 (context-coloring-define-theme
1169  'solarized
1170  :recede t
1171  :aliases '(solarized-light
1172             solarized-dark
1173             sanityinc-solarized-light
1174             sanityinc-solarized-dark)
1175  :colors '("#839496"
1176            "#268bd2"
1177            "#2aa198"
1178            "#859900"
1179            "#b58900"
1180            "#cb4b16"
1181            "#dc322f"
1182            "#d33682"
1183            "#6c71c4"
1184            "#69b7f0"
1185            "#69cabf"
1186            "#b4c342"
1187            "#deb542"
1188            "#f2804f"
1189            "#ff6e64"
1190            "#f771ac"
1191            "#9ea0e5"))
1192
1193 (context-coloring-define-theme
1194  'spacegray
1195  :recede t
1196  :colors '("#ffffff"
1197            "#89aaeb"
1198            "#c189eb"
1199            "#bf616a"
1200            "#dca432"
1201            "#ebcb8b"
1202            "#b4eb89"
1203            "#89ebca"))
1204
1205 (context-coloring-define-theme
1206  'tango
1207  :recede t
1208  :colors '("#2e3436"
1209            "#346604"
1210            "#204a87"
1211            "#5c3566"
1212            "#a40000"
1213            "#b35000"
1214            "#c4a000"
1215            "#8ae234"
1216            "#8cc4ff"
1217            "#ad7fa8"
1218            "#ef2929"
1219            "#fcaf3e"
1220            "#fce94f"))
1221
1222 (context-coloring-define-theme
1223  'zenburn
1224  :recede t
1225  :colors '("#dcdccc"
1226            "#93e0e3"
1227            "#bfebbf"
1228            "#f0dfaf"
1229            "#dfaf8f"
1230            "#cc9393"
1231            "#dc8cc3"
1232            "#94bff3"
1233            "#9fc59f"
1234            "#d0bf8f"
1235            "#dca3a3"))
1236
1237
1238 ;;; Minor mode
1239
1240 (defvar-local context-coloring-colorize-idle-timer nil
1241   "The currently-running idle timer.")
1242
1243 (defcustom context-coloring-delay 0.25
1244   "Delay between a buffer update and colorization.
1245
1246 Increase this if your machine is high-performing.  Decrease it if
1247 it ain't.
1248
1249 Supported modes: `js-mode', `js3-mode'"
1250   :group 'context-coloring)
1251
1252 (defun context-coloring-setup-idle-change-detection ()
1253   "Setup idle change detection."
1254   (add-hook
1255    'after-change-functions 'context-coloring-change-function nil t)
1256   (setq context-coloring-colorize-idle-timer
1257         (run-with-idle-timer
1258          context-coloring-delay
1259          t
1260          'context-coloring-maybe-colorize)))
1261
1262 ;;;###autoload
1263 (define-minor-mode context-coloring-mode
1264   "Context-based code coloring, inspired by Douglas Crockford."
1265   nil " Context" nil
1266   (if (not context-coloring-mode)
1267       (progn
1268         (context-coloring-kill-scopifier)
1269         (when context-coloring-colorize-idle-timer
1270           (cancel-timer context-coloring-colorize-idle-timer))
1271         (let ((dispatch (gethash major-mode context-coloring-mode-hash-table)))
1272           (when dispatch
1273             (let ((command (plist-get dispatch :command))
1274                   (teardown (plist-get dispatch :teardown)))
1275               (when command
1276                 (remove-hook
1277                  'after-change-functions 'context-coloring-change-function t))
1278               (when teardown
1279                 (funcall teardown)))))
1280         (font-lock-mode)
1281         (jit-lock-mode t))
1282
1283     ;; Remember this buffer.  This value should not be dynamically-bound.
1284     (setq context-coloring-buffer (current-buffer))
1285
1286     ;; Font lock is incompatible with this mode; the converse is also true.
1287     (font-lock-mode 0)
1288     (jit-lock-mode nil)
1289
1290     ;; Safely change the valye of this function as necessary.
1291     (make-local-variable 'font-lock-syntactic-face-function)
1292
1293     (let ((dispatch (gethash major-mode context-coloring-mode-hash-table)))
1294       (if dispatch
1295           (progn
1296             (let ((command (plist-get dispatch :command))
1297                   (version (plist-get dispatch :version))
1298                   (executable (plist-get dispatch :executable))
1299                   (setup (plist-get dispatch :setup))
1300                   (colorize-initially-p t))
1301               (when command
1302                 ;; Shell commands recolor on change, idly.
1303                 (cond
1304                  ((and executable
1305                        (null (executable-find executable)))
1306                   (message "Executable \"%s\" not found" executable)
1307                   (setq colorize-initially-p nil))
1308                  (version
1309                   (context-coloring-check-scopifier-version
1310                    (lambda (sufficient-p)
1311                      (if sufficient-p
1312                          (progn
1313                            (context-coloring-setup-idle-change-detection)
1314                            (context-coloring-colorize))
1315                        (message "Update to the minimum version of \"%s\" (%s)"
1316                                 executable version))))
1317                   (setq colorize-initially-p nil))
1318                  (t
1319                   (context-coloring-setup-idle-change-detection))))
1320               (when setup
1321                 (funcall setup))
1322               ;; Colorize once initially.
1323               (when colorize-initially-p
1324                 (context-coloring-colorize))))
1325         (when (null dispatch)
1326           (message "Context coloring is not available for this major mode"))))))
1327
1328 (provide 'context-coloring)
1329
1330 ;;; context-coloring.el ends here