From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Lars Ingebrigtsen Newsgroups: gmane.emacs.bugs Subject: bug#6347: re-builder.el initial patch Date: Fri, 26 Feb 2016 17:30:07 +1030 Message-ID: <8737sgt0qw.fsf@gnus.org> References: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1456470088 13686 80.91.229.3 (26 Feb 2016 07:01:28 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Fri, 26 Feb 2016 07:01:28 +0000 (UTC) Cc: 6347@debbugs.gnu.org To: Lennart Borgman Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Fri Feb 26 08:01:13 2016 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1aZCOn-0001Hw-A8 for geb-bug-gnu-emacs@m.gmane.org; Fri, 26 Feb 2016 08:01:13 +0100 Original-Received: from localhost ([::1]:47768 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aZCOm-0003ej-JU for geb-bug-gnu-emacs@m.gmane.org; Fri, 26 Feb 2016 02:01:12 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:51526) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aZCOh-0003eS-JR for bug-gnu-emacs@gnu.org; Fri, 26 Feb 2016 02:01:09 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aZCOc-0005us-GZ for bug-gnu-emacs@gnu.org; Fri, 26 Feb 2016 02:01:07 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:49593) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aZCOc-0005uo-Bz for bug-gnu-emacs@gnu.org; Fri, 26 Feb 2016 02:01:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84) (envelope-from ) id 1aZCOc-00051S-1Q for bug-gnu-emacs@gnu.org; Fri, 26 Feb 2016 02:01:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Lars Ingebrigtsen Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Fri, 26 Feb 2016 07:01:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 6347 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: Original-Received: via spool by 6347-submit@debbugs.gnu.org id=B6347.145647004618503 (code B ref 6347); Fri, 26 Feb 2016 07:01:01 +0000 Original-Received: (at 6347) by debbugs.gnu.org; 26 Feb 2016 07:00:46 +0000 Original-Received: from localhost ([127.0.0.1]:46720 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aZCOM-0004nt-2o for submit@debbugs.gnu.org; Fri, 26 Feb 2016 02:00:46 -0500 Original-Received: from hermes.netfonds.no ([80.91.224.195]:44890) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aZCOJ-0004kp-Pn for 6347@debbugs.gnu.org; Fri, 26 Feb 2016 02:00:44 -0500 Original-Received: from [175.103.25.178] (helo=mouse) by hermes.netfonds.no with esmtpsa (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1aZCNn-0006Ek-SM; Fri, 26 Feb 2016 08:00:12 +0100 In-Reply-To: (Lennart Borgman's message of "Fri, 4 Jun 2010 04:26:38 +0200") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.1.50 (gnu/linux) X-MailScanner-ID: 1aZCNn-0006Ek-SM MailScanner-NULL-Check: 1457074814.01454@s37TtFsaJGdBqmvtG6k6eg X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.bugs:113853 Archived-At: --=-=-= Content-Type: text/plain Lennart Borgman writes: > Here is an initial path for re-builder.el. It tries to add the following: > > - Syntax-hilighting in re-builder window > - Some small menu fixes > - copy regexp did not take care of new lines > - Try to stay where you are when starting re-builder > > Comments? Looks good to me. It didn't quite apply, so I made the obvious changes, and new version appended below. This probably needs an etc/NEWS item. Could you submit one? --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=reb.diff diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 01e5241..64103a9 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -240,6 +240,7 @@ reb-mode-map (define-key menu-map [rq] '(menu-item "Quit" reb-quit :help "Quit the RE Builder mode")) + (define-key menu-map [div1] '(menu-item "--")) (define-key menu-map [rt] '(menu-item "Case sensitive" reb-toggle-case :button (:toggle . (with-current-buffer @@ -252,6 +253,7 @@ reb-mode-map (define-key menu-map [rs] '(menu-item "Change syntax..." reb-change-syntax :help "Change the syntax used by the RE Builder")) + (define-key menu-map [div2] '(menu-item "--")) (define-key menu-map [re] '(menu-item "Enter subexpression mode" reb-enter-subexp-mode :help "Enter the subexpression mode in the RE Builder")) @@ -264,6 +266,7 @@ reb-mode-map (define-key menu-map [rp] '(menu-item "Go to previous match" reb-prev-match :help "Go to previous match in the RE Builder target window")) + (define-key menu-map [div3] '(menu-item "--")) (define-key menu-map [rc] '(menu-item "Copy current RE" reb-copy :help "Copy current RE into the kill ring for later insertion")) @@ -339,6 +342,7 @@ reb-initialize-buffer (cond ((reb-lisp-syntax-p) (reb-lisp-mode)) (t (reb-mode))) + (reb-restart-font-lock) (reb-do-update)) (defun reb-mode-buffer-p () @@ -371,6 +375,7 @@ re-builder (setq reb-window-config (current-window-configuration)) (split-window (selected-window) (- (window-height) 4))))) (switch-to-buffer (get-buffer-create reb-buffer)) + (font-lock-mode 1) (reb-initialize-buffer))) (defun reb-change-target-buffer (buf) @@ -447,7 +452,9 @@ reb-copy (reb-update-regexp) (let ((re (with-output-to-string (print (reb-target-binding reb-regexp))))) - (kill-new (substring re 1 (1- (length re)))) + (setq re (substring re 1 (1- (length re)))) + (setq re (replace-regexp-in-string "\n" "\\n" re nil t)) + (kill-new re) (message "Regexp copied to kill-ring"))) ;; The subexpression mode is not electric because the number of @@ -483,6 +490,8 @@ reb-quit-subexp-mode (use-local-map reb-mode-map) (reb-do-update)) +(defvar reb-change-syntax-hist nil) + (defun reb-change-syntax (&optional syntax) "Change the syntax used by the RE Builder. Optional argument SYNTAX must be specified if called non-interactively." @@ -491,7 +500,8 @@ reb-change-syntax (completing-read "Select syntax: " (mapcar (lambda (el) (cons (symbol-name el) 1)) '(read string sregex rx)) - nil t (symbol-name reb-re-syntax))))) + nil t (symbol-name reb-re-syntax) + 'reb-change-syntax-hist)))) (if (memq syntax '(read string sregex rx)) (let ((buffer (get-buffer reb-buffer))) @@ -653,8 +663,14 @@ reb-update-overlays (subexps (reb-count-subexps re)) (matches 0) (submatches 0) - firstmatch) + firstmatch + here + firstmatch-after-here) (with-current-buffer reb-target-buffer + (setq here + (if reb-target-window + (with-selected-window reb-target-window (window-point)) + (point))) (reb-delete-overlays) (goto-char (point-min)) (while (and (not (eobp)) @@ -689,6 +705,9 @@ reb-update-overlays ;; `reb-match-1' must exist. 'reb-match-1)))) (unless firstmatch (setq firstmatch (match-data))) + (unless firstmatch-after-here + (when (> (point) here) + (setq firstmatch-after-here (match-data)))) (setq reb-overlays (cons overlay reb-overlays) submatches (1+ submatches)) (overlay-put overlay 'face face) @@ -703,7 +722,7 @@ reb-update-overlays (= reb-auto-match-limit count)) " (limit reached)" ""))) (when firstmatch - (store-match-data firstmatch) + (store-match-data (or firstmatch-after-here firstmatch)) (reb-show-subexp (or subexp 0))))) ;; The End @@ -718,6 +737,124 @@ re-builder-unload-function ;; continue standard unloading nil) +(defun reb-fontify-string-re (bound) + (catch 'found + ;; The following loop is needed to continue searching after matches + ;; that do not occur in strings. The associated regexp matches one + ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to + ;; avoid highlighting, for example, `\\(' in `\\\\('. + (when (memq reb-re-syntax '(read string)) + (while (re-search-forward + (if (eq reb-re-syntax 'read) + ;; Copied from font-lock.el + "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" + "\\(\\\\\\)\\(?:\\(\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)") + bound t) + (unless (match-beginning 2) + (let ((face (get-text-property (1- (point)) 'face))) + (when (or (and (listp face) + (memq 'font-lock-string-face face)) + (eq 'font-lock-string-face face) + t) + (throw 'found t)))))))) + +(defface reb-regexp-grouping-backslash + '((t :inherit font-lock-keyword-face :weight bold :underline t)) + "Font Lock mode face for backslashes in Lisp regexp grouping constructs." + :group 're-builder) + +(defface reb-regexp-grouping-construct + '((t :inherit font-lock-keyword-face :weight bold :underline t)) + "Font Lock mode face used to highlight grouping constructs in Lisp regexps." + :group 're-builder) + +(defconst reb-string-font-lock-keywords + (eval-when-compile + '(((reb-fontify-string-re + (1 'reb-regexp-grouping-backslash prepend) + (3 'reb-regexp-grouping-construct prepend)) + (reb-mark-non-matching-parenthesis)) + nil))) + +(defsubst reb-while (limit counter where) + (let ((count (symbol-value counter))) + (if (= count limit) + (progn + (msgtrc "Reached (while limit=%s, where=%s)" limit where) + nil) + (set counter (1+ count))))) + +(defun reb-mark-non-matching-parenthesis (bound) + ;; We have a small string, check the whole of it, but wait until + ;; everything else is fontified. + (when (>= bound (point-max)) + (let ((here (point)) + left-pars + (n-reb 0) + faces-here + ) + (goto-char (point-min)) + (while (and (reb-while 100 'n-reb "mark-par") + (not (eobp))) + (skip-chars-forward "^()") + (unless (eobp) + (setq faces-here (get-text-property (point) 'face)) + ;; It is already fontified, use that info: + (when (or (eq 'reb-regexp-grouping-construct faces-here) + (and (listp faces-here) + (memq 'reb-regexp-grouping-construct faces-here))) + (cond ((eq (char-after) ?\() + (setq left-pars (cons (point) left-pars))) + ((eq (char-after) ?\)) + (if left-pars + (setq left-pars (cdr left-pars)) + (put-text-property (point) (1+ (point)) + 'face 'font-lock-warning-face))) + (t (message "markpar: char-after=%s" (char-to-string (char-after)))))) + (forward-char))) + (dolist (lp left-pars) + (put-text-property lp (1+ lp) + 'face 'font-lock-warning-face))))) + +(require 'rx) +(defconst reb-rx-font-lock-keywords + (let ((constituents (mapcar (lambda (rec) (symbol-name (car rec))) rx-constituents)) + (syntax (mapcar (lambda (rec) (symbol-name (car rec))) rx-syntax)) + (categories (mapcar (lambda (rec) (symbol-name (car rec))) rx-categories))) + `( + (,(concat "(" (regexp-opt (list "rx-to-string") t) "[[:space:]]") + (1 font-lock-function-name-face)) + (,(concat "(" (regexp-opt (list "rx") t) "[[:space:]]") + (1 font-lock-preprocessor-face)) + (,(concat "(category[[:space:]]+" (regexp-opt categories t) ")") + (1 font-lock-variable-name-face)) + (,(concat "(syntax[[:space:]]+" (regexp-opt syntax t) ")") + (1 font-lock-type-face)) + (,(concat "(" (regexp-opt constituents t)) + (1 font-lock-keyword-face)) + ))) + +(defun reb-restart-font-lock () + "Restart `font-lock-mode' to fit current regexp format." + ;;(set-default 'font-lock-keywords nil) + ;;(set-default 'font-lock-set-defaults nil) + (message "reb-restart-font-lock re-re-syntax=%s" reb-re-syntax) + (with-current-buffer (get-buffer reb-buffer) + (let ((font-lock-is-on font-lock-mode)) + (font-lock-mode -1) + (kill-local-variable 'font-lock-set-defaults) + ;;(set (make-local-variable 'reb-re-syntax) 'string) + ;;(set (make-local-variable 'reb-re-syntax) 'rx) + (setq font-lock-defaults + (cond + ((memq reb-re-syntax '(read string)) + reb-string-font-lock-keywords) + ((eq reb-re-syntax 'rx) + '(reb-rx-font-lock-keywords + nil)) + (t nil))) + (when font-lock-is-on (font-lock-mode 1))))) + (provide 're-builder) ;;; re-builder.el ends here --=-=-= Content-Type: text/plain -- (domestic pets only, the antidote for overdose, milk.) bloggy blog: http://lars.ingebrigtsen.no --=-=-=--