Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv28292

Modified Files: swine.lisp swine-cmds.lisp Log Message: * Cleaned some of the mechanics of the parameter hinting code, factored some of the hairy bits to a reusable `with-code-insight'-macro.

* Begun the construction of a form traits protocol for customizing the parameter hinting of forms.

* Fixed handling of values for &optional parameters with default values.

* Added parameter hinting for ((lambda (...) ...) ...)-style forms. :-)

--- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/20 17:30:30 1.9 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/28 12:26:08 1.10 @@ -449,7 +449,7 @@ optional-args-count) provided-args-count)))) (append (mapcar #'cons - (get-args '&optional) + (mapcar #'unlisted (get-args '&optional)) opt-args-values)

(loop @@ -667,57 +667,81 @@ operator))) arglist)))

-(defun show-arglist-silent (symbol &optional +(defmethod arglist-for-form ((operator list) &optional arguments) + (declare (ignore arguments)) + (case (first operator) + ('cl:lambda (second operator)))) + +(defgeneric operator-for-display (operator) + (:documentation "Return what should be displayed whenever + `operator' is displayed as an operator.") + (:method (operator) + operator)) + +(defmethod operator-for-display ((operator list)) + (case (first operator) + ('cl:lambda '|Lambda-Expression|))) + +(defun display-arglist-to-stream (stream operator arglist + &optional emphasized-symbols + highlighted-symbols) + "Display the operator and arglist to stream, format as + appropriate." + ;; FIXME: This is fairly ugly. + (labels ((display-symbol (symbol) + (with-text-style + (stream + `(nil + ,(cond ((member symbol + highlighted-symbols) + :bold) + ((member symbol + emphasized-symbols) + :italic)) + nil)) + (format stream "~A" symbol))) + (display-list (list) + (if (and (eq (first list) 'quote) + (= (length list) 2)) + (progn + (format stream "'") + (display-argument (second list))) + (progn + (format stream "(") + (display-argument (first list)) + (dolist (arg (rest list)) + (format stream " ") + (display-argument arg)) + (format stream ")")))) + (display-argument (arg) + (if (and (listp arg) + (not (null arg))) + (display-list arg) + (display-symbol arg)))) + (display-argument (cons (operator-for-display operator) + arglist)))) + +(defun show-arglist-silent (operator &optional current-arg-indices preceding-arg arguments) - "Display the arglist for `symbol' in the minibuffer, do not -complain if `symbol' is not bound to a function. + "Display the arglist for `operator' in the minibuffer, do not +complain if `operator' is not bound to, or is not, a function.

`Current-arg-index' and `preceding-arg' are used to add extra information to the arglist display. `Arguments' should be either nil or a list of provided arguments in the form housing symbol.

Returns NIL if an arglist cannot be displayed." - (when (fboundp symbol) - (multiple-value-bind (arglist emphasized-symbols highlighted-symbols) - (analyze-arglist - (arglist-for-form symbol arguments) - current-arg-indices - preceding-arg - arguments) - ;; FIXME: This is fairly ugly. - (esa:with-minibuffer-stream (minibuffer) - (labels ((display-symbol (symbol) - (with-text-style - (minibuffer - `(nil - ,(cond ((member symbol - highlighted-symbols) - :bold) - ((member symbol - emphasized-symbols) - :italic)) - nil)) - (format minibuffer "~A" symbol))) - (display-list (list) - (if (and (eq (first list) 'quote) - (= (length list) 2)) - (progn - (format minibuffer "'") - (display-argument (second list))) - (progn - (format minibuffer "(") - (display-argument (first list)) - (dolist (arg (rest list)) - (format minibuffer " ") - (display-argument arg)) - (format minibuffer ")")))) - (display-argument (arg) - (if (and (listp arg) - (not (null arg))) - (display-list arg) - (display-symbol arg)))) - (display-argument (cons symbol arglist))))))) + (multiple-value-bind (arglist emphasized-symbols highlighted-symbols) + (analyze-arglist + (arglist-for-form operator arguments) + current-arg-indices + preceding-arg + arguments) + (esa:with-minibuffer-stream (minibuffer) + (display-arglist-to-stream minibuffer operator + arglist emphasized-symbols + highlighted-symbols))))

(defun show-arglist (symbol name) (unless (show-arglist-silent symbol) @@ -795,30 +819,74 @@ :no-error t)))) (values preceding-arg-obj argument-indices)))

