Mercurial > hg > xemacs-beta

comparison lisp/packages/paren.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; paren.el --- highlight (un)matching parens and whole expressions
2
3 ;; Copyright (C) 1993 Free Software Foundation, Inc.
4 ;; Copyright (C) 1993, 1994, 1995 Tinker Systems
5 ;;
6 ;; Author: Jonathan Stigelman <Stig@hackvan.com>
7 ;; Note: (some code scammed from simple.el and blink-paren.el)
8 ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
9 ;; Keywords: languages, faces
10
11 ;;; This file is part of XEmacs.
12 ;;;
13 ;;; XEmacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2 of the License, or
16 ;;; (at your option) any later version.
17 ;;;
18 ;;; XEmacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with XEmacs; if not, write to the Free Software
25 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
26
27 ;;; Synched up with: Not synched with FSF.
28 ;;; Way different from FSF.
29
30 ;;; Commentary:
31
32 ;; Purpose of this package:
33 ;;
34 ;; This package highlights matching parens (or whole sexps) for easier
35 ;; editing of source code, particularly lisp source code.
36 ;;
37 ;; The `paren-highlight' hook function runs after each command and
38 ;; checks to see if the cursor is at a parenthesis. If so, then it
39 ;; highlights, in one of several ways, the matching parenthesis.
40 ;;
41 ;; Priority is given to matching parentheses right before the cursor because
42 ;; that's what makes sense when you're typing a lot of closed parentheses.
43 ;;
44 ;; This is especially intuitive if you frequently use forward-sexp (M-C-f)
45 ;; and backward-sexp (M-C-b) to maneuver around in source code.
46 ;;
47 ;; Different faces are used for matching and mismatching parens so that it
48 ;; is easier to see mistakes as you type them. Audible feedback is optional.
49 ;;
50 ;; If a (mis)matching paren is offscreen, then a message is sent to the modeline.
51 ;;
52 ;; If paren-mode is `sexp', entire S-expressions are highlighted instead of
53 ;; just matching parens.
54
55 ;;; Code:
56
57 (defvar paren-message-offscreen t
58 "*Display message if matching open paren is offscreen.")
59
60 (defvar paren-ding-unmatched nil
61 "*Make noise if the cursor is at an unmatched paren.
62
63 If T, then typing or passing over an unmatched paren will ring the bell
64 using the `paren' sound. If NIL, then the bell will not ring even if an
65 unmatched paren is typed. If neither T or NIL, then the bell will not ring
66 when the cursor moves over unmatched parens but will ring if one is typed.")
67
68 ;;;###autoload
69 (defvar paren-mode nil
70 "*Sets the style of parenthesis highlighting.
71 Valid values are nil, `blink-paren', `paren', and `sexp'.
72 nil no parenthesis highlighting.
73 blink-paren causes the matching paren to blink.
74 paren causes the matching paren to be highlighted but not to blink.
75 sexp whole expression enclosed by the local paren at its mate.
76 nested (not yet implemented) use variable shading to see the
77 nesting of an expression. Also groks regular expressions
78 and shell quoting.
79
80 This variable is global by default, but you can make it buffer-local and
81 highlight parentheses differrently in different major modes.")
82
83 (make-face 'paren-match)
84 (or (face-differs-from-default-p 'paren-match)
85 (copy-face 'highlight 'paren-match))
86
87 (make-face 'paren-mismatch)
88 (cond ((face-differs-from-default-p 'paren-mismatch) nil)
89 (t (let ((color-tag (list 'x 'color))
90 (mono-tag (list 'x 'mono))
91 (gray-tag (list 'x 'grayscale)))
92 (set-face-background 'paren-mismatch "DeepPink" 'global color-tag)
93 (set-face-reverse-p 'paren-mismatch t 'global 'tty)
94 (set-face-background 'paren-mismatch [modeline background] 'global
95 mono-tag)
96 (set-face-foreground 'paren-mismatch [modeline foreground] 'global
97 mono-tag)
98 (set-face-background 'paren-mismatch [modeline background] 'global
99 gray-tag)
100 (set-face-foreground 'paren-mismatch [modeline foreground] 'global
101 gray-tag))))
102
103 (make-face 'paren-blink-off)
104 (or (face-differs-from-default-p 'paren-blink-off)
105 (set-face-foreground 'paren-blink-off (face-background 'default)))
106
107 ;; this is either paren-match or paren-mismatch...
108 (defvar paren-blink-on-face nil)
109
110 (defvar paren-blink-interval 0.2
111 "*If the cursor is on a parenthesis, the matching parenthesis will blink.
112 This variable controls how long each phase of the blink lasts in seconds.
113 This should be a fractional part of a second (a float.)")
114
115 (defvar paren-max-blinks (* 5 60 5) ; 5 minutes is plenty...
116 ;; idea from Eric Eide <eeide@jaguar.cs.utah.edu>
117 "*Maximum number of times that a matching parenthesis will blink.
118 Set this to NIL if you want indefinite blinking.")
119
120 ;; timeout to blink the face
121 (defvar paren-timeout-id nil)
122
123 ;; Code:
124
125 (defvar paren-n-blinks)
126 (defvar paren-extent nil)
127
128 ;; used to suppress messages from the same position so that other messages
129 ;; can be seen in the modeline.
130 (make-variable-buffer-local
131 (defvar paren-message-suppress nil))
132
133 (defsubst pos-visible-in-window-safe (pos)
134 "safe version of pos-visible-in-window-p"
135 (condition-case nil
136 ;; #### - is this needed in XEmacs???
137 (pos-visible-in-window-p pos)
138 (args-out-of-range nil)))
139
140 ;; called before a new command is executed in the pre-command-hook
141 ;; cleanup by removing the extent and the time-out
142 (defun paren-nuke-extent ()
143 (condition-case c ; don't ever signal an error in pre-command-hook!
144 (let ((inhibit-quit t))
145 (if paren-timeout-id
146 (disable-timeout (prog1 paren-timeout-id
147 (setq paren-timeout-id nil))))
148 (if paren-extent
149 (delete-extent (prog1 paren-extent
150 (setq paren-extent nil)))))
151 (error
152 (message "paren-nuke-extent error! %s" c))))
153
154 ;; callback for the timeout
155 ;; swap the face of the extent on the matching paren
156 (defun paren-blink-timeout (arg)
157 ;; The extent could have been deleted for some reason and not point to a
158 ;; buffer anymore. So catch any error to remove the timeout.
159 (condition-case ()
160 (if (and paren-max-blinks
161 (> (setq paren-n-blinks (1+ paren-n-blinks)) paren-max-blinks))
162 (paren-nuke-extent)
163 (set-extent-face paren-extent
164 (if (eq (extent-face paren-extent)
165 paren-blink-on-face)
166 'paren-blink-off
167 paren-blink-on-face)))
168 (error (paren-nuke-extent))))
169
170
171 (defun paren-describe-match (pos mismatch)
172 (or (window-minibuffer-p (selected-window))
173 (save-excursion
174 (goto-char pos)
175 (message "%s %s"
176 (if mismatch "MISMATCH:" "Matches")
177 ;; if there's stuff on this line preceding the paren, then
178 ;; display text from beginning of line to paren.
179 ;;
180 ;; If, however, the paren is at the beginning of a line, then
181 ;; skip whitespace forward and display text from paren to end
182 ;; of the next line containing nonspace text.
183 ;;
184 ;; If paren-backwards-message gravity were implemented, then
185 ;; perhaps it would reverse this behavior and look to the
186 ;; previous line for meaningful context.
187 (if (save-excursion
188 (skip-chars-backward " \t")
189 (not (bolp)))
190 (concat (buffer-substring
191 (progn (beginning-of-line) (point))
192 (1+ pos)) "...")
193 (buffer-substring
194 pos (progn
195 (forward-char 1)
196 (skip-chars-forward "\n \t")
197 (end-of-line)
198 (point))))))))
199
200 (defun paren-maybe-ding ()
201 (and (or (eq paren-ding-unmatched t)
202 (and paren-ding-unmatched
203 (eq this-command 'self-insert-command)))
204 (progn
205 (message "Unmatched parenthesis.")
206 (ding nil 'paren))))
207
208 ;; Find the place to show, if there is one,
209 ;; and show it until input arrives.
210 (defun paren-highlight ()
211 "This highlights matching parentheses.
212
213 See the variables:
214 paren-message-offscreen use modeline when matchingparen is offscreen?
215 paren-ding-unmatched make noise when passing over mismatched parens?
216 paren-mode 'blink-paren, 'paren, or 'sexp
217 blink-matching-paren-distance maximum distance to search for parens.
218
219 and the following faces:
220 paren-match, paren-mismatch, paren-blink-off"
221
222 ;; I suppose I could check here to see if a keyboard macro is executing,
223 ;; but I did a quick empirical check and couldn't tell that there was any
224 ;; difference in performance
225
226 (let ((oldpos (point))
227 (pface nil) ; face for paren...nil kills the overlay
228 (dir (and paren-mode
229 (not (input-pending-p))
230 (not executing-kbd-macro)
231 (cond ((eq (char-syntax (preceding-char)) ?\))
232 -1)
233 ((eq (char-syntax (following-char)) ?\()
234 1))))
235 pos mismatch)
236
237 (save-excursion
238 (if (or (not dir)
239 (not (save-restriction
240 ;; Determine the range within which to look for a match.
241 (if blink-matching-paren-distance
242 (narrow-to-region
243 (max (point-min)
244 (- (point) blink-matching-paren-distance))
245 (min (point-max)
246 (+ (point) blink-matching-paren-distance))))
247
248 ;; Scan across one sexp within that range.
249 (condition-case nil
250 (setq pos (scan-sexps (point) dir))
251 ;; NOTE - if blink-matching-paren-distance is set,
252 ;; then we can have spurious unmatched parens.
253 (error (paren-maybe-ding)
254 nil)))))
255
256 ;; do nothing if we didn't find a matching paren...
257 nil
258
259 ;; See if the "matching" paren is the right kind of paren
260 ;; to match the one we started at.
261 (let ((beg (min pos oldpos)) (end (max pos oldpos)))
262 (setq mismatch
263 (and (/= (char-syntax (char-after beg)) ?\\)
264 (/= (char-syntax (char-after beg)) ?\$)
265 (/= (char-after (1- end))
266 (logand (lsh (aref (syntax-table)
267 (char-after beg))
268 -8)
269 255))))
270 (if (eq paren-mode 'sexp)
271 (setq paren-extent (make-extent beg end))))
272 (and mismatch
273 (paren-maybe-ding))
274 (setq pface (if mismatch
275 'paren-mismatch
276 'paren-match))
277 (and (memq paren-mode '(blink-paren paren))
278 (setq paren-extent (make-extent (- pos dir) pos)))
279
280 (if (and paren-message-offscreen
281 (eq dir -1)
282 (not (eq paren-message-suppress (point)))
283 (not (window-minibuffer-p (selected-window)))
284 (not (pos-visible-in-window-safe pos)))
285 (progn
286 (setq paren-message-suppress (point))
287 (paren-describe-match pos mismatch))
288 (setq paren-message-suppress nil))
289
290 ;; put the right face on the extent
291 (cond (pface
292 (set-extent-face paren-extent pface)
293 (set-extent-priority paren-extent 100) ; want this to be high
294 (and (eq paren-mode 'blink-paren)
295 (setq paren-blink-on-face pface
296 paren-n-blinks 0
297 paren-timeout-id
298 (and paren-blink-interval
299 (add-timeout paren-blink-interval
300 'paren-blink-timeout
301 nil
302 paren-blink-interval))))))
303 ))))
304
305 ;; kill off the competition, er, uh, eliminate redundancy...
306 (setq post-command-hook (delq 'show-paren-command-hook post-command-hook))
307 (setq pre-command-hook (delq 'blink-paren-pre-command pre-command-hook))
308 (setq post-command-hook (delq 'blink-paren-post-command post-command-hook))
309
310 ;;;###autoload
311 (defun paren-set-mode (arg &optional quiet)
312 "Cycles through possible values for `paren-mode', force off with negative arg.
313 When called from lisp, a symbolic value for `paren-mode' can be pased directly.
314 See also `paren-mode' and `paren-highlight'."
315 (interactive "P")
316 (let* ((paren-modes '(blink-paren paren sexp))
317 (paren-next-modes (cons nil (append paren-modes (list nil)))))
318 (setq paren-mode (if (and (numberp arg) (< arg 0))
319 nil ; turn paren highlighting off
320 (cond ((and arg (symbolp arg)) arg)
321 ((and (numberp arg) (> arg 0))
322 (nth (1- arg) paren-modes))
323 ((numberp arg) nil)
324 (t (car (cdr (memq paren-mode
325 paren-next-modes)))))
326 )))
327 (cond (paren-mode
328 (add-hook 'post-command-hook 'paren-highlight)
329 (add-hook 'pre-command-hook 'paren-nuke-extent)
330 (setq blink-matching-paren nil))
331 ((not (local-variable-p 'paren-mode (current-buffer)))
332 (remove-hook 'post-command-hook 'paren-highlight)
333 (remove-hook 'pre-command-hook 'paren-nuke-extent)
334 (paren-nuke-extent) ; overkill
335 (setq blink-matching-paren t)
336 ))
337 (or quiet (message "Paren mode is %s" (or paren-mode "OFF"))))
338
339 (eval-when-compile
340 ;; suppress compiler warning.
341 (defvar highlight-paren-expression))
342
343 (paren-set-mode (if (and (boundp 'highlight-paren-expression)
344 ;; bletcherous blink-paren no-naming-convention
345 highlight-paren-expression)
346 'sexp
347 (if (eq 'x (device-type (selected-device)))
348 'blink-paren
349 'paren))
350 t)
351
352 ;;;###autoload
353 (make-obsolete 'blink-paren 'paren-set-mode)
354
355 ;;;###autoload
356 (defun blink-paren (&optional arg)
357 "Obsolete. Use `paren-set-mode' instead."
358 (interactive "P")
359 (paren-set-mode (if (and (numberp arg) (> arg 0))
360 'blink-paren -1) t))
361
362 (provide 'blink-paren)
363 (provide 'paren)
364
365 ;; Local Variables:
366 ;; byte-optimize: t
367 ;; End:
368
369 ;;; paren.el ends here