Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv3885
Modified Files:
lisp-syntax.lisp lisp-syntax-commands.lisp
Log Message:
Many changes, but CVS makes it too painful to break it up into smaller
patches (/me wishes for more modern VCS). The highlights are:
* Symbol completion should no longer nuke quoting.
* Symbol completion is now more intelligent with respect to
completion of keywords for keyword arguments.
* Changed some form selection functions to accept offsets as
well as marks (using the `as-offsets' macro).
* Realized that this syntax is becoming quite complex, slight
refactoring is needed.
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 22:12:04 1.96
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/23 20:31:56 1.97
@@ -1305,17 +1305,15 @@
found, return the package specified in the attribute list. If no
package can be found at all, or the otherwise found packages are
invalid, return the CLIM-USER package."
- (let* ((mark-offset (if (numberp mark-or-offset)
- mark-or-offset
- (offset mark-or-offset)))
- (designator (rest (find mark-offset (package-list syntax)
- :key #'first
- :test #'>=))))
- (or (handler-case (find-package designator)
- (type-error ()
+ (as-offsets ((mark-or-offset offset))
+ (let* ((designator (rest (find offset (package-list syntax)
+ :key #'first
+ :test #'>=))))
+ (or (handler-case (find-package designator)
+ (type-error ()
nil))
- (find-package (option-specified-package syntax))
- (find-package :clim-user))))
+ (find-package (option-specified-package syntax))
+ (find-package :clim-user)))))
(defmacro with-syntax-package (syntax offset (package-sym) &body
body)
@@ -1489,8 +1487,6 @@
(:method (form syntax) nil))
(defmethod form-operands ((form list-form) syntax)
- ;; If *anything' goes wrong, just assume that we could not find any
- ;; operands and return nil.
(mapcar #'(lambda (operand)
(if (typep operand 'form)
(token-to-object syntax operand :no-error t)))
@@ -1517,60 +1513,64 @@
;;;
;;; Useful functions for selecting forms based on the mark.
-(defun expression-at-mark (mark syntax)
- "Return the form at `mark'. If `mark' is just after,
+(defun expression-at-mark (mark-or-offset syntax)
+ "Return the form at `mark-or-offset'. If `mark-or-offset' is just after,
or inside, a top-level-form, or if there are no forms after
-`mark', the form preceding `mark' is returned. Otherwise, the
-form following `mark' is returned."
- (or (form-around syntax (offset mark))
- (form-after syntax (offset mark))
- (form-before syntax (offset mark))))
-
-(defun definition-at-mark (mark syntax)
- "Return the top-level form at `mark'. If `mark' is just after,
-or inside, a top-level-form, or if there are no forms after
-`mark', the top-level-form preceding `mark' is
-returned. Otherwise, the top-level-form following `mark' is
+`mark-or-offset', the form preceding `mark-or-offset' is
+returned. Otherwise, the form following `mark-or-offset' is
returned."
- (form-toplevel (expression-at-mark mark syntax) syntax))
+ (as-offsets ((mark-or-offset offset))
+ (or (form-around syntax offset)
+ (form-after syntax offset)
+ (form-before syntax offset))))
-(defun symbol-at-mark (mark syntax)
- "Return a symbol token at mark. This function will \"unwrap\"
- quote-forms in order to return the symbol token. If no symbol
- token can be found, NIL will be returned."
+(defun definition-at-mark (mark-or-offset syntax)
+ "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after,
+or inside, a top-level-form, or if there are no forms after
+`mark-or-offset', the top-level-form preceding `mark-or-offset'
+is returned. Otherwise, the top-level-form following
+`mark-or-offset' is returned."
+ (form-toplevel (expression-at-mark mark-or-offset syntax) syntax))
+
+(defun symbol-at-mark (mark-or-offset syntax)
+ "Return a symbol token at `mark-or-offset'. This function will
+ \"unwrap\" quote-forms in order to return the symbol token. If
+ no symbol token can be found, NIL will be returned."
(labels ((unwrap-form (form)
(cond ((typep form 'quote-form)
(unwrap-form (first-form (children form))))
((typep form 'complete-token-lexeme)
form))))
- (unwrap-form (expression-at-mark mark syntax))))
+ (unwrap-form (expression-at-mark mark-or-offset syntax))))
-(defun this-form (mark syntax)
- "Return a form at mark. This function defines which
+(defun this-form (mark-or-offset syntax)
+ "Return a form at `mark-or-offset'. This function defines which
forms the COM-FOO-this commands affect."
- (or (form-around syntax (offset mark))
- (form-before syntax (offset mark))))
-
-(defun preceding-form (mark syntax)
- "Return a form at mark."
- (or (form-before syntax (offset mark))
- (form-around syntax (offset mark))))
+ (as-offsets ((mark-or-offset offset))
+ (or (form-around syntax offset)
+ (form-before syntax offset))))
+
+(defun preceding-form (mark-or-offset syntax)
+ "Return a form at `mark-or-offset'."
+ (as-offsets ((mark-or-offset offset))
+ (or (form-before syntax offset)
+ (form-around syntax offset))))
(defun text-of-definition-at-mark (mark syntax)
"Return the text of the definition at mark."
(let ((definition (definition-at-mark mark syntax)))
(buffer-substring (buffer mark)
- (start-offset definition)
+ (start-offset definition)
(end-offset definition))))
-(defun text-of-expression-at-mark (mark syntax)
- "Return the text of the expression at mark."
- (let ((expression (expression-at-mark mark syntax)))
+(defun text-of-expression-at-mark (mark-or-offset syntax)
+ "Return the text of the expression at `mark-or-offset'."
+ (let ((expression (expression-at-mark mark-or-offset syntax)))
(token-string syntax expression)))
-(defun symbol-name-at-mark (mark syntax)
- "Return the text of the symbol at mark."
- (let ((token (symbol-at-mark mark syntax)))
+(defun symbol-name-at-mark (mark-or-offset syntax)
+ "Return the text of the symbol at `mark-or-offset'."
+ (let ((token (symbol-at-mark mark-or-offset syntax)))
(when token (token-string syntax token))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1581,8 +1581,7 @@
"Replace the symbol at `mark' with `string' and move `mark' to
after `string'."
(let ((token (symbol-at-mark mark syntax)))
- (unless (= (offset mark) (start-offset token))
- (backward-expression mark syntax 1 nil))
+ (setf (offset mark) (start-offset token))
(forward-kill-expression mark syntax)
(insert-sequence mark string)))
@@ -1844,15 +1843,15 @@
(should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset)
(= (the fixnum (start-offset parse-symbol)) point-offset))))
(if should-highlight
- (with-text-face (pane :bold)
- (display-parse-tree (car children) syntax pane))
- (display-parse-tree (car children) syntax pane))
+ (with-text-face (pane :bold)
+ (display-parse-tree (car children) syntax pane))
+ (display-parse-tree (car children) syntax pane))
(loop for child-list on (cdr children)
if (and should-highlight (null (cdr child-list))) do
- (with-text-face (pane :bold)
- (display-parse-tree (car child-list) syntax pane))
- else do
- (display-parse-tree (car child-list) syntax pane))))
+ (with-text-face (pane :bold)
+ (display-parse-tree (car child-list) syntax pane))
+ else do
+ (display-parse-tree (car child-list) syntax pane))))
(defmethod display-parse-tree ((parse-symbol incomplete-list-form) (syntax lisp-syntax) pane)
(let* ((children (children parse-symbol))
@@ -3559,44 +3558,42 @@
(defun find-operand-info (mark-or-offset syntax operator-form)
"Returns two values: The operand preceding `mark-or-offset' and
the path from `operator-form' to the operand."
- (let* ((offset (if (numberp mark-or-offset)
- mark-or-offset
- (offset mark-or-offset)))
- (preceding-arg-token (form-before syntax offset))
- (indexing-start-arg
- (let* ((candidate-before preceding-arg-token)
- (candidate-after (when (null candidate-before)
- (let ((after (form-after syntax offset)))
- (when after
- (parent after)))))
- (candidate-around (when (null candidate-after)
- (form-around syntax offset)))
- (candidate (or candidate-before
- candidate-after
- candidate-around)))
- (if (or (and candidate-before
- (typep candidate-before 'incomplete-list-form))
- (and (null candidate-before)
- (typep (or candidate-after candidate-around)
- 'list-form)))
- ;; HACK: We should not attempt to find the location of
- ;; the list form itself, so we create a new parser
- ;; symbol, attach the list form as a parent and try to
- ;; find the new symbol. That way we can get a list of
- ;; argument-indices to the first element of the list
- ;; form, even if it is empty or incomplete.
- (let ((obj (make-instance 'parser-symbol)))
- (setf (parent obj) candidate)
- obj)
- candidate)))
- (argument-indices (find-argument-indices-for-operand
- syntax
- indexing-start-arg
- operator-form))
- (preceding-arg-obj (when preceding-arg-token
- (token-to-object syntax preceding-arg-token
- :no-error t))))
- (values preceding-arg-obj argument-indices)))
+ (as-offsets ((mark-or-offset offset))
+ (let* ((preceding-arg-token (form-before syntax offset))
+ (indexing-start-arg
+ (let* ((candidate-before preceding-arg-token)
+ (candidate-after (when (null candidate-before)
+ (let ((after (form-after syntax offset)))
+ (when after
+ (parent after)))))
+ (candidate-around (when (null candidate-after)
+ (form-around syntax offset)))
+ (candidate (or candidate-before
+ candidate-after
+ candidate-around)))
+ (if (or (and candidate-before
+ (typep candidate-before 'incomplete-list-form))
+ (and (null candidate-before)
+ (typep (or candidate-after candidate-around)
+ 'list-form)))
+ ;; HACK: We should not attempt to find the location of
+ ;; the list form itself, so we create a new parser
+ ;; symbol, attach the list form as a parent and try to
+ ;; find the new symbol. That way we can get a list of
+ ;; argument-indices to the first element of the list
+ ;; form, even if it is empty or incomplete.
+ (let ((obj (make-instance 'parser-symbol)))
+ (setf (parent obj) candidate)
+ obj)
+ candidate)))
+ (argument-indices (find-argument-indices-for-operand
+ syntax
+ indexing-start-arg
+ operator-form))
+ (preceding-arg-obj (when preceding-arg-token
+ (token-to-object syntax preceding-arg-token
+ :no-error t))))
+ (values preceding-arg-obj argument-indices))))
(defun valid-operator-p (operator)
"Check whether or not `operator' is a valid
@@ -3654,9 +3651,9 @@
(when (parent form)
(recurse (parent form)))))
-(defmacro with-code-insight (mark syntax (&key operator preceding-operand
- form preceding-operand-indices
- operands)
+(defmacro with-code-insight (mark-or-offset 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
@@ -3669,7 +3666,7 @@
;; My kingdom for with-gensyms (or once-only)!
(mark-value-sym (gensym))
(syntax-value-sym (gensym)))
- `(let* ((,mark-value-sym ,mark)
+ `(let* ((,mark-value-sym ,mark-or-offset)
(,syntax-value-sym ,syntax)
(,form-sym
;; Find a form with a valid (fboundp) operator.
@@ -3683,35 +3680,38 @@
;; cannot find a form with a valid operator, just
;; return the form `mark' is in.
(unless (null immediate-form)
- (labels ((recurse (form)
- (unless (null (parent form))
- (or (unless (eq (first-form (children (parent form)))
- form)
- (recurse (parent form)))
- (and (valid-operator-p (form-operator
- form
- ,syntax-value-sym))
- (indices-match-arglist
- (arglist-for-form
- (form-operator
- form
- ,syntax-value-sym)
- (form-operands
- form
- ,syntax-value-sym))
- (second
- (multiple-value-list
- (find-operand-info ,mark-value-sym ,syntax-value-sym form))))
- (not (direct-arg-p form ,syntax-value-sym))
- form)))))
- (or (recurse (parent immediate-form))
- (parent immediate-form))))))
+ (labels ((recurse (form)
+ (unless (null (parent form))
+ (or (unless (eq (first-form (children (parent form)))
+ form)
+ (recurse (parent form)))
+ (and (valid-operator-p (form-operator
+ form
+ ,syntax-value-sym))
+ (indices-match-arglist
+ (arglist-for-form
+ (form-operator
+ form
+ ,syntax-value-sym)
+ (form-operands
+ form
+ ,syntax-value-sym))
+ (second
+ (multiple-value-list
+ (find-operand-info ,mark-value-sym ,syntax-value-sym form))))
+ (not (direct-arg-p form ,syntax-value-sym))
+ form)))))
+ (or (recurse (parent 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))))
+ (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym
+ ,operator-sym ,operands-sym))
(multiple-value-bind (,preceding-operand-sym ,operand-indices-sym)
(when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym))
+ (declare (ignorable ,preceding-operand-sym ,operand-indices-sym))
,@body))))
(defun show-arglist-for-form-at-mark (mark syntax)
@@ -3824,6 +3824,103 @@
(defvar *completion-pane* nil)
+(defun relevant-keywords (arglist arg-indices)
+ "Return a list of the keyword arguments that it would make
+ sense to use at the position `arg-indices' relative to the
+ operator that has the argument list `arglist'."
+ (let* ((key-position (position '&key arglist))
+ (cleaned-arglist (remove-if #'arglist-keyword-p
+ arglist))
+ (index (first arg-indices))
+ (difference (- (length arglist)
+ (length cleaned-arglist))))
+ (cond ((and (null key-position)
+ (rest arg-indices)
+ (> (length cleaned-arglist)
+ index)
+ (listp (elt cleaned-arglist index)))
+ ;; Look in a nested argument list.
+ (relevant-keywords (elt cleaned-arglist index)
+ (rest arg-indices)))
+ ((and (not (null key-position))
+ (>= (+ index
+ difference)
+ key-position)
+ (not (evenp (- index key-position difference))))
+ (mapcar #'unlisted (subseq cleaned-arglist
+ (- key-position
+ difference
+ -1)))))))
+
+(defun completions-from-keywords (syntax token)
+ "Assume that `token' is a (partial) keyword argument
+keyword. Find out which operator it is applicable to, and return
+a completion list based on the valid keywords, or NIL, if no
+keyword arguments would be valid (for example, if the operator
+doesn't take keyword arguments)."
+ (with-code-insight (start-offset token) syntax
+ (:preceding-operand-indices poi
+ :operator operator)
+ (when (valid-operator-p operator)
+ (let* ((relevant-keywords
+ (relevant-keywords (arglist-for-form operator)
+ poi))
+ (completions (simple-completions
+ (get-usable-image syntax)
+ (token-string syntax token)
+ +keyword-package+))
+ (relevant-completions
+ (remove-if-not #'(lambda (compl)
+ (member compl relevant-keywords
+ :test #'(lambda (a b)
+ (string-equal a b
+ :start1 1))
+ :key #'symbol-name))
+ (mapcar #'string-downcase (first completions)))))
+ (list relevant-completions
+ (longest-completion relevant-completions))))))
+
+;; The following stuff is from Swank.
+
+(defun longest-completion (completions)
+ "Return the longest completion of `completions', which must be a
+list of sequences."
[76 lines skipped]
--- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/21 06:15:40 1.9
+++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/23 20:31:56 1.10
@@ -254,11 +254,11 @@
(buffer (buffer pane))
(syntax (syntax buffer))
(mark (point pane))
- (name (symbol-name-at-mark mark
- syntax)))
- (when name
+ (token (symbol-at-mark mark
+ syntax)))
+ (when token
(with-syntax-package syntax mark (package)
- (let ((completion (show-completions syntax name package)))
+ (let ((completion (show-completions syntax token package)))
(unless (= (length completion) 0)
(replace-symbol-at-mark mark syntax completion)))))))
