diff --git a/bundles/clojure/highlight-parentheses.el b/bundles/clojure/highlight-parentheses.el new file mode 100644 index 0000000..8df50ab --- /dev/null +++ b/bundles/clojure/highlight-parentheses.el @@ -0,0 +1,157 @@ +;;; highlight-parentheses.el --- highlight surrounding parentheses +;; +;; Copyright (C) 2007, 2009 Nikolaj Schumacher +;; +;; Author: Nikolaj Schumacher +;; Version: 1.0.1 +;; Keywords: faces, matching +;; URL: http://nschum.de/src/emacs/highlight-parentheses/ +;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x +;; +;; This file is NOT part of GNU Emacs. +;; +;; 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, see . +;; +;;; Commentary: +;; +;; Add the following to your .emacs file: +;; (require 'highlight-parentheses) +;; +;; Enable `highlight-parentheses-mode'. +;; +;;; Change Log: +;; +;; 2009-03-19 (1.0.1) +;; Added setter for color variables. +;; +;; 2007-07-30 (1.0) +;; Added background highlighting and faces. +;; +;; 2007-05-15 (0.9.1) +;; Support for defcustom. +;; +;; 2007-04-26 (0.9) +;; Initial Release. +;; +;;; Code: + +(eval-when-compile (require 'cl)) + +(defgroup highlight-parentheses nil + "Highlight surrounding parentheses" + :group 'faces + :group 'matching) + +(defun hl-paren-set (variable value) + (set variable value) + (when (fboundp 'hl-paren-color-update) + (hl-paren-color-update))) + +(defcustom hl-paren-colors + '("firebrick1" "IndianRed1" "IndianRed3" "IndianRed4") + "*List of colors for the highlighted parentheses. +The list starts with the the inside parentheses and moves outwards." + :type '(repeat color) + :set 'hl-paren-set + :group 'highlight-parentheses) + +(defcustom hl-paren-background-colors nil + "*List of colors for the background highlighted parentheses. +The list starts with the the inside parentheses and moves outwards." + :type '(repeat color) + :set 'hl-paren-set + :group 'highlight-parentheses) + +(defface hl-paren-face nil + "*Face used for highlighting parentheses. +Color attributes might be overriden by `hl-paren-colors' and +`hl-paren-background-colors'." + :group 'highlight-parentheses) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar hl-paren-overlays nil + "This buffers currently active overlays.") +(make-variable-buffer-local 'hl-paren-overlays) + +(defvar hl-paren-last-point 0 + "The last point for which parentheses were highlighted. +This is used to prevent analyzing the same context over and over.") +(make-variable-buffer-local 'hl-paren-last-point) + +(defun hl-paren-highlight () + "Highlight the parentheses around point." + (unless (= (point) hl-paren-last-point) + (setq hl-paren-last-point (point)) + (let ((overlays hl-paren-overlays) + pos1 pos2 + (pos (point))) + (save-excursion + (condition-case err + (while (and (setq pos1 (cadr (syntax-ppss pos1))) + (cddr overlays)) + (move-overlay (pop overlays) pos1 (1+ pos1)) + (when (setq pos2 (scan-sexps pos1 1)) + (move-overlay (pop overlays) (1- pos2) pos2) + )) + (error nil)) + (goto-char pos)) + (dolist (ov overlays) + (move-overlay ov 1 1))))) + +;;;###autoload +(define-minor-mode highlight-parentheses-mode + "Minor mode to highlight the surrounding parentheses." + nil " hl-p" nil + (if highlight-parentheses-mode + (progn + (hl-paren-create-overlays) + (add-hook 'post-command-hook 'hl-paren-highlight nil t)) + (mapc 'delete-overlay hl-paren-overlays) + (kill-local-variable 'hl-paren-overlays) + (kill-local-variable 'hl-paren-point) + (remove-hook 'post-command-hook 'hl-paren-highlight t))) + +;;; overlays ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hl-paren-create-overlays () + (let ((fg hl-paren-colors) + (bg hl-paren-background-colors) + attributes) + (while (or fg bg) + (setq attributes (face-attr-construct 'hl-paren-face)) + (when (car fg) + (setq attributes (plist-put attributes :foreground (car fg)))) + (pop fg) + (when (car bg) + (setq attributes (plist-put attributes :background (car bg)))) + (pop bg) + (dotimes (i 2) ;; front and back + (push (make-overlay 0 0) hl-paren-overlays) + (overlay-put (car hl-paren-overlays) 'face attributes))) + (setq hl-paren-overlays (nreverse hl-paren-overlays)))) + +(defun hl-paren-color-update () + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when hl-paren-overlays + (mapc 'delete-overlay hl-paren-overlays) + (setq hl-paren-overlays nil) + (hl-paren-create-overlays) + (let ((hl-paren-last-point -1)) ;; force update + (hl-paren-highlight)))))) + +(provide 'highlight-parentheses) + +;;; highlight-parentheses.el ends here