[nongnu] elpa/sly 7dbaae5f0f 2/2: Per #588: Adjust logic around M-x sly-remove-method

[ELPA Syncer]

branch: elpa/sly
commit 7dbaae5f0f9c896fa35fd7a04463acc930045a6b
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    Per #588: Adjust logic around M-x sly-remove-method
    
    * sly.el (sly-remove-method): Use sly-eval.
    
    * lib/sly-completion.el (sly-parse): Require it.
    (sly--read-method): Rework.  Add docstring.  Fix CL terminology.
    
    * slynk/slynk.lisp (remove-method-by-name): Rename from
    undefine-method.  Just error when method not found.  Add docstring
    (generic-method-specs): Rename from method-selectors.  Add
    docstring.
---
 lib/sly-completion.el | 68 +++++++++++++++++++++++++++------------------------
 sly.el                |  9 ++++---
 slynk/slynk.lisp      | 16 ++++++------
 3 files changed, 50 insertions(+), 43 deletions(-)

diff --git a/lib/sly-completion.el b/lib/sly-completion.el
index 8bda16d467..43ef270928 100644
--- a/lib/sly-completion.el
+++ b/lib/sly-completion.el
@@ -27,6 +27,7 @@
 (require 'cl-lib)
 (require 'comint)
 (require 'sly-messages "lib/sly-messages")
+(require 'sly-parse "lib/sly-parse")
 
 
 ;;; Something to move to minibuffer.el, maybe
@@ -757,39 +758,42 @@ symbol at point, or if QUERY is non-nil."
                  (t (funcall do-it))))
           (t sym-at-point))))
 
