Hi,
I am sending a new patch that improves arglist display and slime-complete-form. This patch supersedes the one from my message of Feb 22, which has not made it into CVS yet.
The patch integrates the code for detecting extra keyword arguments for generic functions into the arglist display in the echo area, as suggested by Luke. It also special-cases the keyword arguments :test and :test-not in slime-complete-form, as suggested by Christophe. For more details, see the changelog.
Anyone who wants to merge it into CVS?
Cheers, Matthias
2005-03-06 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de
* slime.el (slime-easy-menu): Add menu item for slime-complete-form.
* swank.lisp (format-arglist-for-echo-area): Use extra-keywords to enrich the list of keywords. (arglist-to-string): Remove extraneous whitespace. (keyword-arg, optional-arg): New structures. (decode-keyword-arg, decode-optional-arg): Return structure objects rather than multiple values. (encode-keyword-arg, encode-optional-arg, encode-arglist): New functions. (arglist): New slot key-p. (decode-arglist): Handle &whole, &environment. Store more information on optional and keyword args, set arglist.key-p. (values-equal?): Removed. (print-decoded-arglist-as-template): If keyword is not a keyword symbol, quote it in the template. (extra-keywords): Return a secondary value (allow-other-keys). For make-instance, try to finalize the class if it is not finalized yet (fix for Allegro CL 6.2). If class is not finalizable, use direct slots instead of slots and indicate that the keywords are not complete. (enrich-decoded-arglist-with-extra-keywords): New function, use the secondary value of extra-keywords. (arglist-for-insertion, complete-form): Use it here. (*remove-keywords-alist*): New variable. (remove-actual-args): When the keyword :test is provided, don't suggest :test-not and vice versa.
* swank-backend.lisp (:swank-mop package): Export finalize-inheritance.
Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.463 diff -u -p -r1.463 slime.el --- slime.el 4 Mar 2005 23:43:29 -0000 1.463 +++ slime.el 6 Mar 2005 14:54:15 -0000 @@ -690,6 +690,7 @@ If INFERIOR is non-nil, the key is also [ "Return From Definition" slime-pop-find-definition-stack ,C ] [ "Complete Symbol" slime-complete-symbol ,C ] [ "Fuzzy Complete Symbol" slime-fuzzy-complete-symbol ,C ] + [ "Complete Form" slime-complete-form ,C ] [ "Show REPL" slime-switch-to-output-buffer ,C ] "--" ("Evaluation" Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.282 diff -u -p -r1.282 swank.lisp --- swank.lisp 28 Feb 2005 23:32:58 -0000 1.282 +++ swank.lisp 6 Mar 2005 14:54:17 -0000 @@ -1148,6 +1148,9 @@ Return the package or nil." (let ((symbol (parse-symbol string))) (valid-operator-symbol-p symbol)))
+ +;;;; Arglists + (defslimefun arglist-for-echo-area (names) "Return the arglist for the first function, macro, or special-op in NAMES." (handler-case @@ -1165,8 +1168,21 @@ Use the string NAME as operator name." ((member :not-available) nil) (list - (arglist-to-string (cons name arglist) - (symbol-package symbol)))))) + (let ((enriched-arglist + (if (extra-keywords symbol) + ;; When there are extra keywords, we decode the + ;; arglist, merge in the keywords and encode it + ;; again. + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords + decoded-arglist (list symbol)) + (encode-arglist decoded-arglist)) + ;; Otherwise, just use the original arglist. + ;; This works better for implementation-specific + ;; lambda-list-keywords like CMUCL's &parse-body. + arglist))) + (arglist-to-string (cons name enriched-arglist) + (symbol-package symbol)))))))
(defun clean-arglist (arglist) "Remove &whole, &enviroment, and &aux elements from ARGLIST." @@ -1198,7 +1214,8 @@ pretty printing of (function foo) as #'f (string (princ arg)) (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")") (princ (car arg)) - (write-char #\space) + (unless (null (cdr arg)) + (write-char #\space)) (pprint-fill *standard-output* (cdr arg) nil)))) (when (null arglist) (return)) (write-char #\space) @@ -1227,65 +1244,106 @@ pretty printing of (function foo) as #'f (*print-length* 10) (*print-circle* t)) (format nil "~A => ~A" sym (symbol-value sym)))))))
+(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor make-keyword-arg (keyword arg-name default-arg))) + keyword + arg-name + default-arg) + (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)) + (make-keyword-arg (intern (symbol-name arg) keyword-package) + arg + nil)) ((and (consp arg) (consp (car arg))) - (values (caar arg) - (cadar arg) - (cadr arg))) + (make-keyword-arg (caar arg) + (cadar arg) + (cadr arg))) ((consp arg) - (values (intern (symbol-name (car arg)) keyword-package) - (car arg) - (cadr arg))) + (make-keyword-arg (intern (symbol-name (car arg)) keyword-package) + (car arg) + (cadr arg))) (t (error "Bad keyword item of formal argument list"))))
-(defmacro values-equal? (exp (&rest values)) - "Are the values produced by EXP equal to VALUES." - `(equal (multiple-value-list ,exp) (list ,@values))) +(defun encode-keyword-arg (arg) + (if (eql (intern (symbol-name (keyword-arg.arg-name arg)) + keyword-package) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg)) + (let ((keyword/name (list (keyword-arg.arg-name arg) + (keyword-arg.keyword arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))
(progn - (assert (values-equal? (decode-keyword-arg 'x) (:x 'x nil))) - (assert (values-equal? (decode-keyword-arg '(x t)) (:x 'x t))) - (assert (values-equal? (decode-keyword-arg '((:x y))) (:x 'y nil))) - (assert (values-equal? (decode-keyword-arg '((:x y) t)) (:x 'y t)))) + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil)) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t)))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor make-optional-arg (arg-name default-arg))) + arg-name + default-arg)
(defun decode-optional-arg (arg) "Decode an optional item of a formal argument list. -Return two values: argument name, default arg." +Return an OPTIONAL-ARG structure." (etypecase arg - (symbol (values arg nil)) - (list (values (car arg) (cadr arg))))) + (symbol (make-optional-arg arg nil)) + (list (make-optional-arg (car arg) (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (optional-arg.default-arg optional-arg) + (list (optional-arg.arg-name optional-arg) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg)))
(progn - (assert (values-equal? (decode-optional-arg 'x) ('x nil))) - (assert (values-equal? (decode-optional-arg '(x t)) ('x t)))) + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t))))
(defstruct (arglist (:conc-name arglist.)) required-args ; list of the required arguments optional-args ; list of the optional arguments + key-p ; whether &key appeared keyword-args ; list of the keywords rest ; name of the &rest or &body argument (if any) body-p ; whether the rest argument is a &body allow-other-keys-p) ; whether &allow-other-keys appeared
(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." (let ((mode nil) (result (make-arglist))) (dolist (arg arglist) - (typecase arg - ((member &key &optional &rest &body &whole &aux) - (setq mode arg)) - ((member &allow-other-keys) - (setf (arglist.allow-other-keys-p result) t)) - (t - (case mode + (cond + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((member arg lambda-list-keywords) + (setq mode arg)) + (t + (case mode (&key (push (decode-keyword-arg arg) (arglist.keyword-args result))) @@ -1298,7 +1356,9 @@ Return two values: argument name, defaul (&rest (setf (arglist.rest result) arg)) ((nil) - (push arg (arglist.required-args result))))))) + (push arg (arglist.required-args result))) + ((&whole &environment) + (setf mode nil)))))) (setf (arglist.required-args result) (nreverse (arglist.required-args result))) (setf (arglist.optional-args result) @@ -1307,6 +1367,23 @@ Return two values: argument name, defaul (nreverse (arglist.keyword-args result))) result))
+(defun encode-arglist (decoded-arglist) + (append (arglist.required-args decoded-arglist) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))))) + (defun arglist-keywords (arglist) "Return the list of keywords in ARGLIST. As a secondary value, return whether &allow-other-keys appears." @@ -1323,7 +1400,8 @@ As a secondary value, return whether &al (multiple-value-bind (kw aok) (arglist-keywords (swank-mop:method-lambda-list method)) - (setq keywords (remove-duplicates (append keywords kw)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) allow-other-keys (or allow-other-keys aok)))) (values keywords allow-other-keys)))
@@ -1367,10 +1445,14 @@ whether &allow-other-keys appears somewh (princ arg)) (dolist (arg (arglist.optional-args decoded-arglist)) (space) - (format t "[~A]" arg)) - (dolist (keyword (arglist.keyword-args decoded-arglist)) + (format t "[~A]" (optional-arg.arg-name arg))) + (dolist (keyword-arg (arglist.keyword-args decoded-arglist)) (space) - (format t "~W ~A" keyword keyword)) + (let ((arg-name (keyword-arg.arg-name keyword-arg)) + (keyword (keyword-arg.keyword keyword-arg))) + (format t "~W ~A" + (if (keywordp keyword) keyword `',keyword) + arg-name))) (when (and (arglist.rest decoded-arglist) (or (not (arglist.keyword-args decoded-arglist)) (arglist.allow-other-keys-p decoded-arglist))) @@ -1381,8 +1463,9 @@ whether &allow-other-keys appears somewh (pprint-newline :fill))
(defgeneric extra-keywords (operator &rest args) - (:documentation "Return a list of extra keywords of OPERATOR (a symbol) -when applied to the (unevaluated) ARGS.")) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. As a secondary value, +return whether other keys are allowed."))
(defmethod extra-keywords (operator &rest args) ;; default method @@ -1401,20 +1484,51 @@ when applied to the (unevaluated) ARGS." (eq (car class-name-form) 'quote)) (let* ((class-name (cadr class-name-form)) (class (find-class class-name nil))) + (unless (swank-mop:class-finalized-p class) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (handler-case (swank-mop:finalize-inheritance class) + (program-error (c) + (declare (ignore c))))) (when class ;; We have the case (make-instance 'CLASS ...) ;; with a known CLASS. - (let ((slot-init-keywords - (loop for slot in (swank-mop:class-slots class) - append (swank-mop:slot-definition-initargs slot))) - (initialize-instance-keywords - (applicable-methods-keywords #'initialize-instance - (list class)))) - (return-from extra-keywords - (append slot-init-keywords - initialize-instance-keywords)))))))) + (multiple-value-bind (slots allow-other-keys-p) + (if (swank-mop:class-finalized-p class) + (values (swank-mop:class-slots class) nil) + (values (swank-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + initarg ; FIXME + (swank-mop:slot-definition-initform slot))) + (swank-mop:slot-definition-initargs slot)))) + (initialize-instance-keywords + (applicable-methods-keywords #'initialize-instance + (list class)))) + (return-from extra-keywords + (values (append slot-init-keywords + initialize-instance-keywords) + allow-other-keys-p))))))))) (call-next-method))
+(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + (multiple-value-bind (extra-keywords extra-aok) + (apply #'extra-keywords form) + ;; enrich the list of keywords with the extra keywords + (when extra-keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + extra-keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) extra-aok))) + decoded-arglist) + (defslimefun arglist-for-insertion (name) (with-buffer-syntax () (let ((symbol (parse-symbol name))) @@ -1426,18 +1540,18 @@ when applied to the (unevaluated) ARGS." ((member :not-available) :not-available) (list - (let ((decoded-arglist (decode-arglist arglist)) - (extra-keywords (extra-keywords symbol))) - ;; enrich the list of keywords with the extra keywords - (setf (arglist.keyword-args decoded-arglist) - (remove-duplicates - (append (arglist.keyword-args decoded-arglist) - extra-keywords))) + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (list symbol)) (decoded-arglist-to-template-string decoded-arglist *buffer-package*)))))) (t :not-available)))))
+(defvar *remove-keywords-alist* + '((:test :test-not) + (:test-not :test))) + (defun remove-actual-args (decoded-arglist actual-arglist) "Remove from DECODED-ARGLIST the arguments that have already been provided in ACTUAL-ARGLIST." @@ -1450,8 +1564,13 @@ provided in ACTUAL-ARGLIST." do (progn (pop actual-arglist) (pop (arglist.optional-args decoded-arglist)))) (loop for keyword in actual-arglist by #'cddr + for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*)) do (setf (arglist.keyword-args decoded-arglist) - (delete keyword (arglist.keyword-args decoded-arglist))))) + (remove-if (lambda (kw) + (or (eql kw keyword) + (member kw keywords-to-remove))) + (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword))))
(defslimefun complete-form (form-string) "Read FORM-STRING in the current buffer package, then complete it @@ -1469,13 +1588,8 @@ by adding a template for the missing arg ((member :not-available) :not-available) (list - (let ((decoded-arglist (decode-arglist arglist)) - (extra-keywords (apply #'extra-keywords form))) - ;; enrich the list of keywords with the extra keywords - (setf (arglist.keyword-args decoded-arglist) - (remove-duplicates - (append (arglist.keyword-args decoded-arglist) - extra-keywords))) + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist form) ;; get rid of formal args already provided (remove-actual-args decoded-arglist argument-forms) (return-from complete-form Index: swank-backend.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v retrieving revision 1.81 diff -u -p -r1.81 swank-backend.lisp --- swank-backend.lisp 28 Feb 2005 23:30:59 -0000 1.81 +++ swank-backend.lisp 6 Mar 2005 14:54:17 -0000 @@ -83,7 +83,8 @@ #:slot-definition-readers #:slot-definition-writers ;; generic function protocol - #:compute-applicable-methods-using-classes)) + #:compute-applicable-methods-using-classes + #:finalize-inheritance))
(in-package :swank-backend)
Matthias Koeppe mkoeppe+slime@mail.math.uni-magdeburg.de writes:
Hi,
I am sending a new patch that improves arglist display and slime-complete-form. This patch supersedes the one from my message of Feb 22, which has not made it into CVS yet.
I know it's late in the game to be asking this, but what's the complete-form command really used for?
The patch integrates the code for detecting extra keyword arguments for generic functions into the arglist display in the echo area, as suggested by Luke.
What I would really like is that if I type this:
CL-USER> (defclass foo () ((x :initarg :x) (y :initarg :y))) #<STANDARD-CLASS FOO> CL-USER> (make-instance 'foo
then slime-space arglist display shows this:
(make-instance 'foo &key x y)
basically for slime-space to generate output similarly to slime-complete-form. And if we had such good arglist display as this I wonder if slime-complete-form would still be neede?
-Luke (missing something!)
Luke Gorrie luke@synap.se writes:
I know it's late in the game to be asking this, but what's the complete-form command really used for?
I type an operator that has a complicated arglist. Slime-complete-form fills in a template for the arglist. I can C-M-f over the formal arguments and replace them with the actual args. I can C-M-k unneeded keyword arguments. When the actual args are complicated, I often let-bind them to the formal argument name instead, so I don't even have to modify the inserted template.
This is more efficient (and feels much less stupid) than looking at the echo area and typing in what is displayed there.
The patch integrates the code for detecting extra keyword arguments for generic functions into the arglist display in the echo area, as suggested by Luke.
What I would really like is that if I type this:
CL-USER> (defclass foo () ((x :initarg :x) (y :initarg :y))) #<STANDARD-CLASS FOO> CL-USER> (make-instance 'foo
then slime-space arglist display shows this:
(make-instance 'foo &key x y)
basically for slime-space to generate output similarly to slime-complete-form.
Yes, I also want this. It requires, however, a change in the protocol of ARGLIST-FOR-ECHO-AREA. Currently it only gets the list of nested operator names as strings. For the new functionality, we would also need the "nested operands" before point. And one needs to be more careful with READing the operands before point, so as not to INTERN too much. (Like for reading the operators, where SLIME uses PARSE-SYMBOL rather than READ.) Maybe someone would like to help here.
And if we had such good arglist display as this I wonder if slime-complete-form would still be neede?
Yes!
Cheers,
On Sun, 06 Mar 2005 21:28:37 +0100, Matthias Koeppe mkoeppe+slime@mail.math.uni-magdeburg.de wrote:
I type an operator that has a complicated arglist. Slime-complete-form fills in a template for the arglist.
How is that different from slime-insert-arglist?
Cheers, Edi.
Edi Weitz edi@agharta.de writes:
On Sun, 06 Mar 2005 21:28:37 +0100, Matthias Koeppe mkoeppe+slime@mail.math.uni-magdeburg.de wrote:
I type an operator that has a complicated arglist. Slime-complete-form fills in a template for the arglist.
How is that different from slime-insert-arglist?
It's different for functions with optional and keyword arguments, and when some arguments have already been typed in. Examples:
(subseq "abc" <C-c C-s> --inserts--> start [end]) (find 17 <C-c C-s> --inserts--> sequence :from-end from-end :test test :test-not test-not :start start :end end :key key) (find 17 '(17 18 19) :test #'= <C-c C-s> --inserts--> :from-end from-end :start start :end end :key key) (defclass foo () ((bar :initarg :bar))) (defmethod initialize-instance :after ((object foo) &key blub)) (make-instance 'foo <C-c C-s> --inserts--> :bar bar :blub blub initargs...) Cheers,
On Sun, 06 Mar 2005 22:52:52 +0100, Matthias Koeppe mkoeppe+slime@mail.math.uni-magdeburg.de wrote:
It's different for functions with optional and keyword arguments, and when some arguments have already been typed in. Examples:
(subseq "abc" <C-c C-s> --inserts--> start [end]) (find 17 <C-c C-s> --inserts--> sequence :from-end from-end :test test :test-not test-not :start start :end end :key key) (find 17 '(17 18 19) :test #'= <C-c C-s> --inserts--> :from-end from-end :start start :end end :key key) (defclass foo () ((bar :initarg :bar))) (defmethod initialize-instance :after ((object foo) &key blub)) (make-instance 'foo <C-c C-s> --inserts--> :bar bar :blub blub initargs...)
OK, thanks. Looks cool to me.
Matthias Koeppe mkoeppe+slime@mail.math.uni-magdeburg.de writes:
Luke Gorrie luke@synap.se writes:
I know it's late in the game to be asking this, but what's the complete-form command really used for?
I type an operator that has a complicated arglist. Slime-complete-form fills in a template for the arglist. I can C-M-f over the formal arguments and replace them with the actual args. I can C-M-k unneeded keyword arguments. When the actual args are complicated, I often let-bind them to the formal argument name instead, so I don't even have to modify the inserted template.
I committed the changes. I don't really understand the need for the command but I can believe it's one of those things that's obvious to CLOS programmers :-)
Cheers, Luke
Luke Gorrie luke@synap.se writes:
I committed the changes.
Thanks!
-
Edi Weitz -
Luke Gorrie -
Matthias Koeppe