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

   1 ;;; context-coloring.el --- Highlight by scope  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014-2016  Free Software Foundation, Inc.
   4
   5 ;; Author: Jackson Ray Hamilton <jackson@jacksonrayhamilton.com>
   6 ;; Version: 7.2.1
   7 ;; Keywords: convenience faces tools
   8 ;; Package-Requires: ((emacs "24.3"))
   9 ;; URL: https://github.com/jacksonrayhamilton/context-coloring
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; This program is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; Highlights code by scope.  Top-level scopes are one color, second-level
  29 ;; scopes are another color, and so on.  Variables retain the color of the scope
  30 ;; in which they are defined.  A variable defined in an outer scope referenced
  31 ;; by an inner scope is colored the same as the outer scope.
  32
  33 ;; By default, comments and strings are still highlighted syntactically.
  34
  35 ;;; Code:
  36
  37
  38 ;;; Utilities
  39
  40 (defun context-coloring-join (strings delimiter)
  41   "Join a list of STRINGS with the string DELIMITER."
  42   (mapconcat #'identity strings delimiter))
  43
  44
  45 ;;; Faces
  46
  47 (defun context-coloring-defface (level light dark tty)
  48   "Define a face for LEVEL with LIGHT, DARK and TTY colors."
  49   (let ((face (intern (format "context-coloring-level-%s-face" level)))
  50         (doc (format "Context coloring face, level %s." level)))
  51     (custom-declare-face
  52      face
  53      `((((type tty)) (:foreground ,tty))
  54        (((background light)) (:foreground ,light))
  55        (((background dark)) (:foreground ,dark)))
  56      doc
  57      :group 'context-coloring)))
  58
  59 ;; Provide some default colors based off Emacs's defaults.
  60 (context-coloring-defface 0 "#000000" "#ffffff" nil)
  61 (context-coloring-defface 1 "#008b8b" "#00ffff" "yellow")
  62 (context-coloring-defface 2 "#0000ff" "#87cefa" "green")
  63 (context-coloring-defface 3 "#483d8b" "#b0c4de" "cyan")
  64 (context-coloring-defface 4 "#a020f0" "#eedd82" "blue")
  65 (context-coloring-defface 5 "#a0522d" "#98fb98" "magenta")
  66 (context-coloring-defface 6 "#228b22" "#7fffd4" "red")
  67 (context-coloring-defface 7 "#3f3f3f" "#cdcdcd" nil)
  68
  69 (defconst context-coloring-default-maximum-face 7
  70   "Maximum face when there are no custom faces.")
  71
  72 ;; Create placeholder faces for users and theme authors.
  73 (dotimes (level 18)
  74   (let* ((level (+ level 8))
  75          (face (intern (format "context-coloring-level-%s-face" level)))
  76          (doc (format "Context coloring face, level %s." level)))
  77     (custom-declare-face face nil doc :group 'context-coloring)))
  78
  79 (defvar-local context-coloring-maximum-face nil
  80   "Dynamic index of the highest face available for coloring.")
  81
  82 (defsubst context-coloring-level-face (level)
  83   "Return symbol for face with LEVEL."
  84   ;; `concat' is faster than `format' here.
  85   (intern-soft
  86    (concat "context-coloring-level-" (number-to-string level) "-face")))
  87
  88 (defsubst context-coloring-bounded-level-face (level)
  89   "Return symbol for face with LEVEL, bounded by the maximum."
  90   (context-coloring-level-face (min level context-coloring-maximum-face)))
  91
  92 (defconst context-coloring-level-face-regexp
  93   "context-coloring-level-\\([[:digit:]]+\\)-face"
  94   "Extract a level from a face.")
  95
  96 (defun context-coloring-theme-highest-level (theme)
  97   "Return the highest coloring level for THEME, or -1."
  98   (let* ((settings (get theme 'theme-settings))
  99          (tail settings)
 100          face-string
 101          number
 102          (found -1))
 103     (while tail
 104       (and (eq (nth 0 (car tail)) 'theme-face)
 105            (setq face-string (symbol-name (nth 1 (car tail))))
 106            (string-match
 107             context-coloring-level-face-regexp
 108             face-string)
 109            (setq number (string-to-number
 110                          (substring face-string
 111                                     (match-beginning 1)
 112                                     (match-end 1))))
 113            (> number found)
 114            (setq found number))
 115       (setq tail (cdr tail)))
 116     found))
 117
 118 (defun context-coloring-update-maximum-face ()
 119   "Save the highest possible face for the current theme."
 120   (let ((themes (append custom-enabled-themes '(user)))
 121         (continue t)
 122         theme
 123         highest-level)
 124     (while continue
 125       (setq theme (car themes))
 126       (setq themes (cdr themes))
 127       (setq highest-level (context-coloring-theme-highest-level theme))
 128       (setq continue (and themes (= highest-level -1))))
 129     (setq context-coloring-maximum-face
 130           (cond
 131            ((= highest-level -1)
 132             context-coloring-default-maximum-face)
 133            (t
 134             highest-level)))))
 135
 136
 137 ;;; Change detection
 138
 139 (defvar-local context-coloring-changed-p nil
 140   "Indication that the buffer has changed recently, which implies
 141 that it should be colored again by
 142 `context-coloring-maybe-colorize-idle-timer' if that timer is
 143 being used.")
 144
 145 (defvar-local context-coloring-changed-start nil
 146   "Beginning of last text that changed.")
 147
 148 (defvar-local context-coloring-changed-end nil
 149   "End of last text that changed.")
 150
 151 (defvar-local context-coloring-changed-length nil
 152   "Length of last text that changed.")
 153
 154 (defun context-coloring-change-function (start end length)
 155   "Register a change so that a buffer can be colorized soon.
 156
 157 START, END and LENGTH are recorded for later use."
 158   ;; Tokenization is obsolete if there was a change.
 159   (setq context-coloring-changed-start start)
 160   (setq context-coloring-changed-end end)
 161   (setq context-coloring-changed-length length)
 162   (setq context-coloring-changed-p t))
 163
 164 (defun context-coloring-maybe-colorize-with-buffer (buffer)
 165   "Color BUFFER and if it has changed."
 166   (when (and (eq buffer (current-buffer))
 167              context-coloring-changed-p)
 168     (context-coloring-colorize-with-buffer buffer)
 169     (setq context-coloring-changed-p nil)
 170     (setq context-coloring-changed-start nil)
 171     (setq context-coloring-changed-end nil)
 172     (setq context-coloring-changed-length nil)))
 173
 174 (defvar-local context-coloring-maybe-colorize-idle-timer nil
 175   "The currently-running idle timer for conditional coloring.")
 176
 177 (defvar-local context-coloring-colorize-idle-timer nil
 178   "The currently-running idle timer for unconditional coloring.")
 179
 180 (defcustom context-coloring-default-delay 0.25
 181   "Default delay between a buffer update and colorization.
 182
 183 Increase this if your machine is high-performing.  Decrease it if
 184 it ain't."
 185   :type 'float
 186   :group 'context-coloring)
 187
 188 (make-obsolete-variable
 189  'context-coloring-delay
 190  'context-coloring-default-delay
 191  "6.4.0")
 192
 193 (defun context-coloring-cancel-timer (timer)
 194   "Cancel TIMER."
 195   (when timer
 196     (cancel-timer timer)))
 197
 198 (defun context-coloring-schedule-coloring (time)
 199   "Schedule coloring to occur once after Emacs is idle for TIME."
 200   (context-coloring-cancel-timer context-coloring-colorize-idle-timer)
 201   (setq context-coloring-colorize-idle-timer
 202         (run-with-idle-timer
 203          time
 204          nil
 205          #'context-coloring-colorize-with-buffer
 206          (current-buffer))))
 207
 208 (defun context-coloring-setup-idle-change-detection ()
 209   "Setup idle change detection."
 210   (let ((dispatch (context-coloring-get-current-dispatch)))
 211     (add-hook
 212      'after-change-functions #'context-coloring-change-function nil t)
 213     (add-hook
 214      'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
 215     (setq context-coloring-maybe-colorize-idle-timer
 216           (run-with-idle-timer
 217            (or (plist-get dispatch :delay) context-coloring-default-delay)
 218            t
 219            #'context-coloring-maybe-colorize-with-buffer
 220            (current-buffer)))))
 221
 222 (defun context-coloring-teardown-idle-change-detection ()
 223   "Teardown idle change detection."
 224   (dolist (timer (list context-coloring-colorize-idle-timer
 225                        context-coloring-maybe-colorize-idle-timer))
 226     (context-coloring-cancel-timer timer))
 227   (remove-hook
 228    'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
 229   (remove-hook
 230    'after-change-functions #'context-coloring-change-function t))
 231
 232
 233 ;;; Colorization utilities
 234
 235 (defsubst context-coloring-colorize-region (start end level)
 236   "Color from START (inclusive) to END (exclusive) with LEVEL."
 237   (add-text-properties
 238    start
 239    end
 240    `(face ,(context-coloring-bounded-level-face level))))
 241
 242 (make-obsolete-variable
 243  'context-coloring-comments-and-strings
 244  "use `context-coloring-syntactic-comments' and
 245  `context-coloring-syntactic-strings' instead."
 246  "6.1.0")
 247
 248 (defcustom context-coloring-syntactic-comments t
 249   "If non-nil, also color comments using `font-lock'."
 250   :type 'boolean
 251   :group 'context-coloring)
 252
 253 (defcustom context-coloring-syntactic-strings t
 254   "If non-nil, also color strings using `font-lock'."
 255   :type 'boolean
 256   :group 'context-coloring)
 257
 258 (defun context-coloring-font-lock-syntactic-comment-function (state)
 259   "Color a comment according to STATE."
 260   (if (nth 3 state) nil font-lock-comment-face))
 261
 262 (defun context-coloring-font-lock-syntactic-string-function (state)
 263   "Color a string according to STATE."
 264   (if (nth 3 state) font-lock-string-face nil))
 265
 266 (defsubst context-coloring-colorize-comments-and-strings (&optional min max)
 267   "Maybe color comments and strings in buffer from MIN to MAX.
 268 MIN defaults to beginning of buffer.  MAX defaults to end."
 269   (when (or context-coloring-syntactic-comments
 270             context-coloring-syntactic-strings)
 271     (let ((min (or min (point-min)))
 272           (max (or max (point-max)))
 273           (font-lock-syntactic-face-function
 274            (cond
 275             ((and context-coloring-syntactic-comments
 276                   (not context-coloring-syntactic-strings))
 277              #'context-coloring-font-lock-syntactic-comment-function)
 278             ((and context-coloring-syntactic-strings
 279                   (not context-coloring-syntactic-comments))
 280              #'context-coloring-font-lock-syntactic-string-function)
 281             (t
 282              font-lock-syntactic-face-function))))
 283       (save-excursion
 284         (font-lock-fontify-syntactically-region min max)
 285         ;; TODO: Make configurable at the dispatch level.
 286         (when (eq major-mode 'emacs-lisp-mode)
 287           (font-lock-fontify-keywords-region min max))))))
 288
 289 (defcustom context-coloring-initial-level 0
 290   "Scope level at which to start coloring.
 291
 292 If top-level variables and functions do not become global, but
 293 are scoped to a file (as in Node.js), set this to `1'."
 294   :type 'integer
 295   :safe #'integerp
 296   :group 'context-coloring)
 297
 298
 299 ;;; Dispatch
 300
 301 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
 302   "Map dispatch strategy names to their property lists.")
 303
 304 (defvar context-coloring-mode-hash-table (make-hash-table :test #'eq)
 305   "Map major mode names to dispatch property lists.")
 306
 307 (defvar context-coloring-dispatch-predicates '()
 308   "Functions which may return a dispatch.")
 309
 310 (defun context-coloring-get-current-dispatch ()
 311   "Return the first dispatch appropriate for the current state."
 312   (let ((predicates context-coloring-dispatch-predicates)
 313         dispatch)
 314     ;; Maybe a predicate will be satisfied and return a dispatch.
 315     (while (and predicates
 316                 (not (setq dispatch (funcall (pop predicates))))))
 317     ;; If not, maybe a major mode (or a derivative) will define a dispatch.
 318     (when (not dispatch)
 319       (setq dispatch (gethash major-mode context-coloring-mode-hash-table)))
 320     dispatch))
 321
 322 (defun context-coloring-define-dispatch (symbol &rest properties)
 323   "Define a new dispatch named SYMBOL with PROPERTIES.
 324
 325 A \"dispatch\" is a property list describing a strategy for
 326 coloring a buffer.
 327
 328 PROPERTIES must include one of `:modes' or `:predicate', and a
 329 `:colorizer'.
 330
 331 `:modes' - List of major modes this dispatch is valid for.
 332
 333 `:predicate' - Function that determines if the dispatch is valid
 334 for any given state.
 335
 336 `:colorizer' - Function that parses and colors the buffer.
 337
 338 `:delay' - Delay between buffer update and colorization, to
 339 override `context-coloring-default-delay'.
 340
 341 `:setup' - Arbitrary code to set up this dispatch when
 342 `context-coloring-mode' is enabled.
 343
 344 `:teardown' - Arbitrary code to tear down this dispatch when
 345 `context-coloring-mode' is disabled."
 346   (let ((modes (plist-get properties :modes))
 347         (predicate (plist-get properties :predicate))
 348         (colorizer (plist-get properties :colorizer)))
 349     (when (null (or modes predicate))
 350       (error "No mode or predicate defined for dispatch"))
 351     (when (not colorizer)
 352       (error "No colorizer defined for dispatch"))
 353     (puthash symbol properties context-coloring-dispatch-hash-table)
 354     (dolist (mode modes)
 355       (puthash mode properties context-coloring-mode-hash-table))
 356     (when predicate
 357       (push (lambda ()
 358               (when (funcall predicate)
 359                 properties)) context-coloring-dispatch-predicates))))
 360
 361 (defun context-coloring-before-colorize ()
 362   "Set up environment for colorization."
 363   (context-coloring-update-maximum-face))
 364
 365 (defun context-coloring-dispatch ()
 366   "Determine how to color the current buffer, and color it."
 367   (let* ((dispatch (context-coloring-get-current-dispatch))
 368          (colorizer (plist-get dispatch :colorizer)))
 369     (context-coloring-before-colorize)
 370     (catch 'interrupted
 371       (funcall colorizer))))
 372
 373
 374 ;;; Colorization
 375
 376 (defun context-coloring-colorize ()
 377   "Color the current buffer by function context."
 378   (interactive)
 379   (context-coloring-dispatch))
 380
 381 (defun context-coloring-colorize-with-buffer (buffer)
 382   "Color BUFFER."
 383   ;; Don't select deleted buffers.
 384   (when (get-buffer buffer)
 385     (with-current-buffer buffer
 386       (context-coloring-colorize))))
 387
 388
 389 ;;; Minor mode
 390
 391 (defvar context-coloring-ignore-unavailable-predicates
 392   (list
 393    #'minibufferp)
 394   "Cases when \"unavailable\" messages are silenced.
 395 Necessary in editing states where coloring is only sometimes
 396 permissible.")
 397
 398 (defun context-coloring-ignore-unavailable-message-p ()
 399   "Determine if the unavailable message should be silenced."
 400   (let ((predicates context-coloring-ignore-unavailable-predicates)
 401         (ignore-p nil))
 402     (while (and predicates
 403                 (not ignore-p))
 404       (setq ignore-p (funcall (pop predicates))))
 405     ignore-p))
 406
 407 (defvar context-coloring-parse-interruptable-p t
 408   "Set this to nil to force parse to continue until finished.")
 409
 410 ;;;###autoload
 411 (define-minor-mode context-coloring-mode
 412   "Toggle contextual code coloring.
 413 With a prefix argument ARG, enable Context Coloring mode if ARG
 414 is positive, and disable it otherwise.  If called from Lisp,
 415 enable the mode if ARG is omitted or nil.
 416
 417 Context Coloring mode is a buffer-local minor mode.  When
 418 enabled, code is colored by scope.  Scopes are colored
 419 hierarchically.  Variables referenced from nested scopes retain
 420 the color of their defining scopes.  Certain syntax, like
 421 comments and strings, is still colored with `font-lock'.
 422
 423 The entire buffer is colored initially.  Changes to the buffer
 424 trigger recoloring.
 425
 426 Define your own colors by customizing faces like
 427 `context-coloring-level-N-face', where N is a number starting
 428 from 0.  If no face is found on a custom theme nor the `user'
 429 theme, the defaults are used.
 430
 431 New language / major mode support can be added with
 432 `context-coloring-define-dispatch', which see.
 433
 434 Feature inspired by Douglas Crockford."
 435   nil " Context" nil
 436   (cond
 437    (context-coloring-mode
 438     ;; Font lock is incompatible with this mode; the converse is also true.
 439     (font-lock-mode 0)
 440     (jit-lock-mode nil)
 441     ;; ...but we do use font-lock functions here.
 442     (font-lock-set-defaults)
 443     ;; Safely change the value of this function as necessary.
 444     (make-local-variable 'font-lock-syntactic-face-function)
 445     (let ((dispatch (context-coloring-get-current-dispatch)))
 446       (cond
 447        (dispatch
 448         (let ((setup (plist-get dispatch :setup)))
 449           (when setup
 450             (funcall setup))
 451           ;; Colorize once initially.
 452           (let ((context-coloring-parse-interruptable-p nil))
 453             (context-coloring-colorize))))
 454        ((not (context-coloring-ignore-unavailable-message-p))
 455         (message "Context coloring is unavailable here")))))
 456    (t
 457     (let ((dispatch (context-coloring-get-current-dispatch)))
 458       (when dispatch
 459         (let ((teardown (plist-get dispatch :teardown)))
 460           (when teardown
 461             (funcall teardown)))))
 462     (font-lock-mode)
 463     (jit-lock-mode t))))
 464
 465 (provide 'context-coloring)
 466
 467 ;;; context-coloring.el ends here