| 1 | ;;; srecode/fields.el --- Handling type-in fields in a buffer. |
| 2 | ;; |
| 3 | ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. |
| 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 | |
| 438 | ;; arch-tag: 00cea6f0-42ac-4b15-b778-46e6db0bfcb5 |
| 439 | ;;; srecode/fields.el ends here |