[elpa] master 5acd088 10/47: Add non-recursive let* coloring.

[Jackson Ray Hamilton]

branch: master
commit 5acd088cbb1a9115d77d71279eabc0e2d8e8ea93
Author: Jackson Ray Hamilton <address@hidden>
Commit: Jackson Ray Hamilton <address@hidden>

    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))