;;; character-fold.el --- match unicode to similar ASCII -*- lexical-binding: t; -*-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: matching
;;; Code:
+(eval-and-compile (put 'character-fold-table 'char-table-extra-slots 1))
\f
(defconst character-fold-table
(eval-when-compile
- (let* ((equiv (make-char-table 'character-fold-table))
- (table (unicode-property-table-internal 'decomposition))
- (func (char-table-extra-slot table 1)))
+ (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.
- (map-char-table
- (lambda (i v) (when (consp i) (funcall func (car i) v table)))
- table)
+ (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 (i dec)
- (when (consp dec)
- ;; Discard a possible formatting tag.
- (when (symbolp (car dec))
- (setq dec (cdr dec)))
+ (lambda (char decomp)
+ (when (consp decomp)
;; Skip trivial cases like ?a decomposing to (?a).
- (unless (or (and (eq i (car dec))
- (not (cdr dec))))
- (let ((d dec)
- (fold-decomp t)
- k found)
- (while (and d (not found))
- (setq k (pop d))
- ;; Is k a number or letter, per unicode standard?
- (setq found (memq (get-char-code-property k 'general-category)
- '(Lu Ll Lt Lm Lo Nd Nl No))))
- (if found
- ;; Check if the decomposition has more than one letter,
- ;; because then we don't want the first letter to match
- ;; the decomposition.
- (dolist (k d)
- (when (and fold-decomp
- (memq (get-char-code-property k 'general-category)
- '(Lu Ll Lt Lm Lo Nd Nl No)))
- (setq fold-decomp nil)))
- ;; If there's no number or letter on the
- ;; decomposition, take the first character in it.
- (setq found (car-safe dec)))
- ;; Finally, we only fold multi-char decomposition if at
- ;; least one of the chars is non-spacing (combining).
- (when fold-decomp
- (setq fold-decomp nil)
- (dolist (k dec)
- (when (and (not fold-decomp)
- (> (get-char-code-property k 'canonical-combining-class) 0))
- (setq fold-decomp t))))
- ;; Add i to the list of characters that k can
- ;; represent. Also possibly add its decomposition, so we can
- ;; match multi-char representations like (format "a%c" 769)
- (when (and found (not (eq i k)))
- (let ((chars (cons (char-to-string i) (aref equiv k))))
- (aset equiv k
- (if fold-decomp
- (cons (apply #'string dec) chars)
- chars))))))))
+ (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.
;; Convert the lists of characters we compiled into regexps.
(map-char-table
- (lambda (i v) (let ((re (regexp-opt (cons (char-to-string i) v))))
- (if (consp i)
- (set-char-table-range equiv i re)
- (aset equiv i re))))
+ (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.")
+ "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."
(make-list n (or (aref character-fold-table ?\s) " ")))))
;;;###autoload
-(defun character-fold-to-regexp (string &optional _lax)
+(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."
+regexp) and other characters are `regexp-quote'd.
+
+If the resulting regexp would be too long for Emacs to handle,
+just return the result of calling `regexp-quote' on STRING.
+
+FROM is for internal use. It specifies an index in the STRING
+from which to start."
(let* ((spaces 0)
- (chars (mapcar #'identity string))
- (out chars))
- ;; When the user types a space, we want to match the table entry,
- ;; but we also want the ?\s to be visible to `search-spaces-regexp'.
- ;; See commit message for a longer description.
- (while chars
- (let ((c (car chars)))
- (setcar chars
- (cond
- ((eq c ?\s)
- (setq spaces (1+ spaces))
- nil)
- ((> spaces 0)
- (prog1 (concat (character-fold--make-space-string spaces)
- (or (aref character-fold-table c)
- (regexp-quote (string c))))
- (setq spaces 0)))
- (t (or (aref character-fold-table c)
- (regexp-quote (string c))))))
- (setq chars (cdr chars))))
- (concat (apply #'concat out)
- (when (> spaces 0)
- (character-fold--make-space-string spaces)))))
+ (multi-char-table (char-table-extra-slot character-fold-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))))
+ ;; Long string. The regexp would probably be too long.
+ (alist (unless (> end 50)
+ (aref multi-char-table c))))
+ (push (let ((matched-entries nil)
+ (max-length 0))
+ (dolist (entry alist)
+ (let* ((suffix (car entry))
+ (len-suf (length suffix)))
+ (when (eq (compare-strings suffix 0 nil
+ string (1+ i) (+ i 1 len-suf)
+ nil)
+ t)
+ (push (cons len-suf (cdr entry)) matched-entries)
+ (setq max-length (max max-length len-suf)))))
+ ;; If no suffixes matched, just go on.
+ (if (not matched-entries)
+ regexp
+;;; If N suffixes match, we "branch" out into N+1 executions for the
+;;; length of the longest match. This means "fix" will match "fix" but
+;;; not "fⅸ", but it's necessary to keep the regexp size from scaling
+;;; exponentially. See https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg02562.html
+ (let ((subs (substring string (1+ i) (+ i 1 max-length))))
+ ;; `i' is still going to inc by 1 below.
+ (setq i (+ i max-length))
+ (concat
+ "\\(?:"
+ (mapconcat (lambda (entry)
+ (let ((length (car entry))
+ (suffix-regexp (cdr entry)))
+ (concat suffix-regexp
+ (character-fold-to-regexp subs nil length))))
+ `((0 . ,regexp) . ,matched-entries) "\\|")
+ "\\)"))))
+ out))))
+ (setq i (1+ i)))
+ (when (> spaces 0)
+ (push (character-fold--make-space-string spaces) out))
+ (let ((regexp (apply #'concat (nreverse out))))
+ ;; Limited by `MAX_BUF_SIZE' in `regex.c'.
+ (if (> (length regexp) 5000)
+ (regexp-quote string)
+ regexp))))
\f
;;; Commands provided for completeness.
(interactive "sSearch: ")
(re-search-backward (character-fold-to-regexp string) bound noerror count))
+(provide 'character-fold)
+
;;; character-fold.el ends here