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