ld/yasnippet
1
0
Fork 0
mirror of https://github.com/joaotavora/yasnippet.git synced 2025-10-13 13:13:03 +00:00
Code Issues Packages Projects Releases Wiki Activity

Implement protection overlays

Browse Source 
* snippet.el (snippet--field-overlay): Make buffer-local and permanent-local.
(snippet--field-protection-overlays): New variable.
(snippet--move-to-field): Also move protection overlays.
(snippet--field-overlay-changed): Don't do anything if undo in
progress or snippet being exited.
(snippet--field-protection-violated): new function.
(snippet--protection-overlay-face): New debug-only face.
(snippet-exit): Rename from `snippet-exit-snippet'
(snippet--exiting-p): New function
(snippet--activate-snippet): Create protection overlays.
(snippet--cleanup): New function.
(snippet--post-command-hook): Use `snippet--exiting-p' and
`snippet--cleanup'.
(snippet--debug-snippet): Consider that `snippet--field-overlay'
is now buffer-local.
This commit is contained in:
João Távora 2015-04-05 11:54:02 +01:00
parent 579ca936d2
commit ad2bb8bed1
1 changed files with 85 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

112
snippet.el
View File

@ -59,11 +59,6 @@
;;
;; TODO: more documentation
;;
;; TODO: "protection overlays" or some robust mechanism preventing the use from
;; inadvertenly destroying the snippet's structure and leaving its
;; incoherent carcass behind. Alternatively, detect this and exit the
;; snippet beforehand.
;;
;; TODO: primary field transformations: the (&transform ...) option to &field
;; constructs.
;;
@ -538,13 +533,24 @@ pairs. Its meaning is not decided yet"
(insert retval))))))
(defvar snippet--field-overlay nil)
(defvar snippet--field-protection-overlays nil)
(make-variable-buffer-local 'snippet--field-overlay)
(make-variable-buffer-local 'snippet--field-protection-overlays)
(put 'snippet--field-overlay 'permanent-local t)
(put 'snippet--field-protection-overlays 'permanent-local t)
(defun snippet--move-to-field (field)
(goto-char (snippet--object-start field))
(move-overlay snippet--field-overlay
(point)
(snippet--object-end field))
(overlay-put snippet--field-overlay 'snippet--field field))
(let ((start (snippet--object-start field))
(end (snippet--object-end field)))
(goto-char start)
(move-overlay snippet--field-overlay start end)
(move-overlay (car snippet--field-protection-overlays)
(max (point-min) (1- start))
start)
(move-overlay (cadr snippet--field-protection-overlays)
end
(min (point-max) (1+ end)))
(overlay-put snippet--field-overlay 'snippet--field field)))
(defun snippet--update-field-mirrors (field)
(mapc #'snippet--update-mirror (snippet--field-mirrors field))
@ -559,7 +565,12 @@ pairs. Its meaning is not decided yet"
;;
(let* ((field (overlay-get overlay 'snippet--field))
(inhibit-modification-hooks t))
(cond (after?
(cond ((and after?
;; Don't run if snippet is being exited
(not (snippet--exiting-p))
;; Also don't run if in the middle of an undo
(not undo-in-progress))
;; field clearing: if we're doing an insertion and the field hasn't
;; been modified yet, we're going to delete previous contents and
;; leave just the newly inserted text.
@ -587,6 +598,11 @@ pairs. Its meaning is not decided yet"
(t
(snippet--open-object field)))))
(defun snippet--field-protection-violated (_overlay after? _beg _end
&optional _pre-change-len)
(unless (or after? undo-in-progress)
(snippet-exit "protection overlay violated")))
(defun snippet--field-string (field)
(let ((start (snippet--object-start field))
(end (snippet--object-end field)))
@ -603,6 +619,10 @@ pairs. Its meaning is not decided yet"
'((t (:inherit 'region)))
"Face used to highlight the currently active field of a snippet")
(defface snippet--protection-overlay-face
'((t (:background "tomato")))
"Face used to highlight the currently active field of a snippet")
(defvar snippet-field-keymap
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<tab>") 'snippet-next-field)
@ -636,7 +656,7 @@ PREV means move to the previous field."
(let ((exit (overlay-get snippet--field-overlay
'snippet--exit)))
(snippet--move-to-field exit)
(overlay-put snippet--field-overlay 'snippet--exit-reason "exit")))))
(snippet-exit "exit")))))
(defun snippet-prev-field ()
"Move the the start of the previous field in the current snippet.
@ -645,8 +665,21 @@ Skips over nested fields if their parent has been modified."
(interactive)
(snippet-next-field t))
(defun snippet-exit-snippet (&optional reason)
(overlay-put snippet--field-overlay 'snippet--exit-reason reason))
(defun snippet-exit (&optional reason)
"Quit the currently active snippet."
(interactive (list "interactive quit"))
(cond (snippet--field-overlay
(overlay-put snippet--field-overlay 'snippet--exit-reason reason)
(unless (memq 'snippet--post-command-hook post-command-hook)
(display-warning 'snippet "Hook not present: forced snippet cleanup")
(snippet--cleanup reason)))
(t
(error "No active snippet"))))
(defun snippet--exiting-p ()
(overlay-get snippet--field-overlay 'snippet--exit-reason))
;;; Main
@ -704,15 +737,34 @@ Skips over nested fields if their parent has been modified."
'keymap
snippet-field-keymap)
overlay))
(setq snippet--field-protection-overlays
(list (make-overlay (point) (point) nil nil nil)
(make-overlay (point) (point) nil t nil)))
(mapc #'(lambda (ov)
(overlay-put ov
'modification-hooks
'(snippet--field-protection-violated))
(overlay-put ov
'face (if snippet--debug
'snippet--protection-overlay-face)))
snippet--field-protection-overlays)
(snippet-next-field)
(add-hook 'post-command-hook 'snippet--post-command-hook 'append 'local)))
(defun snippet--cleanup (reason)
(when snippet--field-overlay
(delete-overlay snippet--field-overlay)
(setq snippet--field-overlay nil))
(when snippet--field-protection-overlays
(mapc #'delete-overlay snippet--field-protection-overlays)
(setq snippet--field-protection-overlays nil))
(message "snippet exited (%s)" reason))
(defun snippet--post-command-hook ()
;; TODO: exiting the snippet might someday run user-provided code, hence the
;; apparent overengineeredness
;;
(let ((remove-self "unknown reason")
(exit-reason nil))
(let (remove-self exit-reason)
(cond
((and snippet--field-overlay
(not (overlay-buffer snippet--field-overlay)))
@ -721,8 +773,7 @@ Skips over nested fields if their parent has been modified."
exit-reason "overlay destroyed"))
(snippet--field-overlay
(setq exit-reason
(or (overlay-get snippet--field-overlay
'snippet--exit-reason)
(or (snippet--exiting-p)
(and (or (< (point)
(overlay-start snippet--field-overlay))
(> (point)
@ -741,13 +792,9 @@ Skips over nested fields if their parent has been modified."
;;
(remove-hook 'post-command-hook 'snippet--post-command-hook))
(remove-hook 'post-command-hook 'snippet--post-command-hook 'local))
(if (and snippet--debug snippet--field-overlay)
(snippet--debug-snippet snippet--field-overlay))
(if (and snippet--debug snippet--field-overlay) (snippet--debug-snippet))
(when exit-reason
(when snippet--field-overlay
(delete-overlay snippet--field-overlay)
(setq snippet--field-overlay nil))
(message "snippet exited (%s)" exit-reason))))
(snippet--cleanup exit-reason))))
;;; Debug helpers
@ -791,16 +838,21 @@ Skips over nested fields if their parent has been modified."
(with-current-buffer (snippet--object-buffer exit)
(format "exit %s" (if short "" (cl-call-next-method)))))
(defun snippet--debug-snippet (field-overlay)
(with-current-buffer (get-buffer-create "*snippet-debug*")
(defun snippet--debug-snippet ()
(let ((inhibit-read-only t)
(sorted (cl-sort (cl-copy-list
(overlay-get field-overlay 'snippet--objects))
#'snippet--object-<)))
(overlay-get snippet--field-overlay
'snippet--objects))
#'snippet--object-<))
(buffer (current-buffer)))
(with-current-buffer (get-buffer-create "*snippet-debug*")
(erase-buffer)
(cl-loop for object in sorted
do (insert (snippet--describe-object object) "\n")))
(display-buffer (current-buffer))))
do (insert
(with-current-buffer buffer
(snippet--describe-object object))
"\n"))
(display-buffer (current-buffer)))))
(provide 'snippet)