[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master de6c1c4d5c9: rx: Better translation of char-matching patterns
|
From: |
Mattias Engdegård |
|
Subject: |
master de6c1c4d5c9: rx: Better translation of char-matching patterns |
|
Date: |
Sat, 12 Aug 2023 11:41:46 -0400 (EDT) |
branch: master
commit de6c1c4d5c92b92d5b280e157c2a5bc3228749f2
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>
rx: Better translation of char-matching patterns
Translate or-patterns that (even partially) match single characters
into character alternatives which are more efficient in matching,
sometimes algorithmically so. Example:
(or "%" (in "a-z") space)
was previously translated to
"%\\|[a-z]\\|[[:space:]]"
but now becomes
"[%a-z[:space:]]"
Single-char patterns include `nonl` and `anychar`, which now can also
be used in set operations (union, complement and intersection), and
character classes. For example, `(or nonl "\n")` is now equivalent to
`anychar`.
* lisp/emacs-lisp/rx.el (rx--expand-def): Remove, split into...
(rx--expand-def-form, rx--expand-def-symbol): ...these.
(rx--translate-compat-symbol-entry)
(rx--translate-compat-form-entry): New functions for handling the
legacy extension mechanism.
(rx--normalise-or-arg): Renamed to...
(rx--normalise-char-pattern): ...this, and rewrite.
(rx--all-string-or-args): Remove, split into...
(rx--all-string-branches-p, rx--collect-or-strings): ...these.
(rx--char-alt-union, rx--intersection-intervals)
(rx--reduce-to-char-alt, rx--optimise-or-args)
(rx--translate-char-alt, rx--human-readable): New.
(rx--translate-or, rx--translate-not, rx--translate-intersection):
Rewrite.
(rx--charset-p, rx--intervals-to-alt, rx--charset-intervals)
(rx--charset-union, rx--charset-intersection, rx--charset-all)
(rx--translate-union): Remove.
(rx--generate-alt): Decide whether to generate a negated character
alternative.
(rx--complement-intervals, rx--intersect-intervals)
(rx--union-intervals): Rename to...
(rx--interval-set-complement, rx--interval-set-intersection)
(rx--interval-set-union): ...these.
(rx--translate-symbol, rx--translate-form): Refactor extension
processing. Handle synthetic `rx--char-alt` form.
* test/lisp/emacs-lisp/rx-tests.el (rx-or, rx-char-any-raw-byte)
(rx-any, rx-charset-or): Adapt to changes and extend.
* test/lisp/emacs-lisp/rx-tests.el (rx--complement-intervals)
(rx--union-intervals, rx--intersect-intervals): Rename to...
(rx--interval-set-complement, rx--interval-set-union)
(rx--interval-set-intersection): ...these.
---
lisp/emacs-lisp/rx.el | 562 +++++++++++++++++++++++++--------------
test/lisp/emacs-lisp/rx-tests.el | 94 ++++---
2 files changed, 417 insertions(+), 239 deletions(-)
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index d46d0ca5a98..aa1174ea08b 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -161,27 +161,23 @@ Each entry is:
(or (cdr (assq name rx--local-definitions))
(get name 'rx-definition)))
-(defun rx--expand-def (form)
- "FORM expanded (once) if a user-defined construct; otherwise nil."
- (cond ((symbolp form)
- (let ((def (rx--lookup-def form)))
- (and def
- (if (cdr def)
- (error "Not an `rx' symbol definition: %s" form)
- (car def)))))
- ((and (consp form) (symbolp (car form)))
- (let* ((op (car form))
- (def (rx--lookup-def op)))
+(defun rx--expand-def-form (form)
+ "List FORM expanded (once) if a user-defined construct; otherwise nil."
+ (let ((op (car form)))
+ (and (symbolp op)
+ (let ((def (rx--lookup-def op)))
(and def
(if (cdr def)
- (rx--expand-template
- op (cdr form) (nth 0 def) (nth 1 def))
+ (rx--expand-template op (cdr form) (nth 0 def) (nth 1 def))
(error "Not an `rx' form definition: %s" op)))))))
-;; TODO: Additions to consider:
-;; - A construct like `or' but without the match order guarantee,
-;; maybe `unordered-or'. Useful for composition or generation of
-;; alternatives; permits more effective use of regexp-opt.
+(defun rx--expand-def-symbol (symbol)
+ "SYM expanded (once) if a user-defined name; otherwise nil."
+ (let ((def (rx--lookup-def symbol)))
+ (and def
+ (if (cdr def)
+ (error "Not an `rx' symbol definition: %s" symbol)
+ (car def)))))
(defun rx--translate-symbol (sym)
"Translate an rx symbol. Return (REGEXP . PRECEDENCE)."
@@ -208,22 +204,13 @@ Each entry is:
((let ((class (cdr (assq sym rx--char-classes))))
(and class (cons (list (concat "[[:" (symbol-name class) ":]]")) t))))
- ((let ((expanded (rx--expand-def sym)))
+ ((let ((expanded (rx--expand-def-symbol sym)))
(and expanded (rx--translate expanded))))
;; For compatibility with old rx.
((let ((entry (assq sym rx-constituents)))
- (and (progn
- (while (and entry (not (stringp (cdr entry))))
- (setq entry
- (if (symbolp (cdr entry))
- ;; Alias for another entry.
- (assq (cdr entry) rx-constituents)
- ;; Wrong type, try further down the list.
- (assq (car entry)
- (cdr (memq entry rx-constituents))))))
- entry)
- (cons (list (cdr entry)) nil))))
+ (and entry (rx--translate-compat-symbol-entry entry))))
+
(t (error "Unknown rx symbol `%s'" sym))))))
(defun rx--enclose (left-str rexp right-str)
@@ -289,83 +276,225 @@ Left-fold the list L, starting with X, by the binary
function F."
(setq l (cdr l)))
x)
-(defun rx--normalise-or-arg (form)
- "Normalize the `or' argument FORM.
-Characters become strings, user-definitions and `eval' forms are expanded,
-and `or' forms are normalized recursively."
- (cond ((characterp form)
+;; FIXME: flatten nested `or' patterns when performing char-pattern combining.
+;; The only reason for not flattening is to ensure regexp-opt processing
+;; (which we do for entire `or' patterns, not subsequences), but we
+;; obviously want to translate
+;; (or "a" space (or "b" (+ nonl) word) "c")
+;; -> (or (in "ab" space) (+ nonl) (in "c" word))
+
+;; FIXME: normalise `seq', both the construct and implicit sequences,
+;; so that they are flattened, adjacent strings concatenated, and
+;; empty strings removed. That would give more opportunities for regexp-opt:
+;; (or "a" (seq "ab" (seq "c" "d") "")) -> (or "a" "abcd")
+
+;; FIXME: Since `rx--normalise-char-pattern' recurses through `or', `not' and
+;; `intersection', we may end up normalising subtrees multiple times
+;; which wastes time (but should be idempotent).
+;; One way to avoid this is to aggressively normalise the entire tree
+;; before translating anything at all, but we must then recurse through
+;; all constructs and probably copy them.
+;; Such normalisation could normalise synonyms, eliminate `minimal-match'
+;; and `maximal-match' and convert affected `1+' to either `+' or `+?' etc.
+;; We would also consolidate the user-def lookup, both modern and legacy,
+;; in one place.
+
+(defun rx--normalise-char-pattern (form)
+ "Normalize FORM as a pattern matching a single-character.
+Characters become strings, `any' forms and character classes become
+`rx--char-alt' forms, user-definitions and `eval' forms are expanded,
+and `or', `not' and `intersection' forms are normalized recursively.
+
+A `rx--char-alt' form is shaped (rx--char-alt INTERVALS . CLASSES)
+where INTERVALS is a sorted list of disjoint nonadjacent intervals,
+each a cons of characters, and CLASSES an unordered list of unique
+name-normalised character classes."
+ (defvar rx--builtin-forms)
+ (defvar rx--builtin-symbols)
+ (cond ((consp form)
+ (let ((op (car form))
+ (body (cdr form)))
+ (cond ((memq op '(or |))
+ ;; Normalise the constructor to `or' and the args
recursively.
+ (cons 'or (mapcar #'rx--normalise-char-pattern body)))
+ ;; Convert `any' forms and char classes now so that we
+ ;; don't need to do it later on.
+ ((memq op '(any in char))
+ (cons 'rx--char-alt (rx--parse-any body)))
+ ((memq op '(not intersection))
+ (cons op (mapcar #'rx--normalise-char-pattern body)))
+ ((eq op 'eval)
+ (rx--normalise-char-pattern (rx--expand-eval body)))
+ ((memq op rx--builtin-forms) form)
+ ((let ((expanded (rx--expand-def-form form)))
+ (and expanded
+ (rx--normalise-char-pattern expanded))))
+ (t form))))
+ ;; FIXME: Should we expand legacy definitions from
+ ;; `rx-constituents' here as well?
+ ((symbolp form)
+ (cond ((let ((class (assq form rx--char-classes)))
+ (and class
+ `(rx--char-alt nil . (,(cdr class))))))
+ ((memq form rx--builtin-symbols) form)
+ ((let ((expanded (rx--expand-def-symbol form)))
+ (and expanded
+ (rx--normalise-char-pattern expanded))))
+ (t form)))
+ ((characterp form)
(char-to-string form))
- ((and (consp form) (memq (car form) '(or |)))
- (cons (car form) (mapcar #'rx--normalise-or-arg (cdr form))))
- ((and (consp form) (eq (car form) 'eval))
- (rx--normalise-or-arg (rx--expand-eval (cdr form))))
- (t
- (let ((expanded (rx--expand-def form)))
- (if expanded
- (rx--normalise-or-arg expanded)
- form)))))
-
-(defun rx--all-string-or-args (body)
- "If BODY only consists of strings or such `or' forms, return all the strings.
-Otherwise throw `rx--nonstring'."
+ (t form)))
+
+(defun rx--char-alt-union (a b)
+ "Union of the (INTERVALS . CLASSES) pairs A and B."
+ (let* ((a-cl (cdr a))
+ (b-cl (cdr b))
+ (classes (if (and a-cl b-cl)
+ (let ((acc a-cl))
+ (dolist (c b-cl)
+ (unless (memq c a-cl)
+ (push c acc)))
+ acc)
+ (or a-cl b-cl))))
+ (cons (rx--interval-set-union (car a) (car b)) classes)))
+
+(defun rx--intersection-intervals (forms)
+ "Intersection of the normalised FORMS, as an interval set."
+ (rx--foldl #'rx--interval-set-intersection '((0 . #x3fffff))
+ (mapcar (lambda (x)
+ (let ((char (rx--reduce-to-char-alt x)))
+ (if (and char (null (cdr char)))
+ (car char)
+ (error "Cannot be used in rx intersection: %S"
+ (rx--human-readable x)))))
+ forms)))
+
+(defun rx--reduce-to-char-alt (form)
+ "Transform FORM into (INTERVALS . CLASSES) or nil if not possible.
+Process `or', `intersection' and `not'.
+FORM must be normalised (from `rx--normalise-char-pattern')."
+ (cond
+ ((stringp form)
+ (and (= (length form) 1)
+ (let ((c (aref form 0)))
+ (list (list (cons c c))))))
+ ((consp form)
+ (let ((head (car form)))
+ (cond
+ ;; FIXME: Transform `digit', `xdigit', `cntrl', `ascii', `nonascii'
+ ;; to ranges? That would allow them to be negated and intersected.
+ ((eq head 'rx--char-alt) (cdr form))
+ ((eq head 'not)
+ (unless (= (length form) 2)
+ (error "rx `not' form takes exactly one argument"))
+ (let ((arg (rx--reduce-to-char-alt (cadr form))))
+ ;; Only interval sets without classes are closed under complement.
+ (and arg (null (cdr arg))
+ (list (rx--interval-set-complement (car arg))))))
+ ((eq head 'or)
+ (let ((args (cdr form)))
+ (let ((acc '(nil))) ; union identity
+ (while (and args
+ (let ((char (rx--reduce-to-char-alt (car args))))
+ (setq acc (and char (rx--char-alt-union acc char)))))
+ (setq args (cdr args)))
+ acc)))
+ ((eq head 'intersection)
+ (list (rx--intersection-intervals (cdr form))))
+ )))
+ ((memq form '(nonl not-newline any))
+ '(((0 . 9) (11 . #x3fffff))))
+ ((memq form '(anychar anything))
+ '(((0 . #x3fffff))))
+ ;; FIXME: A better handling of `unmatchable' would be:
+ ;; * (seq ... unmatchable ...) -> unmatchable
+ ;; * any or-pattern branch that is `unmatchable' is deleted
+ ;; * (REPEAT unmatchable) -> "", if REPEAT accepts 0 repetitions
+ ;; * (REPEAT unmatchable) -> unmatchable, otherwise
+ ;; if it's worth the trouble (probably not).
+ ((eq form 'unmatchable)
+ '(nil))
+ ))
+
+(defun rx--optimise-or-args (args)
+ "Optimise `or' arguments. Return a new rx form.
+Each element of ARGS should have been normalised using
+`rx--normalise-char-pattern'."
+ (if (null args)
+ ;; No arguments.
+ '(rx--char-alt nil . nil) ; FIXME: not `unmatchable'?
+ ;; Join consecutive single-char branches into a char alt where possible.
+ ;; Ideally we should collect all single-char branches but that might
+ ;; alter matching order in some cases.
+ (let ((branches nil)
+ (prev-char nil))
+ (while args
+ (let* ((item (car args))
+ (item-char (rx--reduce-to-char-alt item)))
+ (if item-char
+ (setq prev-char (if prev-char
+ (rx--char-alt-union prev-char item-char)
+ item-char))
+ (when prev-char
+ (push (cons 'rx--char-alt prev-char) branches)
+ (setq prev-char nil))
+ (push item branches)))
+ (setq args (cdr args)))
+ (when prev-char
+ (push (cons 'rx--char-alt prev-char) branches))
+ (if (cdr branches)
+ (cons 'or (nreverse branches))
+ (car branches)))))
+
+(defun rx--all-string-branches-p (forms)
+ "Whether FORMS are all strings or `or' forms with the same property."
+ (rx--every (lambda (x) (or (stringp x)
+ (and (eq (car-safe x) 'or)
+ (rx--all-string-branches-p (cdr x)))))
+ forms))
+
+(defun rx--collect-or-strings (forms)
+ "All strings from FORMS, which are strings or `or' forms."
(mapcan (lambda (form)
- (cond ((stringp form) (list form))
- ((and (consp form) (memq (car form) '(or |)))
- (rx--all-string-or-args (cdr form)))
- (t (throw 'rx--nonstring nil))))
- body))
+ (if (stringp form)
+ (list form)
+ ;; must be an `or' form
+ (rx--collect-or-strings (cdr form))))
+ forms))
+
+;; TODO: Write a more general rx-level factoriser to replace
+;; `regexp-opt' for our purposes. It would handle non-literals:
+;;
+;; (or "ab" (: "a" space) "bc" (: "b" (+ digit)))
+;; -> (or (: "a" (in "b" space)) (: "b" (or "c" (+ digit))))
+;;
+;; As a minor side benefit we would get less useless bracketing.
+;; The main problem is how to deal with matching order, which `regexp-opt'
+;; alters in its own way.
(defun rx--translate-or (body)
"Translate an or-pattern of zero or more rx items.
Return (REGEXP . PRECEDENCE)."
- ;; FIXME: Possible improvements:
- ;;
- ;; - Flatten sub-patterns first: (or (or A B) (or C D)) -> (or A B C D)
- ;; Then call regexp-opt on runs of string arguments. Example:
- ;; (or (+ digit) "CHARLIE" "CHAN" (+ blank))
- ;; -> (or (+ digit) (or "CHARLIE" "CHAN") (+ blank))
- ;;
- ;; - Optimize single-character alternatives better:
- ;; * classes: space, alpha, ...
- ;; * (syntax S), for some S (whitespace, word)
- ;; so that (or "@" "%" digit (any "A-Z" space) (syntax word))
- ;; -> (any "@" "%" digit "A-Z" space word)
- ;; -> "[A-Z@%[:digit:][:space:][:word:]]"
(cond
((null body) ; No items: a never-matching regexp.
(rx--empty))
((null (cdr body)) ; Single item.
(rx--translate (car body)))
(t
- (let* ((args (mapcar #'rx--normalise-or-arg body))
- (all-strings (catch 'rx--nonstring (rx--all-string-or-args args))))
- (cond
- (all-strings ; Only strings.
- (cons (list (regexp-opt all-strings nil))
- t))
- ((rx--every #'rx--charset-p args) ; All charsets.
- (rx--translate-union nil args))
- (t
- (cons (append (car (rx--translate (car args)))
- (mapcan (lambda (item)
- (cons "\\|" (car (rx--translate item))))
- (cdr args)))
- nil)))))))
-
-(defun rx--charset-p (form)
- "Whether FORM looks like a charset, only consisting of character intervals
-and set operations."
- (or (and (consp form)
- (or (and (memq (car form) '(any in char))
- (rx--every (lambda (x) (not (symbolp x))) (cdr form)))
- (and (memq (car form) '(not or | intersection))
- (rx--every #'rx--charset-p (cdr form)))))
- (characterp form)
- (and (stringp form) (= (length form) 1))
- (and (or (symbolp form) (consp form))
- (let ((expanded (rx--expand-def form)))
- (and expanded
- (rx--charset-p expanded))))))
+ (let ((args (mapcar #'rx--normalise-char-pattern body)))
+ (if (rx--all-string-branches-p args)
+ ;; All branches are strings: use `regexp-opt'.
+ (cons (list (regexp-opt (rx--collect-or-strings args) nil))
+ t)
+ (let ((form (rx--optimise-or-args args)))
+ (if (eq (car-safe form) 'or)
+ (let ((branches (cdr form)))
+ (cons (append (car (rx--translate (car branches)))
+ (mapcan (lambda (item)
+ (cons "\\|" (car (rx--translate
item))))
+ (cdr branches)))
+ nil))
+ (rx--translate form))))))))
(defun rx--string-to-intervals (str)
"Decode STR as intervals: A-Z becomes (?A . ?Z), and the single
@@ -420,7 +549,7 @@ INTERVALS is a list of (START . END) with START ≤ END,
sorted by START."
(defun rx--parse-any (body)
"Parse arguments of an (any ...) construct.
Return (INTERVALS . CLASSES), where INTERVALS is a sorted list of
-disjoint intervals (each a cons of chars), and CLASSES
+disjoint nonadjacent intervals (each a cons of chars), and CLASSES
a list of named character classes in the order they occur in BODY."
(let ((classes nil)
(strings nil)
@@ -447,7 +576,7 @@ a list of named character classes in the order they occur
in BODY."
(sort (append conses
(mapcan #'rx--string-to-intervals strings))
#'car-less-than-car))
- (reverse classes))))
+ (nreverse classes))))
(defun rx--generate-alt (negated intervals classes)
"Generate a character alternative. Return (REGEXP . PRECEDENCE).
@@ -456,6 +585,19 @@ list of disjoint intervals and CLASSES a list of named
character
classes."
;; No, this is not pretty code. You try doing it in a way that is both
;; elegant and efficient. Or just one of the two. I dare you.
+
+ ;; Detect whether the interval set is better described in
+ ;; complemented form. This is not just a matter of aesthetics: any
+ ;; range that straddles the char-raw boundary will be mutilated by the
+ ;; regexp engine. Ranges from ASCII to raw bytes will exclude the
+ ;; all non-ASCII non-raw bytes, and ranges from non-ASCII Unicode
+ ;; to raw bytes are ignored.
+ (unless (or classes
+ ;; Any interval set covering #x3fff7f should be negated.
+ (rx--every (lambda (iv) (not (<= (car iv) #x3fff7f (cdr iv))))
+ intervals))
+ (setq negated (not negated))
+ (setq intervals (rx--interval-set-complement intervals)))
(cond
;; Single character.
((and intervals (eq (caar intervals) (cdar intervals))
@@ -547,28 +689,18 @@ classes."
"]"))
t)))))
+(defun rx--translate-char-alt (negated body)
+ "Translate a (rx--char-alt ...) construct. Return (REGEXP . PRECEDENCE).
+If NEGATED, negate the sense."
+ (rx--generate-alt negated (car body) (cdr body)))
+
(defun rx--translate-any (negated body)
"Translate an (any ...) construct. Return (REGEXP . PRECEDENCE).
If NEGATED, negate the sense."
(let ((parsed (rx--parse-any body)))
(rx--generate-alt negated (car parsed) (cdr parsed))))
-(defun rx--intervals-to-alt (negated intervals)
- "Generate a character alternative from an interval set.
-Return (REGEXP . PRECEDENCE).
-INTERVALS is a sorted list of disjoint intervals.
-If NEGATED, negate the sense."
- ;; Detect whether the interval set is better described in
- ;; complemented form. This is not just a matter of aesthetics: any
- ;; range from ASCII to raw bytes will automatically exclude the
- ;; entire non-ASCII Unicode range by the regexp engine.
- (if (rx--every (lambda (iv) (not (<= (car iv) #x3ffeff (cdr iv))))
- intervals)
- (rx--generate-alt negated intervals nil)
- (rx--generate-alt
- (not negated) (rx--complement-intervals intervals) nil)))
-
-;; FIXME: Consider turning `not' into a variadic operator, following SRE:
+;; TODO: Consider turning `not' into a variadic operator, following SRE:
;; (not A B) = (not (or A B)) = (intersection (not A) (not B)), and
;; (not) = anychar.
;; Maybe allow singleton characters as arguments.
@@ -578,43 +710,27 @@ If NEGATED, negate the sense."
If NEGATED, negate the sense (thus making it positive)."
(unless (and body (null (cdr body)))
(error "rx `not' form takes exactly one argument"))
- (let ((arg (car body)))
- (cond
- ((and (consp arg)
- (pcase (car arg)
- ((or 'any 'in 'char)
- (rx--translate-any (not negated) (cdr arg)))
- ('syntax
- (rx--translate-syntax (not negated) (cdr arg)))
- ('category
- (rx--translate-category (not negated) (cdr arg)))
- ('not
- (rx--translate-not (not negated) (cdr arg)))
- ((or 'or '|)
- (rx--translate-union (not negated) (cdr arg)))
- ('intersection
- (rx--translate-intersection (not negated) (cdr arg))))))
- ((let ((class (cdr (assq arg rx--char-classes))))
- (and class
- (rx--generate-alt (not negated) nil (list class)))))
- ((eq arg 'word-boundary)
- (rx--translate-symbol
- (if negated 'word-boundary 'not-word-boundary)))
- ((characterp arg)
- (rx--generate-alt (not negated) (list (cons arg arg)) nil))
- ((and (stringp arg) (= (length arg) 1))
- (let ((char (string-to-char arg)))
- (rx--generate-alt (not negated) (list (cons char char)) nil)))
- ((let ((expanded (rx--expand-def arg)))
- (and expanded
- (rx--translate-not negated (list expanded)))))
- (t (error "Illegal argument to rx `not': %S" arg)))))
-
-(defun rx--complement-intervals (intervals)
- "Complement of the interval list INTERVALS."
+ (let ((arg (rx--normalise-char-pattern (car body))))
+ (pcase arg
+ (`(not . ,args)
+ (rx--translate-not (not negated) args))
+ (`(syntax . ,args)
+ (rx--translate-syntax (not negated) args))
+ (`(category . ,args)
+ (rx--translate-category (not negated) args))
+ ('word-boundary ; legacy syntax
+ (rx--translate-symbol (if negated 'word-boundary 'not-word-boundary)))
+ (_ (let ((char (rx--reduce-to-char-alt arg)))
+ (if char
+ (rx--generate-alt (not negated) (car char) (cdr char))
+ (error "Illegal argument to rx `not': %S"
+ (rx--human-readable arg))))))))
+
+(defun rx--interval-set-complement (ivs)
+ "Complement of the interval set IVS."
(let ((compl nil)
(c 0))
- (dolist (iv intervals)
+ (dolist (iv ivs)
(when (< c (car iv))
(push (cons c (1- (car iv))) compl))
(setq c (1+ (cdr iv))))
@@ -622,8 +738,8 @@ If NEGATED, negate the sense (thus making it positive)."
(push (cons c (max-char)) compl))
(nreverse compl)))
-(defun rx--intersect-intervals (ivs-a ivs-b)
- "Intersection of the interval lists IVS-A and IVS-B."
+(defun rx--interval-set-intersection (ivs-a ivs-b)
+ "Intersection of the interval sets IVS-A and IVS-B."
(let ((isect nil))
(while (and ivs-a ivs-b)
(let ((a (car ivs-a))
@@ -645,8 +761,8 @@ If NEGATED, negate the sense (thus making it positive)."
ivs-a)))))))
(nreverse isect)))
-(defun rx--union-intervals (ivs-a ivs-b)
- "Union of the interval lists IVS-A and IVS-B."
+(defun rx--interval-set-union (ivs-a ivs-b)
+ "Union of the interval sets IVS-A and IVS-B."
(let ((union nil))
(while (and ivs-a ivs-b)
(let ((a (car ivs-a))
@@ -670,53 +786,66 @@ If NEGATED, negate the sense (thus making it positive)."
ivs-a))))))
(nconc (nreverse union) (or ivs-a ivs-b))))
-(defun rx--charset-intervals (charset)
- "Return a sorted list of non-adjacent disjoint intervals from CHARSET.
-CHARSET is any expression allowed in a character set expression:
-characters, single-char strings, `any' forms (no classes permitted),
-or `not', `or' or `intersection' forms whose arguments are charsets."
- (pcase charset
- (`(,(or 'any 'in 'char) . ,body)
- (let ((parsed (rx--parse-any body)))
- (when (cdr parsed)
- (error
- "Character class not permitted in set operations: %S"
- (cadr parsed)))
- (car parsed)))
- (`(not ,x) (rx--complement-intervals (rx--charset-intervals x)))
- (`(,(or 'or '|) . ,body) (rx--charset-union body))
- (`(intersection . ,body) (rx--charset-intersection body))
- ((pred characterp)
- (list (cons charset charset)))
- ((guard (and (stringp charset) (= (length charset) 1)))
- (let ((char (string-to-char charset)))
- (list (cons char char))))
- (_ (let ((expanded (rx--expand-def charset)))
- (if expanded
- (rx--charset-intervals expanded)
- (error "Bad character set: %S" charset))))))
-
-(defun rx--charset-union (charsets)
- "Union of CHARSETS, as a set of intervals."
- (rx--foldl #'rx--union-intervals nil
- (mapcar #'rx--charset-intervals charsets)))
-
-(defconst rx--charset-all (list (cons 0 (max-char))))
-
-(defun rx--charset-intersection (charsets)
- "Intersection of CHARSETS, as a set of intervals."
- (rx--foldl #'rx--intersect-intervals rx--charset-all
- (mapcar #'rx--charset-intervals charsets)))
-
-(defun rx--translate-union (negated body)
- "Translate an (or ...) construct of charsets. Return (REGEXP . PRECEDENCE).
-If NEGATED, negate the sense."
- (rx--intervals-to-alt negated (rx--charset-union body)))
+(defun rx--human-readable (form)
+ "Turn FORM into something that is more human-readable, for error messages."
+ ;; FIXME: Should we produce a string instead?
+ ;; That way we wouldn't have problems with ? and ??, and we could escape
+ ;; single chars.
+ ;; We could steal `xr--rx-to-string' and just file off the serials.
+ (let ((recurse (lambda (op skip)
+ (cons op (append (take skip (cdr form))
+ (mapcar #'rx--human-readable
+ (nthcdr skip (cdr form))))))))
+ (pcase form
+ ;; strings are more readable than numbers for single chars
+ ((pred characterp) (char-to-string form))
+ ;; resugar `rx--char-alt'
+ (`(rx--char-alt ((,c . ,c)) . nil)
+ (char-to-string form))
+ (`(rx--char-alt nil . (,class))
+ class)
+ ;; TODO: render in complemented form if more readable that way?
+ (`(rx--char-alt ,ivs . ,classes)
+ (let ((strings (mapcan (lambda (iv)
+ (let ((beg (car iv))
+ (end (cdr iv)))
+ (cond
+ ;; single char
+ ((eq beg end)
+ (list (string beg)))
+ ;; two chars
+ ((eq end (1+ beg))
+ (list (string beg) (string end)))
+ ;; first char is hyphen
+ ((eq beg ?-)
+ (cons (string "-")
+ (if (eq end (+ ?- 2))
+ (list (string (1+ ?-) end))
+ (list (string (1+ ?-) ?- end)))))
+ ;; other range
+ (t (list (string beg ?- end))))))
+ ivs)))
+ `(any ,@strings ,@classes)))
+ ;; avoid numbers as ops
+ (`(? . ,_) (funcall recurse '\? 0))
+ (`(?? . ,_) (funcall recurse '\?? 0))
+ ;; recurse on arguments
+ (`(repeat ,_ ,_) (funcall recurse (car form) 1))
+ (`(,(or '** 'repeat) . ,_) (funcall recurse (car form) 2))
+ (`(,(or '= '>= 'group-n 'submatch-n) . ,_) (funcall recurse (car form) 1))
+ (`(,(or 'backref 'syntax 'not-syntax 'category
+ 'eval 'regex 'regexp 'literal)
+ . ,_)
+ form)
+ (`(,_ . ,_) (funcall recurse (car form) 0))
+ (_ form))))
(defun rx--translate-intersection (negated body)
"Translate an (intersection ...) construct. Return (REGEXP . PRECEDENCE).
If NEGATED, negate the sense."
- (rx--intervals-to-alt negated (rx--charset-intersection body)))
+ (rx--generate-alt negated (rx--intersection-intervals
+ (mapcar #'rx--normalise-char-pattern body))
+ nil))
(defun rx--atomic-regexp (item)
"ITEM is (REGEXP . PRECEDENCE); return a regexp of precedence t."
@@ -1006,6 +1135,36 @@ DEF is the definition tuple. Return (REGEXP .
PRECEDENCE)."
(error "The `%s' form did not expand to a string" (car form)))
(cons (list regexp) nil))))
+(defun rx--translate-compat-symbol-entry (entry)
+ "Translate a compatibility symbol definition for ENTRY.
+Return (REGEXP . PRECEDENCE) or nil if none."
+ (and (progn
+ (while (and entry (not (stringp (cdr entry))))
+ (setq entry
+ (if (symbolp (cdr entry))
+ ;; Alias for another entry.
+ (assq (cdr entry) rx-constituents)
+ ;; Wrong type, try further down the list.
+ (assq (car entry)
+ (cdr (memq entry rx-constituents))))))
+ entry)
+ (cons (list (cdr entry)) nil)))
+
+(defun rx--translate-compat-form-entry (orig-form entry)
+ "Translate a compatibility ORIG-FORM definition for ENTRY.
+Return (REGEXP . PRECEDENCE) or nil if none."
+ (and (progn
+ (while (and entry (not (consp (cdr entry))))
+ (setq entry
+ (if (symbolp (cdr entry))
+ ;; Alias for another entry.
+ (assq (cdr entry) rx-constituents)
+ ;; Wrong type, try further down the list.
+ (assq (car entry)
+ (cdr (memq entry rx-constituents))))))
+ entry)
+ (rx--translate-compat-form (cdr entry) orig-form)))
+
(defun rx--substitute (bindings form)
"Substitute BINDINGS in FORM. BINDINGS is an alist of (NAME . VALUES)
where VALUES is a list to splice into FORM wherever NAME occurs.
@@ -1101,6 +1260,7 @@ can expand to any number of values."
((or 'seq : 'and 'sequence) (rx--translate-seq body))
((or 'or '|) (rx--translate-or body))
((or 'any 'in 'char) (rx--translate-any nil body))
+ ('rx--char-alt (rx--translate-char-alt nil body))
('not-char (rx--translate-any t body))
('not (rx--translate-not nil body))
('intersection (rx--translate-intersection nil body))
@@ -1141,23 +1301,13 @@ can expand to any number of values."
(cond
((not (symbolp op)) (error "Bad rx operator `%S'" op))
- ((let ((expanded (rx--expand-def form)))
+ ((let ((expanded (rx--expand-def-form form)))
(and expanded
(rx--translate expanded))))
;; For compatibility with old rx.
((let ((entry (assq op rx-constituents)))
- (and (progn
- (while (and entry (not (consp (cdr entry))))
- (setq entry
- (if (symbolp (cdr entry))
- ;; Alias for another entry.
- (assq (cdr entry) rx-constituents)
- ;; Wrong type, try further down the list.
- (assq (car entry)
- (cdr (memq entry rx-constituents))))))
- entry)
- (rx--translate-compat-form (cdr entry) form))))
+ (and entry (rx--translate-compat-form-entry form entry))))
(t (error "Unknown rx form `%s'" op)))))))
diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el
index ae83f28d9c4..e773ddf158e 100644
--- a/test/lisp/emacs-lisp/rx-tests.el
+++ b/test/lisp/emacs-lisp/rx-tests.el
@@ -41,19 +41,31 @@
(should (equal (rx "" (or "ab" nonl) "")
"ab\\|.")))
+;; FIXME: Extend tests for `or', `not' etc to cover char pattern combination,
+;; including (syntax whitespace) and (syntax word).
+
(ert-deftest rx-or ()
- (should (equal (rx (or "ab" (| "c" nonl) "de"))
- "ab\\|c\\|.\\|de"))
+ (should (equal (rx (or "ab" (| "cd" nonl) "de"))
+ "ab\\|cd\\|.\\|de"))
(should (equal (rx (or "ab" "abc" ?a))
"\\(?:a\\(?:bc?\\)?\\)"))
(should (equal (rx (or "ab" (| (or "abcd" "abcde")) (or "a" "abc")))
"\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)"))
(should (equal (rx (or "a" (eval (string ?a ?b))))
"\\(?:ab?\\)"))
+ (should (equal (rx (| nonl "ac") (| "bd" blank))
+ "\\(?:.\\|ac\\)\\(?:bd\\|[[:blank:]]\\)"))
(should (equal (rx (| nonl "a") (| "b" blank))
- "\\(?:.\\|a\\)\\(?:b\\|[[:blank:]]\\)"))
+ ".[b[:blank:]]"))
(should (equal (rx (|))
- "\\`a\\`")))
+ "\\`a\\`"))
+ (should (equal (rx (or "a" (not anychar) punct ?c "b" (not (not ?d))))
+ "[a-d[:punct:]]"))
+ (should (equal (rx (or nonl ?\n))
+ "[^z-a]"))
+ (should (equal (rx (or "ab" "a" "b" blank (syntax whitespace) word "z"))
+ "ab\\|[ab[:blank:]]\\|\\s-\\|[z[:word:]]"))
+ )
(ert-deftest rx-def-in-or ()
(rx-let ((a b)
@@ -101,14 +113,18 @@
"[\177ÿ\200-\377]"))
;; Range between normal chars and raw bytes: must be split to be parsed
;; correctly by the Emacs regexp engine.
- (should (equal
- (rx (any (0 . #x3fffff)) (any (?G . #x3fff9a)) (any (?Ü .
#x3ffff2)))
- "[\0-\x3fff7f\x80-\xff][G-\x3fff7f\x80-\x9a][Ü-\x3fff7f\x80-\xf2]"))
+ (should (equal (rx (any (0 . #x3fffff) word) (any (?G . #x3fff9a) word)
+ (any (?Ü . #x3ffff2) word))
+ (concat "[\0-\x3fff7f\x80-\xff[:word:]]"
+ "[G-\x3fff7f\x80-\x9a[:word:]]"
+ "[Ü-\x3fff7f\x80-\xf2[:word:]]")))
;; As above but with ranges in string form. For historical reasons,
;; we special-case ASCII-to-raw ranges to exclude non-ASCII unicode.
- (should (equal
- (rx (any "\x00-\xff") (any "G-\x9a") (any "Ü-\xf2"))
- "[\0-\x7f\x80-\xff][G-\x7f\x80-\x9a][Ü-\x3fff7f\x80-\xf2]")))
+ (should (equal (rx (any "\x00-\xff" alpha) (any "G-\x9a" alpha)
+ (any "Ü-\xf2" alpha))
+ (concat "[\0-\x7f\x80-\xff[:alpha:]]"
+ "[G-\x7f\x80-\x9a[:alpha:]]"
+ "[Ü-\x3fff7f\x80-\xf2[:alpha:]]"))))
(ert-deftest rx-any ()
(should (equal (rx (any ?A (?C . ?D) "F-H" "J-L" "M" "N-P" "Q" "RS"))
@@ -175,7 +191,10 @@
"[a[:space:][:digit:]]"))
(should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n)
(| (not (in "a\n")) (not (char ?\n (?b . ?b)))))
- ".....")))
+ "....."))
+ (should (equal (rx (or (in "g-k") (in "a-f") (or ?r (in "i-m" "n-q"))))
+ "[a-r]"))
+ )
(ert-deftest rx-pcase ()
(should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x)))
@@ -392,7 +411,16 @@
(should (equal (rx (or (not (in "abc")) (not (char "bcd"))))
"[^bc]"))
(should (equal (rx (or "x" (? "yz")))
- "x\\|\\(?:yz\\)?")))
+ "x\\|\\(?:yz\\)?"))
+ (should (equal (rx (or anychar (not anychar)))
+ "[^z-a]"))
+ (should (equal (rx (or (not (in "a-p")) (not (in "k-u"))))
+ "[^k-p]"))
+ (should (equal (rx (or (not (in "a-p")) word (not (in "k-u"))))
+ "[\0-jq-\x3fff7f\x80-\xff[:word:]]"))
+ (should (equal (rx (or (in "a-f" blank) (in "c-z") blank))
+ "[a-z[:blank:]]"))
+ )
(ert-deftest rx-def-in-charset-or ()
(rx-let ((a (any "badc"))
@@ -613,52 +641,52 @@
;;; unit tests for internal functions
-(ert-deftest rx--complement-intervals ()
- (should (equal (rx--complement-intervals '())
+(ert-deftest rx--interval-set-complement ()
+ (should (equal (rx--interval-set-complement '())
'((0 . #x3fffff))))
- (should (equal (rx--complement-intervals '((10 . 20) (30 . 40)))
+ (should (equal (rx--interval-set-complement '((10 . 20) (30 . 40)))
'((0 . 9) (21 . 29) (41 . #x3fffff))))
- (should (equal (rx--complement-intervals '((0 . #x3fffff)))
+ (should (equal (rx--interval-set-complement '((0 . #x3fffff)))
'()))
- (should (equal (rx--complement-intervals
+ (should (equal (rx--interval-set-complement
'((0 . 10) (20 . 20) (30 . #x3fffff)))
'((11 . 19) (21 . 29)))))
-(ert-deftest rx--union-intervals ()
- (should (equal (rx--union-intervals '() '()) '()))
- (should (equal (rx--union-intervals '() '((10 . 20) (30 . 40)))
+(ert-deftest rx--interval-set-union ()
+ (should (equal (rx--interval-set-union '() '()) '()))
+ (should (equal (rx--interval-set-union '() '((10 . 20) (30 . 40)))
'((10 . 20) (30 . 40))))
- (should (equal (rx--union-intervals '((10 . 20) (30 . 40)) '())
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) '())
'((10 . 20) (30 . 40))))
- (should (equal (rx--union-intervals '((5 . 15) (18 . 24) (32 . 40))
+ (should (equal (rx--interval-set-union '((5 . 15) (18 . 24) (32 . 40))
'((10 . 20) (30 . 40) (50 . 60)))
'((5 . 24) (30 . 40) (50 . 60))))
- (should (equal (rx--union-intervals '((10 . 20) (30 . 40) (50 . 60))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40) (50 . 60))
'((0 . 9) (21 . 29) (41 . 50)))
'((0 . 60))))
- (should (equal (rx--union-intervals '((10 . 20) (30 . 40))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40))
'((12 . 18) (28 . 42)))
'((10 . 20) (28 . 42))))
- (should (equal (rx--union-intervals '((10 . 20) (30 . 40))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40))
'((0 . #x3fffff)))
'((0 . #x3fffff)))))
-(ert-deftest rx--intersect-intervals ()
- (should (equal (rx--intersect-intervals '() '()) '()))
- (should (equal (rx--intersect-intervals '() '((10 . 20) (30 . 40)))
+(ert-deftest rx--interval-set-intersection ()
+ (should (equal (rx--interval-set-intersection '() '()) '()))
+ (should (equal (rx--interval-set-intersection '() '((10 . 20) (30 . 40)))
'()))
- (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40)) '())
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) '())
'()))
- (should (equal (rx--intersect-intervals '((5 . 15) (18 . 24) (32 . 40))
+ (should (equal (rx--interval-set-intersection '((5 . 15) (18 . 24) (32 . 40))
'((10 . 20) (30 . 40) (50 . 60)))
'((10 . 15) (18 . 20) (32 . 40))))
- (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40) (50 . 60))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40) (50 .
60))
'((0 . 9) (21 . 29) (41 . 50)))
'((50 . 50))))
- (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40))
'((12 . 18) (28 . 42)))
'((12 . 18) (30 . 40))))
- (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40))
'((0 . #x3fffff)))
'((10 . 20) (30 . 40)))))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master de6c1c4d5c9: rx: Better translation of char-matching patterns,
Mattias Engdegård <=