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 ;;;###autoload
 302 (defvar context-coloring-dispatch-hash-table (make-hash-table :test #'eq)
 303   "Map dispatch strategy names to their property lists.
 304
 305 A \"dispatch\" is a property list describing a strategy for
 306 coloring a buffer.
 307
 308 Its properties must include one of `:modes' or `:predicate', and
 309 a `:colorizer'.
 310
 311 `:modes' - List of major modes this dispatch is valid for.
 312
 313 `:predicate' - Function that determines if the dispatch is valid
 314 for any given state.
 315
 316 `:colorizer' - Function that parses and colors the buffer.
 317
 318 `:delay' - Delay between buffer update and colorization, to
 319 override `context-coloring-default-delay'.
 320
 321 `:setup' - Arbitrary code to set up this dispatch when
 322 `context-coloring-mode' is enabled.
 323
 324 `:teardown' - Arbitrary code to tear down this dispatch when
 325 `context-coloring-mode' is disabled.")
 326
 327 (defun context-coloring-find-dispatch (predicate)
 328   "Find the first dispatch satisfying PREDICATE."
 329   (let (found)
 330     (maphash
 331      (lambda (_ dispatch)
 332        (when (and (not found)
 333                   (funcall predicate dispatch))
 334          (setq found dispatch)))
 335      context-coloring-dispatch-hash-table)
 336     found))
 337
 338 (defun context-coloring-get-current-dispatch ()
 339   "Return the first dispatch appropriate for the current state."
 340   (cond
 341    ;; Maybe a predicate will be satisfied.
 342    ((context-coloring-find-dispatch
 343      (lambda (dispatch)
 344        (let ((predicate (plist-get dispatch :predicate)))
 345          (and predicate (funcall predicate))))))
 346    ;; If not, maybe a major mode (or a derivative) will.
 347    ((context-coloring-find-dispatch
 348      (lambda (dispatch)
 349        (let ((modes (plist-get dispatch :modes))
 350              match)
 351          (while (and modes (not match))
 352            (setq match (eq (pop modes) major-mode)))
 353          match))))))
 354
 355 (defun context-coloring-before-colorize ()
 356   "Set up environment for colorization."
 357   (context-coloring-update-maximum-face))
 358
 359 (defun context-coloring-dispatch ()
 360   "Determine how to color the current buffer, and color it."
 361   (let* ((dispatch (context-coloring-get-current-dispatch))
 362          (colorizer (plist-get dispatch :colorizer)))
 363     (context-coloring-before-colorize)
 364     (when colorizer
 365       (catch 'interrupted
 366         (funcall colorizer)))))
 367
 368
 369 ;;; Colorization
 370
 371 (defun context-coloring-colorize ()
 372   "Color the current buffer by function context."
 373   (interactive)
 374   (context-coloring-dispatch))
 375
 376 (defun context-coloring-colorize-with-buffer (buffer)
 377   "Color BUFFER."
 378   ;; Don't select deleted buffers.
 379   (when (get-buffer buffer)
 380     (with-current-buffer buffer
 381       (context-coloring-colorize))))
 382
 383
 384 ;;; Minor mode
 385
 386 (defvar context-coloring-ignore-unavailable-predicates
 387   (list
 388    #'minibufferp)
 389   "Cases when \"unavailable\" messages are silenced.
 390 Necessary in editing states where coloring is only sometimes
 391 permissible.")
 392
 393 (defun context-coloring-ignore-unavailable-message-p ()
 394   "Determine if the unavailable message should be silenced."
 395   (let ((predicates context-coloring-ignore-unavailable-predicates)
 396         (ignore-p nil))
 397     (while (and predicates
 398                 (not ignore-p))
 399       (setq ignore-p (funcall (pop predicates))))
 400     ignore-p))
 401
 402 (defvar context-coloring-parse-interruptable-p t
 403   "Set this to nil to force parse to continue until finished.")
 404
 405 ;;;###autoload
 406 (define-minor-mode context-coloring-mode
 407   "Toggle contextual code coloring.
 408 With a prefix argument ARG, enable Context Coloring mode if ARG
 409 is positive, and disable it otherwise.  If called from Lisp,
 410 enable the mode if ARG is omitted or nil.
 411
 412 Context Coloring mode is a buffer-local minor mode.  When
 413 enabled, code is colored by scope.  Scopes are colored
 414 hierarchically.  Variables referenced from nested scopes retain
 415 the color of their defining scopes.  Certain syntax, like
 416 comments and strings, is still colored with `font-lock'.
 417
 418 The entire buffer is colored initially.  Changes to the buffer
 419 trigger recoloring.
 420
 421 Define your own colors by customizing faces like
 422 `context-coloring-level-N-face', where N is a number starting
 423 from 0.  If no face is found on a custom theme nor the `user'
 424 theme, the defaults are used.
 425
 426 New language / major mode support can be added with
 427 `context-coloring-define-dispatch', which see.
 428
 429 Feature inspired by Douglas Crockford."
 430   nil " Context" nil
 431   (cond
 432    (context-coloring-mode
 433     ;; Font lock is incompatible with this mode; the converse is also true.
 434     (font-lock-mode 0)
 435     (jit-lock-mode nil)
 436     ;; ...but we do use font-lock functions here.
 437     (font-lock-set-defaults)
 438     ;; Safely change the value of this function as necessary.
 439     (make-local-variable 'font-lock-syntactic-face-function)
 440     (let ((dispatch (context-coloring-get-current-dispatch)))
 441       (cond
 442        (dispatch
 443         (let ((setup (plist-get dispatch :setup)))
 444           (when setup
 445             (funcall setup))
 446           ;; Colorize once initially.
 447           (let ((context-coloring-parse-interruptable-p nil))
 448             (context-coloring-colorize))))
 449        ((not (context-coloring-ignore-unavailable-message-p))
 450         (message "Context coloring is unavailable here")))))
 451    (t
 452     (let ((dispatch (context-coloring-get-current-dispatch)))
 453       (when dispatch
 454         (let ((teardown (plist-get dispatch :teardown)))
 455           (when teardown
 456             (funcall teardown)))))
 457     (font-lock-mode)
 458     (jit-lock-mode t))))
 459
 460 (provide 'context-coloring)
 461
 462 ;;; context-coloring.el ends here