| 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 | |
