bug#6347: re-builder.el initial patch

[Lars Ingebrigtsen]

Lennart Borgman <lennart.borgman@gmail.com> 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?

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


-- 
(domestic pets only, the antidote for overdose, milk.)
   bloggy blog: http://lars.ingebrigtsen.no