Commit | Line | Data |
---|---|---|
4d902e6f CY |
1 | ;;; srecode/fields.el --- Handling type-in fields in a buffer. |
2 | ;; | |
114f9c96 | 3 | ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. |
4d902e6f CY |
4 | ;; |
5 | ;; Author: Eric M. Ludlam <eric@siege-engine.com> | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | ;;; Commentary: | |
23 | ;; | |
24 | ;; Idea courtesy of yasnippets. | |
25 | ;; | |
26 | ;; If someone prefers not to type unknown dictionary entries into | |
27 | ;; mini-buffer prompts, it could instead use in-buffer fields. | |
28 | ;; | |
29 | ;; A template-region specifies an area in which the fields exist. If | |
30 | ;; the cursor exits the region, all fields are cleared. | |
31 | ;; | |
32 | ;; Each field is independent, but some are linked together by name. | |
33 | ;; Typing in one will cause the matching ones to change in step. | |
34 | ;; | |
35 | ;; Each field has 2 overlays. The second overlay allows control in | |
36 | ;; the character just after the field, but does not highlight it. | |
37 | ||
38 | ;; Keep this library independent of SRecode proper. | |
39 | (require 'eieio) | |
40 | ||
41 | ;;; Code: | |
42 | (defvar srecode-field-archive nil | |
43 | "While inserting a set of fields, collect in this variable. | |
44 | Once an insertion set is done, these fields will be activated.") | |
45 | ||
46 | (defface srecode-field-face | |
47 | '((((class color) (background dark)) | |
48 | (:underline "green")) | |
49 | (((class color) (background light)) | |
50 | (:underline "green4"))) | |
51 | "*Face used to specify editable fields from a template." | |
52 | :group 'semantic-faces) | |
53 | ||
54 | ;;; BASECLASS | |
55 | ;; | |
56 | ;; Fields and the template region share some basic overlay features. | |
57 | ||
58 | (defclass srecode-overlaid () | |
59 | ((overlay :documentation | |
60 | "Overlay representing this field. | |
61 | The overlay will crossreference this object.") | |
62 | ) | |
63 | "An object that gets automatically bound to an overlay. | |
64 | Has virtual :start and :end initializers.") | |
65 | ||
66 | (defmethod initialize-instance ((olaid srecode-overlaid) &optional args) | |
67 | "Initialize OLAID, being sure it archived." | |
68 | ;; Extract :start and :end from the olaid list. | |
69 | (let ((newargs nil) | |
70 | (olay nil) | |
71 | start end | |
72 | ) | |
73 | ||
74 | (while args | |
75 | (cond ((eq (car args) :start) | |
76 | (setq args (cdr args)) | |
77 | (setq start (car args)) | |
78 | (setq args (cdr args)) | |
79 | ) | |
80 | ((eq (car args) :end) | |
81 | (setq args (cdr args)) | |
82 | (setq end (car args)) | |
83 | (setq args (cdr args)) | |
84 | ) | |
85 | (t | |
86 | (push (car args) newargs) | |
87 | (setq args (cdr args)) | |
88 | (push (car args) newargs) | |
89 | (setq args (cdr args))) | |
90 | )) | |
91 | ||
92 | ;; Create a temporary overlay now. We have to use an overlay and | |
93 | ;; not a marker becaues of the in-front insertion rules. The rules | |
94 | ;; are backward from what is wanted while typing. | |
95 | (setq olay (make-overlay start end (current-buffer) t nil)) | |
96 | (overlay-put olay 'srecode-init-only t) | |
97 | ||
98 | (oset olaid overlay olay) | |
99 | (call-next-method olaid (nreverse newargs)) | |
100 | ||
101 | )) | |
102 | ||
103 | (defmethod srecode-overlaid-activate ((olaid srecode-overlaid)) | |
104 | "Activate the overlaid area." | |
105 | (let* ((ola (oref olaid overlay)) | |
106 | (start (overlay-start ola)) | |
107 | (end (overlay-end ola)) | |
108 | ;; Create a new overlay here. | |
109 | (ol (make-overlay start end (current-buffer) nil t))) | |
110 | ||
111 | ;; Remove the old one. | |
112 | (delete-overlay ola) | |
113 | ||
114 | (overlay-put ol 'srecode olaid) | |
115 | ||
116 | (oset olaid overlay ol) | |
117 | ||
118 | )) | |
119 | ||
120 | (defmethod srecode-delete ((olaid srecode-overlaid)) | |
121 | "Delete the overlay from OLAID." | |
122 | (delete-overlay (oref olaid overlay)) | |
123 | (slot-makeunbound olaid 'overlay) | |
124 | ) | |
125 | ||
126 | (defmethod srecode-empty-region-p ((olaid srecode-overlaid)) | |
127 | "Return non-nil if the region covered by OLAID is of length 0." | |
128 | (= 0 (srecode-region-size olaid))) | |
129 | ||
130 | (defmethod srecode-region-size ((olaid srecode-overlaid)) | |
131 | "Return the length of region covered by OLAID." | |
132 | (let ((start (overlay-start (oref olaid overlay))) | |
133 | (end (overlay-end (oref olaid overlay)))) | |
134 | (- end start))) | |
135 | ||
136 | (defmethod srecode-point-in-region-p ((olaid srecode-overlaid)) | |
137 | "Return non-nil if point is in the region of OLAID." | |
138 | (let ((start (overlay-start (oref olaid overlay))) | |
139 | (end (overlay-end (oref olaid overlay)))) | |
140 | (and (>= (point) start) (<= (point) end)))) | |
141 | ||
142 | (defun srecode-overlaid-at-point (class) | |
143 | "Return a list of overlaid fields of type CLASS at point." | |
144 | (let ((ol (overlays-at (point))) | |
145 | (ret nil)) | |
146 | (while ol | |
147 | (let ((tmp (overlay-get (car ol) 'srecode))) | |
148 | (when (and tmp (object-of-class-p tmp class)) | |
149 | (setq ret (cons tmp ret)))) | |
150 | (setq ol (cdr ol))) | |
151 | (car (nreverse ret)))) | |
152 | ||
153 | (defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to) | |
154 | "Return the text under OLAID. | |
155 | If SET-TO is a string, then replace the text of OLAID wit SET-TO." | |
156 | (let* ((ol (oref olaid overlay)) | |
157 | (start (overlay-start ol))) | |
158 | (if (not (stringp set-to)) | |
159 | ;; Just return it. | |
160 | (buffer-substring-no-properties start (overlay-end ol)) | |
161 | ;; Replace it. | |
162 | (save-excursion | |
163 | (delete-region start (overlay-end ol)) | |
164 | (goto-char start) | |
165 | (insert set-to) | |
166 | (move-overlay ol start (+ start (length set-to)))) | |
167 | nil))) | |
168 | ||
169 | ;;; INSERTED REGION | |
170 | ;; | |
171 | ;; Managing point-exit, and flushing fields. | |
172 | ||
173 | (defclass srecode-template-inserted-region (srecode-overlaid) | |
174 | ((fields :documentation | |
175 | "A list of field overlays in this region.") | |
176 | (active-region :allocation :class | |
177 | :initform nil | |
178 | :documentation | |
179 | "The template region currently being handled.") | |
180 | ) | |
181 | "Manage a buffer region in which fields exist.") | |
182 | ||
183 | (defmethod initialize-instance ((ir srecode-template-inserted-region) | |
184 | &rest args) | |
185 | "Initialize IR, capturing the active fields, and creating the overlay." | |
186 | ;; Fill in the fields | |
187 | (oset ir fields srecode-field-archive) | |
188 | (setq srecode-field-archive nil) | |
189 | ||
190 | ;; Initailize myself first. | |
191 | (call-next-method) | |
192 | ) | |
193 | ||
194 | (defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region)) | |
195 | "Activate the template area for IR." | |
196 | ;; Activate all our fields | |
197 | ||
198 | (dolist (F (oref ir fields)) | |
199 | (srecode-overlaid-activate F)) | |
200 | ||
201 | ;; Activate our overlay. | |
202 | (call-next-method) | |
203 | ||
204 | ;; Position the cursor at the first field | |
205 | (let ((first (car (oref ir fields)))) | |
206 | (goto-char (overlay-start (oref first overlay)))) | |
207 | ||
208 | ;; Set ourselves up as 'active' | |
209 | (oset ir active-region ir) | |
210 | ||
211 | ;; Setup the post command hook. | |
212 | (add-hook 'post-command-hook 'srecode-field-post-command t t) | |
213 | ) | |
214 | ||
215 | (defmethod srecode-delete ((ir srecode-template-inserted-region)) | |
216 | "Call into our base, but also clear out the fields." | |
217 | ;; Clear us out of the baseclass. | |
218 | (oset ir active-region nil) | |
219 | ;; Clear our fields. | |
220 | (mapc 'srecode-delete (oref ir fields)) | |
221 | ;; Call to our base | |
222 | (call-next-method) | |
223 | ;; Clear our hook. | |
224 | (remove-hook 'post-command-hook 'srecode-field-post-command t) | |
225 | ) | |
226 | ||
227 | (defsubst srecode-active-template-region () | |
228 | "Return the active region for template fields." | |
229 | (oref srecode-template-inserted-region active-region)) | |
230 | ||
231 | (defun srecode-field-post-command () | |
232 | "Srecode field handler in the post command hook." | |
233 | (let ((ar (srecode-active-template-region)) | |
234 | ) | |
235 | (if (not ar) | |
236 | ;; Find a bug and fix it. | |
237 | (remove-hook 'post-command-hook 'srecode-field-post-command t) | |
238 | (if (srecode-point-in-region-p ar) | |
239 | nil ;; Keep going | |
240 | ;; We moved out of the temlate. Cancel the edits. | |
241 | (srecode-delete ar))) | |
242 | )) | |
243 | ||
244 | ;;; FIELDS | |
245 | ||
246 | (defclass srecode-field (srecode-overlaid) | |
247 | ((tail :documentation | |
248 | "Overlay used on character just after this field. | |
249 | Used to provide useful keybindings there.") | |
250 | (name :initarg :name | |
251 | :documentation | |
252 | "The name of this field. | |
253 | Usually initialized from the dictionary entry name that | |
254 | the users needs to edit.") | |
255 | (prompt :initarg :prompt | |
256 | :documentation | |
257 | "A prompt string to use if this were in the minibuffer. | |
258 | Display when the cursor enters this field.") | |
259 | (read-fcn :initarg :read-fcn | |
260 | :documentation | |
261 | "A function that would be used to read a string. | |
262 | Try to use this to provide useful completion when available.") | |
263 | ) | |
264 | "Representation of one field.") | |
265 | ||
266 | (defvar srecode-field-keymap | |
267 | (let ((km (make-sparse-keymap))) | |
268 | (define-key km "\C-i" 'srecode-field-next) | |
269 | (define-key km "\M-\C-i" 'srecode-field-prev) | |
270 | (define-key km "\C-e" 'srecode-field-end) | |
271 | (define-key km "\C-a" 'srecode-field-start) | |
272 | (define-key km "\M-m" 'srecode-field-start) | |
273 | (define-key km "\C-c\C-c" 'srecode-field-exit-ask) | |
274 | km) | |
275 | "Keymap applied to field overlays.") | |
276 | ||
277 | (defmethod initialize-instance ((field srecode-field) &optional args) | |
278 | "Initialize FIELD, being sure it archived." | |
279 | (add-to-list 'srecode-field-archive field t) | |
280 | (call-next-method) | |
281 | ) | |
282 | ||
283 | (defmethod srecode-overlaid-activate ((field srecode-field)) | |
284 | "Activate the FIELD area." | |
285 | (call-next-method) | |
286 | ||
287 | (let* ((ol (oref field overlay)) | |
288 | (end nil) | |
289 | (tail nil)) | |
290 | (overlay-put ol 'face 'srecode-field-face) | |
291 | (overlay-put ol 'keymap srecode-field-keymap) | |
292 | (overlay-put ol 'modification-hooks '(srecode-field-mod-hook)) | |
293 | (overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook)) | |
294 | (overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook)) | |
295 | ||
296 | (setq end (overlay-end ol)) | |
297 | (setq tail (make-overlay end (+ end 1) (current-buffer))) | |
298 | ||
299 | (overlay-put tail 'srecode field) | |
300 | (overlay-put tail 'keymap srecode-field-keymap) | |
301 | (overlay-put tail 'face 'srecode-field-face) | |
302 | (oset field tail tail) | |
303 | ) | |
304 | ) | |
305 | ||
306 | (defmethod srecode-delete ((olaid srecode-field)) | |
307 | "Delete our secondary overlay." | |
308 | ;; Remove our spare overlay | |
309 | (delete-overlay (oref olaid tail)) | |
310 | (slot-makeunbound olaid 'tail) | |
311 | ;; Do our baseclass work. | |
312 | (call-next-method) | |
313 | ) | |
314 | ||
315 | (defvar srecode-field-replication-max-size 100 | |
316 | "Maximum size of a field before cancelling replication.") | |
317 | ||
318 | (defun srecode-field-mod-hook (ol after start end &optional pre-len) | |
319 | "Modification hook for the field overlay. | |
320 | OL is the overlay. | |
321 | AFTER is non-nil if it is called after the change. | |
322 | START and END are the bounds of the change. | |
323 | PRE-LEN is used in the after mode for the length of the changed text." | |
324 | (when (and after (not undo-in-progress)) | |
325 | (let* ((field (overlay-get ol 'srecode)) | |
326 | (inhibit-point-motion-hooks t) | |
327 | (inhibit-modification-hooks t) | |
328 | ) | |
329 | ;; Sometimes a field is deleted, but we might still get a stray | |
330 | ;; event. Lets just ignore those events. | |
331 | (when (slot-boundp field 'overlay) | |
332 | ;; First, fixup the two overlays, in case they got confused. | |
333 | (let ((main (oref field overlay)) | |
334 | (tail (oref field tail))) | |
335 | (move-overlay main | |
336 | (overlay-start main) | |
337 | (1- (overlay-end tail))) | |
338 | (move-overlay tail | |
339 | (1- (overlay-end tail)) | |
340 | (overlay-end tail))) | |
341 | ;; Now capture text from the main overlay, and propagate it. | |
342 | (let* ((new-text (srecode-overlaid-text field)) | |
343 | (region (srecode-active-template-region)) | |
344 | (allfields (when region (oref region fields))) | |
345 | (name (oref field name))) | |
346 | (dolist (F allfields) | |
347 | (when (and (not (eq F field)) | |
348 | (string= name (oref F name))) | |
349 | (if (> (length new-text) srecode-field-replication-max-size) | |
350 | (message "Field size too large for replication.") | |
351 | ;; If we find other fields with the same name, then keep | |
352 | ;; then all together. Disable change hooks to make sure | |
353 | ;; we don't get a recursive edit. | |
354 | (srecode-overlaid-text F new-text) | |
355 | )))) | |
356 | )))) | |
357 | ||
358 | (defun srecode-field-behind-hook (ol after start end &optional pre-len) | |
359 | "Modification hook for the field overlay. | |
360 | OL is the overlay. | |
361 | AFTER is non-nil if it is called after the change. | |
362 | START and END are the bounds of the change. | |
363 | PRE-LEN is used in the after mode for the length of the changed text." | |
364 | (when after | |
365 | (let* ((field (overlay-get ol 'srecode)) | |
366 | ) | |
367 | (move-overlay ol (overlay-start ol) end) | |
368 | (srecode-field-mod-hook ol after start end pre-len)) | |
369 | )) | |
370 | ||
371 | (defmethod srecode-field-goto ((field srecode-field)) | |
372 | "Goto the FIELD." | |
373 | (goto-char (overlay-start (oref field overlay)))) | |
374 | ||
375 | (defun srecode-field-next () | |
376 | "Move to the next field." | |
377 | (interactive) | |
378 | (let* ((f (srecode-overlaid-at-point 'srecode-field)) | |
379 | (tr (srecode-overlaid-at-point 'srecode-template-inserted-region)) | |
380 | ) | |
381 | (when (not f) (error "Not in a field")) | |
382 | (when (not tr) (error "Not in a template region")) | |
383 | ||
384 | (let ((fields (oref tr fields))) | |
385 | (while fields | |
386 | ;; Loop over fields till we match. Then move to the next one. | |
387 | (when (eq f (car fields)) | |
388 | (if (cdr fields) | |
389 | (srecode-field-goto (car (cdr fields))) | |
390 | (srecode-field-goto (car (oref tr fields)))) | |
391 | (setq fields nil) | |
392 | ) | |
393 | (setq fields (cdr fields)))) | |
394 | )) | |
395 | ||
396 | (defun srecode-field-prev () | |
397 | "Move to the prev field." | |
398 | (interactive) | |
399 | (let* ((f (srecode-overlaid-at-point 'srecode-field)) | |
400 | (tr (srecode-overlaid-at-point 'srecode-template-inserted-region)) | |
401 | ) | |
402 | (when (not f) (error "Not in a field")) | |
403 | (when (not tr) (error "Not in a template region")) | |
404 | ||
405 | (let ((fields (reverse (oref tr fields)))) | |
406 | (while fields | |
407 | ;; Loop over fields till we match. Then move to the next one. | |
408 | (when (eq f (car fields)) | |
409 | (if (cdr fields) | |
410 | (srecode-field-goto (car (cdr fields))) | |
411 | (srecode-field-goto (car (oref tr fields)))) | |
412 | (setq fields nil) | |
413 | ) | |
414 | (setq fields (cdr fields)))) | |
415 | )) | |
416 | ||
417 | (defun srecode-field-end () | |
418 | "Move to the end of this field." | |
419 | (interactive) | |
420 | (let* ((f (srecode-overlaid-at-point 'srecode-field))) | |
421 | (goto-char (overlay-end (oref f overlay))))) | |
422 | ||
423 | (defun srecode-field-start () | |
424 | "Move to the end of this field." | |
425 | (interactive) | |
426 | (let* ((f (srecode-overlaid-at-point 'srecode-field))) | |
427 | (goto-char (overlay-start (oref f overlay))))) | |
428 | ||
429 | (defun srecode-field-exit-ask () | |
430 | "Ask if the user wants to exit field-editing mini-mode." | |
431 | (interactive) | |
432 | (when (y-or-n-p "Exit field-editing mode? ") | |
433 | (srecode-delete (srecode-active-template-region)))) | |
434 | ||
435 | ||
436 | (provide 'srecode/fields) | |
437 | ||
3999968a | 438 | ;; arch-tag: 00cea6f0-42ac-4b15-b778-46e6db0bfcb5 |
4d902e6f | 439 | ;;; srecode/fields.el ends here |