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