1 files changed, 275 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/rudel-overlay.el b/emacs.d/lisp/rudel/rudel-overlay.el
new file mode 100644
index 0000000..093afdf
--- /dev/null
+++ b/emacs.d/lisp/rudel/rudel-overlay.el
@@ -0,0 +1,275 @@
+;;; rudel-overlay.el --- Overlay functions for Rudel
+;;
+;; Copyright (C) 2008, 2009 Jan Moringen
+;;
+;; Author: Jan Moringen <scymtym@users.sourceforge.net>
+;; Keywords: rudel, overlay
+;; X-RCS: $Id:$
+;;
+;; This file is part of Rudel.
+;;
+;; Rudel 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 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Rudel 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 Rudel. If not, see <http://www.gnu.org/licenses>.
+
+
+;;; Commentary:
+;;
+
+
+;;; History:
+;;
+;; 0.1 - Initial revision.
+
+
+;;; Code:
+;;
+
+(require 'custom)
+
+(eval-when-compile
+  (require 'cl))
+
+
+;;; Rudel overlay faces
+;;
+
+(defcustom rudel-overlay-author-display t
+  "Indicate authorship by setting text color to user color."
+  :group   'rudel
+  :type    'boolean
+  :set     (lambda (symbol value)
+	     (set-default symbol value)
+	     (when (featurep 'rudel-overlay)
+	       (rudel-overlay-options-changed))))
+
+(put 'rudel-overlay-author-display 'safe-local-variable t)
+
+(defface rudel-author-overlay-face
+  '((default (:background "black")))
+  "*Face used to highlight contributions according to their authors.
+Attributes involving color are not applied literally. Instead the
+color is replaced with the color associated with the respective
+author."
+  :group 'rudel)
+
+
+;;; General overlay functions
+;;
+
+(defun rudel-overlay-p (overlay)
+  "Non-nil if OVERLAY is a Rudel overlay."
+  (overlay-get overlay :rudel))
+
+(defun rudel-overlay-length (overlay)
+  "Distance between end and start of OVERLAY."
+  (- (overlay-end overlay) (overlay-start overlay)))
+
+(defun rudel-overlay-user (overlay)
+  "User object associated to OVERLAY."
+  (overlay-get overlay :user))
+
+(defun rudel-overlays (&optional predicate)
+  "Return a list of Rudel-related overlays or overlays satisfying PREDICATE.
+If PREDICATE is non-nil returned overlays satisfy PREDICATES;
+Otherwise all Rudel-related overlays are returned."
+  (unless predicate
+    (setq predicate #'rudel-overlay-p))
+
+  (let* ((overlay-lists (overlay-lists))
+	 (overlays      (append (car overlay-lists)
+				(cdr overlay-lists))))
+    (remove-if-not predicate overlays))
+  )
+
+(defun rudel-overlays-at (position &optional predicate)
+  "Return a list of Rudel-related overlays at POSITION.
+If PREDICATE is non-nil returned overlays satisfy PREDICATES;
+Otherwise all Rudel-related overlays are returned."
+  (unless predicate
+    (setq predicate #'rudel-overlay-p))
+  (remove-if-not predicate (overlays-at position)))
+
+(defun rudel-overlays-in (start end &optional predicate)
+  "Return a list of Rudel-related overlays in the range START to END.
+If PREDICATE is non-nil returned overlays satisfy PREDICATES;
+Otherwise all Rudel-related overlays are returned."
+  (unless predicate
+    (setq predicate #'rudel-overlay-p))
+  (remove-if-not predicate (overlays-in start end)))
+
+(defun rudel-overlays-remove-all ()
+  "Remove all Rudel overlays from the current buffer."
+  (mapc #'delete-overlay (rudel-overlays)))
+
+
+;;; Author overlay
+;;
+
+(defun rudel-author-overlay-p (overlay)
+  "Predicate for author overlays."
+  (eq (overlay-get overlay :rudel) 'author))
+
+(defun rudel-author-overlays ()
+  "Return the list of author overlays in the current buffer."
+  (rudel-overlays #'rudel-author-overlay-p))
+
+(defun rudel-author-overlay-at (position &optional author)
+  ""
+  (let ((overlays (rudel-overlays-at
+		   position #'rudel-author-overlay-p)))
+    ;; There can only be one rudel overlay at any given position
+    (when overlays
+      (when (or (not author)
+		(eq (rudel-overlay-user (car overlays)) author))
+	(car overlays))))
+  )
+
+(defun rudel-author-overlays-in (start end &optional author)
+  ""
+  (rudel-overlays-in
+   start end
+   (lambda (overlay)
+     (and (rudel-overlay-p overlay)
+	  (or (not author)
+	      (eq (rudel-overlay-user overlay) author)))))
+  )
+
+(defun rudel-make-author-overlay (buffer from to author)
+  "Make and return an overlay for the range FROM to TO in BUFFER suitable for contributions by AUTHOR.
+AUTHOR has to be an object of type rudel-user-child."
+  (let ((overlay (make-overlay from to buffer t)))
+    (rudel-overlay-author-set-properties overlay author)
+    overlay))
+
+(defun rudel-overlay-author-set-properties (overlay author)
+  "Set properties of OVERLAY according to slots of AUTHOR.
+AUTHOR has to be an object of type rudel-user-child."
+  (with-slots ((name :object-name) color) author
+    (overlay-put overlay :rudel     'author)
+    (overlay-put overlay :user      author)
+    (overlay-put overlay 'face      (when rudel-overlay-author-display
+				      (rudel-overlay-make-face
+				       (rudel-overlay-make-face-symbol
+					'author name)
+				       'rudel-author-overlay-face
+				       color)))
+    (overlay-put overlay 'help-echo (when rudel-overlay-author-display
+				      (format "Written by %s" name))))
+  )
+
+(defun rudel-overlay-author-update (overlay)
+  "Update properties of OVERLAY from its attached user object."
+  (let ((author (rudel-overlay-user overlay)))
+    (rudel-overlay-author-set-properties overlay author)))
+
+
+;;; Update functions for author overlays
+;;
+
+(defun rudel-update-author-overlay-after-insert (buffer position length author)
+  "Update author overlays in BUFFER to incorporate an insertion of length LENGTH at POSITION by AUTHOR.
+POSITION refers to an Emacs buffer position.
+AUTHOR has to be an object of type rudel-author-child."
+  (when author
+    (with-current-buffer buffer
+      (let* ((end    (+ position length))
+	     (before (when (> position 1)
+		       (rudel-author-overlay-at (- position 1) author)))
+	     (at     (rudel-author-overlay-at position))
+	     (after  (when (< end (point-max))
+		       (rudel-author-overlay-at (+ end 1) author))))
+	(cond
+	 ;; If there is an overlay, we have to split it unless the
+	 ;; author is AUTHOR or we are on its boundary.
+	 (at
+	  (unless (eq (rudel-overlay-user at) author)
+	    (let* ((on-start (= (overlay-start at) position))
+		   (on-end   (= (- (overlay-end at) 1) position))
+		   (before (unless on-start
+			     (if on-end at (copy-overlay at))))
+		   (after  (unless on-end at)))
+	      (when before
+		(move-overlay before (overlay-start before) position))
+	      (when after
+		(move-overlay after end (overlay-end after)))
+	      (rudel-make-author-overlay buffer position end author))))
+	 ;; There is no overlay under the insert, but there are
+	 ;; overlays of the same author immediately before and after
+	 ;; the insert. We merge these two into one large overlay
+	 ;; including the insert.
+	 ((and before after)
+	  (let ((end (overlay-end after)))
+	    (delete-overlay after)
+	    (move-overlay before (overlay-start before) end)))
+	 ;; If there is an overlay of the same author before the
+	 ;; insert, we extend it.
+	 (before
+	  (move-overlay before (overlay-start before) end))
+	 ;; If there is an overlay of the same author after the
+	 ;; insert, we extend it.
+	 (after
+	  (move-overlay after position (overlay-end after)))
+	 ;; If there are no overlays at all, we create a suitable one.
+	 (t
+	  (rudel-make-author-overlay buffer position end author))))))
+  )
+
+(defun rudel-update-author-overlay-after-delete (buffer position length author)
+  "Update author overlays in BUFFER to incorporate a deletion of length LENGTH at POSITION by AUTHOR.
+POSITION refers to an Emacs buffer position.
+AUTHOR has to be an object of type rudel-author-child."
+  (with-current-buffer buffer
+    (mapc
+     (lambda (overlay)
+       (when (zerop (rudel-overlay-length overlay))
+	 (delete-overlay overlay)))
+     (rudel-author-overlays-in position position)))
+  )
+
+
+;;; Miscellaneous functions
+;;
+
+(defun rudel-overlay-make-face-symbol (category name)
+  "Allocate a symbol for a face for CATEGORY and NAME."
+  (intern (format "rudel-%s-overlay-%s-face"
+		  (if (stringp category)
+		      category
+		    (symbol-name category))
+		  name)))
+
+(defun rudel-overlay-make-face (face template color)
+  "Copy TEMPLATE to FACE and replace color attributes with COLOR.
+TEMPLATE has to be a face. FACE can be nil or a face. In the
+latter case, FACE is returned unmodified."
+  (unless (facep face)
+    (make-face face)
+    (copy-face template face)
+    (rudel-overlay-set-face-attributes face color))
+  face)
+
+(defun rudel-overlay-set-face-attributes (face color)
+  "Set color-related attributes of FACE with respect to COLOR."
+  (when (facep face)
+    (dolist (property '(:foreground :background :underline :overline))
+      (unless (eq (face-attribute face property) 'unspecified)
+	(set-face-attribute face nil property color)))))
+
+(defun rudel-overlay-options-changed ()
+  "Update Rudel overlays after a change of customization options."
+  (dolist (buffer (buffer-list))
+    (with-current-buffer buffer
+      (mapc #'rudel-overlay-author-update (rudel-overlays)))))
+
+(provide 'rudel-overlay)
+;;; rudel-overlay.el ends here