-;;; company-template.el
+;;; company-template.el --- utility library for template expansion
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2014-2016 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
;;; Code:
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(defface company-template-field
'((((background dark)) (:background "yellow" :foreground "black"))
(defvar company-template-nav-map
(let ((keymap (make-sparse-keymap)))
- (define-key keymap [remap forward-word] 'company-template-forward-field)
- (define-key keymap [remap subword-forward] 'company-template-forward-field)
- ;; M-n
+ (define-key keymap [tab] 'company-template-forward-field)
+ (define-key keymap (kbd "TAB") 'company-template-forward-field)
keymap))
+(defvar-local company-template--buffer-templates nil)
+
;; interactive ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defsubst company-template-templates-at (pos)
+(defun company-template-templates-at (pos)
(let (os)
(dolist (o (overlays-at pos))
- (when (overlay-get o 'company-template-fields)
+ ;; FIXME: Always return the whole list of templates?
+ ;; We remove templates not at point after every command.
+ (when (memq o company-template--buffer-templates)
(push o os)))
os))
(defun company-template-move-to-first (templ)
(interactive)
- (let ((fields (overlay-get templ 'company-template-fields)))
- (push-mark)
- (goto-char (apply 'min (mapcar 'overlay-start fields)))))
+ (goto-char (overlay-start templ))
+ (company-template-forward-field))
(defun company-template-forward-field ()
(interactive)
- (let* ((templates (company-template-templates-at (point)))
+ (let* ((start (point))
+ (templates (company-template-templates-at (point)))
(minimum (apply 'max (mapcar 'overlay-end templates)))
- (fields (apply 'append
- (mapcar (lambda (templ)
- (overlay-get templ 'company-template-fields))
- templates))))
+ (fields (cl-loop for templ in templates
+ append (overlay-get templ 'company-template-fields))))
(dolist (pos (mapcar 'overlay-start fields))
(and pos
(> pos (point))
(< pos minimum)
(setq minimum pos)))
(push-mark)
- (goto-char minimum)))
+ (goto-char minimum)
+ (company-template-remove-field (company-template-field-at start))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun company-template-field-at (&optional point)
+ (cl-loop for ovl in (overlays-at (or point (point)))
+ when (overlay-get ovl 'company-template-parent)
+ return ovl))
-(defvar company-template--buffer-templates nil)
-(make-variable-buffer-local 'company-template--buffer-templates)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun company-template-declare-template (beg end)
(let ((ov (make-overlay beg end)))
;; (overlay-put ov 'face 'highlight)
(overlay-put ov 'keymap company-template-nav-map)
+ (overlay-put ov 'priority 101)
(overlay-put ov 'evaporate t)
(push ov company-template--buffer-templates)
(add-hook 'post-command-hook 'company-template-post-command nil t)
(delq templ company-template--buffer-templates))
(delete-overlay templ))
-(defun company-template-add-field (templ pos text)
- (assert templ)
- (save-excursion
- ;; (goto-char pos)
- (let ((ov (make-overlay pos pos))
- (siblings (overlay-get templ 'company-template-fields))
- (label (propertize text 'face 'company-template-field
- 'company-template-parent templ)))
- (overlay-put ov 'face 'highlight)
- (add-text-properties 0 1 '(cursor t) label)
- (overlay-put ov 'after-string label)
- ;; (overlay-put ov 'evaporate t)
- (overlay-put ov 'intangible t)
- (overlay-put ov 'company-template-parent templ)
- (overlay-put ov 'insert-in-front-hooks '(company-template-remove))
- (push ov siblings)
+(defun company-template-add-field (templ beg end &optional display)
+ "Add new field to template TEMPL spanning from BEG to END.
+When DISPLAY is non-nil, set the respective property on the overlay.
+Leave point at the end of the field."
+ (cl-assert templ)
+ (when (> end (overlay-end templ))
+ (move-overlay templ (overlay-start templ) end))
+ (let ((ov (make-overlay beg end))
+ (siblings (overlay-get templ 'company-template-fields)))
+ ;; (overlay-put ov 'evaporate t)
+ (overlay-put ov 'intangible t)
+ (overlay-put ov 'face 'company-template-field)
+ (when display
+ (overlay-put ov 'display display))
+ (overlay-put ov 'company-template-parent templ)
+ (overlay-put ov 'insert-in-front-hooks '(company-template-insert-hook))
+ (push ov siblings)
+ (overlay-put templ 'company-template-fields siblings)))
+
+(defun company-template-remove-field (ovl &optional clear)
+ (when (overlayp ovl)
+ (when (overlay-buffer ovl)
+ (when clear
+ (delete-region (overlay-start ovl) (overlay-end ovl)))
+ (delete-overlay ovl))
+ (let* ((templ (overlay-get ovl 'company-template-parent))
+ (siblings (overlay-get templ 'company-template-fields)))
+ (setq siblings (delq ovl siblings))
(overlay-put templ 'company-template-fields siblings))))
-(defun company-template-remove-field (field)
- (when (overlayp field)
- ;; (delete-region (overlay-start field) (overlay-end field))
- (delete-overlay field))
- ;; TODO: unlink
- )
-
(defun company-template-clean-up (&optional pos)
"Clean up all templates that don't contain POS."
- (unless pos (setq pos (point)))
- (let ((local-ovs (overlays-in (- pos 2) pos)))
+ (let ((local-ovs (overlays-at (or pos (point)))))
(dolist (templ company-template--buffer-templates)
(unless (memq templ local-ovs)
(company-template-remove-template templ)))))
;; hooks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun company-template-remove (overlay after-p beg end &optional r)
+(defun company-template-insert-hook (ovl after-p &rest _ignore)
"Called when a snippet input prompt is modified."
- (when after-p
- (delete-overlay overlay)))
+ (unless after-p
+ (company-template-remove-field ovl t)))
(defun company-template-post-command ()
(company-template-clean-up)
(unless company-template--buffer-templates
(remove-hook 'post-command-hook 'company-template-post-command t)))
+;; common ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun company-template-c-like-templatify (call)
+ (let* ((end (point-marker))
+ (beg (- (point) (length call)))
+ (templ (company-template-declare-template beg end))
+ paren-open paren-close)
+ (with-syntax-table (make-syntax-table (syntax-table))
+ (modify-syntax-entry ?< "(")
+ (modify-syntax-entry ?> ")")
+ (when (search-backward ")" beg t)
+ (setq paren-close (point-marker))
+ (forward-char 1)
+ (delete-region (point) end)
+ (backward-sexp)
+ (forward-char 1)
+ (setq paren-open (point-marker)))
+ (when (search-backward ">" beg t)
+ (let ((angle-close (point-marker)))
+ (forward-char 1)
+ (backward-sexp)
+ (forward-char)
+ (company-template--c-like-args templ angle-close)))
+ (when (looking-back "\\((\\*)\\)(" (line-beginning-position))
+ (delete-region (match-beginning 1) (match-end 1)))
+ (when paren-open
+ (goto-char paren-open)
+ (company-template--c-like-args templ paren-close)))
+ (if (overlay-get templ 'company-template-fields)
+ (company-template-move-to-first templ)
+ (company-template-remove-template templ)
+ (goto-char end))))
+
+(defun company-template--c-like-args (templ end)
+ (let ((last-pos (point)))
+ (while (re-search-forward "\\([^,]+\\),?" end 'move)
+ (when (zerop (car (parse-partial-sexp last-pos (point))))
+ (company-template-add-field templ last-pos (match-end 1))
+ (skip-chars-forward " ")
+ (setq last-pos (point))))))
+
+;; objc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun company-template-objc-templatify (selector)
+ (let* ((end (point-marker))
+ (beg (- (point) (length selector) 1))
+ (templ (company-template-declare-template beg end))
+ (cnt 0))
+ (save-excursion
+ (goto-char beg)
+ (catch 'stop
+ (while (search-forward ":" end t)
+ (if (looking-at "\\(([^)]*)\\) ?")
+ (company-template-add-field templ (point) (match-end 1))
+ ;; Not sure which conditions this case manifests under, but
+ ;; apparently it did before, when I wrote the first test for this
+ ;; function. FIXME: Revisit it.
+ (company-template-add-field templ (point)
+ (progn
+ (insert (format "arg%d" cnt))
+ (point)))
+ (when (< (point) end)
+ (insert " "))
+ (cl-incf cnt))
+ (when (>= (point) end)
+ (throw 'stop t)))))
+ (company-template-move-to-first templ)))
+
(provide 'company-template)
;;; company-template.el ends here