;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;****************************************************************************
;;;;FILE: pjb-blink.el
;;;;LANGUAGE: emacs lisp
;;;;SYSTEM: POSIX
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Alternate blinking parens.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2005-09-20 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; GPL
;;;;
;;;; Copyright Pascal Bourguignon 2005 - 2011
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;****************************************************************************
(defun blink (start end)
(set-mark start)
(goto-char (1+ end)))
(defun unblink (start end)
"Nothing to do")
;; Another implementation of blink and unblink could set the face,
;; or put some overlay on the region or on the start and end characters.
(defun blink-matching-open-and-close ()
"Move cursor momentarily to the beginning of the sexp before point."
(interactive)
(let ((close-point (1- (point))))
(and (> (point) (1+ (point-min)))
blink-matching-paren
;; Verify an even number of quoting characters precede the close.
(= 1 (logand 1 (- (point)
(save-excursion
(forward-char -1)
(skip-syntax-backward "/\\")
(point)))))
(let* ((oldpos (point))
(blinkpos)
(mismatch)
matching-paren)
(save-excursion
(save-restriction
(if blink-matching-paren-distance
(narrow-to-region (max (point-min)
(- (point) blink-matching-paren-distance))
oldpos))
(condition-case ()
(let ((parse-sexp-ignore-comments
(and parse-sexp-ignore-comments
(not blink-matching-paren-dont-ignore-comments))))
(setq blinkpos (scan-sexps oldpos -1)))
(error nil)))
(and blinkpos
;; Not syntax '$'.
(not (eq (syntax-class (syntax-after blinkpos)) 8))
(setq matching-paren
(let ((syntax (syntax-after blinkpos)))
(and (consp syntax)
(eq (syntax-class syntax) 4)
(cdr syntax)))
mismatch
(or (null matching-paren)
(/= (char-after (1- oldpos))
matching-paren))))
(if mismatch (setq blinkpos nil))
(if blinkpos
;; Don't log messages about paren matching.
(let (message-log-max)
(blink blinkpos close-point)
(if (pos-visible-in-window-p)
(and blink-matching-paren-on-screen
(sit-for blink-matching-delay))
(goto-char blinkpos)
(message
"Matches %s"
;; Show what precedes the open in its line, if anything.
(if (save-excursion
(skip-chars-backward " \t")
(not (bolp)))
(buffer-substring (progn (beginning-of-line) (point))
(1+ blinkpos))
;; Show what follows the open in its line, if anything.
(if (save-excursion
(forward-char 1)
(skip-chars-forward " \t")
(not (eolp)))
(buffer-substring blinkpos
(progn (end-of-line) (point)))
;; Otherwise show the previous nonblank line,
;; if there is one.
(if (save-excursion
(skip-chars-backward "\n \t")
(not (bobp)))
(concat
(buffer-substring (progn
(skip-chars-backward "\n \t")
(beginning-of-line)
(point))
(progn (end-of-line)
(skip-chars-backward " \t")
(point)))
;; Replace the newline and other whitespace with `...'.
"..."
(buffer-substring blinkpos (1+ blinkpos)))
;; There is nothing to show except the char itself.
(buffer-substring blinkpos (1+ blinkpos)))))))
(unblink blinkpos close-point))
(cond (mismatch
(message "Mismatched parentheses"))
((not blink-matching-paren-distance)
(message "Unmatched parenthesis")))))))))
(setf blink-paren-function (function blink-matching-open-and-close))