1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
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
|
