djavu-asus/elpa/company-20230926.32/company-template.el

   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