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: 8.0.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 (defun context-coloring-cancel-timer (timer)
 189   "Cancel TIMER."
 190   (when timer
 191     (cancel-timer timer)))
 192
 193 (defun context-coloring-schedule-coloring (time)
 194   "Schedule coloring to occur once after Emacs is idle for TIME."
 195   (context-coloring-cancel-timer context-coloring-colorize-idle-timer)
 196   (setq context-coloring-colorize-idle-timer
 197         (run-with-idle-timer
 198          time
 199          nil
 200          #'context-coloring-colorize-with-buffer
 201          (current-buffer))))
 202
 203 (defun context-coloring-setup-idle-change-detection ()
 204   "Setup idle change detection."
 205   (let ((dispatch (context-coloring-get-current-dispatch)))
 206     (add-hook
 207      'after-change-functions #'context-coloring-change-function nil t)
 208     (add-hook
 209      'kill-buffer-hook #'context-coloring-teardown-idle-change-detection nil t)
 210     (setq context-coloring-maybe-colorize-idle-timer
 211           (run-with-idle-timer
 212            (or (plist-get dispatch :delay) context-coloring-default-delay)
 213            t
 214            #'context-coloring-maybe-colorize-with-buffer
 215            (current-buffer)))))
 216
 217 (defun context-coloring-teardown-idle-change-detection ()
 218   "Teardown idle change detection."
 219   (dolist (timer (list context-coloring-colorize-idle-timer
 220                        context-coloring-maybe-colorize-idle-timer))
 221     (context-coloring-cancel-timer timer))
 222   (remove-hook
 223    'kill-buffer-hook #'context-coloring-teardown-idle-change-detection t)
 224   (remove-hook
 225    'after-change-functions #'context-coloring-change-function t))
 226
 227
 228 ;;; Colorization utilities
 229
 230 (defsubst context-coloring-colorize-region (start end level)
 231   "Color from START (inclusive) to END (exclusive) with LEVEL."
 232   (add-text-properties
 233    start
 234    end
 235    `(face ,(context-coloring-bounded-level-face level))))
 236
 237 (defcustom context-coloring-syntactic-comments t
 238   "If non-nil, also color comments using `font-lock'."
 239   :type 'boolean
 240   :group 'context-coloring)
 241
 242 (defcustom context-coloring-syntactic-strings t
 243   "If non-nil, also color strings using `font-lock'."
 244   :type 'boolean
 245   :group 'context-coloring)
 246
 247 (defun context-coloring-font-lock-syntactic-comment-function (state)
 248   "Color a comment according to STATE."
 249   (if (nth 3 state) nil font-lock-comment-face))
 250
 251 (defun context-coloring-font-lock-syntactic-string-function (state)
 252   "Color a string according to STATE."
 253   (if (nth 3 state) font-lock-string-face nil))
 254
 255 (defsubst context-coloring-colorize-comments-and-strings (&optional min max keywords-p)
 256   "Maybe color comments and strings in buffer from MIN to MAX.
 257 MIN defaults to beginning of buffer.  MAX defaults to end.  If
 258 KEYWORDS-P is non-nil, also color keywords from MIN to MAX."
 259   (when (or context-coloring-syntactic-comments
 260             context-coloring-syntactic-strings)
 261     (let ((min (or min (point-min)))
 262           (max (or max (point-max)))
 263           (font-lock-syntactic-face-function
 264            (cond
 265             ((and context-coloring-syntactic-comments
 266                   (not context-coloring-syntactic-strings))
 267              #'context-coloring-font-lock-syntactic-comment-function)
 268             ((and context-coloring-syntactic-strings
 269                   (not context-coloring-syntactic-comments))
 270              #'context-coloring-font-lock-syntactic-string-function)
 271             (t
 272              font-lock-syntactic-face-function))))
 273       (save-excursion
 274         (font-lock-fontify-syntactically-region min max)
 275         (when keywords-p
 276           (font-lock-fontify-keywords-region min max))))))
 277
 278 (defcustom context-coloring-initial-level 0
 279   "Scope level at which to start coloring.
 280
 281 If top-level variables and functions do not become global, but
 282 are scoped to a file (as in Node.js), set this to `1'."
 283   :type 'integer
 284   :safe #'integerp
 285   :group 'context-coloring)
 286
 287
 288 ;;; Dispatch
 289
 290 ;;;###autoload
 291 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
 292   "Map dispatch strategy names to their property lists.
 293
 294 A \"dispatch\" is a property list describing a strategy for
 295 coloring a buffer.
 296
 297 Its properties must include one of `:modes' or `:predicate', and
 298 a `:colorizer'.
 299
 300 `:modes' - List of major modes this dispatch is valid for.
 301
 302 `:predicate' - Function that determines if the dispatch is valid
 303 for any given state.
 304
 305 `:colorizer' - Function that parses and colors the buffer.
 306
 307 `:delay' - Delay between buffer update and colorization, to
 308 override `context-coloring-default-delay'.
 309
 310 `:setup' - Arbitrary code to set up this dispatch when
 311 `context-coloring-mode' is enabled.
 312
 313 `:teardown' - Arbitrary code to tear down this dispatch when
 314 `context-coloring-mode' is disabled.")
 315
 316 (defun context-coloring-find-dispatch (predicate)
 317   "Find the first dispatch satisfying PREDICATE."
 318   (let (found)
 319     (maphash
 320      (lambda (_ dispatch)
 321        (when (and (not found)
 322                   (funcall predicate dispatch))
 323          (setq found dispatch)))
 324      context-coloring-dispatch-hash-table)
 325     found))
 326
 327 (defun context-coloring-get-current-dispatch ()
 328   "Return the first dispatch appropriate for the current state."
 329   (cond
 330    ;; Maybe a predicate will be satisfied.
 331    ((context-coloring-find-dispatch
 332      (lambda (dispatch)
 333        (let ((predicate (plist-get dispatch :predicate)))
 334          (and predicate (funcall predicate))))))
 335    ;; If not, maybe a major mode (or a derivative) will.
 336    ((context-coloring-find-dispatch
 337      (lambda (dispatch)
 338        (let ((modes (plist-get dispatch :modes))
 339              match)
 340          (while (and modes (not match))
 341            (setq match (eq (pop modes) major-mode)))
 342          match))))))
 343
 344 (defun context-coloring-before-colorize ()
 345   "Set up environment for colorization."
 346   (context-coloring-update-maximum-face))
 347
 348 (defun context-coloring-dispatch ()
 349   "Determine how to color the current buffer, and color it."
 350   (let* ((dispatch (context-coloring-get-current-dispatch))
 351          (colorizer (plist-get dispatch :colorizer)))
 352     (context-coloring-before-colorize)
 353     (when colorizer
 354       (catch 'interrupted
 355         (funcall colorizer)))))
 356
 357
 358 ;;; Colorization
 359
 360 (defun context-coloring-colorize ()
 361   "Color the current buffer by function context."
 362   (interactive)
 363   (context-coloring-dispatch))
 364
 365 (defun context-coloring-colorize-with-buffer (buffer)
 366   "Color BUFFER."
 367   ;; Don't select deleted buffers.
 368   (when (get-buffer buffer)
 369     (with-current-buffer buffer
 370       (context-coloring-colorize))))
 371
 372
 373 ;;; Minor mode
 374
 375 (defvar context-coloring-ignore-unavailable-predicates
 376   (list
 377    #'minibufferp)
 378   "Cases when \"unavailable\" messages are silenced.
 379 Necessary in editing states where coloring is only sometimes
 380 permissible.")
 381
 382 (defun context-coloring-ignore-unavailable-message-p ()
 383   "Determine if the unavailable message should be silenced."
 384   (let ((predicates context-coloring-ignore-unavailable-predicates)
 385         (ignore-p nil))
 386     (while (and predicates
 387                 (not ignore-p))
 388       (setq ignore-p (funcall (pop predicates))))
 389     ignore-p))
 390
 391 (defvar context-coloring-interruptable-p t
 392   "When non-nil, coloring may be interrupted by user input.")
 393
 394 ;;;###autoload
 395 (define-minor-mode context-coloring-mode
 396   "Toggle contextual code coloring.
 397 With a prefix argument ARG, enable Context Coloring mode if ARG
 398 is positive, and disable it otherwise.  If called from Lisp,
 399 enable the mode if ARG is omitted or nil.
 400
 401 Context Coloring mode is a buffer-local minor mode.  When
 402 enabled, code is colored by scope.  Scopes are colored
 403 hierarchically.  Variables referenced from nested scopes retain
 404 the color of their defining scopes.  Certain syntax, like
 405 comments and strings, is still colored with `font-lock'.
 406
 407 The entire buffer is colored initially.  Changes to the buffer
 408 trigger recoloring.
 409
 410 Define your own colors by customizing faces like
 411 `context-coloring-level-N-face', where N is a number starting
 412 from 0.  If no face is found on a custom theme nor the `user'
 413 theme, the defaults are used.
 414
 415 New language / major mode support can be added with
 416 `context-coloring-define-dispatch', which see.
 417
 418 Feature inspired by Douglas Crockford."
 419   nil " Context" nil
 420   (cond
 421    (context-coloring-mode
 422     (let ((dispatch (context-coloring-get-current-dispatch)))
 423       (cond
 424        (dispatch
 425         ;; Font lock is incompatible with this mode; the converse is also true.
 426         (font-lock-mode 0)
 427         ;; ...but we do use font-lock functions here.
 428         (font-lock-set-defaults)
 429         ;; Safely change the value of this function as necessary.
 430         (make-local-variable 'font-lock-syntactic-face-function)
 431         (let ((setup (plist-get dispatch :setup)))
 432           (when setup
 433             (funcall setup))
 434           ;; Colorize once initially.
 435           (let ((context-coloring-interruptable-p nil))
 436             (context-coloring-colorize))))
 437        ((not (context-coloring-ignore-unavailable-message-p))
 438         (message "Context coloring is unavailable here")))))
 439    (t
 440     (let ((dispatch (context-coloring-get-current-dispatch)))
 441       (when dispatch
 442         (let ((teardown (plist-get dispatch :teardown)))
 443           (when teardown
 444             (funcall teardown)))))
 445     (turn-on-font-lock-if-desired))))
 446
 447 (provide 'context-coloring)
 448
 449 ;;; context-coloring.el ends here