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