bug#14395: 24.3; [PATCH] new feature smie-highlight-matching-block

[Leo Liu <sdl.web@gmail.com>]

On 2013-05-15 00:02 +0800, Stefan Monnier wrote:
> I don't think enabling it in octave-mode makes sense: this is more like
> "blink-paren vs show-paren-mode", i.e. a personal preference.  So the
> enabling/disabling should be done via code in smie.el.
>
>> +  (when (and (bound-and-true-p smie-closer-alist)
>
> It's defvarred to nil, so don't test if it's boundp.
>
>> +    (let ((open-re (concat "\\_<"
>> +                           (regexp-opt (mapcar 'car smie-closer-alist))
>> +                           "\\_>"))
>> +          (close-re (concat "\\_<"
>> +                            (regexp-opt (mapcar 'cdr smie-closer-alist))
>> +                            "\\_>"))
>
> The string returned by smie-forward-token-function is usually the same
> as the representation of the token in the buffer, but not always.
> So the above is not strictly correct.
>
> Instead you want to call smie-for/backward-token-function and then
> compare the result via (r?assoc tok smie-closer-alist).
>
>> +         ((funcall beg-of-tok open-re)
>> +          (with-demoted-errors
>> +            (forward-sexp 1)
>> +            (when (looking-back close-re)
>> +              (funcall highlight (match-beginning 0) (match-end 0)))))
>
> I think this should not use with-demoted-errors but instead should
> explicitly catch the scan-error and turn it into a message.
> After all, the user doesn't want to be thrown in the debugger just
> because his sexp is not properly closed yet.  And also this way you can
> provide a much nicer error message.

Thank you for your comments, Stefan. I have taken these into account and
new patch attached.

One thing in the patch that I dislike is having to forward-declare
smie-highlight-matching-block-mode. Do you have a cleaner way?

Leo


=== modified file 'lisp/emacs-lisp/smie.el'
--- lisp/emacs-lisp/smie.el	2013-04-25 03:25:34 +0000
+++ lisp/emacs-lisp/smie.el	2013-05-15 07:03:02 +0000
@@ -966,12 +966,15 @@
         (let ((starter (funcall smie-forward-token-function)))
           (not (member (cons starter ender) smie-closer-alist))))))))
 
+(defvar smie-highlight-matching-block-mode nil) ; Silence compiler warning
+
 (defun smie-blink-matching-open ()
   "Blink the matching opener when applicable.
 This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'."
   (let ((pos (point))                   ;Position after the close token.
         token)
     (when (and blink-matching-paren
+               (not smie-highlight-matching-block-mode)
                smie-closer-alist                     ; Optimization.
                (or (eq (char-before) last-command-event) ;; Sanity check.
                    (save-excursion
@@ -1021,6 +1024,80 @@
             (let ((blink-matching-check-function #'smie-blink-matching-check))
               (blink-matching-open))))))))
 
+(defface smie-matching-block-highlight '((t (:inherit highlight)))
+  "Face used to highlight matching block."
+  :group 'smie)
+
+(defvar smie-highlight-matching-block-timer nil)
+(defvar-local smie-highlight-matching-block-overlay nil)
+(defvar-local smie-highlight-matching-block-lastpos -1)
+
+(defun smie-highlight-matching-block ()
+  (when (and smie-closer-alist
+             (/= (point) smie-highlight-matching-block-lastpos))
+    (unless (overlayp smie-highlight-matching-block-overlay)
+      (setq smie-highlight-matching-block-overlay
+            (make-overlay (point) (point))))
+    (setq smie-highlight-matching-block-lastpos (point))
+    (let ((beg-of-tok
+           (lambda (&optional start)
+             "Move to the beginning of current token."
+             (let* ((token)
+                    (start (or start (point)))
+                    (beg (progn
+                           (funcall smie-backward-token-function)
+                           (point)))
+                    (end (progn
+                           (setq token (funcall smie-forward-token-function))
+                           (point))))
+               (if (and (<= beg start) (<= start end)
+                        (or (assoc token smie-closer-alist)
+                            (rassoc token smie-closer-alist)))
+                   (progn (goto-char beg) token)
+                 (goto-char start)
+                 nil))))
+          (highlight (lambda (beg end)
+                       (move-overlay smie-highlight-matching-block-overlay
+                                     beg end)
+                       (overlay-put smie-highlight-matching-block-overlay
+                                    'face 'smie-matching-block-highlight))))
+      (save-excursion
+        (condition-case nil
+            (if (nth 8 (syntax-ppss))
+                (overlay-put smie-highlight-matching-block-overlay 'face nil)
+              (let ((token
+                     (or (funcall beg-of-tok)
+                         (funcall beg-of-tok
+                                  (prog1 (point)
+                                    (funcall smie-forward-token-function))))))
+                (cond
+                 ((assoc token smie-closer-alist) ; opener
+                  (forward-sexp 1)
+                  (let ((end (point))
+                        (closer (funcall smie-backward-token-function)))
+                    (when (rassoc closer smie-closer-alist)
+                      (funcall highlight (point) end))))
+                 ((rassoc token smie-closer-alist) ; closer
+                  (funcall smie-forward-token-function)
+                  (forward-sexp -1)
+                  (let ((beg (point))
+                        (opener (funcall smie-forward-token-function)))
+                    (when (assoc opener smie-closer-alist)
+                      (funcall highlight beg (point)))))
+                 (t (overlay-put smie-highlight-matching-block-overlay
+                                 'face nil)))))
+          (scan-error
+           (overlay-put smie-highlight-matching-block-overlay 'face nil)))))))
+
+;;;###autoload
+(define-minor-mode smie-highlight-matching-block-mode nil
+  :global t :group 'smie
+  (if smie-highlight-matching-block-mode
+      (setq smie-highlight-matching-block-timer
+            (run-with-idle-timer 0.2 t #'smie-highlight-matching-block))
+    (when (timerp smie-highlight-matching-block-timer)
+      (cancel-timer smie-highlight-matching-block-timer))))
+
 ;;; The indentation engine.
 
 (defcustom smie-indent-basic 4