diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/pcre2el-20161120.1303/pcre2el.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/pcre2el-20161120.1303/pcre2el.el | 3157 |
1 files changed, 3157 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/pcre2el-20161120.1303/pcre2el.el b/configs/shared/emacs/.emacs.d/elpa/pcre2el-20161120.1303/pcre2el.el new file mode 100644 index 000000000000..e4f925c623c4 --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/pcre2el-20161120.1303/pcre2el.el @@ -0,0 +1,3157 @@ +;;; pcre2el.el --- regexp syntax converter -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2015 Jon Oddie <jonxfield@gmail.com> + +;; Author: joddie <jonxfield at gmail.com> +;; Hacked additionally by: opensource at hardakers dot net +;; Created: 14 Feb 2012 +;; Updated: 13 December 2015 +;; Version: 1.8 +;; Package-Version: 20161120.1303 +;; Url: https://github.com/joddie/pcre2el +;; Package-Requires: ((emacs "24") (cl-lib "0.3")) + +;; This file is NOT part of GNU Emacs. + +;; This program 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. +;; +;; This program 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 this program. If not, see `http://www.gnu.org/licenses/'. + +;; This file incorporates work covered by the following copyright and +;; permission notice: +;; +;; Copyright (c) 1993-2002 Richard Kelsey and Jonathan Rees +;; Copyright (c) 1994-2002 by Olin Shivers and Brian D. Carlstrom. +;; Copyright (c) 1999-2002 by Martin Gasbichler. +;; Copyright (c) 2001-2002 by Michael Sperber. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: 1. Redistributions of source code must retain the above +;; copyright notice, this list of conditions and the following +;; disclaimer. 2. Redistributions in binary form must reproduce the +;; above copyright notice, this list of conditions and the following +;; disclaimer in the documentation and/or other materials provided +;; with the distribution. 3. The name of the authors may not be used +;; to endorse or promote products derived from this software without +;; specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS "AS IS" AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY +;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: + +;; 1 Overview +;; ========== + +;; `pcre2el' or `rxt' (RegeXp Translator or RegeXp Tools) is a utility +;; for working with regular expressions in Emacs, based on a +;; recursive-descent parser for regexp syntax. In addition to converting +;; (a subset of) PCRE syntax into its Emacs equivalent, it can do the +;; following: + +;; - convert Emacs syntax to PCRE +;; - convert either syntax to `rx', an S-expression based regexp syntax +;; - untangle complex regexps by showing the parse tree in `rx' form and +;; highlighting the corresponding chunks of code +;; - show the complete list of strings (productions) matching a regexp, +;; provided the list is finite +;; - provide live font-locking of regexp syntax (so far only for Elisp +;; buffers -- other modes on the TODO list) + + +;; 2 Usage +;; ======= + +;; Enable `rxt-mode' or its global equivalent `rxt-global-mode' to get +;; the default key-bindings. There are three sets of commands: commands +;; that take a PCRE regexp, commands which take an Emacs regexp, and +;; commands that try to do the right thing based on the current +;; mode. Currently, this means Emacs syntax in `emacs-lisp-mode' and +;; `lisp-interaction-mode', and PCRE syntax everywhere else. + +;; The default key bindings all begin with `C-c /' and have a mnemonic +;; structure: `C-c / <source> <target>', or just `C-c / <target>' for the +;; "do what I mean" commands. The complete list of key bindings is given +;; here and explained in more detail below: + +;; - "Do-what-I-mean" commands: +;; `C-c / /': `rxt-explain' +;; `C-c / c': `rxt-convert-syntax' +;; `C-c / x': `rxt-convert-to-rx' +;; `C-c / '': `rxt-convert-to-strings' + +;; - Commands that work on a PCRE regexp: +;; `C-c / p e': `rxt-pcre-to-elisp' +;; `C-c / %': `pcre-query-replace-regexp' +;; `C-c / p x': `rxt-pcre-to-rx' +;; `C-c / p '': `rxt-pcre-to-strings' +;; `C-c / p /': `rxt-explain-pcre' + +;; - Commands that work on an Emacs regexp: +;; `C-c / e /': `rxt-explain-elisp' +;; `C-c / e p': `rxt-elisp-to-pcre' +;; `C-c / e x': `rxt-elisp-to-rx' +;; `C-c / e '': `rxt-elisp-to-strings' +;; `C-c / e t': `rxt-toggle-elisp-rx' +;; `C-c / t': `rxt-toggle-elisp-rx' + + +;; 2.1 Interactive input and output +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +;; When used interactively, the conversion commands can read a regexp +;; either from the current buffer or from the minibuffer. The output is +;; displayed in the minibuffer and copied to the kill-ring. + +;; - When called with a prefix argument (`C-u'), they read a regular +;; expression from the minibuffer literally, without further processing +;; -- meaning there's no need to double the backslashes if it's an +;; Emacs regexp. This is the same way commands like +;; `query-replace-regexp' read input. + +;; - When the region is active, they use they the region contents, again +;; literally (without any translation of string syntax). + +;; - With neither a prefix arg nor an active region, the behavior depends +;; on whether the command expects an Emacs regexp or a PCRE one. + +;; Commands that take an Emacs regexp behave like `C-x C-e': they +;; evaluate the sexp before point (which could be simply a string +;; literal) and use its value. This is designed for use in Elisp +;; buffers. As a special case, if point is *inside* a string, it's +;; first moved to the string end, so in practice they should work as +;; long as point is somewhere within the regexp literal. + +;; Commands that take a PCRE regexp try to read a Perl-style delimited +;; regex literal *after* point in the current buffer, including its +;; flags. For example, putting point before the `m' in the following +;; example and doing `C-c / p e' (`rxt-pcre-to-elisp') displays +;; `\(?:bar\|foo\)', correctly stripping out the whitespace and +;; comment: + +;; ,---- +;; | $x =~ m/ foo | (?# comment) bar /x +;; `---- + +;; The PCRE reader currently only works with `/ ... /' delimiters. It +;; will ignore any preceding `m', `s', or `qr' operator, as well as the +;; replacement part of an `s' construction. + +;; Readers for other PCRE-using languages are on the TODO list. + +;; The translation functions display their result in the minibuffer and +;; copy it to the kill ring. When translating something into Elisp +;; syntax, you might need to use the result either literally (e.g. for +;; interactive input to a command like `query-replace-regexp'), or as a +;; string to paste into Lisp code. To allow both uses, +;; `rxt-pcre-to-elisp' copies both versions successively to the +;; kill-ring. The literal regexp without string quoting is the top +;; element of the kill-ring, while the Lisp string is the +;; second-from-top. You can paste the literal regexp somewhere by doing +;; `C-y', or the Lisp string by `C-y M-y'. + + +;; 2.2 Syntax conversion commands +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +;; `rxt-convert-syntax' (`C-c / c') converts between Emacs and PCRE +;; syntax, depending on the major mode in effect when called. +;; Alternatively, you can specify the conversion direction explicitly by +;; using either `rxt-pcre-to-elisp' (`C-c / p e') or `rxt-elisp-to-pcre' +;; (`C-c / e p'). + +;; Similarly, `rxt-convert-to-rx' (`C-c / x') converts either kind of +;; syntax to `rx' form, while `rxt-convert-pcre-to-rx' (`C-c / p x') and +;; `rxt-convert-elisp-to-rx' (`C-c / e x') convert to `rx' from a +;; specified source type. + +;; In Elisp buffers, you can use `rxt-toggle-elisp-rx' (`C-c / t' or `C-c +;; / e t') to switch the regexp at point back and forth between string +;; and `rx' syntax. Point should either be within an `rx' or +;; `rx-to-string' form or a string literal for this to work. + + +;; 2.3 PCRE mode (experimental) +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +;; If you want to use emulated PCRE regexp syntax in all Emacs commands, +;; try `pcre-mode', which uses Emacs's advice system to make all commands +;; that read regexps using the minibuffer use emulated PCRE syntax. It +;; should also work with Isearch. + +;; This feature is still fairly experimental. It may fail to work or do +;; the wrong thing with certain commands. Please report bugs. + +;; `pcre-query-replace-regexp' was originally defined to do query-replace +;; using emulated PCRE regexps, and is now made somewhat obsolete by +;; `pcre-mode'. It is bound to `C-c / %' by default, by analogy with +;; `M-%'. Put the following in your `.emacs' if you want to use +;; PCRE-style query replacement everywhere: + +;; ,---- +;; | (global-set-key [(meta %)] 'pcre-query-replace-regexp) +;; `---- + +;; 2.5 Explain regexps +;; ~~~~~~~~~~~~~~~~~~~ + +;; When syntax-highlighting isn't enough to untangle some gnarly regexp +;; you find in the wild, try the 'explain' commands: `rxt-explain' (`C-c +;; / /'), `rxt-explain-pcre' (`C-c / p') and `rxt-explain-elisp' (`C-c / +;; e'). These display the original regexp along with its pretty-printed +;; `rx' equivalent in a new buffer. Moving point around either in the +;; original regexp or the `rx' translation highlights corresponding +;; pieces of syntax, which can aid in seeing things like the scope of +;; quantifiers. + +;; I call them "explain" commands because the `rx' form is close to a +;; plain syntax tree, and this plus the wordiness of the operators +;; usually helps to clarify what is going on. People who dislike Lisp +;; syntax might disagree with this assessment. + + +;; 2.6 Generate all matching strings (productions) +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +;; Occasionally you come across a regexp which is designed to match a +;; finite set of strings, e.g. a set of keywords, and it would be useful +;; to recover the original set. (In Emacs you can generate such regexps +;; using `regexp-opt'). The commands `rxt-convert-to-strings' (`C-c / +;; ′'), `rxt-pcre-to-strings' (`C-c / p ′') or `rxt-elisp-to-strings' +;; (`C-c / e ′') accomplish this by generating all the matching strings +;; ("productions") of a regexp. (The productions are copied to the kill +;; ring as a Lisp list). + +;; An example in Lisp code: + +;; ,---- +;; | (regexp-opt '("cat" "caterpillar" "catatonic")) +;; | ;; => "\\(?:cat\\(?:atonic\\|erpillar\\)?\\)" +;; | (rxt-elisp-to-strings "\\(?:cat\\(?:atonic\\|erpillar\\)?\\)") +;; | ;; => '("cat" "caterpillar" "catatonic") +;; `---- + +;; For obvious reasons, these commands only work with regexps that don't +;; include any unbounded quantifiers like `+' or `*'. They also can't +;; enumerate all the characters that match a named character class like +;; `[[:alnum:]]'. In either case they will give a (hopefully meaningful) +;; error message. Due to the nature of permutations, it's still possible +;; for a finite regexp to generate a huge number of productions, which +;; will eat memory and slow down your Emacs. Be ready with `C-g' if +;; necessary. + + +;; 2.7 RE-Builder support +;; ~~~~~~~~~~~~~~~~~~~~~~ + +;; The Emacs RE-Builder is a useful visual tool which allows using +;; several different built-in syntaxes via `reb-change-syntax' (`C-c +;; TAB'). It supports Elisp read and literal syntax and `rx', but it can +;; only convert from the symbolic forms to Elisp, not the other way. This +;; package hacks the RE-Builder to also work with emulated PCRE syntax, +;; and to convert transparently between Elisp, PCRE and rx syntaxes. PCRE +;; mode reads a delimited Perl-like literal of the form `/ ... /', and it +;; should correctly support using the `x' and `s' flags. + + +;; 2.8 Use from Lisp +;; ~~~~~~~~~~~~~~~~~ + +;; Example of using the conversion functions: +;; ,---- +;; | (rxt-pcre-to-elisp "(abc|def)\\w+\\d+") +;; | ;; => "\\(\\(?:abc\\|def\\)\\)[_[:alnum:]]+[[:digit:]]+" +;; `---- + +;; All the conversion functions take a single string argument, the regexp +;; to translate: + +;; - `rxt-pcre-to-elisp' +;; - `rxt-pcre-to-rx' +;; - `rxt-pcre-to-strings' +;; - `rxt-elisp-to-pcre' +;; - `rxt-elisp-to-rx' +;; - `rxt-elisp-to-strings' + + +;; 3 Bugs and Limitations +;; ====================== + +;; 3.1 Limitations on PCRE syntax +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +;; PCRE has a complicated syntax and semantics, only some of which can be +;; translated into Elisp. The following subset of PCRE should be +;; correctly parsed and converted: + +;; - parenthesis grouping `( .. )', including shy matches `(?: ... )' +;; - backreferences (various syntaxes), but only up to 9 per expression +;; - alternation `|' +;; - greedy and non-greedy quantifiers `*', `*?', `+', `+?', `?' and `??' +;; (all of which are the same in Elisp as in PCRE) +;; - numerical quantifiers `{M,N}' +;; - beginning/end of string `\A', `\Z' +;; - string quoting `\Q .. \E' +;; - word boundaries `\b', `\B' (these are the same in Elisp) +;; - single character escapes `\a', `\c', `\e', `\f', `\n', `\r', `\t', +;; `\x', and `\octal digits' (but see below about non-ASCII characters) +;; - character classes `[...]' including Posix escapes +;; - character classes `\d', `\D', `\h', `\H', `\s', `\S', `\v', `\V' +;; both within character class brackets and outside +;; - word and non-word characters `\w' and `\W' (Emacs has the same +;; syntax, but its meaning is different) +;; - `s' (single line) and `x' (extended syntax) flags, in regexp +;; literals, or set within the expression via `(?xs-xs)' or `(?xs-xs: +;; .... )' syntax +;; - comments `(?# ... )' + +;; Most of the more esoteric PCRE features can't really be supported by +;; simple translation to Elisp regexps. These include the different +;; lookaround assertions, conditionals, and the "backtracking control +;; verbs" `(* ...)' . OTOH, there are a few other syntaxes which are +;; currently unsupported and possibly could be: + +;; - `\L', `\U', `\l', `\u' case modifiers +;; - `\g{...}' backreferences + + +;; 3.2 Other limitations +;; ~~~~~~~~~~~~~~~~~~~~~ + +;; - The order of alternatives and characters in char classes sometimes +;; gets shifted around, which is annoying. +;; - Although the string parser tries to interpret PCRE's octal and +;; hexadecimal escapes correctly, there are problems with matching +;; 8-bit characters that I don't use enough to properly understand, +;; e.g.: +;; ,---- +;; | (string-match-p (rxt-pcre-to-elisp "\\377") "\377") => nil +;; `---- +;; A fix for this would be welcome. + +;; - Most of PCRE's rules for how `^', `\A', `$' and `\Z' interact with +;; newlines are not implemented, since they seem less relevant to +;; Emacs's buffer-oriented rather than line-oriented model. However, +;; the different meanings of the `.' metacharacter *are* implemented +;; (it matches newlines with the `/s' flag, but not otherwise). + +;; - Not currently namespace clean (both `rxt-' and a couple of `pcre-' +;; functions). + + +;; 3.3 TODO: +;; ~~~~~~~~~ + +;; - Python-specific extensions to PCRE? +;; - Language-specific stuff to enable regexp font-locking and explaining +;; in different modes. Each language would need two functions, which +;; could be kept in an alist: + +;; 1. A function to read PCRE regexps, taking the string syntax into +;; account. E.g., Python has single-quoted, double-quoted and raw +;; strings, each with different quoting rules. PHP has the kind of +;; belt-and-suspenders solution you would expect: regexps are in +;; strings, /and/ you have to include the `/ ... /' delimiters! +;; Duh. + +;; 2. A function to copy faces back from the parsed string to the +;; original buffer text. This has to recognize any escape sequences +;; so they can be treated as a single character. + + +;; 4 Internal details +;; ================== + +;; `rxt' defines an internal syntax tree representation of regular +;; expressions, parsers for Elisp and PCRE syntax, and 'unparsers' +;; to convert the internal representation to PCRE or `rx' syntax. +;; Converting from the internal representation to Emacs syntax is +;; done by converting to `rx' form and passing it to `rx-to-string'. +;; See `rxt-parse-re', `rxt-adt->pcre', and `rxt-adt->rx' for +;; details. + +;; This code is partially based on Olin Shivers' reference SRE +;; implementation in scsh, although it is simplified in some respects and +;; extended in others. See `scsh/re.scm', `scsh/spencer.scm' and +;; `scsh/posixstr.scm' in the `scsh' source tree for details. In +;; particular, `pcre2el' steals the idea of an abstract data type for +;; regular expressions and the general structure of the string regexp +;; parser and unparser. The data types for character sets are extended in +;; order to support symbolic translation between character set +;; expressions without assuming a small (Latin1) character set. The +;; string parser is also extended to parse a bigger variety of +;; constructions, including POSIX character classes and various Emacs and +;; Perl regexp assertions. Otherwise, only the bare minimum of scsh's +;; abstract data type is implemented. + + +;; 5 Soapbox +;; ========= + +;; Emacs regexps have their annoyances, but it is worth getting used to +;; them. The Emacs assertions for word boundaries, symbol boundaries, and +;; syntax classes depending on the syntax of the mode in effect are +;; especially useful. (PCRE has `\b' for word-boundary, but AFAIK it +;; doesn't have separate assertions for beginning-of-word and +;; end-of-word). Other things that might be done with huge regexps in +;; other languages can be expressed more understandably in Elisp using +;; combinations of `save-excursion' with the various searches (regexp, +;; literal, skip-syntax-forward, sexp-movement functions, etc.). + +;; There's not much point in using `rxt-pcre-to-elisp' to use PCRE +;; notation in a Lisp program you're going to maintain, since you still +;; have to double all the backslashes. Better to just use the converted +;; result (or better yet, the `rx' form). + + +;; 6 History and acknowledgments +;; ============================= + +;; This was originally created out of an answer to a stackoverflow +;; question: +;; [http://stackoverflow.com/questions/9118183/elisp-mechanism-for-converting-pcre-regexps-to-emacs-regexps] + +;; Thanks to: + +;; - Wes Hardaker (hardaker) for the initial inspiration and subsequent +;; hacking +;; - priyadarshan for requesting RX support +;; - Daniel Colascione (dcolascione) for a patch to support Emacs's +;; explicitly-numbered match groups +;; - Aaron Meurer (asmeurer) for requesting Isearch support +;; - Philippe Vaucher (silex) for a patch to support `ibuffer-do-replace-regexp' +;; in PCRE mode + +;;; Code: + +(require 'cl-lib) +(require 'rx) +(require 're-builder) +(require 'advice) +(require 'ring) +(require 'pcase) + +;;; Customization group +(defgroup rxt nil + "Regex syntax converter and utilities." + :version 1.2 + :group 'tools + :group 'lisp + :link '(emacs-commentary-link :tag "commentary" "pcre2el.el") + :link '(emacs-library-link :tag "lisp file" "pcre2el.el") + :link '(url-link :tag "web page" "https://github.com/joddie/pcre2el")) + +(defface rxt-highlight-face + '((((min-colors 16581375) (background light)) :background "#eee8d5") + (((min-colors 16581375) (background dark)) :background "#222222")) + "Face for highlighting corresponding regex syntax in `rxt-explain' buffers." + :group 'rxt) + +(defcustom rxt-verbose-rx-translation nil + "Non-nil if `rxt-pcre-to-rx' and `rxt-elisp-to-rx' should use verbose `rx' primitives. + +Verbose primitives are things like `line-start' instead of `bol', +etc." + :group 'rxt + :type 'boolean) + +(defcustom rxt-explain-verbosely t + "Non-nil if `rxt-explain-elisp' and `rxt-explain-pcre' should use verbose `rx' primitives. + +This overrides the value of `rxt-verbose-rx-translation' for +these commands only." + :group 'rxt + :type 'boolean) + + +;;;; Macros and functions for writing interactive input and output + +;; Macros for handling return values. If called interactively, +;; display the value in the echo area and copy it to the kill ring, +;; otherwise just return the value. PCREs are copied as unquoted +;; strings for yanking into Perl, JS, etc. `rx' forms and other sexps +;; are copied as `read'-able literals for yanking into Elisp buffers. +;; Emacs regexps are copied twice: once as an unquoted value for +;; interactive use, and once as a readable string literal for yanking +;; into Elisp buffers. +(defmacro rxt-return-pcre (expr) + (let ((value (make-symbol "value"))) + `(let ((,value ,expr)) + (when (called-interactively-p 'any) + (rxt--kill-pcre ,value)) + ,value))) + +(defmacro rxt-return-sexp (expr) + (let ((value (make-symbol "value"))) + `(let ((,value ,expr)) + (when (called-interactively-p 'any) + (rxt--kill-sexp ,value)) + ,value))) + +(defmacro rxt-return-emacs-regexp (expr) + (let ((value (make-symbol "value"))) + `(let ((,value ,expr)) + (when (called-interactively-p 'any) + (rxt--kill-emacs-regexp ,value)) + ,value))) + +(defun rxt--kill-sexp (value) + (let ((lisp-literal (prin1-to-string value))) + (message "%s" lisp-literal) + (kill-new lisp-literal))) + +(defun rxt--kill-pcre (value) + (message "%s" value) + (kill-new value)) + +(defun rxt--kill-emacs-regexp (value) + (let ((lisp-literal (prin1-to-string value))) + (message "%s" value) + (kill-new lisp-literal) + (kill-new value))) + +;; Read an Elisp regexp interactively. +;; +;; Three possibilities: +;; +;; 1) With a prefix arg, reads literally from the minibuffer, w/o +;; using string syntax -- just like query-replace-regexp, etc. +;; +;; 2) If the region is active, use the text of the region literally +;; (again w/o string syntax) +;; +;; 3) Otherwise, eval the sexp before point (which might be a string +;; literal or an expression) and use its value. Falls back to method +;; (1) if this fails to produce a string value. +;; +(cl-defun rxt-interactive/elisp (&optional (prompt "Emacs regexp: ")) + (list + (cond (current-prefix-arg + (read-string prompt)) + + ((use-region-p) + (buffer-substring-no-properties (region-beginning) (region-end))) + + (t + (condition-case nil + (save-excursion + (while (nth 3 (syntax-ppss)) (forward-char)) + (let ((re (eval (preceding-sexp)))) + (if (stringp re) re + (read-string prompt)))) + (error + (read-string prompt))))))) + +;; Read a PCRE regexp interactively. +;; +;; Three possibilities: As above, except that without prefix arg or +;; active region, tries to read a delimited regexp literal like /.../, +;; m/.../, or qr/.../ following point in the current buffer. Falls +;; back to reading from minibuffer if that fails. +;; +;; Returns the regexp, with flags as text properties. +;; +;; TODO: Different delimiters +(cl-defun rxt-interactive/pcre (&optional (prompt "PCRE regexp: ")) + (list + (cond (current-prefix-arg + (rxt--read-pcre prompt)) + + ((use-region-p) + (buffer-substring-no-properties (region-beginning) (region-end))) + + (t + (condition-case nil + (rxt-read-delimited-pcre) + (error ; Fall back to reading from minibuffer + (rxt--read-pcre prompt))))) + nil)) + +(define-minor-mode rxt--read-pcre-mode + "Minor-mode with key-bindings for toggling PCRE flags. + +You should not normally call this directly. It will be enabled +in minibuffers for `read-regexp' and in the `re-builder' buffer +when `pcre-mode' is active. These bindings will also be added to +`isearch-mode-map' in `pcre-mode'." + :initial nil + :lighter nil + :keymap + `((,(kbd "C-c s") . ,#'rxt--toggle-s-mode) + (,(kbd "C-c x") . ,#'rxt--toggle-x-mode) + (,(kbd "C-c i") . ,#'rxt--toggle-i-mode))) + +(defun rxt--read-pcre (prompt) + "Read a PCRE regexp for translation, together with option flags. + +The `s', `x', and `i' flags can be toggled using the following +commands: \\<rxt--read-pcre-mode-map> + +\\[rxt--toggle-s-mode] : toggle `s' (single-line) mode +\\[rxt--toggle-x-mode] : toggle `x' (extended) mode +\\[rxt--toggle-i-mode] : toggle `i' (case-insensitive) mode + +In single-line mode, `.' will also match newlines. +In extended mode, whitespace is ignored. + +Case-insensitive mode emulates matching without case, +independently of Emacs's builtin `case-fold-search' setting. +Note that this does not apply to backreferences." + (minibuffer-with-setup-hook #'rxt--read-pcre-mode + (read-from-minibuffer prompt))) + +(defun rxt--toggle-s-mode () + "Toggle emulated PCRE single-line (s) flag." + (interactive) + (rxt--toggle-flag ?s)) + +(defun rxt--toggle-x-mode () + "Toggle emulated PCRE extended (x) flag." + (interactive) + (rxt--toggle-flag ?x)) + +(defun rxt--toggle-i-mode () + "Toggle emulated PCRE case-insensitive (i) flag." + (interactive) + (rxt--toggle-flag ?i)) + +(defun rxt--toggle-flag (char) + "Toggle CHAR, a PCRE flag." + (cond + ((derived-mode-p 'reb-mode) ; RE-Builder + (rxt--toggle-flag-re-builder char)) + ((minibufferp) + (rxt--toggle-flag-minibuffer char)) + (isearch-mode + (rxt--toggle-flag-isearch char)) + (t + (error "Not in minibuffer, RE-Builder or isearch mode.")))) + +(defun rxt--toggle-flag-re-builder (char) + (save-excursion + (goto-char (point-max)) + (search-backward "/") + (forward-char) + (when (looking-at (rx (* (any ?i ?s ?x)))) + (let ((inhibit-modification-hooks t)) + (replace-match (rxt--xor-flags (match-string 0) char) t t)))) + (reb-do-update)) + +(defun rxt--toggle-flag-minibuffer (char) + (setf (buffer-substring (minibuffer-prompt-end) (point-max)) + (rxt--toggle-flag-string (minibuffer-contents) char)) + (when + (and (= (point) (minibuffer-prompt-end)) + (looking-at (rx "(?" (group (+ (any ?i ?s ?x))) ")"))) + (forward-sexp))) + +(defun rxt--toggle-flag-isearch (char) + (when isearch-regexp + (setq isearch-string + (rxt--toggle-flag-string isearch-string char)) + (setq isearch-message + (mapconcat #'isearch-text-char-description isearch-string "")) + (isearch-search-and-update))) + +(defun rxt--toggle-flag-string (string char) + (if (string-match (rx string-start "(?" (group (+ (any ?i ?s ?x))) ")") + string) + (let ((flags (rxt--xor-flags (match-string 1 string) char))) + (if (string= flags "") + (replace-match "" t t string) + (replace-match flags t t string 1))) + (format "(?%c)%s" char string))) + +(defun rxt--xor-flags (flags char) + (concat + (sort + (cl-set-exclusive-or (string-to-list flags) (list char)) + #'<))) + + +;;;; Minor mode for using emulated PCRE syntax + +(defvar pcre-old-isearch-search-fun-function nil + "Original value of `isearch-search-fun-function' before entering `pcre-mode.' + +This function is wrapped by `pcre-isearch-search-fun-function' +and restored on exit from `pcre-mode'.") +(make-variable-buffer-local 'pcre-old-isearch-search-fun-function) + +(defvar pcre-old-isearch-key-bindings nil + "Alist of key-bindings to restore in `isearch-mode-map' on exiting `pcre-mode'.") + +;;;###autoload +(define-minor-mode pcre-mode + "Use emulated PCRE syntax for regexps wherever possible. + +Advises the `interactive' specs of `read-regexp' and the +following other functions so that they read PCRE syntax and +translate to its Emacs equivalent: + +- `align-regexp' +- `find-tag-regexp' +- `sort-regexp-fields' +- `isearch-message-prefix' +- `ibuffer-do-replace-regexp' + +Also alters the behavior of `isearch-mode' when searching by regexp." + nil " PCRE" + nil + :global t + + (if pcre-mode + ;; Enabling + (progn + ;; Enable advice + (ad-enable-regexp "pcre-mode") + ;; Set up isearch hooks + (add-hook 'isearch-mode-hook #'pcre-isearch-mode-hook) + (add-hook 'isearch-mode-end-hook #'pcre-isearch-mode-end-hook) + ;; Add the keybindings of `rxt--read-pcre-mode-map' to + ;; `isearch-mode-map' (so that they do not cause an exit from + ;; `isearch-mode'), and save any existing bindings for those + ;; keys to restore on exit from `pcre-mode'. + (setq pcre-old-isearch-key-bindings + (cl-loop for key being the key-seqs of rxt--read-pcre-mode-map + for def = (lookup-key isearch-mode-map key) + collect (cons (copy-sequence key) + (if (numberp def) nil def)))) + (cl-loop for key being the key-seqs of rxt--read-pcre-mode-map + using (key-bindings def) + do (define-key isearch-mode-map key def))) + + ;; Disable advice + (ad-disable-regexp "pcre-mode") + ;; Remove from isearch hooks + (remove-hook 'isearch-mode-hook #'pcre-isearch-mode-hook) + (remove-hook 'isearch-mode-end-hook #'pcre-isearch-mode-end-hook) + ;; Restore key-bindings + (cl-loop for (key . def) in pcre-old-isearch-key-bindings + do (define-key isearch-mode-map key def))) + + ;; "Activating" advice re-computes the function definitions, which + ;; is necessary whether enabling or disabling + (ad-activate-regexp "pcre-mode")) + +;;; Cache of PCRE -> Elisp translations +(defvar pcre-mode-cache-size 100 + "Number of PCRE-to-Emacs translations to keep in the `pcre-mode' cache.") + +(defvar pcre-mode-cache (make-hash-table :test 'equal) + "Cache of PCRE-to-Emacs translations used in `pcre-mode'. + +Keys are PCRE regexps, values are their Emacs equivalents.") + +(defvar pcre-mode-reverse-cache (make-hash-table :test 'equal) + "Cache of original PCREs translated to Emacs syntax in `pcre-mode'. + +Keys are translated Emacs regexps, values are their original PCRE +form. This is used to display the original PCRE regexp in place +of its translated form.") + +(defvar pcre-cache-ring (make-ring pcre-mode-cache-size) + "Ring of PCRE-to-Emacs translations used in `pcre-mode'. + +When the ring fills up, the oldest element is removed and the +corresponding entries are deleted from the hash tables +`pcre-mode-cache' and `pcre-mode-reverse-cache'.") + +(defun pcre-to-elisp/cached (pcre) + "Translate PCRE to Emacs syntax, caching both forms." + (or (gethash pcre pcre-mode-cache) + (let ((elisp (rxt-pcre-to-elisp pcre))) + (pcre-set-cache pcre elisp) + elisp))) + +(defun pcre-set-cache (pcre-regexp emacs-regexp) + "Add a PCRE-to-Emacs translation to the `pcre-mode' cache." + (when (and (not (zerop (length pcre-regexp))) + (not (zerop (length emacs-regexp))) + (not (gethash pcre-regexp pcre-mode-cache))) + (if (= (ring-length pcre-cache-ring) (ring-size pcre-cache-ring)) + (let* ((old-item (ring-remove pcre-cache-ring)) + (old-pcre (car old-item)) + (old-emacs (cdr old-item))) + (remhash old-pcre pcre-mode-cache) + (remhash old-emacs pcre-mode-reverse-cache)) + (puthash pcre-regexp emacs-regexp pcre-mode-cache) + (puthash emacs-regexp pcre-regexp pcre-mode-reverse-cache) + (ring-insert pcre-cache-ring (cons pcre-regexp emacs-regexp))))) + +;;; Isearch advice +(defun pcre-isearch-mode-hook () + (when (not (eq isearch-search-fun-function #'isearch-search-fun-default)) + (message "Warning: pcre-mode overriding existing isearch function `%s'" + isearch-search-fun-function)) + ;; Prevent an infinite loop, if a previous isearch in pcre-mode + ;; exited without restoring the original search function for some + ;; reason + (unless (eq isearch-search-fun-function #'pcre-isearch-search-fun-function) + (setq pcre-old-isearch-search-fun-function isearch-search-fun-function)) + (set (make-local-variable 'isearch-search-fun-function) + #'pcre-isearch-search-fun-function)) + +(defun pcre-isearch-mode-end-hook () + (setq isearch-search-fun-function pcre-old-isearch-search-fun-function)) + +(defun pcre-isearch-search-fun-function () + "Enable isearching using emulated PCRE syntax. + +This is set as the value of `isearch-search-fun-function' when +`pcre-mode' is enabled. Returns a function which searches using +emulated PCRE regexps when `isearch-regexp' is true." + (lambda (string bound noerror) + (let ((real-search-function + (funcall (or pcre-old-isearch-search-fun-function 'isearch-search-fun-default)))) + (if (not isearch-regexp) + (funcall real-search-function string bound noerror) + ;; Raise an error if the regexp ends in an incomplete escape + ;; sequence (= odd number of backslashes). + ;; TODO: Perhaps this should really be handled in rxt-pcre-to-elisp? + (if (isearch-backslash string) (rxt-error "Trailing backslash")) + (funcall real-search-function + (pcre-to-elisp/cached string) bound noerror))))) + +(defadvice isearch-message-prefix (after pcre-mode disable) + "Add \"PCRE\" to the Isearch message when searching by regexp in `pcre-mode'." + (when (and isearch-regexp + ;; Prevent an inaccurate message if our callback was + ;; removed somehow + (eq isearch-search-fun-function #'pcre-isearch-search-fun-function)) + (let ((message ad-return-value)) + ;; Some hackery to give replacement the same fontification as + ;; the original + (when + (let ((case-fold-search t)) (string-match "regexp" message)) + (let* ((match (match-string 0 message)) + (properties (text-properties-at 0 match)) + (replacement (apply #'propertize "PCRE regexp" properties)) + (new-message (replace-match replacement t t message))) + (setq ad-return-value new-message)))))) + +(defadvice isearch-fallback + (before pcre-mode (want-backslash &optional allow-invalid to-barrier) disable) + "Hack to fall back correctly in `pcre-mode'. " + ;; A dirty hack to the internals of isearch. Falling back to a + ;; previous match position is necessary when the (Emacs) regexp ends + ;; in "*", "?", "\{" or "\|": this is handled in + ;; `isearch-process-search-char' by calling `isearch-fallback' with + ;; `t' for the value of the first parameter, `want-backslash', in + ;; the last two cases. With PCRE regexps, falling back should take + ;; place on "*", "?", "{" or "|", with no backslashes required. + ;; This advice handles the last two cases by unconditionally setting + ;; `want-backslash' to nil. + (ad-set-arg 0 nil)) + +(defadvice isearch-edit-string + (around pcre-mode disable) + "Add PCRE mode-toggling keys to Isearch minibuffer in regexp mode." + (if isearch-regexp + (minibuffer-with-setup-hook + #'rxt--read-pcre-mode + ad-do-it) + ad-do-it)) + +;;; evil-mode advice +(defadvice evil-search-function + (around pcre-mode (forward regexp-p wrap) disable) + (if (and regexp-p (not isearch-mode)) + (let ((real-search-function ad-do-it)) + (setq ad-return-value + (pcre-decorate-search-function real-search-function))) + ad-do-it)) + +(eval-after-load 'evil + '(when pcre-mode + (ad-enable-advice 'evil-search-function 'around 'pcre-mode) + (ad-activate 'evil-search-function))) + +(defun pcre-decorate-search-function (real-search-function) + (lambda (string &optional bound noerror count) + (funcall real-search-function + (pcre-to-elisp/cached string) + bound noerror count))) + +;;; Other hooks and defadvices + +;;;###autoload +(defun pcre-query-replace-regexp () + "Perform `query-replace-regexp' using PCRE syntax. + +Consider using `pcre-mode' instead of this function." + (interactive) + (let ((old-pcre-mode pcre-mode)) + (unwind-protect + (progn + (pcre-mode +1) + (call-interactively #'query-replace-regexp)) + (pcre-mode (if old-pcre-mode 1 0))))) + + +(defadvice add-to-history + (before pcre-mode (history-var newelt &optional maxelt keep-all) disable) + "Add the original PCRE to query-replace history in `pcre-mode'." + (when (eq history-var query-replace-from-history-variable) + (let ((original (gethash newelt pcre-mode-reverse-cache))) + (when original + (ad-set-arg 1 original))))) + +(defadvice query-replace-descr + (before pcre-mode (from) disable) + "Use the original PCRE in Isearch prompts in `pcre-mode'." + (let ((original (gethash from pcre-mode-reverse-cache))) + (when original + (ad-set-arg 0 original)))) + +;;; The `interactive' specs of the following functions are lifted +;;; wholesale from the original built-ins, which see. +(defadvice read-regexp + (around pcre-mode first (prompt &optional defaults history) disable) + "Read regexp using PCRE syntax and convert to Elisp equivalent." + (ad-set-arg 0 (concat "[PCRE] " prompt)) + (minibuffer-with-setup-hook + #'rxt--read-pcre-mode + ad-do-it) + (setq ad-return-value + (pcre-to-elisp/cached ad-return-value))) + +(defadvice align-regexp + (before pcre-mode first (beg end regexp &optional group spacing repeat) disable) + "Read regexp using PCRE syntax and convert to Elisp equivalent." + (interactive + (append + (list (region-beginning) (region-end)) + (if current-prefix-arg + (list (rxt-pcre-to-elisp + (read-string "Complex align using PCRE regexp: " + "(\\s*)")) + (string-to-number + (read-string + "Parenthesis group to modify (justify if negative): " "1")) + (string-to-number + (read-string "Amount of spacing (or column if negative): " + (number-to-string align-default-spacing))) + (y-or-n-p "Repeat throughout line? ")) + (list (concat "\\(\\s-*\\)" + (rxt-pcre-to-elisp + (read-string "Align PCRE regexp: "))) + 1 align-default-spacing nil))))) + +(defadvice ibuffer-do-replace-regexp + (before pcre-mode first (from-str to-str) disable) + "Read regexp using PCRE syntax and convert to Elisp equivalent." + (interactive + (let* ((from-str (read-from-minibuffer "[PCRE] Replace regexp: ")) + (to-str (read-from-minibuffer (concat "[PCRE] Replace " from-str " with: ")))) + (list (rxt-pcre-to-elisp from-str) to-str)))) + +(defadvice find-tag-regexp + (before pcre-mode first (regexp &optional next-p other-window) disable) + "Read regexp using PCRE syntax and convert to Elisp equivalent. +Perform `find-tag-regexp' using emulated PCRE regexp syntax." + (interactive + (let ((args (find-tag-interactive "[PCRE] Find tag regexp: " t))) + (list (rxt-pcre-to-elisp (nth 0 args)) + (nth 1 args) (nth 2 args))))) + +(defadvice sort-regexp-fields + (before pcre-mode first (reverse record-regexp key-regexp beg end) disable) + "Read regexp using PCRE syntax and convert to Elisp equivalent." + (interactive "P\nsPCRE regexp specifying records to sort: \n\ +sPCRE regexp specifying key within record: \nr") + (ad-set-arg 1 (rxt-pcre-to-elisp (ad-get-arg 1))) + (ad-set-arg 2 (rxt-pcre-to-elisp (ad-get-arg 2)))) + + + +;;; Commands that take Emacs-style regexps as input + +;;;###autoload +(defun rxt-elisp-to-pcre (regexp) + "Translate REGEXP, a regexp in Emacs Lisp syntax, to Perl-compatible syntax. + +Interactively, reads the regexp in one of three ways. With a +prefix arg, reads from minibuffer without string escaping, like +`query-replace-regexp'. Without a prefix arg, uses the text of +the region if it is active. Otherwise, uses the result of +evaluating the sexp before point (which might be a string regexp +literal or an expression that produces a string). + +Displays the translated PCRE regexp in the echo area and copies +it to the kill ring. + +Emacs regexp features such as syntax classes which cannot be +translated to PCRE will cause an error." + (interactive (rxt-interactive/elisp)) + (rxt-return-pcre (rxt-adt->pcre (rxt-parse-elisp regexp)))) + +;;;###autoload +(defun rxt-elisp-to-rx (regexp) + "Translate REGEXP, a regexp in Emacs Lisp syntax, to `rx' syntax. + +See `rxt-elisp-to-pcre' for a description of the interactive +behavior and `rx' for documentation of the S-expression based +regexp syntax." + (interactive (rxt-interactive/elisp)) + (rxt-return-sexp (rxt-adt->rx (rxt-parse-elisp regexp)))) + +;;;###autoload +(defun rxt-elisp-to-strings (regexp) + "Return a list of all strings matched by REGEXP, an Emacs Lisp regexp. + +See `rxt-elisp-to-pcre' for a description of the interactive behavior. + +This is useful primarily for getting back the original list of +strings from a regexp generated by `regexp-opt', but it will work +with any regexp without unbounded quantifiers (*, +, {2, } and so +on). + +Throws an error if REGEXP contains any infinite quantifiers." + (interactive (rxt-interactive/elisp)) + (rxt-return-sexp (rxt-adt->strings (rxt-parse-elisp regexp)))) + +;;;###autoload +(defun rxt-toggle-elisp-rx () + "Toggle the regexp near point between Elisp string and rx syntax." + (interactive) + ;; First, position point before the regex form near point (either + ;; a string literal or a list beginning `rx' or `rx-to-string'). + (let* ((context (syntax-ppss)) + (string-start (nth 8 context))) + (cond (string-start (goto-char string-start)) + ((looking-back "\"") (backward-sexp)) + ((looking-at "\"") nil) + (t + ;; Search backwards, leaving point in place on error + (goto-char + (save-excursion + (skip-syntax-forward "-") + (while (not (looking-at + (rx "(" (or "rx" "rx-to-string") symbol-end))) + (backward-up-list)) + (point)))))) + + ;; Read and replace the regex following point + (let* ((regex (read (current-buffer))) + (print-escape-newlines t)) + (save-excursion + (if (listp regex) + ;; Replace rx form with string value + (prin1 (eval regex) (current-buffer)) + ;; Pretty-print rx form + (save-restriction + (let* ((start (point)) + (rx-syntax (rxt-elisp-to-rx regex)) + (rx-form + (pcase rx-syntax + (`(seq . ,rest) `(rx . ,rest)) + (form `(rx ,form))))) + (rxt-print rx-form) + (narrow-to-region start (point))) + (pp-buffer) + ;; remove the extra newline that pp-buffer inserts + (goto-char (point-max)) + (delete-region + (point) + (save-excursion (skip-chars-backward " \t\n") (point)))))) + (kill-sexp -1) + (indent-pp-sexp))) + + + +;;; Commands that translate PCRE to other formats + +;;;###autoload +(defun rxt-pcre-to-elisp (pcre &optional flags) + "Translate PCRE, a regexp in Perl-compatible syntax, to Emacs Lisp. + +Interactively, uses the contents of the region if it is active, +otherwise reads from the minibuffer. Prints the Emacs translation +in the echo area and copies it to the kill ring. + +PCRE regexp features that cannot be translated into Emacs syntax +will cause an error. See the commentary section of pcre2el.el for +more details." + (interactive (rxt-interactive/pcre)) + (rxt-return-emacs-regexp + (rx-to-string + (rxt-pcre-to-rx (rxt--add-flags pcre flags)) + t))) + +;;;###autoload +(defalias 'pcre-to-elisp 'rxt-pcre-to-elisp) + +;;;###autoload +(defun rxt-pcre-to-rx (pcre &optional flags) + "Translate PCRE, a regexp in Perl-compatible syntax, to `rx' syntax. + +See `rxt-pcre-to-elisp' for a description of the interactive behavior." + (interactive (rxt-interactive/pcre)) + (rxt-return-sexp (rxt-adt->rx (rxt-parse-pcre (rxt--add-flags pcre flags))))) + +;;;###autoload +(defun rxt-pcre-to-strings (pcre &optional flags) + "Return a list of all strings matched by PCRE, a Perl-compatible regexp. + +See `rxt-elisp-to-pcre' for a description of the interactive +behavior and `rxt-elisp-to-strings' for why this might be useful. + +Throws an error if PCRE contains any infinite quantifiers." + (interactive (rxt-interactive/pcre)) + (rxt-return-sexp (rxt-adt->strings (rxt-parse-pcre (rxt--add-flags pcre flags))))) + +(defun rxt--add-flags (pcre flags) + "Prepend FLAGS to PCRE." + (if (not (zerop (length flags))) + (concat "(?" flags ")" pcre) + pcre)) + + +;;; Regexp explaining functions to display pretty-printed rx syntax + +;; When the `rxt-explain' flag is non-nil, `rxt-adt->rx' records +;; location information for each element of the generated `rx' form, +;; allowing highlighting corresponding pieces of syntax at point. +(defvar rxt-explain nil) + +(defvar rxt-highlight-overlays nil + "List of active location-highlighting overlays in rxt-help-mode buffer.") + +;;;###autoload +(defun rxt-explain-elisp (regexp) + "Insert the pretty-printed `rx' syntax for REGEXP in a new buffer. + +REGEXP is a regular expression in Emacs Lisp syntax. See +`rxt-elisp-to-pcre' for a description of how REGEXP is read +interactively." + (interactive (rxt-interactive/elisp)) + (let ((rxt-explain t) + (rxt-verbose-rx-translation rxt-explain-verbosely)) + (rxt-pp-rx regexp (rxt-elisp-to-rx regexp)))) + +;;;###autoload +(defun rxt-explain-pcre (regexp &optional flags) + "Insert the pretty-printed `rx' syntax for REGEXP in a new buffer. + +REGEXP is a regular expression in PCRE syntax. See +`rxt-pcre-to-elisp' for a description of how REGEXP is read +interactively." + (interactive (rxt-interactive/pcre)) + (let ((rxt-explain t) + (rxt-verbose-rx-translation rxt-explain-verbosely)) + (rxt-pp-rx regexp (rxt-pcre-to-rx regexp flags)))) + +;;;###autoload +(defun rxt-quote-pcre (text) + "Return a PCRE regexp which matches TEXT literally. + +Any PCRE metacharacters in TEXT will be quoted with a backslash." + (rxt-adt->pcre (rxt-string text))) + + +;;;; Commands that depend on the major mode in effect + +;; Macro: interactively call one of two functions depending on the +;; major mode +(defmacro rxt-mode-dispatch (elisp-function pcre-function) + `(if (memq major-mode '(emacs-lisp-mode lisp-interaction-mode)) + (call-interactively #',elisp-function) + (call-interactively #',pcre-function))) + +;;;###autoload +(defun rxt-explain () + "Pop up a buffer with pretty-printed `rx' syntax for the regex at point. + +Chooses regex syntax to read based on current major mode, calling +`rxt-explain-elisp' if buffer is in `emacs-lisp-mode' or +`lisp-interaction-mode', or `rxt-explain-pcre' otherwise." + (interactive) + (rxt-mode-dispatch rxt-explain-elisp rxt-explain-pcre)) + +;;;###autoload +(defun rxt-convert-syntax () + "Convert regex at point to other kind of syntax, depending on major mode. + +For buffers in `emacs-lisp-mode' or `lisp-interaction-mode', +calls `rxt-elisp-to-pcre' to convert to PCRE syntax. Otherwise, +calls `rxt-pcre-to-elisp' to convert to Emacs syntax. + +The converted syntax is displayed in the echo area and copied to +the kill ring; see the two functions named above for details." + (interactive) + (rxt-mode-dispatch rxt-elisp-to-pcre rxt-pcre-to-elisp)) + +;;;###autoload +(defun rxt-convert-to-rx () + "Convert regex at point to RX syntax. Chooses Emacs or PCRE syntax by major mode." + (interactive) + (rxt-mode-dispatch rxt-elisp-to-rx rxt-pcre-to-rx)) + +;;;###autoload +(defun rxt-convert-to-strings () + "Convert regex at point to RX syntax. Chooses Emacs or PCRE syntax by major mode." + (interactive) + (rxt-mode-dispatch rxt-elisp-to-strings rxt-pcre-to-strings)) + + + +;;; Minor mode and keybindings + +(defvar rxt-mode-map + (let ((map (make-sparse-keymap))) + ;; Generic + (define-key map (kbd "C-c / /") 'rxt-explain) + (define-key map (kbd "C-c / c") 'rxt-convert-syntax) + (define-key map (kbd "C-c / x") 'rxt-convert-to-rx) + (define-key map (kbd "C-c / '") 'rxt-convert-to-strings) + + ;; From PCRE + (define-key map (kbd "C-c / p /") 'rxt-explain-pcre) + (define-key map (kbd "C-c / p e") 'rxt-pcre-to-elisp) + (define-key map (kbd "C-c / p x") 'rxt-pcre-to-rx) + (define-key map (kbd "C-c / p '") 'rxt-pcre-to-strings) + + ;; From Elisp + (define-key map (kbd "C-c / e /") 'rxt-explain-elisp) + (define-key map (kbd "C-c / e p") 'rxt-elisp-to-pcre) + (define-key map (kbd "C-c / e x") 'rxt-elisp-to-rx) + (define-key map (kbd "C-c / e '") 'rxt-elisp-to-strings) + (define-key map (kbd "C-c / e t") 'rxt-toggle-elisp-rx) + (define-key map (kbd "C-c / t") 'rxt-toggle-elisp-rx) + + ;; Search + (define-key map (kbd "C-c / %") 'pcre-query-replace-regexp) + + map) + "Keymap for `rxt-mode'.") + +;;;###autoload +(define-minor-mode rxt-mode + "Regex translation utilities." nil nil) + +;;;###autoload +(defun turn-on-rxt-mode () + "Turn on `rxt-mode' in the current buffer." + (interactive) + (rxt-mode 1)) + +;;;###autoload +(define-globalized-minor-mode rxt-global-mode rxt-mode + turn-on-rxt-mode) + + +;;;; Syntax explanations + +;; Major mode for displaying pretty-printed S-exp syntax +(define-derived-mode rxt-help-mode emacs-lisp-mode "Regexp Explain" + (setq buffer-read-only t) + (add-hook 'post-command-hook 'rxt-highlight-text nil t) + (rxt-highlight-text)) + +;; Hack: stop paredit-mode interfering with `rxt-print' +(eval-when-compile (declare-function paredit-mode "paredit.el")) +(add-hook 'rxt-help-mode-hook + (lambda () + (if (and (boundp 'paredit-mode) + paredit-mode) + (paredit-mode 0)))) + +(define-key rxt-help-mode-map "q" 'quit-window) +(define-key rxt-help-mode-map "z" 'kill-this-buffer) +(define-key rxt-help-mode-map "n" 'next-line) +(define-key rxt-help-mode-map "p" 'previous-line) +(define-key rxt-help-mode-map "f" 'forward-list) +(define-key rxt-help-mode-map "b" 'backward-list) +(define-key rxt-help-mode-map "u" 'backward-up-list) +(define-key rxt-help-mode-map "d" 'down-list) + +(defvar rxt--print-with-overlays nil) +(defvar rxt--print-depth 0) + +(defconst rxt--print-char-alist + '((?\a . "\\a") + (?\b . "\\b") + (?\t . "\\t") + (?\n . "\\n") + (?\v . "\\v") + (?\f . "\\f") + (?\r . "\\r") + (?\e . "\\e") + (?\s . "\\s") + (?\\ . "\\\\") + (?\d . "\\d")) + "Alist of characters to print using an escape sequence in Elisp source. +See (info \"(elisp) Basic Char Syntax\").") + +(defconst rxt--whitespace-display-regexp + (rx-to-string `(any ,@(mapcar #'car rxt--print-char-alist)))) + +(defconst rxt--print-special-chars + '(?\( ?\) ?\\ ?\| ?\; ?\' ?\` ?\" ?\# ?\. ?\,) + "Characters which require a preceding backslash in Elisp source. +See (info \"(elisp) Basic Char Syntax\").") + +(defun rxt-pp-rx (regexp rx) + "Display string regexp REGEXP with its `rx' form RX in an `rxt-help-mode' buffer." + (with-current-buffer (get-buffer-create "* Regexp Explain *") + (let ((print-escape-newlines t) + (inhibit-read-only t)) + (erase-buffer) + (rxt-help-mode) + (insert (rxt--propertize-whitespace regexp)) + (newline 2) + (save-excursion + (let ((sexp-begin (point)) + (rxt--print-with-overlays t)) + (rxt-print rx) + (narrow-to-region sexp-begin (point)) + (pp-buffer) + (widen))) + (rxt-highlight-text)) + (pop-to-buffer (current-buffer)))) + +(cl-defun rxt-print (rx) + "Insert RX, an `rx' form, into the current buffer, optionally adding overlays. + +Similar to `print' or `prin1', but ensures that `rx' forms are +printed readably, using character or integer syntax depending on +context. + +If `rxt--print-with-overlays' is non-nil, also creates overlays linking +elements of RX to their corresponding locations in the source +string (see `rxt-explain-elisp', `rxt-explain-pcre' and +`rxt--make-help-overlays')." + (let ((start (point))) + (cl-typecase rx + (cons + (pcase rx + (`(,(and (or `repeat `**) head) + ,(and (pred integerp) from) + ,(and (pred integerp) to) + . ,rest) + (insert (format "(%s %d %d" head from to)) + (rxt--print-list-tail rest)) + (`(,(and (or `repeat `= `>=) head) + ,(and (pred integerp) n) + . ,rest) + (insert (format "(%s %d" head n)) + (rxt--print-list-tail rest)) + (_ + (rxt--print-list-tail rx t)))) + (symbol + (cl-case rx + ;; `print' escapes the ? characters in the rx operators *? + ;; and +?, but this looks bad and is not strictly necessary: + ;; (eq (read "*?") (read "*\\?")) => t + ;; (eq (read "+?") (read "+\\?")) => t + ((*? +?) (insert (symbol-name rx))) + (t (prin1 rx (current-buffer))))) + (string + (insert (rxt--propertize-whitespace (prin1-to-string rx)))) + (character + (cond + ((eq ? rx) + (insert "?")) + ((memq rx rxt--print-special-chars) + (insert "?\\" rx)) + ((assq rx rxt--print-char-alist) + (insert "?" (assoc-default rx rxt--print-char-alist))) + (t + (insert "?" (char-to-string rx))))) + (t + (prin1 rx (current-buffer)))) + (when rxt--print-with-overlays + (rxt--make-help-overlays rx start (point))))) + +(defun rxt--print-list-tail (tail &optional open-paren) + (let ((rxt--print-depth (1+ rxt--print-depth))) + (let ((done nil)) + (while (not done) + (cl-typecase tail + (null + (insert ")") + (setq done t)) + (cons + (if open-paren + (progn + (insert "(") + (setq open-paren nil)) + (insert " ")) + (rxt-print (car tail)) + (setq tail (cdr tail))) + (t + (insert " . ") + (rxt-print tail) + (insert ")") + (setq done t))))))) + +(defun rxt--make-help-overlays (rx start end) + (let ((location (rxt-location rx))) + (when (and location + (rxt-location-start location) + (rxt-location-end location)) + (let* ((sexp-begin (copy-marker start t)) + (sexp-end (copy-marker end)) + (sexp-bounds (list sexp-begin sexp-end)) + + (source-begin (1+ (rxt-location-start location))) + (source-end (1+ (rxt-location-end location))) + (source-bounds (list source-begin source-end)) + + (bounds (list source-bounds sexp-bounds)) + + (sexp-ol (make-overlay sexp-begin sexp-end (current-buffer) t nil)) + (source-ol (make-overlay source-begin source-end (current-buffer) t nil))) + (dolist (ol (list sexp-ol source-ol)) + (overlay-put ol 'priority rxt--print-depth) + (overlay-put ol 'rxt-bounds bounds)))))) + +(defun rxt--propertize-whitespace (string) + (let ((string (copy-sequence string)) + (start 0)) + (while (string-match rxt--whitespace-display-regexp string start) + (put-text-property (match-beginning 0) (match-end 0) + 'display + (assoc-default (string-to-char (match-string 0 string)) + rxt--print-char-alist) + string) + (setq start (match-end 0))) + string)) + +(defun rxt-highlight-text () + "Highlight the regex syntax at point and its corresponding RX/string form." + (let ((all-bounds (get-char-property (point) 'rxt-bounds))) + (mapc #'delete-overlay rxt-highlight-overlays) + (setq rxt-highlight-overlays nil) + (dolist (bounds all-bounds) + (cl-destructuring-bind (begin end) bounds + (let ((overlay (make-overlay begin end))) + (push overlay rxt-highlight-overlays) + (overlay-put overlay 'face 'rxt-highlight-face)))))) + + +;;;; Error handling + +(if (fboundp 'define-error) + (define-error 'rxt-invalid-regexp "Invalid regexp" 'invalid-regexp) + (put 'rxt-invalid-regexp + 'error-conditions + '(rxt-invalid-regexp invalid-regexp error)) + (put 'rxt-invalid-regexp 'error-message "Invalid regexp")) + +(defun rxt-error (&rest format-args) + (signal 'rxt-invalid-regexp (list (apply #'format format-args)))) + + +;;;; Regexp syntax tree data type + +;; Base class from which other elements of the syntax-tree inherit +(cl-defstruct rxt-syntax-tree) + +;; Struct representing the original source location +(cl-defstruct rxt-location + source ; Either a string or a buffer + start end ; Offsets, 0- or 1-indexed as appropriate + ) + +(defun rxt-location-text (location) + (if (not (rxt-location-p location)) + nil + (let ((start (rxt-location-start location)) + (end (rxt-location-end location)) + (source (rxt-location-source location))) + (cond + ((buffer-live-p source) + (with-current-buffer source + (buffer-substring-no-properties start end))) + ((stringp source) + (substring source start end)) + (t nil))))) + +;; Hash table mapping from syntax-tree elements to source locations. +(defvar rxt-location-map (make-hash-table :weakness 'key)) + +(defun rxt-location (object) + (gethash object rxt-location-map)) + +(gv-define-setter rxt-location (value object) + `(puthash ,object ,value rxt-location-map)) + +(defun rxt-source-text (object) + (rxt-location-text (rxt-location object))) + +(defun rxt-to-string (tree) + "Return a readable representation of TREE, a regex syntax-tree object." + (or (rxt-source-text tree) + (let ((print-level 1)) + (prin1-to-string tree)))) +(defalias 'rxt-syntax-tree-readable 'rxt-to-string) + +;; FIXME +(defvar rxt-pcre-case-fold nil) + +;; Literal string +(cl-defstruct + (rxt-string + (:constructor rxt-string (chars &optional case-fold)) + (:include rxt-syntax-tree)) + chars + (case-fold rxt-pcre-case-fold)) + +(defun rxt-empty-string () + (rxt-string "")) + +(defun rxt-trivial-p (re) + (and (rxt-string-p re) + (equal (rxt-string-chars re) ""))) + +;;; Other primitives +(cl-defstruct (rxt-primitive + (:constructor rxt-primitive (pcre rx)) + (:include rxt-syntax-tree)) + pcre rx) + +(defun rxt-bos () (rxt-primitive "\\A" 'bos)) +(defun rxt-eos () (rxt-primitive "\\Z" 'eos)) + +(defun rxt-bol () (rxt-primitive "^" 'bol)) +(defun rxt-eol () (rxt-primitive "$" 'eol)) + +;; FIXME +(defun rxt-anything () (rxt-primitive "." 'anything)) +(defun rxt-nonl () (rxt-primitive "." 'nonl)) + +(defun rxt-word-boundary () (rxt-primitive "\\b" 'word-boundary)) +(defun rxt-not-word-boundary () (rxt-primitive "\\B" 'not-word-boundary)) + +(defun rxt-wordchar () (rxt-primitive "\\w" 'wordchar)) +(defun rxt-not-wordchar () (rxt-primitive "\\W" 'not-wordchar)) + +(defun rxt-symbol-start () (rxt-primitive nil 'symbol-start)) +(defun rxt-symbol-end () (rxt-primitive nil 'symbol-end)) + +(defun rxt-bow () (rxt-primitive nil 'bow)) +(defun rxt-eow () (rxt-primitive nil 'eow)) + +;;; Sequence +(cl-defstruct + (rxt-seq + (:constructor make-rxt-seq (elts)) + (:include rxt-syntax-tree)) + elts) + +;; Slightly smart sequence constructor: +;; - Flattens nested sequences +;; - Drops trivial "" elements +;; - Empty sequence => "" +;; - Singleton sequence is reduced to its one element. +(defun rxt-seq (&rest res) ; Flatten nested seqs & drop ""'s. + (let ((res (rxt-seq-flatten res))) + (if (consp res) + (if (consp (cdr res)) + (make-rxt-seq res) ; General case + (car res)) ; Singleton sequence + (rxt-empty-string)))) ; Empty seq -- "" + +(defun rxt-seq-flatten (res) + (if (consp res) + (let ((re (car res)) + (tail (rxt-seq-flatten (cdr res)))) + (cond ((rxt-seq-p re) ; Flatten nested seqs + (append (rxt-seq-flatten (rxt-seq-elts re)) tail)) + ((rxt-trivial-p re) tail) ; Drop trivial elts + ((and (rxt-string-p re) ; Flatten strings + (consp tail) + (rxt-string-p (car tail))) + (cons + (rxt-string-concat re (car tail)) + (cdr tail))) + (t (cons re tail)))) + '())) + +(defun rxt-string-concat (str1 str2) + (if (not (eq (rxt-string-case-fold str1) + (rxt-string-case-fold str2))) + (make-rxt-seq (list str1 str2)) + (let ((result + (rxt-string (concat (rxt-string-chars str1) + (rxt-string-chars str2)) + (rxt-string-case-fold str1))) + (first (rxt-location str1)) + (last (rxt-location str2))) + (when (and first last) + (setf (rxt-location result) + (make-rxt-location :source (rxt-location-source first) + :start (rxt-location-start first) + :end (rxt-location-end last)))) + result))) + +;;; Choice (alternation/union) +(cl-defstruct + (rxt-choice + (:constructor make-rxt-choice (elts)) + (:include rxt-syntax-tree)) + elts) + +;;; The empty choice represents a regexp that never matches in any context +(defvar rxt-empty (make-rxt-choice nil)) +(defun rxt-empty-p (re) + (or + (and (rxt-choice-p re) + (null (rxt-choice-elts re))) + (rxt-empty-char-set-p re))) + +(defun rxt-choice (&rest alternatives) + "Construct the alternation (union) of several regexps. + +ALTERNATIVES should be a list of `rxt-syntax-tree' objects. +The return value is an `rxt-choice' object representing a regexp +which matches any one of ALTERNATIVES, but simplified in the +following ways: + +- If ALTERNATIVES contains only one element, it is returned unchanged. + +- All existing `rxt-choice' elements in ALTERNATIVES are replaced + by a flat list of their subexpressions: symbolically, + a|(b|(c|d)) is replaced by a|b|c|d + +- All character sets and single-character strings in ALTERNATIVES + are combined together into one or two character sets, + respecting case-folding behaviour." + (cl-destructuring-bind (other-elements char-set case-fold-char-set) + (rxt--simplify-alternatives alternatives) + (let ((simplified-alternatives + (append (if (not (rxt-empty-p char-set)) + (list char-set) + '()) + (if (not (rxt-empty-p case-fold-char-set)) + (list case-fold-char-set) + '()) + other-elements))) + (pcase simplified-alternatives + (`() + rxt-empty) + (`(,element) + element) + (_ + (make-rxt-choice simplified-alternatives)))))) + +(defun rxt--simplify-alternatives (alternatives) + "Simplify a set of regexp alternatives. + +ALTERNATIVES should be a list of `rxt-syntax-tree' objects to be combined +into an `rxt-choice' structure. The result is a three-element +list (OTHER-ELEMENTS CHAR-SET CASE-FOLDED-CHAR-SET): + +- CHAR-SET is an `rxt-char-set-union' containing the union of all + case-sensitive character sets and single-character strings in + RES. + +- CASE-FOLDED-CHAR-SET is similar but combines all the + case-insensitive character sets and single-character strings. + +- OTHER-ELEMENTS is a list of all other elements, with all + `rxt-choice' structures replaced by a flat list of their + component subexpressions." + (if (null alternatives) + (list '() + (make-rxt-char-set-union :case-fold nil) + (make-rxt-char-set-union :case-fold t)) + (let* ((re (car alternatives))) + (cl-destructuring-bind (tail char-set case-fold-char-set) + (rxt--simplify-alternatives (cdr alternatives)) + (cond ((rxt-choice-p re) ; Flatten nested choices + (list + (append (rxt-choice-elts re) tail) + char-set + case-fold-char-set)) + + ((rxt-empty-p re) ; Drop empty re's. + (list tail char-set case-fold-char-set)) + + ((rxt-char-set-union-p re) ; Fold char sets together + (if (rxt-char-set-union-case-fold re) + (list tail + char-set + (rxt-char-set-union case-fold-char-set re)) + (list tail + (rxt-char-set-union char-set re) + case-fold-char-set))) + + ((and (rxt-string-p re) ; Same for 1-char strings + (= 1 (length (rxt-string-chars re)))) + (if (rxt-string-case-fold re) + (list tail + char-set + (rxt-char-set-union case-fold-char-set re)) + (list tail + (rxt-char-set-union char-set re) + case-fold-char-set))) + + (t ; Otherwise. + (list (cons re tail) char-set case-fold-char-set))))))) + +;;; Repetition +(cl-defstruct (rxt-repeat + (:include rxt-syntax-tree)) + from to body greedy) + +(cl-defun rxt-repeat (from to body &optional (greedy t)) + (if (equal to 0) + (rxt-empty-string) + (make-rxt-repeat :from from :to to + :body body :greedy greedy))) + +;;; Submatch +(cl-defstruct + (rxt-submatch + (:constructor rxt-submatch (body)) + (:include rxt-syntax-tree)) + body) + +;;; Numbered submatch (Emacs only) +(cl-defstruct + (rxt-submatch-numbered + (:constructor rxt-submatch-numbered (n body)) + (:include rxt-syntax-tree)) + n + body) + +;;; Backreference +(cl-defstruct + (rxt-backref + (:constructor rxt-backref (n)) + (:include rxt-syntax-tree)) + n) + +;;; Syntax classes (Emacs only) +(cl-defstruct (rxt-syntax-class + (:include rxt-syntax-tree)) + symbol) + +(defun rxt-syntax-class (symbol) + (if (assoc symbol rx-syntax) + (make-rxt-syntax-class :symbol symbol) + (rxt-error "Invalid syntax class symbol `%s'" symbol))) + +;;; Character categories (Emacs only) +(cl-defstruct (rxt-char-category + (:include rxt-syntax-tree)) + symbol) + +(defun rxt-char-category (symbol) + (if (assoc symbol rx-categories) + (make-rxt-char-category :symbol symbol) + (rxt-error "Invalid character category symbol `%s'" symbol))) + + +;;; Char sets +;; <rxt-char-set> ::= <rxt-char-set-union> +;; | <rxt-char-set-negation> +;; | <rxt-char-set-intersection> + +(cl-defstruct (rxt-char-set (:include rxt-syntax-tree))) + +;; An rxt-char-set-union represents the union of any number of +;; characters, character ranges, and POSIX character classes: anything +;; that can be represented in string notation as a class [ ... ] +;; without the negation operator. +(cl-defstruct (rxt-char-set-union + (:include rxt-char-set)) + chars ; list of single characters + ranges ; list of ranges (from . to) + classes ; list of character classes + (case-fold rxt-pcre-case-fold)) + +;; Test for empty character set +(defun rxt-empty-char-set-p (cset) + (and (rxt-char-set-union-p cset) + (null (rxt-char-set-union-chars cset)) + (null (rxt-char-set-union-ranges cset)) + (null (rxt-char-set-union-classes cset)))) + +;; Simple union constructor +(defun rxt-char-set-union (&rest items) + "Construct an regexp character set representing the union of ITEMS. + +Each element of ITEMS may be either: a character; a +single-character string; a single-character `rxt-string' object; +a cons, (FROM . TO) representing a range of characters; a symbol, +representing a named character class; or an `rxt-char-set-union' +object. All `rxt-char-set-union' objects in ITEMS must have the +same `case-fold' property." + (let ((chars '()) + (ranges '()) + (classes '()) + (case-fold 'undetermined)) + (dolist (item items) + (cl-etypecase item + (character + (push item chars)) + + (string + (cl-assert (= 1 (length item))) + (push (string-to-char item) chars)) + + (rxt-string + (cl-assert (= 1 (length (rxt-string-chars item)))) + (push (string-to-char (rxt-string-chars item)) chars)) + + (cons ; range (from . to) + (cl-check-type (car item) character) + (cl-check-type (cdr item) character) + (push item ranges)) + + (symbol ; named character class + (push item classes)) + + (rxt-char-set-union + (if (eq case-fold 'undetermined) + (setq case-fold (rxt-char-set-union-case-fold item)) + (unless (eq case-fold (rxt-char-set-union-case-fold item)) + (error "Cannot construct union of char-sets with unlike case-fold setting: %S" item))) + (setq chars (nconc chars (rxt-char-set-union-chars item))) + (setq ranges (nconc ranges (rxt-char-set-union-ranges item))) + (setq classes (nconc classes (rxt-char-set-union-classes item)))))) + + (make-rxt-char-set-union :chars chars :ranges ranges :classes classes + :case-fold (if (eq case-fold 'undetermined) + rxt-pcre-case-fold + case-fold)))) + +(defun rxt--all-char-set-union-chars (char-set) + "Return a list of all characters in CHAR-SET." + (cl-assert (rxt-char-set-union-p char-set)) + (append + (rxt-char-set-union-chars char-set) + (cl-loop for (start . end) in (rxt-char-set-union-ranges char-set) + nconc (cl-loop for char from start to end collect char)))) + +(defun rxt--simplify-char-set (char-set &optional case-fold-p) + "Return a minimal char-set to match the same characters as CHAR-SET. + +With optional argument CASE-FOLD-P, return a char-set which +emulates case-folding behaviour by including both uppercase and +lowercase versions of all characters in CHAR-SET." + (cl-assert (rxt-char-set-union-p char-set)) + (let* ((classes (rxt-char-set-union-classes char-set)) + (all-chars + (if case-fold-p + (cl-loop for char in (rxt--all-char-set-union-chars char-set) + nconc (list (upcase char) (downcase char))) + (rxt--all-char-set-union-chars char-set))) + (all-ranges + (rxt--extract-ranges (rxt--remove-redundant-chars all-chars classes)))) + (let ((singletons nil) + (ranges nil)) + (cl-loop for (start . end) in all-ranges + do + (cond ((= start end) (push start singletons)) + ((= (1+ start) end) + (push start singletons) + (push end singletons)) + (t (push (cons start end) ranges)))) + (make-rxt-char-set-union :chars (nreverse singletons) + :ranges (nreverse ranges) + :classes classes + :case-fold (if case-fold-p + nil + (rxt-char-set-union-case-fold char-set)))))) + +(defun rxt--remove-redundant-chars (chars classes) + "Remove all characters which match a character class in CLASSES from CHARS." + (if (null classes) + chars + (string-to-list + (replace-regexp-in-string + (rx-to-string `(any ,@classes)) + "" + (apply #'string chars))))) + +(defun rxt--extract-ranges (chars) + "Return a list of all contiguous ranges in CHARS. + +CHARS should be a list of characters (integers). The return +value is a list of conses (START . END) representing ranges, such +that the union of all the ranges represents the same of +characters as CHARS. + +Example: + (rxt--extract-ranges (list ?a ?b ?c ?q ?x ?y ?z)) + => ((?a . ?c) (?q . ?q) (?x . ?z))" + (let ((array + (apply #'vector + (cl-remove-duplicates + (sort (copy-sequence chars) #'<))))) + (cl-labels + ((recur (start end) + (if (< end start) + nil + (let ((min (aref array start)) + (max (aref array end))) + (if (= (- max min) (- end start)) + (list (cons min max)) + (let* ((split-point (/ (+ start end) 2)) + (left (recur start split-point)) + (right (recur (1+ split-point) end))) + (merge left right)))))) + (merge (left right) + (cond ((null left) right) + ((null right) left) + (t + (let ((last-left (car (last left))) + (first-right (car right))) + (if (= (1+ (cdr last-left)) + (car first-right)) + (append (cl-subseq left 0 -1) + (list + (cons (car last-left) + (cdr first-right))) + (cl-subseq right 1)) + (append left right))))))) + (recur 0 (1- (length array)))))) + +;;; Set complement of character set, syntax class, or character +;;; category + +;; In general, all character sets that can be represented in string +;; notation as [^ ... ] (but see `rxt-char-set-intersection', below), plus +;; Emacs' \Sx and \Cx constructions. +(cl-defstruct (rxt-char-set-negation + (:include rxt-char-set)) + elt) + +(defun rxt-negate (char-set) + "Construct the logical complement (negation) of CHAR-SET. + +CHAR-SET may be any of the following types: `rxt-char-set-union', +`rxt-syntax-class', `rxt-char-category', or `rxt-char-set-negation'." + (cl-etypecase char-set + ((or rxt-char-set-union rxt-syntax-class rxt-char-category) + (make-rxt-char-set-negation :elt char-set)) + + (rxt-char-set-negation + (rxt-char-set-negation-elt char-set)))) + +;;; Intersections of char sets + +;; These are difficult to represent in general, but can be constructed +;; in Perl using double negation; for example: [^\Wabc] means the set +;; complement of [abc] with respect to the universe of "word +;; characters": (& (~ (~ word)) (~ ("abc"))) == (& word (~ ("abc"))) +;; == (- word ("abc")) + +(cl-defstruct (rxt-char-set-intersection + (:include rxt-char-set)) + elts) + +;; Intersection constructor +(defun rxt-char-set-intersection (&rest charsets) + (let ((elts '()) + (cmpl (make-rxt-char-set-union))) + (dolist (cset (rxt-int-flatten charsets)) + (cond + ((rxt-char-set-negation-p cset) + ;; Fold negated charsets together: ~A & ~B = ~(A|B) + (setq cmpl (rxt-char-set-union cmpl (rxt-char-set-negation-elt cset)))) + + ((rxt-char-set-union-p cset) + (push cset elts)) + + (t + (rxt-error "Can't take intersection of non-character-set %S" cset)))) + + (if (null elts) + (rxt-negate cmpl) + (unless (rxt-empty-char-set-p cmpl) + (push (rxt-negate cmpl) elts)) + (if (null (cdr elts)) + (car elts) ; singleton case + (make-rxt-char-set-intersection :elts elts))))) + +;; Constructor helper: flatten nested intersections +(defun rxt-int-flatten (csets) + (if (consp csets) + (let ((cset (car csets)) + (tail (rxt-int-flatten (cdr csets)))) + (if (rxt-char-set-intersection-p cset) + (append (rxt-int-flatten (rxt-char-set-intersection-elts cset)) tail) + (cons cset tail))) + '())) + + + +;;;; Macros for building the parser + +(defmacro rxt-token-case (&rest cases) + "Consume a token at point and evaluate corresponding forms. + +CASES is a list of `cond'-like clauses, (REGEXP BODY ...) where +the REGEXPs define possible tokens which may appear at point. The +CASES are considered in order. For each case, if the text at +point matches REGEXP, then point is moved to the end of the +matched token, the corresponding BODY is evaluated and their +value returned. The matched token is available within the BODY +forms as (match-string 0). + +There can be a default case where REGEXP is `t', which evaluates +the corresponding FORMS but does not move point. + +Returns `nil' if none of the CASES matches." + (declare (debug (&rest (sexp &rest form)))) + `(cond + ,@(cl-loop for (token . action) in cases + collect + (if (eq token t) + `(t ,@action) + `((looking-at ,token) + (goto-char (match-end 0)) + ,@action))))) + +(defmacro rxt-with-source-location (&rest body) + "Evaluate BODY and record source location information on its value. + +BODY may evaluate to any kind of object, but its value should +generally not be `eq' to any other object." + (declare (debug (&rest form))) + (let ((begin (make-symbol "begin")) + (value (make-symbol "value"))) + `(let ((,begin (point)) + (,value ,(macroexp-progn body))) + (setf (rxt-location ,value) + (make-rxt-location :source rxt-source-text-string + :start (1- ,begin) + :end (1- (point)))) + ,value))) + +;; Read PCRE + flags +(defun rxt-read-delimited-pcre () + "Read a Perl-style delimited regexp and flags from the current buffer. + +Point should be before the regexp literal before calling +this. Currently only regexps delimited by / ... / are supported. +A preceding \"m\", \"qr\" or \"s\" will be ignored, as will the +replacement string in an s/.../.../ construction. + +Returns two strings: the regexp and the flags." + (save-excursion + (skip-syntax-forward "-") + + ;; Skip m, qr, s + (let ((is-subst (rxt-token-case + ("s" t) + ((rx (or "m" "qr")) nil)))) + + (when (not (looking-at "/")) + (error "Only Perl regexps delimited by slashes are supported")) + (let ((beg (match-end 0)) + (delim (rx (not (any "\\")) + (group "/")))) + (search-forward-regexp delim) + (let ((end (match-beginning 1))) + (when is-subst (search-forward-regexp delim)) + (let ((pcre (buffer-substring-no-properties beg end))) + (rxt-token-case + ("[gimosx]*" + (rxt--add-flags pcre (match-string-no-properties 0)))))))))) + + +;;;; Elisp and PCRE string notation parser + +;;; Parser constants +(defconst rxt-pcre-char-set-alist + `((?w . ; "word" characters + (?_ alnum)) + (?d . ; digits + (digit)) + (?h . ; horizontal whitespace + (#x0009 #x0020 #x00A0 #x1680 #x180E #x2000 #x2001 #x2002 #x2003 + #x2004 #x2005 #x2006 #x2007 #x2008 #x2009 #x200A #x202F + #x205F #x3000)) + (?s . ; whitespace + (9 10 12 13 32)) + (?v . ; vertical whitespace + (#x000A #x000B #x000C #x000D #x0085 #x2028 #x2029)))) + +(defconst rxt-pcre-named-classes-regexp + (rx "[:" + (submatch + (or "alnum" "alpha" "ascii" "blank" "cntrl" "digit" "graph" "lower" + "print" "punct" "space" "upper" "word" "xdigit")) + ":]")) + +(defconst rxt-elisp-named-classes-regexp + (rx "[:" + (submatch + (or "alnum" "alpha" "ascii" "blank" "cntrl" "digit" "graph" "lower" + "print" "punct" "space" "upper" "word" "xdigit" + "unibyte" "nonascii" "multibyte")) + ":]")) + +;;; The following dynamically bound variables control the operation of +;;; the parser (see `rxt-parse-re'.) +(defvar rxt-parse-pcre nil + "t if the rxt string parser is parsing PCRE syntax, nil for Elisp syntax. + +This should only be let-bound internally, never set otherwise.") + +(defvar rxt-pcre-extended-mode nil + "t if the rxt string parser is emulating PCRE's \"extended\" mode. + +In extended mode (indicated by /x in Perl/PCRE), whitespace +outside of character classes and \\Q...\\E quoting is ignored, +and a `#' character introduces a comment that extends to the end +of line.") + +(defvar rxt-pcre-s-mode nil + "t if the rxt string parser is emulating PCRE's single-line \"/s\" mode. + +When /s is used, PCRE's \".\" matches newline characters, which +otherwise it would not match.") + +(defvar rxt-pcre-case-fold nil + "non-nil to emulate PCRE's case-insensitive \"/i\" mode in translated regexps.") + +(defvar rxt-branch-end-regexp nil) +(defvar rxt-choice-regexp nil) +(defvar rxt-brace-begin-regexp nil) +(defvar rxt-m-to-n-brace-regexp nil) +(defvar rxt-m-to-?-brace-regexp nil) +(defvar rxt-m-brace-regexp nil) +(defvar rxt-named-classes-regexp nil) + +(defvar rxt-subgroup-count nil) +(defvar rxt-source-text-string nil) + +(defun rxt-parse-pcre (re) + (rxt-parse-re re t)) + +(defun rxt-parse-elisp (re) + (rxt-parse-re re nil)) + +(defun rxt-parse-re (re pcre-p) + (let* ((rxt-parse-pcre pcre-p) + (rxt-pcre-extended-mode nil) + (rxt-pcre-s-mode nil) + (rxt-pcre-case-fold nil) + + ;; Bind regexps to match syntax that differs between PCRE and + ;; Elisp only in the addition of a backslash "\" + (escape (if pcre-p "" "\\")) + (rxt-choice-regexp + (rx-to-string `(seq ,escape "|"))) + (rxt-branch-end-regexp + (rx-to-string `(or buffer-end + (seq ,escape (or "|" ")"))))) + (rxt-brace-begin-regexp + (rx-to-string `(seq ,escape "{"))) + (rxt-m-to-n-brace-regexp + (rx-to-string + `(seq + (submatch (* (any "0-9"))) "," (submatch (+ (any "0-9"))) + ,escape "}"))) + (rxt-m-to-?-brace-regexp + (rx-to-string + `(seq (submatch (+ (any "0-9"))) "," ,escape "}"))) + (rxt-m-brace-regexp + (rx-to-string + `(seq (submatch (+ (any "0-9"))) ,escape "}"))) + + ;; Named character classes [: ... :] differ slightly + (rxt-named-classes-regexp + (if pcre-p + rxt-pcre-named-classes-regexp + rxt-elisp-named-classes-regexp)) + + (rxt-subgroup-count 0) + (case-fold-search nil)) + (with-temp-buffer + (insert re) + (goto-char (point-min)) + (let ((rxt-source-text-string re)) + (rxt-parse-exp))))) + +;; Parse a complete regex: a number of branches separated by | or +;; \|, as determined by `rxt-branch-end-regexp'. +(defun rxt-parse-exp () + ;; These variables are let-bound here because in PCRE mode they may + ;; be set internally by (?x) or (?s) constructions, whose scope + ;; lasts until the end of a sub-expression + (rxt-with-source-location + (let ((rxt-pcre-extended-mode rxt-pcre-extended-mode) + (rxt-pcre-s-mode rxt-pcre-s-mode) + (rxt-pcre-case-fold rxt-pcre-case-fold)) + (if (eobp) + (rxt-seq) + (let ((branches '())) + (cl-block nil + (while t + (let ((branch (rxt-parse-branch))) + (push branch branches) + (rxt-token-case + (rxt-choice-regexp nil) + (t (cl-return (apply #'rxt-choice (reverse branches))))))))))))) + +;; Skip over whitespace and comments in PCRE extended mode +(defun rxt-extended-skip () + (when rxt-pcre-extended-mode + (skip-syntax-forward "-") + (while (looking-at "#") + (beginning-of-line 2) + (skip-syntax-forward "-")))) + +;; Parse a regexp "branch": a sequence of pieces +(defun rxt-parse-branch () + (rxt-extended-skip) + (rxt-with-source-location + (let ((pieces '()) + (branch-start-p t)) + (while (not (looking-at rxt-branch-end-regexp)) + (push (rxt-parse-piece branch-start-p) pieces) + (setq branch-start-p nil)) + (apply #'rxt-seq (reverse pieces))))) + +;; Parse a regexp "piece": an atom (`rxt-parse-atom') plus any +;; following quantifiers +(defun rxt-parse-piece (&optional branch-begin) + (rxt-extended-skip) + (rxt-with-source-location + (let ((atom (rxt-parse-atom branch-begin))) + (rxt-parse-quantifiers atom)))) + +;; Parse any and all quantifiers after ATOM and return the quantified +;; regexp, or ATOM unchanged if no quantifiers +(defun rxt-parse-quantifiers (atom) + (catch 'done + (while (not (eobp)) + (let ((atom1 (rxt-parse-quantifier atom))) + (if (eq atom1 atom) + (throw 'done t) + (setq atom atom1))))) + atom) + +;; Possibly parse a single quantifier after ATOM and return the +;; quantified atom, or ATOM if no quantifier +(defun rxt-parse-quantifier (atom) + (rxt-extended-skip) + (rxt-token-case + ((rx "*?") (rxt-repeat 0 nil atom nil)) + ((rx "*") (rxt-repeat 0 nil atom t)) + ((rx "+?") (rxt-repeat 1 nil atom nil)) + ((rx "+") (rxt-repeat 1 nil atom t)) + ((rx "??") (rxt-repeat 0 1 atom nil)) + ((rx "?") (rxt-repeat 0 1 atom t)) + ;; Brace expression "{M,N}", "{M,}", "{M}" + (rxt-brace-begin-regexp + (cl-destructuring-bind (from to) + (rxt-parse-braces) + (rxt-repeat from to atom))) + ;; No quantifiers found + (t atom))) + +;; Parse a regexp atom, i.e. an element that binds to any following +;; quantifiers. This includes characters, character classes, +;; parenthesized groups, assertions, etc. +(defun rxt-parse-atom (&optional branch-begin) + (if (eobp) + (rxt-error "Unexpected end of regular expression") + (if rxt-parse-pcre + (rxt-parse-atom/pcre) + (rxt-parse-atom/el branch-begin)))) + +(defun rxt-parse-atom/common () + (rxt-token-case + ((rx "[") (rxt-parse-char-class)) + ((rx "\\b") (rxt-word-boundary)) + ((rx "\\B") (rxt-not-word-boundary)))) + +(defun rxt-parse-atom/el (branch-begin) + (rxt-with-source-location + (or (rxt-parse-atom/common) + (rxt-token-case + ;; "." wildcard + ((rx ".") (rxt-nonl)) + ;; "^" and "$" are metacharacters only at beginning or end of a + ;; branch in Elisp; elsewhere they are literals + ((rx "^") + (if branch-begin + (rxt-bol) + (rxt-string "^"))) + ((rx "$") + (if (looking-at rxt-branch-end-regexp) + (rxt-eol) + (rxt-string "$"))) + ;; Beginning & end of string, word, symbol + ((rx "\\`") (rxt-bos)) + ((rx "\\'") (rxt-eos)) + ((rx "\\<") (rxt-bow)) + ((rx "\\>") (rxt-eow)) + ((rx "\\_<") (rxt-symbol-start)) + ((rx "\\_>") (rxt-symbol-end)) + ;; Subgroup + ((rx "\\(") (rxt-parse-subgroup/el)) + ;; Word/non-word characters (meaning depending on syntax table) + ((rx "\\w") (rxt-wordchar)) + ((rx "\\W") (rxt-not-wordchar)) + ;; Other syntax categories + ((rx "\\" (submatch (any ?S ?s)) (submatch nonl)) + (let ((negated (string= (match-string 1) "S")) + (syntax + (car (rassoc (string-to-char (match-string 2)) + rx-syntax)))) + (if syntax + (let ((re (rxt-syntax-class syntax))) + (if negated (rxt-negate re) re)) + (rxt-error "Invalid syntax class `\\%s'" (match-string 0))))) + ;; Character categories + ((rx "\\" (submatch (any ?C ?c)) (submatch nonl)) + (let ((negated (string= (match-string 1) "C")) + (category + (car (rassoc (string-to-char (match-string 2)) + rx-categories)))) + (if category + (let ((re (rxt-char-category category))) + (if negated (rxt-negate re) re)) + (rxt-error "Invalid character category `%s'" (match-string 0))))) + ;; Backreference + ((rx (seq "\\" (submatch (any "1-9")))) + (rxt-backref (string-to-number (match-string 1)))) + ;; Other escaped characters + ((rx (seq "\\" (submatch nonl))) + (rxt-string (match-string 1))) + ;; Normal characters + ((rx (or "\n" nonl)) + (rxt-string (match-string 0))))))) + +(defun rxt-parse-atom/pcre () + (rxt-extended-skip) + (rxt-with-source-location + (or + ;; Is it an atom that's the same in Elisp? + (rxt-parse-atom/common) + ;; Is it common to PCRE regex and character class syntax? + (let ((char (rxt-parse-escapes/pcre))) + (and char + (rxt-string (char-to-string char)))) + ;; Otherwise: + (rxt-token-case + ;; "." wildcard + ((rx ".") + (if rxt-pcre-s-mode + (rxt-anything) + (rxt-nonl))) + ;; Beginning & end of string/line + ((rx "^") (rxt-bol)) + ((rx "$") (rxt-eol)) + ((rx "\\A") (rxt-bos)) + ((rx "\\Z") (rxt-eos)) + ;; Subgroup + ((rx "(") (rxt-parse-subgroup/pcre)) + ;; Metacharacter quoting + ((rx "\\Q") + ;; It would seem simple to take all the characters between \Q + ;; and \E and make an rxt-string, but \Q...\E isn't an atom: + ;; any quantifiers afterward should bind only to the last + ;; character, not the whole string. + (let ((begin (point))) + (search-forward "\\E" nil t) + (let* ((end (match-beginning 0)) + (str (buffer-substring-no-properties begin (1- end))) + (char (char-to-string (char-before end)))) + (rxt-seq (rxt-string str) + (rxt-parse-quantifiers (rxt-string char)))))) + ;; Pre-defined character sets + ((rx "\\" (submatch (any "d" "D" "h" "H" "s" "S" "v" "V" "w" "W"))) + (rxt--pcre-char-set (string-to-char (match-string 1)))) + ;; \ + digits: backreference or octal char? + ((rx "\\" (submatch (+ (any "0-9")))) + (let* ((digits (match-string 1)) + (dec (string-to-number digits))) + ;; from "man pcrepattern": If the number is less than 10, or if + ;; there have been at least that many previous capturing left + ;; parentheses in the expression, the entire sequence is taken + ;; as a back reference. + (if (and (> dec 0) + (or (< dec 10) + (>= rxt-subgroup-count dec))) + (progn + (when rxt-pcre-case-fold + (display-warning + 'rxt "Backreferences with case-folding are handled poorly")) + (rxt-backref dec)) + ;; from "man pcrepattern": if the decimal number is greater + ;; than 9 and there have not been that many capturing + ;; subpatterns, PCRE re-reads up to three octal digits + ;; following the backslash, and uses them to generate a data + ;; character. Any subsequent digits stand for themselves. + (goto-char (match-beginning 1)) + (re-search-forward (rx (** 0 3 (any "0-7")))) + (rxt-string (char-to-string (string-to-number (match-string 0) 8)))))) + ;; Other escaped characters + ((rx "\\" (submatch nonl)) (rxt-string (match-string 1))) + ;; Everything else + ((rx (or (any "\n") nonl)) (rxt-string (match-string 0))))))) + +(defun rxt-parse-escapes/pcre () + "Consume a one-char PCRE escape at point and return its codepoint equivalent. + +Handles only those character escapes which have the same meaning +in character classes as outside them." + (rxt-token-case + ((rx "\\a") #x07) ; bell + ((rx "\\e") #x1b) ; escape + ((rx "\\f") #x0c) ; formfeed + ((rx "\\n") #x0a) ; linefeed + ((rx "\\r") #x0d) ; carriage return + ((rx "\\t") #x09) ; tab + ;; Control character + ((rx "\\c" (submatch nonl)) + ;; from `man pcrepattern': + ;; The precise effect of \cx is as follows: if x is a lower case + ;; letter, it is converted to upper case. Then bit 6 of the + ;; character (hex 40) is inverted. + (logxor (string-to-char (upcase (match-string 1))) #x40)) + ;; Hex escapes + ((rx "\\x" (submatch (** 1 2 (any "0-9" "A-Z" "a-z")))) + (string-to-number (match-string 1) 16)) + ((rx "\\x{" (submatch (* (any "0-9" "A-Z" "a-z"))) "}") + (string-to-number (match-string 1) 16)))) + +(defun rxt-parse-subgroup/pcre () + (catch 'return + (let ((shy nil) + (extended-mode rxt-pcre-extended-mode) + (single-line-mode rxt-pcre-s-mode) + (case-fold rxt-pcre-case-fold)) + (rxt-extended-skip) + ;; Check for special (? ..) and (* ...) syntax + (rxt-token-case + ((rx "?") ; (? + (rxt-token-case + ((rx ")") ; Empty group (?) + (throw 'return (rxt-empty-string))) + (":" (setq shy t)) ; Shy group (?: + ("#" ; Comment (?# + (search-forward ")") + (throw 'return (rxt-empty-string))) + ((rx (or ; Flags (?isx-isx + (seq (group (* (any "gimosx"))) "-" (group (+ (any "gimosx")))) + (seq (group (+ (any "gimosx")))))) + (let ((token (match-string 0)) + (on (or (match-string 1) (match-string 3))) + (off (or (match-string 2) ""))) + (if (cl-find ?x on) (setq extended-mode t)) + (if (cl-find ?s on) (setq single-line-mode t)) + (if (cl-find ?i on) (setq case-fold t)) + (if (cl-find ?x off) (setq extended-mode nil)) + (if (cl-find ?s off) (setq single-line-mode nil)) + (if (cl-find ?i off) (setq case-fold nil)) + (when (string-match-p "[gmo]" token) + (display-warning + 'rxt (format "Unhandled PCRE flags in (?%s" token)))) + (rxt-token-case + (":" (setq shy t)) ; Shy group with flags (?isx-isx: ... + (")" ; Set flags (?isx-isx) + ;; Set flags for the remainder of the current subexpression + (setq rxt-pcre-extended-mode extended-mode + rxt-pcre-s-mode single-line-mode + rxt-pcre-case-fold case-fold) + (throw 'return (rxt-empty-string))))) + ;; Other constructions like (?=, (?!, etc. are not recognised + (t (rxt-error "Unrecognized PCRE extended construction `(?%c'" + (char-after))))) + + ;; No special (* ...) verbs are recognised + ((rx "*") + (let ((begin (point))) + (search-forward ")" nil 'go-to-end) + (rxt-error "Unrecognized PCRE extended construction `(*%s'" + (buffer-substring begin (point)))))) + + ;; Parse the remainder of the subgroup + (unless shy (cl-incf rxt-subgroup-count)) + (let* ((rxt-pcre-extended-mode extended-mode) + (rxt-pcre-s-mode single-line-mode) + (rxt-pcre-case-fold case-fold) + (rx (rxt-parse-exp))) + (rxt-extended-skip) + (rxt-token-case + (")" (if shy rx (rxt-submatch rx))) + (t (rxt-error "Subexpression missing close paren"))))))) + +(defun rxt-parse-subgroup/el () + (let ((kind + (rxt-token-case + ((rx "?:") + (cl-incf rxt-subgroup-count) + 'shy) + ((rx "?" (group (+ (in "0-9"))) ":") + (let ((n (string-to-number (match-string 1)))) + (when (< rxt-subgroup-count n) + (setf rxt-subgroup-count n)) + n)) + ((rx "?") ; Reserved + (rxt-error "Unknown match group sequence"))))) + (let ((rx (rxt-parse-exp))) + (rxt-token-case + ((rx "\\)") + (cond ((eq kind 'shy) rx) + ((numberp kind) + (rxt-submatch-numbered kind rx)) + (t (rxt-submatch rx)))) + (t (rxt-error "Subexpression missing close paren")))))) + +(defun rxt-parse-braces () + (rxt-token-case + (rxt-m-to-n-brace-regexp + (list (string-to-number (match-string 1)) + (string-to-number (match-string 2)))) + (rxt-m-to-?-brace-regexp + (list (string-to-number (match-string 1)) nil)) + (rxt-m-brace-regexp + (let ((a (string-to-number (match-string 1)))) + (list a a))) + (t + (let ((begin (point))) + (search-forward "}" nil 'go-to-end) + (rxt-error "Bad brace expression {%s" + (buffer-substring-no-properties begin (point))))))) + +;; Parse a character set range [...] +(defun rxt-parse-char-class () + (when (eobp) + (rxt-error "Missing close right bracket in regexp")) + (rxt-with-source-location + (let* ((negated (rxt-token-case + ((rx "^") t) + (t nil))) + (begin (point)) + (result + (if negated + (rxt-negate (rxt-char-set-union)) + (rxt-char-set-union))) + (transformer + (if negated #'rxt-negate #'identity)) + (builder + (if negated #'rxt-char-set-intersection #'rxt-choice))) + (catch 'done + (while t + (when (eobp) + (rxt-error "Missing close right bracket in regexp")) + (if (and (looking-at (rx "]")) + (not (= (point) begin))) + (throw 'done result) + (let ((piece (funcall transformer (rxt-parse-char-class-piece)))) + (setq result (funcall builder result piece)))))) + (forward-char) ; Skip over closing "]" + result))) + +;; Parse a single character, a character range, or a posix class +;; within a character set context. Returns an `rxt-char-set'. +(defun rxt-parse-char-class-piece () + (let ((atom (rxt-parse-char-class-atom))) + (cl-typecase atom + (rxt-char-set ; return unchanged + atom) + (integer ; character: check for range + (let ((range-end (rxt-maybe-parse-range-end))) + (if range-end + (rxt-char-set-union (cons atom range-end)) + (rxt-char-set-union atom)))) + (t ; transform into character set + (rxt-char-set-union atom))))) + +;; Parse a single character or named class within a charset. +;; +;; Returns an integer (a character), a symbol (representing a named +;; character class) or an `rxt-char-set' (for pre-defined character +;; classes like \d, \W, etc.) +(defun rxt-parse-char-class-atom () + (or + ;; First, check for PCRE-specific backslash sequences + (and rxt-parse-pcre + (rxt-parse-char-class-atom/pcre)) + ;; Char-class syntax + (rxt-token-case + ;; Named classes [:alnum:], ... + (rxt-named-classes-regexp + (intern (match-string 1))) + ;; Error on unknown posix-class-like syntax + ((rx "[:" (* (any "a-z")) ":]") + (rxt-error "Unknown posix character class `%s'" (match-string 0))) + ;; Error on [= ... ]= collation syntax + ((rx "[" (submatch (any "." "=")) + (* (any "a-z")) (backref 1) "]") + (rxt-error "Unsupported collation syntax `%s'" (match-string 0))) + ;; Other characters stand for themselves + ((rx (or "\n" nonl)) + (string-to-char (match-string 0)))))) + +;; Parse backslash escapes inside PCRE character classes +(defun rxt-parse-char-class-atom/pcre () + (or (rxt-parse-escapes/pcre) + (rxt-token-case + ;; Backslash + digits => octal char + ((rx "\\" (submatch (** 1 3 (any "0-7")))) + (string-to-number (match-string 1) 8)) + ;; Pre-defined character sets + ((rx "\\" (submatch (any "d" "D" "h" "H" "s" "S" "v" "V" "w" "W"))) + (rxt--pcre-char-set (string-to-char (match-string 1)))) + ;; "\b" inside character classes is a backspace + ((rx "\\b") ?\C-h) + ;; Ignore other escapes + ((rx "\\" (submatch nonl)) + (string-to-char (match-string 1)))))) + +;; Look for a range tail (the "-z" in "a-z") after parsing a single +;; character within in a character set. Returns either a character +;; representing the range end, or nil. +(defun rxt-maybe-parse-range-end () + (let ((range-end nil) (end-position nil)) + (when (looking-at (rx "-" (not (any "]")))) + (save-excursion + (forward-char) + (setq range-end (rxt-parse-char-class-atom) + end-position (point)))) + + (if (characterp range-end) + ;; This is a range: move point after it and return the ending character + (progn + (goto-char end-position) + range-end) + ;; Not a range. + nil))) + +;; Return the pre-defined PCRE char-set associated with CHAR: i.e. \d +;; is digits, \D non-digits, \s space characters, etc. +(defun rxt--pcre-char-set (char) + (let* ((base-char (downcase char)) + (negated (/= char base-char)) + (elements (assoc-default base-char rxt-pcre-char-set-alist)) + (base-char-set (apply #'rxt-char-set-union elements))) + (if negated + (rxt-negate base-char-set) + base-char-set))) + + +;;;; Unparser to `rx' syntax + +(defconst rxt-rx-verbose-equivalents + '((bol . line-start) + (eol . line-end) + (nonl . not-newline) + (bos . string-start) + (eos . string-end) + (bow . word-start) + (eow . word-end) + (seq . sequence)) + "Alist of verbose equivalents for short `rx' primitives.") + +(defun rxt-rx-symbol (sym) + (if rxt-verbose-rx-translation + (or (assoc-default sym rxt-rx-verbose-equivalents) + sym) + sym)) + +(defun rxt-adt->rx (re) + (let ((rx + (cl-typecase re + (rxt-primitive + (rxt-rx-symbol (rxt-primitive-rx re))) + + (rxt-string + (if (or (not (rxt-string-case-fold re)) + (string= "" (rxt-string-chars re))) + (rxt-string-chars re) + `(seq + ,@(cl-loop for char across (rxt-string-chars re) + collect `(any ,(upcase char) ,(downcase char)))))) + + (rxt-seq + `(seq ,@(mapcar #'rxt-adt->rx (rxt-seq-elts re)))) + + (rxt-choice + `(or ,@(mapcar #'rxt-adt->rx (rxt-choice-elts re)))) + + (rxt-submatch + (if (rxt-seq-p (rxt-submatch-body re)) + `(submatch + ,@(mapcar #'rxt-adt->rx (rxt-seq-elts (rxt-submatch-body re)))) + `(submatch ,(rxt-adt->rx (rxt-submatch-body re))))) + + (rxt-submatch-numbered + (if (rxt-seq-p (rxt-submatch-numbered-p re)) + `(,(rxt-rx-symbol 'submatch-n) + ,(rxt-submatch-numbered-n re) + ,@(mapcar #'rxt-adt->rx + (rxt-seq-elts + (rxt-submatch-numbered-body re)))) + `(,(rxt-rx-symbol 'submatch-n) + ,(rxt-submatch-numbered-n re) + ,(rxt-adt->rx (rxt-submatch-numbered-body re))))) + + (rxt-backref + (let ((n (rxt-backref-n re))) + (if (<= n 9) + `(backref ,(rxt-backref-n re)) + (rxt-error "Too many backreferences (%s)" n)))) + + (rxt-syntax-class + `(syntax ,(rxt-syntax-class-symbol re))) + + (rxt-char-category + `(category ,(rxt-char-category-symbol re))) + + (rxt-repeat + (let ((from (rxt-repeat-from re)) + (to (rxt-repeat-to re)) + (greedy (rxt-repeat-greedy re)) + (body (rxt-adt->rx (rxt-repeat-body re)))) + (if rxt-verbose-rx-translation + (let ((rx + (cond + ((and (zerop from) (null to)) + `(zero-or-more ,body)) + ((and (equal from 1) (null to)) + `(one-or-more ,body)) + ((and (zerop from) (equal to 1)) + `(zero-or-one ,body)) + ((null to) + `(>= ,from ,body)) + ((equal from to) + `(repeat ,from ,body)) + (t + `(** ,from ,to ,body))))) + (if greedy + (if rxt-explain + rx ; Readable but not strictly accurate. Fixme? + `(maximal-match ,rx)) + `(minimal-match ,rx))) + (cond + ((and (zerop from) (null to)) + `(,(if greedy '* '*?) ,body)) + ((and (equal from 1) (null to)) + `(,(if greedy '+ '+?) ,body)) + ((and (zerop from) (equal to 1)) + `(,(if greedy ? ??) ,body)) + ((null to) + `(>= ,from ,body)) + ((equal from to) + `(= ,from ,body)) + (t + `(** ,from ,to ,body)))))) + + (rxt-char-set-union + (let* ((case-fold (rxt-char-set-union-case-fold re)) + (re (rxt--simplify-char-set re case-fold)) + (chars (rxt-char-set-union-chars re)) + (ranges (rxt-char-set-union-ranges re)) + (classes (rxt-char-set-union-classes re)) + (case-fold (rxt-char-set-union-case-fold re))) + (if (and (null chars) (null ranges) (= 1 (length classes))) + (car classes) + `(any ,@chars ,@ranges ,@classes)))) + + (rxt-char-set-negation + `(not ,(rxt-adt->rx (rxt-char-set-negation-elt re)))) + + (t + (rxt-error "No RX translation of `%s'" (rxt-to-string re)))))) + + ;; Store source information on each fragment of the generated RX + ;; sexp for rxt-explain mode + (when rxt-explain + ;; Use gensyms to store unique source information for multiple + ;; occurrences of primitives like `bol' + (when (symbolp rx) + (setq rx (make-symbol (symbol-name rx)))) + (setf (rxt-location rx) (rxt-location re))) + rx)) + + +;;;; 'Unparser' to PCRE notation + +;;; Based on scsh/posixstr.scm in scsh + +;; To ensure that the operator precedence in the generated regexp does +;; what we want, we need to keep track of what kind of production is +;; returned from each step. Therefore these functions return a string +;; and a numeric "level" which lets the function using the generated +;; regexp know whether it has to be parenthesized: +;; +;; 0: an already parenthesized expression +;; +;; 1: a "piece" binds to any succeeding quantifiers +;; +;; 2: a "branch", or concatenation of pieces, needs parenthesizing to +;; bind to quantifiers +;; +;; 3: a "top", or alternation of branches, needs parenthesizing to +;; bind to quantifiers or to concatenation +;; +;; This idea is stolen straight out of the scsh implementation. + +(defun rxt-adt->pcre (re) + (cl-destructuring-bind (s _) (rxt-adt->pcre/lev re) s)) + +(defun rxt-adt->pcre/lev (re) + (cl-typecase re + (rxt-primitive + (let ((s (rxt-primitive-pcre re))) + (if s + (list s 1) + (rxt-error "No PCRE translation of `%s'" (rxt-to-string re))))) + + (rxt-string (rxt-string->pcre re)) + (rxt-seq (rxt-seq->pcre re)) + (rxt-choice (rxt-choice->pcre re)) + (rxt-submatch (rxt-submatch->pcre re)) + (rxt-backref + (list (format "\\%d" (rxt-backref-n re)) 1)) + (rxt-repeat (rxt-repeat->pcre re)) + + ((or rxt-char-set-union rxt-char-set-negation) + (rxt-char-set->pcre re)) + + ;; FIXME + ;; ((rxt-char-set-intersection re) (rxt-char-set-intersection->pcre re)) + + (t + (rxt-error "No PCRE translation of `%s'" (rxt-to-string re))))) + +(defconst rxt-pcre-metachars (rx (any "\\^.$|()[]*+?{}"))) +(defconst rxt-pcre-charset-metachars (rx (any "]" "[" "\\" "^" "-"))) + +(defun rxt-string->pcre (re) + (let ((chars (rxt-string-chars re))) + (list + (replace-regexp-in-string + rxt-pcre-metachars + "\\\\\\&" chars) + ;; A one-character string is a 'piece' (it binds to a following + ;; quantifier). A longer string is a 'branch' (it has to be + ;; enclosed in parentheses to bind to a following quantifier). + (if (> (length chars) 1) 2 1)))) + +(defun rxt-seq->pcre (re) + (let ((elts (rxt-seq-elts re))) + (if (null elts) + "" + (rxt-seq-elts->pcre elts)))) + +(defun rxt-seq-elts->pcre (elts) + (cl-destructuring-bind + (s lev) (rxt-adt->pcre/lev (car elts)) + (if (null (cdr elts)) + (list s lev) + (cl-destructuring-bind + (s1 lev1) (rxt-seq-elts->pcre (cdr elts)) + (list (concat (rxt-paren-if-necessary s lev) + (rxt-paren-if-necessary s1 lev1)) + 2))))) + +(defun rxt-paren-if-necessary (s lev) + (if (< lev 3) + s + (concat "(?:" s ")"))) + +(defun rxt-choice->pcre (re) + (let ((elts (rxt-choice-elts re))) + (if (null elts) + nil + (rxt-choice-elts->pcre elts)))) + +(defun rxt-choice-elts->pcre (elts) + (cl-destructuring-bind + (s lev) (rxt-adt->pcre/lev (car elts)) + (if (null (cdr elts)) + (list s lev) + (cl-destructuring-bind + (s1 lev1) (rxt-choice-elts->pcre (cdr elts)) + (list (concat s "|" s1) 3))))) + +(defun rxt-submatch->pcre (re) + (cl-destructuring-bind + (s lev) (rxt-adt->pcre/lev (rxt-submatch-body re)) + (list (concat "(" s ")") 0))) + +(defun rxt-repeat->pcre (re) + (let ((from (rxt-repeat-from re)) + (to (rxt-repeat-to re)) + (body (rxt-repeat-body re)) + (greedy (rxt-repeat-greedy re))) + (cl-destructuring-bind + (s lev) (rxt-adt->pcre/lev body) + (cond + ((and to (= from 1) (= to 1)) (list s lev)) + ((and to (= from 0) (= to 0)) (list "" 2)) + (t + (when (> lev 1) ; parenthesize non-atoms + (setq s (concat "(?:" s ")") + lev 0)) + (list (if to + (cond ((and (= from 0) (= to 1)) + (concat s (if greedy "?" "??"))) + ((= from to) + (concat s "{" (number-to-string to) "}")) + (t + (concat s "{" (number-to-string from) + "," (number-to-string to) "}"))) + (cond ((= from 0) + (concat s (if greedy "*" "*?"))) + ((= from 1) + (concat s (if greedy "+" "+?"))) + (t (concat s "{" (number-to-string from) ",}")))) + 1)))))) + +(defun rxt-char-set->pcre (re) + (cond ((rxt-char-set-union-p re) + (list + (concat "[" (rxt-char-set->pcre/chars re) "]") 1)) + + ((rxt-char-set-negation-p re) + (let ((elt (rxt-char-set-negation-elt re))) + (if (rxt-char-set-union-p elt) + (list + (concat "[^" (rxt-char-set->pcre/chars elt) "]") 1) + (rxt-error "No PCRE translation of `%s'" (rxt-to-string elt))))) + + (t + (rxt-error "Non-char-set in rxt-char-set->pcre: %s" re)))) + +;; Fortunately, easier in PCRE than in POSIX! +(defun rxt-char-set->pcre/chars (re) + (cl-flet + ((escape + (char) + (let ((s (char-to-string char))) + (cond ((string-match rxt-pcre-charset-metachars s) + (concat "\\" s)) + + ((and (not (string= s " ")) + (string-match "[^[:graph:]]" s)) + (format "\\x{%x}" char)) + + (t s))))) + + (let ((chars (rxt-char-set-union-chars re)) + (ranges (rxt-char-set-union-ranges re)) + (classes (rxt-char-set-union-classes re))) + + (concat + (mapconcat #'escape chars "") + (mapconcat #'(lambda (rg) + (format "%s-%s" + (escape (car rg)) + (escape (cdr rg)))) + ranges "") + (mapconcat #'(lambda (class) + (format "[:%s:]" class)) + classes ""))))) + + +;;;; Generate all productions of a finite regexp + +(defun rxt-adt->strings (re) + (cl-typecase re + (rxt-primitive + (list "")) + (rxt-string + (list (rxt-string-chars re))) + (rxt-seq + (rxt-seq-elts->strings (rxt-seq-elts re))) + (rxt-choice + (rxt-choice-elts->strings (rxt-choice-elts re))) + (rxt-submatch + (rxt-adt->strings (rxt-submatch-body re))) + (rxt-submatch-numbered + (rxt-adt->strings (rxt-submatch-numbered-body re))) + (rxt-repeat + (rxt-repeat->strings re)) + (rxt-char-set-union + (rxt-char-set->strings re)) + (t + (error "Can't generate productions of %s" + (rxt-syntax-tree-readable re))))) + +(defun rxt-concat-product (heads tails) + (cl-mapcan + (lambda (hs) + (mapcar + (lambda (ts) (concat hs ts)) + tails)) + heads)) + +(defun rxt-seq-elts->strings (elts) + (if (null elts) + '("") + (let ((heads (rxt-adt->strings (car elts))) + (tails (rxt-seq-elts->strings (cdr elts)))) + (rxt-concat-product heads tails)))) + +(defun rxt-choice-elts->strings (elts) + (if (null elts) + '() + (append (rxt-adt->strings (car elts)) + (rxt-choice-elts->strings (cdr elts))))) + +(defun rxt-repeat->strings (re) + (let ((from (rxt-repeat-from re)) + (to (rxt-repeat-to re))) + (if (not to) + (error "Can't generate all productions of unbounded repeat \"%s\"" + (rxt-syntax-tree-readable re)) + (let ((strings (rxt-adt->strings (rxt-repeat-body re)))) + (rxt-repeat-n-m->strings from to strings))))) + +(defun rxt-repeat-n-m->strings (from to strings) + (cond + ((zerop to) '("")) + ((= to from) (rxt-repeat-n->strings from strings)) + (t ; to > from + (let* ((strs-n (rxt-repeat-n->strings from strings)) + (accum (cl-copy-list strs-n))) + (dotimes (i (- to from)) + (setq strs-n (rxt-concat-product strs-n strings)) + (setq accum (nconc accum strs-n))) + accum)))) + +(defun rxt-repeat-n->strings (n strings) + ;; n > 1 + (cond ((zerop n) '("")) + ((= n 1) strings) + (t + (rxt-concat-product + (rxt-repeat-n->strings (- n 1) strings) + strings)))) + +(defun rxt-char-set->strings (re) + (if (rxt-char-set-union-classes re) + (error "Can't generate all productions of named character classes in \"%s\"" + (rxt-syntax-tree-readable re)) + (let ((chars (mapcar #'char-to-string (rxt-char-set-union-chars re)))) + (dolist (range (rxt-char-set-union-ranges re)) + (let ((end (cdr range))) + (cl-do ((i (car range) (+ i 1))) + ((> i end)) + (push (char-to-string i) chars)))) + chars))) + + +;;;; RE-Builder hacks + +(defadvice reb-update-modestring + (after rxt () activate compile) + "This function is hacked for emulated PCRE syntax and regexp conversion." + (setq reb-mode-string + (concat + (format " (%s)" reb-re-syntax) + reb-mode-string)) + (force-mode-line-update)) + +(defadvice reb-change-syntax + (around rxt (&optional syntax) activate compile) + "This function is hacked for emulated PCRE syntax and regexp conversion." + (interactive + (list (intern + (completing-read (format "Select syntax (%s): " reb-re-syntax) + '(read string pcre sregex rx) + nil t "" nil (symbol-name reb-re-syntax))))) + (unless (memq syntax '(read string pcre lisp-re sregex rx)) + (error "Invalid syntax: %s" syntax)) + (let ((re-builder-buffer (get-buffer reb-buffer))) + (setq reb-re-syntax syntax) + (when re-builder-buffer + (with-current-buffer reb-target-buffer + (cl-case syntax + (rx + (let ((rx (rxt-elisp-to-rx reb-regexp))) + (setq reb-regexp-src + (with-temp-buffer + (insert "\n" "'") + (rxt-print rx) + (buffer-string))))) + (pcre + (setq reb-regexp-src (rxt-elisp-to-pcre reb-regexp))))) + (with-current-buffer re-builder-buffer + ;; Hack: prevent reb-auto-update from clobbering the + ;; reb-regexp-src we just set + (let ((inhibit-modification-hooks t)) + (reb-initialize-buffer)) + ;; Enable flag-toggling bindings for PCRE syntax + (rxt--re-builder-switch-pcre-mode))))) + +(defadvice reb-read-regexp + (around rxt () activate compile) + "This function is hacked for emulated PCRE syntax and regexp conversion." + (if (eq reb-re-syntax 'pcre) + (setq ad-return-value + (save-excursion + (goto-char (point-min)) + (rxt-read-delimited-pcre))) + ad-do-it)) + +(defadvice reb-insert-regexp + (around rxt () activate compile) + "This function is hacked for emulated PCRE syntax and regexp conversion." + (if (eq reb-re-syntax 'pcre) + (let ((src (reb-target-binding reb-regexp-src))) + (if src + (insert "\n/" (replace-regexp-in-string "/" "\\/" src t t) "/") + (insert "\n//"))) + ad-do-it)) + +(defadvice reb-cook-regexp + (around rxt (re) activate compile) + "This function is hacked for emulated PCRE syntax and regexp conversion." + (if (eq reb-re-syntax 'pcre) + (setq ad-return-value (rxt-pcre-to-elisp re)) + ad-do-it)) + +(defadvice reb-update-regexp + (around rxt () activate compile) + "This function is hacked for emulated PCRE syntax and regexp conversion." + (setq ad-return-value + (let* ((re-src (reb-read-regexp)) + (re (reb-cook-regexp re-src))) + (with-current-buffer reb-target-buffer + (let ((oldre reb-regexp)) + (prog1 + (not (string= oldre re)) + (setq reb-regexp re) + ;; Update the source re if format requires translation + (when (or (reb-lisp-syntax-p) (eq reb-re-syntax 'pcre)) + (setq reb-regexp-src re-src)))))))) + +(defun rxt--re-builder-switch-pcre-mode () + (rxt--read-pcre-mode + (if (eq reb-re-syntax 'pcre) 1 0))) + +(add-hook 'reb-mode-hook #'rxt--re-builder-switch-pcre-mode) + +(provide 'rxt) +(provide 'pcre2el) + + +;;; pcre2el.el ends here |