;;; snippet.el -- insert snippets of text into a buffer

;; Copyright (c) 2005 Pete Kazmier
;; Copyright (c) 2009, 2010 Leo

;; Version: 0.27
;; Author: Pete Kazmier, Leo

;; The maximum version number is 0.618 and is used when snippet
;; reaches perfectness.

;; This file is not part of GNU Emacs, but it is distributed under
;; the same terms as GNU Emacs.

;; GNU Emacs 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, or (at your
;; option) any later version.

;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))

(defgroup snippet nil
  "Insert a template with fields that con contain optional defaults."
  :prefix "snippet-"
  :group 'abbrev
  :group 'convenience)

(defface snippet-bound-face
  '((t (:inherit bold)))
  "Face used for the body of the current snippet."
  :group 'snippet)

(defface snippet-field-face
  '((t (:inherit highlight)))
  "Face used for the fields of the current snippet."
  :group 'snippet)

(defface snippet-bound-face-inactive
  '((t (:inherit shadow)))
  "Face used for inactive snippets."
  :group 'snippet)

(defface snippet-field-face-inactive
  '((t (:inherit shadow)))
  "Face used for the fields of inactive snippet."
  :group 'snippet)

(defcustom snippet-field-identifier "$$"
  "String used to identify field placeholders."
  :type 'string
  :group 'snippet)

(defcustom snippet-exit-identifier "$."
  "String used to identify the exit point of the snippet."
  :type 'string
  :group 'snippet)

(defcustom snippet-field-default-beg-char ?{
  "Character used to identify the start of a field's default value."
  :type 'character
  :group 'snippet)

(defcustom snippet-field-default-end-char ?}
  "Character used to identify the stop of a field's default value."
  :type 'character
  :group 'snippet)

(defcustom snippet-indent "$>"
  "String used to indicate that a line is to be indented."
  :type 'string
  :group 'snippet)

(defstruct snippet
  "Structure containing the overlays used to display a snippet.

The BOUND slot contains an overlay to bound the entire text of the
template. This overlay is used to provide a different face
configurable via `snippet-bound-face' as well as the keymap that
enables tabbing between fields.

The FIELDS slot contains a list of overlays used to indicate the
position of each field. In addition, if a field has a default, the
field overlay is used to provide a different face configurable via
`snippet-field-face'.

The EXIT-MARKER slot contains a marker where point should be placed
after the user has cycled through all available fields."
  bound fields exit-marker)

(defvar snippet-stack nil
  "A stack holds existing snippets in the current buffer.")

(defvar snippet-current nil
  "Current active snippet i.e. the head of `snippet-stack'.")

(make-variable-buffer-local 'snippet-stack)
(make-variable-buffer-local 'snippet-current)

(defvar snippet-map (make-sparse-keymap)
  "Keymap used while the point is located within a snippet.")

;; Default key bindings
(define-key snippet-map (kbd "RET")             'snippet-exit-snippet)
(define-key snippet-map (kbd "TAB")             'snippet-next-field)
(define-key snippet-map (kbd "<backtab>")       'snippet-prev-field)
(define-key snippet-map (kbd "<S-tab>")         'snippet-prev-field)
(define-key snippet-map (kbd "<S-iso-lefttab>") 'snippet-prev-field)
(define-key snippet-map [remap self-insert-command] 'snippet-field-insert)
;; when snippet is not hooked into abbrev we need a key to trigger
;; nesting snippets
(define-key snippet-map (kbd "M-TAB")           'snippet-completion-at-point)

(defun snippet-field-insert (&optional arg)
  "A replacement for `self-insert-command' in `snippet-map'.
Find the field that belongs to current snippet at point. If point
is located at the start of the field, delete the region between
the field."
  (interactive "p")
  (let ((field (loop for o in (overlays-at (point))
                     when (memq o (snippet-fields snippet-current))
                     return o)))
    (when (and (overlayp field)
               (= (point) (overlay-start field)))
      (delete-region (point) (overlay-end field))))
  (self-insert-command arg))

(defun snippet-make-bound-overlay ()
  "Create an overlay to bound a snippet.
Add the appropriate properties for the overlay to provide: a face used
to display the snippet, the keymap to use while within the snippet,
and the modification hooks to clean up the overlay in the event it is
deleted."
  (let ((bound (make-overlay (point) (point) (current-buffer) nil t)))
    (overlay-put bound 'priority (1+ (length snippet-stack)))
    (overlay-put bound 'keymap snippet-map)
    (overlay-put bound 'face 'snippet-bound-face)
    (overlay-put bound 'modification-hooks '(snippet-bound-modified))
    bound))

(defun snippet-make-field-overlay (&optional name)
  "Create an overlay for a field in a snippet.
Add the appropriate properties for the overlay to provide: a face used
to display a field's default value, and modification hooks to remove
the default text if the user starts typing."
  (let ((field (make-overlay (point) (point) (current-buffer) nil t)))
    (overlay-put field 'priority (length snippet-stack))
    (overlay-put field 'face 'snippet-field-face)
    (overlay-put field 'insert-in-front-hooks '(snippet-field-update))
    (overlay-put field 'insert-behind-hooks '(snippet-field-update))
    (overlay-put field 'modification-hooks '(snippet-field-update))
    (overlay-put field 'name (when name (make-symbol name)))
    field))

(defun snippet-decorate (snippet how)
  "Decorate SNIPPET in a way specified by HOW."
  (let ((bound (snippet-bound snippet))
        (fields (snippet-fields snippet)))
    (overlay-put bound 'face
                 (if (memq how '(t active))
                     'snippet-bound-face
                   'snippet-bound-face-inactive))
    (dolist (field fields)
      (overlay-put field 'face (if (memq how '(t active))
                                   'snippet-field-face
                                 'snippet-field-face-inactive)))))

(defun snippet-fields-with-name (name)
  "Return a list of fields whose name property is equal to NAME."
  (loop for field in (snippet-fields snippet-current)
        when (string= name (symbol-name (overlay-get field 'name)))
        collect field))

(defun snippet-bound-modified (bound after beg end &optional change)
  "Ensure the overlay that bounds a snippet is cleaned up.
This modification hook is triggered when the overlay that bounds the
snippet is modified. It runs after the change has been made and
ensures that if the snippet has been deleted by the user, the
appropriate cleanup occurs."
  (when (and after (= (overlay-start bound) (overlay-end bound)))
    (snippet-cleanup)))

(defun snippet-field-update (field after beg end &optional change)
  "Update all fields that have the same name.
This modification hook is triggered when a user edits any field and is
responsible for updating all other fields that share a common name."
  (when (and after (= (overlay-get field 'priority) (length snippet-stack)))
    (let ((name (overlay-get field 'name))
          (value (buffer-substring (overlay-start field) (overlay-end field)))
          (inhibit-modification-hooks t))
      (when name
        (setq name (symbol-name name))
        (save-excursion
          (dolist (like-field (remq field (snippet-fields-with-name name)))
            (goto-char (overlay-start like-field))
            (delete-region (overlay-start like-field)
                           (overlay-end like-field))
            (insert value)))))))

(defun snippet-exit-snippet ()
  "Move point to `snippet-exit-identifier' or end of bound.
If the snippet has defined `snippet-exit-identifier' in the template,
move the point to that location. Otherwise, move it to the end of the
snippet."
  (interactive)
  (goto-char (snippet-exit-marker snippet-current))
  (snippet-cleanup))

(defun snippet-next-field ()
  "Move point forward to the next field in the `snippet'.
If there are no more fields in the snippet, point is moved to the end
of the snippet or the location specified by `snippet-exit-identifier',
and the snippet reverts to normal text."
  (interactive)
  (let* ((bound (snippet-bound snippet-current))
         (fields (snippet-fields snippet-current))
         (exit (snippet-exit-marker snippet-current))
         (next-pos (loop for field in fields
                         for start = (overlay-start field)
                         when (< (point) start) return start)))
    (if (not (null next-pos))
        (goto-char next-pos)
      (goto-char exit)
      (snippet-cleanup))))

(defun snippet-prev-field ()
  "Move point backward to the previous field in the `snippet'.
If there are no more fields in the snippet, point is moved to the end
of the snippet or the location specified by `snippet-exit-identifier',
and the snippet reverts to normal text."
  (interactive)
  (let* ((bound (snippet-bound snippet-current))
         (fields (snippet-fields snippet-current))
         (exit (snippet-exit-marker snippet-current))
         (prev-pos (loop for field in (reverse fields)
                         for start = (overlay-start field)
                         when (> (point) start) return start)))
    (if (not (null prev-pos))
        (goto-char prev-pos)
      (goto-char exit)
      (snippet-cleanup))))

(defun snippet-cleanup ()
  "Delete all overlays associated with `snippet'.
This effectively reverts the snippet to normal text in the buffer."
  (when (snippet-p snippet-current)
    (delete-overlay (snippet-bound snippet-current))
    (dolist (field (snippet-fields snippet-current))
      (delete-overlay field))
    ;; make marker point nowhere (info "(elisp)Overview of Markers")
    (set-marker (snippet-exit-marker snippet-current) nil)
    (pop snippet-stack)
    (setq snippet-current (car snippet-stack))
    (when (snippet-p snippet-current)
      (message "Snippet %d" (length snippet-stack))
      (snippet-decorate snippet-current 'active))))

(defun snippet-field-regexp ()
  "Return a regexp that is used to search for fields within a template."
  (let ((beg (char-to-string snippet-field-default-beg-char))
        (end (char-to-string snippet-field-default-end-char)))
    (concat (regexp-quote snippet-field-identifier)
            "\\("
            (regexp-quote beg)
            "\\([^"
            (regexp-quote end)
            "]+\\)"
            (regexp-quote end)
            "\\)?")))

(defun snippet-region (beg end)
  (let ((inhibit-modification-hooks t))
    (when (snippet-p snippet-current)
      (snippet-decorate snippet-current 'inactive))
    (push (make-snippet :bound (snippet-make-bound-overlay)) snippet-stack)
    (setq snippet-current (car snippet-stack))
    (move-overlay (snippet-bound snippet-current) beg end)
    (save-restriction
      (narrow-to-region beg end)
      ;; process exit marker
      (goto-char (point-min))
      (while (re-search-forward (regexp-quote snippet-exit-identifier) nil t)
        (replace-match "")
        (unless (markerp (snippet-exit-marker snippet-current))
          (setf (snippet-exit-marker snippet-current) (point-marker))))

      (unless (markerp (snippet-exit-marker snippet-current))
        (setf (snippet-exit-marker snippet-current) (copy-marker (point-max))))

      (set-marker-insertion-type (snippet-exit-marker snippet-current) t)

      ;; process fields
      (goto-char (point-min))
      (while (re-search-forward (snippet-field-regexp) nil t)
        (let ((field (snippet-make-field-overlay (match-string 2)))
              (start (match-beginning 0)))
          (push field (snippet-fields snippet-current))
          (replace-match (if (match-beginning 2) "\\2" ""))
          (move-overlay field start (point))))

      ;; These are reversed so they are in the order appeared in the
      ;; template as we index into this list when cycling field to
      ;; field.
      (setf (snippet-fields snippet-current) (reverse (snippet-fields snippet-current)))

      ;; done at the final step of the processing since snippet
      ;; identifiers may confuse the major mode about indentation.
      (goto-char (point-min))
      (while (re-search-forward (regexp-quote snippet-indent) nil t)
        (replace-match "")
        (indent-according-to-mode)))

    ;; positioning
    (let ((first (car (snippet-fields snippet-current))))
      (if first
          (goto-char (overlay-start first))
        (snippet-exit-snippet)))
    ;; support undo: exit snippet processing when undo
    (push '(apply (lambda ()
                    (when (snippet-p snippet-current)
                      (snippet-exit-snippet)))) buffer-undo-list)
    (when (snippet-p snippet-current)
      (message "Snippet %d" (length snippet-stack)))))

;;;###autoload
(defun snippet-insert (template)
  "Insert a snippet into the current buffer at point.
TEMPLATE is a string that may optionally contain fields which are
specified by `snippet-field-identifier'. Fields may optionally also
include default values delimited by `snippet-field-default-beg-char'
and `snippet-field-default-end-char'.

For example, the following template specifies two fields which have
the default values of \"element\" and \"sequence\":

  \"for $${element} in $${sequence}:\"

In the next example, only one field is specified and no default has
been provided:

  \"import $$\"

This function may be called interactively, in which case, the TEMPLATE
is prompted for. However, users do not typically invoke this function
interactively, rather it is most often called as part of an expansion."
  (interactive "sSnippet template: ")
  (let ((beg (point)))
    (insert template)
    (snippet-region beg (point))))

;;;###autoload
(defun snippet-insert-file (file &optional no-guess)
  "Insert FILE in current buffer and process it as a snippet.
NO-GUESS means do not guess major mode for FILE."
  (interactive "fInsert file: ")
  (insert-file-contents file)
  (unless no-guess
    (let ((buffer-file-name file))
      (set-auto-mode t)))
  (snippet-region (point-min) (point-max))
  (hack-local-variables))

;;;; -------- abbrev integration --------
;; c.f. http://permalink.gmane.org/gmane.emacs.help/62887
(put 'snippet-expand-abbrev 'no-self-insert t)
(defun snippet-expand-abbrev (expander)
  "Call EXPANDER and process the expansion as snippet.
A function intended to be used in `abbrev-expand-functions'."
  (when (funcall expander)
    (let ((posn (point))
          (result last-abbrev))
      (snippet-region last-abbrev-location (point))
      (when (/= posn (point))           ; point has moved
        ;; use uninterned symbol to avoid modifying the abbrev
        (setq result (make-symbol "snippet-expand"))
        ;; return a symbol whose symbol-function has a non-nil
        ;; `no-self-insert' property
        (fset result 'snippet-expand-abbrev))
      result)))

;;;###autoload
(define-minor-mode snippet-abbrev-mode
  "Toggle Snippet-Abbrev mode in current buffer.
With optional argument ARG, turn Snippet-Abbrev mode on if ARG is
positive, otherwise turn it off. In Snippet-Abbrev mode, abbrev
expansion will be treated as a snippet insertion."
  :lighter ""
  (if snippet-abbrev-mode
      (add-hook 'abbrev-expand-functions 'snippet-expand-abbrev nil 'local)
    (remove-hook 'abbrev-expand-functions 'snippet-expand-abbrev 'local)))

;;;###autoload
(define-globalized-minor-mode global-snippet-abbrev-mode snippet-abbrev-mode
  (lambda () (snippet-abbrev-mode t)))
;;;; -------- abbrev integration end --------

(defcustom snippet-default-regexp "\\(\\s_\\|\\sw\\)+"
  "Default regexp used to find the snippet at point. If it is
nil, word at point is used."
  :type 'regexp
  :group 'snippet)

;;;###autoload
(defun define-snippets (snippets &optional enable-function snippet-regexp)
  "Define snippets.
Each entry in SNIPPETS has the form:
   (NAME EXPANSION &optional HOOK &rest PROPS)
See `define-abbrev' for explanation on each item.

ENABLE-FUNCTION is a function with no arguments that will be the
default value of the abbrev property :enable-function.
SNIPPET-REGEXP defaults to the value of `snippet-default-regexp'
and is used to find snippet at point."
  (let (abbrevs-changed)
    (abbrev-table-put local-abbrev-table
                      :snippet-regexp (or snippet-regexp snippet-default-regexp))
    (mapc
     (lambda (snippet)
       (let* ((name (apply 'define-abbrev local-abbrev-table snippet))
              (symbol (abbrev-symbol name local-abbrev-table)))
         (when symbol
           (abbrev-put symbol :system t)
           (and enable-function
                (unless (abbrev-get symbol :enable-function)
                  (abbrev-put symbol :enable-function enable-function))))))
     snippets)))

(defun snippet-completion-at-point ()
  ;; check `abbrev--before-point' also
  (interactive)
  (let ((tables (abbrev--active-tables))
        (abbrevs (make-vector 59 0))
        start end res regexp comp all)
    (if abbrev-start-location           ; for `abbrev-prefix-mark'
        (setq start (1+ abbrev-start-location)
              end (point))
      (setq regexp (abbrev-table-get local-abbrev-table :snippet-regexp))
      (if (null regexp)
          (progn (backward-word 1)
                 (setq start (point))
                 (forward-word 1)
                 (setq end (point)))
        (while (looking-at regexp)
          (forward-char 1))
        (when (looking-back regexp (line-beginning-position) t)
          (setq start (match-beginning 0)
                end (match-end 0)))))
    (when (and start end)
      ;; the parent tables are appended which is in different order as
      ;; that of `abbrev--before-point'. This should not be a problem
      ;; since we only need the symbols for completion.
      (loop for table in tables
            for parents = (abbrev-table-get table :parents)
            when parents
            collect parents into parent-tables
            finally (setq tables (append parent-tables tables)))
      (loop for table in tables
            for enable-function = (abbrev-table-get table :enable-function)
            do (when (or (null enable-function) (funcall enable-function))
                 (mapatoms (lambda (abbrev)
                             (let ((enable-fun (abbrev-get abbrev :enable-function)))
                               (when (or (null enable-fun) (funcall enable-fun))
                                 (intern (symbol-name abbrev) abbrevs))))
                           table)))
      (let (completion-in-region-functions (minibuffer-message-timeout 0))
        (setq res (completion-in-region start end abbrevs)
              comp (buffer-substring start (point))))
      ;; returning a function is discouraged; see doc string of
      ;; `completion-at-point-functions'; we use this to avoid using
      ;; `completion-in-region-functions'.
      (when res (setq res 'ignore))
      (when (and res (intern-soft comp abbrevs))
        ;; if not unique show other snippets
        (setq all (all-completions comp abbrevs))
        (unless (eq (length all) 1)
          (message "Other snippet(s): %s" (mapconcat 'identity (delete comp all) " ")))
        (push (cons comp (- start)) buffer-undo-list)
        (let ((buffer-undo-list t))
          ;; make sure expand-abbrev finds the same symbol as the completion
          (save-excursion (goto-char start) (abbrev-prefix-mark t))
          (let (abbrev-expand-functions) (expand-abbrev)))
        (push (cons start (point)) buffer-undo-list)
        (snippet-region start (point))))
    res))

;;;###autoload
(define-minor-mode snippet-mode
  "A minor mode for snippet.
When this mode is on, completion is done through
`completion-at-point' which is normally bound to M-TAB. TAB
completion can be conveniently enabled through variable
`tab-always-indent'.

When you are processing a snippet, the following key bindings are
available:

\\{snippet-map}"
  :lighter " Snip"
  (if snippet-mode
      (add-hook 'completion-at-point-functions 'snippet-completion-at-point nil 'local)
    (remove-hook 'completion-at-point-functions 'snippet-completion-at-point 'local)))

(provide 'snippet)