1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
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
|
