clim-desktop-cvs

Download

clim-desktop-cvs@common-lisp.net

April 2006

1 participants
2 discussions

[clim-desktop-cvs] CVS clim-desktop
by thenriksen 30 Apr '06

30 Apr '06

Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv15722 Modified Files: swine.lisp Log Message: Make `definition-at-mark' behave as in SLIME (this probably requires more extensive redesign). --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/04/23 15:34:12 1.3 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/04/30 12:10:05 1.4 @@ -43,13 +43,15 @@ (list obj))) (defun definition-at-mark (mark syntax) - "Return the text of the definition at mark." - (let ((m (clone-mark mark))) - (end-of-definition m syntax) - (let ((end (offset m))) - (beginning-of-definition m syntax) - (buffer-substring (buffer mark) (offset m) end)))) - + "Return the text of the definition at mark." + (let* ((definition (form-toplevel (or (form-around syntax (offset mark)) + (form-after syntax (offset mark))) + syntax)) + (definition-pos (start-offset definition))) + (buffer-substring (buffer mark) + definition-pos + (end-offset definition)))) + (defun expression-at-mark (mark syntax) "Return the text of the expression at mark." (let ((m (clone-mark mark)))

1 0

[clim-desktop-cvs] CVS clim-desktop
by thenriksen 23 Apr '06

23 Apr '06

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

1 0