emacs/.emacs.d/site-lisp/highlight-parentheses.el

   1 ;;; highlight-parentheses.el --- highlight surrounding parentheses
   2 ;;
   3 ;; Copyright (C) 2007, 2009 Nikolaj Schumacher
   4 ;;
   5 ;; Author: Nikolaj Schumacher <bugs * nschum de>
   6 ;; Version: 1.0.1
   7 ;; Keywords: faces, matching
   8 ;; URL: http://nschum.de/src/emacs/highlight-parentheses/
   9 ;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x
  10 ;;
  11 ;; This file is NOT part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License
  15 ;; as published by the Free Software Foundation; either version 2
  16 ;; of the License, or (at your option) any later version.
  17 ;;
  18 ;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  25 ;;
  26 ;;; Commentary:
  27 ;;
  28 ;; Add the following to your .emacs file:
  29 ;; (require 'highlight-parentheses)
  30 ;;
  31 ;; Enable `highlight-parentheses-mode'.
  32 ;;
  33 ;;; Change Log:
  34 ;;
  35 ;; 2009-03-19 (1.0.1)
  36 ;;    Added setter for color variables.
  37 ;;
  38 ;; 2007-07-30 (1.0)
  39 ;;    Added background highlighting and faces.
  40 ;;
  41 ;; 2007-05-15 (0.9.1)
  42 ;;    Support for defcustom.
  43 ;;
  44 ;; 2007-04-26 (0.9)
  45 ;;    Initial Release.
  46 ;;
  47 ;;; Code:
  48
  49 (eval-when-compile (require 'cl))
  50
  51 (defgroup highlight-parentheses nil
  52   "Highlight surrounding parentheses"
  53   :group 'faces
  54   :group 'matching)
  55
  56 (defun hl-paren-set (variable value)
  57   (set variable value)
  58   (when (fboundp 'hl-paren-color-update)
  59     (hl-paren-color-update)))
  60
  61 (defcustom hl-paren-colors
  62   '("firebrick1" "IndianRed1" "IndianRed3" "IndianRed4")
  63   "*List of colors for the highlighted parentheses.
  64 The list starts with the the inside parentheses and moves outwards."
  65   :type '(repeat color)
  66   :set 'hl-paren-set
  67   :group 'highlight-parentheses)
  68
  69 (defcustom hl-paren-background-colors nil
  70   "*List of colors for the background highlighted parentheses.
  71 The list starts with the the inside parentheses and moves outwards."
  72   :type '(repeat color)
  73   :set 'hl-paren-set
  74   :group 'highlight-parentheses)
  75
  76 (defface hl-paren-face nil
  77   "*Face used for highlighting parentheses.
  78 Color attributes might be overriden by `hl-paren-colors' and
  79 `hl-paren-background-colors'."
  80   :group 'highlight-parentheses)
  81
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83
  84 (defvar hl-paren-overlays nil
  85   "This buffers currently active overlays.")
  86 (make-variable-buffer-local 'hl-paren-overlays)
  87
  88 (defvar hl-paren-last-point 0
  89   "The last point for which parentheses were highlighted.
  90 This is used to prevent analyzing the same context over and over.")
  91 (make-variable-buffer-local 'hl-paren-last-point)
  92
  93 (defun hl-paren-highlight ()
  94   "Highlight the parentheses around point."
  95   (unless (= (point) hl-paren-last-point)
  96     (setq hl-paren-last-point (point))
  97     (let ((overlays hl-paren-overlays)
  98           pos1 pos2
  99           (pos (point)))
 100       (save-excursion
 101         (condition-case err
 102             (while (and (setq pos1 (cadr (syntax-ppss pos1)))
 103                         (cddr overlays))
 104               (move-overlay (pop overlays) pos1 (1+ pos1))
 105               (when (setq pos2 (scan-sexps pos1 1))
 106                 (move-overlay (pop overlays) (1- pos2) pos2)
 107                 ))
 108           (error nil))
 109         (goto-char pos))
 110       (dolist (ov overlays)
 111         (move-overlay ov 1 1)))))
 112
 113 ;;;###autoload
 114 (define-minor-mode highlight-parentheses-mode
 115   "Minor mode to highlight the surrounding parentheses."
 116   nil " hl-p" nil
 117   (if highlight-parentheses-mode
 118       (progn
 119         (hl-paren-create-overlays)
 120         (add-hook 'post-command-hook 'hl-paren-highlight nil t))
 121     (mapc 'delete-overlay hl-paren-overlays)
 122     (kill-local-variable 'hl-paren-overlays)
 123     (kill-local-variable 'hl-paren-point)
 124     (remove-hook 'post-command-hook 'hl-paren-highlight t)))
 125
 126 ;;; overlays ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 127
 128 (defun hl-paren-create-overlays ()
 129   (let ((fg hl-paren-colors)
 130         (bg hl-paren-background-colors)
 131         attributes)
 132     (while (or fg bg)
 133       (setq attributes (face-attr-construct 'hl-paren-face))
 134       (when (car fg)
 135         (setq attributes (plist-put attributes :foreground (car fg))))
 136       (pop fg)
 137       (when (car bg)
 138         (setq attributes (plist-put attributes :background (car bg))))
 139       (pop bg)
 140       (dotimes (i 2) ;; front and back
 141         (push (make-overlay 0 0) hl-paren-overlays)
 142         (overlay-put (car hl-paren-overlays) 'face attributes)))
 143     (setq hl-paren-overlays (nreverse hl-paren-overlays))))
 144
 145 (defun hl-paren-color-update ()
 146   (dolist (buffer (buffer-list))
 147     (with-current-buffer buffer
 148       (when hl-paren-overlays
 149         (mapc 'delete-overlay hl-paren-overlays)
 150         (setq hl-paren-overlays nil)
 151         (hl-paren-create-overlays)
 152         (let ((hl-paren-last-point -1)) ;; force update
 153           (hl-paren-highlight))))))
 154
 155 (provide 'highlight-parentheses)
 156
 157 ;;; highlight-parentheses.el ends here