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

wip: some tests already passing, but lambda scheme sucks

Browse Source
This commit is contained in:
Joao Tavora 2013-11-06 01:05:39 +00:00
parent c5f62d81ae
commit dc12a8b4a2
1 changed files with 51 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
snippet.el
View File

@ -120,14 +120,16 @@
(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
all-objects)
`(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))
`((,(snippet--make-field-sym name) `((,(snippet--make-field-sym name)
(snippet--make-field :parent (snippet--make-field :parent
,parent)))))) ,parent))))))
(region (and (region-active-p) (region-string (and (region-active-p)
(buffer-substring-no-properties (buffer-substring-no-properties
(region-beginning) (region-beginning)
(region-end))))) (region-end)))))
@ -136,7 +138,6 @@
with mirror-idx = 0 with mirror-idx = 0
with sym with sym
with prev-sym with prev-sym
with all-objects
append append
(pcase form (pcase form
(`(&field ,name ,expr (&parent ,_parent)) (`(&field ,name ,expr (&parent ,_parent))
@ -146,29 +147,32 @@
,prev-sym ,prev-sym
,(pcase expr ,(pcase expr
(`(&eval ,form) (`(&eval ,form)
`(funcall ,(snippet--eval-lambda form) `',form))
region-string))))))) region-string))))
(`(&mirror ,name ,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))
`((,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)
,(snippet--transform-lambda transform))))) ',transform))))
(`(&exit (&eval ,form) (&parent ,parent)) (`(&exit (&eval ,form) (&parent ,parent))
(setq sym (snippet--make-exit-sym)) (when explicit-exit
(error "too many &exit forms given"))
(setq sym (snippet--make-exit-sym)
explicit-exit sym)
`((,sym (snippet--make-and-insert-exit `((,sym (snippet--make-and-insert-exit
,parent ,parent
,prev-sym ,prev-sym
,(and form ',form
`(funcall ,(snippet--eval-lambda form) region-string))))
region-string))))))
(`(&eval ,form (&parent ,parent)) (`(&eval ,form (&parent ,parent))
`((,(cl-gensym "constant-") `((,(cl-gensym "constant-")
(snippet--insert-constant (snippet--insert-constant
(funcall ,(snippet--eval-lambda form) ',form
region-string) region-string
,parent))))) ,parent)))))
into object-forms into object-forms
when sym do when sym do
@ -177,10 +181,10 @@
(setq sym nil) (setq sym nil)
finally (cl-return finally (cl-return
(append object-forms (append object-forms
`((all-objects ,all-objects))))) `((all-objects (list ,@all-objects))))))
(sorted-fields ,(snippet--sorted-field-syms (sorted-fields (list ,@(snippet--sorted-field-syms
unfolded)) unfolded))))
(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
'face 'face
@ -200,10 +204,16 @@
(overlay-put overlay (overlay-put overlay
'snippet--objects 'snippet--objects
all-objects) all-objects)
(overlay-put snippet--field-overlay (overlay-put overlay
'snippet--fields 'snippet--fields
sorted-fields) sorted-fields)
overlay))) (overlay-put overlay
'snippet--exit
,(or explicit-exit
`(snippet--make-and-insert-exit
nil ,(car all-objects)
nil nil)))
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)))))
@ -290,13 +300,13 @@ meaning is not decided yet"
(cl-defstruct snippet--object (cl-defstruct snippet--object
start end parent next prev (buffer (current-buffer))) start end parent next prev (buffer (current-buffer)))
(cl-defstruct (snippet--field (:constructor snippet--make-field-1) (cl-defstruct (snippet--field (:constructor snippet--make-field)
(:include snippet--object)) (:include snippet--object))
name name
(mirrors '()) (mirrors '())
(modified-p nil)) (modified-p nil))
(cl-defstruct (snippet--mirror (:constructor snippet--make-mirror-1) (cl-defstruct (snippet--mirror (:constructor snippet--make-mirror)
(:include snippet--object)) (:include snippet--object))
source source
(transform nil)) (transform nil))
@ -304,18 +314,16 @@ 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--make-field (&key parent)
(let ((field (snippet--make-field-1 :parent parent)))
field))
(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 `(progn
(cl-assert (null (snippet--object-next ,prev)) nil (when ,prev
"previous object already has another sucessor") (cl-assert (null (snippet--object-next ,prev)) nil
(setf (snippet--object-next ,prev) ,object) "previous object already has another sucessor")
(setf (snippet--object-next ,prev) ,object))
(setf (snippet--object-start ,object) (setf (snippet--object-start ,object)
(if (= (point) (snippet--object-end ,prev)) (if (and ,prev
(= (point) (snippet--object-end ,prev)))
(snippet--object-end ,prev) (snippet--object-end ,prev)
(point-marker))) (point-marker)))
,@body ,@body
@ -324,34 +332,35 @@ meaning is not decided yet"
(when (snippet--object-parent ,object) (when (snippet--object-parent ,object)
(setf (snippet--object-end (setf (snippet--object-end
(snippet--object-parent ,object)) (snippet--object-parent ,object))
(snippet--object-end ,object))))) (snippet--object-end ,object)))
,object))
(defun snippet--insert-field (field prev default) (defun snippet--insert-field (field prev default region-string)
(snippet--inserting-object field prev (snippet--inserting-object field prev
(when default (when default
(insert default)))) (insert (funcall (snippet--eval-lambda 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-1 (let ((mirror (snippet--make-mirror
:parent parent :parent parent
:prev prev :prev prev
:source source :source source
:transform 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)))
(setf (snippet--mirror-source mirror) source) (snippet--update-mirror mirror)
(setf (snippet--mirror-transform mirror) transform))
mirror)) mirror))
(defun snippet--make-and-insert-exit (parent prev constant) (defun snippet--make-and-insert-exit (parent prev constant region-string)
(let ((exit (snippet--make-exit-1 :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 constant))))) (insert (funcall (snippet--eval-lambda constant) region-string))))))
(defun snippet--insert-constant (constant parent) (defun snippet--insert-constant (constant region-string parent)
(when constant (when constant
(insert constant)) (insert (funcall (snippet--eval-lambda constant) region-string)))
(when parent (when parent
(setf (snippet--object-next parent) (point-marker)))) (setf (snippet--object-next parent) (point-marker))))