1
1
Fork 0
ideasman42...emacs-hl_block.../hl-block-mode.el

430 lines
14 KiB
EmacsLisp

;;; hl-block-mode.el --- Highlighting nested blocks -*- lexical-binding: t -*-
;; SPDX-License-Identifier: GPL-2.0-or-later
;; Copyright (C) 2019-2021 Campbell Barton
;; Author: Campbell Barton <ideasman42@gmail.com>
;; URL: https://codeberg.org/ideasman42/emacs-hl-block-mode
;; Version: 0.1
;; Package-Requires: ((emacs "26.1"))
;;; Commentary:
;; Highlight blocks surrounding the cursor.
;;; Usage
;; (hl-block-mode) ; activate in the current buffer.
;; (global-hl-block-mode) ; activate globally for all buffers.
;;; Code:
(eval-when-compile
;; For `pcase-dolist'.
(require 'pcase))
;; ---------------------------------------------------------------------------
;; Custom Variables
(defgroup hl-block nil "Highlight nested blocks or brackets." :group 'convenience)
(defcustom hl-block-bracket "{"
"Characters to use as a starting bracket (set to nil to use all brackets)."
:type '(or null string))
(defcustom hl-block-delay 0.2 "Idle time to wait before highlighting (in seconds)." :type 'float)
(defcustom hl-block-multi-line nil
"Skip highlighting nested blocks on the same line.
Useful for languages that use S-expressions to avoid overly nested highlighting."
:type 'boolean)
(defcustom hl-block-single-level nil
"Only highlight a single level, otherwise highlight all levels."
:type 'boolean)
(defcustom hl-block-style 'color-tint
"Only highlight a single level."
:type
'
(choice
(symbol :tag "Tint the background at each level `hl-block-color-tint'." color-tint)
(symbol :tag "Highlight surrounding brackets using `hl-block-bracket-face'." bracket)))
;; For `color-tint' draw style.
(defcustom hl-block-color-tint "#040404"
"Color to add/subtract from the background each scope step."
:type 'color)
;; For `bracket' draw style.
(defcustom hl-block-bracket-face '(:inverse-video t)
"Face used when `hl-block-style' is set to `bracket'."
:type 'face)
(defcustom hl-block-mode-lighter "" "Lighter for option `hl-block-mode'." :type 'string)
;; ---------------------------------------------------------------------------
;; Internal Variables
(defvar-local hl-block--overlay nil)
;; ---------------------------------------------------------------------------
;; Internal Bracket Functions
(defun hl-block--syntax-prev-bracket (pt)
"A version of `syntax-ppss' to match curly braces.
PT is typically the `(point)'."
(let ((beg (ignore-errors (elt (syntax-ppss pt) 1))))
(when beg
(cond
((memq (char-after beg) hl-block-bracket)
beg)
(t
(hl-block--syntax-prev-bracket (1- beg)))))))
(defun hl-block--find-range (pt)
"Return range around PT or nil."
(let
(
(beg
(cond
(hl-block-bracket
(hl-block--syntax-prev-bracket pt))
(t
(ignore-errors (elt (syntax-ppss pt) 1))))))
(when beg
;; Note that `end' may be nil for un-matched brackets.
;; The caller must handle this case.
(let ((end (ignore-errors (scan-sexps beg 1))))
(cons beg end)))))
(defun hl-block--find-all-ranges (pt)
"Return ranges starting from PT, outer-most to inner-most."
(let ((range (hl-block--find-range pt)))
(when range
;; When the previous range is nil, this simply terminates the list.
(cons range (hl-block--find-all-ranges (car range))))))
(defun hl-block--find-single-range (pt)
"Return ranges starting from PT, only a single level."
(let ((range (hl-block--find-range pt)))
(when range
(list range))))
(defun hl-block--syntax-skip-to-multi-line ()
"Move point to the first multi-line block.
The point will only ever be moved backward."
(let
(
(line-min (line-beginning-position))
(line-max (line-end-position))
(beg (point))
(end (point)))
(while (and beg (>= beg line-min) end (<= end line-max))
(setq beg (ignore-errors (elt (syntax-ppss beg) 1)))
(when beg
(setq end (ignore-errors (scan-sexps beg 1)))))))
;; ---------------------------------------------------------------------------
;; Internal Color Tint (Draw Style)
(defun hl-block--color-values-as-string (color)
"Build a color from COLOR.
Inverse of `color-values'."
(format "#%02x%02x%02x" (ash (aref color 0) -8) (ash (aref color 1) -8) (ash (aref color 2) -8)))
(defun hl-block--color-tint-add (a b tint)
"Tint color lighter from A to B by TINT amount."
(vector
(+ (aref a 0) (* tint (aref b 0)))
(+ (aref a 1) (* tint (aref b 1)))
(+ (aref a 2) (* tint (aref b 2)))))
(defun hl-block--color-tint-sub (a b tint)
"Tint colors darker from A to B by TINT amount."
(vector
(- (aref a 0) (* tint (aref b 0)))
(- (aref a 1) (* tint (aref b 1)))
(- (aref a 2) (* tint (aref b 2)))))
(defun hl-block--overlay-create-color-tint (block-list end-fallback)
"Update the overlays based on the cursor location.
Argument BLOCK-LIST represents start-end ranges of braces.
Argument END-FALLBACK is the point used when no matching end bracket is found,
typically `(point)'."
(let*
(
(block-list-len (length block-list))
(bg-color (apply #'vector (color-values (face-attribute 'default :background))))
(bg-color-tint (apply #'vector (color-values hl-block-color-tint)))
;; Check dark background is light/dark.
(do-highlight (> 98304 (+ (aref bg-color 0) (aref bg-color 1) (aref bg-color 2))))
;; Iterator.
(i 0))
(pcase-let ((`(,beg-prev . ,end-prev) (pop block-list)))
(unless end-prev ;; May be `nil' for un-matched brackets.
(setq end-prev end-fallback))
(while block-list
(pcase-let ((`(,beg . ,end) (pop block-list)))
(unless end ;; May be `nil' for un-matched brackets.
(setq end end-fallback))
(let
(
(elem-overlay-beg (make-overlay beg beg-prev))
(elem-overlay-end (make-overlay end-prev end)))
(let
( ;; Calculate the face with the tint color at this highlight level.
(hl-face
(list
:background
(hl-block--color-values-as-string
(let ((i-tint (- block-list-len i)))
(cond
(do-highlight
(hl-block--color-tint-add bg-color bg-color-tint i-tint))
(t
(hl-block--color-tint-sub bg-color bg-color-tint i-tint)))))
:extend t)))
(overlay-put elem-overlay-beg 'face hl-face)
(overlay-put elem-overlay-end 'face hl-face))
(push elem-overlay-beg hl-block--overlay)
(push elem-overlay-end hl-block--overlay)
(setq beg-prev beg)
(setq end-prev end))
(setq i (1+ i)))))))
;; ---------------------------------------------------------------------------
;; Internal Color Tint (Draw Style)
(defun hl-block--overlay-create-bracket (block-list)
"Update the overlays based on the cursor location.
Argument BLOCK-LIST represents start-end ranges of braces."
;; hl-block-bracket-face
(pcase-dolist (`(,beg . ,end) block-list)
(let ((elem-overlay-beg (make-overlay beg (1+ beg))))
(overlay-put elem-overlay-beg 'face hl-block-bracket-face)
(push elem-overlay-beg hl-block--overlay)
(when end ;; May be `nil' for un-matched brackets.
(let ((elem-overlay-end (make-overlay (1- end) end)))
(overlay-put elem-overlay-end 'face hl-block-bracket-face)
(push elem-overlay-end hl-block--overlay))))))
;; ---------------------------------------------------------------------------
;; Internal Refresh Function
(defun hl-block--overlay-clear ()
"Clear all overlays."
(mapc 'delete-overlay hl-block--overlay)
(setq hl-block--overlay nil))
(defun hl-block--overlay-refresh ()
"Update the overlays based on the cursor location."
(hl-block--overlay-clear)
(let
(
(block-list
(save-excursion
(when hl-block-multi-line
(hl-block--syntax-skip-to-multi-line))
(cond
(hl-block-single-level
(hl-block--find-single-range (point)))
(t
(hl-block--find-all-ranges (point)))))))
(when block-list
(cond
((eq hl-block-style 'color-tint)
;; Ensure outer bounds (when only one pair exists).
(setq block-list
(cond
((cdr block-list)
(reverse block-list))
(t
(cons (cons (point-min) (point-max)) block-list))))
(hl-block--overlay-create-color-tint block-list (point)))
((eq hl-block-style 'bracket)
(hl-block--overlay-create-bracket block-list))
(t
(error "Unknown style %S" hl-block-style))))))
;; ---------------------------------------------------------------------------
;; Internal Timer Management
;;
;; This works as follows:
;;
;; - The timer is kept active as long as the local mode is enabled.
;; - Entering a buffer runs the buffer local `window-state-change-hook'
;; immediately which checks if the mode is enabled,
;; set up the global timer if it is.
;; - Switching any other buffer wont run this hook,
;; rely on the idle timer it's self running, which detects the active mode,
;; canceling it's self if the mode isn't active.
;;
;; This is a reliable way of using a global,
;; repeating idle timer that is effectively buffer local.
;;
;; Global idle timer (repeating), keep active while the buffer-local mode is enabled.
(defvar hl-block--global-timer nil)
;; When t, the timer will update buffers in all other visible windows.
(defvar hl-block--dirty-flush-all nil)
;; When true, the buffer should be updated when inactive.
(defvar-local hl-block--dirty nil)
(defun hl-block--time-callback-or-disable ()
"Callback that run the repeat timer."
;; Ensure all other buffers are highlighted on request.
(let ((is-mode-active (bound-and-true-p hl-block-mode)))
;; When this buffer is not in the mode, flush all other buffers.
(cond
(is-mode-active
;; Don't update in the window loop to ensure we always
;; update the current buffer in the current context.
(setq hl-block--dirty nil))
(t
;; If the timer ran when in another buffer,
;; a previous buffer may need a final refresh, ensure this happens.
(setq hl-block--dirty-flush-all t)))
(when hl-block--dirty-flush-all
;; Run the mode callback for all other buffers in the queue.
(dolist (frame (frame-list))
(dolist (win (window-list frame -1))
(let ((buf (window-buffer win)))
(when
(and
(buffer-local-value 'hl-block-mode buf)
(buffer-local-value 'hl-block--dirty buf))
(with-selected-frame frame
(with-selected-window win
(with-current-buffer buf
(setq hl-block--dirty nil)
(hl-block--overlay-refresh)))))))))
;; Always keep the current buffer dirty
;; so navigating away from this buffer will refresh it.
(when is-mode-active
(setq hl-block--dirty t))
(cond
(is-mode-active
(hl-block--overlay-refresh))
(t ;; Cancel the timer until the current buffer uses this mode again.
(hl-block--time-ensure nil)))))
(defun hl-block--time-ensure (state)
"Ensure the timer is enabled when STATE is non-nil, otherwise disable."
(cond
(state
(unless hl-block--global-timer
(setq hl-block--global-timer
(run-with-idle-timer hl-block-delay :repeat 'hl-block--time-callback-or-disable))))
(t
(when hl-block--global-timer
(cancel-timer hl-block--global-timer)
(setq hl-block--global-timer nil)))))
(defun hl-block--time-reset ()
"Run this when the buffer was changed."
;; Ensure changing windows doesn't leave other buffers with stale highlight.
(cond
((bound-and-true-p hl-block-mode)
(setq hl-block--dirty-flush-all t)
(setq hl-block--dirty t)
(hl-block--time-ensure t))
(t
(hl-block--time-ensure nil))))
(defun hl-block--time-buffer-local-enable ()
"Ensure buffer local state is enabled."
;; Needed in case focus changes before the idle timer runs.
(setq hl-block--dirty-flush-all t)
(setq hl-block--dirty t)
(hl-block--time-ensure t)
(add-hook 'window-state-change-hook #'hl-block--time-reset nil t))
(defun hl-block--time-buffer-local-disable ()
"Ensure buffer local state is disabled."
(kill-local-variable 'hl-block--dirty)
(hl-block--time-ensure nil)
(remove-hook 'window-state-change-hook #'hl-block--time-reset t))
;; ---------------------------------------------------------------------------
;; Internal Mode Management
(defun hl-block--mode-enable ()
"Turn on `hl-block-mode' for the current buffer."
(hl-block--time-buffer-local-enable)
;; Setup brackets:
;; Keep as nil to match all brackets,
;; use a string to convert the string to a list.
(let ((bracket-orig (append hl-block-bracket nil)))
;; Make a local, sanitized version of this variable.
(setq-local hl-block-bracket nil)
(when bracket-orig
;; Filter for recognized values.
(while bracket-orig
(let ((ch (pop bracket-orig)))
(when (eq ?\( (char-syntax ch))
(push ch hl-block-bracket)))))))
(defun hl-block--mode-disable ()
"Turn off `hl-block-mode' for the current buffer."
(hl-block--overlay-clear)
(kill-local-variable 'hl-block--overlay)
(kill-local-variable 'hl-block-bracket)
(hl-block--time-buffer-local-disable))
(defun hl-block--mode-turn-on ()
"Enable command `hl-block-mode'."
(when (and (not (minibufferp)) (not (bound-and-true-p hl-block-mode)))
(hl-block-mode 1)))
;; ---------------------------------------------------------------------------
;; Public API
;;;###autoload
(define-minor-mode hl-block-mode
"Highlight block under the cursor."
:global nil
:lighter hl-block-mode-lighter
(cond
(hl-block-mode
(hl-block--mode-enable))
(t
(hl-block--mode-disable))))
;;;###autoload
(define-globalized-minor-mode
global-hl-block-mode
hl-block-mode hl-block--mode-turn-on)
(provide 'hl-block-mode)
;; Local Variables:
;; indent-tabs-mode: nil
;; End:
;;; hl-block-mode.el ends here