Subject: re-builder.el initial patch

From: Lennart Borgman <[email-masked]>
Date: Fri, 4 Jun 2010 04:26:38 +0200

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?

I will add copying to regexp from target buffer later.
=== modified file 'lisp/emacs-lisp/re-builder.el'
--- trunk/lisp/emacs-lisp/re-builder.el	2010-01-13 08:35:10 +0000
+++ patched/lisp/emacs-lisp/re-builder.el	2010-06-04 02:17:08 +0000
@@ -245,6 +245,7 @@
     (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 . case-fold-search)
@@ -255,6 +256,7 @@
     (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"))
@@ -267,6 +269,7 @@
     (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"))
@@ -343,6 +346,7 @@
   (cond ((reb-lisp-syntax-p)
          (reb-lisp-mode))
         (t (reb-mode)))
+  (reb-restart-font-lock)
   (reb-do-update))
 
 (defun reb-mode-buffer-p ()
@@ -370,6 +374,7 @@
 			 (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)
@@ -446,7 +451,9 @@
   (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
@@ -482,6 +489,8 @@
   (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."
@@ -490,7 +499,8 @@
 	  (completing-read "Select syntax: "
 			   (mapcar (lambda (el) (cons (symbol-name el) 1))
 				   '(read string lisp-re 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 lisp-re sregex rx))
       (let ((buffer (get-buffer reb-buffer)))
@@ -657,8 +667,14 @@
 	 (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))
@@ -693,6 +709,9 @@
 			;; `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)
@@ -707,7 +726,7 @@
 			(= 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
@@ -723,6 +742,124 @@
   ;; 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)
 
 ;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7