[elpa] master d9d901f 03/47: Add basic elisp defun coloring.

[Jackson Ray Hamilton]

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

    Add basic elisp defun coloring.
---
 context-coloring.el           |  186 +++++++++++++++++++++++++++++++++++++++++
 test/context-coloring-test.el |   29 +++++++
 test/fixtures/defun.el        |    4 +
 3 files changed, 219 insertions(+), 0 deletions(-)

diff --git a/context-coloring.el b/context-coloring.el
index c5c7d3f..7787cb5 100644
--- a/context-coloring.el
+++ b/context-coloring.el
@@ -294,6 +294,187 @@ generated by `js2-mode'."
     (context-coloring-maybe-colorize-comments-and-strings)))
 
 
+;;; Emacs Lisp colorization
+
+(defun context-coloring-make-scope (depth level)
+  (list
+   :depth depth
+   :level level
+   :variables (make-hash-table)))
+
+(defun context-coloring-scope-get-depth (scope)
+  (plist-get scope :depth))
+
+(defun context-coloring-scope-get-level (scope)
+  (plist-get scope :level))
+
+(defun context-coloring-scope-add-variable (scope variable)
+  (puthash variable t (plist-get scope :variables)))
+
+(defun context-coloring-scope-get-variable (scope variable)
+  (gethash variable (plist-get scope :variables)))
+
+(defun context-coloring-get-variable-level (scope-stack variable)
+  (let* (scope
+         level)
+    (while (and scope-stack (not level))
+      (setq scope (car scope-stack))
+      (cond
+       ((context-coloring-scope-get-variable scope variable)
+        (setq level (context-coloring-scope-get-level scope)))
+       (t
+        (setq scope-stack (cdr scope-stack)))))
+    ;; Assume global
+    (or level 0)))
+
+(defun context-coloring-emacs-lisp-identifier-syntax-p (syntax-code)
+  (or (= 2 syntax-code)
+      (= 3 syntax-code)))
+
+(defun context-coloring-emacs-lisp-colorize ()
+  "Color the current buffer by parsing emacs lisp sexps."
+  (with-silent-modifications
+    (save-excursion
+      ;; TODO: Can probably make this lazy to the nearest defun
+      (goto-char (point-min))
+      (let* ((inhibit-point-motion-hooks t)
+             (end (point-max))
+             (last-ppss-pos (point))
+             (ppss (syntax-ppss))
+             (scope-stack `(,(context-coloring-make-scope -1 0))) ; -1 never 
matches a depth
+             one-word-found-p
+             in-defun-p
+             function-call-p
+             defun-arglist
+             defun-arg
+             variable
+             variable-end
+             variable-string
+             variable-scope-level
+             token-pos
+             token-syntax
+             token-syntax-code
+             child-0-pos
+             child-0-end
+             child-0-syntax
+             child-0-syntax-code
+             child-0-string
+             child-1-pos
+             child-1-end
+             child-1-syntax
+             child-1-syntax-code
+             child-2-end)
+        (while (> end (progn (skip-syntax-forward "^()w_" end)
+                             (point)))
+          (setq token-pos (point))
+          (setq token-syntax (syntax-after token-pos))
+          (setq ppss (parse-partial-sexp last-ppss-pos token-pos nil nil ppss))
+          (setq last-ppss-pos token-pos)
+          ;; `skip-syntax-forward' leaves the point at the delimiter, move past
+          ;; it.
+          (setq token-syntax-code (logand #xFFFF (car token-syntax)))
+          (cond
+           ;; Opening delimiter
+           ((= 4 token-syntax-code)
+            (forward-char)
+            ;; Lookahead for scopes / function calls
+            (skip-syntax-forward " " end)
+            (setq child-0-pos (point))
+            (setq child-0-syntax (syntax-after child-0-pos))
+            (setq child-0-syntax-code (logand #xFFFF (car child-0-syntax)))
+            (cond
+             ;; Word
+             ((context-coloring-emacs-lisp-identifier-syntax-p 
child-0-syntax-code)
+              (setq one-word-found-p t)
+              (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)
+                (setq in-defun-p t)
+                (setq scope-stack (cons (context-coloring-make-scope
+                                         (nth 0 ppss)
+                                         (1+ (context-coloring-scope-get-level
+                                              (car scope-stack))))
+                                        scope-stack)))
+               ;; Assume a global function call
+               (t
+                (setq function-call-p t)))))
+            ;; TODO: Probably redundant and wasteful
+            (context-coloring-colorize-region token-pos
+                                              (scan-sexps token-pos 1)
+                                              (context-coloring-scope-get-level
+                                               (car scope-stack)))
+            (when function-call-p
+              (context-coloring-colorize-region child-0-pos child-0-end 0)
+              (setq function-call-p nil))
+            (cond
+             (in-defun-p
+              (goto-char child-0-end)
+              ;; Lookahead for defun name
+              (skip-syntax-forward " " end)
+              (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)))
+              (cond
+               ;; Word
+               ((context-coloring-emacs-lisp-identifier-syntax-p 
child-1-syntax-code)
+                (setq child-1-end (scan-sexps child-1-pos 1))
+                ;; defuns are global so use level 0
+                (context-coloring-colorize-region child-1-pos child-1-end 0)))
+              (goto-char child-1-end)
+              ;; Lookahead for parameters
+              (skip-syntax-forward " " end)
+              (when (= 4 (logand #xFFFF (car (syntax-after (point)))))
+                (setq child-2-end (scan-sexps (point) 1))
+                (setq defun-arglist (read (buffer-substring-no-properties
+                                           (point)
+                                           child-2-end)))
+                (while defun-arglist
+                  (setq defun-arg (car defun-arglist))
+                  (when (and (symbolp defun-arg)
+                             (string-match-p "\\`[^&:]" (symbol-name 
defun-arg)))
+                    (context-coloring-scope-add-variable
+                     (car scope-stack)
+                     defun-arg))
+                  (setq defun-arglist (cdr defun-arglist))))
+              (goto-char child-2-end)
+              ;; Cleanup
+              (setq in-defun-p nil))
+             (t
+              (goto-char (cond
+                          ;; If there was a word, continue parsing after it.
+                          (one-word-found-p
+                           (1+ child-0-end))
+                          (t
+                           (1+ token-pos))))))
+            ;; Cleanup
+            (setq one-word-found-p nil))
+           ;; Word (variable)
+           ((context-coloring-emacs-lisp-identifier-syntax-p token-syntax-code)
+            (setq variable-end (scan-sexps (point) 1))
+            (setq variable-string (buffer-substring-no-properties
+                                   token-pos
+                                   variable-end))
+            (setq variable (intern variable-string))
+            (setq variable-scope-level
+                  (context-coloring-get-variable-level scope-stack variable))
+            (when (/= variable-scope-level (context-coloring-scope-get-level
+                                            (car scope-stack)))
+              (context-coloring-colorize-region
+               token-pos
+               variable-end
+               variable-scope-level))
+            (goto-char variable-end))
+           ;; Closing delimiter
+           (t
+            (forward-char)
+            ;; End scope
+            (setq ppss (parse-partial-sexp last-ppss-pos (point) nil nil ppss))
+            (setq last-ppss-pos (point))
+            (when (= (nth 0 ppss) (context-coloring-scope-get-depth (car 
scope-stack)))
+              (setq scope-stack (cdr scope-stack))))))))))
+
+
 ;;; Shell command scopification / colorization
 
 (defun context-coloring-apply-tokens (tokens)
@@ -468,6 +649,11 @@ should be numeric, e.g. \"2\", \"19700101\", \"1.2.3\",
  (lambda ()
    (remove-hook 'js2-post-parse-callbacks 'context-coloring-colorize t)))
 
