Upgrade yasnippet

1 files changed, 115 insertions, 101 deletions

diff --git a/.emacs.d/lisp/yasnippet.el b/.emacs.d/lisp/yasnippet.el
index f5210d5..d130cb9 100644
--- a/.emacs.d/lisp/yasnippet.el
+++ b/.emacs.d/lisp/yasnippet.el
@@ -5,7 +5,7 @@
 ;;          João Távora <joaotavora@gmail.com>,
 ;;          Noam Postavsky <npostavs@gmail.com>
 ;; Maintainer: Noam Postavsky <npostavs@gmail.com>
-;; Version: 0.14.0
+;; Version: 0.14.1
 ;; X-URL: http://github.com/joaotavora/yasnippet
 ;; Keywords: convenience, emulation
 ;; URL: http://github.com/joaotavora/yasnippet
@@ -421,7 +421,12 @@ The condition will respect the value of `yas-keymap-disable-hook'."
 
 (defvar yas-keymap
   (let ((map (make-sparse-keymap)))
-    (define-key map [(tab)]       (yas-filtered-definition 'yas-next-field-or-maybe-expand))
+    ;; Modes should always bind to TAB instead of `tab', so as not to override
+    ;; bindings that should take higher precedence but which bind to `TAB`
+    ;; instead (relying on `function-key-map` to remap `tab` to TAB).
+    ;; If this causes problem because of another package that binds to `tab`,
+    ;; complain to that other package!
+    ;; (define-key map [tab]       (yas-filtered-definition 'yas-next-field-or-maybe-expand))
     (define-key map (kbd "TAB")   (yas-filtered-definition 'yas-next-field-or-maybe-expand))
     (define-key map [(shift tab)] (yas-filtered-definition 'yas-prev-field))
     (define-key map [backtab]     (yas-filtered-definition 'yas-prev-field))
@@ -489,18 +494,19 @@ Attention: This hook is not run when exiting nested/stacked snippet expansion!")
   "Hook run just before expanding a snippet.")
 
 (defconst yas-not-string-or-comment-condition
-  '(if (let ((ppss (syntax-ppss)))
-         (or (nth 3 ppss) (nth 4 ppss)))
-       '(require-snippet-condition . force-in-comment)
-     t)
+  (lambda ()
+    (if (let ((ppss (syntax-ppss)))
+          (or (nth 3 ppss) (nth 4 ppss)))
+        '(require-snippet-condition . force-in-comment)
+      t))
   "Disables snippet expansion in strings and comments.
 To use, set `yas-buffer-local-condition' to this value.")
 
 (defcustom yas-buffer-local-condition t
   "Snippet expanding condition.
 
-This variable is a Lisp form which is evaluated every time a
-snippet expansion is attempted:
+This variable is either a Lisp function (called with no arguments)
+or a Lisp form.  It is evaluated every time a snippet expansion is attempted:
 
     * If it evaluates to nil, no snippets can be expanded.
 
@@ -538,12 +544,13 @@ inside comments, in `python-mode' only, with the exception of
 snippets returning the symbol `force-in-comment' in their
 conditions.
 
- (add-hook \\='python-mode-hook
-           (lambda ()
-              (setq yas-buffer-local-condition
-                    \\='(if (python-syntax-comment-or-string-p)
-                         \\='(require-snippet-condition . force-in-comment)
-                       t))))"
+    (add-hook \\='python-mode-hook
+              (lambda ()
+                (setq yas-buffer-local-condition
+                      (lambda ()
+                        (if (python-syntax-comment-or-string-p)
+                            \\='(require-snippet-condition . force-in-comment)
+                          t)))))"
   :type
   `(choice
     (const :tag "Disable snippet expansion inside strings and comments"
@@ -554,9 +561,12 @@ conditions.
     sexp))
 
 (defcustom yas-keymap-disable-hook nil
-  "The `yas-keymap' bindings are disabled if any function in this list returns non-nil.
+  "Abnormal hook run to decide when `yas-keymap' bindings are enabled.
+The bindings are disabled whenever any function in this list returns non-nil.
 This is useful to control whether snippet navigation bindings
-override bindings from other packages (e.g., `company-mode')."
+override bindings from other packages (e.g., `company-mode').
+This is run (several times) every time we perform a key lookup, so
+it has to be fast."
   :type 'hook)
 
 (defcustom yas-overlay-priority 100
@@ -648,7 +658,7 @@ expanded.")
     ;; instead (relying on `function-key-map` to remap `tab` to TAB).
     ;; If this causes problem because of another package that binds to `tab`,
     ;; complain to that other package!
-    ;;(define-key map [(tab)]     yas-maybe-expand)
+    ;;(define-key map [tab]     yas-maybe-expand)
     (define-key map (kbd "TAB") yas-maybe-expand)
     (define-key map "\C-c&\C-s" #'yas-insert-snippet)
     (define-key map "\C-c&\C-n" #'yas-new-snippet)
@@ -819,42 +829,49 @@ which decides on the snippet to expand.")
   (or (get mode 'yas--all-parents) ;; FIXME: Use `with-memoization'?
       (progn
         (put mode 'yas--all-parents (list mode)) ;; Stop inf-loop with cycles.
-        (put mode 'yas--all-parents
-             (if (fboundp 'derived-mode-all-parents)
-                 (let* ((ap (derived-mode-all-parents mode))
-                        (extras
-                         (mapcar (lambda (parent)
-                                   (yas--merge-ordered-lists
-                                    (mapcar #'yas--all-parents
-                                            (gethash parent yas--parents))))
-                                 ap)))
-                   (yas--merge-ordered-lists
-                    (cons (append ap '(fundamental-mode)) extras)))
-               (cons mode
-                     (yas--merge-ordered-lists
-                      (mapcar #'yas--all-parents
-                              (remq nil
-                                    `(,(or (get mode 'derived-mode-parent)
-                                           ;; Consider `fundamental-mode'
-                                           ;; as ultimate ancestor.
-                                           'fundamental-mode)
-                                      ,(let ((alias (symbol-function mode)))
-                                         (when (symbolp alias) alias))
-                                      ,@(gethash mode yas--parents)))))))))))
+        (let ((all-parents
+               (if (fboundp 'derived-mode-all-parents)
+                   (let* ((ap (derived-mode-all-parents mode))
+                          (extras
+                           (mapcar (lambda (parent)
+                                     (yas--merge-ordered-lists
+                                      (mapcar #'yas--all-parents
+                                              (gethash parent yas--parents))))
+                                   ap)))
+                     (cl-assert (eq mode (car ap)))
+                     (cons mode
+                           (yas--merge-ordered-lists
+                            (cons (if (eq mode 'fundamental-mode) ()
+                                    (append (cdr ap) '(fundamental-mode)))
+                                  extras))))
+                 (cons mode
+                       (yas--merge-ordered-lists
+                        (mapcar #'yas--all-parents
+                                (remq nil
+                                      `(,(or (get mode 'derived-mode-parent)
+                                             ;; Consider `fundamental-mode'
+                                             ;; as ultimate ancestor.
+                                             'fundamental-mode)
+                                        ,(let ((alias (symbol-function mode)))
+                                           (when (symbolp alias) alias))
+                                        ,@(gethash mode yas--parents)))))))))
+          (dolist (parent all-parents)
+            (cl-pushnew mode (get parent 'yas--cached-children)))
+          (put mode 'yas--all-parents all-parents)))))
 
 (defun yas--modes-to-activate (&optional mode)
   "Compute list of mode symbols that are active for `yas-expand' and friends."
   (let* ((modes
           (delete-dups
-           (remq nil `(,(or mode major-mode)
+           (remq nil `(,@(unless mode yas--extra-modes)
+                       ,(or mode major-mode)
                        ;; FIXME: Alternative major modes should use
                        ;; `derived-mode-add-parents', but until that
                        ;; becomes common, use `major-mode-remap-alist'
                        ;; as a crutch to supplement the mode hierarchy.
                        ,(and (boundp 'major-mode-remap-alist)
                              (car (rassq (or mode major-mode)
-                                         major-mode-remap-alist)))
-                       ,@(unless mode (reverse yas--extra-modes)))))))
+                                         major-mode-remap-alist))))))))
     (yas--merge-ordered-lists
      (mapcar #'yas--all-parents modes))))
 
@@ -1276,7 +1293,7 @@ Return TEMPLATE."
       (cl-assert menu-keymap)
       (yas--delete-from-keymap menu-keymap (yas--template-uuid template))
 
-      ;; Add necessary subgroups as necessary.
+      ;; Add subgroups as necessary.
       ;;
       (dolist (subgroup group)
         (let ((subgroup-keymap (lookup-key menu-keymap (vector (make-symbol subgroup)))))
@@ -1314,14 +1331,15 @@ string and TEMPLATE is a `yas--template' structure."
 
 ;;; Filtering/condition logic
 
-(defun yas--eval-condition (condition)
+(defun yas--funcall-condition (fun &rest args)
   (condition-case err
       (save-excursion
         (save-restriction
           (save-match-data
-            (eval condition t))))
+            (apply fun args))))
     (error (progn
-             (yas--message 1 "Error in condition evaluation: %s" (error-message-string err))
+             (yas--message 1 "Error in condition evaluation: %s"
+                           (error-message-string err))
              nil))))
 
 
@@ -1346,9 +1364,13 @@ This function implements the rules described in
 conditions to filter out potential expansions."
   (if (eq 'always yas-buffer-local-condition)
       'always
-    (let ((local-condition (or (and (consp yas-buffer-local-condition)
-                                    (yas--eval-condition yas-buffer-local-condition))
-                               yas-buffer-local-condition)))
+    (let ((local-condition
+           (or (cond
+                ((functionp yas-buffer-local-condition)
+                 (yas--funcall-condition yas-buffer-local-condition))
+                ((consp yas-buffer-local-condition)
+                 (yas--funcall-condition #'eval yas-buffer-local-condition t)))
+               yas-buffer-local-condition)))
       (when local-condition
         (if (eq local-condition t)
             t
@@ -1360,7 +1382,7 @@ conditions to filter out potential expansions."
 (defun yas--template-can-expand-p (condition requirement)
   "Evaluate CONDITION and REQUIREMENT and return a boolean."
   (let* ((result (or (null condition)
-                     (yas--eval-condition condition))))
+                     (yas--funcall-condition #'eval condition t))))
     (cond ((eq requirement t)
            result)
           (t
@@ -1486,7 +1508,7 @@ Also tries to work around Emacs Bug#30931."
   (yas--safely-call-fun (apply-partially #'eval form)))
 
 (defun yas--read-lisp (string &optional nil-on-error)
-  "Read STRING as a elisp expression and return it.
+  "Read STRING as an Elisp expression and return it.
 
 In case STRING in an invalid expression and NIL-ON-ERROR is nil,
 return an expression that when evaluated will issue an error."
@@ -1500,7 +1522,7 @@ return an expression that when evaluated will issue an error."
   (when (and keybinding
              (not (string-match "keybinding" keybinding)))
     (condition-case err
-        (let ((res (or (and (string-match "^\\[.*\\]$" keybinding)
+        (let ((res (or (and (string-match "\\`\\[.*\\]\\'" keybinding)
                             (read keybinding))
                        (read-kbd-macro keybinding 'need-vector))))
           res)
@@ -1584,7 +1606,6 @@ Here's a list of currently recognized directives:
                     (file-name-nondirectory file)))
          (key nil)
          template
-         bound
          condition
          (group (and file
                      (yas--calculate-group file)))
@@ -1592,31 +1613,27 @@ Here's a list of currently recognized directives:
          binding
          uuid)
     (if (re-search-forward "^# --\\s-*\n" nil t)
-        (progn (setq template
-                     (buffer-substring-no-properties (point)
-                                                     (point-max)))
-               (setq bound (point))
-               (goto-char (point-min))
-               (while (re-search-forward "^# *\\([^ ]+?\\) *: *\\(.*?\\)[[:space:]]*$" bound t)
-                 (when (string= "uuid" (match-string-no-properties 1))
-                   (setq uuid (match-string-no-properties 2)))
-                 (when (string= "type" (match-string-no-properties 1))
-                   (setq type (if (string= "command" (match-string-no-properties 2))
-                                  'command
-                                'snippet)))
-                 (when (string= "key" (match-string-no-properties 1))
-                   (setq key (match-string-no-properties 2)))
-                 (when (string= "name" (match-string-no-properties 1))
-                   (setq name (match-string-no-properties 2)))
-                 (when (string= "condition" (match-string-no-properties 1))
-                   (setq condition (yas--read-lisp (match-string-no-properties 2))))
-                 (when (string= "group" (match-string-no-properties 1))
-                   (setq group (match-string-no-properties 2)))
-                 (when (string= "expand-env" (match-string-no-properties 1))
-                   (setq expand-env (yas--read-lisp (match-string-no-properties 2)
-                                                   'nil-on-error)))
-                 (when (string= "binding" (match-string-no-properties 1))
-                   (setq binding (match-string-no-properties 2)))))
+        (let ((bound (point)))
+          (setq template
+                (buffer-substring-no-properties (point)
+                                                (point-max)))
+          (goto-char (point-min))
+          (while (re-search-forward
+                  "^# *\\([^ ]+?\\) *: *\\(.*?\\)[[:space:]]*$" bound t)
+            (let ((val (match-string-no-properties 2)))
+              (pcase (match-string-no-properties 1)
+                ("uuid"      (setq uuid val))
+                ("type"      (setq type (intern val)))
+                ("key"       (setq key val))
+                ("name"      (setq name val))
+                ("condition" (setq condition (yas--read-lisp val)))
+                ("group"     (setq group val))
+                ("expand-env"
+                 (setq expand-env (yas--read-lisp val 'nil-on-error)))
+                ("binding" (setq binding val))
+                ("contributor" nil) ;Documented in `snippet-development.org'.
+                (dir (message "Ignoring unknown directive %S in file: %s"
+                              dir file))))))
       (setq template
             (buffer-substring-no-properties (point-min) (point-max))))
     (unless (or key binding)
@@ -1811,14 +1828,6 @@ the current buffers contents."
   (if yas--creating-compiled-snippets
       (let ((print-length nil))
         (insert ";;; Snippet definitions:\n;;;\n")
-        (dolist (snippet snippets)
-          ;; Fill in missing elements with nil.
-          (setq snippet (append snippet (make-list (- 10 (length snippet)) nil)))
-          ;; Move LOAD-FILE to SAVE-FILE because we will load from the
-          ;; compiled file, not LOAD-FILE.
-          (let ((load-file (nth 6 snippet)))
-            (setcar (nthcdr 6 snippet) nil)
-            (setcar (nthcdr 9 snippet) load-file)))
         (insert (pp-to-string
                  `(yas-define-snippets ',mode ',snippets)))
         (insert "\n\n"))
@@ -1854,6 +1863,9 @@ the current buffers contents."
 
 (defun yas--define-parents (mode parents)
   "Add PARENTS to the list of MODE's parents."
+  (dolist (child (get mode 'yas--cached-children))
+    (put child 'yas--all-parents nil))  ;Flush the cache for children.
+  (put 'mode 'yas--cached-children nil)
   (puthash mode (cl-remove-duplicates
                  (append parents
                          (gethash mode yas--parents)))
@@ -1923,7 +1935,8 @@ With prefix argument USE-JIT do jit-loading of snippets."
                           (current-time-string)))))
     ;; Normal case.
     (unless (file-exists-p (expand-file-name ".yas-skip" directory))
-      (unless (and (load (expand-file-name ".yas-compiled-snippets" directory) 'noerror (<= yas-verbosity 3))
+      (unless (and (load (expand-file-name ".yas-compiled-snippets" directory)
+                         'noerror (<= yas-verbosity 3))
                    (progn (yas--message 4 "Loaded compiled snippets from %s" directory) t))
         (yas--message 4 "Loading snippet files from %s" directory)
         (yas--load-directory-2 directory mode-sym)))))
@@ -2072,7 +2085,7 @@ prefix argument."
 
 This works by stubbing a few functions, then calling
 `yas-load-directory'."
-  (interactive "DTop level snippet directory?")
+  (interactive "DTop level snippet directory? ")
   (let ((yas--creating-compiled-snippets t))
     (yas-load-directory top-level-dir nil)))
 
@@ -2923,7 +2936,8 @@ DEBUG is for debugging the YASnippet engine itself."
                                       (if (and condition
                                                original-buffer)
                                           (with-current-buffer original-buffer
-                                            (if (yas--eval-condition condition)
+                                            (if (yas--funcall-condition
+                                                 #'eval condition t)
                                                 "(y)"
                                               "(s)"))
                                         "(a)")))
@@ -3596,8 +3610,8 @@ If so cleans up the whole snippet up."
                  (yas--commit-snippet snippet)
                  (setq exited-snippets-p t))
                 ((and active-field
-                      (or (not yas--active-field-overlay)
-                          (not (overlay-buffer yas--active-field-overlay))))
+                      (not (and yas--active-field-overlay
+                                (overlay-buffer yas--active-field-overlay))))
                  ;;
                  ;; stacked expansion: this case is mainly for recent
                  ;; snippet exits that place us back int the field of
@@ -3711,7 +3725,7 @@ Otherwise deletes a character normally by calling `delete-char'."
         (t (call-interactively 'delete-char))))
 
 (defun yas--skip-and-clear (field &optional from)
-  "Deletes the region of FIELD and sets it's modified state to t.
+  "Delete the region of FIELD and set its modified state to t.
 If given, FROM indicates position to start at instead of FIELD's beginning."
   ;; Just before skipping-and-clearing the field, mark its children
   ;; fields as modified, too. If the children have mirrors-in-fields
@@ -3926,14 +3940,16 @@ Move the overlays, or create them if they do not exit."
              (overlay-put ov 'face 'yas--field-debug-face)
              (overlay-put ov 'yas--snippet snippet)
              ;; (overlay-put ov 'evaporate t)
-             (overlay-put ov 'modification-hooks '(yas--on-protection-overlay-modification)))))))
+             (overlay-put ov 'modification-hooks
+                          '(yas--on-protection-overlay-modification)))))))
 
-(defun yas--on-protection-overlay-modification (_overlay after? beg end &optional length)
+(defun yas--on-protection-overlay-modification (overlay after? beg end &optional length)
   "Commit the snippet if the protection overlay is being killed."
   (unless (or yas--inhibit-overlay-hooks
               yas-inhibit-overlay-modification-protection
               (not after?)
               (= length (- end beg)) ; deletion or insertion
+              (>= beg (overlay-end overlay)) ;Emacs=29.1 bug#65929
               (yas--undo-in-progress))
     (let ((snippets (yas-active-snippets)))
       (yas--message 2 "Committing snippets. Action would destroy a protection overlay.")
@@ -3984,9 +4000,7 @@ for normal snippets, and a list for command snippets)."
   (run-hooks 'yas-before-expand-snippet-hook)
 
   (let* ((clear-field
-          (let ((field (and yas--active-field-overlay
-                            (overlay-buffer yas--active-field-overlay)
-                            (overlay-get yas--active-field-overlay 'yas--field))))
+          (let ((field (yas-current-field)))
             (and field (yas--skip-and-clear-field-p
                         field (point) (point) 0)
                  field)))
@@ -4033,9 +4047,7 @@ for normal snippets, and a list for command snippets)."
 
              ;; Stacked-expansion: This checks for stacked expansion, save the
              ;; `yas--previous-active-field' and advance its boundary.
-             (let ((existing-field (and yas--active-field-overlay
-                                        (overlay-buffer yas--active-field-overlay)
-                                        (overlay-get yas--active-field-overlay 'yas--field))))
+             (let ((existing-field (yas-current-field)))
                (when existing-field
                  (setf (yas--snippet-previous-active-field snippet) existing-field)
                  (yas--advance-end-maybe-previous-fields
@@ -4510,7 +4522,8 @@ The SNIPPET's markers are preserved."
                              remarkers)))
                    (unwind-protect
                        (progn (back-to-indentation)
-                              (indent-according-to-mode))
+                              (with-demoted-errors "%S"
+                                (indent-according-to-mode)))
                      (save-restriction
                        (narrow-to-region bol (line-end-position))
                        (dolist (remarker remarkers)
@@ -4953,6 +4966,7 @@ When multiple expressions are found, only the last one counts."
                     ;; When not in an undo, check if we must commit the snippet
                     ;; (user exited it).
                     (yas--check-commit-snippet))))
+    ;; FIXME: Why?
     ((debug error) (signal (car err) (cdr err)))))
 
 ;;; Fancy docs: