branch: elpa/highlight-parentheses
commit b9fe4eb04266abb0ed0e0184b46086f126b64b76
Author: Nikolaj Schumacher <g...@nschum.de>
Commit: Nikolaj Schumacher <g...@nschum.de>
Rewrote engine.
---
highlight-parentheses.el | 95 +++++++++++++++++++++---------------------------
1 file changed, 41 insertions(+), 54 deletions(-)
diff --git a/highlight-parentheses.el b/highlight-parentheses.el
index ea4c752..f445819 100644
--- a/highlight-parentheses.el
+++ b/highlight-parentheses.el
@@ -75,6 +75,10 @@ Color attributes might be overriden by `hl-paren-colors' and
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(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.")
@@ -83,53 +87,22 @@ This is used to prevent analyzing the same context over and
over.")
(defun hl-paren-highlight ()
"Highlight the parentheses around point."
(unless (= (point) hl-paren-last-point)
- (save-excursion
- (let ((pos (point))
- (match-pos (point))
- (level -1)
- (max (1- (length hl-paren-overlays))))
- (while (and match-pos (< level max))
- (setq match-pos
- (when (setq pos (cadr (syntax-ppss pos)))
- (ignore-errors (scan-sexps pos 1))))
- (when match-pos
- (hl-paren-put-overlay (incf level) pos 'hl-paren-face)
- (hl-paren-put-overlay (incf level) (1- match-pos) 'hl-paren-face)))
- (while (< level max)
- (hl-paren-put-overlay (incf level) nil nil))))
- (setq hl-paren-last-point (point))))
-
-(defun hl-paren-put-overlay (n pos face)
- "Move or create the N'th overlay so its shown at POS."
- (let ((ov (elt hl-paren-overlays n)) end)
- (if (null pos)
- (when ov
- (delete-overlay ov)
- (aset hl-paren-overlays n nil))
- (if (atom pos)
- (setq end (1+ pos))
- (setq end (cdr pos))
- (setq pos (car pos)))
- (if ov
- (move-overlay ov pos end)
- (let ((face-attributes (face-attr-construct face))
- (color-value (nth (/ n 2) hl-paren-colors))
- (background-value (nth (/ n 2) hl-paren-background-colors)))
- (when color-value
- (let ((attribute (memq :foreground face-attributes)))
- (if attribute
- (setcar (cdr attribute) color-value)
- (push color-value face-attributes)
- (push :foreground face-attributes))))
- (when background-value
- (let ((attribute (memq :background face-attributes)))
- (if attribute
- (setcar (cdr attribute) background-value)
- (push background-value face-attributes)
- (push :background face-attributes))))
- (setq ov (make-overlay pos end))
- (aset hl-paren-overlays n ov)
- (overlay-put ov 'face face-attributes))))))
+ (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
@@ -137,18 +110,32 @@ This is used to prevent analyzing the same context over
and over.")
nil " hl-p" nil
(if highlight-parentheses-mode
(progn
- (setq hl-paren-overlays
- (make-vector (* 2 (max (length hl-paren-colors)
- (length hl-paren-background-colors)))
nil))
+ (hl-paren-create-overlays)
(add-hook 'post-command-hook 'hl-paren-highlight nil t))
- (let (ov)
- (dotimes (i (length hl-paren-overlays))
- (when (setq ov (elt hl-paren-overlays i))
- (delete-overlay ov))))
+ (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))))
+
(provide 'highlight-parentheses)
;;; highlight-parentheses.el ends here
