diff --git a/snippet.el b/snippet.el index b75f077..d79fd1f 100644 --- a/snippet.el +++ b/snippet.el @@ -25,7 +25,7 @@ ;;; Code: -(cl-defstruct (snippet--field (:constructor snippet--make-field (name parent-field))) +(cl-defstruct (snippet--field (:constructor snippet--make-field (name mirrors parent-field))) name start end parent-field @@ -35,7 +35,7 @@ next) -(cl-defstruct (snippet--mirror (:constructor snippet--make-mirror (source transform))) +(cl-defstruct (snippet--mirror (:constructor snippet--make-mirror (source transform parent-field))) source start end (transform nil) @@ -53,55 +53,147 @@ (insert (funcall (snippet--mirror-transform mirror))) (setf (snippet--mirror-end mirror) (point))) +(defun snippet--field-text (field) + (buffer-substring-no-properties (snippet--field-start field) + (snippet--field-end field))) + + + +;;; the define-snippet macro and its helpers +;;; + + +(defun snippet--form-field-p (form) + (and (consp form) (eq (car form) 'field))) +(defun snippet--form-mirror-p (form) + (and (consp form) (eq (car form) 'mirror))) +(defun snippet--form-make-field-sym (field-name &optional parent-field-sym) + (make-symbol (format "field-%s%s" field-name + (if parent-field-sym + (format "-son-of-%s" parent-field-sym) + "")))) +(defun snippet--form-make-mirror-sym (mirror-name source-field-name &optional parent-field-sym) + (make-symbol (format "mirror-%s-of-%s%s" mirror-name source-field-name + (if parent-field-sym + (format "-son-of-%s" parent-field-sym) + "")))) +(defun snippet--form-make-field-form (field-name parent-field-sym mirrors) + `(snippet--make-field ,field-name ,parent-field-sym ,mirrors)) +(defun snippet--form-make-mirror-form (source-field-sym transform) + `(snippet--make-mirror ,source-field-sym ,transform)) + + +(defvar snippet--form-mirror-sym-idx nil) +(defun snippet--form-sym-tuples (forms &optional parent-field-sym) + (loop with snippet--form-mirror-sym-idx = (or snippet--form-mirror-sym-idx + 0) + for form in forms + append (cond ((snippet--form-field-p form) + ;; + ;; + (let ((field-sym (snippet--form-make-field-sym (second form) parent-field-sym))) + `((,field-sym ,form ,parent-field-sym) + ,@(when (listp (third form)) + (snippet--form-sym-tuples (third form) field-sym))))) + + ((snippet--form-mirror-p form) + ;; + ;; + (incf snippet--form-mirror-sym-idx) + (let ((mirror-sym (snippet--form-make-mirror-sym snippet--form-mirror-sym-idx + (second form) + parent-field-sym))) + `((,mirror-sym ,form ,parent-field-sym)))) + + (t + ;; it's a literal string, append a dummy tuple + `((string ,form)))))) + +(defun snippet--make-object-sym-tuples (tuples) + (let* ((field-mirrors (make-hash-table)) + ;; we first collect `snippet--make-mirror' forms. When + ;; collecting them, we populate the `field-mirrors' table... + ;; + (make-mirror-forms + (loop for (sym form parent-sym) in tuples + when (snippet--form-mirror-p form) + collect (let ((source-sym nil)) + (loop for (sym-b form-b) in tuples + when (and + (snippet--form-field-p form-b) + (eq (second form) + (second form-b))) + do + (setq source-sym sym-b) + (puthash source-sym (cons sym (gethash source-sym field-mirrors)) field-mirrors)) + (unless source-sym + (error "mirror definition %s mentions unknown field" form)) + `(,sym (snippet--make-mirror ,source-sym + ,(snippet--transform-lambda (third form) source-sym) + ,parent-sym))))) + ;; so that we can now create `snippet--make-field' forms with + ;; complete lists of mirror symbols. + ;; + (make-field-forms + (loop for (sym form parent-sym) in tuples + when (snippet--form-field-p form) + collect `(,sym (snippet--make-field ,(second form) (list ,@(gethash sym field-mirrors)) ,parent-sym))))) + + (append make-field-forms + make-mirror-forms))) + +(defun snippet--transform-lambda (transform-form source-sym) + `(lambda () + (funcall + #'(lambda (field-text) + ,(or transform-form + 'field-text)) + (snippet--field-text ,source-sym)))) + (defmacro* define-snippet (name (&key obarray) &rest body) - (cl-flet ((field-p (form) (and (consp form) (eq (car form) 'field))) - (mirror-p (form) (and (consp form) (eq (car form) 'mirror))) - (make-field-sym (field-name) (make-symbol (format "field-%s" - field-name))) - (make-mirror-sym (mirror-name field-name) (make-symbol (format "mirror-%s-of-%s" - mirror-name - field-name)))) + (let* ((sym-tuples (snippet--form-sym-tuples body)) + (make-object-forms (snippet--make-object-forms sym-tuples))) `(defun ,name () - (let* (,@(loop for form in (cl-remove-if-not #'field-p body) - for field-sym = (make-field-sym (second form)) - collect `(,field-sym - (snippet--make-field ,(second form) ,(third form)))) - ,@(loop for form in (cl-remove-if-not #'mirror-p body) - for mirror-sym = (make-mirror-sym i (second form)) - for source-field-sym = (make-field-sym (second form)) - for i from 1 - collect `(,mirror-sym - (snippet--make-mirror ,source-field-sym - #'(lambda () - (funcall - #'(lambda (field-text) - ,(third form)) - (snippet--field-text ,source-field-sym)))))) + (let* (,@(remove 'string (mapcar #'car sym-tuples)) (start (point)) overlay) - ,@(loop with mirror-idx = 1 - for form in body - collect (cond ((field-p form) - `(snippet--insert-field ,(make-field-sym (second form)) - ,(third form))) - ((mirror-p form) - (prog1 `(snippet--insert-mirror ,(make-mirror-sym mirror-idx - (second form))) - (incf mirror-idx))) + ,@make-object-forms + + + ,@(loop for (sym form) in sym-tuples + collect (cond ((snippet--form-field-p form) + `(snippet--insert-field ,sym ,(third form))) + ((snippet--form-mirror-p form) + `(snippet--insert-mirror ,sym)) (t `(insert ,form)))) + (setq overlay (make-overlay start (point))))))) (define-snippet printf () "printf (\"" (field 1 "%s") - "\n" (mirror 1 (if (string-match "%" field-text) "," "\);")) (field 2) (mirror 1 (if (string-match "%" field-text) "\);" ""))) +(printf) +(ert-deftest snippet--test-form-sym-tuples () + (let* ((test-tuples (snippet--form-sym-tuples '((field 1 "bla") + "ble" + (mirror 1) + (field 2 + ((field 3 "fonix") + "fotrix" + (mirror 1 "qqcoisa"))) + "end"))) + (symbols-declared (mapcar #'(lambda (sym) (intern (symbol-name sym))) + (remove 'string (mapcar #'car test-tuples))))) + (should + (equal '(field-1 mirror-1-of-1 field-2 field-3-son-of-field-2 mirror-2-of-1-son-of-field-2) + symbols-declared)))) (provide 'snippet)