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

   1 ;;; context-coloring-emacs-lisp.el --- Emacs Lisp support  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014-2016  Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; Add Emacs Lisp context coloring support.
  23
  24 ;;; Code:
  25
  26 (require 'context-coloring)
  27
  28
  29 ;;; Emacs Lisp colorization
  30
  31 (defconst context-coloring-WORD-CODE 2)
  32 (defconst context-coloring-SYMBOL-CODE 3)
  33 (defconst context-coloring-OPEN-PARENTHESIS-CODE 4)
  34 (defconst context-coloring-CLOSE-PARENTHESIS-CODE 5)
  35 (defconst context-coloring-EXPRESSION-PREFIX-CODE 6)
  36 (defconst context-coloring-STRING-QUOTE-CODE 7)
  37 (defconst context-coloring-ESCAPE-CODE 9)
  38 (defconst context-coloring-COMMENT-START-CODE 11)
  39 (defconst context-coloring-COMMENT-END-CODE 12)
  40
  41 (defconst context-coloring-OCTOTHORPE-CHAR (string-to-char "#"))
  42 (defconst context-coloring-APOSTROPHE-CHAR (string-to-char "'"))
  43 (defconst context-coloring-OPEN-PARENTHESIS-CHAR (string-to-char "("))
  44 (defconst context-coloring-COMMA-CHAR (string-to-char ","))
  45 (defconst context-coloring-AT-CHAR (string-to-char "@"))
  46 (defconst context-coloring-BACKTICK-CHAR (string-to-char "`"))
  47
  48 (defsubst context-coloring-get-syntax-code ()
  49   "Get the syntax code at point."
  50   (syntax-class
  51    ;; Faster version of `syntax-after':
  52    (aref (syntax-table) (char-after (point)))))
  53
  54 (defsubst context-coloring-forward-sws ()
  55   "Move forward through whitespace and comments."
  56   (while (forward-comment 1)))
  57
  58 (defsubst context-coloring-elisp-forward-sws ()
  59   "Move through whitespace and comments, coloring comments."
  60   (let ((start (point)))
  61     (context-coloring-forward-sws)
  62     (context-coloring-colorize-comments-and-strings start (point))))
  63
  64 (defsubst context-coloring-elisp-forward-sexp ()
  65   "Skip/ignore missing sexps, coloring comments and strings."
  66   (let ((start (point)))
  67     (when (= (context-coloring-get-syntax-code)
  68              context-coloring-EXPRESSION-PREFIX-CODE)
  69       ;; `forward-sexp' does not skip an unfinished expression (e.g. when the
  70       ;; name of a symbol or the parentheses of a list do not follow a single
  71       ;; quote).
  72       (forward-char))
  73     (condition-case nil
  74         (forward-sexp)
  75       (scan-error (context-coloring-forward-sws)))
  76     (context-coloring-elisp-colorize-comments-and-strings-in-region
  77      start (point))))
  78
  79 (defsubst context-coloring-exact-regexp (word)
  80   "Create a regexp matching exactly WORD."
  81   (concat "\\`" (regexp-quote word) "\\'"))
  82
  83 (defsubst context-coloring-exact-or-regexp (words)
  84   "Create a regexp matching any exact word in WORDS."
  85   (context-coloring-join
  86    (mapcar #'context-coloring-exact-regexp words) "\\|"))
  87
  88 (defconst context-coloring-elisp-ignored-word-regexp
  89   (context-coloring-join (list "\\`[-+]?[0-9]"
  90                                "\\`[&:].+"
  91                                (context-coloring-exact-or-regexp
  92                                 '("t" "nil" "." "?")))
  93                          "\\|")
  94   "Match symbols that can't be bound as variables.")
  95
  96 (defsubst context-coloring-elisp-identifier-p (syntax-code)
  97   "Check if SYNTAX-CODE is an elisp identifier constituent."
  98   (or (= syntax-code context-coloring-WORD-CODE)
  99       (= syntax-code context-coloring-SYMBOL-CODE)))
 100
 101 (defconst context-coloring-elisp-sexps-per-pause 350
 102   "Pause after this many iterations to check for user input.
 103 If user input is pending, stop the parse.  This makes for a
 104 smoother user experience for large files.
 105
 106 This number should trigger pausing at about 60 frames per
 107 second.")
 108
 109 (defvar context-coloring-elisp-sexp-count 0
 110   "Current number of sexps leading up to the next pause.")
 111
 112 (defsubst context-coloring-elisp-increment-sexp-count ()
 113   "Maybe check if the user interrupted the current parse."
 114   (setq context-coloring-elisp-sexp-count
 115         (1+ context-coloring-elisp-sexp-count))
 116   (when (and (zerop (% context-coloring-elisp-sexp-count
 117                        context-coloring-elisp-sexps-per-pause))
 118              context-coloring-parse-interruptable-p
 119              (input-pending-p))
 120     (throw 'interrupted t)))
 121
 122 (defvar context-coloring-elisp-scope-stack '()
 123   "List of scopes in the current parse.")
 124
 125 (defsubst context-coloring-elisp-make-scope (level)
 126   "Make a scope object for LEVEL."
 127   (list
 128    :level level
 129    :variables '()))
 130
 131 (defsubst context-coloring-elisp-scope-get-level (scope)
 132   "Get the level of SCOPE object."
 133   (plist-get scope :level))
 134
 135 (defsubst context-coloring-elisp-scope-add-variable (scope variable)
 136   "Add to SCOPE a VARIABLE."
 137   (plist-put scope :variables (cons variable (plist-get scope :variables))))
 138
 139 (defsubst context-coloring-elisp-scope-has-variable (scope variable)
 140   "Check if SCOPE has VARIABLE."
 141   (member variable (plist-get scope :variables)))
 142
 143 (defsubst context-coloring-elisp-get-variable-level (variable)
 144   "Return the level of VARIABLE, or 0 if it isn't found."
 145   (let* ((scope-stack context-coloring-elisp-scope-stack)
 146          scope
 147          level)
 148     (while (and scope-stack (not level))
 149       (setq scope (car scope-stack))
 150       (cond
 151        ((context-coloring-elisp-scope-has-variable scope variable)
 152         (setq level (context-coloring-elisp-scope-get-level scope)))
 153        (t
 154         (setq scope-stack (cdr scope-stack)))))
 155     ;; Assume a global variable.
 156     (or level 0)))
 157
 158 (defsubst context-coloring-elisp-get-current-scope-level ()
 159   "Get the nesting level of the current scope."
 160   (cond
 161    ((car context-coloring-elisp-scope-stack)
 162     (context-coloring-elisp-scope-get-level (car context-coloring-elisp-scope-stack)))
 163    (t
 164     0)))
 165
 166 (defsubst context-coloring-elisp-push-scope ()
 167   "Add a new scope to the bottom of the scope chain."
 168   (push (context-coloring-elisp-make-scope
 169          (1+ (context-coloring-elisp-get-current-scope-level)))
 170         context-coloring-elisp-scope-stack))
 171
 172 (defsubst context-coloring-elisp-pop-scope ()
 173   "Remove the scope on the bottom of the scope chain."
 174   (pop context-coloring-elisp-scope-stack))
 175
 176 (defsubst context-coloring-elisp-add-variable (variable)
 177   "Add VARIABLE to the current scope."
 178   (context-coloring-elisp-scope-add-variable
 179    (car context-coloring-elisp-scope-stack)
 180    variable))
 181
 182 (defsubst context-coloring-elisp-parse-bindable (callback)
 183   "Parse the symbol at point.
 184 If the symbol can be bound, invoke CALLBACK with it."
 185   (let* ((arg-string (buffer-substring-no-properties
 186                       (point)
 187                       (progn (context-coloring-elisp-forward-sexp)
 188                              (point)))))
 189     (when (not (string-match-p
 190                 context-coloring-elisp-ignored-word-regexp
 191                 arg-string))
 192       (funcall callback arg-string))))
 193
 194 (defun context-coloring-elisp-parse-let-varlist (type)
 195   "Parse the list of variable initializers at point.
 196 If TYPE is `let', all the variables are bound after all their
 197 initializers are parsed; if TYPE is `let*', each variable is
 198 bound immediately after its own initializer is parsed."
 199   (let ((varlist '())
 200         syntax-code)
 201     ;; Enter.
 202     (forward-char)
 203     (context-coloring-elisp-forward-sws)
 204     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 205                context-coloring-CLOSE-PARENTHESIS-CODE)
 206       (cond
 207        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 208         (forward-char)
 209         (context-coloring-elisp-forward-sws)
 210         (setq syntax-code (context-coloring-get-syntax-code))
 211         (when (context-coloring-elisp-identifier-p syntax-code)
 212           (context-coloring-elisp-parse-bindable
 213            (lambda (var)
 214              (push var varlist)))
 215           (context-coloring-elisp-forward-sws)
 216           (setq syntax-code (context-coloring-get-syntax-code))
 217           (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
 218             (context-coloring-elisp-colorize-sexp)))
 219         (context-coloring-elisp-forward-sws)
 220         ;; Skip past the closing parenthesis.
 221         (forward-char))
 222        ((context-coloring-elisp-identifier-p syntax-code)
 223         (context-coloring-elisp-parse-bindable
 224          (lambda (var)
 225            (push var varlist))))
 226        (t
 227         ;; Ignore artifacts.
 228         (context-coloring-elisp-forward-sexp)))
 229       (when (eq type 'let*)
 230         (context-coloring-elisp-add-variable (pop varlist)))
 231       (context-coloring-elisp-forward-sws))
 232     (when (eq type 'let)
 233       (while varlist
 234         (context-coloring-elisp-add-variable (pop varlist))))
 235     ;; Exit.
 236     (forward-char)))
 237
 238 (defun context-coloring-elisp-parse-arglist ()
 239   "Parse the list of function arguments at point."
 240   (let (syntax-code)
 241     ;; Enter.
 242     (forward-char)
 243     (context-coloring-elisp-forward-sws)
 244     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 245                context-coloring-CLOSE-PARENTHESIS-CODE)
 246       (cond
 247        ((context-coloring-elisp-identifier-p syntax-code)
 248         (context-coloring-elisp-parse-bindable
 249          (lambda (arg)
 250            (context-coloring-elisp-add-variable arg))))
 251        (t
 252         ;; Ignore artifacts.
 253         (context-coloring-elisp-forward-sexp)))
 254       (context-coloring-elisp-forward-sws))
 255     ;; Exit.
 256     (forward-char)))
 257
 258 (defun context-coloring-elisp-skip-callee-name ()
 259   "Skip past the opening parenthesis and name of a function."
 260   ;; Enter.
 261   (forward-char)
 262   (context-coloring-elisp-forward-sws)
 263   ;; Skip past the function name.
 264   (forward-sexp)
 265   (context-coloring-elisp-forward-sws))
 266
 267 (defun context-coloring-elisp-colorize-scope (callback)
 268   "Color the whole scope at point with its one color.
 269 Handle a header in CALLBACK."
 270   (let ((start (point))
 271         (end (progn (forward-sexp)
 272                     (point))))
 273     (context-coloring-elisp-push-scope)
 274     ;; Splash the whole thing in one color.
 275     (context-coloring-colorize-region
 276      start
 277      end
 278      (context-coloring-elisp-get-current-scope-level))
 279     ;; Even if the parse is interrupted, this region should still be colored
 280     ;; syntactically.
 281     (context-coloring-elisp-colorize-comments-and-strings-in-region
 282      start
 283      end)
 284     (goto-char start)
 285     (context-coloring-elisp-skip-callee-name)
 286     (funcall callback)
 287     (context-coloring-elisp-colorize-region (point) (1- end))
 288     ;; Exit.
 289     (forward-char)
 290     (context-coloring-elisp-pop-scope)))
 291
 292 (defun context-coloring-elisp-parse-header (callback)
 293   "Parse a function header at point with CALLBACK."
 294   (when (= (context-coloring-get-syntax-code) context-coloring-OPEN-PARENTHESIS-CODE)
 295     (funcall callback)))
 296
 297 (defun context-coloring-elisp-colorize-defun-like (callback)
 298   "Color the defun-like function at point.
 299 Parse the header with CALLBACK."
 300   (context-coloring-elisp-colorize-scope
 301    (lambda ()
 302      (when (context-coloring-elisp-identifier-p (context-coloring-get-syntax-code))
 303        ;; Color the defun's name with the top-level color.
 304        (context-coloring-colorize-region
 305         (point)
 306         (progn (forward-sexp)
 307                (point))
 308         0)
 309        (context-coloring-elisp-forward-sws)
 310        (context-coloring-elisp-parse-header callback)))))
 311
 312 (defun context-coloring-elisp-colorize-defun ()
 313   "Color the `defun' at point."
 314   (context-coloring-elisp-colorize-defun-like
 315    'context-coloring-elisp-parse-arglist))
 316
 317 (defun context-coloring-elisp-colorize-defadvice ()
 318   "Color the `defadvice' at point."
 319   (context-coloring-elisp-colorize-defun-like
 320    (lambda ()
 321      (let (syntax-code)
 322        ;; Enter.
 323        (forward-char)
 324        (context-coloring-elisp-forward-sws)
 325        (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 326                   context-coloring-CLOSE-PARENTHESIS-CODE)
 327          (cond
 328           ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 329            (context-coloring-elisp-parse-arglist))
 330           (t
 331            ;; Ignore artifacts.
 332            (context-coloring-elisp-forward-sexp)))
 333          (context-coloring-elisp-forward-sws))))))
 334
 335 (defun context-coloring-elisp-colorize-lambda-like (callback)
 336   "Color the lambda-like function at point.
 337 Parsing the header with CALLBACK."
 338   (context-coloring-elisp-colorize-scope
 339    (lambda ()
 340      (context-coloring-elisp-parse-header callback))))
 341
 342 (defun context-coloring-elisp-colorize-lambda ()
 343   "Color the `lambda' at point."
 344   (context-coloring-elisp-colorize-lambda-like
 345    'context-coloring-elisp-parse-arglist))
 346
 347 (defun context-coloring-elisp-colorize-let ()
 348   "Color the `let' at point."
 349   (context-coloring-elisp-colorize-lambda-like
 350    (lambda ()
 351      (context-coloring-elisp-parse-let-varlist 'let))))
 352
 353 (defun context-coloring-elisp-colorize-let* ()
 354   "Color the `let*' at point."
 355   (context-coloring-elisp-colorize-lambda-like
 356    (lambda ()
 357      (context-coloring-elisp-parse-let-varlist 'let*))))
 358
 359 (defun context-coloring-elisp-colorize-macroexp-let2 ()
 360   "Color the `macroexp-let2' at point."
 361   (let (syntax-code
 362         variable)
 363     (context-coloring-elisp-colorize-scope
 364      (lambda ()
 365        (and
 366         (progn
 367           (setq syntax-code (context-coloring-get-syntax-code))
 368           (context-coloring-elisp-identifier-p syntax-code))
 369         (progn
 370           (context-coloring-elisp-colorize-sexp)
 371           (context-coloring-elisp-forward-sws)
 372           (setq syntax-code (context-coloring-get-syntax-code))
 373           (context-coloring-elisp-identifier-p syntax-code))
 374         (progn
 375           (context-coloring-elisp-parse-bindable
 376            (lambda (parsed-variable)
 377              (setq variable parsed-variable)))
 378           (context-coloring-elisp-forward-sws)
 379           (when variable
 380             (context-coloring-elisp-add-variable variable))))))))
 381
 382 (defun context-coloring-elisp-colorize-cond ()
 383   "Color the `cond' at point."
 384   (let (syntax-code)
 385     (context-coloring-elisp-skip-callee-name)
 386     (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 387                context-coloring-CLOSE-PARENTHESIS-CODE)
 388       (cond
 389        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 390         ;; Colorize inside the parens.
 391         (let ((start (point)))
 392           (forward-sexp)
 393           (context-coloring-elisp-colorize-region
 394            (1+ start) (1- (point)))
 395           ;; Exit.
 396           (forward-char)))
 397        (t
 398         ;; Ignore artifacts.
 399         (context-coloring-elisp-forward-sexp)))
 400       (context-coloring-elisp-forward-sws))
 401     ;; Exit.
 402     (forward-char)))
 403
 404 (defun context-coloring-elisp-colorize-condition-case ()
 405   "Color the `condition-case' at point."
 406   (let (syntax-code
 407         variable
 408         case-pos
 409         case-end)
 410     (context-coloring-elisp-colorize-scope
 411      (lambda ()
 412        (setq syntax-code (context-coloring-get-syntax-code))
 413        ;; Gracefully ignore missing variables.
 414        (when (context-coloring-elisp-identifier-p syntax-code)
 415          (context-coloring-elisp-parse-bindable
 416           (lambda (parsed-variable)
 417             (setq variable parsed-variable)))
 418          (context-coloring-elisp-forward-sws))
 419        (context-coloring-elisp-colorize-sexp)
 420        (context-coloring-elisp-forward-sws)
 421        ;; Parse the handlers with the error variable in scope.
 422        (when variable
 423          (context-coloring-elisp-add-variable variable))
 424        (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 425                   context-coloring-CLOSE-PARENTHESIS-CODE)
 426          (cond
 427           ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 428            (setq case-pos (point))
 429            (context-coloring-elisp-forward-sexp)
 430            (setq case-end (point))
 431            (goto-char case-pos)
 432            ;; Enter.
 433            (forward-char)
 434            (context-coloring-elisp-forward-sws)
 435            (setq syntax-code (context-coloring-get-syntax-code))
 436            (when (/= syntax-code context-coloring-CLOSE-PARENTHESIS-CODE)
 437              ;; Skip the condition name(s).
 438              (context-coloring-elisp-forward-sexp)
 439              ;; Color the remaining portion of the handler.
 440              (context-coloring-elisp-colorize-region
 441               (point)
 442               (1- case-end)))
 443            ;; Exit.
 444            (forward-char))
 445           (t
 446            ;; Ignore artifacts.
 447            (context-coloring-elisp-forward-sexp)))
 448          (context-coloring-elisp-forward-sws))))))
 449
 450 (defun context-coloring-elisp-colorize-dolist ()
 451   "Color the `dolist' at point."
 452   (let (syntax-code
 453         (index 0))
 454     (context-coloring-elisp-colorize-scope
 455      (lambda ()
 456        (setq syntax-code (context-coloring-get-syntax-code))
 457        (when (= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 458          (forward-char)
 459          (context-coloring-elisp-forward-sws)
 460          (while (/= (setq syntax-code (context-coloring-get-syntax-code))
 461                     context-coloring-CLOSE-PARENTHESIS-CODE)
 462            (cond
 463             ((and
 464               (or (= index 0) (= index 2))
 465               (context-coloring-elisp-identifier-p syntax-code))
 466              ;; Add the first or third name to the scope.
 467              (context-coloring-elisp-parse-bindable
 468               (lambda (variable)
 469                 (context-coloring-elisp-add-variable variable))))
 470             (t
 471              ;; Color artifacts.
 472              (context-coloring-elisp-colorize-sexp)))
 473            (context-coloring-elisp-forward-sws)
 474            (setq index (1+ index)))
 475          ;; Exit.
 476          (forward-char))))))
 477
 478 (defun context-coloring-elisp-colorize-quote ()
 479   "Color the `quote' at point."
 480   (let* ((start (point))
 481          (end (progn (forward-sexp)
 482                      (point))))
 483     (context-coloring-colorize-region
 484      start
 485      end
 486      (context-coloring-elisp-get-current-scope-level))
 487     (context-coloring-elisp-colorize-comments-and-strings-in-region start end)))
 488
 489 (defvar context-coloring-elisp-callee-dispatch-hash-table
 490   (let ((table (make-hash-table :test 'equal)))
 491     (dolist (callee '("defun" "defun*" "defsubst" "defmacro" "cl-defun" "cl-defsubst" "cl-defmacro"))
 492       (puthash callee #'context-coloring-elisp-colorize-defun table))
 493     (dolist (callee '("condition-case" "condition-case-unless-debug"))
 494       (puthash callee #'context-coloring-elisp-colorize-condition-case table))
 495     (dolist (callee '("dolist" "dotimes"))
 496       (puthash callee #'context-coloring-elisp-colorize-dolist table))
 497     (dolist (callee '("let" "gv-letplace"))
 498       (puthash callee #'context-coloring-elisp-colorize-let table))
 499     (puthash "let*" #'context-coloring-elisp-colorize-let* table)
 500     (puthash "macroexp-let2" #'context-coloring-elisp-colorize-macroexp-let2 table)
 501     (puthash "lambda" #'context-coloring-elisp-colorize-lambda table)
 502     (puthash "cond" #'context-coloring-elisp-colorize-cond table)
 503     (puthash "defadvice" #'context-coloring-elisp-colorize-defadvice table)
 504     (puthash "quote" #'context-coloring-elisp-colorize-quote table)
 505     (puthash "backquote" #'context-coloring-elisp-colorize-backquote table)
 506     table)
 507   "Map function names to their coloring functions.")
 508
 509 (defun context-coloring-elisp-colorize-parenthesized-sexp ()
 510   "Color the sexp enclosed by parenthesis at point."
 511   (context-coloring-elisp-increment-sexp-count)
 512   (let* ((start (point))
 513          (end (progn (forward-sexp)
 514                      (point)))
 515          (syntax-code (progn (goto-char start)
 516                              (forward-char)
 517                              ;; Coloring is unnecessary here, it'll happen
 518                              ;; presently.
 519                              (context-coloring-forward-sws)
 520                              (context-coloring-get-syntax-code)))
 521          dispatch-function)
 522     ;; Figure out if the sexp is a special form.
 523     (cond
 524      ((and (context-coloring-elisp-identifier-p syntax-code)
 525            (setq dispatch-function (gethash
 526                                     (buffer-substring-no-properties
 527                                      (point)
 528                                      (progn (forward-sexp)
 529                                             (point)))
 530                                     context-coloring-elisp-callee-dispatch-hash-table)))
 531       (goto-char start)
 532       (funcall dispatch-function))
 533      ;; Not a special form; just colorize the remaining region.
 534      (t
 535       (context-coloring-colorize-region
 536        start
 537        end
 538        (context-coloring-elisp-get-current-scope-level))
 539       (context-coloring-elisp-colorize-region (point) (1- end))
 540       (forward-char)))))
 541
 542 (defun context-coloring-elisp-colorize-symbol ()
 543   "Color the symbol at point."
 544   (context-coloring-elisp-increment-sexp-count)
 545   (let* ((symbol-pos (point))
 546          (symbol-end (progn (forward-sexp)
 547                             (point)))
 548          (symbol-string (buffer-substring-no-properties
 549                          symbol-pos
 550                          symbol-end)))
 551     (cond
 552      ((string-match-p context-coloring-elisp-ignored-word-regexp symbol-string))
 553      (t
 554       (context-coloring-colorize-region
 555        symbol-pos
 556        symbol-end
 557        (context-coloring-elisp-get-variable-level
 558         symbol-string))))))
 559
 560 (defun context-coloring-elisp-colorize-backquote-form ()
 561   "Color the backquote form at point."
 562   (let ((start (point))
 563         (end (progn (forward-sexp)
 564                     (point)))
 565         char)
 566     (goto-char start)
 567     (while (> end (progn (forward-char)
 568                          (point)))
 569       (setq char (char-after))
 570       (when (= char context-coloring-COMMA-CHAR)
 571         (forward-char)
 572         (when (= (char-after) context-coloring-AT-CHAR)
 573           ;; If we don't do this "@" could be interpreted as a symbol.
 574           (forward-char))
 575         (context-coloring-elisp-forward-sws)
 576         (context-coloring-elisp-colorize-sexp)))
 577     ;; We could probably do this as part of the above loop but it'd be
 578     ;; repetitive.
 579     (context-coloring-elisp-colorize-comments-and-strings-in-region
 580      start end)))
 581
 582 (defun context-coloring-elisp-colorize-backquote ()
 583   "Color the `backquote' at point."
 584   (context-coloring-elisp-skip-callee-name)
 585   (context-coloring-elisp-colorize-backquote-form)
 586   ;; Exit.
 587   (forward-char))
 588
 589 (defun context-coloring-elisp-colorize-expression-prefix ()
 590   "Color the expression prefix and expression at point.
 591 It could be a quoted or backquoted expression."
 592   (context-coloring-elisp-increment-sexp-count)
 593   (cond
 594    ((/= (char-after) context-coloring-BACKTICK-CHAR)
 595     (context-coloring-elisp-forward-sexp))
 596    (t
 597     (context-coloring-elisp-colorize-backquote-form))))
 598
 599 (defun context-coloring-elisp-colorize-comment ()
 600   "Color the comment at point."
 601   (context-coloring-elisp-increment-sexp-count)
 602   (context-coloring-elisp-forward-sws))
 603
 604 (defun context-coloring-elisp-colorize-string ()
 605   "Color the string at point."
 606   (context-coloring-elisp-increment-sexp-count)
 607   (let ((start (point)))
 608     (forward-sexp)
 609     (context-coloring-colorize-comments-and-strings start (point))))
 610
 611 ;; Elisp has whitespace, words, symbols, open/close parenthesis, expression
 612 ;; prefix, string quote, comment starters/enders and escape syntax classes only.
 613
 614 (defun context-coloring-elisp-colorize-sexp ()
 615   "Color the sexp at point."
 616   (let ((syntax-code (context-coloring-get-syntax-code)))
 617     (cond
 618      ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 619       (context-coloring-elisp-colorize-parenthesized-sexp))
 620      ((context-coloring-elisp-identifier-p syntax-code)
 621       (context-coloring-elisp-colorize-symbol))
 622      ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
 623       (context-coloring-elisp-colorize-expression-prefix))
 624      ((= syntax-code context-coloring-STRING-QUOTE-CODE)
 625       (context-coloring-elisp-colorize-string))
 626      ((= syntax-code context-coloring-ESCAPE-CODE)
 627       (forward-char 2)))))
 628
 629 (defun context-coloring-elisp-colorize-comments-and-strings-in-region (start end)
 630   "Color comments and strings between START and END."
 631   (let (syntax-code)
 632     (goto-char start)
 633     (while (> end (progn (skip-syntax-forward "^\"<\\" end)
 634                          (point)))
 635       (setq syntax-code (context-coloring-get-syntax-code))
 636       (cond
 637        ((= syntax-code context-coloring-STRING-QUOTE-CODE)
 638         (context-coloring-elisp-colorize-string))
 639        ((= syntax-code context-coloring-COMMENT-START-CODE)
 640         (context-coloring-elisp-colorize-comment))
 641        ((= syntax-code context-coloring-ESCAPE-CODE)
 642         (forward-char 2))))))
 643
 644 (defun context-coloring-elisp-colorize-region (start end)
 645   "Color everything between START and END."
 646   (let (syntax-code)
 647     (goto-char start)
 648     (while (> end (progn (skip-syntax-forward "^w_('\"<\\" end)
 649                          (point)))
 650       (setq syntax-code (context-coloring-get-syntax-code))
 651       (cond
 652        ((= syntax-code context-coloring-OPEN-PARENTHESIS-CODE)
 653         (context-coloring-elisp-colorize-parenthesized-sexp))
 654        ((context-coloring-elisp-identifier-p syntax-code)
 655         (context-coloring-elisp-colorize-symbol))
 656        ((= syntax-code context-coloring-EXPRESSION-PREFIX-CODE)
 657         (context-coloring-elisp-colorize-expression-prefix))
 658        ((= syntax-code context-coloring-STRING-QUOTE-CODE)
 659         (context-coloring-elisp-colorize-string))
 660        ((= syntax-code context-coloring-COMMENT-START-CODE)
 661         (context-coloring-elisp-colorize-comment))
 662        ((= syntax-code context-coloring-ESCAPE-CODE)
 663         (forward-char 2))))))
 664
 665 (defun context-coloring-elisp-colorize-region-initially (start end)
 666   "Begin coloring everything between START and END."
 667   (setq context-coloring-elisp-sexp-count 0)
 668   (setq context-coloring-elisp-scope-stack '())
 669   (let ((inhibit-point-motion-hooks t)
 670         (case-fold-search nil)
 671         ;; This is a recursive-descent parser, so give it a big stack.
 672         (max-lisp-eval-depth (max max-lisp-eval-depth 3000))
 673         (max-specpdl-size (max max-specpdl-size 3000)))
 674     (context-coloring-elisp-colorize-region start end)))
 675
 676 (defun context-coloring-elisp-colorize-guard (callback)
 677   "Silently color in CALLBACK."
 678   (with-silent-modifications
 679     (save-excursion
 680       (condition-case nil
 681           (funcall callback)
 682         ;; Scan errors can happen virtually anywhere if parenthesis are
 683         ;; unbalanced.  Just swallow them.  (`progn' for test coverage.)
 684         (scan-error (progn))))))
 685
 686 ;;;###autoload
 687 (defun context-coloring-elisp-colorize ()
 688   "Color the current Emacs Lisp buffer."
 689   (interactive)
 690   (context-coloring-elisp-colorize-guard
 691    (lambda ()
 692      (cond
 693       ;; Just colorize the changed region.
 694       (context-coloring-changed-p
 695        (let* ( ;; Prevent `beginning-of-defun' from making poor assumptions.
 696               (open-paren-in-column-0-is-defun-start nil)
 697               ;; Seek the beginning and end of the previous and next
 698               ;; offscreen defuns, so just enough is colored.
 699               (start (progn (goto-char context-coloring-changed-start)
 700                             (while (and (< (point-min) (point))
 701                                         (pos-visible-in-window-p))
 702                               (end-of-line 0))
 703                             (beginning-of-defun)
 704                             (point)))
 705               (end (progn (goto-char context-coloring-changed-end)
 706                           (while (and (> (point-max) (point))
 707                                       (pos-visible-in-window-p))
 708                             (forward-line 1))
 709                           (end-of-defun)
 710                           (point))))
 711          (context-coloring-elisp-colorize-region-initially start end)
 712          ;; Fast coloring is nice, but if the code is not well-formed
 713          ;; (e.g. an unclosed string literal is parsed at any time) then
 714          ;; there could be leftover incorrectly-colored code offscreen.  So
 715          ;; do a clean sweep as soon as appropriate.
 716          (context-coloring-schedule-coloring context-coloring-default-delay)))
 717       (t
 718        (context-coloring-elisp-colorize-region-initially (point-min) (point-max)))))))
 719
 720 (context-coloring-define-dispatch
 721  'emacs-lisp
 722  :modes '(emacs-lisp-mode lisp-interaction-mode)
 723  :colorizer #'context-coloring-elisp-colorize
 724  :delay 0.016 ;; Thanks to lazy colorization this can be 60 frames per second.
 725  :setup #'context-coloring-setup-idle-change-detection
 726  :teardown #'context-coloring-teardown-idle-change-detection)
 727
 728
 729 ;;; eval-expression colorization
 730
 731 (defun context-coloring-eval-expression-match ()
 732   "Determine expression start in `eval-expression'."
 733   (string-match "\\`Eval: " (buffer-string)))
 734
 735 ;;;###autoload
 736 (defun context-coloring-eval-expression-colorize ()
 737   "Color the `eval-expression' minibuffer prompt as elisp."
 738   (interactive)
 739   (context-coloring-elisp-colorize-guard
 740    (lambda ()
 741      (context-coloring-elisp-colorize-region-initially
 742       (progn
 743         (context-coloring-eval-expression-match)
 744         (1+ (match-end 0)))
 745       (point-max)))))
 746
 747 ;; `eval-expression-minibuffer-setup-hook' is not available in Emacs 24.3, so
 748 ;; the backwards-compatible recommendation is to use `minibuffer-setup-hook' and
 749 ;; rely on this predicate instead.
 750 (defun context-coloring-eval-expression-predicate ()
 751   "Non-nil if the minibuffer is for `eval-expression'."
 752   ;; Kinda better than checking `this-command', because `this-command' changes.
 753   (context-coloring-eval-expression-match))
 754
 755 (context-coloring-define-dispatch
 756  'eval-expression
 757  :predicate #'context-coloring-eval-expression-predicate
 758  :colorizer #'context-coloring-eval-expression-colorize
 759  :delay 0.016
 760  :setup #'context-coloring-setup-idle-change-detection
 761  :teardown #'context-coloring-teardown-idle-change-detection)
 762
 763 (provide 'context-coloring-emacs-lisp)
 764
 765 ;;; context-coloring-emacs-lisp.el ends here