Commit 5c599700 authored by Artur Malabarba's avatar Artur Malabarba

* lisp/character-fold.el: Add support for multi-char matches

(character-fold-table): Now has an extra-slot. This is a second
char-table that holds multi-character matches.  See docstring for
details.
(character-fold-to-regexp): Can build branching regexps when a
character's entry the extra slot of `character-fold-table' matches the
characters that succeed it.
parent 35c7dc06
......@@ -22,11 +22,15 @@
;;; 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)
......@@ -36,63 +40,61 @@
;; 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)
(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))))
;; Finally, figure out whether char has a simpler
;; equivalent (char-aux). If so, ensure that char-aux
;; matches char and maybe its decomp too.
;; Skip trivial cases like ?a decomposing to (?a).
(unless (or (and (eq char (car decomp))
(not (cdr decomp))))
(let ((dec-aux decomp)
(fold-decomp t)
char-aux found)
(while (and dec-aux (not found))
(setq char-aux (pop dec-aux))
;; Is char-aux a number or letter, per unicode standard?
(setq found (memq (get-char-code-property char-aux 'general-category)
'(Lu Ll Lt Lm Lo Nd Nl No))))
(if found
;; Check if the decomp has more than one letter,
;; because then we don't want the first letter to
;; match the decomposition. This is because we
;; want 'f' to match 'ff' but not 'ff'.
(dolist (char-aux dec-aux)
(when (and fold-decomp
(memq (get-char-code-property char-aux 'general-category)
'(Lu Ll Lt Lm Lo Nd Nl No)))
(setq fold-decomp nil)))
;; If there's no number or letter on the
;; decomp, take the first character in it.
(setq found (car-safe decomp)))
;; Finally, we only fold multi-char decomp if at
;; least one of the chars is non-spacing (combining).
(when fold-decomp
(setq fold-decomp nil)
(dolist (char-aux decomp)
(when (and (not fold-decomp)
(> (get-char-code-property char-aux 'canonical-combining-class) 0))
(setq fold-decomp t))))
;; Add char to the list of characters that char-aux can
;; represent. Also possibly add its decomp, so we can
;; match multi-char representations like (format "a%c" 769)
(when (and found (not (eq char char-aux)))
(let ((chars (cons (char-to-string char) (aref equiv char-aux))))
(aset equiv char-aux
(if fold-decomp
(cons (apply #'string decomp) 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.
......@@ -112,7 +114,27 @@
(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."
......@@ -122,13 +144,17 @@
(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.
FROM is for internal use. It specifies an index in the STRING
from which to start."
(let ((spaces 0)
(i 0)
(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
......@@ -145,9 +171,36 @@ regexp) and other characters are `regexp-quote'd."
(c (when (> spaces 0)
(push (character-fold--make-space-string spaces) out)
(setq spaces 0))
(push (or (aref character-fold-table c)
(regexp-quote (string c)))
out)))
(let ((regexp (or (aref character-fold-table c)
(regexp-quote (string c))))
;; Long string. The regexp would probably be too long.
(alist (unless (> end 60)
(aref multi-char-table 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))
......
......@@ -43,7 +43,7 @@
(character-fold--test-search-with-contents w w))))
(ert-deftest character-fold--test-lax-whitespace ()
(dotimes (n 100)
(dotimes (n 50)
(let ((w1 (character-fold--random-word n))
(w2 (character-fold--random-word n))
(search-spaces-regexp "\\s-+"))
......@@ -52,17 +52,44 @@
(concat w1 " " w2))
(character-fold--test-search-with-contents
(concat w1 "\s\n\s\t\f\t\n\r\t" w2)
(concat w1 (make-string 90 ?\s) w2)))))
(concat w1 (make-string 10 ?\s) w2)))))
(defun character-fold--test-match-exactly (string &rest strings-to-match)
(let ((re (concat "\\`" (character-fold-to-regexp string) "\\'")))
(dolist (it strings-to-match)
(should (string-match re it)))))
(ert-deftest character-fold--test-some-defaults ()
(dolist (it '(("ffl" . "ffl") ("ffi" . "ffi")
("fi" . "fi") ("ff" . "ff")
("ä" . "ä")))
(character-fold--test-search-with-contents (cdr it) (car it))
(let ((multi (char-table-extra-slot character-fold-table 0))
(character-fold-table (make-char-table 'character-fold-table)))
(set-char-table-extra-slot character-fold-table 0 multi)
(character-fold--test-match-exactly (car it) (cdr it)))))
(ert-deftest character-fold--test-fold-to-regexp ()
(let ((character-fold-table (make-char-table 'character-fold-table)))
(aset character-fold-table ?a "abc")
(aset character-fold-table ?1 "123")
(let ((character-fold-table (make-char-table 'character-fold-table))
(multi (make-char-table 'character-fold-table)))
(set-char-table-extra-slot character-fold-table 0 multi)
(aset character-fold-table ?a "xx")
(aset character-fold-table ?1 "44")
(aset character-fold-table ?\s "-!-")
(should (equal (character-fold-to-regexp "a1a1")
"abc123abc123"))
(should (equal (character-fold-to-regexp "a1 a 1")
"abc123\\(?: \\|-!--!-\\)abc\\(?: \\|-!-\\)123"))))
(character-fold--test-match-exactly "a1a1" "xx44xx44")
(character-fold--test-match-exactly "a1 a 1" "xx44-!--!-xx-!-44")
(aset multi ?a '(("1" . "99")
("2" . "88")
("12" . "77")))
(character-fold--test-match-exactly "a" "xx")
(character-fold--test-match-exactly "a1" "xx44" "99")
(character-fold--test-match-exactly "a12" "77" "xx442" "992")
(character-fold--test-match-exactly "a2" "88")
(aset multi ?1 '(("2" . "yy")))
(character-fold--test-match-exactly "a1" "xx44" "99")
(character-fold--test-match-exactly "a12" "77" "xx442" "992")
(character-fold--test-match-exactly "a12" "xxyy")))
(provide 'character-fold-tests)
;;; character-fold-tests.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment