diff options
Diffstat (limited to 'emacs.d/lisp/rudel/.svn/text-base/rudel-overlay.el.svn-base')
-rw-r--r-- | emacs.d/lisp/rudel/.svn/text-base/rudel-overlay.el.svn-base | 275 |
1 files changed, 275 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/.svn/text-base/rudel-overlay.el.svn-base b/emacs.d/lisp/rudel/.svn/text-base/rudel-overlay.el.svn-base new file mode 100644 index 0000000..093afdf --- /dev/null +++ b/emacs.d/lisp/rudel/.svn/text-base/rudel-overlay.el.svn-base @@ -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 |