| commit | author | age | ||
| 5cb5f7 | 1 | ;;; company-template.el --- utility library for template expansion |
| C | 2 | |
| 3 | ;; Copyright (C) 2009, 2010, 2014-2017 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Author: Nikolaj Schumacher | |
| 6 | ||
| 7 | ;; This file is part of GNU Emacs. | |
| 8 | ||
| 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. | |
| 13 | ||
| 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. | |
| 18 | ||
| 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/>. | |
| 21 | ||
| 22 | ;;; Code: | |
| 23 | ||
| 24 | (require 'cl-lib) | |
| 25 | ||
| 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." | |
| 30 | :group 'company) | |
| 31 | ||
| 32 | (defvar company-template-nav-map | |
| 33 | (let ((keymap (make-sparse-keymap))) | |
| 34 | (define-key keymap [tab] 'company-template-forward-field) | |
| 35 | (define-key keymap (kbd "TAB") 'company-template-forward-field) | |
| 36 | keymap)) | |
| 37 | ||
| 38 | (defvar company-template-field-map | |
| 39 | (let ((keymap (make-sparse-keymap))) | |
| 40 | (set-keymap-parent keymap company-template-nav-map) | |
| 41 | (define-key keymap (kbd "C-d") 'company-template-clear-field) | |
| 42 | keymap)) | |
| 43 | ||
| 44 | (defvar-local company-template--buffer-templates nil) | |
| 45 | ||
| 46 | ;; interactive ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 47 | ||
| 48 | (defun company-template-templates-at (pos) | |
| 49 | (let (os) | |
| 50 | (dolist (o (overlays-at pos)) | |
| 51 | ;; FIXME: Always return the whole list of templates? | |
| 52 | ;; We remove templates not at point after every command. | |
| 53 | (when (memq o company-template--buffer-templates) | |
| 54 | (push o os))) | |
| 55 | os)) | |
| 56 | ||
| 57 | (defun company-template-move-to-first (templ) | |
| 58 | (interactive) | |
| 59 | (goto-char (overlay-start templ)) | |
| 60 | (company-template-forward-field)) | |
| 61 | ||
| 62 | (defun company-template-forward-field () | |
| 63 | (interactive) | |
| 64 | (let ((start (point)) | |
| 65 | (next-field-start (company-template-find-next-field))) | |
| 66 | (push-mark) | |
| 67 | (goto-char next-field-start) | |
| 68 | (company-template-remove-field (company-template-field-at start)))) | |
| 69 | ||
| 70 | (defun company-template-clear-field () | |
| 71 | "Clear the field at point." | |
| 72 | (interactive) | |
| 73 | (let ((ovl (company-template-field-at (point)))) | |
| 74 | (when ovl | |
| 75 | (company-template-remove-field ovl t) | |
| 76 | (let ((after-clear-fn | |
| 77 | (overlay-get ovl 'company-template-after-clear))) | |
| 78 | (when (functionp after-clear-fn) | |
| 79 | (funcall after-clear-fn)))))) | |
| 80 | ||
| 81 | (defun company-template--after-clear-c-like-field () | |
| 82 | "Function that can be called after deleting a field of a c-like template. | |
| 83 | For c-like templates it is set as `after-post-fn' property on fields in | |
| 84 | `company-template-add-field'. If there is a next field, delete everything | |
| 85 | from point to it. If there is no field after point, remove preceding comma | |
| 86 | if present." | |
| 87 | (let* ((pos (point)) | |
| 88 | (next-field-start (company-template-find-next-field)) | |
| 89 | (last-field-p (not (company-template-field-at next-field-start)))) | |
| 90 | (cond ((and (not last-field-p) | |
| 91 | (< pos next-field-start) | |
| 92 | (string-match "^[ ]*,+[ ]*$" (buffer-substring-no-properties | |
| 93 | pos next-field-start))) | |
| 94 | (delete-region pos next-field-start)) | |
| 95 | ((and last-field-p | |
| 96 | (looking-back ",+[ ]*" (line-beginning-position))) | |
| 97 | (delete-region (match-beginning 0) pos))))) | |
| 98 | ||
| 99 | (defun company-template-find-next-field () | |
| 100 | (let* ((start (point)) | |
| 101 | (templates (company-template-templates-at start)) | |
| 102 | (minimum (apply 'max (mapcar 'overlay-end templates))) | |
| 103 | (fields (cl-loop for templ in templates | |
| 104 | append (overlay-get templ 'company-template-fields)))) | |
| 105 | (dolist (pos (mapcar 'overlay-start fields) minimum) | |
| 106 | (and pos | |
| 107 | (> pos start) | |
| 108 | (< pos minimum) | |
| 109 | (setq minimum pos))))) | |
| 110 | ||
| 111 | (defun company-template-field-at (&optional point) | |
| 112 | (cl-loop for ovl in (overlays-at (or point (point))) | |
| 113 | when (overlay-get ovl 'company-template-parent) | |
| 114 | return ovl)) | |
| 115 | ||
| 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 117 | ||
| 118 | (defun company-template-declare-template (beg end) | |
| 119 | (let ((ov (make-overlay beg end))) | |
| 120 | ;; (overlay-put ov 'face 'highlight) | |
| 121 | (overlay-put ov 'keymap company-template-nav-map) | |
| 122 | (overlay-put ov 'priority 101) | |
| 123 | (overlay-put ov 'evaporate t) | |
| 124 | (push ov company-template--buffer-templates) | |
| 125 | (add-hook 'post-command-hook 'company-template-post-command nil t) | |
| 126 | ov)) | |
| 127 | ||
| 128 | (defun company-template-remove-template (templ) | |
| 129 | (mapc 'company-template-remove-field | |
| 130 | (overlay-get templ 'company-template-fields)) | |
| 131 | (setq company-template--buffer-templates | |
| 132 | (delq templ company-template--buffer-templates)) | |
| 133 | (delete-overlay templ)) | |
| 134 | ||
| 135 | (defun company-template-add-field (templ beg end &optional display after-clear-fn) | |
| 136 | "Add new field to template TEMPL spanning from BEG to END. | |
| 137 | When DISPLAY is non-nil, set the respective property on the overlay. | |
| 138 | Leave point at the end of the field. | |
| 139 | AFTER-CLEAR-FN is a function that can be used to apply custom behavior | |
| 140 | after deleting a field in `company-template-remove-field'." | |
| 141 | (cl-assert templ) | |
| 142 | (when (> end (overlay-end templ)) | |
| 143 | (move-overlay templ (overlay-start templ) end)) | |
| 144 | (let ((ov (make-overlay beg end)) | |
| 145 | (siblings (overlay-get templ 'company-template-fields))) | |
| 146 | ;; (overlay-put ov 'evaporate t) | |
| 147 | (overlay-put ov 'intangible t) | |
| 148 | (overlay-put ov 'face 'company-template-field) | |
| 149 | (when display | |
| 150 | (overlay-put ov 'display display)) | |
| 151 | (overlay-put ov 'company-template-parent templ) | |
| 152 | (overlay-put ov 'insert-in-front-hooks '(company-template-insert-hook)) | |
| 153 | (when after-clear-fn | |
| 154 | (overlay-put ov 'company-template-after-clear after-clear-fn)) | |
| 155 | (overlay-put ov 'keymap company-template-field-map) | |
| 156 | (overlay-put ov 'priority 101) | |
| 157 | (push ov siblings) | |
| 158 | (overlay-put templ 'company-template-fields siblings))) | |
| 159 | ||
| 160 | (defun company-template-remove-field (ovl &optional clear) | |
| 161 | (when (overlayp ovl) | |
| 162 | (when (overlay-buffer ovl) | |
| 163 | (when clear | |
| 164 | (delete-region (overlay-start ovl) (overlay-end ovl))) | |
| 165 | (delete-overlay ovl)) | |
| 166 | (let* ((templ (overlay-get ovl 'company-template-parent)) | |
| 167 | (siblings (overlay-get templ 'company-template-fields))) | |
| 168 | (setq siblings (delq ovl siblings)) | |
| 169 | (overlay-put templ 'company-template-fields siblings)))) | |
| 170 | ||
| 171 | (defun company-template-clean-up (&optional pos) | |
| 172 | "Clean up all templates that don't contain POS." | |
| 173 | (let ((local-ovs (overlays-at (or pos (point))))) | |
| 174 | (dolist (templ company-template--buffer-templates) | |
| 175 | (unless (memq templ local-ovs) | |
| 176 | (company-template-remove-template templ))))) | |
| 177 | ||
| 178 | ;; hooks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 179 | ||
| 180 | (defun company-template-insert-hook (ovl after-p &rest _ignore) | |
| 181 | "Called when a snippet input prompt is modified." | |
| 182 | (unless after-p | |
| 183 | (company-template-remove-field ovl t))) | |
| 184 | ||
| 185 | (defun company-template-post-command () | |
| 186 | (company-template-clean-up) | |
| 187 | (unless company-template--buffer-templates | |
| 188 | (remove-hook 'post-command-hook 'company-template-post-command t))) | |
| 189 | ||
| 190 | ;; common ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 191 | ||
| 192 | (defun company-template-c-like-templatify (call) | |
| 193 | (let* ((end (point-marker)) | |
| 194 | (beg (- (point) (length call))) | |
| 195 | (templ (company-template-declare-template beg end)) | |
| 196 | paren-open paren-close) | |
| 197 | (with-syntax-table (make-syntax-table (syntax-table)) | |
| 198 | (modify-syntax-entry ?< "(") | |
| 199 | (modify-syntax-entry ?> ")") | |
| 200 | (when (search-backward ")" beg t) | |
| 201 | (setq paren-close (point-marker)) | |
| 202 | (forward-char 1) | |
| 203 | (delete-region (point) end) | |
| 204 | (backward-sexp) | |
| 205 | (forward-char 1) | |
| 206 | (setq paren-open (point-marker))) | |
| 207 | (when (search-backward ">" beg t) | |
| 208 | (let ((angle-close (point-marker))) | |
| 209 | (forward-char 1) | |
| 210 | (backward-sexp) | |
| 211 | (forward-char) | |
| 212 | (company-template--c-like-args templ angle-close))) | |
| 213 | (when (looking-back "\\((\\*)\\)(" (line-beginning-position)) | |
| 214 | (delete-region (match-beginning 1) (match-end 1))) | |
| 215 | (when paren-open | |
| 216 | (goto-char paren-open) | |
| 217 | (company-template--c-like-args templ paren-close))) | |
| 218 | (if (overlay-get templ 'company-template-fields) | |
| 219 | (company-template-move-to-first templ) | |
| 220 | (company-template-remove-template templ) | |
| 221 | (goto-char end)))) | |
| 222 | ||
| 223 | (defun company-template--c-like-args (templ end) | |
| 224 | (let ((last-pos (point))) | |
| 225 | (while (re-search-forward "\\([^,]+\\),?" end 'move) | |
| 226 | (when (zerop (car (parse-partial-sexp last-pos (point)))) | |
| 227 | (company-template-add-field templ last-pos (match-end 1) nil | |
| 228 | #'company-template--after-clear-c-like-field) | |
| 229 | (skip-chars-forward " ") | |
| 230 | (setq last-pos (point)))))) | |
| 231 | ||
| 232 | ;; objc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 233 | ||
| 234 | (defun company-template-objc-templatify (selector) | |
| 235 | (let* ((end (point-marker)) | |
| 236 | (beg (- (point) (length selector) 1)) | |
| 237 | (templ (company-template-declare-template beg end)) | |
| 238 | (cnt 0)) | |
| 239 | (save-excursion | |
| 240 | (goto-char beg) | |
| 241 | (catch 'stop | |
| 242 | (while (search-forward ":" end t) | |
| 243 | (if (looking-at "\\(([^)]*)\\) ?") | |
| 244 | (company-template-add-field templ (point) (match-end 1)) | |
| 245 | ;; Not sure which conditions this case manifests under, but | |
| 246 | ;; apparently it did before, when I wrote the first test for this | |
| 247 | ;; function. FIXME: Revisit it. | |
| 248 | (company-template-add-field templ (point) | |
| 249 | (progn | |
| 250 | (insert (format "arg%d" cnt)) | |
| 251 | (point))) | |
| 252 | (when (< (point) end) | |
| 253 | (insert " ")) | |
| 254 | (cl-incf cnt)) | |
| 255 | (when (>= (point) end) | |
| 256 | (throw 'stop t))))) | |
| 257 | (company-template-move-to-first templ))) | |
| 258 | ||
| 259 | (provide 'company-template) | |
| 260 | ;;; company-template.el ends here | |
