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.3.0
   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 ;;; 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 (defsubst context-coloring-trim-right (string)
  47   "Remove leading whitespace from STRING."
  48   (if (string-match "[ \t\n\r]+\\'" string)
  49       (replace-match "" t t string)
  50     string))
  51
  52 (defsubst context-coloring-trim-left (string)
  53   "Remove trailing whitespace from STRING."
  54   (if (string-match "\\`[ \t\n\r]+" string)
  55       (replace-match "" t t string)
  56     string))
  57
  58 (defsubst context-coloring-trim (string)
  59   "Remove leading and trailing whitespace from STRING."
  60   (context-coloring-trim-left (context-coloring-trim-right string)))
  61
  62
  63 ;;; Faces
  64
  65 (defun context-coloring-defface (level tty light dark)
  66   "Define a face for LEVEL with colors for TTY, LIGHT and DARK
  67 backgrounds."
  68   (let ((face (intern (format "context-coloring-level-%s-face" level)))
  69         (doc (format "Context coloring face, level %s." level)))
  70     (custom-declare-face
  71      face
  72      `((((type tty)) (:foreground ,tty))
  73        (((background light)) (:foreground ,light))
  74        (((background dark)) (:foreground ,dark)))
  75      doc
  76      :group 'context-coloring)))
  77
  78 (defun context-coloring-defface-neutral (level)
  79   "Define a face for LEVEL with the default neutral colors."
  80   (context-coloring-defface level nil "#3f3f3f" "#cdcdcd"))
  81
  82 (context-coloring-defface 0 nil       "#000000" "#ffffff")
  83 (context-coloring-defface 1 "yellow"  "#008b8b" "#00ffff")
  84 (context-coloring-defface 2 "green"   "#0000ff" "#87cefa")
  85 (context-coloring-defface 3 "cyan"    "#483d8b" "#b0c4de")
  86 (context-coloring-defface 4 "blue"    "#a020f0" "#eedd82")
  87 (context-coloring-defface 5 "magenta" "#a0522d" "#98fb98")
  88 (context-coloring-defface 6 "red"     "#228b22" "#7fffd4")
  89 (context-coloring-defface-neutral 7)
  90
  91 (defvar context-coloring-maximum-face nil
  92   "Index of the highest face available for coloring.")
  93
  94 (defvar context-coloring-original-maximum-face nil
  95   "Fallback value for `context-coloring-maximum-face' when all
  96   themes have been disabled.")
  97
  98 (setq context-coloring-maximum-face 7)
  99
 100 (setq context-coloring-original-maximum-face
 101       context-coloring-maximum-face)
 102
 103 ;; Theme authors can have up to 26 levels: 1 (0th) for globals, 24 (1st-24th)
 104 ;; for nested levels, and 1 (25th) for infinity.
 105 (dotimes (number 18)
 106   (context-coloring-defface-neutral (+ number context-coloring-maximum-face 1)))
 107
 108
 109 ;;; Face functions
 110
 111 (defsubst context-coloring-level-face (level)
 112   "Return the symbol for a face with LEVEL."
 113   ;; `concat' is faster than `format' here.
 114   (intern-soft
 115    (concat "context-coloring-level-" (number-to-string level) "-face")))
 116
 117 (defsubst context-coloring-bounded-level-face (level)
 118   "Return the symbol for a face with LEVEL, bounded by
 119 `context-coloring-maximum-face'."
 120   (context-coloring-level-face (min level context-coloring-maximum-face)))
 121
 122
 123 ;;; Change detection
 124
 125 (defvar-local context-coloring-changed-p nil
 126   "Indication that the buffer has changed recently, which implies
 127 that it should be colored again by
 128 `context-coloring-colorize-idle-timer' if that timer is being
 129 used.")
 130
 131 (defvar-local context-coloring-changed-start nil
 132   "Beginning of last text that changed.")
 133
 134 (defvar-local context-coloring-changed-end nil
 135   "End of last text that changed.")
 136
 137 (defvar-local context-coloring-changed-length nil
 138   "Length of last text that changed.")
 139
 140 (defun context-coloring-change-function (start end length)
 141   "Register a change so that a buffer can be colorized soon."
 142   ;; Tokenization is obsolete if there was a change.
 143   (context-coloring-cancel-scopification)
 144   (setq context-coloring-changed-start start)
 145   (setq context-coloring-changed-end end)
 146   (setq context-coloring-changed-length length)
 147   (setq context-coloring-changed-p t))
 148
 149 (defun context-coloring-maybe-colorize (buffer)
 150   "Colorize the current buffer if it has changed."
 151   (when (and (eq buffer (current-buffer))
 152              context-coloring-changed-p)
 153     (context-coloring-colorize)
 154     (setq context-coloring-changed-p nil)
 155     (setq context-coloring-changed-start nil)
 156     (setq context-coloring-changed-end nil)
 157     (setq context-coloring-changed-length nil)))
 158
 159 (defvar-local context-coloring-colorize-idle-timer nil
 160   "The currently-running idle timer.")
 161
 162 (defcustom context-coloring-default-delay 0.25
 163   "Default (sometimes overridden) delay between a buffer update
 164 and colorization.
 165
 166 Increase this if your machine is high-performing.  Decrease it if
 167 it ain't.
 168
 169 Supported modes: `js-mode', `js3-mode'"
 170   :group 'context-coloring)
 171
 172 (make-obsolete-variable
 173  'context-coloring-delay
 174  'context-coloring-default-delay
 175  "6.4.0")
 176
 177 (defun context-coloring-setup-idle-change-detection ()
 178   "Setup idle change detection."
 179   (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
 180     (add-hook
 181      'after-change-functions #'context-coloring-change-function nil t)
 182     (add-hook
 183      'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
 184     (setq context-coloring-colorize-idle-timer
 185           (run-with-idle-timer
 186            (or (plist-get dispatch :delay) context-coloring-default-delay)
 187            t
 188            #'context-coloring-maybe-colorize
 189            (current-buffer)))))
 190
 191 (defun context-coloring-teardown-idle-change-detection ()
 192   "Teardown idle change detection."
 193   (context-coloring-cancel-scopification)
 194   (when context-coloring-colorize-idle-timer
 195     (cancel-timer context-coloring-colorize-idle-timer))
 196   (remove-hook
 197    'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
 198   (remove-hook
 199    'after-change-functions #'context-coloring-change-function t))
 200
 201
 202 ;;; Colorization utilities
 203
 204 (defsubst context-coloring-colorize-region (start end level)
 205   "Color characters from the 1-indexed START point (inclusive) to
 206 the END point (exclusive) with the face corresponding to LEVEL."
 207   (add-text-properties
 208    start
 209    end
 210    `(face ,(context-coloring-bounded-level-face level))))
 211
 212 (make-obsolete-variable
 213  'context-coloring-comments-and-strings
 214  "use `context-coloring-syntactic-comments' and
 215  `context-coloring-syntactic-strings' instead."
 216  "6.1.0")
 217
 218 (defcustom context-coloring-syntactic-comments t
 219   "If non-nil, also color comments using `font-lock'."
 220   :group 'context-coloring)
 221
 222 (defcustom context-coloring-syntactic-strings t
 223   "If non-nil, also color strings using `font-lock'."
 224   :group 'context-coloring)
 225
 226 (defun context-coloring-font-lock-syntactic-comment-function (state)
 227   "Tell `font-lock' to color a comment but not a string."
 228   (if (nth 3 state) nil font-lock-comment-face))
 229
 230 (defun context-coloring-font-lock-syntactic-string-function (state)
 231   "Tell `font-lock' to color a string but not a comment."
 232   (if (nth 3 state) font-lock-string-face nil))
 233
 234 (defsubst context-coloring-maybe-colorize-comments-and-strings (&optional min max)
 235   "Color the current buffer's comments or strings if
 236 `context-coloring-syntactic-comments' or
 237 `context-coloring-syntactic-strings' are non-nil."
 238   (when (or context-coloring-syntactic-comments
 239             context-coloring-syntactic-strings)
 240     (let ((min (or min (point-min)))
 241           (max (or max (point-max)))
 242           (font-lock-syntactic-face-function
 243            (cond
 244             ((and context-coloring-syntactic-comments
 245                   (not context-coloring-syntactic-strings))
 246              #'context-coloring-font-lock-syntactic-comment-function)
 247             ((and context-coloring-syntactic-strings
 248                   (not context-coloring-syntactic-comments))
 249              #'context-coloring-font-lock-syntactic-string-function)
 250             (t
 251              font-lock-syntactic-face-function))))
 252       (save-excursion
 253         (font-lock-fontify-syntactically-region min max)
 254         ;; TODO: Make configurable at the dispatch level.
 255         (when (eq major-mode 'emacs-lisp-mode)
 256           (font-lock-fontify-keywords-region min max))))))
 257
 258
 259 ;;; js2-mode colorization
 260
 261 (defvar-local context-coloring-js2-scope-level-hash-table nil
 262   "Associate `js2-scope' structures and with their scope
 263   levels.")
 264
 265 (defcustom context-coloring-js-block-scopes nil
 266   "If non-nil, also color block scopes in the scope hierarchy in JavaScript.
 267
 268 The block-scoped `let' and `const' are introduced in ES6.  Enable
 269 this for ES6 code; disable it elsewhere.
 270
 271 Supported modes: `js2-mode'"
 272   :group 'context-coloring)
 273
 274 (defsubst context-coloring-js2-scope-level (scope)
 275   "Return the level of SCOPE."
 276   (cond ((gethash scope context-coloring-js2-scope-level-hash-table))
 277         (t
 278          (let ((level 0)
 279                (current-scope scope)
 280                enclosing-scope)
 281            (while (and current-scope
 282                        (js2-node-parent current-scope)
 283                        (setq enclosing-scope
 284                              (js2-node-get-enclosing-scope current-scope)))
 285              (when (or context-coloring-js-block-scopes
 286                        (let ((type (js2-scope-type current-scope)))
 287                          (or (= type js2-SCRIPT)
 288                              (= type js2-FUNCTION)
 289                              (= type js2-CATCH))))
 290                (setq level (+ level 1)))
 291              (setq current-scope enclosing-scope))
 292            (puthash scope level context-coloring-js2-scope-level-hash-table)))))
 293
 294 (defsubst context-coloring-js2-local-name-node-p (node)
 295   "Determine if NODE is a `js2-name-node' representing a local
 296 variable."
 297   (and (js2-name-node-p node)
 298        (let ((parent (js2-node-parent node)))
 299          (not (or (and (js2-object-prop-node-p parent)
 300                        (eq node (js2-object-prop-node-left parent)))
 301                   (and (js2-prop-get-node-p parent)
 302                        ;; For nested property lookup, the node on the left is a
 303                        ;; `js2-prop-get-node', so this always works.
 304                        (eq node (js2-prop-get-node-right parent))))))))
 305
 306 (defvar-local context-coloring-point-max nil
 307   "Cached value of `point-max'.")
 308
 309 (defsubst context-coloring-js2-colorize-node (node level)
 310   "Color NODE with the color for LEVEL."
 311   (let ((start (js2-node-abs-pos node)))
 312     (context-coloring-colorize-region
 313      start
 314      (min
 315       ;; End
 316       (+ start (js2-node-len node))
 317       ;; Somes nodes (like the ast when there is an unterminated multiline
 318       ;; comment) will stretch to the value of `point-max'.
 319       context-coloring-point-max)
 320      level)))
 321
 322 (defun context-coloring-js2-colorize ()
 323   "Color the current buffer using the abstract syntax tree
 324 generated by `js2-mode'."
 325   ;; Reset the hash table; the old one could be obsolete.
 326   (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test #'eq))
 327   (setq context-coloring-point-max (point-max))
 328   (with-silent-modifications
 329     (js2-visit-ast
 330      js2-mode-ast
 331      (lambda (node end-p)
 332        (when (null end-p)
 333          (cond
 334           ((js2-scope-p node)
 335            (context-coloring-js2-colorize-node
 336             node
 337             (context-coloring-js2-scope-level node)))
 338           ((context-coloring-js2-local-name-node-p node)
 339            (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
 340                   (defining-scope (js2-get-defining-scope
 341                                    enclosing-scope
 342                                    (js2-name-node-name node))))
 343              ;; The tree seems to be walked lexically, so an entire scope will
 344              ;; be colored, including its name nodes, before they are reached.
 345              ;; Coloring the nodes defined in that scope would be redundant, so
 346              ;; don't do it.
 347              (when (not (eq defining-scope enclosing-scope))
 348                (context-coloring-js2-colorize-node
 349                 node
 350                 (context-coloring-js2-scope-level defining-scope))))))
 351          ;; The `t' indicates to search children.
 352          t)))
 353     (context-coloring-maybe-colorize-comments-and-strings)))
 354
 355
 356 ;;; Emacs Lisp colorization
 357
 358 (defsubst context-coloring-forward-sws ()
 359   "Move forward through whitespace and comments."
 360   (while (forward-comment 1)))
 361
 362 (defsubst context-coloring-elisp-forward-sws ()
 363   "Move forward through whitespace and comments, colorizing
 364 them along the way."
 365   (let ((start (point)))
 366     (context-coloring-forward-sws)
 367     (context-coloring-maybe-colorize-comments-and-strings start (point))))
 368
 369 (defsubst context-coloring-elisp-forward-sexp ()
 370   "Like `forward-sexp', but colorize comments and strings along
 371 the way."
 372   (let ((start (point)))
 373     (forward-sexp)
 374     (context-coloring-elisp-colorize-comments-and-strings-in-region
 375      start (point))))
 376
 377 (defsubst context-coloring-get-syntax-code ()
 378   (syntax-class
 379    ;; Faster version of `syntax-after':
 380    (aref (syntax-table) (char-after (point)))))
 381
 382 (defsubst context-coloring-exact-regexp (word)
 383   "Create a regexp that matches exactly WORD."
 384   (concat "\\`" (regexp-quote word) "\\'"))
 385
 386 (defsubst context-coloring-exact-or-regexp (words)
 387   "Create a regexp that matches any exact word in WORDS."
 388   (context-coloring-join
 389    (mapcar #'context-coloring-exact-regexp words) "\\|"))
 390
 391 (defconst context-coloring-elisp-defun-regexp
 392   (context-coloring-exact-or-regexp
 393    '("defun" "defun*" "defsubst" "defmacro"
 394      "cl-defun" "cl-defsubst" "cl-defmacro")))
 395
 396 (defconst context-coloring-elisp-condition-case-regexp
 397   (context-coloring-exact-or-regexp
 398    '("condition-case"
 399      "condition-case-unless-debug")))
 400
 401 (defconst context-coloring-ignored-word-regexp
 402   (context-coloring-join (list "\\`[-+]?[0-9]"
 403                                "\\`[&:].+"
 404                                (context-coloring-exact-or-regexp
 405                                 '("t" "nil" "." "?")))
 406                          "\\|"))
 407
 408 (defconst context-coloring-WORD-CODE 2)
 409 (defconst context-coloring-SYMBOL-CODE 3)
 410 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
 411 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
 412 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
 413 (defconst context-coloring-STRING-QUOTE-CODE 7)
 414 (defconst context-coloring-ESCAPE-CODE 9)
 415 (defconst context-coloring-COMMENT-START-CODE 11)
 416 (defconst context-coloring-COMMENT-END-CODE 12)
 417
 418 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
 419 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
 420 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
 421 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
 422 (defconst context-coloring-AT-CHAR (string-to-char "@"))
 423 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
 424
 425 (defvar context-coloring-parse-interruptable-p t
 426   "Set this to nil to force parse to continue until finished.")
 427
 428 (defconst context-coloring-elisp-sexps-per-pause 1000
 429   "Pause after this many iterations to check for user input.
 430 If user input is pending, stop the parse.  This makes for a
 431 smoother user experience for large files.")
 432
 433 (defvar context-coloring-elisp-sexp-count 0)
 434
 435 (defsubst context-coloring-elisp-increment-sexp-count ()
 436   (setq context-coloring-elisp-sexp-count
 437         (1+ context-coloring-elisp-sexp-count))
 438   (when (and (zerop (% context-coloring-elisp-sexp-count
 439                        context-coloring-elisp-sexps-per-pause))
 440              context-coloring-parse-interruptable-p
 441              (input-pending-p))
 442     (throw 'interrupted t)))
 443
 444 (defvar context-coloring-elisp-scope-stack '())
 445
 446 (defsubst context-coloring-elisp-make-scope (level)
 447   (list
 448    :level level
 449    :variables '()))
 450
 451 (defsubst context-coloring-elisp-scope-get-level (scope)
 452   (plist-get scope :level))
 453
 454 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
 455   (plist-put scope :variables (cons variable (plist-get scope :variables))))
 456
 457 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
 458   (member variable (plist-get scope :variables)))
 459
 460 (defsubst context-coloring-elisp-get-variable-level (variable)
 461   (let* ((scope-stack context-coloring-elisp-scope-stack)
 462          scope
 463          level)
 464     (while (and scope-stack (not level))
 465       (setq scope (car scope-stack))
 466       (cond
 467        ((context-coloring-elisp-scope-has-variable scope variable)
 468         (setq level (context-coloring-elisp-scope-get-level scope)))
 469        (t
 470         (setq scope-stack (cdr scope-stack)))))
 471     ;; Assume a global variable.
 472     (or level 0)))
 473
 474 (defsubst context-coloring-elisp-current-scope-level ()
 475   (cond
 476    ((car context-coloring-elisp-scope-stack)
 477     (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
 478    (t
 479     0)))
 480
 481 (defsubst context-coloring-elisp-push-scope ()
 482   (push (context-coloring-elisp-make-scope
 483          (1+ (context-coloring-elisp-current-scope-level)))
 484         context-coloring-elisp-scope-stack))
 485
 486 (defsubst context-coloring-elisp-pop-scope ()
 487   (pop context-coloring-elisp-scope-stack))
 488
 489 (defsubst context-coloring-elisp-add-variable (variable)
 490   (context-coloring-elisp-scope-add-variable
 491    (car context-coloring-elisp-scope-stack)
 492    variable))
 493
 494 (defsubst context-coloring-elisp-parse-arg (callback)
 495   (let* ((arg-string (buffer-substring-no-properties
 496                       (point)
 497                       (progn (context-coloring-elisp-forward-sexp)
 498                              (point)))))
 499     (when (not (string-match-p
 500                 context-coloring-ignored-word-regexp
 501                 arg-string))
 502       (funcall callback arg-string))))
 503
 504 (defun context-coloring-elisp-parse-let-varlist (type)
 505   (let ((varlist '())
 506         syntax-code)
 507     ;; Enter.
 508     (forward-char)
 509     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 510                context-coloring-CLOSE-PARENTHESIS-CODE)
 511       (cond
 512        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 513         (forward-char)
 514         (context-coloring-elisp-forward-sws)
 515         (setq syntax-code (context-coloring-get-syntax-code))
 516         (when (or (= syntax-code context-coloring-WORD-CODE)
 517                   (= syntax-code context-coloring-SYMBOL-CODE))
 518           (context-coloring-elisp-parse-arg
 519            (lambda (var)
 520              (push var varlist)))
 521           (context-coloring-elisp-forward-sws)
 522           (setq syntax-code (context-coloring-get-syntax-code))
 523           (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
 524             (context-coloring-elisp-colorize-sexp)))
 525         (context-coloring-elisp-forward-sws)
 526         ;; Skip past the closing parenthesis.
 527         (forward-char))
 528        ((or (= syntax-code context-coloring-WORD-CODE)
 529             (= syntax-code context-coloring-SYMBOL-CODE))
 530         (context-coloring-elisp-parse-arg
 531          (lambda (var)
 532            (push var varlist)))))
 533       (when (eq type 'let*)
 534         (context-coloring-elisp-add-variable (pop varlist)))
 535       (context-coloring-elisp-forward-sws))
 536     (when (eq type 'let)
 537       (while varlist
 538         (context-coloring-elisp-add-variable (pop varlist))))
 539     ;; Exit.
 540     (forward-char)))
 541
 542 (defun context-coloring-elisp-parse-arglist ()
 543   (let (syntax-code)
 544     ;; Enter.
 545     (forward-char)
 546     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 547                context-coloring-CLOSE-PARENTHESIS-CODE)
 548       (cond
 549        ((or (= syntax-code context-coloring-WORD-CODE)
 550             (= syntax-code context-coloring-SYMBOL-CODE))
 551         (context-coloring-elisp-parse-arg
 552          (lambda (arg)
 553            (context-coloring-elisp-add-variable arg))))
 554        (t
 555         (context-coloring-elisp-forward-sexp)))
 556       (context-coloring-elisp-forward-sws))
 557     ;; Exit.
 558     (forward-char)))
 559
 560 (defun context-coloring-elisp-colorize-defun-like (&optional anonymous-p
 561                                                              let-type)
 562   (let ((start (point))
 563         end
 564         stop
 565         syntax-code
 566         defun-name-pos
 567         defun-name-end)
 568     (context-coloring-elisp-push-scope)
 569     ;; Color the whole sexp.
 570     (forward-sexp)
 571     (setq end (point))
 572     (context-coloring-colorize-region
 573      start
 574      end
 575      (context-coloring-elisp-current-scope-level))
 576     (goto-char start)
 577     ;; Enter.
 578     (forward-char)
 579     (context-coloring-elisp-forward-sws)
 580     ;; Skip past the "defun".
 581     (forward-sexp)
 582     (context-coloring-elisp-forward-sws)
 583     (setq stop nil)
 584     (unless anonymous-p
 585       ;; Check for the defun's name.
 586       (setq syntax-code (context-coloring-get-syntax-code))
 587       (cond
 588        ((or (= syntax-code context-coloring-WORD-CODE)
 589             (= syntax-code context-coloring-SYMBOL-CODE))
 590         ;; Color the defun's name with the top-level color.
 591         (setq defun-name-pos (point))
 592         (forward-sexp)
 593         (setq defun-name-end (point))
 594         (context-coloring-colorize-region defun-name-pos defun-name-end 0)
 595         (context-coloring-elisp-forward-sws))
 596        (t
 597         (setq stop t))))
 598     (cond
 599      (stop
 600       ;; Skip it.
 601       (goto-char start)
 602       (context-coloring-elisp-forward-sexp))
 603      (t
 604       (setq syntax-code (context-coloring-get-syntax-code))
 605       (cond
 606        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 607         (cond
 608          (let-type
 609           (context-coloring-elisp-parse-let-varlist let-type))
 610          (t
 611           (context-coloring-elisp-parse-arglist)))
 612         ;; Colorize the rest of the function.
 613         (context-coloring-elisp-colorize-region (point) (1- end))
 614         ;; Exit the defun.
 615         (forward-char))
 616        (t
 617         ;; Skip it.
 618         (goto-char start)
 619         (context-coloring-elisp-forward-sexp)))))
 620     (context-coloring-elisp-pop-scope)))
 621
 622 (defun context-coloring-elisp-colorize-defun ()
 623   (context-coloring-elisp-colorize-defun-like))
 624
 625 (defun context-coloring-elisp-colorize-lambda ()
 626   (context-coloring-elisp-colorize-defun-like t))
 627
 628 (defun context-coloring-elisp-colorize-let ()
 629   (context-coloring-elisp-colorize-defun-like t 'let))
 630
 631 (defun context-coloring-elisp-colorize-let* ()
 632   (context-coloring-elisp-colorize-defun-like t 'let*))
 633
 634 (defun context-coloring-elisp-colorize-cond ()
 635   (let (syntax-code)
 636     ;; Enter.
 637     (forward-char)
 638     (context-coloring-elisp-forward-sws)
 639     ;; Skip past the "cond".
 640     (forward-sexp)
 641     (context-coloring-elisp-forward-sws)
 642     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 643                context-coloring-CLOSE-PARENTHESIS-CODE)
 644       (cond
 645        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 646         ;; Colorize inside the parens.
 647         (let ((start (point)))
 648           (forward-sexp)
 649           (context-coloring-elisp-colorize-region
 650            (1+ start) (1- (point)))
 651           ;; Exit.
 652           (forward-char)))
 653        (t
 654         (context-coloring-elisp-forward-sexp)))
 655       (context-coloring-elisp-forward-sws))
 656     ;; Exit.
 657     (forward-char)))
 658
 659 (defun context-coloring-elisp-colorize-condition-case ()
 660   (let ((start (point))
 661         end
 662         syntax-code
 663         variable
 664         case-pos
 665         case-end)
 666     (context-coloring-elisp-push-scope)
 667     ;; Color the whole sexp.
 668     (forward-sexp)
 669     (setq end (point))
 670     (context-coloring-colorize-region
 671      start
 672      end
 673      (context-coloring-elisp-current-scope-level))
 674     (goto-char start)
 675     ;; Enter.
 676     (forward-char)
 677     (context-coloring-elisp-forward-sws)
 678     ;; Skip past the "condition-case".
 679     (forward-sexp)
 680     (context-coloring-elisp-forward-sws)
 681     (setq syntax-code (context-coloring-get-syntax-code))
 682     ;; Gracefully ignore missing variables.
 683     (when (or (= syntax-code context-coloring-WORD-CODE)
 684               (= syntax-code context-coloring-SYMBOL-CODE))
 685       (context-coloring-elisp-parse-arg
 686        (lambda (parsed-variable)
 687          (setq variable parsed-variable)))
 688       (context-coloring-elisp-forward-sws))
 689     (context-coloring-elisp-colorize-sexp)
 690     (context-coloring-elisp-forward-sws)
 691     ;; Parse the handlers with the error variable in scope.
 692     (when variable
 693       (context-coloring-elisp-add-variable variable))
 694     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 695                context-coloring-CLOSE-PARENTHESIS-CODE)
 696       (cond
 697        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 698         (setq case-pos (point))
 699         (context-coloring-elisp-forward-sexp)
 700         (setq case-end (point))
 701         (goto-char case-pos)
 702         ;; Enter.
 703         (forward-char)
 704         (context-coloring-elisp-forward-sws)
 705         (setq syntax-code (context-coloring-get-syntax-code))
 706         (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
 707           ;; Skip the condition name(s).
 708           (context-coloring-elisp-forward-sexp)
 709           ;; Color the remaining portion of the handler.
 710           (context-coloring-elisp-colorize-region
 711            (point)
 712            (1- case-end)))
 713         ;; Exit.
 714         (forward-char))
 715        (t
 716         ;; Ignore artifacts.
 717         (context-coloring-elisp-forward-sexp)))
 718       (context-coloring-elisp-forward-sws))
 719     ;; Exit.
 720     (forward-char)
 721     (context-coloring-elisp-pop-scope)))
 722
 723 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
 724   (context-coloring-elisp-increment-sexp-count)
 725   (let* ((start (point))
 726          (end (progn (forward-sexp)
 727                      (point)))
 728          (syntax-code (progn (goto-char start)
 729                              (forward-char)
 730                              ;; Coloring is unnecessary here, it'll happen
 731                              ;; presently.
 732                              (context-coloring-forward-sws)
 733                              (context-coloring-get-syntax-code))))
 734     ;; Figure out if the sexp is a special form.
 735     (cond
 736      ((when (or (= syntax-code context-coloring-WORD-CODE)
 737                 (= syntax-code context-coloring-SYMBOL-CODE))
 738         (let ((name-string (buffer-substring-no-properties
 739                             (point)
 740                             (progn (forward-sexp)
 741                                    (point)))))
 742           (cond
 743            ((string-match-p context-coloring-elisp-defun-regexp name-string)
 744             (goto-char start)
 745             (context-coloring-elisp-colorize-defun)
 746             t)
 747            ((string-equal "let" name-string)
 748             (goto-char start)
 749             (context-coloring-elisp-colorize-let)
 750             t)
 751            ((string-equal "let*" name-string)
 752             (goto-char start)
 753             (context-coloring-elisp-colorize-let*)
 754             t)
 755            ((string-equal "lambda" name-string)
 756             (goto-char start)
 757             (context-coloring-elisp-colorize-lambda)
 758             t)
 759            ((string-equal "cond" name-string)
 760             (goto-char start)
 761             (context-coloring-elisp-colorize-cond)
 762             t)
 763            ((string-match-p context-coloring-elisp-condition-case-regexp name-string)
 764             (goto-char start)
 765             (context-coloring-elisp-colorize-condition-case)
 766             t)
 767            (t
 768             nil)))))
 769      ;; Not a special form; just colorize the remaining region.
 770      (t
 771       (context-coloring-colorize-region
 772        start
 773        end
 774        (context-coloring-elisp-current-scope-level))
 775       (context-coloring-elisp-colorize-region (point) (1- end))
 776       (forward-char)))))
 777
 778 (defun context-coloring-elisp-colorize-symbol ()
 779   (context-coloring-elisp-increment-sexp-count)
 780   (let* ((symbol-pos (point))
 781          (symbol-end (progn (forward-sexp)
 782                             (point)))
 783          (symbol-string (buffer-substring-no-properties
 784                          symbol-pos
 785                          symbol-end)))
 786     (cond
 787      ((string-match-p context-coloring-ignored-word-regexp symbol-string))
 788      (t
 789       (context-coloring-colorize-region
 790        symbol-pos
 791        symbol-end
 792        (context-coloring-elisp-get-variable-level
 793         symbol-string))))))
 794
 795 (defun context-coloring-elisp-colorize-expression-prefix ()
 796   (context-coloring-elisp-increment-sexp-count)
 797   (let ((char (char-after))
 798         start
 799         end)
 800     (cond
 801      ((or (= char context-coloring-APOSTROPHE-CHAR)
 802           (= char context-coloring-OCTOTHORPE-CHAR))
 803       (context-coloring-elisp-forward-sexp))
 804      ((= char context-coloring-BACKTICK-CHAR)
 805       (setq start (point))
 806       (setq end (progn (forward-sexp)
 807                        (point)))
 808       (goto-char start)
 809       (while (> end (progn (forward-char)
 810                            (point)))
 811         (setq char (char-after))
 812         (when (= char context-coloring-COMMA-CHAR)
 813           (forward-char)
 814           (when (= (char-after) context-coloring-AT-CHAR)
 815             ;; If we don't do this "@" could be interpreted as a symbol.
 816             (forward-char))
 817           (context-coloring-elisp-forward-sws)
 818           (context-coloring-elisp-colorize-sexp)))
 819       ;; We could probably do this as part of the above loop but it'd be
 820       ;; repetitive.
 821       (context-coloring-elisp-colorize-comments-and-strings-in-region
 822        start end)))))
 823
 824 (defun context-coloring-elisp-colorize-comment ()
 825   (context-coloring-elisp-increment-sexp-count)
 826   (context-coloring-elisp-forward-sws))
 827
 828 (defun context-coloring-elisp-colorize-string ()
 829   (context-coloring-elisp-increment-sexp-count)
 830   (let ((start (point)))
 831     (forward-sexp)
 832     (context-coloring-maybe-colorize-comments-and-strings
 833      start
 834      (point))))
 835
 836 (defun context-coloring-elisp-colorize-sexp ()
 837   (let ((syntax-code (context-coloring-get-syntax-code)))
 838     (cond
 839      ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 840       (context-coloring-elisp-colorize-parenthesized-sexp))
 841      ((or (= syntax-code context-coloring-WORD-CODE)
 842           (= syntax-code context-coloring-SYMBOL-CODE))
 843       (context-coloring-elisp-colorize-symbol))
 844      ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
 845       (context-coloring-elisp-colorize-expression-prefix))
 846      ((= syntax-code context-coloring-STRING-QUOTE-CODE)
 847       (context-coloring-elisp-colorize-string))
 848      ((= syntax-code context-coloring-ESCAPE-CODE)
 849       (forward-char 2))
 850      (t
 851       (forward-char)))))
 852
 853 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
 854   (let (syntax-code)
 855     (goto-char start)
 856     (while (> end (progn (skip-syntax-forward "^<\"\\" end)
 857                          (point)))
 858       (setq syntax-code (context-coloring-get-syntax-code))
 859       (cond
 860        ((= syntax-code context-coloring-STRING-QUOTE-CODE)
 861         (context-coloring-elisp-colorize-string))
 862        ((= syntax-code context-coloring-COMMENT-START-CODE)
 863         (context-coloring-elisp-colorize-comment))
 864        ((= syntax-code context-coloring-ESCAPE-CODE)
 865         (forward-char 2))
 866        (t
 867         (forward-char))))))
 868
 869 (defun context-coloring-elisp-colorize-region (start end)
 870   (let (syntax-code)
 871     (goto-char start)
 872     (while (> end (progn (skip-syntax-forward "^()w_'<\"\\" end)
 873                          (point)))
 874       (setq syntax-code (context-coloring-get-syntax-code))
 875       (cond
 876        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 877         (context-coloring-elisp-colorize-parenthesized-sexp))
 878        ((or (= syntax-code context-coloring-WORD-CODE)
 879             (= syntax-code context-coloring-SYMBOL-CODE))
 880         (context-coloring-elisp-colorize-symbol))
 881        ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
 882         (context-coloring-elisp-colorize-expression-prefix))
 883        ((= syntax-code context-coloring-STRING-QUOTE-CODE)
 884         (context-coloring-elisp-colorize-string))
 885        ((= syntax-code context-coloring-COMMENT-START-CODE)
 886         (context-coloring-elisp-colorize-comment))
 887        ((= syntax-code context-coloring-ESCAPE-CODE)
 888         (forward-char 2))
 889        (t
 890         (forward-char))))))
 891
 892 (defun context-coloring-elisp-colorize-region-initially (start end)
 893   (setq context-coloring-elisp-sexp-count 0)
 894   (setq context-coloring-elisp-scope-stack '())
 895   (let ((inhibit-point-motion-hooks t)
 896         (case-fold-search nil)
 897         ;; This is a recursive-descent parser, so give it a big stack.
 898         (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
 899         (max-specpdl-size (max max-specpdl-size 3000)))
 900     (context-coloring-elisp-colorize-region start end)))
 901
 902 (defun context-coloring-elisp-colorize ()
 903   "Color the current buffer, parsing elisp to determine its
 904 scopes and variables."
 905   (interactive)
 906   (with-silent-modifications
 907     (save-excursion
 908       (cond
 909        ;; Just colorize the changed region.
 910        (context-coloring-changed-p
 911         (let ((start (progn (goto-char context-coloring-changed-start)
 912                             (beginning-of-defun)
 913                             (point)))
 914               (end (progn (goto-char context-coloring-changed-end)
 915                           (end-of-defun)
 916                           (point))))
 917           (context-coloring-elisp-colorize-region-initially start end)))
 918        (t
 919         (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
 920
 921
 922 ;;; Shell command scopification / colorization
 923
 924 (defun context-coloring-apply-tokens (tokens)
 925   "Process a string of TOKENS to apply context-based coloring to
 926 the current buffer.  Tokens are 3 integers: start, end, level.  A
 927 new token occurrs after every 3rd element, and the elements are
 928 separated by commas."
 929   (let* ((tokens (mapcar #'string-to-number (split-string tokens ","))))
 930     (while tokens
 931       (context-coloring-colorize-region
 932        (pop tokens)
 933        (pop tokens)
 934        (pop tokens))))
 935   (context-coloring-maybe-colorize-comments-and-strings))
 936
 937 (defun context-coloring-parse-array (array)
 938   "Parse ARRAY as a flat JSON array of numbers and use the tokens
 939 to colorize the buffer."
 940   (let* ((braceless (substring-no-properties (context-coloring-trim array) 1 -1)))
 941     (when (> (length braceless) 0)
 942       (with-silent-modifications
 943         (context-coloring-apply-tokens braceless)))))
 944
 945 (defvar-local context-coloring-scopifier-cancel-function nil
 946   "Kills the current scopification process.")
 947
 948 (defvar-local context-coloring-scopifier-process nil
 949   "The single scopifier process that can be running.")
 950
 951 (defun context-coloring-cancel-scopification ()
 952   "Stop the currently-running scopifier from scopifying."
 953   (when context-coloring-scopifier-cancel-function
 954     (funcall context-coloring-scopifier-cancel-function)
 955     (setq context-coloring-scopifier-cancel-function nil))
 956   (when (not (null context-coloring-scopifier-process))
 957     (delete-process context-coloring-scopifier-process)
 958     (setq context-coloring-scopifier-process nil)))
 959
 960 (defun context-coloring-shell-command (command callback)
 961   "Invoke COMMAND, read its response asynchronously and invoke
 962 CALLBACK with its output.  Return the command process."
 963   (let ((process (start-process-shell-command "context-coloring-process" nil command))
 964         (output ""))
 965     ;; The process may produce output in multiple chunks.  This filter
 966     ;; accumulates the chunks into a message.
 967     (set-process-filter
 968      process
 969      (lambda (_process chunk)
 970        (setq output (concat output chunk))))
 971     ;; When the process's message is complete, this sentinel parses it as JSON
 972     ;; and applies the tokens to the buffer.
 973     (set-process-sentinel
 974      process
 975      (lambda (_process event)
 976        (when (equal "finished\n" event)
 977          (funcall callback output))))
 978     process))
 979
 980 (defun context-coloring-scopify-shell-command (command callback)
 981   "Invoke a scopifier via COMMAND, read its response
 982 asynchronously and invoke CALLBACK with its output."
 983   ;; Prior running tokenization is implicitly obsolete if this function is
 984   ;; called.
 985   (context-coloring-cancel-scopification)
 986   ;; Start the process.
 987   (setq context-coloring-scopifier-process
 988         (context-coloring-shell-command command callback)))
 989
 990 (defun context-coloring-send-buffer-to-scopifier ()
 991   "Give the scopifier process its input so it can begin
 992 scopifying."
 993   (process-send-region
 994    context-coloring-scopifier-process
 995    (point-min) (point-max))
 996   (process-send-eof
 997    context-coloring-scopifier-process))
 998
 999 (defun context-coloring-start-scopifier-server (command host port callback)
1000   (let* ((connect
1001           (lambda ()
1002             (let ((stream (open-network-stream "context-coloring-stream" nil host port)))
1003               (funcall callback stream)))))
1004     ;; Try to connect in case a server is running, otherwise start one.
1005     (condition-case nil
1006         (progn
1007           (funcall connect))
1008       (error
1009        (let ((server (start-process-shell-command
1010                       "context-coloring-scopifier-server" nil
1011                       (context-coloring-join
1012                        (list command
1013                              "--server"
1014                              "--host" host
1015                              "--port" (number-to-string port))
1016                        " ")))
1017              (output ""))
1018          ;; Connect as soon as the "listening" message is printed.
1019          (set-process-filter
1020           server
1021           (lambda (_process chunk)
1022             (setq output (concat output chunk))
1023             (when (string-match-p (format "^Scopifier listening at %s:%s$" host port) output)
1024               (funcall connect)))))))))
1025
1026 (defun context-coloring-send-buffer-to-scopifier-server (command host port callback)
1027   (context-coloring-start-scopifier-server
1028    command host port
1029    (lambda (process)
1030      (let* ((body (buffer-substring-no-properties (point-min) (point-max)))
1031             (header (concat "POST / HTTP/1.0\r\n"
1032                             "Host: localhost\r\n"
1033                             "Content-Type: application/x-www-form-urlencoded"
1034                             "; charset=UTF8\r\n"
1035                             (format "Content-Length: %d\r\n" (length body))
1036                             "\r\n"))
1037             (output "")
1038             (active t))
1039        (set-process-filter
1040         process
1041         (lambda (_process chunk)
1042           (setq output (concat output chunk))))
1043        (set-process-sentinel
1044         process
1045         (lambda (_process event)
1046           (when (and (equal "connection broken by remote peer\n" event)
1047                      active)
1048             ;; Strip the response headers.
1049             (string-match "\r\n\r\n" output)
1050             (setq output (substring-no-properties output (match-end 0)))
1051             (funcall callback output))))
1052        (process-send-string process (concat header body "\r\n"))
1053        (setq context-coloring-scopifier-cancel-function
1054              (lambda ()
1055                "Cancel this scopification."
1056                (setq active nil)))))))
1057
1058 (defun context-coloring-scopify-and-colorize-server (command host port &optional callback)
1059   "Contact or start a scopifier server via COMMAND at HOST and
1060 PORT with the current buffer's contents, read the scopifier's
1061 response asynchronously and apply a parsed list of tokens to
1062 `context-coloring-apply-tokens'.
1063
1064 Invoke CALLBACK when complete."
1065   (let ((buffer (current-buffer)))
1066     (context-coloring-send-buffer-to-scopifier-server
1067      command host port
1068      (lambda (output)
1069        (with-current-buffer buffer
1070          (context-coloring-parse-array output))
1071        (when callback (funcall callback))))))
1072
1073 (defun context-coloring-scopify-and-colorize (command &optional callback)
1074   "Invoke a scopifier via COMMAND with the current buffer's contents,
1075 read the scopifier's response asynchronously and apply a parsed
1076 list of tokens to `context-coloring-apply-tokens'.
1077
1078 Invoke CALLBACK when complete."
1079   (let ((buffer (current-buffer)))
1080     (context-coloring-scopify-shell-command
1081      command
1082      (lambda (output)
1083        (with-current-buffer buffer
1084          (context-coloring-parse-array output))
1085        (setq context-coloring-scopifier-process nil)
1086        (when callback (funcall callback)))))
1087   (context-coloring-send-buffer-to-scopifier))
1088
1089
1090 ;;; Dispatch
1091
1092 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
1093   "Map dispatch strategy names to their corresponding property
1094   lists, which contain details about the strategies.")
1095
1096 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
1097   "Map major mode names to dispatch property lists.")
1098
1099 (defun context-coloring-get-dispatch-for-mode (mode)
1100   "Return the dispatch for MODE (or a derivative mode)."
1101   (let ((parent mode)
1102         dispatch)
1103     (while (and parent
1104                 (not (setq dispatch (gethash parent context-coloring-mode-hash-table)))
1105                 (setq parent (get parent 'derived-mode-parent))))
1106     dispatch))
1107
1108 (defun context-coloring-define-dispatch (symbol &rest properties)
1109   "Define a new dispatch named SYMBOL with PROPERTIES.
1110
1111 A \"dispatch\" is a property list describing a strategy for
1112 coloring a buffer.  There are three possible strategies: Parse
1113 and color in a single function (`:colorizer'), parse with a shell
1114 command that returns scope data (`:command'), or parse with a
1115 server that returns scope data (`:command', `:host' and `:port').
1116 In the latter two cases, the scope data will be used to
1117 automatically color the buffer.
1118
1119 PROPERTIES must include `:modes' and one of `:colorizer',
1120 `:scopifier' or `:command'.
1121
1122 `:modes' - List of major modes this dispatch is valid for.
1123
1124 `:colorizer' - Symbol referring to a function that parses and
1125 colors the buffer.
1126
1127 `:executable' - Optional name of an executable required by
1128 `:command'.
1129
1130 `:command' - Shell command to execute with the current buffer
1131 sent via stdin, and with a flat JSON array of start, end and
1132 level data returned via stdout.
1133
1134 `:host' - Hostname of the scopifier server, e.g. \"localhost\".
1135
1136 `:port' - Port number of the scopifier server, e.g. 80, 1337.
1137
1138 `:delay' - Delay between buffer update and colorization, to
1139 override `context-coloring-default-delay'.
1140
1141 `:version' - Minimum required version that should be printed when
1142 executing `:command' with a \"--version\" flag.  The version
1143 should be numeric, e.g. \"2\", \"19700101\", \"1.2.3\",
1144 \"v1.2.3\" etc.
1145
1146 `:setup' - Arbitrary code to set up this dispatch when
1147 `context-coloring-mode' is enabled.
1148
1149 `:teardown' - Arbitrary code to tear down this dispatch when
1150 `context-coloring-mode' is disabled."
1151   (let ((modes (plist-get properties :modes))
1152         (colorizer (plist-get properties :colorizer))
1153         (command (plist-get properties :command)))
1154     (when (null modes)
1155       (error "No mode defined for dispatch"))
1156     (when (not (or colorizer
1157                    command))
1158       (error "No colorizer or command defined for dispatch"))
1159     (puthash symbol properties context-coloring-dispatch-hash-table)
1160     (dolist (mode modes)
1161       (puthash mode properties context-coloring-mode-hash-table))))
1162
1163
1164 ;;; Colorization
1165
1166 (defvar context-coloring-colorize-hook nil
1167   "Hooks to run after coloring a buffer.")
1168
1169 (defun context-coloring-colorize (&optional callback)
1170   "Color the current buffer by function context.
1171
1172 Invoke CALLBACK when complete; see `context-coloring-dispatch'."
1173   (interactive)
1174   (context-coloring-dispatch
1175    (lambda ()
1176      (when callback (funcall callback))
1177      (run-hooks 'context-coloring-colorize-hook))))
1178
1179
1180 ;;; Versioning
1181
1182 (defun context-coloring-parse-version (string)
1183   "Extract segments of a version STRING into a list.  \"v1.0.0\"
1184 produces (1 0 0), \"19700101\" produces (19700101), etc."
1185   (let (version)
1186     (while (string-match "[0-9]+" string)
1187       (setq version (append version
1188                             (list (string-to-number (match-string 0 string)))))
1189       (setq string (substring string (match-end 0))))
1190     version))
1191
1192 (defun context-coloring-check-version (expected actual)
1193   "Check that version EXPECTED is less than or equal to ACTUAL."
1194   (let ((expected (context-coloring-parse-version expected))
1195         (actual (context-coloring-parse-version actual))
1196         (continue t)
1197         (acceptable t))
1198     (while (and continue expected)
1199       (let ((an-expected (car expected))
1200             (an-actual (car actual)))
1201         (cond
1202          ((> an-actual an-expected)
1203           (setq acceptable t)
1204           (setq continue nil))
1205          ((< an-actual an-expected)
1206           (setq acceptable nil)
1207           (setq continue nil))))
1208       (setq expected (cdr expected))
1209       (setq actual (cdr actual)))
1210     acceptable))
1211
1212 (defvar context-coloring-check-scopifier-version-hook nil
1213   "Hooks to run after checking the scopifier version.")
1214
1215 (defun context-coloring-check-scopifier-version (&optional callback)
1216   "Asynchronously invoke CALLBACK with a predicate indicating
1217 whether the current scopifier version satisfies the minimum
1218 version number required for the current major mode."
1219   (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
1220     (when dispatch
1221       (let ((version (plist-get dispatch :version))
1222             (command (plist-get dispatch :command)))
1223         (context-coloring-shell-command
1224          (context-coloring-join (list command "--version") " ")
1225          (lambda (output)
1226            (if (context-coloring-check-version version output)
1227                (progn
1228                  (when callback (funcall callback t)))
1229              (when callback (funcall callback nil)))
1230            (run-hooks 'context-coloring-check-scopifier-version-hook)))))))
1231
1232
1233 ;;; Themes
1234
1235 (defvar context-coloring-theme-hash-table (make-hash-table :test #'eq)
1236   "Map theme names to theme properties.")
1237
1238 (defun context-coloring-theme-p (theme)
1239   "Return t if THEME is defined, nil otherwise."
1240   (and (gethash theme context-coloring-theme-hash-table)))
1241
1242 (defconst context-coloring-level-face-regexp
1243   "context-coloring-level-\\([[:digit:]]+\\)-face"
1244   "Extract a level from a face.")
1245
1246 (defvar context-coloring-originally-set-theme-hash-table
1247   (make-hash-table :test #'eq)
1248   "Cache custom themes who originally set their own
1249   `context-coloring-level-N-face' faces.")
1250
1251 (defun context-coloring-theme-originally-set-p (theme)
1252   "Return t if there is a `context-coloring-level-N-face'
1253 originally set for THEME, nil otherwise."
1254   (let (originally-set)
1255     (cond
1256      ;; `setq' might return a non-nil value for the sake of this `cond'.
1257      ((setq
1258        originally-set
1259        (gethash
1260         theme
1261         context-coloring-originally-set-theme-hash-table))
1262       (eq originally-set 'yes))
1263      (t
1264       (let* ((settings (get theme 'theme-settings))
1265              (tail settings)
1266              found)
1267         (while (and tail (not found))
1268           (and (eq (nth 0 (car tail)) 'theme-face)
1269                (string-match
1270                 context-coloring-level-face-regexp
1271                 (symbol-name (nth 1 (car tail))))
1272                (setq found t))
1273           (setq tail (cdr tail)))
1274         found)))))
1275
1276 (defun context-coloring-cache-originally-set (theme originally-set)
1277   "Remember if THEME had colors originally set for it.  If
1278 ORIGINALLY-SET is non-nil, it did, otherwise it didn't."
1279   ;; Caching whether a theme was originally set is kind of dirty, but we have to
1280   ;; do it to remember the past state of the theme.  There are probably some
1281   ;; edge cases where caching will be an issue, but they are probably rare.
1282   (puthash
1283    theme
1284    (if originally-set 'yes 'no)
1285    context-coloring-originally-set-theme-hash-table))
1286
1287 (defun context-coloring-warn-theme-originally-set (theme)
1288   "Warn the user that the colors for THEME are already originally
1289 set."
1290   (warn "Context coloring colors for theme `%s' are already defined" theme))
1291
1292 (defun context-coloring-theme-highest-level (theme)
1293   "Return the highest level N of a face like
1294 `context-coloring-level-N-face' set for THEME, or `-1' if there
1295 is none."
1296   (let* ((settings (get theme 'theme-settings))
1297          (tail settings)
1298          face-string
1299          number
1300          (found -1))
1301     (while tail
1302       (and (eq (nth 0 (car tail)) 'theme-face)
1303            (setq face-string (symbol-name (nth 1 (car tail))))
1304            (string-match
1305             context-coloring-level-face-regexp
1306             face-string)
1307            (setq number (string-to-number
1308                          (substring face-string
1309                                     (match-beginning 1)
1310                                     (match-end 1))))
1311            (> number found)
1312            (setq found number))
1313       (setq tail (cdr tail)))
1314     found))
1315
1316 (defun context-coloring-apply-theme (theme)
1317   "Apply THEME's properties to its respective custom theme,
1318 which must already exist and which *should* already be enabled."
1319   (let* ((properties (gethash theme context-coloring-theme-hash-table))
1320          (colors (plist-get properties :colors))
1321          (level -1))
1322     ;; Only clobber when we have to.
1323     (when (custom-theme-enabled-p theme)
1324       (setq context-coloring-maximum-face (- (length colors) 1)))
1325     (apply
1326      #'custom-theme-set-faces
1327      theme
1328      (mapcar
1329       (lambda (color)
1330         (setq level (+ level 1))
1331         `(,(context-coloring-level-face level) ((t (:foreground ,color)))))
1332       colors))))
1333
1334 (defun context-coloring-define-theme (theme &rest properties)
1335   "Define a context theme named THEME for coloring scope levels.
1336
1337 PROPERTIES is a property list specifiying the following details:
1338
1339 `:aliases': List of symbols of other custom themes that these
1340 colors are applicable to.
1341
1342 `:colors': List of colors that this context theme uses.
1343
1344 `:override': If non-nil, this context theme is intentionally
1345 overriding colors set by a custom theme.  Don't set this non-nil
1346 unless there is a custom theme you want to use which sets
1347 `context-coloring-level-N-face' faces that you want to replace.
1348
1349 `:recede': If non-nil, this context theme should not apply its
1350 colors if a custom theme already sets
1351 `context-coloring-level-N-face' faces.  This option is
1352 optimistic; set this non-nil if you would rather confer the duty
1353 of picking colors to a custom theme author (if / when he ever
1354 gets around to it).
1355
1356 By default, context themes will always override custom themes,
1357 even if those custom themes set `context-coloring-level-N-face'
1358 faces.  If a context theme does override a custom theme, a
1359 warning will be raised, at which point you may want to enable the
1360 `:override' option, or just delete your context theme and opt to
1361 use your custom theme's author's colors instead.
1362
1363 Context themes only work for the custom theme with the highest
1364 precedence, i.e. the car of `custom-enabled-themes'."
1365   (let ((aliases (plist-get properties :aliases))
1366         (override (plist-get properties :override))
1367         (recede (plist-get properties :recede)))
1368     (dolist (name (append `(,theme) aliases))
1369       (puthash name properties context-coloring-theme-hash-table)
1370       (when (custom-theme-p name)
1371         (let ((originally-set (context-coloring-theme-originally-set-p name)))
1372           (context-coloring-cache-originally-set name originally-set)
1373           ;; In the particular case when you innocently define colors that a
1374           ;; custom theme originally set, warn.  Arguably this only has to be
1375           ;; done at enable time, but it is probably more useful to do it at
1376           ;; definition time for prompter feedback.
1377           (when (and originally-set
1378                      (not recede)
1379                      (not override))
1380             (context-coloring-warn-theme-originally-set name))
1381           ;; Set (or overwrite) colors.
1382           (when (not (and originally-set
1383                           recede))
1384             (context-coloring-apply-theme name)))))))
1385
1386 (defun context-coloring-enable-theme (theme)
1387   "Apply THEME if its colors are not already set, else just set
1388 `context-coloring-maximum-face' to the correct value for THEME."
1389   (let* ((properties (gethash theme context-coloring-theme-hash-table))
1390          (recede (plist-get properties :recede))
1391          (override (plist-get properties :override)))
1392     (cond
1393      (recede
1394       (let ((highest-level (context-coloring-theme-highest-level theme)))
1395         (cond
1396          ;; This can be true whether originally set by a custom theme or by a
1397          ;; context theme.
1398          ((> highest-level -1)
1399           (setq context-coloring-maximum-face highest-level))
1400          ;; It is possible that the corresponding custom theme did not exist at
1401          ;; the time of defining this context theme, and in that case the above
1402          ;; condition proves the custom theme did not originally set any faces,
1403          ;; so we have license to apply the context theme for the first time
1404          ;; here.
1405          (t
1406           (context-coloring-apply-theme theme)))))
1407      (t
1408       (let ((originally-set (context-coloring-theme-originally-set-p theme)))
1409         ;; Cache now in case the context theme was defined after the custom
1410         ;; theme.
1411         (context-coloring-cache-originally-set theme originally-set)
1412         (when (and originally-set
1413                    (not override))
1414           (context-coloring-warn-theme-originally-set theme))
1415         (context-coloring-apply-theme theme))))))
1416
1417 (defadvice enable-theme (after context-coloring-enable-theme (theme) activate)
1418   "Enable colors for context themes just-in-time."
1419   (when (and (not (eq theme 'user)) ; Called internally by `enable-theme'.
1420              (custom-theme-p theme) ; Guard against non-existent themes.
1421              (context-coloring-theme-p theme))
1422     (when (= (length custom-enabled-themes) 1)
1423       ;; Cache because we can't reliably figure it out in reverse.
1424       (setq context-coloring-original-maximum-face
1425             context-coloring-maximum-face))
1426     (context-coloring-enable-theme theme)))
1427
1428 (defadvice disable-theme (after context-coloring-disable-theme (theme) activate)
1429   "Update `context-coloring-maximum-face'."
1430   (when (custom-theme-p theme) ; Guard against non-existent themes.
1431     (let ((enabled-theme (car custom-enabled-themes)))
1432       (if (context-coloring-theme-p enabled-theme)
1433           (progn
1434             (context-coloring-enable-theme enabled-theme))
1435         ;; Assume we are back to no theme; act as if nothing ever happened.
1436         ;; This is still prone to intervention, but rather extraordinarily.
1437         (setq context-coloring-maximum-face
1438               context-coloring-original-maximum-face)))))
1439
1440 (context-coloring-define-theme
1441  'ample
1442  :recede t
1443  :colors '("#bdbdb3"
1444            "#baba36"
1445            "#6aaf50"
1446            "#5180b3"
1447            "#ab75c3"
1448            "#cd7542"
1449            "#df9522"
1450            "#454545"))
1451
1452 (context-coloring-define-theme
1453  'anti-zenburn
1454  :recede t
1455  :colors '("#232333"
1456            "#6c1f1c"
1457            "#401440"
1458            "#0f2050"
1459            "#205070"
1460            "#336c6c"
1461            "#23733c"
1462            "#6b400c"
1463            "#603a60"
1464            "#2f4070"
1465            "#235c5c"))
1466
1467 (context-coloring-define-theme
1468  'grandshell
1469  :recede t
1470  :colors '("#bebebe"
1471            "#5af2ee"
1472            "#b2baf6"
1473            "#f09fff"
1474            "#efc334"
1475            "#f6df92"
1476            "#acfb5a"
1477            "#888888"))
1478
1479 (context-coloring-define-theme
1480  'leuven
1481  :recede t
1482  :colors '("#333333"
1483            "#0000ff"
1484            "#6434a3"
1485            "#ba36a5"
1486            "#d0372d"
1487            "#036a07"
1488            "#006699"
1489            "#006fe0"
1490            "#808080"))
1491
1492 (context-coloring-define-theme
1493  'monokai
1494  :recede t
1495  :colors '("#f8f8f2"
1496            "#66d9ef"
1497            "#a1efe4"
1498            "#a6e22e"
1499            "#e6db74"
1500            "#fd971f"
1501            "#f92672"
1502            "#fd5ff0"
1503            "#ae81ff"))
1504
1505 (context-coloring-define-theme
1506  'solarized
1507  :recede t
1508  :aliases '(solarized-light
1509             solarized-dark
1510             sanityinc-solarized-light
1511             sanityinc-solarized-dark)
1512  :colors '("#839496"
1513            "#268bd2"
1514            "#2aa198"
1515            "#859900"
1516            "#b58900"
1517            "#cb4b16"
1518            "#dc322f"
1519            "#d33682"
1520            "#6c71c4"
1521            "#69b7f0"
1522            "#69cabf"
1523            "#b4c342"
1524            "#deb542"
1525            "#f2804f"
1526            "#ff6e64"
1527            "#f771ac"
1528            "#9ea0e5"))
1529
1530 (context-coloring-define-theme
1531  'spacegray
1532  :recede t
1533  :colors '("#ffffff"
1534            "#89aaeb"
1535            "#c189eb"
1536            "#bf616a"
1537            "#dca432"
1538            "#ebcb8b"
1539            "#b4eb89"
1540            "#89ebca"))
1541
1542 (context-coloring-define-theme
1543  'tango
1544  :recede t
1545  :colors '("#2e3436"
1546            "#346604"
1547            "#204a87"
1548            "#5c3566"
1549            "#a40000"
1550            "#b35000"
1551            "#c4a000"
1552            "#8ae234"
1553            "#8cc4ff"
1554            "#ad7fa8"
1555            "#ef2929"
1556            "#fcaf3e"
1557            "#fce94f"))
1558
1559 (context-coloring-define-theme
1560  'zenburn
1561  :recede t
1562  :colors '("#dcdccc"
1563            "#93e0e3"
1564            "#bfebbf"
1565            "#f0dfaf"
1566            "#dfaf8f"
1567            "#cc9393"
1568            "#dc8cc3"
1569            "#94bff3"
1570            "#9fc59f"
1571            "#d0bf8f"
1572            "#dca3a3"))
1573
1574
1575 ;;; Built-in dispatches
1576
1577 (context-coloring-define-dispatch
1578  'javascript-node
1579  :modes '(js-mode js3-mode)
1580  :executable "scopifier"
1581  :command "scopifier"
1582  :version "v1.2.1"
1583  :host "localhost"
1584  :port 6969)
1585
1586 (context-coloring-define-dispatch
1587  'javascript-js2
1588  :modes '(js2-mode)
1589  :colorizer #'context-coloring-js2-colorize
1590  :setup
1591  (lambda ()
1592    (add-hook 'js2-post-parse-callbacks #'context-coloring-colorize nil t))
1593  :teardown
1594  (lambda ()
1595    (remove-hook 'js2-post-parse-callbacks #'context-coloring-colorize t)))
1596
1597 (context-coloring-define-dispatch
1598  'emacs-lisp
1599  :modes '(emacs-lisp-mode)
1600  :colorizer #'context-coloring-elisp-colorize
1601  :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
1602  :setup #'context-coloring-setup-idle-change-detection
1603  :teardown #'context-coloring-teardown-idle-change-detection)
1604
1605 (defun context-coloring-dispatch (&optional callback)
1606   "Determine the optimal track for scopification / coloring of
1607 the current buffer, then execute it.
1608
1609 Invoke CALLBACK when complete.  It is invoked synchronously for
1610 elisp tracks, and asynchronously for shell command tracks."
1611   (let* ((dispatch (context-coloring-get-dispatch-for-mode major-mode))
1612          (colorizer (plist-get dispatch :colorizer))
1613          (command (plist-get dispatch :command))
1614          (host (plist-get dispatch :host))
1615          (port (plist-get dispatch :port))
1616          interrupted-p)
1617     (cond
1618      (colorizer
1619       (setq interrupted-p
1620             (catch 'interrupted
1621               (funcall colorizer)))
1622       (when (and (not interrupted-p)
1623                  callback)
1624         (funcall callback)))
1625      (command
1626       (cond
1627        ((and host port)
1628         (context-coloring-scopify-and-colorize-server command host port callback))
1629        (t
1630         (context-coloring-scopify-and-colorize command callback)))))))
1631
1632
1633 ;;; Minor mode
1634
1635 ;;;###autoload
1636 (define-minor-mode context-coloring-mode
1637   "Context-based code coloring, inspired by Douglas Crockford."
1638   nil " Context" nil
1639   (if (not context-coloring-mode)
1640       (progn
1641         (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
1642           (when dispatch
1643             (let ((command (plist-get dispatch :command))
1644                   (teardown (plist-get dispatch :teardown)))
1645               (when command
1646                 (context-coloring-teardown-idle-change-detection))
1647               (when teardown
1648                 (funcall teardown)))))
1649         (font-lock-mode)
1650         (jit-lock-mode t))
1651
1652     ;; Font lock is incompatible with this mode; the converse is also true.
1653     (font-lock-mode 0)
1654     (jit-lock-mode nil)
1655
1656     ;; ...but we do use font-lock functions here.
1657     (font-lock-set-defaults)
1658
1659     ;; Safely change the value of this function as necessary.
1660     (make-local-variable 'font-lock-syntactic-face-function)
1661
1662     (let ((dispatch (context-coloring-get-dispatch-for-mode major-mode)))
1663       (if dispatch
1664           (progn
1665             (let ((command (plist-get dispatch :command))
1666                   (version (plist-get dispatch :version))
1667                   (executable (plist-get dispatch :executable))
1668                   (setup (plist-get dispatch :setup))
1669                   (colorize-initially-p t))
1670               (when command
1671                 ;; Shell commands recolor on change, idly.
1672                 (cond
1673                  ((and executable
1674                        (null (executable-find executable)))
1675                   (message "Executable \"%s\" not found" executable)
1676                   (setq colorize-initially-p nil))
1677                  (version
1678                   (context-coloring-check-scopifier-version
1679                    (lambda (sufficient-p)
1680                      (if sufficient-p
1681                          (progn
1682                            (context-coloring-setup-idle-change-detection)
1683                            (context-coloring-colorize))
1684                        (message "Update to the minimum version of \"%s\" (%s)"
1685                                 executable version))))
1686                   (setq colorize-initially-p nil))
1687                  (t
1688                   (context-coloring-setup-idle-change-detection))))
1689               (when setup
1690                 (funcall setup))
1691               ;; Colorize once initially.
1692               (when colorize-initially-p
1693                 (let ((context-coloring-parse-interruptable-p nil))
1694                   (context-coloring-colorize)))))
1695         (when (null dispatch)
1696           (message "Context coloring is not available for this major mode"))))))
1697
1698 (provide 'context-coloring)
1699
1700 ;;; context-coloring.el ends here