[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Fri Sep 15 22:34:25 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv7529
Modified Files:
utils.lisp packages.lisp lisp-syntax.lisp
lisp-syntax-swine.lisp
Log Message:
Added new utility function (`list-aref'), added Lisp parser
recognition of incomplete quote forms, added support for "blank"
completion in Lisp syntax, so you no longer need to complete from a
symbol, but can get a list of all (applicable) completions. Is very,
very slow when listing all possible symbols due to the "slow" McCLIM
menu implementation.
--- /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:32 1.1
+++ /project/climacs/cvsroot/climacs/utils.lisp 2006/09/15 22:34:24 1.2
@@ -48,4 +48,10 @@
(defun listed (obj)
(if (listp obj)
obj
- (list obj)))
\ No newline at end of file
+ (list obj)))
+
+(defun list-aref (list &rest subscripts)
+ (if subscripts
+ (apply #'list-aref (nth (first subscripts) list)
+ (rest subscripts))
+ list))
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/12 19:49:18 1.119
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/15 22:34:24 1.120
@@ -32,7 +32,8 @@
#:once-only
#:unlisted
#:fully-unlisted
- #:listed))
+ #:listed
+ #:list-aref))
(defpackage :climacs-buffer
(:use :clim-lisp :flexichain :binseq)
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/12 17:24:56 1.115
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/15 22:34:24 1.116
@@ -981,7 +981,7 @@
;;; parse trees
(defclass token-form (form token-mixin) ())
(defclass complete-token-form (token-form) ())
-(defclass incomplete-token-form (token-form) ())
+(defclass incomplete-token-form (token-form incomplete-form-mixin) ())
(define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ())
(define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ())
@@ -1002,6 +1002,8 @@
;;; parse trees
(defclass quote-form (form) ())
+(defclass complete-quote-form (quote-form) ())
+(defclass incomplete-quote-form (quote-form incomplete-form-mixin) ())
(define-parser-state |' | (form-may-follow) ())
(define-parser-state |' form | (lexer-toplevel-state parser-state) ())
@@ -1009,16 +1011,25 @@
(define-new-lisp-state (form-may-follow quote-lexeme) |' |)
(define-new-lisp-state (|' | form) |' form |)
(define-new-lisp-state (|' | comment) |' |)
-
+(define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |)
;;; reduce according to the rule form -> ' form
(define-lisp-action (|' form | t)
- (reduce-until-type quote-form quote-lexeme))
+ (reduce-until-type complete-quote-form quote-lexeme))
+
+(define-lisp-action (|' | right-parenthesis-lexeme)
+ (reduce-until-type incomplete-quote-form quote-lexeme))
+(define-lisp-action (|' | unmatched-right-parenthesis-lexeme)
+ (reduce-until-type incomplete-quote-form quote-lexeme))
+(define-lisp-action (|' | (eql nil))
+ (reduce-until-type incomplete-quote-form quote-lexeme))
;;;;;;;;;;;;;;;; Backquote
;;; parse trees
(defclass backquote-form (form) ())
+(defclass complete-backquote-form (backquote-form) ())
+(defclass incomplete-backquote-form (backquote-form incomplete-form-mixin) ())
(define-parser-state |` | (form-may-follow) ())
(define-parser-state |` form | (lexer-toplevel-state parser-state) ())
@@ -1026,10 +1037,18 @@
(define-new-lisp-state (form-may-follow backquote-lexeme) |` |)
(define-new-lisp-state (|` | form) |` form |)
(define-new-lisp-state (|` | comment) |` |)
+(define-new-lisp-state (|` | unmatched-right-parenthesis-lexeme) |( form* ) |)
;;; reduce according to the rule form -> ` form
(define-lisp-action (|` form | t)
- (reduce-until-type backquote-form backquote-lexeme))
+ (reduce-until-type complete-backquote-form backquote-lexeme))
+
+(define-lisp-action (|` | right-parenthesis-lexeme)
+ (reduce-until-type incomplete-backquote-form backquote-lexeme))
+(define-lisp-action (|` | unmatched-right-parenthesis-lexeme)
+ (reduce-until-type incomplete-backquote-form backquote-lexeme))
+(define-lisp-action (|` | (eql nil))
+ (reduce-until-type incomplete-backquote-form backquote-lexeme))
;;;;;;;;;;;;;;;; Comma
@@ -2412,7 +2431,7 @@
incomplete tokens. This function may signal an error if
`no-error' is nil and `token' cannot be converted to a Lisp
object. Otherwise, nil will be returned.")
- (:method :around (syntax token &rest args &key no-error package quote read)
+ (:method :around (syntax (token t) &rest args &key no-error package quote read)
;; Ensure that every symbol that is READ will be looked up
;; in the correct package. Also handle quoting.
(flet ((act ()
@@ -2479,9 +2498,14 @@
(declare (ignore no-error))
(read-from-string (token-string syntax token)))
-(defmethod token-to-object (syntax (token quote-form) &rest args)
+(defmethod token-to-object (syntax (token complete-quote-form) &rest args)
(apply #'token-to-object syntax (second (children token)) :quote t args))
+(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args)
+ (declare (ignore args))
+ ;; Utterly arbitrary, but reasonable in my opinion.
+ '(quote))
+
;; I'm not sure backquotes are handled correctly, but then again,
;; `token-to-object' is not meant to be a perfect Lisp reader, only a
;; convenience function.
--- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 19:49:18 1.8
+++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/15 22:34:24 1.9
@@ -339,9 +339,9 @@
(defun find-argument-indices-for-operand (syntax operand-form operator-form)
"Return a list of argument indices for `argument-form' relative
to `operator-form'. These lists take the form of (n m p), which
- means (aref form-operand-list n m p). A list of
- argument indices can have arbitrary length (but they are
- practically always at most 2 elements long). "
+ means (list-aref form-operand-list n m p). A list of argument
+ indices can have arbitrary length (but they are practically
+ always at most 2 elements long). "
(declare (ignore syntax))
(let ((operator (first-form (children operator-form))))
(labels ((worker (operand-form &optional the-first)
@@ -482,15 +482,16 @@
argument. Return NIL if none can be found."
;; The algorithm for finding the applicable form:
;;
- ;; From `arg-form', we wander up the tree looking enclosing forms,
- ;; until we find a a form with an operator, the form-operator, that
- ;; has `arg-form' as a direct argument (this is checked by comparing
- ;; argument indices for `arg-form', relative to form-operator, with
- ;; the arglist ofform-operator). However, if form-operator itself is
- ;; a direct argument to one of its parents, we ignore it (unless
- ;; form-operators form-operator is itself a direct argument,
- ;; etc). This is so we can properly handle nested/destructuring
- ;; argument lists such as those found in macros.
+ ;; From `arg-form', we wander up the tree looking at enclosing
+ ;; forms, until we find a a form with an operator, the
+ ;; form-operator, that has `arg-form' as a direct argument (this is
+ ;; checked by comparing argument indices for `arg-form', relative to
+ ;; form-operator, with the arglist ofform-operator). However, if
+ ;; form-operator itself is a direct argument to one of its parents,
+ ;; we ignore it (unless form-operators form-operator is itself a
+ ;; direct argument, etc). This is so we can properly handle
+ ;; nested/destructuring argument lists such as those found in
+ ;; macros.
(labels ((recurse (candidate-form)
(when (parent candidate-form)
(if (and (direct-arg-p syntax (first-form (children candidate-form))
@@ -531,40 +532,48 @@
difference)
(if rest-position 2 1))))))))
-(defgeneric possible-completions (syntax operator token operands indices)
+(defgeneric possible-completions (syntax operator string package operands indices)
(:documentation "Get the applicable completions for completing
- `token' (which should be a token-lexeme), which is part of a
- form with the operator `operator' (which should be a valid
- operator object), and which has the operands
- `operands'. `Indices' should be the argument indices from the
- operator to `token' (see
- `find-argument-indices-for-operands').")
- (:method :around (syntax operator token operands indices)
- (declare (ignore syntax operator token operands indices))
- (with-syntax-package (syntax (start-offset token))
- (call-next-method)))
- (:method (syntax operator token operands indices)
+`string' (which should a string of the, possibly partial, symbol
+name to be completed) in `package', which is part of a form with
+the operator `operator' (which should be a valid operator
+object), and which has the operands `operands'. `Indices' should
+be the argument indices from the operator to `token' (see
+`find-argument-indices-for-operands').")
+ (:method (syntax operator string package operands indices)
(let ((completions (first (simple-completions (get-usable-image syntax)
- (token-string syntax (fully-unquoted-form token))
- (package-at-mark syntax (start-offset token))))))
+ string package))))
+ ;; Welcome to the ugly mess! Part of the uglyness is that we
+ ;; depend on Swank do to our nonobvious completion (m-v-b ->
+ ;; multiple-value-bind).
(or (when (valid-operator-p operator)
(let* ((relevant-keywords
(relevant-keywords (arglist-for-form syntax operator operands) indices))
- (relevant-completions
- (remove-if-not #'(lambda (compl)
- (member compl relevant-keywords
- :test #'(lambda (a b)
- (string-equal a b
- :start1 1))
- :key #'(lambda (s)
- (symbol-name (fully-unlisted s)))))
- (mapcar #'string-downcase completions))))
- relevant-completions))
+ (keyword-completions (mapcar #'(lambda (a)
+ (string-downcase (format nil ":~A" a)))
+ relevant-keywords)))
+ (when relevant-keywords
+ ;; We need Swank to get the concrete list of
+ ;; possibilities, but after that, we need to filter
+ ;; out anything that is not a relevant keyword
+ ;; argument. ALSO, if `string' is blank, Swank will
+ ;; "helpfully" not put any keyword symbols in
+ ;; `completions', thus ruining this entire scheme. SO,
+ ;; we have to force Swank to give us a list of keyword
+ ;; symbols and use that instead of `completions'. Joy!
+ (intersection (mapcar #'string-downcase
+ (if (string= string "")
+ (first (simple-completions (get-usable-image syntax)
+ ":" package))
+ completions))
+ keyword-completions
+ :key #'string-downcase
+ :test #'string=))))
completions))))
-(defgeneric complete-argument-of-type (argument-type syntax token all-completions)
+(defgeneric complete-argument-of-type (argument-type syntax string all-completions)
(:documentation "")
- (:method (argument-type syntax token all-completions)
+ (:method (argument-type syntax string all-completions)
all-completions))
(defgeneric modify-argument-list (argument-type syntax arglist arguments arg-position)
@@ -612,11 +621,14 @@
(remove-method #'modify-argument-list method)))))))
(define-argument-type class-name ()
- (:completion (syntax token all-completions)
- (loop for completion in all-completions
- when (find-class (ignore-errors (read-from-string completion))
- nil)
- collect completion))
+ (:completion (syntax string all-completions)
+ (let ((all-lower (every #'lower-case-p string)))
+ (loop for completion in all-completions
+ when (find-class (ignore-errors (read-from-string completion))
+ nil)
+ collect (if all-lower
+ (string-downcase completion)
+ completion))))
(:arglist-modification (syntax arglist arguments arg-position)
(if (and (> (length arguments) arg-position)
(listp (elt arguments arg-position))
@@ -630,10 +642,11 @@
arglist)))
(define-argument-type package-designator ()
- (:completion (syntax token all-completions)
+ (:completion (syntax string all-completions)
(declare (ignore all-completions))
- (let* ((string (token-string syntax token))
- (keyworded (char= (aref string 0) #\:)))
+ (let ((keyworded (and (plusp (length string))
+ (char= (aref string 0) #\:)))
+ (all-upper (every #'upper-case-p string)))
(loop for package in (list-all-packages)
for package-name = (if keyworded
(concatenate 'string ":" (package-name package))
@@ -642,7 +655,7 @@
:test #'char-equal
:end2 (min (length string)
(length package-name)))
- collect (if (every #'upper-case-p string)
+ collect (if all-upper
package-name
(string-downcase package-name))))))
@@ -666,48 +679,53 @@
;; FIXME: This macro should also define indentation rules.
(labels ((process-keyword-arg-descs (arguments)
;; We expect `arguments' to be a plist mapping keyword
- ;; symbols to type/class designators/names. We use a
- ;; `case' form to map from the keyword preceding the
- ;; symbol to be completed, to the code that generates the
- ;; possible completions.
+ ;; symbols to type/class designators/names.
`((t
- (let* ((keyword (token-to-object syntax (form-before syntax (1- (start-offset token)))))
+ (let* ((keyword-indices (loop
+ for (car . cdr) on indices
+ if (null cdr)
+ collect (1+ car)
+ else collect car))
+ (keyword (apply #'list-aref operands keyword-indices))
(type (getf ',arguments keyword)))
(if (null type)
(call-next-method)
- (complete-argument-of-type type syntax token all-completions))))))
+ (complete-argument-of-type type syntax string all-completions))))))
(process-arg-descs (arguments index)
(let ((argument (first arguments)))
- (cond ((null arguments)
+ (cond ((null argument)
nil)
((eq argument '&rest)
`(((>= (first indices) ,index)
- (complete-argument-of-type ',(second arguments) syntax token all-completions))))
+ (complete-argument-of-type ',(second arguments) syntax string all-completions))))
((eq argument '&key)
(process-keyword-arg-descs (rest arguments)))
((listp argument)
- `(((= (first indices) ,index)
- ,(if (eq (first argument) 'quote)
- `(cond ((form-quoted-p token)
- (complete-argument-of-type ',(second argument) syntax token all-completions))
- (t (call-next-method)))
- `(cond ((not (null (rest indices)))
- (pop indices)
- (cond ,@(build-completions-cond-body argument)))
- (t (call-next-method)))))))
+ (cons `((= (first indices) ,index)
+ ,(if (eq (first argument) 'quote)
+ `(cond ((eq (first (apply #'list-aref operands indices)) 'quote)
+ (complete-argument-of-type ',(second argument) syntax string all-completions))
+ (t (call-next-method)))
+ `(cond ((not (null (rest indices)))
+ (pop indices)
+ (cond ,@(build-completions-cond-body argument)))
+ (t (call-next-method)))))
+ (process-arg-descs (rest arguments)
+ (1+ index))))
(t
(cons `((= (first indices) ,index)
- (complete-argument-of-type ',argument syntax token all-completions))
+ (complete-argument-of-type ',argument syntax string all-completions))
(process-arg-descs (rest arguments)
(1+ index)))))))
(build-completions-cond-body (arguments)
(append (process-arg-descs arguments 0)
'((t (call-next-method))))))
`(progn
- (defmethod possible-completions (syntax (operator (eql ',operator)) token operands indices)
+ (defmethod possible-completions (syntax (operator (eql ',operator)) string package operands indices)
,(if no-typed-completion
'(call-next-method)
- `(let ((all-completions (call-next-method)))
+ `(let* ((*package* package)
+ (all-completions (call-next-method)))
(cond ,@(build-completions-cond-body arguments)))))
,(unless no-smart-arglist
`(defmethod arglist-for-form (syntax (operator (eql ',operator)) &optional arguments)
@@ -758,7 +776,8 @@
;; up any of this stuff.
(,operator-sym (when ,form-sym (token-to-object ,syntax (form-operator ,syntax ,form-sym))))
(,operands-sym (when ,form-sym (mapcar #'(lambda (operand)
- (token-to-object ,syntax operand))
+ (when operand
+ (token-to-object ,syntax operand)))
(form-operands ,syntax ,form-sym)))))
(declare (ignorable ,form-sym ,operator-sym ,operands-sym))
(multiple-value-bind (,preceding-operand-sym ,operand-indices-sym)
@@ -1361,65 +1380,77 @@
(delete-window completions-pane)
(setf completions-pane nil))))
-(defun find-completion-by-fn (fn symbol package)
- (esa:display-message (format nil "~a completions" symbol))
- (let* ((result (funcall fn symbol (package-name package)))
- (set (first result))
- (longest (second result)))
- (values longest set)))
-
-(defun find-completion (syntax token)
- (let* ((symbol-name (token-string syntax token))
- (result (with-code-insight (start-offset token) syntax
+(defun find-completions (syntax mark-or-offset string)
+ "Find completions for the symbol denoted by the string `string'
+at `mark-or-offset'. Two values will be returned: the common
+leading string of the completions and a list of the possible
+completions as strings."
+ (let* ((result (with-code-insight mark-or-offset syntax
(:operator operator
:operands operands
:preceding-operand-indices indices)
- (let ((completions (possible-completions syntax operator token operands indices)))
+ (let ((completions (possible-completions
+ syntax operator string
+ (package-at-mark syntax mark-or-offset)
+ operands indices)))
(list completions (longest-completion completions)))))
(set (first result))
(longest (second result)))
- (esa:display-message (format nil "~a completions" symbol-name))
(values longest set)))
-(defun find-fuzzy-completion (syntax token package)
- (let ((symbol-name (token-string syntax token)))
- (esa:display-message (format nil "~a completions" symbol-name))
- (let* ((set (fuzzy-completions (get-usable-image syntax) symbol-name package 10))
- (best (caar set)))
- (values best set))))
+(defun find-fuzzy-completions (syntax mark-or-offset string)
+ "Find completions for the symbol denoted by the string
+`string' at `mark-or-offset'. Two values will be returned: the
+common leading string of the completions and a list of the
+possible completions as strings. This function uses fuzzy logic
+to find completions based on `string'."
+ (let* ((set (fuzzy-completions (get-usable-image syntax) string
+ (package-at-mark syntax mark-or-offset)
+ 10))
+ (best (caar set)))
+ (values best set)))
-(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completion))
+(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completions))
"Attempt to find and complete the symbol at `mark' using the
function `fn' to get the list of completions. If the completion
is ambiguous, a list of possible completions will be
displayed. If no symbol can be found at `mark', return nil."
- (let ((token (form-around syntax (offset mark))))
- (when (and (not (null token))
- (form-token-p token)
- (not (= (start-offset token)
- (offset mark))))
- (multiple-value-bind (longest completions)
- (funcall fn syntax (fully-quoted-form token))
- (if (> (length longest) 0)
- (if (= (length completions) 1)
- (replace-symbol-at-mark mark syntax longest)
- (progn
- (esa:display-message (format nil "Longest is ~a|" longest))
- (let ((selection (menu-choose (mapcar
- ;; FIXME: this can
- ;; get ugly.
- #'(lambda (completion)
- (if (listp completion)
- (cons completion
- (first completion))
- completion))
- completions)
- :label "Possible completions"
- :scroll-bars :vertical)))
- (replace-symbol-at-mark mark syntax (or selection
- longest)))))
- (esa:display-message "No completions found")))
- t)))
+ (let* ((token (form-around syntax (offset mark)))
+ (useful-token (and (not (null token))
+ (form-token-p token)
+ (not (= (start-offset token)
+ (offset mark))))))
+ (multiple-value-bind (longest completions)
+ (funcall fn syntax
+ (if useful-token
+ (start-offset (fully-quoted-form token))
+ (if (form-quoted-p token)
+ (start-offset token)
+ (offset mark)))
+ (if useful-token
+ (token-string syntax token)
+ ""))
+ (if completions
+ (if (= (length completions) 1)
+ (replace-symbol-at-mark mark syntax longest)
+ (progn
+ (esa:display-message (format nil "Longest is ~a|" longest))
+ (let ((selection (menu-choose (mapcar
+ ;; FIXME: this can
+ ;; get ugly.
+ #'(lambda (completion)
+ (if (listp completion)
+ (cons completion
+ (first completion))
+ completion))
+ completions)
+ :label "Possible completions"
+ :scroll-bars :vertical)))
+ (if useful-token
+ (replace-symbol-at-mark mark syntax (or selection longest))
+ (insert-sequence mark (or selection longest))))))
+ (esa:display-message "No completions found")))
+ t))
(defun complete-symbol-at-mark (syntax mark)
"Attempt to find and complete the symbol at `mark'. If the
@@ -1432,4 +1463,4 @@
completion. If the completion is ambiguous, a list of possible
completions will be displayed. If no symbol can be found at
`mark', return nil."
- (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completion))
+ (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completions))
More information about the Climacs-cvs
mailing list