[clim-desktop-cvs] CVS clim-desktop
thenriksen
thenriksen at common-lisp.net
Sun Apr 23 15:34:12 UTC 2006
Update of /project/clim-desktop/cvsroot/clim-desktop
In directory clnet:/tmp/cvs-serv22639
Modified Files:
swine.lisp swine-cmds.lisp
Log Message:
Added new position-aware parameter hinting and experimental class
initarg hinting for (make-instance)-forms. Requires recent Swank.
--- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/03/30 14:38:19 1.2
+++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/04/23 15:34:12 1.3
@@ -25,10 +25,23 @@
(in-package :climacs-lisp-syntax)
+;; Convenience functions:
+
(defun buffer-substring (buffer start end)
- "Convenience function."
+ "Return a string of the contents of buffer from `start' to
+`end'."
(coerce (buffer-sequence buffer start end) 'string))
+(defun unlisted (obj)
+ (if (listp obj)
+ (first obj)
+ obj))
+
+(defun listed (obj)
+ (if (listp obj)
+ obj
+ (list obj)))
+
(defun definition-at-mark (mark syntax)
"Return the text of the definition at mark."
(let ((m (clone-mark mark)))
@@ -419,21 +432,24 @@
(show-swine-note-counts notes (second result))
(when notes (show-swine-notes notes (name buffer) "")))))
-(defun split-lambda-list-on-keywords (lambda-list)
- "Return an alist keying lambda list keywords of `lambda-list'
+;;; Parameter hinting code.
+;;; -----------------------
+
+(defun split-arglist-on-keywords (arglist)
+ "Return an alist keying lambda list keywords of `arglist'
to the symbols affected by the keywords."
(let ((sing-result '())
- (env (position '&environment lambda-list)))
+ (env (position '&environment arglist)))
(when env
- (push (list '&environment (elt lambda-list (1+ env))) sing-result)
- (setf lambda-list (remove-if (constantly t) lambda-list :start env :end (+ env 2))))
- (when (eq '&whole (first lambda-list))
- (push (subseq lambda-list 0 2) sing-result)
- (setf lambda-list (cddr lambda-list)))
+ (push (list '&environment (elt arglist (1+ env))) sing-result)
+ (setf arglist (remove-if (constantly t) arglist :start env :end (+ env 2))))
+ (when (eq '&whole (first arglist))
+ (push (subseq arglist 0 2) sing-result)
+ (setf arglist (cddr arglist)))
(do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body))
- (args (if (member (first lambda-list) +cl-lambda-list-keywords+)
- lambda-list
- (cons '&mandatory lambda-list))
+ (args (if (member (first arglist) +cl-arglist-keywords+)
+ arglist
+ (cons '&mandatory arglist))
(cdr args))
(chunk '())
(result '()))
@@ -446,97 +462,410 @@
(setf chunk (list (car args))))
(push (car args) chunk)))))
-(defparameter +cl-lambda-list-keywords+
+(defparameter +cl-arglist-keywords+
'(&whole &optional &rest &key &allow-other-keys &aux &body &environment))
-(defun affected-symbols-in-arglist (arglist index &optional preceeding-arg)
- "Return a list of the symbols of `arglist' that would be
- affected by entering a new argument at position `index'. Index
- 0 is just after the operator and before any
- arguments. `Preceeding-arg' is either nil or a symbol of the
- argument preceeding the one about to be written. Only
- mandatory, &optional, &rest, &body and &key-arguments are
- supported, and complex argument lists from macros may not be
- interpreted correctly."
- (let ((split-arglist (split-lambda-list-on-keywords arglist)))
- (flet ((get-args (keyword)
- (rest (assoc keyword split-arglist))))
- (cond ((> (length (get-args '&mandatory))
- index)
+(defun find-optional-argument-values (arglist provided-args &optional
+ (split-arglist
+ (split-arglist-on-keywords
+ arglist)))
+ "Return an association list mapping symbols of optional or
+ keyword arguments from `arglist' to the specified values in
+ `provided-args'. `Split-arglist' should be either a split
+ arglist or nil, in which case it will be calculated from
+ `arglist'."
+ ;; First we check whether any optional arguments have even been
+ ;; provided.
+ (flet ((get-args (keyword)
+ (rest (assoc keyword split-arglist))))
+ (let* ((mandatory-args-count (length (get-args '&mandatory)))
+ (optional-args-count (length (get-args '&optional)))
+ (keyword-args-count (length (get-args '&key)))
+ (provided-args-count (length provided-args))
+ (nonmandatory-args-count (+ keyword-args-count
+ optional-args-count)))
+ (when (> provided-args-count
+ mandatory-args-count)
+ ;; We have optional arguments.
+ (let (
+ ;; Find the part of the provided arguments that concern
+ ;; optional arguments.
+ (opt-args-values (subseq provided-args
+ mandatory-args-count
+ (min provided-args-count
+ nonmandatory-args-count)))
+ ;; Find the part of the provided arguments that concern
+ ;; keyword arguments.
+ (keyword-args-values (subseq provided-args
+ (min (+ mandatory-args-count
+ optional-args-count)
+ provided-args-count))))
+ (append (mapcar #'cons
+ (get-args '&optional)
+ opt-args-values)
+
+ (loop
+ ;; Loop over the provided keyword symbols and
+ ;; values in the argument list. Note that
+ ;; little checking is done to ensure that the
+ ;; given symbols are valid - this is not a
+ ;; compiler, so extra mappings do not
+ ;; matter.
+ for (keyword value) on keyword-args-values by #'cddr
+ if (keywordp keyword)
+ collect (let ((argument-symbol
+ (unlisted (find (symbol-name keyword)
+ (get-args '&key)
+ :key #'(lambda (arg)
+ (symbol-name (unlisted arg)))
+ :test #'string=))))
+ ;; We have to find the associated
+ ;; symbol in the argument list... ugly.
+ (cons argument-symbol
+ value)))))))))
+
+(defun find-affected-simple-arguments (arglist current-arg-index preceding-arg
+ &optional (split-arglist (split-arglist-on-keywords arglist)))
+ "Find the simple arguments of `arglist' that would be affected
+ if an argument was intered at index `current-arg-index' in the
+ arglist. `Preceding-arg-key' should either be nil or the
+ argument directly preceding point. `Split-arglist' should
+ either be a split arglist or nil, in which case `split-arglist'
+ will be computed from `arglist'. This function returns two
+ values: The primary value is a list of symbols that should be
+ emphasized, the secondary value is a list of symbols that
+ should be highlighted."
+ (flet ((get-args (keyword)
+ (rest (assoc keyword split-arglist))))
+ (let ((mandatory-argument-count (length (get-args '&mandatory))))
+ (cond ((> mandatory-argument-count
+ current-arg-index)
;; We are in the main, mandatory, positional arguments.
- (list (elt (get-args '&mandatory) index)))
+ (let ((relevant-arg (elt (get-args '&mandatory)
+ current-arg-index)))
+ ;; We do not handle complex argument lists here, only
+ ;; pure standard arguments.
+ (unless (and (listp relevant-arg)
+ (< current-arg-index mandatory-argument-count))
+ (values nil (list (unlisted relevant-arg))))))
((> (+ (length (get-args '&optional))
(length (get-args '&mandatory)))
- index)
+ current-arg-index)
;; We are in the &optional arguments.
- (list (elt (get-args '&optional)
- (- index
- (length (get-args '&mandatory))))))
- ((let ((body-or-rest-args (or (get-args '&rest)
+ (values nil
+ (list (unlisted (elt (get-args '&optional)
+ (- current-arg-index
+ (length (get-args '&mandatory))))))))
+ (t
+ (let ((body-or-rest-args (or (get-args '&rest)
(get-args '&body)))
- (key-arg (find (symbol-name preceeding-arg)
+ (key-arg (find (format nil "~A" preceding-arg)
(get-args '&key)
:test #'string=
:key #'(lambda (arg)
- (symbol-name (if (listp arg)
- (first arg)
- arg))))))
+ (symbol-name (unlisted arg))))))
;; We are in the &body, &rest or &key arguments.
- (append (list key-arg)
- body-or-rest-args
- ;; Only highlight the &key
- ;; symbol if we are in a position to add a new
- ;; keyword-value pair, and not just in a position to
- ;; specify a value for a keyword.
- (when (and (null key-arg)
- (get-args '&key))
- '(&key)))))))))
+ (values
+ ;; Only emphasize the &key
+ ;; symbol if we are in a position to add a new
+ ;; keyword-value pair, and not just in a position to
+ ;; specify a value for a keyword.
+ (when (and (null key-arg)
+ (get-args '&key))
+ '(&key))
+ (append (when key-arg
+ (list (unlisted key-arg)))
+ body-or-rest-args))))))))
+
+(defun analyze-arglist-impl (arglist current-arg-indices preceding-arg provided-args)
+ "The implementation for `analyze-arglist'."
+ (let* ((split-arglist (split-arglist-on-keywords arglist))
+ (user-supplied-arg-values (find-optional-argument-values
+ arglist
+ provided-args
+ split-arglist))
+ (mandatory-argument-count
+ (length (rest (assoc '&mandatory split-arglist))))
+ (current-arg-index (or (first current-arg-indices) 0))
+ ret-arglist
+ emphasized-symbols
+ highlighted-symbols)
+ ;; First, we find any standard arguments that should be
+ ;; highlighted or emphasized, more complex, destructuring
+ ;; arguments will be handled specially.
+ (multiple-value-bind (es hs)
+ (find-affected-simple-arguments arglist
+ current-arg-index
+ preceding-arg
+ split-arglist)
+ (setf emphasized-symbols es)
+ (setf highlighted-symbols hs))
+ ;; We loop over the arglist and build a new list, and if we
+ ;; have a default value for a given argument, we insert it into
+ ;; the list. Also, whenever we encounter a list in a mandatory
+ ;; argument position, we assume that it is a destructuring
+ ;; arglist and recursively calls `analyze-arglist' on it
+ ;; to find the arglist and emphasized and highlighted symbols for
+ ;; it.
+ (labels ((generate-arglist (arglist)
+ (loop
+ for arg-element in arglist
+ for arg-name = (unlisted arg-element)
+ for index from 0
+
+ with in-&aux ; If non-NIL, we are in the
+ ; &aux parameters that should
+ ; not be displayed.
+
+ with in-&environment ; If non-NIL, the next
+ ; argument is an &environment
+ ; parameter that should not be
+ ; displayed.
+ if (eq arg-element '&aux)
+ do (setf in-&aux t)
+ else if (eq arg-element '&environment)
+ do (setf in-&environment t)
+ else if (and (listp arg-element)
+ (> mandatory-argument-count
+ index)
+ (not in-&environment)
+ (not in-&aux))
+ collect (multiple-value-bind (arglist
+ sublist-emphasized-symbols
+ sublist-highlighted-symbols)
+ (analyze-arglist arg-element
+ (rest current-arg-indices)
+ preceding-arg
+ (when (< index (length provided-args))
+ (listed (elt provided-args index))))
+ ;; Unless our `current-arg-index' actually
+ ;; refers to this sublist, its highlighted
+ ;; and emphasized symbols are ignored.
+ (if (= index current-arg-index)
+ (if (and (rest current-arg-indices))
+ (setf emphasized-symbols
+ (union (mapcar #'unlisted
+ sublist-emphasized-symbols)
+ emphasized-symbols)
+ highlighted-symbols
+ (union sublist-highlighted-symbols
+ highlighted-symbols))
+ (setf emphasized-symbols
+ (union (mapcar #'unlisted
+ arg-element)
+ emphasized-symbols))))
+ arglist)
+ else if (and (assoc arg-name user-supplied-arg-values)
+ (not in-&environment)
+ (not in-&aux))
+ collect (list arg-name
+ (rest (assoc
+ arg-name
+ user-supplied-arg-values)))
+ else
+ if in-&environment
+ do (setf in-&environment nil)
+ else if (not in-&aux)
+ collect arg-element)))
+ (setf ret-arglist (generate-arglist arglist)))
+ (list ret-arglist emphasized-symbols highlighted-symbols)))
+
+(defun analyze-arglist (arglist current-arg-indices
+ preceding-arg provided-args)
+ "Analyze argument list and provide information for highlighting
+it. `Arglist' is the argument list that is to be analyzed,
+`current-arg-index' is the index where the next argument would be
+written (0 is just after the operator), `preceding-arg' is the
+written argument preceding point and `provided-args' is a list of
+the args already written.
+
+Three values are returned:
+
+* An argument list with values for &optional and &key arguments
+inserted from `provided-args'.
+
+* A list of symbols that should be emphasized.
+
+* A list of symbols that should be highlighted."
+ (apply #'values (analyze-arglist-impl
+ arglist
+ current-arg-indices
+ preceding-arg
+ provided-args)))
+
+(defgeneric arglist-for-form (operator &optional arguments)
+ (:documentation
+ "Return an arglist for `operator'")
+ (:method (operator &optional arguments)
+ (declare (ignore arguments))
+ (swank::arglist operator)))
+
+;; Proof of concept, just to make sure it can be done. We probably
+;; shouldn't use Swank for this. Also, we need a more elegant
+;; interface. Perhaps it could be integrated with the indentation
+;; definition macros, in order to create some sort of
+;; `define-form-traits'-supermacro. That could be cool. Also, that way
+;; various libraries could trivially create a Climacs-extension-file
+;; containing calls to this super-macro that would make Climacs aware
+;; of the libraries indentation- and completion-needs.
+(defmethod arglist-for-form ((operator (eql 'cl:make-instance)) &optional arguments)
+ (let ((arglist (call-next-method)))
+ (if (and (plusp (length arguments))
+ (listp (first arguments))
+ (> (length (first arguments)) 1)
+ (eq (caar arguments) 'cl:quote))
+ (rest (read-from-string (swank::format-arglist-for-echo-area
+ (cons operator arguments)
+ operator)))
+ arglist)))
+
+(defun show-arglist-silent (symbol &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.
+
+`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.
-(defun show-arglist-silent (symbol &optional provided-args-count preceeding-arg)
+Returns NIL if an arglist cannot be displayed."
(when (fboundp symbol)
- (let* ((arglist (swank::arglist symbol))
- (affected-symbols (when provided-args-count
- (affected-symbols-in-arglist
- arglist
- provided-args-count
- preceeding-arg)))
- (arglist-display (apply #'concatenate 'string
- (format nil"(~A" symbol)
- (append (loop for arg in arglist
- for argno from 1
- if (member arg affected-symbols)
- collect (format nil " >~A<" arg)
- else
- collect (format nil " ~A" arg))
- (list ")")))))
- (esa:display-message arglist-display))))
+ (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
[144 lines skipped]
--- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/30 14:38:19 1.7
+++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/04/23 15:34:12 1.8
@@ -173,9 +173,16 @@
;; between the mark and the symbol.
(insert-character #\Space)
(backward-object mark)
- (let ((form (form-before syntax (offset mark))))
- (when form
- (show-arglist-for-form mark syntax form)))
+ ;; We must update the syntax in order to reflect any changes to
+ ;; 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,
+ ;; 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))))
(forward-object mark)
(clear-completions)))
More information about the Clim-desktop-cvs
mailing list