+(context-coloring-define-dispatch
+ 'emacs-lisp
+ :modes '(emacs-lisp-mode)
+ :colorizer 'context-coloring-emacs-lisp-colorize)
+
 (defun context-coloring-dispatch (&optional callback)
   "Determine the optimal track for scopification / coloring of
 the current buffer, then execute it.
diff --git a/test/context-coloring-test.el b/test/context-coloring-test.el
index b9a43d9..8bd91fd 100644
--- a/test/context-coloring-test.el
+++ b/test/context-coloring-test.el
@@ -167,6 +167,25 @@ format."
         ',setup-function-name
         (,function-name)))))
 
+(defmacro context-coloring-test-emacs-lisp-mode (fixture &rest body)
+  "Use FIXTURE as the subject matter for test logic in BODY."
+  `(context-coloring-test-with-fixture
+    ,fixture
+    (emacs-lisp-mode)
+    (context-coloring-mode)
+    ,@body))
+
+(defmacro context-coloring-test-deftest-emacs-lisp-mode (name &rest body)
+  "Define a test for `emacs-lisp-mode' with name and fixture as
+NAME, with BODY containing the assertions."
+  (declare (indent defun))
+  (let ((test-name (intern (format "context-coloring-emacs-lisp-mode-%s" 
name)))
+        (fixture (format "./fixtures/%s.el" name)))
+    `(ert-deftest ,test-name ()
+       (context-coloring-test-emacs-lisp-mode
+        ,fixture
+        ,@body))))
+
 
 ;;; Assertion functions
 
@@ -988,6 +1007,16 @@ see that function."
 
 (context-coloring-test-deftest-js2-mode unterminated-comment)
 
+(context-coloring-test-deftest-emacs-lisp-mode defun
+  (context-coloring-test-assert-region-level 1 8 1)    ; (defun
+  (context-coloring-test-assert-region-level 8 11 0)   ; abc
+  (context-coloring-test-assert-region-level 11 39 1)  ; (def ghi &optional 
jkl) (
+  (context-coloring-test-assert-region-level 39 40 0)  ; +
+  (context-coloring-test-assert-region-level 40 53 1)  ; def ghi jkl
+  (context-coloring-test-assert-region-level 53 57 0)  ; free
+  (context-coloring-test-assert-region-level 57 59 1)  ; ))
+  (context-coloring-test-assert-region-level 61 72 0)) ; (abc 1 2 3)
+
 (provide 'context-coloring-test)
 
 ;;; context-coloring-test.el ends here
diff --git a/test/fixtures/defun.el b/test/fixtures/defun.el
new file mode 100644
index 0000000..9ed7b7b
--- /dev/null
+++ b/test/fixtures/defun.el
@@ -0,0 +1,4 @@
+(defun abc (def ghi &optional jkl)
+  (+ def ghi jkl free))
+
+(abc 1 2 3)