mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-09-02 01:35:32 +00:00
e4b243b931
* lisp/international/emoji.el (emoji--name): Lookup name using 'char-to-name'. * lisp/international/textsec.el (textsec-domain-suspicious-p): And here. * lisp/simple.el (what-cursor-position): And here.
756 lines
28 KiB
EmacsLisp
756 lines
28 KiB
EmacsLisp
;;; emoji.el --- Inserting emojis -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2021-2024 Free Software Foundation, Inc.
|
|
|
|
;; Author: Lars Ingebrigtsen <larsi@gnus.org>
|
|
;; Keywords: fun
|
|
|
|
;; Package-Requires: ((emacs "28.0") (transient "0.3.7"))
|
|
;; Package-Version: 0.1
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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.
|
|
|
|
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'cl-extra)
|
|
(require 'transient)
|
|
(require 'multisession)
|
|
(require 'generate-lisp-file)
|
|
|
|
(defgroup emoji nil
|
|
"Inserting Emojis."
|
|
:version "29.1"
|
|
:group 'play)
|
|
|
|
(defface emoji-list-header
|
|
'((default :weight bold :inherit variable-pitch))
|
|
"Face for emoji list headers."
|
|
:version "29.1")
|
|
|
|
(defface emoji
|
|
'((t :height 2.0))
|
|
"Face used when displaying an emoji."
|
|
:version "29.1")
|
|
|
|
(defface emoji-with-derivations
|
|
'((((background dark))
|
|
(:background "#202020" :inherit emoji))
|
|
(((background light))
|
|
(:background "#e0e0e0" :inherit emoji)))
|
|
"Face for emojis that have derivations."
|
|
:version "29.1")
|
|
|
|
(defvar emoji-alternate-names nil
|
|
"Alist of emojis and lists of alternate names for the emojis.
|
|
Each element in the alist should have the emoji (as a string) as
|
|
the first element, and the rest of the elements should be strings
|
|
representing names. For instance:
|
|
|
|
(\"🤗\" \"hug\" \"hugging\" \"kind\")")
|
|
|
|
(defvar emoji--labels nil)
|
|
(defvar emoji--all-bases nil)
|
|
(defvar emoji--derived nil)
|
|
(defvar emoji--names (make-hash-table :test #'equal))
|
|
(define-multisession-variable emoji--recent (list "😀" "😖"))
|
|
(defvar emoji--insert-buffer)
|
|
|
|
;;;###autoload (autoload 'emoji-insert "emoji" nil t)
|
|
(transient-define-prefix emoji-insert ()
|
|
"Choose and insert an emoji glyph."
|
|
:variable-pitch t
|
|
[:class transient-columns
|
|
:setup-children emoji--setup-suffixes
|
|
:description emoji--group-description]
|
|
(interactive "*")
|
|
(emoji--init)
|
|
(emoji--setup-prefix 'emoji-insert "Emoji" nil
|
|
`(("Recent" ,@(multisession-value emoji--recent))
|
|
,@emoji--labels)))
|
|
|
|
;;;###autoload (autoload 'emoji-recent "emoji" nil t)
|
|
(transient-define-prefix emoji-recent ()
|
|
"Choose and insert one of the recently-used emoji glyphs."
|
|
:variable-pitch t
|
|
[:class transient-columns
|
|
:setup-children emoji--setup-suffixes
|
|
:description emoji--group-description]
|
|
(interactive "*")
|
|
(emoji--init)
|
|
(emoji--setup-prefix 'emoji-recent "Recent" t
|
|
(multisession-value emoji--recent)))
|
|
|
|
;;;###autoload (autoload 'emoji-search "emoji" nil t)
|
|
(transient-define-prefix emoji-search (glyph derived)
|
|
"Choose and insert an emoji glyph by typing its Unicode name.
|
|
This command prompts for an emoji name, with completion, and
|
|
inserts it. It recognizes the Unicode Standard names of emoji,
|
|
and also consults the `emoji-alternate-names' alist."
|
|
:variable-pitch t
|
|
[:class transient-columns
|
|
:setup-children emoji--setup-suffixes
|
|
:description emoji--group-description]
|
|
(interactive
|
|
(progn (barf-if-buffer-read-only)
|
|
(emoji--init)
|
|
(let ((cons (emoji--read-emoji)))
|
|
(list (car cons) (cdr cons)))))
|
|
(if derived
|
|
(emoji--setup-prefix 'emoji-search "Choose Emoji"
|
|
(list glyph)
|
|
(cons glyph derived))
|
|
(emoji--add-recent glyph)
|
|
(insert glyph)))
|
|
|
|
(defclass emoji--narrow (transient-suffix)
|
|
((title :initarg :title)
|
|
(done-derived :initarg :done-derived)
|
|
(children :initarg :children)))
|
|
|
|
(defun emoji--setup-prefix (command title done-derived spec)
|
|
(transient-setup
|
|
command nil nil
|
|
:scope (if (eq transient-current-command command)
|
|
(cons (oref (transient-suffix-object) title)
|
|
(oref (transient-suffix-object) done-derived))
|
|
(cons title done-derived))
|
|
:value (if (eq transient-current-command command)
|
|
(oref (transient-suffix-object) children)
|
|
spec)))
|
|
|
|
(defun emoji--setup-suffixes (_)
|
|
(transient-parse-suffixes
|
|
(oref transient--prefix command)
|
|
(pcase-let ((`(,title . ,done-derived) (oref transient--prefix scope)))
|
|
(emoji--layout (oref transient--prefix command) title
|
|
(oref transient--prefix value) done-derived))))
|
|
|
|
(defun emoji--group-description ()
|
|
(car (oref transient--prefix scope)))
|
|
|
|
(transient-define-suffix emoji-insert-glyph (glyph)
|
|
"Insert the emoji you selected."
|
|
(interactive
|
|
(list (if (string-prefix-p "emoji-" (symbol-name transient-current-command))
|
|
(oref (transient-suffix-object) description)
|
|
(car (multisession-value emoji--recent))))
|
|
not-a-mode)
|
|
(emoji--add-recent glyph)
|
|
(insert glyph))
|
|
|
|
;;;###autoload
|
|
(defun emoji-list ()
|
|
"List emojis and allow selecting and inserting one of them.
|
|
Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture.
|
|
The glyph will be inserted into the buffer that was current
|
|
when the command was invoked."
|
|
(interactive)
|
|
(let ((buf (current-buffer)))
|
|
(emoji--init)
|
|
(switch-to-buffer (get-buffer-create "*Emoji*"))
|
|
;; Don't regenerate the buffer if it already exists -- this will
|
|
;; leave point where it was the last time it was used.
|
|
(when (zerop (buffer-size))
|
|
(let ((inhibit-read-only t))
|
|
(emoji-list-mode)
|
|
(setq-local emoji--insert-buffer buf)
|
|
(emoji--list-generate nil (cons nil emoji--labels))
|
|
(goto-char (point-min))))))
|
|
|
|
;;;###autoload
|
|
(defun emoji-describe (glyph &optional interactive)
|
|
"Display the name of the grapheme cluster composed from GLYPH.
|
|
GLYPH should be a string of one or more characters which together
|
|
produce an emoji. Interactively, GLYPH is the emoji at point (it
|
|
could also be any character, not just emoji).
|
|
|
|
If called from Lisp, return the name as a string; return nil if
|
|
the name is not known."
|
|
(interactive
|
|
(list (if (eobp)
|
|
(error "No glyph under point")
|
|
(let ((comp (find-composition (point) (1+ (point)))))
|
|
(if comp
|
|
(buffer-substring-no-properties (car comp) (cadr comp))
|
|
(buffer-substring-no-properties (point) (1+ (point))))))
|
|
t))
|
|
(require 'emoji-labels)
|
|
(if (not interactive)
|
|
;; Don't return a name for non-compositions when called
|
|
;; non-interactively.
|
|
(gethash glyph emoji--names)
|
|
;; Give a name for (pretty much) any glyph, including non-emojis.
|
|
(let ((name (emoji--name glyph)))
|
|
(if (not name)
|
|
(message "No known name for \"%s\"" glyph)
|
|
(message "The name of \"%s\" is \"%s\"" glyph name)))))
|
|
|
|
(defun emoji--list-generate (name alist)
|
|
(let ((width (/ (window-width) 5))
|
|
(mname (pop alist)))
|
|
(if (consp (car alist))
|
|
;; Recurse.
|
|
(mapcar (lambda (elem)
|
|
(emoji--list-generate (if name
|
|
(concat name " > " mname)
|
|
mname)
|
|
elem))
|
|
alist)
|
|
;; Output this block of emojis.
|
|
(insert (propertize
|
|
(if (zerop (length name))
|
|
mname
|
|
(concat name " > " mname))
|
|
'face 'emoji-list-header)
|
|
"\n\n")
|
|
(cl-loop for i from 0
|
|
for glyph in alist
|
|
do
|
|
(when (and (cl-plusp i)
|
|
(zerop (mod i width)))
|
|
(insert "\n"))
|
|
(insert
|
|
(propertize
|
|
(emoji--fontify-glyph glyph)
|
|
'emoji-glyph glyph
|
|
'help-echo (emoji--name glyph))))
|
|
(insert "\n\n"))))
|
|
|
|
(defun emoji--fontify-glyph (glyph &optional done-derived)
|
|
(propertize glyph 'face
|
|
(if (and (not (or (eq done-derived t)
|
|
(member glyph done-derived)))
|
|
(gethash glyph emoji--derived))
|
|
;; If this emoji has derivations, use a special face
|
|
;; to tell the user.
|
|
'emoji-with-derivations
|
|
;; Normal emoji.
|
|
'emoji)))
|
|
|
|
(defun emoji--name (glyph)
|
|
(or (gethash glyph emoji--names)
|
|
(char-to-name (aref glyph 0))))
|
|
|
|
(defvar-keymap emoji-list-mode-map
|
|
"RET" #'emoji-list-select
|
|
"<mouse-2>" #'emoji-list-select
|
|
"h" #'emoji-list-help
|
|
"<follow-link>" 'mouse-face)
|
|
|
|
(define-derived-mode emoji-list-mode special-mode "Emoji"
|
|
"Mode to display emojis."
|
|
:interactive nil
|
|
(setq-local truncate-lines t))
|
|
|
|
;;;###autoload (autoload 'emoji-list-select "emoji" nil t)
|
|
(transient-define-prefix emoji-list-select (event)
|
|
"Select the emoji under point."
|
|
:variable-pitch t
|
|
[:class transient-columns
|
|
:setup-children emoji--setup-suffixes
|
|
:description emoji--group-description]
|
|
(interactive (list last-nonmenu-event) emoji-list-mode)
|
|
(mouse-set-point event)
|
|
(let ((glyph (get-text-property (point) 'emoji-glyph)))
|
|
(unless glyph
|
|
(error "No emoji under point"))
|
|
(let ((buf emoji--insert-buffer))
|
|
(quit-window)
|
|
(if (buffer-live-p buf)
|
|
(progn
|
|
(switch-to-buffer buf)
|
|
(barf-if-buffer-read-only))
|
|
(error "Buffer disappeared")))
|
|
(let ((derived (gethash glyph emoji--derived)))
|
|
(if derived
|
|
(emoji--setup-prefix 'emoji-list-select "Choose Emoji"
|
|
(list glyph)
|
|
(cons glyph derived))
|
|
(emoji--add-recent glyph)
|
|
(insert glyph)))))
|
|
|
|
(defun emoji-list-help ()
|
|
"Display the name of the emoji at point."
|
|
(interactive nil emoji-list-mode)
|
|
(let ((glyph (get-text-property (point) 'emoji-glyph)))
|
|
(unless glyph
|
|
(error "No emoji here"))
|
|
(let ((name (emoji--name glyph)))
|
|
(if (not name)
|
|
(error "Emoji name is unknown")
|
|
(message "%s" name)))))
|
|
|
|
;;;###autoload
|
|
(defun emoji--init (&optional force inhibit-adjust)
|
|
(when (or (not emoji--labels)
|
|
force)
|
|
(unless force
|
|
(ignore-errors (require 'emoji-labels)))
|
|
;; The require should define the variable, but in case the .el
|
|
;; file doesn't exist (yet), parse the file now.
|
|
(when (or force
|
|
(not emoji--labels))
|
|
(setq emoji--derived (make-hash-table :test #'equal))
|
|
(emoji--parse-emoji-test)))
|
|
(when (and (not inhibit-adjust)
|
|
(not emoji--all-bases))
|
|
(setq emoji--all-bases (make-hash-table :test #'equal))
|
|
(emoji--adjust-displayable (cons "Emoji" emoji--labels))))
|
|
|
|
(defvar emoji--font nil)
|
|
|
|
(defun emoji--adjust-displayable (alist)
|
|
"Remove glyphs we don't have fonts for."
|
|
(let ((emoji--font nil))
|
|
(emoji--adjust-displayable-1 alist)))
|
|
|
|
(defun emoji--adjust-displayable-1 (alist)
|
|
(if (consp (caddr alist))
|
|
(dolist (child (cdr alist))
|
|
(emoji--adjust-displayable-1 child))
|
|
(while (cdr alist)
|
|
(let ((glyph (cadr alist)))
|
|
;; Store all the emojis for later retrieval by
|
|
;; the search feature.
|
|
(when-let ((name (emoji--name glyph)))
|
|
(setf (gethash (downcase name) emoji--all-bases) glyph))
|
|
(if (display-graphic-p)
|
|
;; Remove glyphs we don't have in graphical displays.
|
|
(if (let ((char (elt glyph 0)))
|
|
(if emoji--font
|
|
(font-has-char-p emoji--font char)
|
|
(when-let ((font (car (internal-char-font nil char))))
|
|
(setq emoji--font font))))
|
|
(setq alist (cdr alist))
|
|
;; Remove the element.
|
|
(setcdr alist (cddr alist)))
|
|
;; We don't have font info on non-graphical displays.
|
|
(if (let ((char (elt glyph 0)))
|
|
;; FIXME. Some grapheme clusters display more or less
|
|
;; correctly in the terminal, but we don't really know
|
|
;; which ones. None of these display totally
|
|
;; correctly, though, so should they be filtered out?
|
|
(char-displayable-p char))
|
|
(setq alist (cdr alist))
|
|
;; Remove the element.
|
|
(setcdr alist (cddr alist))))))))
|
|
|
|
(defun emoji--parse-emoji-test ()
|
|
(setq emoji--labels nil)
|
|
(with-temp-buffer
|
|
(insert-file-contents (expand-file-name "../admin/unidata/emoji-test.txt"
|
|
data-directory))
|
|
(unless (re-search-forward "^# +group:" nil t)
|
|
(error "Can't find start of data"))
|
|
(beginning-of-line)
|
|
(setq emoji--names (make-hash-table :test #'equal))
|
|
(let ((derivations (make-hash-table :test #'equal))
|
|
(case-fold-search t)
|
|
(glyphs nil)
|
|
group subgroup)
|
|
(while (not (eobp))
|
|
(cond
|
|
((looking-at "# +group: \\(.*\\)")
|
|
(setq group (match-string 1)
|
|
subgroup nil))
|
|
((looking-at "# +subgroup: \\(.*\\)")
|
|
(setq subgroup (match-string 1)))
|
|
((looking-at
|
|
"\\([[:xdigit:] \t]+\\); *\\([^ \t]+\\)[ \t]+#.*?E[.0-9]+ +\\(.*\\)")
|
|
(let* ((codes (match-string 1))
|
|
(qualification (match-string 2))
|
|
(name (match-string 3))
|
|
(glyph (mapconcat
|
|
(lambda (code)
|
|
(string (string-to-number code 16)))
|
|
(split-string codes))))
|
|
(push (list name qualification group subgroup glyph) glyphs))))
|
|
(forward-line 1))
|
|
;; We sort the data so that the "person foo" variant comes
|
|
;; first, so that that becomes the key.
|
|
(setq glyphs
|
|
(sort (nreverse glyphs)
|
|
(lambda (g1 g2)
|
|
(and (equal (nth 2 g1) (nth 2 g2))
|
|
(equal (nth 3 g1) (nth 3 g2))
|
|
(< (emoji--score (car g1))
|
|
(emoji--score (car g2)))))))
|
|
;; Get the derivations.
|
|
(cl-loop for (name qualification group subgroup glyph) in glyphs
|
|
for base = (emoji--base-name name derivations)
|
|
do
|
|
;; Special-case flags.
|
|
(when (equal base "flag")
|
|
(setq base name))
|
|
;; Register all glyphs to that we can look up their names
|
|
;; later.
|
|
(setf (gethash glyph emoji--names) name)
|
|
;; For the interface, we only care about the fully qualified
|
|
;; emojis.
|
|
(when (equal qualification "fully-qualified")
|
|
(when (equal base name)
|
|
(emoji--add-to-group group subgroup glyph))
|
|
;; Create mapping from base glyph name to name of
|
|
;; derived glyphs.
|
|
(setf (gethash base derivations)
|
|
(nconc (gethash base derivations) (list glyph)))))
|
|
;; Finally create the mapping from the base glyphs to derived ones.
|
|
(setq emoji--derived (make-hash-table :test #'equal))
|
|
(maphash (lambda (_k v)
|
|
(setf (gethash (car v) emoji--derived)
|
|
(cdr v)))
|
|
derivations))))
|
|
|
|
(defun emoji--score (string)
|
|
(if (string-match-p "person\\|people"
|
|
(replace-regexp-in-string ":.*" "" string))
|
|
0
|
|
1))
|
|
|
|
(defun emoji--add-to-group (group subgroup glyph)
|
|
;; "People & Body" is very large; split it up.
|
|
(cond
|
|
((equal group "People & Body")
|
|
(if (or (string-match "\\`person" subgroup)
|
|
(equal subgroup "family"))
|
|
(emoji--add-glyph glyph "People"
|
|
(if (equal subgroup "family")
|
|
(list subgroup)
|
|
;; Avoid "Person person".
|
|
(cdr (emoji--split-subgroup subgroup))))
|
|
(emoji--add-glyph glyph "Body" (emoji--split-subgroup subgroup))))
|
|
;; "Smileys & Emotion" also seems sub-optimal.
|
|
((equal group "Smileys & Emotion")
|
|
(if (equal subgroup "emotion")
|
|
(emoji--add-glyph glyph "Emotion" nil)
|
|
(let ((subs (emoji--split-subgroup subgroup)))
|
|
;; Remove one level of menus in the face case.
|
|
(when (equal (car subs) "face")
|
|
(pop subs))
|
|
(emoji--add-glyph glyph "Smileys" subs))))
|
|
;; Don't modify the rest.
|
|
(t
|
|
(emoji--add-glyph glyph group (emoji--split-subgroup subgroup)))))
|
|
|
|
(defun emoji--generate-file (&optional file)
|
|
"Generate an .el file with emoji mapping data and write it to FILE."
|
|
;; Running from Makefile.
|
|
(unless file
|
|
(setq file (pop command-line-args-left)))
|
|
(emoji--init t t)
|
|
;; Weed out the elements that are empty.
|
|
(let ((glyphs nil))
|
|
(maphash (lambda (k v)
|
|
(unless v
|
|
(push k glyphs)))
|
|
emoji--derived)
|
|
(dolist (glyph glyphs)
|
|
(remhash glyph emoji--derived)))
|
|
(with-temp-buffer
|
|
(generate-lisp-file-heading file 'emoji--generate-file)
|
|
(insert ";; Copyright © 1991-2021 Unicode, Inc.
|
|
;; Generated from Unicode data files by emoji.el.
|
|
;; The source for this file is found in the admin/unidata/emoji-test.txt
|
|
;; file in the Emacs sources. The Unicode data files are used under the
|
|
;; Unicode Terms of Use, as contained in the file copyright.html in that
|
|
;; same directory.\n\n")
|
|
(dolist (var '(emoji--labels emoji--derived emoji--names))
|
|
(insert (format "(defconst %s '" var))
|
|
(pp (symbol-value var) (current-buffer))
|
|
(insert (format "\n) ;; End %s\n\n" var)))
|
|
(generate-lisp-file-trailer file)
|
|
(write-region (point-min) (point-max) file)))
|
|
|
|
(defun emoji--base-name (name derivations)
|
|
(let* ((base (replace-regexp-in-string ":.*" "" name)))
|
|
(catch 'found
|
|
;; If we have (for instance) "person golfing", and we're adding
|
|
;; "man golfing", make the latter a derivation of the former.
|
|
(let ((non-binary (replace-regexp-in-string
|
|
"\\`\\(m[ae]n\\|wom[ae]n\\) " "" base)))
|
|
(dolist (prefix '("person " "people " ""))
|
|
(let ((key (concat prefix non-binary)))
|
|
(when (gethash key derivations)
|
|
(throw 'found key)))))
|
|
;; We can also have the gender at the end of the string, like
|
|
;; "merman" and "pregnant woman".
|
|
(let ((non-binary (replace-regexp-in-string
|
|
"\\(m[ae]n\\|wom[ae]n\\|maid\\)\\'" "" base)))
|
|
(dolist (suffix '(" person" "person" ""))
|
|
(let ((key (concat non-binary suffix)))
|
|
(when (gethash key derivations)
|
|
(throw 'found key)))))
|
|
;; Just return the base.
|
|
base)))
|
|
|
|
(defun emoji--split-subgroup (subgroup)
|
|
(let ((prefixes '("face" "hand" "person" "animal" "plant"
|
|
"food" "place")))
|
|
(cond
|
|
((string-match (concat "\\`" (regexp-opt prefixes) "-") subgroup)
|
|
;; Split these subgroups into hierarchies.
|
|
(list (substring subgroup 0 (1- (match-end 0)))
|
|
(substring subgroup (match-end 0))))
|
|
((equal subgroup "person")
|
|
(list "person" "age"))
|
|
(t
|
|
(list subgroup)))))
|
|
|
|
(defun emoji--add-glyph (glyph main subs)
|
|
(let (parent elem)
|
|
;; Useless category.
|
|
(unless (member main '("Component"))
|
|
(unless (setq parent (assoc main emoji--labels))
|
|
(setq emoji--labels (append emoji--labels
|
|
(list (setq parent (list main))))))
|
|
(setq elem parent)
|
|
(while subs
|
|
(unless (setq elem (assoc (car subs) parent))
|
|
(nconc parent (list (setq elem (list (car subs))))))
|
|
(pop subs)
|
|
(setq parent elem))
|
|
(nconc elem (list glyph)))))
|
|
|
|
(defun emoji--layout (command title spec done-derived)
|
|
(let ((has-subs (consp (cadr spec))))
|
|
(emoji--columnize
|
|
(if has-subs
|
|
(cl-loop for (key desc . glyphs) in (emoji--compute-prefix spec)
|
|
collect
|
|
(list key
|
|
(emoji--compute-name (cons desc glyphs))
|
|
command
|
|
:class 'emoji--narrow
|
|
:title (concat title " > " desc)
|
|
:done-derived (or (string-suffix-p "Recent" desc)
|
|
done-derived)
|
|
:children glyphs))
|
|
(cl-loop for glyph in spec
|
|
for char in (emoji--char-sequence)
|
|
for key = (string char)
|
|
for derived = (and (not (or (eq done-derived t)
|
|
(member glyph done-derived)))
|
|
(gethash glyph emoji--derived))
|
|
collect
|
|
(if derived
|
|
(list key
|
|
(emoji--fontify-glyph glyph done-derived)
|
|
command
|
|
:class 'emoji--narrow
|
|
:title (concat title " " glyph)
|
|
:done-derived (or (eq done-derived t)
|
|
(cons glyph done-derived))
|
|
:children (cons glyph derived))
|
|
(list key
|
|
(emoji--fontify-glyph glyph done-derived)
|
|
'emoji-insert-glyph))))
|
|
(if has-subs 2 8))))
|
|
|
|
(defun emoji--char-sequence ()
|
|
(append (number-sequence ?a ?z)
|
|
(number-sequence ?A ?Z)
|
|
(number-sequence ?0 ?9)
|
|
(number-sequence ?! ?/)))
|
|
|
|
(defun emoji--add-recent (glyph)
|
|
"Add GLYPH to the set of recently used emojis."
|
|
(let ((recent (multisession-value emoji--recent)))
|
|
(set-text-properties 0 (length glyph) nil glyph)
|
|
(setq recent (delete glyph recent))
|
|
(push glyph recent)
|
|
;; Shorten the list.
|
|
(when-let ((tail (nthcdr 30 recent)))
|
|
(setcdr tail nil))
|
|
(setf (multisession-value emoji--recent) recent)))
|
|
|
|
(defun emoji--columnize (list columns)
|
|
"Split LIST into COLUMN columns."
|
|
(cl-loop with length = (ceiling (/ (float (length list)) columns))
|
|
for i upto columns
|
|
for part on list by (lambda (l) (nthcdr length l))
|
|
collect (apply #'vector (seq-take part length))))
|
|
|
|
(defun emoji--compute-prefix (alist)
|
|
"Compute characters to use for entries in ALIST.
|
|
We prefer the earliest unique letter."
|
|
(cl-loop with taken = (make-hash-table)
|
|
for entry in alist
|
|
for name = (car entry)
|
|
collect (cons (cl-loop for char across (concat
|
|
(downcase name)
|
|
(upcase name))
|
|
while (gethash char taken)
|
|
finally (progn
|
|
(setf (gethash char taken) t)
|
|
(cl-return (string char))))
|
|
entry)))
|
|
|
|
(defun emoji--compute-name (entry)
|
|
"Add example emojis to the name."
|
|
(let* ((name (concat (car entry) " "))
|
|
(children (emoji--flatten entry))
|
|
(length (length name))
|
|
(max 30))
|
|
(cl-loop for i from 0 upto 20
|
|
;; Choose from all the children.
|
|
while (< length max)
|
|
do (cl-loop for child in children
|
|
for glyph = (elt child i)
|
|
while (< length max)
|
|
when glyph
|
|
do (setq name (concat name glyph)
|
|
length (+ length 2))))
|
|
(if (= (length name) max)
|
|
;; Make an ellipsis signal that we've not exhausted the
|
|
;; possibilities.
|
|
(concat name "…")
|
|
name)))
|
|
|
|
(defun emoji--flatten (alist)
|
|
(pop alist)
|
|
(if (consp (cadr alist))
|
|
(cl-loop for child in alist
|
|
append (emoji--flatten child))
|
|
(list alist)))
|
|
|
|
(defun emoji--split-long-lists (alist)
|
|
(let ((whole alist))
|
|
(pop alist)
|
|
(if (consp (cadr alist))
|
|
;; Descend.
|
|
(cl-loop for child in alist
|
|
do (emoji--split-long-lists child))
|
|
;; We have a list.
|
|
(when (length> alist 77)
|
|
(setcdr whole
|
|
(cl-loop for prefix from ?a
|
|
for bit on alist by (lambda (l) (nthcdr 77 l))
|
|
collect (cons (concat (string prefix) "-group")
|
|
(seq-take bit 77))))))))
|
|
|
|
(defun emoji--read-emoji ()
|
|
;; Use the list of names.
|
|
(let* ((table
|
|
(if (not emoji-alternate-names)
|
|
;; If we don't have alternate names, do the efficient version.
|
|
emoji--all-bases
|
|
;; Compute all the (possibly non-unique) names.
|
|
(let ((table nil))
|
|
(maphash
|
|
(lambda (name glyph)
|
|
(push (concat name "\t" glyph) table))
|
|
emoji--all-bases)
|
|
(dolist (elem emoji-alternate-names)
|
|
(dolist (name (cdr elem))
|
|
(push (concat name "\t" (car elem)) table)))
|
|
(sort table #'string<))))
|
|
(name
|
|
(completing-read
|
|
"Insert emoji: "
|
|
(lambda (string pred action)
|
|
(if (eq action 'metadata)
|
|
(list 'metadata
|
|
(cons
|
|
'affixation-function
|
|
;; Add the glyphs to the start of the displayed
|
|
;; strings when TAB-ing.
|
|
(lambda (strings)
|
|
(mapcar
|
|
(lambda (name)
|
|
(if emoji-alternate-names
|
|
(list name "" "")
|
|
(list name
|
|
(concat
|
|
(or (gethash name emoji--all-bases) " ")
|
|
"\t")
|
|
"")))
|
|
strings))))
|
|
(complete-with-action action table string pred)))
|
|
nil t)))
|
|
(if (cl-plusp (length name))
|
|
(let ((glyph (if emoji-alternate-names
|
|
(cadr (split-string name "\t"))
|
|
(gethash name emoji--all-bases))))
|
|
(cons glyph (gethash glyph emoji--derived)))
|
|
(user-error "You didn't specify an emoji"))))
|
|
|
|
(defvar-keymap emoji-zoom-map
|
|
"+" #'emoji-zoom-increase
|
|
"-" #'emoji-zoom-decrease
|
|
"0" #'emoji-zoom-reset)
|
|
|
|
;;;###autoload
|
|
(defun emoji-zoom-increase (&optional factor)
|
|
"Increase the size of the character under point.
|
|
FACTOR is the multiplication factor for the size."
|
|
(interactive)
|
|
(set-transient-map emoji-zoom-map t #'redisplay "Zoom with %k")
|
|
(unless (eobp)
|
|
(let* ((factor (or factor 1.1))
|
|
(old (get-text-property (point) 'face))
|
|
;; The text property is either a named face, or a plist
|
|
;; with :height, or a list starting with such a plist,
|
|
;; followed by one or more faces.
|
|
(newheight (* (or (and (consp old)
|
|
(or (plist-get (car old) :height)
|
|
(plist-get old :height)))
|
|
1.0)
|
|
factor))
|
|
(inhibit-read-only t))
|
|
(with-silent-modifications
|
|
(if (consp old)
|
|
(add-text-properties
|
|
(point) (1+ (point))
|
|
(list 'face
|
|
(cond
|
|
((eq (car old) :height)
|
|
(plist-put (copy-sequence old) :height newheight))
|
|
((plistp (car old))
|
|
(cons (plist-put (car old) :height newheight)
|
|
(cdr old)))
|
|
(t
|
|
(append (list (list :height newheight)) old)))
|
|
'rear-nonsticky t))
|
|
(add-face-text-property (point) (1+ (point))
|
|
(list :height newheight))
|
|
(put-text-property (point) (1+ (point))
|
|
'rear-nonsticky t))))))
|
|
|
|
;;;###autoload
|
|
(defun emoji-zoom-decrease ()
|
|
"Decrease the size of the character under point."
|
|
(interactive)
|
|
(emoji-zoom-increase 0.9))
|
|
|
|
;;;###autoload
|
|
(defun emoji-zoom-reset ()
|
|
"Reset the size of the character under point."
|
|
(interactive)
|
|
(with-silent-modifications
|
|
(let ((old (get-text-property (point) 'face)))
|
|
(when (and (consp old)
|
|
(remove-text-properties (point) (1+ (point)) '(rear-nonsticky nil)))
|
|
(if (eq (car old) :height)
|
|
(remove-text-properties (point) (1+ (point)) '(face nil))
|
|
(add-text-properties (point) (1+ (point)) (list 'face
|
|
(cdr old))))))))
|
|
|
|
(provide 'emoji)
|
|
|
|
;;; emoji.el ends here
|