[slime-devel] Patch to make slime-insert-arglist more useful

[Matthias Koeppe]

Please find below a patch that makes C-c C-s (slime-insert-arglist)
much more useful.  Instead of inserting a formal argument list, it
inserts a template for a function call; this makes a difference for
functions with optional and keyword arguments.  After inserting the
arguments, point is left on the first argument, like ILISP's C-u M-x
arglist-lisp does; this allows editing the arguments easily.

Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.443
diff -u -p -u -r1.443 slime.el
--- slime.el	16 Dec 2004 22:24:41 -0000	1.443
+++ slime.el	17 Dec 2004 13:24:07 -0000
@@ -4227,7 +4227,17 @@ more than one space."
   "Insert the argument list for NAME behind the symbol point is
 currently looking at."
   (interactive (list (slime-read-symbol-name "Arglist of: ")))
-  (insert (slime-eval `(swank:arglist-for-insertion ',name))))
+  (let ((arglist (slime-eval `(swank:arglist-for-insertion ',name))))
+    (cond
+      ((eq arglist :not-available)
+       (error "Arglist not available"))
+      ((string-match "^(" arglist)
+       (insert " ")
+       (save-excursion 
+         (insert (substring arglist 1))))
+      (t
+       (save-excursion
+         (insert arglist))))))
 
 (defun slime-get-arglist (symbol-name)
   "Return the argument list for SYMBOL-NAME."

Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.272
diff -u -p -u -r1.272 swank.lisp
--- swank.lisp	16 Dec 2004 21:16:50 -0000	1.272
+++ swank.lisp	17 Dec 2004 13:25:18 -0000
@@ -1143,17 +1143,108 @@ pretty printing of (function foo) as #'f
                 (*print-length* 10) (*print-circle* t))
              (format nil "~A => ~A" sym (symbol-value sym)))))))
 
+(defun decode-keyword-arg (arg)
+  "Decode a keyword item of formal argument list.
+Return three values: keyword, argument name, default arg."
+  (cond
+    ((symbolp arg)
+     (values (intern (symbol-name arg) keyword-package)
+             arg
+             nil))
+    ((and (consp arg)
+          (consp (car arg)))
+     (values (caar arg)
+             (cadar arg)
+             (cadr arg)))
+    ((consp arg)
+     (values (intern (symbol-name (car arg)) keyword-package)
+             (car arg)
+             (cadr arg)))
+    (t
+     (error "Bad keyword item of formal argument list"))))
+(progn
+  (assert (equal (multiple-value-list (decode-keyword-arg 'x)) '(:x x nil)))
+  (assert (equal (multiple-value-list (decode-keyword-arg '(x t))) '(:x x t)))
+  (assert (equal (multiple-value-list (decode-keyword-arg '((:x y)))) '(:x y nil)))
+  (assert (equal (multiple-value-list (decode-keyword-arg '((:x y) t))) '(:x y t))))
+(defun decode-optional-arg (arg)
+  "Decode an optional item of a formal argument list.
+Return two values: argument name, default arg."
+  (etypecase arg
+    (symbol
+     (values arg nil))
+    (list
+     (values (car arg) (cadr arg)))))
+(progn
+  (assert (equal (multiple-value-list (decode-optional-arg 'x)) '(x nil)))
+  (assert (equal (multiple-value-list (decode-optional-arg '(x t))) '(x t))))
+
+(defun arglist-to-template-string (arglist package)
+  "Print the list ARGLIST for insertion as a template for a function call."
+  (setq arglist (clean-arglist arglist))
+  (etypecase arglist
+    (null "()")
+    (cons 
+     (with-output-to-string (*standard-output*)
+       (with-standard-io-syntax
+         (let ((*package* package) (*print-case* :downcase)
+               (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
+               (*print-level* 10) (*print-length* 20))
+           (pprint-logical-block (nil nil :prefix "(" :suffix ")")  
+             (let ((mode nil))
+               (loop
+                  (let ((arg (pop arglist)))
+                    (typecase arg
+                      ((member &key &optional &rest &body)
+                       (setq mode arg))
+                      (string
+                       (princ arg)
+                       (unless (null arglist)
+                         (write-char #\space)))
+                      (t
+                       (case mode
+                         (&key
+                          (multiple-value-bind (keyword arg-symbol default-arg)
+                              (decode-keyword-arg arg)
+                            (declare (ignore default-arg))
+                            (write keyword)
+                            (write-char #\space)
+                            (princ arg-symbol)))
+                         (&optional
+                          (multiple-value-bind (arg-symbol default-arg)
+                              (decode-optional-arg arg)
+                            (declare (ignore default-arg))
+                            (write-char #\[)
+                            (princ arg-symbol)
+                            (write-char #\])))
+                         (&body
+                          (pprint-newline :mandatory)
+                          (princ arg)
+                          (princ "..."))
+                         (&rest
+                          (princ arg)
+                          (princ "..."))
+                         (otherwise
+                          (princ arg)))
+                       (unless (null arglist)
+                         (write-char #\space)))))
+                  (when (null arglist) (return))
+                  (pprint-newline :fill))))))))))
+
+(defun test-print-template (list string)
+  (string= (arglist-to-template-string list (find-package :swank)) string))
+
 (defslimefun arglist-for-insertion (name)
   (with-buffer-syntax ()
     (cond ((valid-operator-name-p name)
            (let ((arglist (arglist (parse-symbol name))))
              (etypecase arglist
                ((member :not-available)
-                " <not available>")
+                :not-available)
                (list
-                (arglist-to-string arglist *buffer-package*)))))
+                (arglist-to-template-string arglist *buffer-package*)))))
           (t
-           " <not available>"))))
+           :not-available))))
 
 

 ;;;; Evaluation

-- 
Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe