code.delx.au - gnu-emacs/blob - lisp/paren.el

   1 ;;; paren.el --- highlight matching paren.
   2 ;; Copyright (C) 1993 Free Software Foundation, Inc.
   3
   4 ;; Author: rms@gnu.ai.mit.edu
   5 ;; Maintainer: FSF
   6 ;; Keywords: languages, faces
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; Load this and it will display highlighting on whatever
  27 ;; paren matches the one before or after point.
  28
  29 ;;; Code:
  30
  31 ;; This is the overlay used to highlight the matching paren.
  32 (defvar show-paren-overlay nil)
  33 ;; This is the overlay used to highlight the closeparen
  34 ;; right before point.
  35 (defvar show-paren-overlay-1 nil)
  36
  37 (defvar show-paren-mismatch-face nil)
  38
  39 (defvar show-paren-face 'region
  40   "*Name of face to use for showing the matching paren.")
  41
  42 ;; Find the place to show, if there is one,
  43 ;; and show it until input arrives.
  44 (defun show-paren-command-hook ()
  45   ;; Do nothing if no window system to display results with.
  46   ;; Do nothing if executing keyboard macro.
  47   ;; Do nothing if input is pending.
  48   (if window-system
  49       (let (pos dir mismatch (oldpos (point))
  50                 (face show-paren-face))
  51         (cond ((eq (char-syntax (preceding-char)) ?\))
  52                (setq dir -1))
  53               ((eq (char-syntax (following-char)) ?\()
  54                (setq dir 1)))
  55         (if dir
  56             (save-excursion
  57               (save-restriction
  58                 ;; Determine the range within which to look for a match.
  59                 (if blink-matching-paren-distance
  60                     (narrow-to-region (max (point-min)
  61                                            (- (point) blink-matching-paren-distance))
  62                                       (min (point-max)
  63                                            (+ (point) blink-matching-paren-distance))))
  64                 ;; Scan across one sexp within that range.
  65                 (condition-case ()
  66                     (setq pos (scan-sexps (point) dir))
  67                   (error nil))
  68                 ;; See if the "matching" paren is the right kind of paren
  69                 ;; to match the one we started at.
  70                 (if pos
  71                     (let ((beg (min pos oldpos)) (end (max pos oldpos)))
  72                       (and (/= (char-syntax (char-after beg)) ?\$)
  73                            (setq mismatch
  74                                  (not (eq (char-after (1- end))
  75                                           ;; This can give nil.
  76                                           (matching-paren (char-after beg))))))))
  77                 ;; If they don't properly match, use a different face,
  78                 ;; or print a message.
  79                 (if mismatch
  80                     (progn
  81                       (and (null show-paren-mismatch-face)
  82                            (x-display-color-p)
  83                            (progn
  84                              (add-to-list 'facemenu-unlisted-faces
  85                                           'paren-mismatch)
  86                              (make-face 'paren-mismatch)
  87                              (or (face-nontrivial-p 'paren-mismatch t)
  88                                  (progn
  89                                    (set-face-background 'paren-mismatch
  90                                                         "purple")
  91                                    (set-face-foreground 'paren-mismatch
  92                                                         "white")))
  93                              (setq show-paren-mismatch-face 'paren-mismatch)))
  94                       (if show-paren-mismatch-face
  95                           (setq face show-paren-mismatch-face)
  96                         (message "Paren mismatch"))))
  97                 )))
  98         (cond (pos
  99                (if (= dir -1)
 100                    ;; If matching backwards, highlight the closeparen
 101                    ;; before point as well as its matching open.
 102                    (progn
 103                      (if show-paren-overlay-1
 104                          (move-overlay show-paren-overlay-1
 105                                        (+ (point) dir) (point)
 106                                        (current-buffer))
 107                        (setq show-paren-overlay-1
 108                              (make-overlay (- pos dir) pos)))
 109                      ;; Always set the overlay face, since it varies.
 110                      (overlay-put show-paren-overlay-1 'face face))
 111                  ;; Otherwise, turn off any such highlighting.
 112                  (and show-paren-overlay-1
 113                       (overlay-buffer show-paren-overlay-1)
 114                       (delete-overlay show-paren-overlay-1)))
 115                ;; Turn on highlighting for the matching paren.
 116                (if show-paren-overlay
 117                    (move-overlay show-paren-overlay (- pos dir) pos
 118                                  (current-buffer))
 119                  (setq show-paren-overlay
 120                        (make-overlay (- pos dir) pos)))
 121                ;; Always set the overlay face, since it varies.
 122                (overlay-put show-paren-overlay 'face face))
 123               (t
 124                ;; If not at a paren that has a match,
 125                ;; turn off any previous paren highlighting.
 126                (and show-paren-overlay (overlay-buffer show-paren-overlay)
 127                     (delete-overlay show-paren-overlay))
 128                (and show-paren-overlay-1 (overlay-buffer show-paren-overlay-1)
 129                     (delete-overlay show-paren-overlay-1)))))))
 130
 131 (if window-system
 132     (progn
 133       (setq blink-matching-paren-on-screen nil)
 134       (add-hook 'post-command-idle-hook 'show-paren-command-hook)))
 135 ;;; This is in case paren.el is preloaded.
 136 (add-hook 'window-setup-hook
 137           (function (lambda ()
 138                       (if window-system
 139                           (progn
 140                             (setq blink-matching-paren-on-screen nil)
 141                             (add-hook 'post-command-idle-hook
 142                                       'show-paren-command-hook))))))
 143 (provide 'paren)
 144
 145 ;;; paren.el ends here