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