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

   1 ;;; context-coloring.el --- Syntax highlighting, except not for syntax. -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014 Jackson Ray Hamilton
   4
   5 ;; Author: Jackson Ray Hamilton <jackson@jacksonrayhamilton.com>
   6 ;; Keywords: context coloring syntax highlighting
   7 ;; Version: 1.0.0
   8 ;; Package-Requires: ((emacs "24") (js2-mode "20141228"))
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Colors code by scope, rather than by syntax.
  26
  27 ;; A range of characters encompassing a scope is colored according to its level;
  28 ;; the global scope is white, scopes within the global scope are yellow, scopes
  29 ;; within scopes within the global scope are green, etc.  Variables defined in a
  30 ;; parent scope which are referenced from child scopes retain the same color as
  31 ;; the scope in which they are defined; a variable defined in the global scope
  32 ;; will be the same color when referenced from nested scopes.
  33
  34 ;; To use, add the following to your ~/.emacs:
  35
  36 ;; (require 'context-coloring)
  37 ;; (add-hook 'js-mode-hook 'context-coloring-mode)
  38
  39 ;;; Code:
  40
  41 (require 'js2-mode)
  42
  43
  44 ;;; Constants
  45
  46 (defconst context-coloring-path
  47   (file-name-directory (or load-file-name buffer-file-name))
  48   "This file's directory.")
  49
  50
  51 ;;; Customizable options
  52
  53 (defcustom context-coloring-delay 0.25
  54   "Delay between a buffer update and colorization.
  55
  56 Increase this if your machine is high-performing. Decrease it if it ain't.
  57
  58 Supported modes: `js-mode', `js3-mode'"
  59   :group 'context-coloring)
  60
  61 (defcustom context-coloring-js-block-scopes nil
  62   "If non-nil, also color block scopes in the scope hierarchy in JavaScript.
  63
  64 The block-scope-inducing `let' and `const' are introduced in
  65 ES6. If you are writing ES6 code, enable this; otherwise, don't.
  66
  67 Supported modes: `js2-mode'"
  68   :group 'context-coloring)
  69
  70 (defcustom context-coloring-benchmark-colorization nil
  71   "If non-nil, track how long colorization takes and print
  72 messages with the colorization duration."
  73   :group 'context-coloring)
  74
  75
  76 ;;; Local variables
  77
  78 (defvar-local context-coloring-buffer nil
  79   "Reference to this buffer (for timers).")
  80
  81 (defvar-local context-coloring-scopifier-process nil
  82   "Reference to the single scopifier process that can be
  83   running.")
  84
  85 (defvar-local context-coloring-colorize-idle-timer nil
  86   "Reference to the currently-running idle timer.")
  87
  88 (defvar-local context-coloring-changed nil
  89   "Indication that the buffer has changed recently, which would
  90 imply that it should be colorized again by
  91 `context-coloring-colorize-idle-timer' if that timer is being
  92 used.")
  93
  94
  95 ;;; Faces
  96
  97 (defface context-coloring-level--1-face
  98   '((((type tty)) (:foreground "white"))
  99     (t (:foreground "#7f7f7f")))
 100   "Context coloring face, level -1; comments."
 101   :group 'context-coloring-faces)
 102
 103 (defface context-coloring-level-0-face
 104   '((((type tty)) (:foreground "white"))
 105     (((background light)) (:foreground "#000000"))
 106     (((background dark)) (:foreground "#ffffff")))
 107   "Context coloring face, level 0; global scope."
 108   :group 'context-coloring-faces)
 109
 110 (defface context-coloring-level-1-face
 111   '((((type tty)) (:foreground "yellow"))
 112     (((background light)) (:foreground "#007f80"))
 113     (((background dark)) (:foreground "#ffff80")))
 114   "Context coloring face, level 1."
 115   :group 'context-coloring-faces)
 116
 117 (defface context-coloring-level-2-face
 118   '((((type tty)) (:foreground "green"))
 119     (((background light)) (:foreground "#001580"))
 120     (((background dark)) (:foreground "#cdfacd")))
 121   "Context coloring face, level 2."
 122   :group 'context-coloring-faces)
 123
 124 (defface context-coloring-level-3-face
 125   '((((type tty)) (:foreground "cyan"))
 126     (((background light)) (:foreground "#550080"))
 127     (((background dark)) (:foreground "#d8d8ff")))
 128   "Context coloring face, level 3."
 129   :group 'context-coloring-faces)
 130
 131 (defface context-coloring-level-4-face
 132   '((((type tty)) (:foreground "blue"))
 133     (((background light)) (:foreground "#802b00"))
 134     (((background dark)) (:foreground "#e7c7ff")))
 135   "Context coloring face, level 4."
 136   :group 'context-coloring-faces)
 137
 138 (defface context-coloring-level-5-face
 139   '((((type tty)) (:foreground "magenta"))
 140     (((background light)) (:foreground "#6a8000"))
 141     (((background dark)) (:foreground "#ffcdcd")))
 142   "Context coloring face, level 5."
 143   :group 'context-coloring-faces)
 144
 145 (defface context-coloring-level-6-face
 146   '((((type tty)) (:foreground "red"))
 147     (((background light)) (:foreground "#008000"))
 148     (((background dark)) (:foreground "#ffe390")))
 149   "Context coloring face, level 6."
 150   :group 'context-coloring-faces)
 151
 152 ;;; Additional 6 faces for insane levels of nesting
 153
 154 (defface context-coloring-level-7-face
 155   '((t (:inherit context-coloring-level-1-face)))
 156   "Context coloring face, level 7."
 157   :group 'context-coloring-faces)
 158
 159 (defface context-coloring-level-8-face
 160   '((t (:inherit context-coloring-level-2-face)))
 161   "Context coloring face, level 8."
 162   :group 'context-coloring-faces)
 163
 164 (defface context-coloring-level-9-face
 165   '((t (:inherit context-coloring-level-3-face)))
 166   "Context coloring face, level 9."
 167   :group 'context-coloring-faces)
 168
 169 (defface context-coloring-level-10-face
 170   '((t (:inherit context-coloring-level-4-face)))
 171   "Context coloring face, level 10."
 172   :group 'context-coloring-faces)
 173
 174 (defface context-coloring-level-11-face
 175   '((t (:inherit context-coloring-level-5-face)))
 176   "Context coloring face, level 11."
 177   :group 'context-coloring-faces)
 178
 179 (defface context-coloring-level-12-face
 180   '((t (:inherit context-coloring-level-6-face)))
 181   "Context coloring face, level 12."
 182   :group 'context-coloring-faces)
 183
 184 (defcustom context-coloring-face-count 7
 185   "Number of faces defined for highlighting levels.
 186 Determines level at which to cycle through faces again."
 187   :group 'context-coloring)
 188
 189
 190 ;;; Face functions
 191
 192 (defsubst context-coloring-level-face (level)
 193   "Return face-name for LEVEL as a string \"context-coloring-level-LEVEL-face\".
 194 For example: \"context-coloring-level-1-face\"."
 195   (intern-soft
 196    (concat "context-coloring-level-"
 197            (number-to-string
 198             (or
 199              ;; Has a face directly mapping to it.
 200              (and (< level context-coloring-face-count)
 201                   level)
 202              ;; After the number of available faces are used up, pretend the 0th
 203              ;; face doesn't exist.
 204              (+ 1
 205                 (mod (- level 1)
 206                      (- context-coloring-face-count 1)))))
 207            "-face")))
 208
 209
 210 ;;; Colorization utilities
 211
 212 (defun context-coloring-uncolorize-buffer ()
 213   "Clears all coloring in the current buffer."
 214   (remove-text-properties
 215    (point-min)
 216    (point-max)
 217    `(face nil rear-nonsticky nil)))
 218
 219 (defsubst context-coloring-colorize-region (start end level)
 220   "Colorizes characters from the 1-indexed START (inclusive) to
 221 END (exclusive) with the face corresponding to LEVEL."
 222   (add-text-properties
 223    start
 224    end
 225    `(face ,(context-coloring-level-face level) rear-nonsticky t)))
 226
 227
 228 ;;; js2-mode colorization
 229
 230 (defsubst context-coloring-js2-scope-level (scope)
 231   "Gets the level of SCOPE."
 232   (let ((level 0)
 233         enclosing-scope)
 234     (while (and scope
 235                 (js2-node-parent scope)
 236                 (setq enclosing-scope (js2-node-get-enclosing-scope scope)))
 237       (when (or context-coloring-js-block-scopes
 238                 (let ((type (js2-scope-type scope)))
 239                   (or (= type js2-SCRIPT)
 240                       (= type js2-FUNCTION)
 241                       (= type js2-CATCH))))
 242         (setq level (+ level 1)))
 243       (setq scope enclosing-scope))
 244     level))
 245
 246 ;; Adapted from js2-refactor.el/js2r-vars.el.
 247 ;; FIXME: This fails if there is whitespace between the name and the colon.
 248 (defsubst context-coloring-js2-local-name-node-p (node)
 249   "Determines if NODE is a js2-name-node representing a local
 250 variable."
 251   (and (js2-name-node-p node)
 252        (let ((start (js2-node-abs-pos node)))
 253          (and
 254           (let ((end (+ start (js2-node-len node))))
 255             (not (string-match "[\n\t ]*:" (buffer-substring-no-properties
 256                                             end
 257                                             (+ end 1)))))
 258           (not (string-match "\\.[\n\t ]*" (buffer-substring-no-properties
 259                                             (max 1 (- start 1)) ; 0 throws an
 260                                                                 ; error. "" will
 261                                                                 ; fail the test.
 262                                             start)))))))
 263
 264 (defsubst context-coloring-js2-colorize-node (node level)
 265   "Colors NODE with the color for LEVEL."
 266   (let ((start (js2-node-abs-pos node)))
 267     (context-coloring-colorize-region
 268      start
 269      (+ start (js2-node-len node)) ; End
 270      level)))
 271
 272 (defun context-coloring-js2-colorize ()
 273   "Colorizes the current buffer using the abstract syntax tree
 274 generated by js2-mode."
 275   (with-silent-modifications
 276     (js2-visit-ast
 277      js2-mode-ast
 278      (lambda (node end-p)
 279        (when (null end-p)
 280          (cond
 281           ((js2-comment-node-p node)
 282            (context-coloring-js2-colorize-node
 283             node
 284             -1))
 285           ((js2-scope-p node)
 286            (context-coloring-js2-colorize-node
 287             node
 288             (context-coloring-js2-scope-level node)))
 289           ((context-coloring-js2-local-name-node-p node)
 290            (context-coloring-js2-colorize-node
 291             node
 292             (context-coloring-js2-scope-level
 293              (js2-get-defining-scope
 294               (js2-node-get-enclosing-scope node)
 295               (js2-name-node-name node))))))
 296          ;; The `t' indicates to search children.
 297          t)))))
 298
 299
 300 ;;; Shell command scopification / colorization
 301
 302 (defun context-coloring-apply-tokens (tokens)
 303   "Processes a vector of TOKENS to apply context-based coloring
 304 to the current buffer. Tokens are 3 integers: start, end,
 305 level. The vector is flat, with a new token occurring after every
 306 3rd element."
 307   (with-silent-modifications
 308     (let ((i 0)
 309           (len (length tokens)))
 310       (while (< i len)
 311         (context-coloring-colorize-region
 312          (elt tokens i)
 313          (elt tokens (+ i 1))
 314          (elt tokens (+ i 2)))
 315         (setq i (+ i 3))))))
 316
 317 (defun context-coloring-parse-array (input)
 318   "Specialized JSON parser for a flat array of numbers."
 319   (vconcat (mapcar 'string-to-number (split-string (substring input 1 -1) ","))))
 320
 321 (defun context-coloring-kill-scopifier ()
 322   "Kills the currently-running scopifier process for this
 323 buffer."
 324   (when (not (null context-coloring-scopifier-process))
 325     (delete-process context-coloring-scopifier-process)
 326     (setq context-coloring-scopifier-process nil)))
 327
 328 (defun context-coloring-scopify-shell-command (command &optional callback)
 329   "Invokes a scopifier with the current buffer's contents,
 330 reading the scopifier's response asynchronously and applying a
 331 parsed list of tokens to `context-coloring-apply-tokens'."
 332
 333   ;; Prior running tokenization is implicitly obsolete if this function is
 334   ;; called.
 335   (context-coloring-kill-scopifier)
 336
 337   ;; Start the process.
 338   (setq context-coloring-scopifier-process
 339         (start-process-shell-command "scopifier" nil command))
 340
 341   (let ((output "")
 342         (buffer context-coloring-buffer))
 343
 344     ;; The process may produce output in multiple chunks. This filter
 345     ;; accumulates the chunks into a message.
 346     (set-process-filter
 347      context-coloring-scopifier-process
 348      (lambda (_process chunk)
 349        (setq output (concat output chunk))))
 350
 351     ;; When the process's message is complete, this sentinel parses it as JSON
 352     ;; and applies the tokens to the buffer.
 353     (set-process-sentinel
 354      context-coloring-scopifier-process
 355      (lambda (_process event)
 356        (when (equal "finished\n" event)
 357          (let ((tokens (context-coloring-parse-array output)))
 358            (with-current-buffer buffer
 359              (context-coloring-apply-tokens tokens))
 360            (setq context-coloring-scopifier-process nil)
 361            (if callback (funcall callback)))))))
 362
 363   ;; Give the process its input so it can begin.
 364   (process-send-region context-coloring-scopifier-process (point-min) (point-max))
 365   (process-send-eof context-coloring-scopifier-process))
 366
 367
 368 ;;; Dispatch
 369
 370 (defvar context-coloring-javascript-scopifier
 371   `(:type shell-command
 372           :executable "node"
 373           :command ,(expand-file-name
 374                      "./languages/javascript/bin/scopifier"
 375                      context-coloring-path)))
 376
 377 (defvar context-coloring-js2-colorizer
 378   `(:type elisp
 379           :colorizer context-coloring-js2-colorize))
 380
 381 (defcustom context-coloring-dispatch-plist
 382   `(js-mode ,context-coloring-javascript-scopifier
 383             js2-mode ,context-coloring-js2-colorizer
 384             js3-mode ,context-coloring-javascript-scopifier)
 385   "Property list mapping major modes to scopification programs."
 386   :group 'context-coloring)
 387
 388 (defun context-coloring-dispatch (&optional callback)
 389   "Determines the optimal track for scopification / colorization
 390 of the current buffer, then does it."
 391   (let ((dispatch (plist-get context-coloring-dispatch-plist major-mode)))
 392     (if (null dispatch)
 393         (message "%s" "Context coloring is not available for this major mode"))
 394     (let ((type (plist-get dispatch :type)))
 395       (cond
 396        ((eq type 'elisp)
 397         (let ((colorizer (plist-get dispatch :colorizer))
 398               (scopifier (plist-get dispatch :scopifier)))
 399           (cond
 400            (colorizer
 401             (funcall colorizer)
 402             (if callback (funcall callback)))
 403            (scopifier
 404             (context-coloring-apply-tokens (funcall scopifier))
 405             (if callback (funcall callback)))
 406            (t
 407             (error "No `:colorizer' nor `:scopifier' specified for dispatch of `:type' elisp")))))
 408        ((eq type 'shell-command)
 409         (let ((executable (plist-get dispatch :executable))
 410               (command (plist-get dispatch :command)))
 411           (if (null command)
 412               (error "No `:command' specified for dispatch of `:type' shell-command"))
 413           (if (and (not (null executable))
 414                    (null (executable-find executable)))
 415               (message "Executable \"%s\" not found" executable))
 416           (context-coloring-scopify-shell-command command callback)))))))
 417
 418
 419 ;;; Colorization
 420
 421 (defun context-coloring-colorize (&optional callback)
 422   "Colors the current buffer by function context."
 423   (interactive)
 424   (let ((start-time (float-time)))
 425     (context-coloring-dispatch
 426      (lambda ()
 427        (when context-coloring-benchmark-colorization
 428          (message "Colorization took %.3f seconds" (- (float-time) start-time)))
 429        (if callback (funcall callback))))))
 430
 431 (defun context-coloring-change-function (_start _end _length)
 432   "Registers a change so that a context-colored buffer can be
 433 colorized soon."
 434   ;; Tokenization is obsolete if there was a change.
 435   (context-coloring-kill-scopifier)
 436   (setq context-coloring-changed t))
 437
 438 (defun context-coloring-maybe-colorize ()
 439   "Colorize unders certain conditions. This will run as an idle
 440 timer, so firstly the buffer must not be some other
 441 buffer. Additionally, the buffer must have changed, otherwise
 442 colorizing would be redundant."
 443   (when (and (eq context-coloring-buffer (window-buffer (selected-window)))
 444              context-coloring-changed)
 445     (setq context-coloring-changed nil)
 446     (context-coloring-colorize)))
 447
 448
 449 ;;; Minor mode
 450
 451 ;;;###autoload
 452 (define-minor-mode context-coloring-mode
 453   "Context-based code coloring, inspired by Douglas Crockford."
 454   nil " Context" nil
 455   (if (not context-coloring-mode)
 456       (progn
 457         (context-coloring-kill-scopifier)
 458         (when context-coloring-colorize-idle-timer
 459           (cancel-timer context-coloring-colorize-idle-timer))
 460         (remove-hook 'js2-post-parse-callbacks 'context-coloring-colorize t)
 461         (remove-hook 'after-change-functions 'context-coloring-change-function t)
 462         (font-lock-mode)
 463         (jit-lock-mode t))
 464
 465     ;; Remember this buffer. This value should not be dynamically-bound.
 466     (setq context-coloring-buffer (current-buffer))
 467
 468     ;; Font lock is incompatible with this mode; the converse is also true.
 469     (font-lock-mode 0)
 470     (jit-lock-mode nil)
 471
 472     ;; Colorize once initially.
 473     (context-coloring-colorize)
 474
 475     (cond
 476      ((equal major-mode 'js2-mode)
 477       ;; Only recolor on reparse.
 478       (add-hook 'js2-post-parse-callbacks 'context-coloring-colorize nil t))
 479      (t
 480       ;; Only recolor on change.
 481       (add-hook 'after-change-functions 'context-coloring-change-function nil t)))
 482
 483     (when (not (equal major-mode 'js2-mode))
 484       ;; Only recolor idly.
 485       (setq context-coloring-colorize-idle-timer
 486             (run-with-idle-timer context-coloring-delay t 'context-coloring-maybe-colorize)))))
 487
 488 (provide 'context-coloring)
 489
 490 ;;; context-coloring.el ends here