diff --git a/snippet-tests.el b/snippet-tests.el new file mode 100644 index 0000000..ba65e5b --- /dev/null +++ b/snippet-tests.el @@ -0,0 +1,69 @@ +;;; snippet-tests.el --- some basic tests for snippet.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2013 + +;; Author: ;;; some basic test snippets +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'snippet) + +(define-snippet printf () + "printf (\"" + (field 1 "%s") + (mirror 1 (if (string-match "%" field-text) "\"," "\);")) + (field 2) + (mirror 1 (if (string-match "%" field-text) "\);" ""))) + +(define-snippet foo () + (field 1 "bla") + "ble" + (mirror 1) + (field 2 + ((field 3 "fonix") + "fotrix" + (mirror 1 (concat field-text "qqcoisa")))) + "end") + +(define-snippet easy () + "A " + (field 1 "field") + " and its mirror: " + (mirror 1 (format "(mirror of %s)" field-text))) + +(defun test () + (interactive) + (with-current-buffer (switch-to-buffer (get-buffer-create "*test easy snippet*")) + (erase-buffer) + (easy))) + +(defun test2 () + (interactive) + (with-current-buffer (switch-to-buffer (get-buffer-create "*test printf snippent*")) + (erase-buffer) + (printf))) + +(provide 'snippet-tests) + +;;; Local Variables: +;;; lexical-binding: t +;;; End: +;;; snippet-tests.el ends here diff --git a/snippet.el b/snippet.el index 62f9eb4..692b8e4 100644 --- a/snippet.el +++ b/snippet.el @@ -26,215 +26,6 @@ (eval-when-compile (require 'cl)) - -(cl-defstruct (snippet--field (:constructor snippet--make-field ())) - name - start end - parent-field - (mirrors '()) - next-field - prev-field) - -(defun snippet--init-field (object name start end parent-field mirrors next-field prev-field) - (setf (snippet--field-name object) name - (snippet--field-start object) start - (snippet--field-end object) end - (snippet--field-parent-field object) parent-field - (snippet--field-mirrors object) mirrors - (snippet--field-next-field object) next-field - (snippet--field-prev-field object) prev-field)) - -(cl-defstruct (snippet--mirror (:constructor snippet--make-mirror ())) - source - start end - (transform nil) - parent-field) - -(defun snippet--init-mirror (object source start end transform parent-field) - (setf (snippet--mirror-source object) source - (snippet--mirror-start object) start - (snippet--mirror-end object) end - (snippet--mirror-transform object) transform - (snippet--mirror-parent-field object) parent-field)) - -(defgroup snippet nil - "Customize snippet features" - :group 'convenience) - -(defface snippet-field-face - '((t (:inherit 'region))) - "Face used to highlight the currently active field of a snippet" - :group 'snippet) - -(defvar snippet-field-keymap - (let ((map (make-sparse-keymap))) - (define-key map (kbd "") 'snippet-next-field) - (define-key map (kbd "S-") 'snippet-prev-field) - map) - "The active keymap while a snippet expansion is in progress.") - -(defvar snippet--field-overlay nil) - -(defun snippet-next-field (&optional prev) - (interactive) - (let ((field (overlay-get snippet--field-overlay 'snippet--field))) - (cond (prev - (if (snippet--field-prev-field field) - (snippet--move-to-field (snippet--field-prev-field field)) - (goto-char (snippet--field-start field)) - (snippet-exit-snippet))) - (t - (if (snippet--field-next-field field) - (snippet--move-to-field (snippet--field-next-field field)) - (goto-char (snippet--field-end field)) - (snippet-exit-snippet)))))) - -(defun snippet-prev-field () - (interactive) - (snippet-next-field t)) - -(defun snippet-exit-snippet (&optional reason) - (delete-overlay snippet--field-overlay) - (message "snippet exited%s" - (or (and reason - (format " (%s)" reason)) - ""))) - -(defun snippet--make-marker () - (let ((marker (make-marker))) - (set-marker-insertion-type marker t) - (set-marker marker (point)))) - -(defun snippet--object-start-marker (field-or-mirror) - (cond ((snippet--field-p field-or-mirror) - (snippet--field-start field-or-mirror)) - ((snippet--mirror-p field-or-mirror) - (snippet--mirror-start field-or-mirror)))) - -(defun snippet--object-end-marker (field-or-mirror) - (cond ((snippet--field-p field-or-mirror) - (snippet--field-end field-or-mirror)) - ((snippet--mirror-p field-or-mirror) - (snippet--mirror-end field-or-mirror)))) - -(defun snippet--open-markers (start end) - (set-marker-insertion-type start nil) - (set-marker-insertion-type end t)) - -(defun snippet--close-markers (start end) - (cond ((= start end) - (set-marker-insertion-type start t) - (set-marker-insertion-type end t)) - (t - (set-marker-insertion-type start t) - (set-marker-insertion-type end nil)))) - -(defun snippet--call-with-current-object (object fn) - (let* ((start (snippet--object-start-marker object)) - (end (snippet--object-end-marker object))) - (unwind-protect - (progn - (snippet--open-markers start end) - (funcall fn)) - (snippet--close-markers start end)))) - -(defmacro snippet--with-current-object (object &rest body) - (declare (indent defun) (debug t)) - `(snippet--call-with-current-object ,object #'(lambda () ,@body))) - - -(defun snippet--insert-field (field text) - (when text - (snippet--with-current-object field - (insert text)))) - -(defun snippet--insert-mirror (mirror) - (snippet--update-mirror mirror)) - -(defun snippet--update-mirror (mirror) - (snippet--with-current-object mirror - (delete-region (snippet--object-start-marker mirror) - (snippet--object-end-marker mirror)) - (save-excursion - (goto-char (snippet--object-start-marker mirror)) - (insert (funcall (snippet--mirror-transform mirror)))))) - -(defun snippet--move-to-field (field) - (goto-char (snippet--object-start-marker field)) - (move-overlay snippet--field-overlay - (point) - (snippet--object-end-marker field)) - (overlay-put snippet--field-overlay 'snippet--field field)) - -(defun snippet--field-overlay-changed (overlay after? _beg _end &optional _length) - (let* ((field (overlay-get overlay 'snippet--field)) - (inhibit-modification-hooks t)) - (cond (after? - (snippet--close-markers (snippet--field-start field) (snippet--field-end field)) - (mapc #'snippet--update-mirror (snippet--field-mirrors field)) - (move-overlay overlay (snippet--field-start field) (snippet--field-end field))) - (t - (snippet--open-markers (snippet--field-start field) (snippet--field-end field)))))) - -(defun snippet--field-text (field) - (buffer-substring-no-properties (snippet--field-start field) - (snippet--field-end field))) - -(defvar snippet--debug nil) -;; (setq snippet--debug t) - -(defun snippet--post-command-hook () - (cond ((and snippet--field-overlay - (overlay-buffer snippet--field-overlay)) - (cond ((or (< (point) - (overlay-start snippet--field-overlay)) - (> (point) - (overlay-end snippet--field-overlay))) - (snippet-exit-snippet "point left snippet") - (remove-hook 'post-command-hook 'snippet--post-command-hook t)) - (snippet--debug - (snippet--debug-snippet snippet--field-overlay)))) - (snippet--field-overlay - ;; snippet must have been exited for some other reason - ;; - (remove-hook 'post-command-hook 'snippet--post-command-hook t)))) - -(defun snippet--debug-snippet (field-overlay) - (let ((buffer (current-buffer))) - (cl-flet ((describe-field - (field) - (with-current-buffer buffer - (format "active field overlay %s from %s to %s covering \"%s\", with %s mirrors" - (snippet--field-name field) - (marker-position (snippet--field-start field)) - (marker-position (snippet--field-end field)) - (buffer-substring-no-properties (snippet--field-start field) - (snippet--field-end field)) - (length (snippet--field-mirrors field))))) - (describe-mirror - (mirror) - (with-current-buffer buffer - (format " mirror from %s to %s covering \"%s\"" - (marker-position (snippet--mirror-start mirror)) - (marker-position (snippet--mirror-end mirror)) - (buffer-substring-no-properties (snippet--mirror-start mirror) - (snippet--mirror-end mirror)))))) - (with-current-buffer (get-buffer-create "*snippet-debug*") - (let ((inhibit-read-only t)) - (erase-buffer) - (let ((active-field (overlay-get field-overlay 'snippet--field))) - (loop for object in (overlay-get field-overlay 'snippet--objects) - when (snippet--field-p object) - do - (insert (describe-field object)) - (when (eq object active-field) (insert "*ACTIVE*")) - (insert "\n") - (loop for mirror in (snippet--field-mirrors object) - do (insert (describe-mirror mirror) - "\n"))))) - (display-buffer (current-buffer)))))) - - ;;; the define-snippet macro and its helpers ;;; @@ -495,42 +286,214 @@ can be: (funcall insert-snippet-fn))))) -;;; some basic test snippets -(define-snippet printf () - "printf (\"" - (field 1 "%s") - (mirror 1 (if (string-match "%" field-text) "\"," "\);")) - (field 2) - (mirror 1 (if (string-match "%" field-text) "\);" ""))) +;;; Snippet mechanics +;;; +(cl-defstruct (snippet--field (:constructor snippet--make-field ())) + name + start end + parent-field + (mirrors '()) + next-field + prev-field) -(define-snippet foo () - (field 1 "bla") - "ble" - (mirror 1) - (field 2 - ((field 3 "fonix") - "fotrix" - (mirror 1 (concat field-text "qqcoisa")))) - "end") +(defun snippet--init-field (object name start end parent-field mirrors next-field prev-field) + (setf (snippet--field-name object) name + (snippet--field-start object) start + (snippet--field-end object) end + (snippet--field-parent-field object) parent-field + (snippet--field-mirrors object) mirrors + (snippet--field-next-field object) next-field + (snippet--field-prev-field object) prev-field)) -(define-snippet easy () - "A " - (field 1 "field") - " and its mirror: " - (mirror 1 (format "(mirror of %s)" field-text))) +(cl-defstruct (snippet--mirror (:constructor snippet--make-mirror ())) + source + start end + (transform nil) + parent-field) -(defun test () +(defun snippet--init-mirror (object source start end transform parent-field) + (setf (snippet--mirror-source object) source + (snippet--mirror-start object) start + (snippet--mirror-end object) end + (snippet--mirror-transform object) transform + (snippet--mirror-parent-field object) parent-field)) + +(defgroup snippet nil + "Customize snippet features" + :group 'convenience) + +(defface snippet-field-face + '((t (:inherit 'region))) + "Face used to highlight the currently active field of a snippet" + :group 'snippet) + +(defvar snippet-field-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") 'snippet-next-field) + (define-key map (kbd "S-") 'snippet-prev-field) + map) + "The active keymap while a snippet expansion is in progress.") + +(defvar snippet--field-overlay nil) + +(defun snippet-next-field (&optional prev) (interactive) - (with-current-buffer (switch-to-buffer (get-buffer-create "*test easy snippet*")) - (erase-buffer) - (easy))) + (let ((field (overlay-get snippet--field-overlay 'snippet--field))) + (cond (prev + (if (snippet--field-prev-field field) + (snippet--move-to-field (snippet--field-prev-field field)) + (goto-char (snippet--field-start field)) + (snippet-exit-snippet))) + (t + (if (snippet--field-next-field field) + (snippet--move-to-field (snippet--field-next-field field)) + (goto-char (snippet--field-end field)) + (snippet-exit-snippet)))))) -(defun test2 () +(defun snippet-prev-field () (interactive) - (with-current-buffer (switch-to-buffer (get-buffer-create "*test printf snippet*")) - (erase-buffer) - (printf))) + (snippet-next-field t)) +(defun snippet-exit-snippet (&optional reason) + (delete-overlay snippet--field-overlay) + (message "snippet exited%s" + (or (and reason + (format " (%s)" reason)) + ""))) + +(defun snippet--make-marker () + (let ((marker (make-marker))) + (set-marker-insertion-type marker t) + (set-marker marker (point)))) + +(defun snippet--object-start-marker (field-or-mirror) + (cond ((snippet--field-p field-or-mirror) + (snippet--field-start field-or-mirror)) + ((snippet--mirror-p field-or-mirror) + (snippet--mirror-start field-or-mirror)))) + +(defun snippet--object-end-marker (field-or-mirror) + (cond ((snippet--field-p field-or-mirror) + (snippet--field-end field-or-mirror)) + ((snippet--mirror-p field-or-mirror) + (snippet--mirror-end field-or-mirror)))) + +(defun snippet--open-markers (start end) + (set-marker-insertion-type start nil) + (set-marker-insertion-type end t)) + +(defun snippet--close-markers (start end) + (cond ((= start end) + (set-marker-insertion-type start t) + (set-marker-insertion-type end t)) + (t + (set-marker-insertion-type start t) + (set-marker-insertion-type end nil)))) + +(defun snippet--call-with-current-object (object fn) + (let* ((start (snippet--object-start-marker object)) + (end (snippet--object-end-marker object))) + (unwind-protect + (progn + (snippet--open-markers start end) + (funcall fn)) + (snippet--close-markers start end)))) + +(defmacro snippet--with-current-object (object &rest body) + (declare (indent defun) (debug t)) + `(snippet--call-with-current-object ,object #'(lambda () ,@body))) + + +(defun snippet--insert-field (field text) + (when text + (snippet--with-current-object field + (insert text)))) + +(defun snippet--insert-mirror (mirror) + (snippet--update-mirror mirror)) + +(defun snippet--update-mirror (mirror) + (snippet--with-current-object mirror + (delete-region (snippet--object-start-marker mirror) + (snippet--object-end-marker mirror)) + (save-excursion + (goto-char (snippet--object-start-marker mirror)) + (insert (funcall (snippet--mirror-transform mirror)))))) + +(defun snippet--move-to-field (field) + (goto-char (snippet--object-start-marker field)) + (move-overlay snippet--field-overlay + (point) + (snippet--object-end-marker field)) + (overlay-put snippet--field-overlay 'snippet--field field)) + +(defun snippet--field-overlay-changed (overlay after? _beg _end &optional _length) + (let* ((field (overlay-get overlay 'snippet--field)) + (inhibit-modification-hooks t)) + (cond (after? + (snippet--close-markers (snippet--field-start field) (snippet--field-end field)) + (mapc #'snippet--update-mirror (snippet--field-mirrors field)) + (move-overlay overlay (snippet--field-start field) (snippet--field-end field))) + (t + (snippet--open-markers (snippet--field-start field) (snippet--field-end field)))))) + +(defun snippet--field-text (field) + (buffer-substring-no-properties (snippet--field-start field) + (snippet--field-end field))) + +(defvar snippet--debug nil) +;; (setq snippet--debug t) + +(defun snippet--post-command-hook () + (cond ((and snippet--field-overlay + (overlay-buffer snippet--field-overlay)) + (cond ((or (< (point) + (overlay-start snippet--field-overlay)) + (> (point) + (overlay-end snippet--field-overlay))) + (snippet-exit-snippet "point left snippet") + (remove-hook 'post-command-hook 'snippet--post-command-hook t)) + (snippet--debug + (snippet--debug-snippet snippet--field-overlay)))) + (snippet--field-overlay + ;; snippet must have been exited for some other reason + ;; + (remove-hook 'post-command-hook 'snippet--post-command-hook t)))) + +(defun snippet--debug-snippet (field-overlay) + (let ((buffer (current-buffer))) + (cl-flet ((describe-field + (field) + (with-current-buffer buffer + (format "active field overlay %s from %s to %s covering \"%s\", with %s mirrors" + (snippet--field-name field) + (marker-position (snippet--field-start field)) + (marker-position (snippet--field-end field)) + (buffer-substring-no-properties (snippet--field-start field) + (snippet--field-end field)) + (length (snippet--field-mirrors field))))) + (describe-mirror + (mirror) + (with-current-buffer buffer + (format " mirror from %s to %s covering \"%s\"" + (marker-position (snippet--mirror-start mirror)) + (marker-position (snippet--mirror-end mirror)) + (buffer-substring-no-properties (snippet--mirror-start mirror) + (snippet--mirror-end mirror)))))) + (with-current-buffer (get-buffer-create "*snippet-debug*") + (let ((inhibit-read-only t)) + (erase-buffer) + (let ((active-field (overlay-get field-overlay 'snippet--field))) + (loop for object in (overlay-get field-overlay 'snippet--objects) + when (snippet--field-p object) + do + (insert (describe-field object)) + (when (eq object active-field) (insert "*ACTIVE*")) + (insert "\n") + (loop for mirror in (snippet--field-mirrors object) + do (insert (describe-mirror mirror) + "\n"))))) + (display-buffer (current-buffer)))))) (provide 'snippet)