[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