Permalink
Cannot retrieve contributors at this time
Fetching contributors…
Cannot retrieve contributors at this time
| ;;; helm-font --- Font and ucs selection for Helm -*- lexical-binding: t -*- | |
| ;; Copyright (C) 2012 ~ 2017 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) | |
| (defgroup helm-font nil | |
| "Related applications to display fonts in helm." | |
| :group 'helm) | |
| (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-return>") 'helm-ucs-persistent-insert) | |
| (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)) (: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) | |
| (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 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 an 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-insert (candidate n) | |
| "Insert the N part of CANDIDATE." | |
| (with-helm-current-buffer | |
| (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)) | |
| (defun helm-ucs-persistent-insert () | |
| "Insert ucs char without quitting helm." | |
| (interactive) | |
| (with-helm-alive-p | |
| (helm-attrset 'action-insert 'helm-ucs-insert-char) | |
| (helm-execute-persistent-action 'action-insert))) | |
| (put 'helm-ucs-persistent-insert 'helm-only t) | |
| ;; Kill actions | |
| (defun helm-ucs-kill-char (_candidate) | |
| "Action that concatenate ucs marked chars." | |
| (kill-new (mapconcat (lambda (x) | |
| (helm-ucs-match x 2)) | |
| (helm-marked-candidates) ""))) | |
| (defun helm-ucs-kill-code (candidate) | |
| (kill-new (helm-ucs-match candidate 1))) | |
| (defun helm-ucs-kill-name (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-attrset '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-attrset '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-attrset '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-attrset 'action-insert-space 'helm-ucs-insert-space) | |
| (helm-execute-persistent-action 'action-insert-space))) | |
| (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 | |
| :match-part (lambda (candidate) (cadr (split-string candidate ":"))) | |
| :filtered-candidate-transformer | |
| (lambda (candidates _source) (sort candidates #'helm-generic-sort-fn)) | |
| :action '(("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)) | |
| :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 'helm-source-ucs | |
| :history 'helm-ucs-history | |
| :input (and char (multibyte-string-p char) char) | |
| :buffer "*helm ucs*"))) | |
| (provide 'helm-font) | |
| ;; Local Variables: | |
| ;; byte-compile-warnings: (not obsolete) | |
| ;; coding: utf-8 | |
| ;; indent-tabs-mode: nil | |
| ;; End: | |
| ;;; helm-font.el ends here |