[clim-desktop-cvs] CVS clim-desktop
thenriksen
thenriksen at common-lisp.net
Thu Mar 30 14:38:19 UTC 2006
Update of /project/clim-desktop/cvsroot/clim-desktop
In directory clnet:/tmp/cvs-serv14319
Modified Files:
swine.lisp swine-cmds.lisp
Log Message:
Improved the arglist lookup code with hints about which argument point
is at.
--- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/01/06 03:15:45 1.1.1.1
+++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/03/30 14:38:19 1.2
@@ -45,7 +45,6 @@
(backward-expression m syntax)
(buffer-substring (buffer mark) (offset m) end))))
-
(defun symbol-name-at-mark (mark syntax)
"Return the text of the symbol at mark."
(let ((potential-form (or (form-around syntax (offset mark))
@@ -95,16 +94,10 @@
(setf (offset mark) (start-offset parent)))))))
(defun enclosing-list-first-word (mark syntax)
- "Return the text of the expression at mark."
- (cond
- ((in-type-p mark syntax 'list-form)
- (let ((m (clone-mark mark)))
- (when (backward-up-list-no-error m syntax)
- (let ((begin (offset m)))
- (re-search-forward m " |
-")
- (buffer-substring (buffer mark) (1+ begin) (1- (offset m)))))))
- (t nil)))
+ "Return the text of the expression at mark. Mark need not be in
+a complete list form."
+ ;; This is not very fast, but fast enough.
+ (first (reverse (enclosing-operator-names-at-mark mark syntax))))
(defun macroexpand-with-swank (mark syntax &optional (all nil))
(with-slots (package) syntax
@@ -426,6 +419,129 @@
(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'
+to the symbols affected by the keywords."
+ (let ((sing-result '())
+ (env (position '&environment lambda-list)))
+ (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)))
+ (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))
+ (cdr args))
+ (chunk '())
+ (result '()))
+ ((null args)
+ (when chunk (push (nreverse chunk) result))
+ (nreverse (nconc sing-result result)))
+ (if (member (car args) llk)
+ (progn
+ (when chunk (push (nreverse chunk) result))
+ (setf chunk (list (car args))))
+ (push (car args) chunk)))))
+
+(defparameter +cl-lambda-list-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)
+ ;; We are in the main, mandatory, positional arguments.
+ (list (elt (get-args '&mandatory) index)))
+ ((> (+ (length (get-args '&optional))
+ (length (get-args '&mandatory)))
+ 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)
+ (get-args '&body)))
+ (key-arg (find (symbol-name preceeding-arg)
+ (get-args '&key)
+ :test #'string=
+ :key #'(lambda (arg)
+ (symbol-name (if (listp arg)
+ (first arg)
+ 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)))))))))
+
+(defun show-arglist-silent (symbol &optional provided-args-count preceeding-arg)
+ (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))))
+
+(defun show-arglist (symbol name)
+ (unless (show-arglist-silent symbol)
+ (esa:display-message "Function ~a not found." name)))
+
+;; This is a generic function in order to facilitate different
+;; argument list types for different form types (I'm not yet sure when
+;; this would be useful).
+(defgeneric show-arglist-for-form (mark syntax form)
+ (: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-token (second (children form)))
+ (function-symbol (when operator-token
+ (token-to-symbol syntax operator-token))))
+ (if (fboundp function-symbol)
+ (let* ((mark-form (form-before syntax (offset mark)))
+ (argument-elt-position (position mark-form
+ (children form)))
+ (argument-position (when argument-elt-position
+ (1- argument-elt-position)))
+ (preceding-symbol (token-to-symbol syntax mark-form)))
+ (show-arglist-silent function-symbol
+ argument-position
+ preceding-symbol))
+ ;; 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))))))
+
(defparameter *swine-find-definition-stack* '())
(defun pop-find-definition-stack ()
--- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/17 23:54:04 1.6
+++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/30 14:38:19 1.7
@@ -141,25 +141,17 @@
(closure:visit url))))
(esa:set-key 'com-hyperspec-lookup
- 'lisp-table
- '((#\c :control) (#\d :control) (#\h)))
+ 'lisp-table
+ '((#\c :control) (#\d :control) (#\h)))
-
-(defun show-arglist-silent (symbol)
- (if (fboundp symbol)
- (let ((arglist (swank::arglist symbol)))
- (esa:display-message (format nil "(~A~{ ~A~})" symbol arglist))
- t)
- nil))
-
-(defun show-arglist (symbol name)
- (unless (show-arglist-silent symbol)
- (esa:display-message "Function ~a not found." name)))
-
-(define-command (com-arglist-lookup :name t :command-table lisp-table) ()
- (let* ((name (string-upcase (or (symbol-name-at-mark (point (current-window))
+(define-command (com-arglist-lookup :name t :command-table lisp-table)
+ ((symbol 'symbol :prompt "Symbol"))
+ "Show argument list for given symbol. If the provided argument
+is nil, this command will attempt to find a token at point."
+ (let* ((name (string-upcase (or symbol
+ (symbol-name-at-mark (point (current-window))
(syntax (buffer (current-window))))
- (accept 'string :prompt "Arglist lookup for symbol")))))
+ (accept 'symbol :prompt "Symbol")))))
(with-slots (package) (syntax (buffer (current-window)))
(let ((function-symbol (let* ((pos2 (position #\: name :from-end t))
(pos1 (if (and pos2 (char= (elt name (1- pos2)) #\:)) (1- pos2) pos2) ))
@@ -167,49 +159,25 @@
(find-symbol name (or package *package*))))))
(show-arglist function-symbol (string-upcase name))))))
-(esa:set-key 'com-arglist-lookup
- 'lisp-table
- '((#\c :control) (#\d :control) (#\a)))
-
-
+(esa:set-key '(com-arglist-lookup nil)
+ 'lisp-table
+ '((#\c :control) (#\d :control) (#\a)))
(define-command (com-swine-space :name t :command-table lisp-table)
()
- (let ((mark (point (current-window))))
+ (let* ((window (current-window))
+ (mark (point window))
+ (syntax (syntax (buffer window))))
;; It is important that the space is inserted before we look up
;; any symbols, but at the same time, there must not be a space
;; between the mark and the symbol.
(insert-character #\Space)
(backward-object mark)
- (let* ((name (string-upcase (or (enclosing-list-first-word
- mark
- (syntax (buffer (current-window))))
- (symbol-name-at-mark
- mark
- (syntax (buffer (current-window))))))))
- (when name
- (with-slots (package) (syntax (buffer (current-window)))
- (let ((function-symbol (let* ((pos2 (position #\: name :from-end t))
- (pos1 (if (and pos2
- ;; If the first
- ;; element of
- ;; the list is
- ;; a keyword
- ;; symbol, pos2
- ;; might be 0.
- (plusp pos2)
- (char= (elt name (1- pos2)) #\:))
- (1- pos2) pos2)))
- (handler-case (if pos1 (find-symbol (subseq name (1+ pos2)) (subseq name 0 pos1))
- (find-symbol name (or package *package*)))
- (package-error (e)
- ;; The specified symbol is in
- ;; an invalid package.
- (declare (ignore e))
- nil)))))
- (show-arglist-silent function-symbol))))
- (forward-object mark)
- (clear-completions))))
+ (let ((form (form-before syntax (offset mark))))
+ (when form
+ (show-arglist-for-form mark syntax form)))
+ (forward-object mark)
+ (clear-completions)))
(esa:set-key 'com-swine-space
'lisp-table
More information about the Clim-desktop-cvs
mailing list