Add Highlight parentheses mode to Clojure bundle

bundles/clojure/highlight-parentheses.el

@@ -0,0 +1,157 @@
+;;; highlight-parentheses.el --- highlight surrounding parentheses
+;;
+;; Copyright (C) 2007, 2009 Nikolaj Schumacher
+;;
+;; Author: Nikolaj Schumacher <bugs * nschum de>
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;;; 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