forked from emacs-helm/helm
-
Notifications
You must be signed in to change notification settings - Fork 0
/
helm-font.el
333 lines (284 loc) · 11.5 KB
/
helm-font.el
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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
;;; helm-font --- Font and ucs selection for Helm -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2020 Thierry Volpiatto <thierry.volpiatto@gmail.com>
;; 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 <http://www.gnu.org/licenses/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-help)
(declare-function helm-generic-sort-fn "helm-utils")
(defgroup helm-font nil
"Related applications to display fonts in Helm."
:group 'helm)
(defcustom helm-ucs-recent-size 10
"Number of recent chars to keep."
:type 'integer
:group 'helm-font)
(defcustom helm-ucs-actions
'(("Insert character" . helm-ucs-insert-char)
("Insert character name" . helm-ucs-insert-name)
("Insert character code in hex" . helm-ucs-insert-code)
("Kill marked characters" . helm-ucs-kill-char)
("Kill name" . helm-ucs-kill-name)
("Kill code" . helm-ucs-kill-code))
"Actions for `helm-source-ucs'."
:group 'helm-font
:type '(alist :key-type string :value-type function))
(defvar helm-ucs-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "<C-backspace>") 'helm-ucs-persistent-delete)
(define-key map (kbd "<C-left>") 'helm-ucs-persistent-backward)
(define-key map (kbd "<C-right>") 'helm-ucs-persistent-forward)
(define-key map (kbd "C-c SPC") 'helm-ucs-persistent-insert-space)
map)
"Keymap for `helm-ucs'.")
(defface helm-ucs-char
`((((class color) (background dark))
,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "Gold"))
"Face used to display ucs characters."
:group 'helm-font)
;;; Xfont selection
;;
;;
(defvar helm-xfonts-cache nil)
(defvar helm-previous-font nil)
(defvar helm-source-xfonts
(helm-build-sync-source "X Fonts"
:init (lambda ()
(unless helm-xfonts-cache
(setq helm-xfonts-cache
(x-list-fonts "*")))
;; Save current font so it can be restored in cleanup
(setq helm-previous-font (cdr (assq 'font (frame-parameters)))))
:candidates 'helm-xfonts-cache
:action '(("Copy font to kill ring" . (lambda (elm)
(kill-new elm)))
("Set font" . (lambda (elm)
(kill-new elm)
(set-frame-font elm 'keep-size)
(message "Font copied to kill ring"))))
:cleanup (lambda ()
;; Restore previous font
(set-frame-font helm-previous-font 'keep-size))
:persistent-action (lambda (new-font)
(set-frame-font new-font 'keep-size)
(kill-new new-font))
:persistent-help "Preview font and copy to kill-ring"))
;;; 𝕌𝕔𝕤 𝕊𝕪𝕞𝕓𝕠𝕝 𝕔𝕠𝕞𝕡𝕝𝕖𝕥𝕚𝕠𝕟
;;
;;
(defvar helm-ucs--max-len nil)
(defvar helm-ucs--names nil)
(defvar helm-ucs-history nil)
(defvar helm-ucs-recent nil
"Ring of recent `helm-ucs' selections.")
(defun helm-calculate-ucs-alist-max-len (names)
"Calculate the length of the longest NAMES list candidate."
(cl-loop for (_n . v) in names
maximize (length (format "#x%x:" v)) into code
maximize (max 1 (string-width (format "%c" v))) into char
finally return (cons code char)))
(defun helm-calculate-ucs-hash-table-max-len (names)
"Calculate the length of the longest NAMES hash table candidate."
(cl-loop for _n being the hash-keys of names
using (hash-values v)
maximize (length (format "#x%x:" v)) into code
maximize (max 1 (string-width (format "%c" v))) into char
finally return (cons code char)))
(defun helm-calculate-ucs-max-len ()
"Calculate the length of the longest `ucs-names' candidate."
(let ((ucs-struct (ucs-names)))
(if (hash-table-p ucs-struct)
(helm-calculate-ucs-hash-table-max-len ucs-struct)
(helm-calculate-ucs-alist-max-len ucs-struct))))
(defun helm-ucs-collect-symbols-alist (names)
"Collect ucs symbols from the NAMES list."
(cl-loop with pr = (make-progress-reporter
"collecting ucs names"
0 (length names))
for (n . v) in names
for count from 1
for xcode = (format "#x%x:" v)
for len = (length xcode)
for diff = (- (car helm-ucs--max-len) len)
for code = (format "(#x%x): " v)
for char = (propertize (format "%c" v)
'face 'helm-ucs-char)
unless (or (string= "" n)
;; `char-displayable-p' return a font object or
;; t for some char that are displayable but have
;; no special font (e.g 10) so filter out char
;; with no font.
(not (fontp (char-displayable-p (read xcode)))))
collect
(concat code (make-string diff ? )
char " " n)
and do (progress-reporter-update pr count)))
(defun helm-ucs-collect-symbols-hash-table (names)
"Collect ucs symbols from the NAMES hash-table."
(cl-loop with pr = (make-progress-reporter
"collecting ucs names"
0 (hash-table-count names))
for n being the hash-keys of names
using (hash-values v)
for count from 1
for xcode = (format "#x%x:" v)
for len = (length xcode)
for diff = (- (car helm-ucs--max-len) len)
for code = (format "(#x%x): " v)
for char = (propertize (format "%c" v)
'face 'helm-ucs-char)
unless (or (string= "" n)
(not (fontp (char-displayable-p (read xcode)))))
collect
(concat code (make-string diff ? )
char " " n)
and do (progress-reporter-update pr count)))
(defun helm-ucs-collect-symbols (ucs-struct)
"Collect ucs symbols from UCS-STRUCT.
Depending on the Emacs version, the variable `ucs-names' can
either be an alist or a hash-table."
(if (hash-table-p ucs-struct)
(helm-ucs-collect-symbols-hash-table ucs-struct)
(helm-ucs-collect-symbols-alist ucs-struct)))
(defun helm-ucs-init ()
"Initialize a Helm buffer with ucs symbols.
Only math* symbols are collected."
(unless helm-ucs--max-len
(setq helm-ucs--max-len
(helm-calculate-ucs-max-len)))
(or helm-ucs--names
(setq helm-ucs--names
(helm-ucs-collect-symbols (ucs-names)))))
;; Actions (insertion)
(defun helm-ucs-match (candidate n)
"Return the N part of an ucs CANDIDATE.
Where N=1 is the ucs code, N=2 the ucs char and N=3 the ucs
name."
(when (string-match
"^(\\(#x[a-f0-9]+\\)): *\\(.\\) *\\([^:]+\\)+"
candidate)
(match-string n candidate)))
(defun helm-ucs-save-recentest (candidate)
(let ((lst (cons candidate (delete candidate helm-ucs-recent))))
(setq helm-ucs-recent
(if (> (length lst) helm-ucs-recent-size)
(nbutlast lst 1)
lst))))
(defun helm-ucs-insert (candidate n)
"Insert the N part of CANDIDATE."
(with-helm-current-buffer
(helm-ucs-save-recentest candidate)
(insert (helm-ucs-match candidate n))))
(defun helm-ucs-insert-char (candidate)
"Insert ucs char part of CANDIDATE at point."
(helm-ucs-insert candidate 2))
(defun helm-ucs-insert-code (candidate)
"Insert ucs code part of CANDIDATE at point."
(helm-ucs-insert candidate 1))
(defun helm-ucs-insert-name (candidate)
"Insert ucs name part of CANDIDATE at point."
(helm-ucs-insert candidate 3))
;; Kill actions
(defun helm-ucs-kill-char (_candidate)
"Action that concatenate ucs marked chars."
(let ((marked (helm-marked-candidates)))
(cl-loop for candidate in marked
do (helm-ucs-save-recentest candidate))
(kill-new (mapconcat (lambda (x)
(helm-ucs-match x 2))
marked ""))))
(defun helm-ucs-kill-code (candidate)
(helm-ucs-save-recentest candidate)
(kill-new (helm-ucs-match candidate 1)))
(defun helm-ucs-kill-name (candidate)
(helm-ucs-save-recentest candidate)
(kill-new (helm-ucs-match candidate 3)))
;; Navigation in current-buffer (persistent)
(defun helm-ucs-forward-char (_candidate)
(with-helm-current-buffer
(forward-char 1)))
(defun helm-ucs-backward-char (_candidate)
(with-helm-current-buffer
(forward-char -1)))
(defun helm-ucs-delete-backward (_candidate)
(with-helm-current-buffer
(delete-char -1)))
(defun helm-ucs-insert-space (_candidate)
(with-helm-current-buffer
(insert " ")))
(defun helm-ucs-persistent-forward ()
(interactive)
(with-helm-alive-p
(helm-set-attr 'action-forward 'helm-ucs-forward-char)
(helm-execute-persistent-action 'action-forward)))
(put 'helm-ucs-persistent-forward 'helm-only t)
(defun helm-ucs-persistent-backward ()
(interactive)
(with-helm-alive-p
(helm-set-attr 'action-back 'helm-ucs-backward-char)
(helm-execute-persistent-action 'action-back)))
(put 'helm-ucs-persistent-backward 'helm-only t)
(defun helm-ucs-persistent-delete ()
(interactive)
(with-helm-alive-p
(helm-set-attr 'action-delete 'helm-ucs-delete-backward)
(helm-execute-persistent-action 'action-delete)))
(put 'helm-ucs-persistent-delete 'helm-only t)
(defun helm-ucs-persistent-insert-space ()
(interactive)
(with-helm-alive-p
(helm-set-attr 'action-insert-space 'helm-ucs-insert-space)
(helm-execute-persistent-action 'action-insert-space)))
(defvar helm-source-ucs-recent
(helm-build-sync-source "Recent UCS"
:action helm-ucs-actions
:candidates (lambda () helm-ucs-recent)
:help-message helm-ucs-help-message
:keymap helm-ucs-map
:volatile t))
(defvar helm-source-ucs
(helm-build-in-buffer-source "UCS names"
:data #'helm-ucs-init
:get-line #'buffer-substring
:help-message 'helm-ucs-help-message
:filtered-candidate-transformer
(lambda (candidates _source) (sort candidates #'helm-generic-sort-fn))
:action helm-ucs-actions
:persistent-action (lambda (candidate)
(helm-ucs-insert-char candidate)
(helm-force-update))
:keymap helm-ucs-map)
"Source for collecting `ucs-names' math symbols.")
;;;###autoload
(defun helm-select-xfont ()
"Preconfigured `helm' to select Xfont."
(interactive)
(helm :sources 'helm-source-xfonts
:buffer "*helm select xfont*"))
;;;###autoload
(defun helm-ucs (arg)
"Preconfigured `helm' for `ucs-names'.
Called with a prefix arg force reloading cache."
(interactive "P")
(when arg
(setq helm-ucs--names nil
helm-ucs--max-len nil
ucs-names nil))
(let ((char (helm-aif (char-after) (string it))))
(helm :sources (list helm-source-ucs-recent helm-source-ucs)
:history 'helm-ucs-history
:input (and char (multibyte-string-p char) char)
:buffer "*helm ucs*")))
(provide 'helm-font)
;;; helm-font.el ends here