diff options
Diffstat (limited to 'emacs/site-lisp/elastic-tools.el')
| -rw-r--r-- | emacs/site-lisp/elastic-tools.el | 223 |
1 files changed, 223 insertions, 0 deletions
diff --git a/emacs/site-lisp/elastic-tools.el b/emacs/site-lisp/elastic-tools.el new file mode 100644 index 0000000..c010766 --- /dev/null +++ b/emacs/site-lisp/elastic-tools.el @@ -0,0 +1,223 @@ +;; elastic-tools --- tools for variable-pitch fonts. -*- lexical-binding: t; -*- +;; Copyright (C) 2023 Jean-Philippe Bernardy + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; This file provides tools for elastic-indent and elastic-table + +(require 'dash) +(require 'cl-lib) + +;;; Code: + +(defgroup elastic nil "Customization of elastic spacing (helps alignment in presence of proportional fonts)." + :group 'programming :group 'convenience) + +(defvar-local elastic-tools-handlers nil + "Alist mapping handler function symbols to a depth.") + +(defvar-local elastic-tools-deleted-newline nil + "Have we just deleted a newline character?") + +(defun elastic-tools-add-handler (handler depth) + "Register HANDLER at given DEPTH. +Lower DEPTH means executed first." + (setf (alist-get handler elastic-tools-handlers) depth) + (setq elastic-tools-handlers (-sort (-on #'< #'cdr) elastic-tools-handlers)) + (add-hook 'text-scale-mode-hook #'elastic-tools-queue-buffer t) + (add-hook 'post-command-hook #'elastic-tools-handle-queue nil t) + (add-hook 'before-change-functions #'elastic-tools-before-change-function nil t) + (add-hook 'after-change-functions #'elastic-tools-after-change-function nil t) + ;; Queue handling the buffer so it's taken care of by the new + ;; handler. Note that when activating the modes (e.g. upon buffer + ;; creation, with this method, the buffer will be handled just + ;; once, and zero times if the buffer is not active at the end of + ;; the command. For instance, org-babel native fontification will + ;; create a temporary buffer that is never active, and therefore + ;; will not be handled. This is a good thing, because org-babel + ;; creates such a buffer at each keystroke, and handling it all + ;; every time is very slow. + (elastic-tools-queue-buffer)) + +(defun elastic-tools-remove-handler (handler) + "Unregister HANDLER." + (setq elastic-tools-handlers (assq-delete-all handler elastic-tools-handlers)) + (unless elastic-tools-handlers + (remove-hook 'text-scale-mode-hook #'elastic-tools-queue-buffer) + (remove-hook 'post-command-hook #'elastic-tools-handle-queue) + (remove-hook 'before-change-functions #'elastic-tools-before-change-function t) + (remove-hook 'after-change-functions #'elastic-tools-after-change-function t))) + +(defmacro elastic-tools-with-suitable-window (&rest body) + "Execute BODY in a context where current buffer as a window." + (declare (indent 0)) + (let ((temp-frame-symb (make-symbol "temp-frame")) + (window-symb (make-symbol "window"))) + `(let* ((,window-symb (get-buffer-window nil t)) + (,temp-frame-symb + (if ,window-symb + nil + ;; the new frame will display the current buffer by default + (make-frame '((visibility . nil)))))) + (unwind-protect + ;; using ‘with-selected-window’ is probably inefficient for + ;; our purposes, could rewrite to say explicitly exactly + ;; what really needs restoration + (with-selected-window + (or ,window-symb + (frame-selected-window ,temp-frame-symb)) + (progn ,@body)) + (when ,temp-frame-symb + (delete-frame ,temp-frame-symb)))))) + +(defun elastic-tools-before-change-function (start end) + "Queue a call to `elastic-tools-do-region' for START and END." + (setq elastic-tools-deleted-newline + (save-excursion + (goto-char start) + (and (search-forward "\n" end t) + t))) ; forget the actual position (for tidyness) + ;; (message "etbcf: %s %s-%s" elastic-tools-deleted-newline start end) + ) + +(defvar-local elastic-tools-queue nil + "Queue of changes to handle. +We need queueing because some commands (for instance +`fill-paragraph') will cause many changes, which may individually +propagate down the buffer. Doing all this work many times can +cause visible slowdowns.") + +(defun elastic-tools-push (task hook) + "Push TASK in the queue for HOOK." + (push task (alist-get hook elastic-tools-queue))) + +(defun elastic-tools-after-change-function (start end _len) + "Queue a change between START and END to be handled by `elastic-tools-handlers'." + ;; (message "etacf: %s %s-%s" elastic-tools-deleted-newline start end) + (elastic-tools-push (list elastic-tools-deleted-newline (copy-marker start) (copy-marker end t)) + (car (car elastic-tools-handlers)))) + +(defmacro elastic-tools-with-context (&rest body) + "Run BODY in a context which is suitable for applying our adjustments." + (declare (indent 0)) + `(save-match-data ; just in case + (elastic-tools-with-suitable-window ; we need a window to compute the character widths. + (save-excursion + (without-restriction ; because changes may propagate beyond the restriction. + (with-silent-modifications + ,@body)))))) + + +(defun elastic-tools-do-buffer () + "Call each `elastic-tools-handlers' on the whole buffer." + (interactive) + (elastic-tools-with-context + (dolist (hook (-map #'car elastic-tools-handlers)) + (funcall hook t (point-min) (point-max))))) + + +(defun elastic-tools-queue-buffer () + "Queue handling the whole buffer." + (elastic-tools-after-change-function (point-min) (point-max) nil)) + +(defun elastic-tools-handle-queue () + "Take care of intervals in queue. +If input comes before the work can be finished, then stop and +continue the work later, when idle." + (let ((hooks (-map #'car elastic-tools-handlers))) + (while hooks + (let ((hook (pop hooks))) + ;; (message "elastic-tools: dealing with %s q=%s" hook (alist-get hook elastic-tools-queue)) + (setf (alist-get hook elastic-tools-queue) + (--sort (or (< (cadr it) (cadr other)) (car it)) (alist-get hook elastic-tools-queue))) + (elastic-tools-with-context + (goto-char (point-min)) + (while-no-input ; see post-command-hook documentation. + (while (alist-get hook elastic-tools-queue) + (pcase (car (alist-get hook elastic-tools-queue)) + (`(,force-propagate ,start ,end) + (when (> end (point)) ; otherwise the change has already been taken care of. + (let ((actual-start (max (point) start))) ; portion before point was already done. + (funcall hook force-propagate actual-start end) + ;; (message "elastic-tools: running %s %s %s %s" hook force-propagate actual-start end) + (when hooks + ;; next layer needs to deal with the change. + (elastic-tools-push (list t actual-start (copy-marker (max end (point)))) + (car hooks))))))) + ;; pop only when we're done so we don't forget something + (pop (alist-get hook elastic-tools-queue)))) + (when (alist-get hook elastic-tools-queue) + ;; input came: we continue later. + (setq hooks nil) ; stop the outer loop + (run-with-idle-timer 0.2 nil #'elastic-tools-handle-queue))))))) + +(defun elastic-tools-clear-region-properties (start end cue-prop props-to-remove) + "Clear PROPS-TO-REMOVE text properties in given region. +The region is the part between START and END which also has the +text property CUE-PROP be t." + (with-silent-modifications + (cl-do ((pos1 start) pos2) (nil) + (setq pos1 (text-property-any pos1 end cue-prop t)) + (unless pos1 (cl-return)) + (setq pos2 (or (next-single-property-change pos1 cue-prop nil end) + end)) + (remove-list-of-text-properties pos1 pos2 props-to-remove) + (setq pos1 pos2)))) + + +(defun elastic-tools-on-col-2 (pos) + "Is POS on 2nd column?" + (save-excursion + (goto-char pos) + (and (not (bolp)) + (progn (forward-char -1) + (bolp))))) + +(defun elastic-tools-text-pixel-width (start end) + "Return the pixel width of text between START and END in current buffer." + (let ((c (car (window-text-pixel-size nil start end)))) + (if (> c 2) c ;; Emacs bug: sometimes the returned window-text-pixel-size is negative. In this case computing it indirectly like below seems to fix the issue. + (- (car (window-text-pixel-size nil (1- start) end)) + (car (window-text-pixel-size nil (1- start) start)))))) + +(defun elastic-tools-char-pixel-width (pos) + "Return the pixel width of char at POS." + (if-let (p (get-text-property pos 'elastindent-width)) + p + ;; Emacs bug: sometimes the returned window-text-pixel-size is + ;; wrong. In this case computing it indirectly like below + ;; seems to fix the issue. + (let ((c (car (window-text-pixel-size nil pos (1+ pos))))) + (if (or (<= c 1) ; suspicious + (elastic-tools-on-col-2 pos)) ; emacs is often wrong on that column, for some reason. + (- (car (window-text-pixel-size nil (1- pos) (1+ pos))) + (car (window-text-pixel-size nil (1- pos) pos))) + c)))) + + +(defun elastic-tools-show-char-pixel-width (pos) + "Display pixel width of region char at POS. +This is a debug utility for `elastindent-mode'" + (interactive "d") + (message "pixel width of region: %s, raw=%s, disp=%s, prop=%s" + (elastic-tools-char-pixel-width pos) + (car (window-text-pixel-size nil pos (1+ pos))) + (get-char-property pos 'elastindent-width) + (get-char-property pos 'display))) + + +(provide 'elastic-tools) +;;; elastic-tools.el ends here |