Source

edit-utils / paren.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
;;; paren.el --- highlight (un)matching parens and whole expressions

;; Copyright (C) 1993 Free Software Foundation, Inc.
;; Copyright (C) 1993, 1994, 1995 Tinker Systems
;;
;; Author: Jonathan Stigelman <Stig@hackvan.com>
;; Note:   (some code scammed from simple.el and blink-paren.el)
;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
;; Keywords: languages, faces

;;; This file is part of XEmacs.
;;; 
;;; XEmacs is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;; 
;;; XEmacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with XEmacs; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Synched up with: Not synched with FSF.
;;; Way different from FSF.

;;; Commentary:

;; Purpose of this package:
;;
;;   This package highlights matching parens (or whole sexps) for easier
;;   editing of source code, particularly lisp source code.
;; 
;; The `paren-highlight' hook function runs after each command and
;; checks to see if the cursor is at a parenthesis.  If so, then it
;; highlights, in one of several ways, the matching parenthesis.
;; 
;; Priority is given to matching parentheses right before the cursor because
;; that's what makes sense when you're typing a lot of closed parentheses.
;; 
;; This is especially intuitive if you frequently use forward-sexp (M-C-f)
;; and backward-sexp (M-C-b) to maneuver around in source code.
;; 
;; Different faces are used for matching and mismatching parens so that it
;; is easier to see mistakes as you type them.  Audible feedback is optional.
;; 
;; If a (mis)matching paren is offscreen, then a message is sent to the modeline.
;; 
;; If paren-mode is `sexp', entire S-expressions are highlighted instead of
;; just matching parens.

;;; Code:

(defgroup paren-matching nil
  "Highlight (un)matching of parens and expressions."
  :prefix "paren-"
  :group 'matching)


;;;###autoload
(defcustom paren-mode nil
  "*Sets the style of parenthesis highlighting.
Valid values are nil, `blink-paren', `paren', and `sexp'.
  nil		no parenthesis highlighting.
  blink-paren	causes the matching paren to blink.
  paren		causes the matching paren to be highlighted but not to blink.
  sexp		whole expression enclosed by the local paren at its mate.
  sexp-surround whole surrounding expression, even if point is not at paren.
  nested	(not yet implemented) use variable shading to see the
		nesting of an expression.  Also groks regular expressions
		and shell quoting.

This variable is global by default, but you can make it buffer-local and
highlight parentheses differently in different major modes."
  :type '(radio (const :tag "None (default)" nil)
		(const :tag "Blinking Paren" blink-paren)
		(const :tag "Highlighted Paren" paren)
		(const :tag "Highlighted Expression" sexp)
		(const :tag "Highlighted Surrounding Expression" sexp-surround))
  :set (lambda (symbol value)
	 (paren-set-mode value))
  :initialize 'custom-initialize-default
  :require 'paren
  :group 'paren-matching)

(defcustom paren-message-offscreen t
  "*Non-nil means display a message if matching open paren is offscreen."
  :type 'boolean
  :group 'paren-matching)

(defcustom paren-ding-unmatched nil
  "*Make noise if the cursor is at an unmatched paren.

If t, then typing or passing over an unmatched paren will ring the bell
using the `paren' sound.  If nil, then the bell will not ring even if an
unmatched paren is typed.  If neither t nor nil, then the bell will not ring
when the cursor moves over unmatched parens but will ring if one is typed."
  :type '(choice (const :tag "off" nil)
		 (const :tag "on" t)
		 (const :tag "other" other))
  :group 'paren-matching)

(defcustom paren-backwards-message nil
  "*Control what context is reported when a matching paren is offscreen.

If nil, the matching paren and the following context is reported;
if non-nil, the matching paren and the previous context.

This variable should normally be set in a language major mode hook as
appropriate for the syntax of a program in that language."
  :type 'boolean
  :group 'paren-matching)
(make-variable-buffer-local 'paren-backwards-message)


(make-face 'paren-match)
(or (face-differs-from-default-p 'paren-match)
    (copy-face 'highlight 'paren-match))

(make-face 'paren-mismatch)
(cond ((face-differs-from-default-p 'paren-mismatch) nil)
      (t (let ((color-tag (list 'x 'color))
	       (mono-tag (list 'x 'mono))
	       (gray-tag (list 'x 'grayscale)))
	   (set-face-background 'paren-mismatch "DeepPink" 'global color-tag)
	   (set-face-reverse-p 'paren-mismatch t 'global 'tty)
	   (set-face-background 'paren-mismatch [modeline background] 'global
				mono-tag)
	   (set-face-foreground 'paren-mismatch [modeline foreground] 'global
				mono-tag)
	   (set-face-background 'paren-mismatch [modeline background] 'global
				gray-tag)
	   (set-face-foreground 'paren-mismatch [modeline foreground] 'global
				gray-tag))))

(make-face 'paren-blink-off)
(or (face-differs-from-default-p 'paren-blink-off)
    (set-face-foreground 'paren-blink-off (face-background 'default)))

;; this is either paren-match or paren-mismatch...
(defvar paren-blink-on-face nil)

(defcustom paren-blink-interval 0.2
  "*If the cursor is on a parenthesis, the matching parenthesis will blink.
This variable controls how long each phase of the blink lasts in seconds.
This should be a fractional part of a second (a float.)"
  :type 'number
  :group 'paren-matching)

(defcustom paren-max-blinks (* 5 60 5)	; 5 minutes is plenty...
  ;; idea from Eric Eide <eeide@jaguar.cs.utah.edu>
  "*Maximum number of times that a matching parenthesis will blink.
Set this to NIL if you want indefinite blinking."
  :type '(choice (const nil) number)
  :group 'paren-matching)

;; timeout to blink the face
(defvar paren-timeout-id nil)

;; Code:

(defvar paren-n-blinks)
(defvar paren-extent nil)

(defsubst pos-visible-in-window-safe (pos)
  "safe version of pos-visible-in-window-p"
  (condition-case nil
      ;; #### - is this needed in XEmacs???
      (pos-visible-in-window-p pos)
      (args-out-of-range nil)))

;; called before a new command is executed in the pre-command-hook
;; cleanup by removing the extent and the time-out
(defun paren-nuke-extent ()
  (condition-case c  ; don't ever signal an error in pre-command-hook!
      (let ((inhibit-quit t))
	(if paren-timeout-id
	    (disable-timeout (prog1 paren-timeout-id
			       (setq paren-timeout-id nil))))
	(if paren-extent
	    (delete-extent (prog1 paren-extent
			     (setq paren-extent nil)))))
    (error
     (message "paren-nuke-extent error! %s" c))))

;; callback for the timeout
;; swap the face of the extent on the matching paren
(defun paren-blink-timeout (arg)
  ;; The extent could have been deleted for some reason and not point to a
  ;; buffer anymore.  So catch any error to remove the timeout.
  (condition-case ()
      (if (and paren-max-blinks
	       (> (setq paren-n-blinks (1+ paren-n-blinks)) paren-max-blinks))
	  (paren-nuke-extent)
	(set-extent-face paren-extent 
			 (if (eq (extent-face paren-extent)
				 paren-blink-on-face)
			     'paren-blink-off
			   paren-blink-on-face)))
    (error (paren-nuke-extent))))

;; Show a match where the parenthesis is not on screen.
;;
;; In the forwards case (like lisp):
;;   Display from the matching paren through to the end of the line.  If only
;;   whitespace after the paren, then append the next line.
;;
;; Backwards case (like C):
;;   Display from the matching paren back to the start of its line.  If only
;;   whitespace before the paren, then prepend the previous line.

(defun paren-describe-match (pos mismatch)  
  (or (window-minibuffer-p (selected-window))
      (save-excursion
	(goto-char pos)
	(message "%s: %s"
		 (if mismatch "MISMATCH" "Matches")
                 (replace-in-string
                  (buffer-substring
                   (save-excursion
                     (if paren-backwards-message
                         (progn
                           (skip-syntax-backward " ")
                           (beginning-of-line (if (bolp) 0 1))
                           (skip-syntax-forward " "))
                       (forward-char 1)
                       (skip-syntax-forward " ")
                       (end-of-line (if (eolp) 2 1)))
                     (point)) 
                   (if paren-backwards-message (1+ (point)) (point)))
                  "[\n\t ]+" " " t)))))

(defun paren-maybe-ding ()
  (and (or (eq paren-ding-unmatched t)
	   (and paren-ding-unmatched
		(eq this-command 'self-insert-command)))
       (progn
	 (message "Unmatched parenthesis.")
	 (ding nil 'paren))))

;; Find the place to show, if there is one,
;; and show it until input arrives.
(defun paren-highlight ()
  "This highlights matching parentheses.

See the variables:
  paren-message-offscreen   use modeline when matching paren is offscreen?
  paren-ding-unmatched	    make noise when passing over mismatched parens?
  paren-mode		    'blink-paren, 'paren, 'sexp or 'sexp-surround
  blink-matching-paren-distance  maximum distance to search for parens.

and the following faces:
  paren-match, paren-mismatch, paren-blink-off"

  ;; I suppose I could check here to see if a keyboard macro is executing,
  ;; but I did a quick empirical check and couldn't tell that there was any
  ;; difference in performance

  (let ((oldpos (point))
	(pface nil)			; face for paren...nil kills the overlay
	(dir (and paren-mode
		  (not (input-pending-p))
		  (not executing-kbd-macro)
		  (cond ((eq (char-syntax (preceding-char)) ?\))
			 -1)
			((eq (char-syntax (following-char)) ?\()
			 1))))
	pos mismatch)

    (save-excursion
      (if (or (not dir)
	      (not (save-restriction
		     ;; Determine the range within which to look for a match.
		     (if blink-matching-paren-distance
			 (narrow-to-region
			  (max (point-min)
			       (- (point) blink-matching-paren-distance))
			  (min (point-max)
			       (+ (point) blink-matching-paren-distance))))

		     ;; Scan across one sexp within that range.
		     (condition-case nil
			 (setq pos (scan-sexps (point) dir))
		       ;; NOTE - if blink-matching-paren-distance is set,
		       ;; then we can have spurious unmatched parens.
		       (error (paren-maybe-ding)
			      nil)))))

	  ;; No paren at point, so possible highlight sexp around
	  (when (eq paren-mode 'sexp-surround)
	    (let ((pnt (save-excursion
			 (condition-case nil
			     (cons (progn (up-list -1) (point))
				   (or (scan-lists (point) 1 0)
				       (buffer-end 1)))
			   (error nil)))))
	      (when (and pnt (> (cdr pnt) (car pnt)))
		(setq paren-extent (make-extent (car pnt) (cdr pnt)))
		(set-extent-face paren-extent 'paren-match) 
		(set-extent-priority paren-extent 100))))
	    
	;; See if the "matching" paren is the right kind of paren
	;; to match the one we started at.
	(let ((beg (min pos oldpos)) (end (max pos oldpos)))
	  (setq mismatch
		(and (/= (char-syntax (char-after beg)) ?\\)
		     (/= (char-syntax (char-after beg)) ?\$)
		     ;; XEmacs change
		     (matching-paren (char-after beg))
		     (/= (char-after (1- end))
			 (matching-paren (char-after beg)))))
	  (if (or (eq paren-mode 'sexp) (eq paren-mode 'sexp-surround))
	      (setq paren-extent (make-extent beg end))))
	(and mismatch
	     (paren-maybe-ding))
 	(setq pface (if mismatch
			'paren-mismatch
		      'paren-match))
	(and (memq paren-mode '(blink-paren paren))
	     (setq paren-extent (make-extent (- pos dir) pos)))

	(if (and paren-message-offscreen
		 (eq dir -1)
                 (not (current-message))
		 (not (window-minibuffer-p (selected-window)))
		 (not (pos-visible-in-window-safe pos)))
            (paren-describe-match pos mismatch))
		 
	;; put the right face on the extent
	(cond (pface
	       (set-extent-face paren-extent pface) 
	       (set-extent-priority paren-extent 100) ; want this to be high
	       (and (eq paren-mode 'blink-paren)
		    (setq paren-blink-on-face pface
			  paren-n-blinks 0
			  paren-timeout-id
			  (and paren-blink-interval
			       (add-timeout paren-blink-interval
					    'paren-blink-timeout
					    nil
					    paren-blink-interval))))))
	))))


;;;###autoload
(defun paren-set-mode (arg &optional quiet)
  "Cycles through possible values for `paren-mode', force off with negative arg.
When called from lisp, a symbolic value for `paren-mode' can be passed directly.
See also `paren-mode' and `paren-highlight'."
  (interactive "P")
  ;; kill off the competition, er, uh, eliminate redundancy...
  (setq post-command-hook (delq 'show-paren-command-hook post-command-hook))
  (setq pre-command-hook (delq 'blink-paren-pre-command pre-command-hook))
  (setq post-command-hook (delq 'blink-paren-post-command post-command-hook))

  (let* ((paren-modes '(blink-paren paren sexp sexp-surround))
	 (paren-next-modes (cons nil (append paren-modes (list nil)))))
    (setq paren-mode (if (and (numberp arg) (< arg 0))
			 nil		; turn paren highlighting off
		       (cond ((and arg (symbolp arg)) arg)
			     ((and (numberp arg) (> arg 0))
			      (nth (1- arg) paren-modes))
			     ((numberp arg) nil)
			     (t (car (cdr (memq paren-mode
						paren-next-modes)))))
		       )))
  (cond (paren-mode
	 (add-hook 'post-command-hook 'paren-highlight)
	 (add-hook 'pre-command-hook 'paren-nuke-extent)
	 (setq blink-matching-paren nil))
	((not (local-variable-p 'paren-mode (current-buffer)))
	 (remove-hook 'post-command-hook 'paren-highlight)
	 (remove-hook 'pre-command-hook 'paren-nuke-extent)
	 (paren-nuke-extent)		; overkill
	 (setq blink-matching-paren t)
	 ))
  (or quiet (message "Paren mode is %s" (or paren-mode "OFF"))))

(eval-when-compile
  ;; suppress compiler warning.
  (defvar highlight-paren-expression))

;; No no no!
;(paren-set-mode (if (and (boundp 'highlight-paren-expression)
;			    ;; bletcherous blink-paren no-naming-convention
;			    highlight-paren-expression)
;		       'sexp
;		     (if (eq 'x (device-type (selected-device)))
;			 'blink-paren
;		       'paren))
;		t)

;;;###autoload
(make-obsolete 'blink-paren 'paren-set-mode)

;;;###autoload
(defun blink-paren (&optional arg)
  "Obsolete.  Use `paren-set-mode' instead."
  (interactive "P") 
  (paren-set-mode (if (and (numberp arg) (> arg 0))
		      'blink-paren -1) t))

(provide 'blink-paren)
(provide 'paren)

;; Local Variables:
;; byte-optimize: t
;; End:

;;; paren.el ends here