refactor: redo and document some of the menu-bar code, also add tests

yasnippet-tests.el

@@ -28,8 +28,7 @@
 (require 'ert)
 (require 'ert-x)
 
-
+
-
 ;;; Snippet mechanics
 
 (ert-deftest field-navigation ()
@@ -94,7 +93,7 @@
 ;;     (should (string= (buffer-substring-no-properties (point-min) (point-max))
 ;;                      "brother from another mother!"))))
 
-
+
 ;;; Misc tests
 ;;;
 
@@ -109,10 +108,10 @@ TODO: correct this bug!"
     (should (string= (buffer-substring-no-properties (point-min) (point-max))
                      "brother from another mother") ;; no newline should be here!
             )))
-
+
 ;;; Loading
 ;;;
-(defmacro with-some-interesting-snippet-dirs (&rest body)
+(defmacro yas-with-some-interesting-snippet-dirs (&rest body)
   `(yas-saving-variables
     (yas-with-snippet-dirs
      '((".emacs.d/snippets"
@@ -130,13 +129,13 @@ TODO: correct this bug!"
 
 (ert-deftest basic-jit-loading ()
   "Test basic loading and expansion of snippets"
-  (with-some-interesting-snippet-dirs
+  (yas-with-some-interesting-snippet-dirs
    (yas-reload-all)
    (yas--basic-jit-loading-1)))
 
 (ert-deftest basic-jit-loading-with-compiled-snippets ()
   "Test basic loading and expansion of snippets"
-  (with-some-interesting-snippet-dirs
+  (yas-with-some-interesting-snippet-dirs
    (yas-reload-all)
    (yas-recompile-all)
    (flet ((yas--load-directory-2
@@ -168,6 +167,126 @@ TODO: correct this bug!"
                          ("def" . "# define")))
     (yas-should-not-expand '("sc" "dolist" "ert-deftest"))))
 
+
+;;; Menu
+;;;
+(defmacro yas-with-even-more-interesting-snippet-dirs (&rest body)
+  `(yas-saving-variables
+    (yas-with-snippet-dirs
+     `((".emacs.d/snippets"
+        ("c-mode"
+         (".yas-make-groups" . "")
+         ("printf" . "printf($1);")
+         ("foo-group-a"
+          ("fnprintf" . "fprintf($1);")
+          ("snprintf" . "snprintf($1);"))
+         ("foo-group-b"
+          ("strcmp" . "strecmp($1);")
+          ("strcasecmp" . "strcasecmp($1);")))
+        ("lisp-interaction-mode"
+         ("ert-deftest" . "# group: barbar\n# --\n(ert-deftest ${1:name} () $0)"))
+        ("fancy-mode"
+         ("a-guy" . "# uuid: 999\n# --\nyo!")
+         ("a-sir" . "# uuid: 12345\n# --\nindeed!")
+         ("a-lady" . "# uuid: 54321\n# --\noh-la-la!")
+         ("a-beggar" . "# uuid: 0101\n# --\narrrgh!")
+         ("an-outcast" . "# uuid: 666\n# --\narrrgh!")
+         (".yas-setup.el" . , (pp-to-string
+                               '(yas-define-menu 'fancy-mode
+                                                 '((yas-ignore-item "0101")
+                                                   (yas-item "999")
+                                                   (yas-submenu "sirs"
+                                                                ((yas-item "12345")))
+                                                   (yas-submenu "ladies"
+                                                                ((yas-item "54321"))))
+                                                 '("666")))))))
+     ,@body)))
+
+(ert-deftest test-yas-define-menu ()
+  (let ((yas-use-menu t))
+    (yas-with-even-more-interesting-snippet-dirs
+     (yas-reload-all 'no-jit)
+     (let ((menu (cdr (gethash 'fancy-mode yas--menu-table))))
+       (should (eql 4 (length menu)))
+       (dolist (item '("a-guy" "a-beggar"))
+         (should (find item menu :key #'third :test #'string=)))
+       (should-not (find "an-outcast" menu :key #'third :test #'string=))
+       (dolist (submenu '("sirs" "ladies"))
+         (should (keymapp
+                  (fourth
+                   (find submenu menu :key #'third :test #'string=)))))
+       ))))
+
+(ert-deftest test-group-menus ()
+  "Test group-based menus using .yas-make-groups and the group directive"
+  (let ((yas-use-menu t))
+    (yas-with-even-more-interesting-snippet-dirs
+     (yas-reload-all 'no-jit)
+     ;; first the subdir-based groups
+     ;;
+     (let ((menu (cdr (gethash 'c-mode yas--menu-table))))
+       (should (eql 3 (length menu)))
+       (dolist (item '("printf" "foo-group-a" "foo-group-b"))
+         (should (find item menu :key #'third :test #'string=)))
+       (dolist (submenu '("foo-group-a" "foo-group-b"))
+         (should (keymapp
+                  (fourth
+                   (find submenu menu :key #'third :test #'string=))))))
+     ;; now group directives
+     ;;
+     (let ((menu (cdr (gethash 'lisp-interaction-mode yas--menu-table))))
+       (should (eql 1 (length menu)))
+       (should (find "barbar" menu :key #'third :test #'string=))
+       (should (keymapp
+                (fourth
+                 (find "barbar" menu :key #'third :test #'string=))))))))
+
+(ert-deftest test-group-menus-twisted ()
+  "Same as similarly named test, but be mean.
+
+TODO: be meaner"
+  (let ((yas-use-menu t))
+    (yas-with-even-more-interesting-snippet-dirs
+     ;; add a group directive conflicting with the subdir and watch
+     ;; behaviour
+     (with-temp-buffer
+       (insert "# group: foo-group-c\n# --\nstrecmp($1)")
+       (write-region nil nil (concat (first (yas-snippet-dirs))
+                                     "/c-mode/foo-group-b/strcmp")))
+     (yas-reload-all 'no-jit)
+     (let ((menu (cdr (gethash 'c-mode yas--menu-table))))
+       (should (eql 4 (length menu)))
+       (dolist (item '("printf" "foo-group-a" "foo-group-b" "foo-group-c"))
+         (should (find item menu :key #'third :test #'string=)))
+       (dolist (submenu '("foo-group-a" "foo-group-b" "foo-group-c"))
+         (should (keymapp
+                  (fourth
+                   (find submenu menu :key #'third :test #'string=))))))
+     ;; delete the .yas-make-groups file and watch behaviour
+     ;;
+     (delete-file (concat (first (yas-snippet-dirs))
+                          "/c-mode/.yas-make-groups"))
+     (yas-reload-all 'no-jit)
+     (let ((menu (cdr (gethash 'c-mode yas--menu-table))))
+       (should (eql 5 (length menu))))
+     ;; Change a group directive and reload
+     ;;
+     (let ((menu (cdr (gethash 'lisp-interaction-mode yas--menu-table))))
+       (should (find "barbar" menu :key #'third :test #'string=)))
+
+     (with-temp-buffer
+       (insert "# group: foofoo\n# --\n(ert-deftest ${1:name} () $0)")
+       (write-region nil nil (concat (first (yas-snippet-dirs))
+                                     "/lisp-interaction-mode/ert-deftest")))
+     (yas-reload-all 'no-jit)
+     (let ((menu (cdr (gethash 'lisp-interaction-mode yas--menu-table))))
+       (should (eql 1 (length menu)))
+       (should (find "foofoo" menu :key #'third :test #'string=))
+       (should (keymapp
+                (fourth
+                 (find "foofoo" menu :key #'third :test #'string=))))))))
+
+
 ;;; Helpers
 ;;;
 
@@ -220,12 +339,18 @@ TODO: correct this bug!"
                       (push sym syms))))
     syms))
 
+(defun yas-call-with-saving-variables (fn)
+  (let* ((vars (yas-variables))
+         (saved-values (mapcar #'symbol-value vars)))
+    (unwind-protect
+        (funcall fn)
+      (loop for var in vars
+            for saved in saved-values
+            do (set var saved)))))
 
 (defmacro yas-saving-variables (&rest body)
-  `(let ,(mapcar #'(lambda (sym)
+  `(yas-call-with-saving-variables #'(lambda () ,@body)))
-                     `(,sym ,sym))
+
-                 (yas-variables))
-     ,@body))
 
 (defun yas-call-with-snippet-dirs (dirs fn)
   (let* ((default-directory (make-temp-file "yasnippet-fixture" t))
@@ -253,5 +378,9 @@ TODO: correct this bug!"
 ;;; curl -L -O https://github.com/mirrors/emacs/raw/master/lisp/emacs-lisp/ert-x.el
 ;;; /usr/bin/emacs -nw -Q -L . -l yasnippet-tests.el --batch -e ert
 
+
 (provide 'yasnippet-tests)
 ;;; yasnippet-tests.el ends here
+;; Local Variables:
+;; lexical-binding: t
+;; End:

yasnippet.el

@@ -361,7 +361,9 @@ Any other non-nil value, every submenu is listed."
                  (const :tag "No menu" nil))
   :group 'yasnippet)
 
-(defcustom yas-trigger-symbol " =>"
+(defcustom yas-trigger-symbol (if (eq window-system 'mac)
+                                  (char-to-string ?\x21E5) ;; little ->| sign
+                                  " =>")
   "The text that will be used in menu to represent the trigger."
   :type 'string
   :group 'yasnippet)
@@ -1065,7 +1067,7 @@ keybinding)."
   (let ((name (yas--template-name template))
         (key (yas--template-key template))
         (keybinding (yas--template-keybinding template))
-        (menu-binding-pair (yas--snippet-menu-binding-pair-get-create template)))
+        (menu-binding-pair (yas--template-menu-binding-pair-get-create template)))
     (dolist (k (remove nil (list key keybinding)))
       (puthash name
                template
@@ -1077,14 +1079,10 @@ keybinding)."
       (when (vectorp k)
         (define-key (yas--table-direct-keymap table) k 'yas-expand-from-keymap)))
 
-    ;; Update trigger & keybinding in the menu-binding pair
+    ;; Update TABLE's `yas--table-uuidhash'
-    ;;
+    (puthash (yas--template-uuid template)
-    (unless (eq (cdr menu-binding-pair) :none)
+             template
-      (setf (getf (cdr (car menu-binding-pair)) :keys)
+             (yas--table-uuidhash table))))
-            (or (and keybinding (key-description keybinding))
-                (and key (concat key yas-trigger-symbol)))))
-
-    (puthash (yas--template-uuid template) template (yas--table-uuidhash table))))
 
 (defun yas--update-template (table template)
   "Add or update TEMPLATE in TABLE.
@@ -1098,33 +1096,52 @@ Also takes care of adding and updating to the associated menu."
   (yas--add-template table template)
   ;; Take care of the menu
   ;;
-  (let ((keymap
+  (when yas-use-menu
-         (yas--menu-keymap-get-create (yas--table-mode table)
+    (yas--update-template-menu table template)))
-                                      (mapcar #'yas--table-mode
+
-                                              (yas--table-parents table))))
+(defun yas--update-template-menu (table template)
-        (group (yas--template-group template)))
+  "Update every menu-related for TEMPLATE"
-    (when (and yas-use-menu
+  (let ((menu-binding-pair (yas--template-menu-binding-pair-get-create template))
-               keymap
+        (key (yas--template-key template))
-               (not (cdr (yas--template-menu-binding-pair template))))
+        (keybinding (yas--template-keybinding template)))
+    ;; The snippet might have changed name or keys, so update
+    ;; user-visible strings
+    ;;
+    (unless (eq (cdr menu-binding-pair) :none)
+      ;; the menu item name
+      ;;
+      (setf (cadar menu-binding-pair) (yas--template-name template))
+      ;; the :keys information (also visible to the user)
+      (setf (getf (cdr (car menu-binding-pair)) :keys)
+            (or (and keybinding (key-description keybinding))
+                (and key (concat key yas-trigger-symbol))))))
+  (unless (yas--template-menu-managed-by-yas-define-menu template)
+    (let ((menu-keymap
+           (yas--menu-keymap-get-create (yas--table-mode table)
+                                        (mapcar #'yas--table-mode
+                                                (yas--table-parents table))))
+          (group (yas--template-group template)))
       ;; Remove from menu keymap
       ;;
-      (yas--delete-from-keymap keymap (yas--template-uuid template))
+      (assert menu-keymap)
+      (yas--delete-from-keymap menu-keymap (yas--template-uuid template))
 
       ;; Add necessary subgroups as necessary.
       ;;
       (dolist (subgroup group)
-        (let ((subgroup-keymap (lookup-key keymap (vector (make-symbol subgroup)))))
+        (let ((subgroup-keymap (lookup-key menu-keymap (vector (make-symbol subgroup)))))
           (unless (and subgroup-keymap
                        (keymapp subgroup-keymap))
             (setq subgroup-keymap (make-sparse-keymap))
-            (define-key keymap (vector (make-symbol subgroup))
+            (define-key menu-keymap (vector (make-symbol subgroup))
               `(menu-item ,subgroup ,subgroup-keymap)))
-            (setq keymap subgroup-keymap)))
+          (setq menu-keymap subgroup-keymap)))
 
       ;; Add this entry to the keymap
       ;;
-      (let ((menu-binding-pair (yas--snippet-menu-binding-pair-get-create template)))
+      (define-key menu-keymap
-        (define-key keymap (vector (make-symbol (yas--template-uuid template))) (car menu-binding-pair))))))
+        (vector (make-symbol (yas--template-uuid template)))
+        (car (yas--template-menu-binding-pair template))))))
 
 (defun yas--namehash-templates-alist (namehash)
   (let (alist)
@@ -1776,8 +1793,7 @@ loading."
       ;; Init the `yas-minor-mode-map', taking care not to break the
       ;; menu....
       ;;
-      (setf (cdr yas-minor-mode-map)
+      (setcdr yas-minor-mode-map (cdr (yas--init-minor-keymap)))
-            (cdr (yas--init-minor-keymap)))
 
       ;; Reload the directories listed in `yas-snippet-dirs' or prompt
       ;; the user to select one.
@@ -1903,9 +1919,9 @@ This works by stubbing a few functions, then calling
 
 (defun yas--define-parents (mode parents)
   "Add PARENTS to the list of MODE's parents"
-  (puthash mode-sym (remove-duplicates
+  (puthash mode (remove-duplicates
-                     (append parents
+                 (append parents
-                             (gethash mode-sym yas--parents)))
+                         (gethash mode yas--parents)))
            yas--parents))
 
 (defun yas-define-snippets (mode snippets)
@@ -1982,7 +1998,39 @@ the current buffers contents."
     ;;
     template))
 
-(defun yas--snippet-menu-binding-pair-get-create (template &optional type)
+
+;;; Apropos snippet menu:
+;;
+;; The snippet menu keymaps are store by mode in hash table called
+;; `yas--menu-table'. They are linked to the main menu in
+;; `yas--menu-keymap-get-create' and are initially created empty,
+;; reflecting the table hierarchy.
+;;
+;; They can be populated in two mutually exclusive ways: (1) by
+;; reading `yas--template-group', which in turn is populated by the "#
+;; group:" directives of the snippets or the ".yas-make-groups" file
+;; or (2) by using a separate `yas-define-menu' call, which declares a
+;; menu structure based on snippets uuids.
+;;
+;; Both situations are handled in `yas--update-template-menu', which
+;; uses the predicate `yas--template-menu-managed-by-yas-define-menu'
+;; that can tell between the two situations.
+;;
+;; Note:
+;;
+;; * if `yas-define-menu' is used it must run before
+;;   `yas-define-snippets' and the UUIDS must match, otherwise we get
+;;   duplicate entries. The `yas--template' objects are created in
+;;   `yas-define-menu', holding nothing but the menu entry,
+;;   represented by a pair of ((menu-item NAME :keys KEYS) TYPE) and
+;;   stored in `yas--template-menu-binding-pair'. The (menu-item ...)
+;;   part is then stored in the menu keymap itself which make the item
+;;   appear to the user. These limitations could probably be revised.
+;;
+;; * The `yas--template-perm-group' slot is only used in
+;;   `yas-describe-tables'.
+;;
+(defun yas--template-menu-binding-pair-get-create (template &optional type)
   "Get TEMPLATE's menu binding or assign it a new one.
 
 TYPE may be `:stay', signalling this menu binding should be
@@ -1996,6 +2044,10 @@ static in the menu."
                                 ,(yas--make-menu-binding template)
                                 :keys ,nil)
                     type)))))
+(defun yas--template-menu-managed-by-yas-define-menu (template)
+  "Non-nil if TEMPLATE's menu entry was included in a `yas-define-menu' call."
+  (cdr (yas--template-menu-binding-pair template)))
+
 
 (defun yas--show-menu-p (mode)
   (cond ((eq yas-use-menu 'abbreviate)
@@ -2004,6 +2056,8 @@ static in the menu."
                            (yas--table-mode table))
                        (yas--get-snippet-tables))))
         ((eq yas-use-menu 'full)
+         t)
+        ((eq yas-use-menu t)
          t)))
 
 (defun yas--delete-from-keymap (keymap uuid)
@@ -2031,7 +2085,7 @@ static in the menu."
                                          (null (cdr (third (cdr item)))))))
                             (rest keymap))))
 
-(defun yas-define-menu (mode menu omit-items)
+(defun yas-define-menu (mode menu &optional omit-items)
   "Define a snippet menu for MODE according to MENU, ommitting OMIT-ITEMS.
 
 MENU is a list, its elements can be:
@@ -2067,7 +2121,7 @@ This function does nothing if `yas-use-menu' is nil.
                                                     :uuid uuid))))
           (setf (yas--template-menu-binding-pair template) (cons nil :none)))))))
 
-(defun yas--define-menu-1 (table keymap menu uuidhash &optional group-list)
+(defun yas--define-menu-1 (table menu-keymap menu uuidhash &optional group-list)
   (dolist (e (reverse menu))
     (cond ((eq (first e) 'yas-item)
            (let ((template (or (gethash (second e) uuidhash)
@@ -2077,11 +2131,11 @@ This function does nothing if `yas-use-menu' is nil.
                                                       :table table
                                                       :perm-group group-list
                                                       :uuid (second e)))))
-             (define-key keymap (vector (gensym))
+             (define-key menu-keymap (vector (gensym))
-               (car (yas--snippet-menu-binding-pair-get-create template :stay)))))
+               (car (yas--template-menu-binding-pair-get-create template :stay)))))
           ((eq (first e) 'yas-submenu)
            (let ((subkeymap (make-sparse-keymap)))
-             (define-key keymap (vector (gensym))
+             (define-key menu-keymap (vector (gensym))
                `(menu-item ,(second e) ,subkeymap))
              (yas--define-menu-1 table
                                 subkeymap
@@ -2089,7 +2143,7 @@ This function does nothing if `yas-use-menu' is nil.
                                 uuidhash
                                 (append group-list (list (second e))))))
           ((eq (first e) 'yas-separator)
-           (define-key keymap (vector (gensym))
+           (define-key menu-keymap (vector (gensym))
              '(menu-item "----")))
           (t
            (yas--message 3 "Don't know anything about menu entry %s" (first e))))))