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