cgit.sxemacs.org Git - packages/blob - xemacs-packages/edit-utils/blink-paren.el

   1 ;;; blink-paren.el --- blink the matching paren, just like Zmacs
   2 ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
   3
   4 ;; Author: devin@lucid.com.
   5 ;; Keywords: faces
   6
   7 ;; This file is part of XEmacs.
   8
   9 ;; XEmacs is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; XEmacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with XEmacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Synched up with: Not in FSF.
  25
  26 (defvar blink-paren-timeout 0.2
  27   "*If the cursor is on a parenthesis, the matching parenthesis will blink.
  28 This variable controls how long each phase of the blink lasts in seconds.
  29 This should be a fractional part of a second (a float.)")
  30
  31 (defvar highlight-paren-expression nil
  32   "*If true, highlight the whole expression of the paren under the cursor
  33 instead of blinking (or highlighting) the matching paren.  This will highlight
  34 the expression using the `highlight-expression' face.")
  35
  36 ;;; The blinking paren alternates between the faces blink-paren-on and
  37 ;;; blink-paren-off.  The default is for -on to look just like default
  38 ;;; text, and -off to be invisible.  You can change this so that, for
  39 ;;; example, the blinking paren fluctuates between bold and italic...
  40 ;;;
  41 ;;; You can make the matching paren merely be highlighted (and not blink)
  42 ;;; by setting the blink-paren-on and blink-paren-off faces to have the same
  43 ;;; attributes; if you do this, then emacs will not consume as much CPU.
  44 ;;;
  45 ;;; If highlight-paren-expression is true, then the whole sexp between the
  46 ;;; parens will be displayed in the `highlight-expression' face instead.
  47
  48 (make-face 'blink-paren-on)
  49 (make-face 'blink-paren-off)
  50 (make-face 'highlight-expression)
  51
  52 ;; extent used to change the face of the matching paren
  53 (defvar blink-paren-extent nil)
  54
  55 ;; timeout to blink the face
  56 (defvar blink-paren-timeout-id nil)
  57
  58 ;; find if we should look forward or backward to find the matching paren
  59 (defun blink-paren-sexp-dir ()
  60   (cond ((and (< (point) (point-max))
  61               (eq (char-syntax (char-after (point))) ?\())
  62          1)
  63         ((and (> (point) (point-min))
  64               (eq (char-syntax (char-after (- (point) 1))) ?\)))
  65          -1)
  66         (t ())))
  67
  68 ;; make an extent on the matching paren if any.  return it.
  69 (defun blink-paren-make-extent ()
  70   (let ((dir (blink-paren-sexp-dir)))
  71     (and dir
  72          (condition-case ()
  73              (let* ((parse-sexp-ignore-comments t)
  74                     (other-pos (let ((pmin (point-min))
  75                                      (pmax (point-max))
  76                                      (point (point)))
  77                                  (unwind-protect
  78                                      (progn
  79                                        (narrow-to-region
  80                                         (max pmin (- point blink-matching-paren-distance))
  81                                         (min pmax (+ point blink-matching-paren-distance)))
  82                                        (forward-sexp dir) (point))
  83                                    (narrow-to-region pmin pmax)
  84                                    (goto-char point))))
  85                     (extent (if (= dir 1)
  86                                 (make-extent (if highlight-paren-expression
  87                                                  (point)
  88                                                (- other-pos 1))
  89                                              other-pos)
  90                               (make-extent other-pos
  91                                            (if highlight-paren-expression
  92                                                (point)
  93                                              (+ other-pos 1))))))
  94                (set-extent-face extent (if highlight-paren-expression
  95                                            'highlight-expression
  96                                          'blink-paren-on))
  97                extent)
  98            (error nil)))))
  99
 100 ;; callback for the timeout
 101 ;; swap the face of the extent on the matching paren
 102 (defun blink-paren-timeout (arg)
 103   ;; The extent could have been deleted for some reason and not point to a
 104   ;; buffer anymore.  So catch any error to remove the timeout.
 105   (condition-case ()
 106       (set-extent-face blink-paren-extent
 107                        (if (eq (extent-face blink-paren-extent)
 108                                'blink-paren-on)
 109                            'blink-paren-off
 110                          'blink-paren-on))
 111     (error (blink-paren-pre-command))))
 112
 113 ;; called after each command is executed in the post-command-hook
 114 ;; add the extent and the time-out if we are on a paren.
 115 (defun blink-paren-post-command ()
 116   (blink-paren-pre-command)
 117   (if (and (setq blink-paren-extent (blink-paren-make-extent))
 118            (not highlight-paren-expression)
 119            (not (and (face-equal 'blink-paren-on 'blink-paren-off)
 120                      (progn
 121                        (set-extent-face blink-paren-extent 'blink-paren-on)
 122                        t)))
 123            (or (floatp blink-paren-timeout)
 124                (integerp blink-paren-timeout)))
 125       (setq blink-paren-timeout-id
 126             (add-timeout blink-paren-timeout 'blink-paren-timeout ()
 127                          blink-paren-timeout))))
 128
 129 ;; called before a new command is executed in the pre-command-hook
 130 ;; cleanup by removing the extent and the time-out
 131 (defun blink-paren-pre-command ()
 132   (condition-case c  ; don't ever signal an error in pre-command-hook!
 133       (let ((inhibit-quit t))
 134         (if blink-paren-timeout-id
 135             (disable-timeout (prog1 blink-paren-timeout-id
 136                                (setq blink-paren-timeout-id nil))))
 137         (if blink-paren-extent
 138             (delete-extent (prog1 blink-paren-extent
 139                              (setq blink-paren-extent nil)))))
 140     (error
 141      (message "blink paren error! %s" c))))
 142
 143
 144 (defun blink-paren (&optional arg)
 145   "Toggles paren blinking on and off.
 146 With a positive argument, turns it on.
 147 With a non-positive argument, turns it off."
 148   (interactive "P")
 149   (let* ((was-on (not (not (memq 'blink-paren-pre-command pre-command-hook))))
 150          (on-p (if (null arg)
 151                    (not was-on)
 152                 (> (prefix-numeric-value arg) 0))))
 153     (cond (on-p
 154
 155            ;; in case blink paren was dumped, this needs to be setup
 156            (or (face-differs-from-default-p 'blink-paren-off)
 157                (progn
 158                  (set-face-background 'blink-paren-off (face-background 'default))
 159                  (set-face-foreground 'blink-paren-off (face-background 'default))))
 160
 161            (or (face-differs-from-default-p 'highlight-expression)
 162                (set-face-underline-p 'highlight-expression t))
 163
 164            (add-hook 'pre-command-hook 'blink-paren-pre-command)
 165            (add-hook 'post-command-hook 'blink-paren-post-command)
 166            (setq blink-matching-paren nil))
 167           (t
 168            (remove-hook 'pre-command-hook 'blink-paren-pre-command)
 169            (remove-hook 'post-command-hook 'blink-paren-post-command)
 170            (and blink-paren-extent (detach-extent blink-paren-extent))
 171            (setq blink-matching-paren t)))
 172     on-p))
 173
 174 (defun blink-paren-init ()
 175   "obsolete - use `blink-paren' instead."
 176   (interactive)
 177   (blink-paren 1))
 178
 179 (provide 'blink-paren)
 180
 181 (blink-paren 1)