-(defsubst context-coloring-js2-scope-level (scope)
- "Return the level of SCOPE."
- (cond ((gethash scope context-coloring-js2-scope-level-hash-table))
- (t
- (let ((level 0)
- (current-scope scope)
- enclosing-scope)
- (while (and current-scope
- (js2-node-parent current-scope)
- (setq enclosing-scope
- (js2-node-get-enclosing-scope current-scope)))
- (when (or context-coloring-js-block-scopes
- (let ((type (js2-scope-type current-scope)))
- (or (= type js2-SCRIPT)
- (= type js2-FUNCTION)
- (= type js2-CATCH))))
- (setq level (+ level 1)))
- (setq current-scope enclosing-scope))
- (puthash scope level context-coloring-js2-scope-level-hash-table)))))
-
-(defsubst context-coloring-js2-local-name-node-p (node)
- "Determine if NODE is a `js2-name-node' representing a local
-variable."
- (and (js2-name-node-p node)
- (let ((parent (js2-node-parent node)))
- (not (or (and (js2-object-prop-node-p parent)
- (eq node (js2-object-prop-node-left parent)))
- (and (js2-prop-get-node-p parent)
- ;; For nested property lookup, the node on the left is a
- ;; `js2-prop-get-node', so this always works.
- (eq node (js2-prop-get-node-right parent))))))))
-
-(defvar-local context-coloring-point-max nil
- "Cached value of `point-max'.")
-
-(defsubst context-coloring-js2-colorize-node (node level)
- "Color NODE with the color for LEVEL."
- (let ((start (js2-node-abs-pos node)))
- (context-coloring-colorize-region
- start
- (min
- ;; End
- (+ start (js2-node-len node))
- ;; Somes nodes (like the ast when there is an unterminated multiline
- ;; comment) will stretch to the value of `point-max'.
- context-coloring-point-max)
- level)))
-
-(defun context-coloring-js2-colorize ()
- "Color the current buffer using the abstract syntax tree
-generated by `js2-mode'."
- ;; Reset the hash table; the old one could be obsolete.
- (setq context-coloring-js2-scope-level-hash-table (make-hash-table :test 'eq))
- (setq context-coloring-point-max (point-max))
- (with-silent-modifications
- (js2-visit-ast
- js2-mode-ast
- (lambda (node end-p)
- (when (null end-p)
- (cond
- ((js2-scope-p node)
- (context-coloring-js2-colorize-node
- node
- (context-coloring-js2-scope-level node)))
- ((context-coloring-js2-local-name-node-p node)
- (let* ((enclosing-scope (js2-node-get-enclosing-scope node))
- (defining-scope (js2-get-defining-scope
- enclosing-scope
- (js2-name-node-name node))))
- ;; The tree seems to be walked lexically, so an entire scope will
- ;; be colored, including its name nodes, before they are reached.
- ;; Coloring the nodes defined in that scope would be redundant, so
- ;; don't do it.
- (when (not (eq defining-scope enclosing-scope))
- (context-coloring-js2-colorize-node
- node
- (context-coloring-js2-scope-level defining-scope))))))
- ;; The `t' indicates to search children.
- t)))
- (context-coloring-maybe-colorize-comments-and-strings)))
-
-
-;;; Emacs Lisp colorization
-
-(defsubst context-coloring-forward-sws ()
- "Move forward through whitespace and comments."
- (while (forward-comment 1)))
-
-(defsubst context-coloring-get-syntax-code ()
- (syntax-class (syntax-after (point))))
-
-(defsubst context-coloring-exact-regexp (word)
- "Create a regexp that matches exactly WORD."
- (concat "\\`" (regexp-quote word) "\\'"))
-
-(defsubst context-coloring-exact-or-regexp (words)
- "Create a regexp that matches any exact word in WORDS."
- (context-coloring-join
- (mapcar 'context-coloring-exact-regexp words) "\\|"))
-
-(defconst context-coloring-elisp-defun-regexp
- (context-coloring-exact-or-regexp
- '("defun" "defun*" "defsubst" "defmacro"
- "cl-defun" "cl-defsubst" "cl-defmacro")))
-
-(defconst context-coloring-elisp-lambda-regexp
- (context-coloring-exact-regexp "lambda"))
-
-(defconst context-coloring-elisp-let-regexp
- (context-coloring-exact-regexp "let"))
-
-(defconst context-coloring-elisp-let*-regexp
- (context-coloring-exact-regexp "let*"))
-
-(defconst context-coloring-elisp-arglist-arg-regexp
- "\\`[^&:]")
-
-(defconst context-coloring-ignored-word-regexp
- (context-coloring-join (list "\\`[-+]?[0-9]"
- "\\`[&:].+"
- (context-coloring-exact-or-regexp
- '("t" "nil" "." "?")))
- "\\|"))
-
-(defconst context-coloring-WORD-CODE 2)
-(defconst context-coloring-SYMBOL-CODE 3)
-(defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
-(defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
-(defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
-(defconst context-coloring-STRING-QUOTE-CODE 7)
-(defconst context-coloring-ESCAPE-CODE 9)
-(defconst context-coloring-COMMENT-START-CODE 11)
-(defconst context-coloring-COMMENT-END-CODE 12)
-
-(defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
-(defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
-(defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
-(defconst context-coloring-COMMA-CHAR (string-to-char ","))
-(defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
-
-(defvar context-coloring-elisp-scope-stack '())
-
-(defsubst context-coloring-elisp-make-scope (level)
- (list
- :level level
- :variables '()))
-
-(defsubst context-coloring-elisp-scope-get-level (scope)
- (plist-get scope :level))
-
-(defsubst context-coloring-elisp-scope-add-variable (scope variable)
- (plist-put scope :variables (cons variable (plist-get scope :variables))))
-
-(defsubst context-coloring-elisp-scope-has-variable (scope variable)
- (member variable (plist-get scope :variables)))
-
-(defsubst context-coloring-elisp-get-variable-level (variable)
- (let* ((scope-stack context-coloring-elisp-scope-stack)
- scope
- level)
- (while (and scope-stack (not level))
- (setq scope (car scope-stack))
- (cond
- ((context-coloring-elisp-scope-has-variable scope variable)
- (setq level (context-coloring-elisp-scope-get-level scope)))
- (t
- (setq scope-stack (cdr scope-stack)))))
- ;; Assume a global variable.
- (or level 0)))
-
-(defsubst context-coloring-elisp-current-scope-level ()
- (cond
- ((car context-coloring-elisp-scope-stack)
- (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
- (t
- 0)))
-
-(defsubst context-coloring-elisp-push-scope ()
- (push (context-coloring-elisp-make-scope
- (1+ (context-coloring-elisp-current-scope-level)))
- context-coloring-elisp-scope-stack))
-
-(defsubst context-coloring-elisp-pop-scope ()
- (pop context-coloring-elisp-scope-stack))
-
-(defsubst context-coloring-elisp-add-variable (variable)
- (context-coloring-elisp-scope-add-variable
- (car context-coloring-elisp-scope-stack)
- variable))
-
-(defun context-coloring-elisp-parse-arg (callback)
- (let (arg-pos
- arg-end
- arg-string)
- (setq arg-pos (point))
- (forward-sexp)
- (setq arg-end (point))
- (setq arg-string (buffer-substring-no-properties
- arg-pos
- arg-end))
- (when (string-match-p
- context-coloring-elisp-arglist-arg-regexp
- arg-string)
- (funcall callback arg-string))))
-
-(defun context-coloring-elisp-parse-let-varlist (type)
- (let ((varlist '())
- syntax-code)
- ;; Enter.
- (forward-char)
- (while (/= (setq syntax-code (context-coloring-get-syntax-code))
- context-coloring-CLOSE-PARENTHESIS-CODE)
- (cond
- ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
- (forward-char)
- (context-coloring-forward-sws)
- (setq syntax-code (context-coloring-get-syntax-code))
- (when (or (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE))
- (context-coloring-elisp-parse-arg
- (lambda (var)
- (push var varlist)))
- (context-coloring-forward-sws)
- (setq syntax-code (context-coloring-get-syntax-code))
- (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
- (context-coloring-elisp-colorize-sexp)))
- (context-coloring-forward-sws)
- ;; Skip past the closing parenthesis.
- (forward-char))
- ((or (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE))
- (context-coloring-elisp-parse-arg
- (lambda (var)
- (push var varlist)))))
- (when (eq type 'let*)
- (context-coloring-elisp-add-variable (pop varlist)))
- (context-coloring-forward-sws))
- (when (eq type 'let)
- (while varlist
- (context-coloring-elisp-add-variable (pop varlist))))
- ;; Exit.
- (forward-char)))
-
-(defun context-coloring-elisp-parse-arglist ()
- (let (syntax-code)
- ;; Enter.
- (forward-char)
- (while (/= (setq syntax-code (context-coloring-get-syntax-code))
- context-coloring-CLOSE-PARENTHESIS-CODE)
- (cond
- ((or (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE))
- (context-coloring-elisp-parse-arg
- (lambda (arg)
- (context-coloring-elisp-add-variable arg))))
- (t
- (forward-sexp)))
- (context-coloring-forward-sws))
- ;; Exit.
- (forward-char)))
-
-(defun context-coloring-elisp-colorize-defun (&optional anonymous-p
- let-type)
- (let ((start (point))
- end
- stop
- syntax-code
- defun-name-pos
- defun-name-end)
- (context-coloring-elisp-push-scope)
- ;; Color the whole sexp.
- (forward-sexp)
- (setq end (point))
- (context-coloring-colorize-region
- start
- end
- (context-coloring-elisp-current-scope-level))
- (goto-char start)
- ;; Skip past the "defun".
- (skip-syntax-forward "^w_")
- (forward-sexp)
- (context-coloring-forward-sws)
- (setq stop nil)
- (unless anonymous-p
- ;; Check for the defun's name.
- (setq syntax-code (context-coloring-get-syntax-code))
- (cond
- ((or (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE))
- ;; Color the defun's name with the top-level color.
- (setq defun-name-pos (point))
- (forward-sexp)
- (setq defun-name-end (point))
- (context-coloring-colorize-region defun-name-pos defun-name-end 0)
- (context-coloring-forward-sws))
- (t
- (setq stop t))))
- (cond
- (stop
- ;; Skip it.
- (goto-char start)
- (forward-sexp))
- (t
- (setq syntax-code (context-coloring-get-syntax-code))
- (cond
- ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
- (cond
- (let-type
- (context-coloring-elisp-parse-let-varlist let-type))
- (t
- (context-coloring-elisp-parse-arglist)))
- ;; Colorize the rest of the function.
- (context-coloring-elisp-colorize-region (point) (1- end))
- ;; Exit the defun.
- (forward-char))
- (t
- ;; Skip it.
- (goto-char start)
- (forward-sexp)))))
- (context-coloring-elisp-pop-scope)))
-
-(defun context-coloring-elisp-colorize-lambda ()
- (context-coloring-elisp-colorize-defun t))
-
-(defun context-coloring-elisp-colorize-let ()
- (context-coloring-elisp-colorize-defun t 'let))
-
-(defun context-coloring-elisp-colorize-let* ()
- (context-coloring-elisp-colorize-defun t 'let*))
-
-(defun context-coloring-elisp-colorize-parenthesized-sexp ()
- (let ((start (point))
- end
- syntax-code
- child-0-pos
- child-0-end
- child-0-string)
- (forward-sexp)
- (setq end (point))
- (goto-char start)
- (forward-char)
- (context-coloring-forward-sws)
- (setq syntax-code (context-coloring-get-syntax-code))
- ;; Figure out if the sexp is a special form.
- (cond
- ((when (or (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE))
- (setq child-0-pos (point))
- (forward-sexp)
- (setq child-0-end (point))
- (setq child-0-string (buffer-substring-no-properties
- child-0-pos
- child-0-end))
- (cond
- ((string-match-p context-coloring-elisp-defun-regexp child-0-string)
- (goto-char start)
- (context-coloring-elisp-colorize-defun)
- t)
- ((string-match-p context-coloring-elisp-lambda-regexp child-0-string)
- (goto-char start)
- (context-coloring-elisp-colorize-lambda)
- t)
- ((string-match-p context-coloring-elisp-let-regexp child-0-string)
- (goto-char start)
- (context-coloring-elisp-colorize-let)
- t)
- ((string-match-p context-coloring-elisp-let*-regexp child-0-string)
- (goto-char start)
- (context-coloring-elisp-colorize-let*)
- t)
- (t
- nil))))
- ;; Not a special form; just colorize the remaining region.
- (t
- (context-coloring-colorize-region
- start
- end
- (context-coloring-elisp-current-scope-level))
- (context-coloring-elisp-colorize-region (point) (1- end))
- (forward-char)))))
-
-(defun context-coloring-elisp-colorize-symbol ()
- (let (symbol-pos
- symbol-end
- symbol-string)
- (setq symbol-pos (point))
- (forward-sexp)
- (setq symbol-end (point))
- (setq symbol-string (buffer-substring-no-properties
- symbol-pos
- symbol-end))
- (cond
- ((string-match-p context-coloring-ignored-word-regexp symbol-string))
- (t
- (context-coloring-colorize-region
- symbol-pos
- symbol-end
- (context-coloring-elisp-get-variable-level
- symbol-string))))))
-
-(defun context-coloring-elisp-colorize-expression-prefix ()
- (let ((char (char-after))
- (start (point))
- (end (progn (forward-sexp)
- (point))))
- (cond
- ((or (= char context-coloring-APOSTROPHE-CHAR)
- (= char context-coloring-OCTOTHORPE-CHAR))
- (context-coloring-elisp-colorize-comments-and-strings-in-region start end))
- ((= char context-coloring-BACKTICK-CHAR)
- (goto-char start)
- (while (> end (progn (forward-char)
- (point)))
- (setq char (char-after))
- (when (= char context-coloring-COMMA-CHAR)
- (forward-char)
- (context-coloring-forward-sws)
- (context-coloring-elisp-colorize-sexp)))))))
-
-(defvar context-coloring-parse-interruptable-p t
- "Set this to nil to force parse to continue until finished.")
-
-(defconst context-coloring-elisp-sexps-per-pause 1000
- "Pause after this many iterations to check for user input.
-If user input is pending, stop the parse. This makes for a
-smoother user experience for large files.
-
-As of this writing, emacs lisp colorization seems to run at about
-60,000 iterations per second. A default value of 1000 should
-provide visually \"instant\" updates at 60 frames per second.")
-
-(defvar context-coloring-elisp-sexp-count 0)
-
-(defun context-coloring-elisp-increment-sexp-count ()
- (setq context-coloring-elisp-sexp-count
- (1+ context-coloring-elisp-sexp-count))
- (when (and (zerop (% context-coloring-elisp-sexp-count
- context-coloring-elisp-sexps-per-pause))
- context-coloring-parse-interruptable-p
- (input-pending-p))
- (throw 'interrupted t)))
-
-(defun context-coloring-elisp-colorize-sexp ()
- (let (syntax-code)
- (context-coloring-elisp-increment-sexp-count)
- (setq syntax-code (context-coloring-get-syntax-code))
- (cond
- ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
- (context-coloring-elisp-colorize-parenthesized-sexp))
- ((or (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE))
- (context-coloring-elisp-colorize-symbol))
- ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
- (context-coloring-elisp-colorize-expression-prefix))
- (t
- (forward-char)))))
-
-(defun context-coloring-elisp-colorize-comment ()
- (let ((start (point)))
- (context-coloring-elisp-increment-sexp-count)
- (context-coloring-forward-sws)
- (context-coloring-maybe-colorize-comments-and-strings
- start
- (point))))
-
-(defun context-coloring-elisp-colorize-string ()
- (let ((start (point)))
- (context-coloring-elisp-increment-sexp-count)
- (forward-sexp)
- (context-coloring-maybe-colorize-comments-and-strings
- start
- (point))))
-
-(defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
- (let (syntax-code)
- (goto-char start)
- (while (> end (progn (skip-syntax-forward "^<\"\\" end)
- (point)))
- (setq syntax-code (context-coloring-get-syntax-code))
- (cond
- ((= syntax-code context-coloring-COMMENT-START-CODE)
- (context-coloring-elisp-colorize-comment))
- ((= syntax-code context-coloring-STRING-QUOTE-CODE)
- (context-coloring-elisp-colorize-string))
- ((= syntax-code context-coloring-ESCAPE-CODE)
- (forward-char 2))
- (t
- (forward-char))))))
-
-(defun context-coloring-elisp-colorize-region (start end)
- (let (syntax-code)
- (goto-char start)
- (while (> end (progn (skip-syntax-forward "^()w_'<\"\\" end)
- (point)))
- (setq syntax-code (context-coloring-get-syntax-code))
- (cond
- ((or (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
- (= syntax-code context-coloring-WORD-CODE)
- (= syntax-code context-coloring-SYMBOL-CODE)
- (= syntax-code context-coloring-EXPRESSION-PREFIX-CODE))
- (context-coloring-elisp-colorize-sexp))
- ((= syntax-code context-coloring-COMMENT-START-CODE)
- (context-coloring-elisp-colorize-comment))
- ((= syntax-code context-coloring-STRING-QUOTE-CODE)
- (context-coloring-elisp-colorize-string))
- ((= syntax-code context-coloring-ESCAPE-CODE)
- (forward-char 2))
- (t
- (forward-char))))))
-
-(defun context-coloring-elisp-colorize (start end)
- (setq context-coloring-elisp-sexp-count 0)
- (setq context-coloring-elisp-scope-stack '())
- (context-coloring-elisp-colorize-region start end))
-
-(defun context-coloring-elisp-colorize-changed-region (start end)
- (with-silent-modifications
- (save-excursion
- (let ((start (progn (goto-char start)
- (beginning-of-defun)
- (point)))
- (end (progn (goto-char end)
- (end-of-defun)
- (point))))
- (context-coloring-elisp-colorize start end)))))
-
-(defun context-coloring-elisp-colorize-buffer ()
- (interactive)
- (with-silent-modifications
- (save-excursion
- (context-coloring-elisp-colorize (point-min) (point-max)))))
-
-(defalias 'ccecb 'context-coloring-elisp-colorize-buffer)
-
-
-;;; Shell command scopification / colorization
-
-(defun context-coloring-apply-tokens (tokens)
- "Process a vector of TOKENS to apply context-based coloring to
-the current buffer. Tokens are 3 integers: start, end, level.
-The vector is flat, with a new token occurring after every 3rd
-element."
- (with-silent-modifications
- (let ((i 0)
- (len (length tokens)))
- (while (< i len)
- (context-coloring-colorize-region
- (elt tokens i)
- (elt tokens (+ i 1))
- (elt tokens (+ i 2)))
- (setq i (+ i 3))))
- (context-coloring-maybe-colorize-comments-and-strings)))
-
-(defun context-coloring-parse-array (array)
- "Parse ARRAY as a flat JSON array of numbers."
- (let ((braceless (substring (context-coloring-trim array) 1 -1)))
- (cond
- ((> (length braceless) 0)
- (vconcat
- (mapcar 'string-to-number (split-string braceless ","))))
- (t
- (vector)))))
-
-(defvar-local context-coloring-scopifier-process nil
- "The single scopifier process that can be running.")
-
-(defun context-coloring-kill-scopifier ()
- "Kill the currently-running scopifier process."
- (when (not (null context-coloring-scopifier-process))
- (delete-process context-coloring-scopifier-process)
- (setq context-coloring-scopifier-process nil)))
-
-(defun context-coloring-scopify-shell-command (command callback)
- "Invoke a scopifier via COMMAND, read its response
-asynchronously and invoke CALLBACK with its output."
-
- ;; Prior running tokenization is implicitly obsolete if this function is
- ;; called.
- (context-coloring-kill-scopifier)
-
- ;; Start the process.
- (setq context-coloring-scopifier-process
- (start-process-shell-command "scopifier" nil command))
-
- (let ((output ""))
-
- ;; The process may produce output in multiple chunks. This filter
- ;; accumulates the chunks into a message.
- (set-process-filter
- context-coloring-scopifier-process
- (lambda (_process chunk)
- (setq output (concat output chunk))))
-
- ;; When the process's message is complete, this sentinel parses it as JSON
- ;; and applies the tokens to the buffer.
- (set-process-sentinel
- context-coloring-scopifier-process
- (lambda (_process event)
- (when (equal "finished\n" event)
- (funcall callback output))))))
-
-(defun context-coloring-send-buffer-to-scopifier ()
- "Give the scopifier process its input so it can begin
-scopifying."
- (process-send-region
- context-coloring-scopifier-process
- (point-min) (point-max))
- (process-send-eof
- context-coloring-scopifier-process))
-
-(defun context-coloring-scopify-and-colorize (command &optional callback)
- "Invoke a scopifier via COMMAND with the current buffer's contents,
-read the scopifier's response asynchronously and apply a parsed
-list of tokens to `context-coloring-apply-tokens'.
-
-Invoke CALLBACK when complete."
- (let ((buffer (current-buffer)))
- (context-coloring-scopify-shell-command
- command
- (lambda (output)
- (let ((tokens (context-coloring-parse-array output)))
- (with-current-buffer buffer
- (context-coloring-apply-tokens tokens))
- (setq context-coloring-scopifier-process nil)
- (when callback (funcall callback))))))
- (context-coloring-send-buffer-to-scopifier))
-