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

wip: just one test failing

Browse Source
This commit is contained in:
Joao Tavora 2013-11-06 08:45:01 +00:00
parent fc8804471a
commit 98946135a9
1 changed files with 80 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
snippet.el
View File

@ -109,20 +109,21 @@
(loop for form in sorted (loop for form in sorted
collect (snippet--make-field-sym (cadr form))))) collect (snippet--make-field-sym (cadr form)))))
(defun snippet--transform-lambda (transform-form) (defun snippet--make-transform-lambda (transform-form)
`(lambda (field-string field-empty-p) `(lambda (field-string field-empty-p)
,transform-form)) ,transform-form))
(defun snippet--eval-lambda (eval-form) (defun snippet--make-lambda (eval-form)
`(lambda (region-string) `#'(lambda (region-string)
,eval-form)) ,eval-form))
(defun define--snippet-body (body) (defun define--snippet-body (body)
"Does the actual work for `define-snippet'" "Does the actual work for `define-snippet'"
(let ((unfolded (snippet--unfold-forms (let ((unfolded (snippet--unfold-forms
(mapcar #'snippet--canonicalize-form body))) (mapcar #'snippet--canonicalize-form body)))
explicit-exit exit-object
all-objects) all-objects
all-mirrors)
`(let* (,@(loop for form in unfolded `(let* (,@(loop for form in unfolded
append (pcase form append (pcase form
(`(&field ,name ,_expr (&parent ,parent)) (`(&field ,name ,_expr (&parent ,parent))
@ -147,43 +148,56 @@
,prev-sym ,prev-sym
,(pcase expr ,(pcase expr
(`(&eval ,form) (`(&eval ,form)
`',form)) `(funcall ,(snippet--make-lambda form)
region-string)))) region-string)))))))
(`(&mirror ,name (&transform ,transform) (&parent ,parent)) (`(&mirror ,name (&transform ,transform) (&parent ,parent))
(setq sym (snippet--make-mirror-sym (setq sym (snippet--make-mirror-sym
(cl-incf mirror-idx) name)) (cl-incf mirror-idx) name))
(push sym all-mirrors)
`((,sym (snippet--make-and-insert-mirror `((,sym (snippet--make-and-insert-mirror
,parent ,parent
,prev-sym ,prev-sym
,(snippet--make-field-sym name) ,(snippet--make-field-sym name)
',transform)))) ',transform))))
(`(&exit (&eval ,form) (&parent ,parent)) (`(&exit (&eval ,form) (&parent ,parent))
(when explicit-exit (when exit-object
(error "too many &exit forms given")) (error "too many &exit forms given"))
(setq sym (snippet--make-exit-sym) (setq sym (snippet--make-exit-sym)
explicit-exit sym) exit-object sym)
`((,sym (snippet--make-and-insert-exit `((,sym (snippet--make-and-insert-exit
,parent ,parent
,prev-sym ,prev-sym
',form ,(and form
region-string)))) `(funcall ,(snippet--make-lambda form)
region-string))))))
(`(&eval ,form (&parent ,parent)) (`(&eval ,form (&parent ,parent))
`((,(cl-gensym "constant-") `((,(cl-gensym "constant-")
(snippet--insert-constant (snippet--insert-constant
',form ,parent
region-string (funcall ,(snippet--make-lambda form)
,parent))))) region-string))))))
into object-forms into object-forms
when sym do when sym do
(push sym all-objects) (push sym all-objects)
(setq prev-sym sym) (setq prev-sym sym)
(setq sym nil) (setq sym nil)
finally (cl-return finally
(progn
(unless exit-object
(setq exit-object (snippet--make-exit-sym))
(push exit-object all-objects)
(nconc object-forms
`((,exit-object (snippet--make-and-insert-exit
nil
,prev-sym
nil)))))
(cl-return
(append object-forms (append object-forms
`((all-objects (list ,@all-objects)))))) `((all-objects (list ,@all-objects)))))))
(sorted-fields (list ,@(snippet--sorted-field-syms (sorted-fields (list ,@(snippet--sorted-field-syms
unfolded)))) unfolded)))
(all-mirrors (list ,@all-mirrors)))
(mapc #'snippet--update-mirror all-mirrors)
(setq snippet--field-overlay (setq snippet--field-overlay
(let ((overlay (make-overlay (point) (point) nil nil t))) (let ((overlay (make-overlay (point) (point) nil nil t)))
(overlay-put overlay (overlay-put overlay
@ -209,10 +223,7 @@
sorted-fields) sorted-fields)
(overlay-put overlay (overlay-put overlay
'snippet--exit 'snippet--exit
,(or explicit-exit ,exit-object)
`(snippet--make-and-insert-exit
nil ,(car all-objects)
nil nil)))
overlay)) overlay))
(snippet-next-field) (snippet-next-field)
(add-hook 'post-command-hook 'snippet--post-command-hook t))))) (add-hook 'post-command-hook 'snippet--post-command-hook t)))))
@ -314,32 +325,33 @@ meaning is not decided yet"
(cl-defstruct (snippet--exit (:constructor snippet--make-exit) (cl-defstruct (snippet--exit (:constructor snippet--make-exit)
(:include snippet--object))) (:include snippet--object)))
(defun snippet--call-with-inserting-object (object prev fn)
(when prev
(cl-assert (null (snippet--object-next prev)) nil
"previous object already has another sucessor")
(setf (snippet--object-next prev) object))
(setf (snippet--object-start object)
(if (and prev
(= (point) (snippet--object-end prev)))
(snippet--object-end prev)
(point-marker)))
(funcall fn)
(setf (snippet--object-end object)
(point-marker))
(when (snippet--object-parent object)
(setf (snippet--object-end
(snippet--object-parent object))
(snippet--object-end object)))
object)
(defmacro snippet--inserting-object (object prev &rest body) (defmacro snippet--inserting-object (object prev &rest body)
(declare (indent defun) (debug (sexp sexp &rest form))) (declare (indent defun) (debug (sexp sexp &rest form)))
`(progn `(snippet--call-with-inserting-object ,object ,prev #'(lambda () ,@body)))
(when ,prev
(cl-assert (null (snippet--object-next ,prev)) nil
"previous object already has another sucessor")
(setf (snippet--object-next ,prev) ,object))
(setf (snippet--object-start ,object)
(if (and ,prev
(= (point) (snippet--object-end ,prev)))
(snippet--object-end ,prev)
(point-marker)))
,@body
(setf (snippet--object-end ,object)
(point-marker))
(when (snippet--object-parent ,object)
(setf (snippet--object-end
(snippet--object-parent ,object))
(snippet--object-end ,object)))
,object))
(defun snippet--insert-field (field prev default region-string) (defun snippet--insert-field (field prev default)
(snippet--inserting-object field prev (snippet--inserting-object field prev
(when default (when default
(insert (funcall (snippet--eval-lambda default) (insert default))))
region-string)))))
(defun snippet--make-and-insert-mirror (parent prev source transform) (defun snippet--make-and-insert-mirror (parent prev source transform)
(let ((mirror (snippet--make-mirror (let ((mirror (snippet--make-mirror
@ -349,20 +361,19 @@ meaning is not decided yet"
:transform (snippet--transform-lambda transform)))) :transform (snippet--transform-lambda transform))))
(snippet--inserting-object mirror prev (snippet--inserting-object mirror prev
(pushnew mirror (snippet--field-mirrors source))) (pushnew mirror (snippet--field-mirrors source)))
(snippet--update-mirror mirror)
mirror)) mirror))
(defun snippet--make-and-insert-exit (parent prev constant region-string) (defun snippet--make-and-insert-exit (parent prev constant)
(let ((exit (snippet--make-exit :parent parent :prev prev))) (let ((exit (snippet--make-exit :parent parent :prev prev)))
(snippet--inserting-object exit prev (snippet--inserting-object exit prev
(when constant (when constant
(insert (funcall (snippet--eval-lambda constant) region-string)))))) (insert constant)))))
(defun snippet--insert-constant (constant region-string parent) (defun snippet--insert-constant (parent constant)
(when constant (when constant
(insert (funcall (snippet--eval-lambda constant) region-string))) (insert constant))
(when parent (when parent
(setf (snippet--object-next parent) (point-marker)))) (setf (snippet--object-end parent) (point-marker))))
(defun snippet--describe-field (field) (defun snippet--describe-field (field)
(with-current-buffer (snippet--object-buffer field) (with-current-buffer (snippet--object-buffer field)
@ -429,11 +440,9 @@ meaning is not decided yet"
(first sorted)))) (first sorted))))
(if target (if target
(snippet--move-to-field target) (snippet--move-to-field target)
(let ((exit (overlay-get snippet--field-overlay 'snippet--exit))) (goto-char (snippet--object-start (overlay-get snippet--field-overlay
(goto-char (if (markerp exit) 'snippet--exit)))
exit (snippet-exit-snippet))))
(snippet--object-start exit)))
(snippet-exit-snippet)))))
(defun snippet-prev-field () (defun snippet-prev-field ()
(interactive) (interactive)
@ -581,15 +590,21 @@ meaning is not decided yet"
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(erase-buffer) (erase-buffer)
(let ((active-field (overlay-get field-overlay 'snippet--field))) (let ((active-field (overlay-get field-overlay 'snippet--field)))
(cl-loop for object in (overlay-get field-overlay 'snippet--objects) (cl-loop for object in
when (snippet--field-p object) (cl-sort (cl-copy-list
do (overlay-get field-overlay 'snippet--objects)) #'<
:key #'snippet--object-start)
do (cond ((snippet--field-p object)
(insert (snippet--describe-field object)) (insert (snippet--describe-field object))
(when (eq object active-field) (insert " (active)")) (when (eq object active-field) (insert " (active)"))
(insert "\n") (insert "\n")
(cl-loop for mirror in (snippet--field-mirrors object) (cl-loop for mirror in (snippet--field-mirrors object)
do (insert " " (snippet--describe-mirror mirror) do (insert " " (snippet--describe-mirror mirror)
"\n"))))) "\n")))
((snippet--mirror-p object)
(insert (snippet--describe-mirror object) "\n"))
((snippet--exit-p object)
(insert (snippet--describe-exit object) "\n"))))))
(display-buffer (current-buffer)))) (display-buffer (current-buffer))))
(provide 'snippet) (provide 'snippet)