+(defun valid-operator-p (operator) + "Check whether or not `operator' is a valid + operator. `Operator' is considered a valid operator if it is a + symbol bound to a function." + (and (symbolp operator) + (fboundp operator))) + +(defmacro with-code-insight (mark syntax (&key operator preceding-operand + form preceding-operand-indices + operands) + &body body) + "Evaluate `body' with the provided symbols lexically bound to + interesting details about the code at `mark'. If `mark' is not + within a form, everything will be bound to nil." + (let ((operator-sym (or operator (gensym))) + (preceding-operand-sym (or preceding-operand (gensym))) + (operands-sym (or operands (gensym))) + (form-sym (or form (gensym))) + (operand-indices-sym (or preceding-operand-indices (gensym))) + ;; My kingdom for with-gensyms! + (mark-value-sym (gensym)) + (syntax-value-sym (gensym))) + `(let* ((,mark-value-sym ,mark) + (,syntax-value-sym ,syntax) + (,form-sym + ;; Find a form with a valid (fboundp) operator. + (let ((immediate-form + (or (form-before ,syntax-value-sym (offset ,mark-value-sym)) + (form-around ,syntax-value-sym (offset ,mark-value-sym))))) + ;; Recurse upwards until we find a form with a valid + ;; operator. This could be improved a lot, as we could + ;; inspect the lambda list of the found operator and + ;; check if the position of mark makes sense with + ;; regard to the structure of the lambda list. If we + ;; cannot find a form with a valid operator, just + ;; return the form `mark' is in. + (labels ((recurse (form) + (if (valid-operator-p (form-operator + form + ,syntax-value-sym)) + form + (when (and form (parent form)) + (recurse (parent form)))))) + (or (recurse (when immediate-form (parent immediate-form))) + (when immediate-form (parent immediate-form)))))) + ;; If we cannot find a form, there's no point in looking + ;; up any of this stuff. + (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym))) + (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym)))) + (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) + (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym)) + ,@body)))) + ;; This is a generic function in order to facilitate different lambda ;; list types for different form types (I'm not yet sure when this ;; would be useful). -(defgeneric show-arglist-for-form (mark syntax form) +(defgeneric show-arglist-for-form (mark syntax) (:documentation "Display the argument list for the operator of `form'. The list need not be complete. If an argument list cannot be retrieved for the operator, nothing will be displayed."))

-(defmethod show-arglist-for-form (mark syntax form) - (let* ((operator-symbol (form-operator form syntax))) - ;; The user may have provided an invalid function name as the - ;; operator - that should not result in an error. - (if (ignore-errors (fboundp operator-symbol)) - (let* ((form-operands (form-operands form syntax))) - (multiple-value-bind (preceding-operand preceding-operand-indices) - (find-operand-info mark syntax form) - (show-arglist-silent operator-symbol - preceding-operand-indices - preceding-operand - form-operands))) - ;; If the symbol is not bound to a function, we move up - ;; a level and try that lists operator. - (when (parent form) - (show-arglist-for-form mark syntax (parent form)))))) +(defmethod show-arglist-for-form (mark syntax) + (with-code-insight mark syntax (:operator operator + :preceding-operand preceding-operand + :preceding-operand-indices preceding-operand-indices + :operands operands) + ;; The operator is not something usable (it might be a lambda form). + (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))

(defparameter *swine-find-definition-stack* '())

--- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/05/20 17:30:30 1.15 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/05/28 12:26:08 1.16 @@ -221,12 +221,9 @@ ;; the parse tree our insertion of a space character may have ;; done. (update-syntax (buffer syntax) syntax) - ;; Try to find the argument before point, if that is not possibly, + ;; Try to find the argument before point, if that is not possible, ;; find the form that point is in. - (let ((immediate-form (or (form-before syntax (offset mark)) - (form-around syntax (offset mark))))) - (when immediate-form - (show-arglist-for-form mark syntax (parent immediate-form)))) + (show-arglist-for-form mark syntax) (forward-object mark) (clear-completions)))