branch: master
commit 5acd088cbb1a9115d77d71279eabc0e2d8e8ea93
Author: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
Commit: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
Add non-recursive let* coloring.
---
context-coloring.el | 59 ++++++++++++++++++++++++++++---
test/context-coloring-test.el | 78 ++++++++++++++++++++++++-----------------
test/fixtures/let*.el | 9 +++++
3 files changed, 109 insertions(+), 37 deletions(-)
diff --git a/context-coloring.el b/context-coloring.el
index 3bd2b0f..3a57b3f 100644
--- a/context-coloring.el
+++ b/context-coloring.el
@@ -341,6 +341,13 @@ generated by `js2-mode'."
(defun context-coloring-backtick-enabled-p (backtick-stack)
(context-coloring-backtick-get-enabled (car backtick-stack)))
+(defun context-coloring-make-let-value (end)
+ (list
+ :end end))
+
+(defun context-coloring-let-value-get-end (let-value)
+ (plist-get let-value :end))
+
(defun context-coloring-emacs-lisp-identifier-syntax-p (syntax-code)
(or (= 2 syntax-code)
(= 3 syntax-code)))
@@ -349,6 +356,9 @@ generated by `js2-mode'."
"Move forward through whitespace and comments."
(while (forward-comment 1)))
+(defun context-coloring-at-open-parenthesis ()
+ (= 4 (logand #xFFFF (car (syntax-after (point))))))
+
(defun context-coloring-emacs-lisp-colorize ()
"Color the current buffer by parsing emacs lisp sexps."
(with-silent-modifications
@@ -361,12 +371,16 @@ generated by `js2-mode'."
(ppss (syntax-ppss))
(scope-stack `(,(context-coloring-make-scope -1 0))) ; -1 never
matches a depth
(backtick-stack `(,(context-coloring-make-backtick -1 nil)))
+ (let-value-stack `(,(context-coloring-make-let-value -1)))
one-word-found-p
in-defun-p
in-lambda-p
+ in-let*-p
function-call-p
defun-arglist
defun-arg
+ let-varlist
+ let-var
variable
variable-end
variable-string
@@ -453,14 +467,18 @@ generated by `js2-mode'."
(setq child-0-end (scan-sexps child-0-pos 1))
(setq child-0-string (buffer-substring-no-properties child-0-pos
child-0-end))
(cond
- ((string-match-p "defun\\|defmacro" child-0-string)
+ ((string-match-p "\\`defun\\'\\|\\`defmacro\\'" child-0-string)
(setq in-defun-p t))
- ((string-match-p "lambda" child-0-string)
+ ((string-match-p "\\`lambda\\'" child-0-string)
(setq in-lambda-p t))
+ ((string-match-p "\\`let\\*\\'" child-0-string)
+ (setq in-let*-p t))
;; Assume a global function call
(t
(setq function-call-p t)))))
- (when (or in-defun-p in-lambda-p)
+ (when (or in-defun-p
+ in-lambda-p
+ in-let*-p)
(setq scope-stack (cons (context-coloring-make-scope
(nth 0 ppss)
(1+ (context-coloring-scope-get-level
@@ -475,7 +493,8 @@ generated by `js2-mode'."
(context-coloring-colorize-region child-0-pos child-0-end 0)
(setq function-call-p nil))
(cond
- ((or in-defun-p in-lambda-p)
+ ((or in-defun-p
+ in-lambda-p)
(goto-char child-0-end)
(when in-defun-p
;; Lookahead for defun name
@@ -492,7 +511,8 @@ generated by `js2-mode'."
(goto-char child-1-end))))
;; Lookahead for parameters
(context-coloring-forward-sws)
- (when (= 4 (logand #xFFFF (car (syntax-after (point)))))
+ (when (context-coloring-at-open-parenthesis)
+ ;; Actually it should be `child-1-end' for `lambda'.
(setq child-2-end (scan-sexps (point) 1))
(setq defun-arglist (read (buffer-substring-no-properties
(point)
@@ -509,6 +529,35 @@ generated by `js2-mode'."
;; Cleanup
(setq in-defun-p nil)
(setq in-lambda-p nil))
+ (in-let*-p
+ (goto-char child-0-end)
+ ;; Lookahead for bindings
+ (context-coloring-forward-sws)
+ (setq child-1-pos (point))
+ (setq child-1-syntax (syntax-after child-1-pos))
+ (setq child-1-syntax-code (logand #xFFFF (car child-1-syntax)))
+ (when (= 4 child-1-syntax-code)
+ (setq child-1-end (scan-sexps (point) 1))
+ (setq let-varlist (read (buffer-substring-no-properties
+ (point)
+ child-1-end)))
+ (while let-varlist
+ (setq let-var (car let-varlist))
+ (cond
+ ((symbolp let-var)
+ (context-coloring-scope-add-variable
+ (car scope-stack)
+ let-var))
+ ((listp let-var)
+ (context-coloring-scope-add-variable
+ (car scope-stack)
+ (car let-var))
+ ;; TODO: Recurse or use stack to eval var value
+ ))
+ (setq let-varlist (cdr let-varlist)))
+ (goto-char child-1-end))
+ ;; Cleanup
+ (setq in-let*-p nil))
(t
(goto-char (cond
;; If there was a word, continue parsing after it.
diff --git a/test/context-coloring-test.el b/test/context-coloring-test.el
index 93e0517..148ddac 100644
--- a/test/context-coloring-test.el
+++ b/test/context-coloring-test.el
@@ -234,38 +234,39 @@ environment."
(defun context-coloring-test-assert-coloring (map)
"Assert that the current buffer's coloring matches MAP."
- ;; Omit the superfluous, formatting-related leading newline.
- (save-excursion
- (goto-char (point-min))
- (let* ((map (substring map 1))
- (index 0)
- char-string
- char)
- (while (< index (length map))
- (setq char-string (substring map index (1+ index)))
- (setq char (string-to-char char-string))
- (cond
- ;; Newline
- ((= char 10)
- (next-logical-line)
- (beginning-of-line))
- ;; Number
- ((and (>= char 48)
- (<= char 57))
- (context-coloring-test-assert-position-level
- (point) (string-to-number char-string))
- (forward-char))
- ;; ';' = Comment
- ((= char 59)
- (context-coloring-test-assert-position-comment (point))
- (forward-char))
- ;; 's' = String
- ((= char 115)
- (context-coloring-test-assert-position-string (point))
- (forward-char))
- (t
- (forward-char)))
- (setq index (1+ index))))))
+ ;; Omit the superfluous, formatting-related leading newline. Can't use
+ ;; `save-excursion' here because if an assertion fails it will cause future
+ ;; tests to get messed up.
+ (goto-char (point-min))
+ (let* ((map (substring map 1))
+ (index 0)
+ char-string
+ char)
+ (while (< index (length map))
+ (setq char-string (substring map index (1+ index)))
+ (setq char (string-to-char char-string))
+ (cond
+ ;; Newline
+ ((= char 10)
+ (next-logical-line)
+ (beginning-of-line))
+ ;; Number
+ ((and (>= char 48)
+ (<= char 57))
+ (context-coloring-test-assert-position-level
+ (point) (string-to-number char-string))
+ (forward-char))
+ ;; ';' = Comment
+ ((= char 59)
+ (context-coloring-test-assert-position-comment (point))
+ (forward-char))
+ ;; 's' = String
+ ((= char 115)
+ (context-coloring-test-assert-position-string (point))
+ (forward-char))
+ (t
+ (forward-char)))
+ (setq index (1+ index)))))
(defmacro context-coloring-test-assert-region (&rest body)
"Assert something about the face of points in a region.
@@ -1135,6 +1136,19 @@ see that function."
(xxxxx x ()
(0 0 1 11 11 111 11 1 111))")))
+(context-coloring-test-deftest-emacs-lisp-mode let*
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+11111 11
+ 11 11
+ 11 000011
+ 1000 1 1 1 0 0 00001
+ 22222 22
+ 22 12
+ 22 000022
+ 2000 1 1 2 2 2 0000))
+ 1000 1 1 1 0 0 000011")))
+
(provide 'context-coloring-test)
;;; context-coloring-test.el ends here
diff --git a/test/fixtures/let*.el b/test/fixtures/let*.el
new file mode 100644
index 0000000..967f866
--- /dev/null
+++ b/test/fixtures/let*.el
@@ -0,0 +1,9 @@
+(let* (a
+ (b a)
+ (c free))
+ (and a b c d e free)
+ (let* (d
+ (e a)
+ (c free))
+ (and a b c d e free))
+ (and a b c d e free))
