* lisp/char-fold.el (describe-char-fold-equivalences): New command.

(char-fold--no-regexp): New internal variable.
(char-fold--make-table): Use it to skip translation to regexp.
Suggested by Robert Pluim <rpluim@gmail.com>.
https://lists.gnu.org/archive/html/emacs-devel/2022-07/msg00864.html

diff --git a/etc/NEWS b/etc/NEWS
index b27f0760d1240ba59d9bbb6789fddbf2d76cb0a2..a40954a83760300e97f646b0e0c426b23eae13a1 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1518,6 +1518,9 @@ with 'C-s C-s', but also after typing a character.
 Non-nil means that the default definitions of equivalent characters
 are overridden.
 
+*** New command 'describe-char-fold-equivalences'.
+It displays character equivalences used by `char-fold-to-regexp'.
+
 +++
 *** New command 'isearch-emoji-by-name'.
 It is bound to 'C-x 8 e RET' during an incremental search.  The

diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index 05ae52cae0d7c9bca2de2994c25db8a1d7b29c4e..e4c7c3c41e55c48597c0ab3181ba3b1979039082 100644 (file)
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -48,6 +48,7 @@
 
 \f
 (eval-and-compile
+  (defvar char-fold--no-regexp nil)
   (defun char-fold--make-table ()
     (let* ((equiv (make-char-table 'char-fold-table))
            (equiv-multi (make-char-table 'char-fold-table))
@@ -201,11 +202,14 @@
            symmetric)))
 
       ;; Convert the lists of characters we compiled into regexps.
-      (map-char-table
-       (lambda (char decomp-list)
-         (let ((re (regexp-opt (cons (char-to-string char) decomp-list))))
-           (aset equiv char re)))
-       equiv)
+      (unless char-fold--no-regexp
+        ;; Non-nil `char-fold--no-regexp' unoptimized for regexp
+        ;; is used by `describe-char-fold-equivalences'.
+        (map-char-table
+         (lambda (char decomp-list)
+           (let ((re (regexp-opt (cons (char-to-string char) decomp-list))))
+             (aset equiv char re)))
+         equiv))
       equiv)))
 
 (defconst char-fold-table
@@ -421,6 +425,58 @@ BOUND NOERROR COUNT are passed to `re-search-backward'."
   (interactive "sSearch: ")
   (re-search-backward (char-fold-to-regexp string) bound noerror count))
 
+\f
+(defun describe-char-fold-equivalences (char &optional lax)
+  "Display characters equivalent to CHAR.
+Prompt for CHAR.  With no input, i.e. when CHAR is nil, by default
+describe all available character equivalences of `char-fold-to-regexp'.
+Interactively, a prefix arg means also include partially matching
+ligatures."
+  (interactive (list (ignore-errors
+                       (read-char-by-name
+                        "Character (Unicode name or hex, default all): "))
+                     current-prefix-arg))
+  (require 'help-fns)
+  (let ((help-buffer-under-preparation t))
+    (help-setup-xref (list #'describe-char-fold-equivalences)
+                     (called-interactively-p 'interactive))
+    (let* ((equivalences nil)
+           (char-fold--no-regexp t)
+           (table (char-fold--make-table))
+           (extra (char-table-extra-slot table 0)))
+      (if (not char)
+          (map-char-table
+           (lambda (char list)
+             (when lax
+               (setq list (append list (mapcar (lambda (entry)
+                                                 (cdr entry))
+                                               (aref extra char)))))
+             (setq equivalences (cons (cons char list)
+                                      equivalences)))
+           table)
+        (setq equivalences (aref table char))
+        (when lax
+          (setq equivalences (append equivalences
+                                     (mapcar (lambda (entry)
+                                               (cdr entry))
+                                             (aref extra char)))))
+        (setq equivalences (cons (char-to-string char) equivalences)))
+      (with-help-window (help-buffer)
+        (with-current-buffer standard-output
+          (if char
+              (insert (mapconcat
+                       (lambda (c)
+                         (format "%s: \?\\N{%s}\n"
+                                 c
+                                 (or (get-char-code-property (string-to-char c) 'name)
+                                     (get-char-code-property (string-to-char c) 'old-name))))
+                       equivalences))
+            (insert "A list of char-fold equivalences for `char-fold-to-regexp':\n\n")
+            (setq-local bidi-paragraph-direction 'left-to-right)
+            (dolist (equiv (nreverse equivalences))
+              (insert (format "%c: %s\n" (car equiv)
+                              (string-join (cdr equiv) " "))))))))))
+
 (provide 'char-fold)
 
 ;;; char-fold.el ends here