-(defun sly--read-method (method-name-prompt selectors-prompt-function)
-  (let* ((method-name (sly-read-symbol-name method-name-prompt t))
-         (format-selectors
-          (lambda (selectors)
-            (let ((qualifiers (car selectors)))
-              (if (null qualifiers)
-                  (format "%s" (cadr selectors))
-                (format "%s %s" (string-join qualifiers " ")
-                        (cadr selectors))))))
-         (selectors-alist
-          (mapcar
-           (lambda (selectors)
-             (cons (funcall format-selectors selectors)
-                   selectors))
-           (sly-eval `(slynk:method-selectors ,method-name))))
-         (selectors-at-point (sly-parse-context method-name)))
-    (when (and (eq :defmethod (car selectors-at-point))
-               (equal method-name (cadr selectors-at-point)))
-      (setq selectors-at-point
-            (string-replace
-             "'" "" (string-join (mapcar #'prin1-to-string
-                                         (cddr selectors-at-point))
-                                 " "))))
-    (unless (cl-member selectors-at-point selectors-alist
-                       :key #'car :test #'equal)
-      (setq selectors-at-point nil))
-    (cons method-name
+(defun sly--read-method (prompt-for-generic
+                         prompt-for-method-within-generic)
+  "Read triplet (GENERIC-NAME QUALIFIERS SPECIALIZERS) for a method."
+  (let* ((generic-name (sly-read-symbol-name prompt-for-generic t))
+         (format-spec (lambda (spec)
+                        (let ((qualifiers (car spec)))
+                          (if (null qualifiers)
+                              (format "%s" (cadr spec))
+                            (format "%s %s" (string-join qualifiers " ")
+                                    (cadr spec))))))
+         (methods-by-formatted-name
+          (cl-loop for spec in (sly-eval `(slynk:generic-method-specs 
,generic-name))
+                   collect (cons (funcall format-spec spec) spec)))
+         (context-at-point (sly-parse-context generic-name))
+         (probe (and (eq :defmethod (car context-at-point))
+                     (equal generic-name (cadr context-at-point))
+                     (string-replace
+                      "'" "" (mapconcat #'prin1-to-string (cddr 
context-at-point)
+                                        " "))))
+         default
+         (reordered
+          (cl-loop for e in methods-by-formatted-name
+                   if (cl-equalp (car e) probe) do (setq default e)
+                   else collect e into others
+                   finally (cl-return (if default (cons default others)
+                                        others)))))
+    (unless reordered
+      (sly-user-error "Generic `%s' doesn't have any methods!" generic-name))
+    (cons generic-name
           (cdr (assoc (completing-read
-                       (funcall selectors-prompt-function method-name)
-                       (mapcar #'car selectors-alist)
-                       nil t selectors-at-point)
-                      selectors-alist))))))
+                       (concat (format prompt-for-method-within-generic 
generic-name)
+                               (if default (format " (default %s)" (car 
default)))
+                               ": ")
+                       (mapcar #'car reordered)
+                       nil t nil nil (car default))
+                      reordered)))))
 
 (provide 'sly-completion)
 ;;; sly-completion.el ends here
-
diff --git a/sly.el b/sly.el
index 319c581b0f..5dcec4d38b 100644
--- a/sly.el
+++ b/sly.el
@@ -4391,10 +4391,11 @@ in Lisp when committed with \\[sly-edit-value-commit]."
 The method removed is identified by QUALIFIERS and SPECIALIZERS."
   (interactive (sly--read-method
                 "[sly] Remove method from which generic function: "
-                (lambda (method-name)
-                  (format "[sly] Remove which method from %s: " method-name))))
-  (sly-eval-async `(slynk:undefine-method ,name ',qualifiers ',specializers)
-    (lambda (result) (sly-message "%s" result))))
+                "[sly] Remove which method from %s"))
+  (sly-eval `(slynk:remove-method-by-name ,name
+                                          ',qualifiers
+                                          ',specializers))
+  (sly-message "Method removed"))
 
 (defun sly-unintern-symbol (symbol-name package)
   "Unintern the symbol given with SYMBOL-NAME PACKAGE."
diff --git a/slynk/slynk.lisp b/slynk/slynk.lisp
index 2e3648f3b4..7b8e2382bc 100644
--- a/slynk/slynk.lisp
+++ b/slynk/slynk.lisp
@@ -3201,16 +3201,18 @@ If non-nil, called with two arguments SPEC and 
TRACED-P." )
 (defun read-as-function (name)
   (eval (from-string (format nil "(function ~A)" name))))
 
-(defslyfun undefine-method (method-name qualifiers specializers)
-  (let* ((generic-function (read-as-function method-name))
+(defslyfun remove-method-by-name (generic-name qualifiers specializers)
+  "Remove GENERIC-NAME's method with QUALIFIERS and SPECIALIZERS."
+  (let* ((generic-function (read-as-function generic-name))
          (qualifiers (mapcar #'from-string qualifiers))
          (specializers (mapcar #'from-string specializers))
          (method (find-method generic-function qualifiers specializers)))
-    (format nil "~S"
-            (when method
-              (remove-method generic-function method)))))
+    (remove-method generic-function method)
+    t))
 
-(defslyfun method-selectors (method-name)
+(defslyfun generic-method-specs (generic-name)
+  "Compute ((QUALIFIERS SPECIALIZERS)...) for methods of GENERIC-NAME's gf.
+QUALIFIERS and SPECIALIZERS are lists of strings."
   (mapcar
    (lambda (method)
      (list (mapcar #'prin1-to-string (slynk-mop:method-qualifiers method))
@@ -3220,7 +3222,7 @@ If non-nil, called with two arguments SPEC and TRACED-P." 
)
                                  (sb-mop:eql-specializer-object specializer))
                          (prin1-to-string (class-name specializer))))
                    (slynk-mop:method-specializers method))))
-   (slynk-mop:generic-function-methods (read-as-function method-name))))
+   (slynk-mop:generic-function-methods (read-as-function generic-name))))
 
 (defslyfun unintern-symbol (name package)
   (let ((pkg (guess-package package)))