1 ;;; company-template.el
3 ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
5 ;; Author: Nikolaj Schumacher
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 (eval-when-compile (require 'cl))
26 (defface company-template-field
27 '((((background dark)) (:background "yellow" :foreground "black"))
28 (((background light)) (:background "orange" :foreground "black")))
29 "Face used for editable text in template fields."
32 (defvar company-template-nav-map
33 (let ((keymap (make-sparse-keymap)))
34 (define-key keymap [tab] 'company-template-forward-field)
37 ;; interactive ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 (defun company-template-templates-at (pos)
41 (dolist (o (overlays-at pos))
42 (when (overlay-get o 'company-template-fields)
46 (defun company-template-move-to-first (templ)
48 (let ((fields (overlay-get templ 'company-template-fields)))
50 (goto-char (apply 'min (mapcar 'overlay-start fields)))))
52 (defun company-template-forward-field ()
54 (let* ((start (point))
55 (templates (company-template-templates-at (point)))
56 (minimum (apply 'max (mapcar 'overlay-end templates)))
57 (fields (loop for templ in templates
58 append (overlay-get templ 'company-template-fields))))
59 (dolist (pos (mapcar 'overlay-start fields))
66 (let ((field (loop for ovl in (overlays-at start)
67 when (overlay-get ovl 'company-template-parent)
69 (company-template-remove-field field))))
71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
73 (defvar company-template--buffer-templates nil)
74 (make-variable-buffer-local 'company-template--buffer-templates)
76 (defun company-template-declare-template (beg end)
77 (let ((ov (make-overlay beg end)))
78 ;; (overlay-put ov 'face 'highlight)
79 (overlay-put ov 'keymap company-template-nav-map)
80 (overlay-put ov 'priority 101)
81 (overlay-put ov 'evaporate t)
82 (push ov company-template--buffer-templates)
83 (add-hook 'post-command-hook 'company-template-post-command nil t)
86 (defun company-template-remove-template (templ)
87 (mapc 'company-template-remove-field
88 (overlay-get templ 'company-template-fields))
89 (setq company-template--buffer-templates
90 (delq templ company-template--buffer-templates))
91 (delete-overlay templ))
93 (defun company-template-add-field (templ pos text)
99 (when (> (point) (overlay-end templ))
100 (move-overlay templ (overlay-start templ) (point))))
101 (let ((ov (make-overlay pos (+ pos (length text))))
102 (siblings (overlay-get templ 'company-template-fields)))
103 ;; (overlay-put ov 'evaporate t)
104 (overlay-put ov 'intangible t)
105 (overlay-put ov 'face 'company-template-field)
106 (overlay-put ov 'company-template-parent templ)
107 (overlay-put ov 'insert-in-front-hooks '(company-template-insert-hook))
109 (overlay-put templ 'company-template-fields siblings))))
111 (defun company-template-remove-field (ovl &optional clear)
113 (when (overlay-buffer ovl)
115 (delete-region (overlay-start ovl) (overlay-end ovl)))
116 (delete-overlay ovl))
117 (let* ((templ (overlay-get ovl 'company-template-parent))
118 (siblings (overlay-get templ 'company-template-fields)))
119 (setq siblings (delq ovl siblings))
120 (overlay-put templ 'company-template-fields siblings))))
122 (defun company-template-clean-up (&optional pos)
123 "Clean up all templates that don't contain POS."
124 (unless pos (setq pos (point)))
125 (let ((local-ovs (overlays-in (- pos 2) pos)))
126 (dolist (templ company-template--buffer-templates)
127 (unless (and (memq templ local-ovs)
128 (overlay-get templ 'company-template-fields))
129 (company-template-remove-template templ)))))
131 ;; hooks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
133 (defun company-template-insert-hook (ovl after-p &rest ignore)
134 "Called when a snippet input prompt is modified."
136 (company-template-remove-field ovl t)))
138 (defun company-template-post-command ()
139 (company-template-clean-up)
140 (unless company-template--buffer-templates
141 (remove-hook 'post-command-hook 'company-template-post-command t)))
143 (provide 'company-template)
144 ;;; company-template.el ends here