Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

335 lines
11 KiB

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