mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
747f81861c
Warn about using long strings. * test/automated/character-fold-tests.el (character-fold--test-lax-whitespace) (character-fold--test-consistency): Reduce string size for tests.
247 lines
12 KiB
EmacsLisp
247 lines
12 KiB
EmacsLisp
;;; character-fold.el --- match unicode to similar ASCII -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||
|
||
;; Maintainer: emacs-devel@gnu.org
|
||
;; Keywords: matching
|
||
|
||
;; 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 <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Code:
|
||
|
||
(eval-and-compile (put 'character-fold-table 'char-table-extra-slots 1))
|
||
|
||
(defconst character-fold-table
|
||
(eval-when-compile
|
||
(let ((equiv (make-char-table 'character-fold-table))
|
||
(equiv-multi (make-char-table 'character-fold-table))
|
||
(table (unicode-property-table-internal 'decomposition)))
|
||
(set-char-table-extra-slot equiv 0 equiv-multi)
|
||
|
||
;; Ensure the table is populated.
|
||
(let ((func (char-table-extra-slot table 1)))
|
||
(map-char-table (lambda (char v)
|
||
(when (consp char)
|
||
(funcall func (car char) v table)))
|
||
table))
|
||
|
||
;; Compile a list of all complex characters that each simple
|
||
;; character should match.
|
||
;; In summary this loop does 3 things:
|
||
;; - A complex character might be allowed to match its decomp.
|
||
;; - The decomp is allowed to match the complex character.
|
||
;; - A single char of the decomp might be allowed to match the
|
||
;; character.
|
||
;; Some examples in the comments below.
|
||
(map-char-table
|
||
(lambda (char decomp)
|
||
(when (consp decomp)
|
||
;; Skip trivial cases like ?a decomposing to (?a).
|
||
(unless (and (not (cdr decomp))
|
||
(eq char (car decomp)))
|
||
(if (symbolp (car decomp))
|
||
;; Discard a possible formatting tag.
|
||
(setq decomp (cdr decomp))
|
||
;; If there's no formatting tag, ensure that char matches
|
||
;; its decomp exactly. This is because we want 'ä' to
|
||
;; match 'ä', but we don't want '¹' to match '1'.
|
||
(aset equiv char
|
||
(cons (apply #'string decomp)
|
||
(aref equiv char))))
|
||
|
||
;; Allow the entire decomp to match char. If decomp has
|
||
;; multiple characters, this is done by adding an entry
|
||
;; to the alist of the first character in decomp. This
|
||
;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to
|
||
;; match '¹'.
|
||
(let ((make-decomp-match-char
|
||
(lambda (decomp char)
|
||
(if (cdr decomp)
|
||
(aset equiv-multi (car decomp)
|
||
(cons (cons (apply #'string (cdr decomp))
|
||
(regexp-quote (string char)))
|
||
(aref equiv-multi (car decomp))))
|
||
(aset equiv (car decomp)
|
||
(cons (char-to-string char)
|
||
(aref equiv (car decomp))))))))
|
||
(funcall make-decomp-match-char decomp char)
|
||
;; Do it again, without the non-spacing characters.
|
||
;; This allows 'a' to match 'ä'.
|
||
(let ((simpler-decomp nil)
|
||
(found-one nil))
|
||
(dolist (c decomp)
|
||
(if (> (get-char-code-property c 'canonical-combining-class) 0)
|
||
(setq found-one t)
|
||
(push c simpler-decomp)))
|
||
(when (and simpler-decomp found-one)
|
||
(funcall make-decomp-match-char simpler-decomp char)
|
||
;; Finally, if the decomp only had one spacing
|
||
;; character, we allow this character to match the
|
||
;; decomp. This is to let 'a' match 'ä'.
|
||
(unless (cdr simpler-decomp)
|
||
(aset equiv (car simpler-decomp)
|
||
(cons (apply #'string decomp)
|
||
(aref equiv (car simpler-decomp)))))))))))
|
||
table)
|
||
|
||
;; Add some manual entries.
|
||
(dolist (it '((?\" "＂" "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»")
|
||
(?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "" "❮" "❯" "‹" "›")
|
||
(?` "❛" "‘" "‛" "" "❮" "‹")))
|
||
(let ((idx (car it))
|
||
(chars (cdr it)))
|
||
(aset equiv idx (append chars (aref equiv idx)))))
|
||
|
||
;; Convert the lists of characters we compiled into regexps.
|
||
(map-char-table
|
||
(lambda (char dec-list)
|
||
(let ((re (regexp-opt (cons (char-to-string char) dec-list))))
|
||
(if (consp char)
|
||
(set-char-table-range equiv char re)
|
||
(aset equiv char re))))
|
||
equiv)
|
||
equiv))
|
||
"Used for folding characters of the same group during search.
|
||
This is a char-table with the `character-fold-table' subtype.
|
||
|
||
Let us refer to the character in question by char-x.
|
||
Each entry is either nil (meaning char-x only matches literally)
|
||
or a regexp. This regexp should match anything that char-x can
|
||
match by itself \(including char-x). For instance, the default
|
||
regexp for the ?+ character is \"[+⁺₊﬩﹢＋]\".
|
||
|
||
This table also has one extra slot which is also a char-table.
|
||
Each entry in the extra slot is an alist used for multi-character
|
||
matching (which may be nil). The elements of the alist should
|
||
have the form (SUFFIX . OTHER-REGEXP). If the characters after
|
||
char-x are equal to SUFFIX, then this combination of char-x +
|
||
SUFFIX is allowed to match OTHER-REGEXP. This is in addition to
|
||
char-x being allowed to match REGEXP.
|
||
For instance, the default alist for ?f includes:
|
||
\((\"fl\" . \"ffl\") (\"fi\" . \"ffi\")
|
||
(\"i\" . \"fi\") (\"f\" . \"ff\"))
|
||
|
||
Exceptionally for the space character (32), ALIST is ignored.")
|
||
|
||
(defun character-fold--make-space-string (n)
|
||
"Return a string that matches N spaces."
|
||
(format "\\(?:%s\\|%s\\)"
|
||
(make-string n ?\s)
|
||
(apply #'concat
|
||
(make-list n (or (aref character-fold-table ?\s) " ")))))
|
||
|
||
;;;###autoload
|
||
(defun character-fold-to-regexp (string &optional _lax from)
|
||
"Return a regexp matching anything that character-folds into STRING.
|
||
Any character in STRING that has an entry in
|
||
`character-fold-table' is replaced with that entry (which is a
|
||
regexp) and other characters are `regexp-quote'd.
|
||
|
||
Note that this function can potentially return regexps too long
|
||
for Emacs to handle. If STRING is longer than 30 characters,
|
||
consider not using this function.
|
||
|
||
FROM is for internal use. It specifies an index in the STRING
|
||
from which to start."
|
||
(let* ((spaces 0)
|
||
(multi-char-table (char-table-extra-slot character-fold-table 0))
|
||
(lower-case-table (current-case-table))
|
||
(upper-case-table (char-table-extra-slot lower-case-table 0))
|
||
(i (or from 0))
|
||
(end (length string))
|
||
(out nil))
|
||
;; When the user types a space, we want to match the table entry
|
||
;; for ?\s, which is generally a regexp like "[ ...]". However,
|
||
;; the `search-spaces-regexp' variable doesn't "see" spaces inside
|
||
;; these regexp constructs, so we need to use "\\( \\|[ ...]\\)"
|
||
;; instead (to manually expose a space). Furthermore, the lax
|
||
;; search engine acts on a bunch of spaces, not on individual
|
||
;; spaces, so if the string contains sequential spaces like " ", we
|
||
;; need to keep them grouped together like this: "\\( \\|[ ...][ ...]\\)".
|
||
(while (< i end)
|
||
(pcase (aref string i)
|
||
(`?\s (setq spaces (1+ spaces)))
|
||
(c (when (> spaces 0)
|
||
(push (character-fold--make-space-string spaces) out)
|
||
(setq spaces 0))
|
||
(let ((regexp (or (aref character-fold-table c)
|
||
(regexp-quote (string c))))
|
||
(alist nil))
|
||
;; Long string. The regexp would probably be too long.
|
||
(unless (> end 50)
|
||
(setq alist (aref multi-char-table c))
|
||
(when case-fold-search
|
||
(let ((other-c (aref lower-case-table c)))
|
||
(when (or (not other-c)
|
||
(eq other-c c))
|
||
(setq other-c (aref upper-case-table c)))
|
||
(when other-c
|
||
(setq alist (append alist (aref multi-char-table other-c)))
|
||
(setq regexp (concat "\\(?:" regexp "\\|"
|
||
(or (aref character-fold-table other-c)
|
||
(regexp-quote (string other-c)))
|
||
"\\)"))))))
|
||
(push (let ((alist-out '("\\)")))
|
||
(pcase-dolist (`(,suffix . ,out-regexp) alist)
|
||
(let ((len-suf (length suffix)))
|
||
(when (eq (compare-strings suffix 0 nil
|
||
string (1+ i) (+ i 1 len-suf)
|
||
nil)
|
||
t)
|
||
;; FIXME: If N suffixes match, we "branch"
|
||
;; out into N+1 executions for the rest of
|
||
;; the string. This involves redundant
|
||
;; work and makes a huge regexp.
|
||
(push (concat "\\|" out-regexp
|
||
(character-fold-to-regexp
|
||
string nil (+ i 1 len-suf)))
|
||
alist-out))))
|
||
;; If no suffixes matched, just go on.
|
||
(if (not (cdr alist-out))
|
||
regexp
|
||
;; Otherwise, add a branch for the
|
||
;; no-suffix case, and stop the loop here.
|
||
(prog1 (apply #'concat "\\(?:" regexp
|
||
(character-fold-to-regexp string nil (1+ i))
|
||
alist-out)
|
||
(setq i end))))
|
||
out))))
|
||
(setq i (1+ i)))
|
||
(when (> spaces 0)
|
||
(push (character-fold--make-space-string spaces) out))
|
||
(apply #'concat (nreverse out))))
|
||
|
||
|
||
;;; Commands provided for completeness.
|
||
(defun character-fold-search-forward (string &optional bound noerror count)
|
||
"Search forward for a character-folded version of STRING.
|
||
STRING is converted to a regexp with `character-fold-to-regexp',
|
||
which is searched for with `re-search-forward'.
|
||
BOUND NOERROR COUNT are passed to `re-search-forward'."
|
||
(interactive "sSearch: ")
|
||
(re-search-forward (character-fold-to-regexp string) bound noerror count))
|
||
|
||
(defun character-fold-search-backward (string &optional bound noerror count)
|
||
"Search backward for a character-folded version of STRING.
|
||
STRING is converted to a regexp with `character-fold-to-regexp',
|
||
which is searched for with `re-search-backward'.
|
||
BOUND NOERROR COUNT are passed to `re-search-backward'."
|
||
(interactive "sSearch: ")
|
||
(re-search-backward (character-fold-to-regexp string) bound noerror count))
|
||
|
||
(provide 'character-fold)
|
||
|
||
;;; character-fold.el ends here
|