-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathfringe-helper.el
334 lines (308 loc) · 12.6 KB
/
fringe-helper.el
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
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
;;; fringe-helper.el --- helper functions for fringe bitmaps
;;
;; Copyright (C) 2008 Nikolaj Schumacher
;;
;; Author: Nikolaj Schumacher <bugs * nschum de>
;; Version: 0.1.1
;; Keywords: lisp
;; URL: http://nschum.de/src/emacs/fringe-helper/
;; Compatibility: GNU Emacs 22.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:
;;
;; fringe-helper contains helper functions for fringe bitmaps.
;;
;; `fringe-helper-define' allows you to to define fringe bitmaps using a visual
;; string replesentation. For example:
;;
;; (fringe-helper-define 'test-bitmap '(top repeat)
;; "XX......"
;; "..XX...."
;; "....XX.."
;; "......XX")
;;
;; You can also generate arguments for `define-fringe-bitmap' yourself, by
;; using `fringe-helper-convert'.
;;
;; fringe-helper also provides a few stock bitmaps. They are loaded on demand
;; by `fringe-lib-load' and adapt to the current fringe size to a certain
;; extend.
;;
;; `fringe-helper-insert' inserts a fringe bitmap at point and
;; `fringe-helper-insert-region' inserts a fringe bitmap along a region.
;; `fringe-helper-remove' removes both kinds.
;;
;;
;; Here's an example for enhancing `flymake-mode' with fringe bitmaps:
;;
;; (require 'fringe-helper)
;; (require 'flymake)
;;
;; (defvar flymake-fringe-overlays nil)
;; (make-variable-buffer-local 'flymake-fringe-overlays)
;;
;; (defadvice flymake-make-overlay (after add-to-fringe first
;; (beg end tooltip-text face mouse-face)
;; activate compile)
;; (push (fringe-helper-insert-region
;; beg end
;; (fringe-lib-load (if (eq face 'flymake-errline)
;; fringe-lib-exclamation-mark
;; fringe-lib-question-mark))
;; 'left-fringe 'font-lock-warning-face)
;; flymake-fringe-overlays))
;;
;; (defadvice flymake-delete-own-overlays (after remove-from-fringe activate
;; compile)
;; (mapc 'fringe-helper-remove flymake-fringe-overlays)
;; (setq flymake-fringe-overlays nil))
;;
;;
;;; Change Log:
;;
;; 2008-06-04 (0.1.1)
;; Fixed bug where `fringe-helper-remove' missed overlays at the end.
;; Fixed `fringe-lib-load' to work when already loaded.
;;
;; 2008-04-25 (0.1)
;; Initial release.
;;
;;; Code:
(eval-when-compile (require 'cl))
(defun fringe-helper-convert (&rest strings)
"Convert STRINGS into a vector usable for `define-fringe-bitmap'.
Each string in STRINGS represents a line of the fringe bitmap.
Periods (.) are background-colored pixel; Xs are foreground-colored. The
fringe bitmap always is aligned to the right. If the fringe has half
width, only the left 4 pixels of an 8 pixel bitmap will be shown.
For example, the following code defines a diagonal line.
\(fringe-helper-convert
\"XX......\"
\"..XX....\"
\"....XX..\"
\"......XX\"\)"
(unless (cdr strings)
;; only one string, probably with newlines
(setq strings (split-string (car strings) "\n")))
(apply 'vector
(mapcar (lambda (str)
(let ((num 0))
(dolist (c (string-to-list str))
(setq num (+ (* num 2) (if (eq c ?.) 0 1))))
num))
strings)))
(defmacro fringe-helper-define (name alignment &rest strings)
"Define a fringe bitmap from a visual representation.
Parameters NAME and ALIGNMENT are the same as `define-fringe-bitmap'.
Each string in STRINGS represents a line of the fringe bitmap as in
`fringe-helper-convert'."
(declare (indent defun))
`(define-fringe-bitmap ,name
(eval-when-compile (fringe-helper-convert ,@strings))
nil nil ,alignment))
(defun fringe-helper-insert (bitmap pos &optional side face)
"Insert a fringe bitmap at POS.
BITMAP is the name of a bitmap defined with `define-fringe-bitmap' or
`fringe-helper-define'. SIDE defaults to 'left-fringe and can also be
'right-fringe. FACE is used to determine the bitmap's color.
The function returns an object suitable for passing to
`fringe-helper-remove'."
(let* ((display-string `(,(or side 'left-fringe) ,bitmap .
,(when face (cons face nil))))
(before-string (propertize "!" 'display display-string))
(ov (make-overlay pos pos)))
(overlay-put ov 'before-string before-string)
(overlay-put ov 'fringe-helper t)
ov))
(defun fringe-helper-insert-region (beg end bitmap side &optional face)
"Insert fringe bitmaps between BEG and END.
BITMAP is the name of a bitmap defined with `define-fringe-bitmap' or
`fringe-helper-define'. SIDE defaults to 'left-fringe and can also be
'right-fringe. FACE is used to determine the bitmap's color. The
function returns an overlay covering the entire region, which is suitable
for passing to `fringe-helper-remove'. The region grows and shrinks with
input automatically."
(let* ((display-string `(,(or side 'left-fringe) ,bitmap .
,(when face (cons face nil))))
(before-string (propertize "!" 'display display-string))
(parent (make-overlay beg end))
ov)
(save-excursion
(goto-char beg)
(goto-char (point-at-bol 2))
;; can't use <= here, or we'll get an infinity loop at buffer end
(while (and (<= (point) end) (< (point) (point-max)))
(setq ov (make-overlay (point) (point)))
(overlay-put ov 'before-string before-string)
(overlay-put ov 'fringe-helper-parent parent)
(goto-char (point-at-bol 2))))
(overlay-put parent 'fringe-helper t)
(overlay-put parent 'before-string before-string)
(overlay-put parent 'insert-in-front-hooks
'(fringe-helper-modification-func))
(overlay-put parent 'modification-hooks
'(fringe-helper-modification-func))
parent))
(defun fringe-helper-modification-func (ov after-p beg end &optional len)
(if after-p
(if (eq beg end)
;; evaporate overlay
(when (= (overlay-start ov) (overlay-end ov))
(delete-overlay ov))
;; if new lines are inserted, add new bitmaps
(let ((before-string (overlay-get ov 'before-string))
fringe-ov)
(save-excursion
(goto-char beg)
(while (search-forward "\n" end t)
(setq fringe-ov (make-overlay (point) (point)))
(overlay-put fringe-ov 'before-string before-string)
(overlay-put fringe-ov 'fringe-helper-parent ov)))))
;; if a \n is removed, remove the fringe overlay
(unless (= beg end)
(setq beg (max beg (overlay-start ov)))
(setq end (min end (overlay-end ov)))
(save-excursion
(goto-char beg)
(while (search-forward "\n" end t)
(let ((overlays (overlays-in (point) (1+ (point)))))
(while overlays
(when (eq (overlay-get (car overlays) 'fringe-helper-parent) ov)
(delete-overlay (car overlays))
(setq overlays nil))
(pop overlays))))))))
(defun fringe-helper-remove (fringe-bitmap-reference)
"Remove a fringe bitmap."
(unless (or (not (overlay-buffer fringe-bitmap-reference))
(overlay-get fringe-bitmap-reference 'fringe-helper-parent))
;; region
(dolist (ov (overlays-in (overlay-start fringe-bitmap-reference)
(1+ (overlay-end fringe-bitmap-reference))))
(when (eq (overlay-get ov 'fringe-helper-parent) fringe-bitmap-reference)
(delete-overlay ov)))
(delete-overlay fringe-bitmap-reference)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fringe-lib-load (pattern &optional side)
"Load a stock bitmap.
It returns the symbol name of the loaded bitmap, which is suitable for passing
to `fringe-helper-insert'. The actual work of defining the bitmap is only done once.
PATTERN can be one of the following:
`fringe-lib-exclamation-mark': an exclamation mark
`fringe-lib-question-mark': a question mark
`fringe-lib-zig-zag': a zig-zag pattern
`fringe-lib-wave': a wavy-line pattern
`fringe-lib-stipple': a stipple pattern
`fringe-lib-full': a solid color
SIDE should be either 'left-fringe or 'right-fringe and defaults to the former."
(let ((fringe-width (frame-parameter (selected-frame)
(or side 'left-fringe)))
(alignment (when (eq (car pattern) 'repeat)
(setq pattern (cdr pattern))
'(top t))))
(while (> (caar pattern) fringe-width)
(pop pattern))
(setq pattern (cdar pattern))
(or (car (memq (car pattern) fringe-bitmaps))
(define-fringe-bitmap (car pattern) (cdr pattern) nil nil alignment))))
(defconst fringe-lib-exclamation-mark
`((5 fringe-lib-exclamation-mark-5 .
,(eval-when-compile
(fringe-helper-convert "...XX..."
"..XXXX.."
"..XXXX.."
"...XX..."
"...XX..."
"........"
"........"
"...XX..."
"...XX...")))
(0 fringe-lib-exclamation-mark-0 .
,(eval-when-compile
(fringe-helper-convert ".XX....."
".XX....."
".XX....."
".XX....."
".XX....."
"........"
"........"
".XX....."
".XX.....")))))
(defconst fringe-lib-question-mark
`((5 fringe-lib-question-mark-5 .
,(eval-when-compile
(fringe-helper-convert "...XX..."
"..XXXX.."
"..X..X.."
"....XX.."
"...XX..."
"...XX..."
"........"
"...XX..."
"...XX...")))
(0 fringe-lib-question-mark-0 .
,(eval-when-compile
(fringe-helper-convert ".XX....."
"XXXX...."
"X..X...."
"..XX...."
".XX....."
".XX....."
"........"
".XX....."
".XX.....")))))
(defconst fringe-lib-zig-zag
`(repeat
(0 fringe-lib-zig-zag-0 .
,(eval-when-compile
(fringe-helper-convert "X......."
"X......."
".X......"
".X......"
"..X....."
"..X....."
".X......"
".X......")))))
(defconst fringe-lib-wave
`(repeat
(0 fringe-lib-wave-0 .
,(eval-when-compile
(fringe-helper-convert "X......."
".X......"
"..X....."
"..X....."
"..X....."
".X......"
"X......."
"X.......")))))
(defconst fringe-lib-stipple
`(repeat
(0 fringe-lib-stipple-0 .
,(eval-when-compile
(fringe-helper-convert "XXXXXXXX"
"XXXXXXXX"
"XXXXXXXX"
"........"
"........"
"........")))))
(defconst fringe-lib-full
`(repeat
(0 fringe-lib-full-0 .
,(eval-when-compile
(fringe-helper-convert "XXXXXXXX")))))
(provide 'fringe-helper)
;;; fringe-helper.el ends here