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)))
