mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 21067e7cbe6d7a0f65ff5c317a96b5c337b0b3d8
commit | author | age
5cb5f7 1 ;;; helm-font --- Font and ucs selection for Helm -*- lexical-binding: t -*-
C 2
3 ;; Copyright (C) 2012 ~ 2018 Thierry Volpiatto <thierry.volpiatto@gmail.com>
4
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, either version 3 of the License, or
8 ;; (at your option) any later version.
9
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18 ;;; Code:
19
20 (require 'cl-lib)
21 (require 'helm)
22 (require 'helm-help)
23
24
25 (defgroup helm-font nil
26   "Related applications to display fonts in helm."
27   :group 'helm)
28
29 (defcustom helm-ucs-recent-size 10
30   "Number of recent chars to keep."
31   :type 'integer
32   :group 'helm-font)
33
34 (defcustom helm-ucs-actions
35   '(("Insert character"             . helm-ucs-insert-char)
36     ("Insert character name"        . helm-ucs-insert-name)
37     ("Insert character code in hex" . helm-ucs-insert-code)
38     ("Kill marked characters"       . helm-ucs-kill-char)
39     ("Kill name"                    . helm-ucs-kill-name)
40     ("Kill code"                    . helm-ucs-kill-code))
41   "Actions for `helm-source-ucs'."
42   :group 'helm-font
43   :type '(alist :key-type string :value-type function))
44
45 (defvar helm-ucs-map
46   (let ((map (make-sparse-keymap)))
47     (set-keymap-parent map helm-map)
48     (define-key map (kbd "<C-backspace>") 'helm-ucs-persistent-delete)
49     (define-key map (kbd "<C-left>")      'helm-ucs-persistent-backward)
50     (define-key map (kbd "<C-right>")     'helm-ucs-persistent-forward)
51     (define-key map (kbd "C-c SPC")       'helm-ucs-persistent-insert-space)
52     map)
53   "Keymap for `helm-ucs'.")
54
55 (defface helm-ucs-char
56   '((((class color) (background dark))  (:foreground "Gold")))
57   "Face used to display ucs characters."
58   :group 'helm-font)
59
60 ;;; Xfont selection
61 ;;
62 ;;
63 (defvar helm-xfonts-cache nil)
64 (defvar helm-previous-font nil)
65 (defvar helm-source-xfonts
66   (helm-build-sync-source "X Fonts"
67     :init (lambda ()
68             (unless helm-xfonts-cache
69               (setq helm-xfonts-cache
70                     (x-list-fonts "*")))
71             ;; Save current font so it can be restored in cleanup
72             (setq helm-previous-font (cdr (assq 'font (frame-parameters)))))
73     :candidates 'helm-xfonts-cache
74     :action '(("Copy font to kill ring" . (lambda (elm)
75                                             (kill-new elm)))
76               ("Set font" . (lambda (elm)
77                               (kill-new elm)
78                               (set-frame-font elm 'keep-size)
79                               (message "Font copied to kill ring"))))
80     :cleanup (lambda ()
81                ;; Restore previous font
82                (set-frame-font helm-previous-font 'keep-size))
83     :persistent-action (lambda (new-font)
84                          (set-frame-font new-font 'keep-size)
85                          (kill-new new-font))
86     :persistent-help "Preview font and copy to kill-ring"))
87
88
89 ;;; 𝕌𝕔𝕤 𝕊𝕪𝕞𝕓𝕠𝕝 𝕔𝕠𝕞𝕡𝕝𝕖𝕥𝕚𝕠𝕟
90 ;;
91 ;;
92 (defvar helm-ucs--max-len nil)
93 (defvar helm-ucs--names nil)
94 (defvar helm-ucs-history nil)
95 (defvar helm-ucs-recent nil
96   "Ring of recent `helm-ucs' selections.")
97
98 (defun helm-calculate-ucs-alist-max-len (names)
99   "Calculate the length of the longest NAMES list candidate."
100   (cl-loop for (_n . v) in names
101            maximize (length (format "#x%x:" v)) into code
102            maximize (max 1 (string-width (format "%c" v))) into char
103            finally return (cons code char)))
104
105 (defun helm-calculate-ucs-hash-table-max-len (names)
106   "Calculate the length of the longest NAMES hash table candidate."
107   (cl-loop for _n being the hash-keys of names
108            using (hash-values v)
109            maximize (length (format "#x%x:" v)) into code
110            maximize (max 1 (string-width (format "%c" v))) into char
111            finally return (cons code char)))
112
113 (defun helm-calculate-ucs-max-len ()
114   "Calculate the length of longest `ucs-names' candidate."
115   (let ((ucs-struct (ucs-names)))
116     (if (hash-table-p ucs-struct)
117         (helm-calculate-ucs-hash-table-max-len ucs-struct)
118       (helm-calculate-ucs-alist-max-len ucs-struct))))
119
120 (defun helm-ucs-collect-symbols-alist (names)
121   "Collect ucs symbols from the NAMES list."
122   (cl-loop with pr = (make-progress-reporter
123                       "collecting ucs names"
124                       0 (length names))
125            for (n . v) in names
126            for count from 1
127            for xcode = (format "#x%x:" v)
128            for len = (length xcode)
129            for diff = (- (car helm-ucs--max-len) len)
130            for code = (format "(#x%x): " v)
131            for char = (propertize (format "%c" v)
132                                   'face 'helm-ucs-char)
133            unless (or (string= "" n)
134                       ;; `char-displayable-p' return a font object or
135                       ;; t for some char that are displayable but have
136                       ;; no special font (e.g 10) so filter out char
137                       ;; with no font.
138                       (not (fontp (char-displayable-p (read xcode)))))
139            collect
140            (concat code (make-string diff ? )
141                    char "  " n)
142            and do (progress-reporter-update pr count)))
143
144 (defun helm-ucs-collect-symbols-hash-table (names)
145   "Collect ucs symbols from the NAMES hash-table."
146   (cl-loop with pr = (make-progress-reporter
147                       "collecting ucs names"
148                       0 (hash-table-count names))
149            for n being the hash-keys of names
150            using (hash-values v)
151            for count from 1
152            for xcode = (format "#x%x:" v)
153            for len = (length xcode)
154            for diff = (- (car helm-ucs--max-len) len)
155            for code = (format "(#x%x): " v)
156            for char = (propertize (format "%c" v)
157                                   'face 'helm-ucs-char)
158            unless (or (string= "" n)
159                       (not (fontp (char-displayable-p (read xcode)))))
160            collect
161            (concat code (make-string diff ? )
162                    char "  " n)
163            and do (progress-reporter-update pr count)))
164
165 (defun helm-ucs-collect-symbols (ucs-struct)
166   "Collect ucs symbols from UCS-STRUCT.
167
168 Depending on the Emacs version, the variable `ucs-names' can
169 either be an alist or a hash-table."
170   (if (hash-table-p ucs-struct)
171       (helm-ucs-collect-symbols-hash-table ucs-struct)
172     (helm-ucs-collect-symbols-alist ucs-struct)))
173
174 (defun helm-ucs-init ()
175   "Initialize an helm buffer with ucs symbols.
176 Only math* symbols are collected."
177   (unless helm-ucs--max-len
178     (setq helm-ucs--max-len
179           (helm-calculate-ucs-max-len)))
180   (or helm-ucs--names
181       (setq helm-ucs--names
182             (helm-ucs-collect-symbols (ucs-names)))))
183
184 ;; Actions (insertion)
185
186 (defun helm-ucs-match (candidate n)
187   "Return the N part of an ucs CANDIDATE.
188 Where N=1 is the ucs code, N=2 the ucs char and N=3 the ucs name."
189   (when (string-match
190          "^(\\(#x[a-f0-9]+\\)): *\\(.\\) *\\([^:]+\\)+"
191          candidate)
192     (match-string n candidate)))
193
194 (defun helm-ucs-save-recentest (candidate)
195   (let ((lst (cons candidate (delete candidate helm-ucs-recent))))
196     (setq helm-ucs-recent
197           (if (> (length lst) helm-ucs-recent-size)
198               (nbutlast lst 1)
199             lst))))
200
201 (defun helm-ucs-insert (candidate n)
202   "Insert the N part of CANDIDATE."
203   (with-helm-current-buffer
204     (helm-ucs-save-recentest candidate)
205     (insert (helm-ucs-match candidate n))))
206
207 (defun helm-ucs-insert-char (candidate)
208   "Insert ucs char part of CANDIDATE at point."
209   (helm-ucs-insert candidate 2))
210
211 (defun helm-ucs-insert-code (candidate)
212   "Insert ucs code part of CANDIDATE at point."
213   (helm-ucs-insert candidate 1))
214
215 (defun helm-ucs-insert-name (candidate)
216   "Insert ucs name part of CANDIDATE at point."
217   (helm-ucs-insert candidate 3))
218
219 ;; Kill actions
220 (defun helm-ucs-kill-char (_candidate)
221   "Action that concatenate ucs marked chars."
222   (let ((marked (helm-marked-candidates)))
223     (cl-loop for candidate in marked
224              do (helm-ucs-save-recentest candidate))
225     (kill-new (mapconcat (lambda (x)
226                            (helm-ucs-match x 2))
227                          marked ""))))
228
229 (defun helm-ucs-kill-code (candidate)
230   (helm-ucs-save-recentest candidate)
231   (kill-new (helm-ucs-match candidate 1)))
232
233 (defun helm-ucs-kill-name (candidate)
234   (helm-ucs-save-recentest candidate)
235   (kill-new (helm-ucs-match candidate 3)))
236
237 ;; Navigation in current-buffer (persistent)
238
239 (defun helm-ucs-forward-char (_candidate)
240   (with-helm-current-buffer
241     (forward-char 1)))
242
243 (defun helm-ucs-backward-char (_candidate)
244   (with-helm-current-buffer
245     (forward-char -1)))
246
247 (defun helm-ucs-delete-backward (_candidate)
248   (with-helm-current-buffer
249     (delete-char -1)))
250
251 (defun helm-ucs-insert-space (_candidate)
252   (with-helm-current-buffer
253     (insert " ")))
254
255 (defun helm-ucs-persistent-forward ()
256   (interactive)
257   (with-helm-alive-p
258     (helm-attrset 'action-forward 'helm-ucs-forward-char)
259     (helm-execute-persistent-action 'action-forward)))
260 (put 'helm-ucs-persistent-forward 'helm-only t)
261
262 (defun helm-ucs-persistent-backward ()
263   (interactive)
264   (with-helm-alive-p
265     (helm-attrset 'action-back 'helm-ucs-backward-char)
266     (helm-execute-persistent-action 'action-back)))
267 (put 'helm-ucs-persistent-backward 'helm-only t)
268
269 (defun helm-ucs-persistent-delete ()
270   (interactive)
271   (with-helm-alive-p
272     (helm-attrset 'action-delete 'helm-ucs-delete-backward)
273     (helm-execute-persistent-action 'action-delete)))
274 (put 'helm-ucs-persistent-delete 'helm-only t)
275
276 (defun helm-ucs-persistent-insert-space ()
277   (interactive)
278   (with-helm-alive-p
279     (helm-attrset 'action-insert-space 'helm-ucs-insert-space)
280     (helm-execute-persistent-action 'action-insert-space)))
281
282 (defvar helm-source-ucs-recent
283   (helm-build-sync-source "Recent UCS"
284     :action helm-ucs-actions
285     :candidates (lambda () helm-ucs-recent)
286     :help-message helm-ucs-help-message
287     :keymap helm-ucs-map
288     :volatile t))
289
290 (defvar helm-source-ucs
291   (helm-build-in-buffer-source "UCS names"
292     :data #'helm-ucs-init
293     :get-line #'buffer-substring
294     :help-message 'helm-ucs-help-message
295     :filtered-candidate-transformer
296     (lambda (candidates _source) (sort candidates #'helm-generic-sort-fn))
297     :action helm-ucs-actions
298     :persistent-action (lambda (candidate)
299                          (helm-ucs-insert-char candidate)
300                          (helm-force-update))
301     :keymap helm-ucs-map)
302   "Source for collecting `ucs-names' math symbols.")
303
304 ;;;###autoload
305 (defun helm-select-xfont ()
306   "Preconfigured `helm' to select Xfont."
307   (interactive)
308   (helm :sources 'helm-source-xfonts
309         :buffer "*helm select xfont*"))
310
311 ;;;###autoload
312 (defun helm-ucs (arg)
313   "Preconfigured helm for `ucs-names'.
314
315 Called with a prefix arg force reloading cache."
316   (interactive "P")
317   (when arg
318     (setq helm-ucs--names nil
319           helm-ucs--max-len nil
320           ucs-names nil))
321   (let ((char (helm-aif (char-after) (string it))))
322     (helm :sources (list helm-source-ucs-recent helm-source-ucs)
323           :history 'helm-ucs-history
324           :input (and char (multibyte-string-p char) char)
325           :buffer "*helm ucs*")))
326
327 (provide 'helm-font)
328
329 ;; Local Variables:
330 ;; byte-compile-warnings: (not obsolete)
331 ;; coding: utf-8
332 ;; indent-tabs-mode: nil
333 ;; End:
334
335 ;;; helm-font.el ends here