X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/da0d153e1520b5af5d008412187bbcb1d686de48..2d44e7fef7e7388759518cba1a424495119679d1:/packages/company/company-template.el diff --git a/packages/company/company-template.el b/packages/company/company-template.el index 4a57ef001..576b246ec 100644 --- a/packages/company/company-template.el +++ b/packages/company/company-template.el @@ -1,6 +1,6 @@ ;;; company-template.el -;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc. ;; Author: Nikolaj Schumacher @@ -21,61 +21,66 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (defface company-template-field '((((background dark)) (:background "yellow" :foreground "black")) (((background light)) (:background "orange" :foreground "black"))) - "*Face used for editable text in template fields." + "Face used for editable text in template fields." :group 'company) (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) @@ -88,51 +93,78 @@ (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 pos text &optional display) + "Add new field to template TEMPL at POS, inserting TEXT. +When DISPLAY is non-nil, set the respective property on the overlay. +Leave point at the end of the field." + (cl-assert templ) + (goto-char pos) + (insert text) + (when (> (point) (overlay-end templ)) + (move-overlay templ (overlay-start templ) (point))) + (let ((ov (make-overlay pos (+ pos (length text)))) + (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))) -(provide 'company-template) +;; common ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun company-template-c-like-templatify (call) + (let* ((end (point-marker)) + (beg (- (point) (length call))) + (cnt 0)) + (when (re-search-backward ")" beg t) + (delete-region (match-end 0) end)) + (goto-char beg) + (when (search-forward "(" end 'move) + (if (eq (char-after) ?\)) + (forward-char 1) + (let ((templ (company-template-declare-template beg end))) + (while (re-search-forward (concat " *\\([^,)]*\\)[,)]") end t) + (let ((sig (match-string 1))) + (delete-region (match-beginning 1) (match-end 1)) + (save-excursion + (company-template-add-field templ (match-beginning 1) + (format "arg%d" cnt) sig)) + (cl-incf cnt))) + (company-template-move-to-first templ)))))) +(provide 'company-template) ;;; company-template.el ends here