X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/cb0a58684509ba5d3546d7d08a11b136ca294c11..e52579348d8529b0cff08a1f0a676cb0cc6f61c3:/company-template.el

diff --git a/company-template.el b/company-template.el
index 53d968757..053429dc4 100644
--- a/company-template.el
+++ b/company-template.el
@@ -1,6 +1,6 @@
-;;; 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
 
@@ -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,50 +93,122 @@
         (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