/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.465 by mbaringer, Sun Apr 8 11:12:23 2007 UTC revision 1.466 by mbaringer, Sun Apr 8 11:21:45 2007 UTC
# Line 2473  Fall back to the the current if no such Line 2473  Fall back to the the current if no such
2473        *package*))        *package*))
2474    
2475  (defun eval-for-emacs (form buffer-package id)  (defun eval-for-emacs (form buffer-package id)
2476    "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.    "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2477  Return the result to the continuation ID.  Return the result to the continuation ID.
2478  Errors are trapped and invoke our debugger."  Errors are trapped and invoke our debugger."
2479    (call-with-debugger-hook    (call-with-debugger-hook
# Line 3281  MATCHER is a two-argument predicate." Line 3281  MATCHER is a two-argument predicate."
3281                                   collect (package-name package)                                   collect (package-name package)
3282                                   append (package-nicknames package))))))                                   append (package-nicknames package))))))
3283    
3284    ;; PARSE-COMPLETION-ARGUMENTS return table:
3285    ;;
3286    ;;  user behaviour |  NAME  | PACKAGE-NAME | PACKAGE
3287    ;; ----------------+--------+--------------+-----------------------------------
3288    ;; asdf     [tab]  | "asdf" |     NIL      | #<PACKAGE "DEFAULT-PACKAGE-NAME">
3289    ;;                 |        |              |      or *BUFFER-PACKAGE*
3290    ;; asdf:    [tab]  |   ""   |    "asdf"    | #<PACKAGE "ASDF">
3291    ;;                 |        |              |
3292    ;; asdf:foo [tab]  | "foo"  |    "asdf"    | #<PACKAGE "ASDF">
3293    ;;                 |        |              |
3294    ;; as:fo    [tab]  |  "fo"  |     "as"     | NIL
3295    ;;                 |        |              |
3296    ;; :        [tab]  |   ""   |      ""      | #<PACKAGE "KEYWORD">
3297    ;;                 |        |              |
3298    ;; :foo     [tab]  | "foo"  |      ""      | #<PACKAGE "KEYWORD">
3299    ;;
3300  (defun parse-completion-arguments (string default-package-name)  (defun parse-completion-arguments (string default-package-name)
3301    "Parse STRING as a symbol designator.    "Parse STRING as a symbol designator.
3302  Return these values:  Return these values:
3303   SYMBOL-NAME   SYMBOL-NAME
3304   PACKAGE-NAME, or nil if the designator does not include an explicit package.   PACKAGE-NAME, or nil if the designator does not include an explicit package.
3305   PACKAGE, the package to complete in   PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
3306              NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
3307              if PACKAGE is non-NIL but a package cannot be found under that name,
3308              return NIL.)
3309   INTERNAL-P, if the symbol is qualified with `::'."   INTERNAL-P, if the symbol is qualified with `::'."
3310    (multiple-value-bind (name package-name internal-p)    (multiple-value-bind (name package-name internal-p)
3311        (tokenize-symbol string)        (tokenize-symbol string)
3312      (let ((package (carefully-find-package package-name default-package-name)))      (if package-name
3313        (values name package-name package internal-p))))          (let ((package (guess-package (if (equal package-name "")
3314                                              "KEYWORD"
3315                                              package-name))))
3316              (values name package-name package internal-p))
3317            (let ((package (guess-package default-package-name)))
3318              (values name package-name (or package *buffer-package*) internal-p))
3319            )))
3320    
 (defun carefully-find-package (name default-package-name)  
   "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the  
 *buffer-package*.  NAME and DEFAULT-PACKAGE-NAME can be nil."  
   (let ((string (cond ((equal name "") "KEYWORD")  
                       (t (or name default-package-name)))))  
     (or (and string (guess-package string))  
         *buffer-package*)))  
3321    
3322  ;;;;; Format completion results  ;;;;; Format completion results
3323  ;;;  ;;;
# Line 3479  be sorted by score, most likely match fi Line 3497  be sorted by score, most likely match fi
3497    
3498  The result is a list of completion objects, where a completion  The result is a list of completion objects, where a completion
3499  object is:  object is:
3500    
3501      (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)      (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
3502    
3503  where a CHUNK is a description of a matched substring:  where a CHUNK is a description of a matched substring:
3504    
3505      (OFFSET SUBSTRING)      (OFFSET SUBSTRING)
3506    
3507  and FLAGS is a list of keywords describing properties of the  and FLAGS is a list of keywords describing properties of the
3508  symbol (see CLASSIFY-SYMBOL).  symbol (see CLASSIFY-SYMBOL).
3509    
# Line 3506  designator's format. The cases are as fo Line 3528  designator's format. The cases are as fo
3528    ;; but then the network serialization were slower by handling arrays.    ;; but then the network serialization were slower by handling arrays.
3529    ;; Instead we limit the number of completions that is transferred    ;; Instead we limit the number of completions that is transferred
3530    ;; (the limit is set from emacs).    ;; (the limit is set from emacs).
3531    (coerce (fuzzy-completion-set string default-package-name    (coerce (fuzzy-completion-set string default-package-name :limit limit
3532                                  :limit limit :time-limit-in-msec time-limit-in-msec)                                  :time-limit-in-msec time-limit-in-msec)
3533            'list))            'list))
3534    
3535    
3536  (defun convert-fuzzy-completion-result (fuzzy-matching converter  ;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
3537                                          internal-p package-name)  ;;; object that will be sent back to Emacs, as described above.
3538    
3539    (defstruct (fuzzy-matching (:conc-name   fuzzy-matching.)
3540                               (:predicate   fuzzy-matching-p)
3541                               (:constructor %make-fuzzy-matching))
3542      symbol            ; The symbol that has been found to match.
3543      score             ; the higher the better symbol is a match.
3544      package-chunks    ; Chunks pertaining to the package identifier of the symbol.
3545      symbol-chunks)    ; Chunks pertaining to the symbol's name.
3546    
3547    (defun make-fuzzy-matching (symbol score package-chunks symbol-chunks)
3548      (%make-fuzzy-matching :symbol symbol :score score
3549                            :package-chunks package-chunks
3550                            :symbol-chunks symbol-chunks))
3551    
3552    
3553    (defun fuzzy-convert-matching-for-emacs (fuzzy-matching converter
3554                                             internal-p package-name)
3555    "Converts a result from the fuzzy completion core into    "Converts a result from the fuzzy completion core into
3556  something that emacs is expecting.  Converts symbols to strings,  something that emacs is expecting.  Converts symbols to strings,
3557  fixes case issues, and adds information describing if the symbol  fixes case issues, and adds information describing if the symbol
3558  is :bound, :fbound, a :class, a :macro, a :generic-function,  is :bound, :fbound, a :class, a :macro, a :generic-function,
3559  a :special-operator, or a :package."  a :special-operator, or a :package."
3560    (destructuring-bind (symbol score chunks) fuzzy-matching    (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching
3561      (multiple-value-bind (name added-length)      (multiple-value-bind (name added-length)
3562          (format-completion-result          (format-completion-result
3563            (funcall (or converter #'identity) (symbol-name symbol))            (funcall (or converter #'identity) (symbol-name symbol))
3564            internal-p package-name)            internal-p package-name)
3565        (list name        (list name
3566              score              score
3567              (mapcar #'(lambda (chunk)              (append package-chunks
3568                          ;; fix up chunk positions to account for possible                      (mapcar #'(lambda (chunk)
3569                          ;; added package identifier                                  ;; fix up chunk positions to account for possible
3570                          (list (+ added-length (first chunk))                                  ;; added package identifier.
3571                                (second chunk)))                                  (let ((offset (first chunk)) (string (second chunk)))
3572                      chunks)                                    (list (+ added-length offset) string)))
3573                                symbol-chunks))
3574              (classify-symbol symbol)))))              (classify-symbol symbol)))))
3575    
3576  (defun classify-symbol (symbol)  (defun classify-symbol (symbol)
# Line 3552  keywords: :BOUNDP, :FBOUNDP, :GENERIC-FU Line 3592  keywords: :BOUNDP, :FBOUNDP, :GENERIC-FU
3592        (push :generic-function result))        (push :generic-function result))
3593      result))      result))
3594    
3595    
3596  (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)  (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
3597    "Prepares list of completion objects, sorted by SCORE, of fuzzy    "Prepares list of completion objects, sorted by SCORE, of fuzzy
3598  completions of STRING in DEFAULT-PACKAGE-NAME.  If LIMIT is set,  completions of STRING in DEFAULT-PACKAGE-NAME.  If LIMIT is set,
3599  only the top LIMIT results will be returned."  only the top LIMIT results will be returned."
3600    (declare (type (or null (integer 0 #.(1- most-positive-fixnum))) limit time-limit-in-msec))    (check-type (values limit time-limit-in-msec)
3601    (multiple-value-bind (name package-name package internal-p)                (or null (integer 0 #.(1- most-positive-fixnum))))
3602        (parse-completion-arguments string default-package-name)    (let* ((completion-set (fuzzy-create-completion-set string default-package-name
3603      (flet ((convert (vector &optional converter)                                                        time-limit-in-msec)))
              (when vector  
                (map-into vector  
                          #'(lambda (fuzzy-matching)  
                              (convert-fuzzy-completion-result fuzzy-matching converter  
                                                               internal-p package-name))  
                          vector))))  
       (let* ((symbols (and package  
                            (fuzzy-find-matching-symbols name package  
                                                         :time-limit-in-msec time-limit-in-msec  
                                                         :external-only (and (not internal-p)  
                                                                             package-name))))  
              (packages (and (not package-name)  
                          (fuzzy-find-matching-packages name)))  
              (results))  
         (convert symbols  (completion-output-symbol-converter string))  
         (convert packages #'(lambda (package-name)  
                               (let ((converter (completion-output-package-converter string)))  
                                 ;; Present packages with a trailing colon for maximum convenience!  
                                 (concatenate 'string (funcall converter package-name) ":"))))  
         ;; Sort alphabetically before sorting by score. (Especially useful when  
         ;; STRING is empty, and SYMBOLS is a list of all possible completions.)  
         (setf results (sort (concatenate 'vector symbols packages) #'string-lessp :key #'first))  
         (setf results (stable-sort results #'> :key #'second))  
3604          (when (and limit          (when (and limit
3605                     (> limit 0)                     (> limit 0)
3606                     (< limit (length results)))                     (< limit (length completion-set)))
3607            (if (array-has-fill-pointer-p results)            (if (array-has-fill-pointer-p completion-set)
3608                (setf (fill-pointer results) limit)                (setf (fill-pointer completion-set) limit)
3609                (setf results (make-array limit :displaced-to results))))                (setf completion-set (make-array limit :displaced-to completion-set))))
3610          results))))      completion-set))
3611    
3612    
3613    (defun fuzzy-create-completion-set (string default-package-name time-limit-in-msec)
3614      "Does all the hard work for FUZZY-COMPLETION-SET."
3615      (multiple-value-bind (parsed-name parsed-package-name package internal-p)
3616          (parse-completion-arguments string default-package-name)
3617        (flet ((convert (matchings package-name &optional converter)
3618                 ;; Converts MATCHINGS to completion objects for Emacs.
3619                 ;; PACKAGE-NAME is the package identifier that's used as prefix
3620                 ;; during formatting. If NIL, the identifier is omitted.
3621                 (map-into matchings
3622                           #'(lambda (m)
3623                               (fuzzy-convert-matching-for-emacs m converter
3624                                                                 internal-p
3625                                                                 package-name))
3626                           matchings))
3627               (fix-up (matchings parent-package-matching)
3628                 ;; The components of each matching in MATCHINGS have been computed
3629                 ;; relative to PARENT-PACKAGE-MATCHING. Make them absolute.
3630                 (let* ((p parent-package-matching)
3631                        (p.score  (fuzzy-matching.score p))
3632                        (p.chunks (fuzzy-matching.package-chunks p)))
3633                   (map-into matchings
3634                             #'(lambda (m)
3635                                 (let ((m.score (fuzzy-matching.score m)))
3636                                   (setf (fuzzy-matching.package-chunks m) p.chunks)
3637                                   (setf (fuzzy-matching.score m)
3638                                         (if (string= parsed-name "")
3639                                             ;; (make packages be sorted before their symbol
3640                                             ;; matchings while preserving over all orderness
3641                                             ;; among different symbols in different packages)
3642                                             (/ p.score 100)
3643                                             (+ p.score m.score)))
3644                                   m))
3645                             matchings)))
3646               (find-matchings (designator package)
3647                 (fuzzy-find-matching-symbols designator package
3648                                              :time-limit-in-msec time-limit-in-msec
3649                                              :external-only (not internal-p))))
3650          (let ((symbol-normalizer  (completion-output-symbol-converter string))
3651                (package-normalizer #'(lambda (package-name)
3652                                        (let ((converter (completion-output-package-converter string)))
3653                                          ;; Present packages with a trailing colon for maximum convenience!
3654                                          (concatenate 'string (funcall converter package-name) ":"))))
3655                (symbols) (packages) (results))
3656            (cond ((not parsed-package-name)        ; STRING = "asd"
3657                   ;; We don't know if user is searching for a package or a symbol
3658                   ;; within his current package. So we try to find either.
3659                   (setf symbols  (find-matchings parsed-name package)
3660                         symbols  (convert symbols nil symbol-normalizer)
3661                         packages (fuzzy-find-matching-packages parsed-name)
3662                         packages (convert packages nil package-normalizer)))
3663                  ((string= parsed-package-name "") ; STRING = ":" or ":foo"
3664                   (setf symbols (find-matchings parsed-name package)
3665                         symbols (convert symbols "" symbol-normalizer)))
3666                  (t                                ; STRING= "asdf:" or "asdf:foo"
3667                   ;; Find fuzzy matchings of the denoted package identifier part.
3668                   ;; After that find matchings for the denoted symbol identifier
3669                   ;; relative to all those packages found.
3670                   (loop
3671                      with found-packages = (fuzzy-find-matching-packages parsed-package-name)
3672                      for package-matching across found-packages
3673                      do
3674                      (let* ((pkgsym       (fuzzy-matching.symbol package-matching))
3675                             (package-name (symbol-name pkgsym))
3676                             (package-name (funcall symbol-normalizer package-name))
3677                             (matchings (find-matchings parsed-name (find-package pkgsym))))
3678                        (setf matchings (fix-up matchings package-matching))
3679                        (setf matchings (convert matchings package-name symbol-normalizer))
3680                        (setf symbols   (concatenate 'vector symbols matchings)))
3681                      finally ; CONVERT is destructive. So we have to do this at last.
3682                      (when (string= parsed-name "")
3683                        (setf packages (convert found-packages nil package-normalizer))))))
3684            ;; Sort alphabetically before sorting by score. (Especially useful when
3685            ;; PARSED-NAME is empty, and all possible completions are to be returned.)
3686            (setf results (concatenate 'vector symbols packages))
3687            (setf results (sort results #'string-lessp :key #'first))
3688            (setf results (stable-sort results #'> :key #'second))
3689            results))))
3690    
3691    
3692  (defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec)  (defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec)
3693    "Returns a vector of fuzzy matchings (that is a list of the symbol in    "Returns a vector of fuzzy matchings for matching symbols in PACKAGE,
3694  PACKAGE that's matching STRING, its score, and a list of its completion  using the fuzzy completion algorithm. If EXTERNAL-ONLY is true, only
3695  chunks), using the fuzzy completion algorithm. If EXTERNAL-ONLY is true,  external symbols are considered."
 only external symbols are considered."  
3696    (let ((completions (make-array 256 :adjustable t :fill-pointer 0))    (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
3697          (converter (completion-output-symbol-converter string))          (converter (completion-output-symbol-converter string))
3698          (time-limit (if time-limit-in-msec          (time-limit (if time-limit-in-msec
# Line 3607  only external symbols are considered." Line 3704  only external symbols are considered."
3704      (declare (type function converter))      (declare (type function converter))
3705      (flet ((time-exhausted-p ()      (flet ((time-exhausted-p ()
3706               (and (not (zerop time-limit))               (and (not (zerop time-limit))
3707                    (zerop (mod count 256))  ; ease up on calling get-universal-time like crazy                    (zerop (mod count 256)) ; ease up on calling get-universal-time like crazy
3708                    (incf count)                    (incf count)
3709                    (>= (- (get-universal-time) utime-at-start) time-limit)))                    (>= (- (get-universal-time) utime-at-start) time-limit)))
3710             (perform-fuzzy-match (string symbol-name)             (perform-fuzzy-match (string symbol-name)
# Line 3618  only external symbols are considered." Line 3715  only external symbols are considered."
3715            (do-symbols* (symbol package)            (do-symbols* (symbol package)
3716              (when (time-exhausted-p) (return-from loop))              (when (time-exhausted-p) (return-from loop))
3717              (when (or (not external-only) (symbol-external-p symbol package))              (when (or (not external-only) (symbol-external-p symbol package))
3718                (if (string= "" string)                (if (string= "" string)
3719                    (vector-push-extend (list symbol 0.0 (list (list 0 ""))) completions)                    (vector-push-extend (make-fuzzy-matching symbol 0.0 '() '())
3720                                          completions) ; create vanilla matching.
3721                    (multiple-value-bind (match-result score)                    (multiple-value-bind (match-result score)
3722                        (perform-fuzzy-match string (symbol-name symbol))                        (perform-fuzzy-match string (symbol-name symbol))
3723                      (when match-result                      (when match-result
3724                        (vector-push-extend (list symbol score match-result) completions)))))))))))                        (vector-push-extend (make-fuzzy-matching symbol score '() match-result)
3725                                              completions)))))))))))
3726    
3727    
3728  (defun fuzzy-find-matching-packages (name)  (defun fuzzy-find-matching-packages (name)
3729    "Returns a vector of relevant fuzzy matchings (that is a list    "Returns a vector of fuzzy matchings for each package that
3730  consisting of a symbol representing the package that matches NAME,  is similiar to NAME."
 its score, and its completions chunks.)"  
3731    (let ((converter (completion-output-package-converter name))    (let ((converter (completion-output-package-converter name))
3732          (completions (make-array 32 :adjustable t :fill-pointer 0)))          (completions (make-array 32 :adjustable t :fill-pointer 0)))
3733      (declare ;;(optimize (speed 3))      (declare ;;(optimize (speed 3))
# Line 3641  its score, and its completions chunks.)" Line 3740  its score, and its completions chunks.)"
3740            for (result score) = (multiple-value-list            ;  too invasive.            for (result score) = (multiple-value-list            ;  too invasive.
3741                                     (compute-highest-scoring-completion                                     (compute-highest-scoring-completion
3742                                      name converted-name))                                      name converted-name))
3743            ;; We return a symbol that represents the package, a) to make            when result do (vector-push-extend
3744            ;; the type of the returned value consistent with the one of                             (make-fuzzy-matching package-symbol score result '())
3745            ;; FUZZY-FIND-MATCHING-SYMBOLS, and b) to be able to call                             completions))
           ;; CLASSIFY-SYMBOL upon it later on.  
           when result do  
           (vector-push-extend (list package-symbol score result) completions))  
3746      completions))      completions))
3747    
3748    
3749  (defslimefun fuzzy-completion-selected (original-string completion)  (defslimefun fuzzy-completion-selected (original-string completion)
3750    "This function is called by Slime when a fuzzy completion is    "This function is called by Slime when a fuzzy completion is
3751  selected by the user.  It is for future expansion to make  selected by the user.  It is for future expansion to make
# Line 3662  user selected." Line 3759  user selected."
3759    (declare (ignore original-string completion))    (declare (ignore original-string completion))
3760    nil)    nil)
3761    
3762    
3763  ;;;;; Fuzzy completion core  ;;;;; Fuzzy completion core
3764    
3765  (defparameter *fuzzy-recursion-soft-limit* 30  (defparameter *fuzzy-recursion-soft-limit* 30
# Line 3773  onto the special variable *ALL-CHUNKS* a Line 3871  onto the special variable *ALL-CHUNKS* a
3871            (push rev-chunks *all-chunks*)            (push rev-chunks *all-chunks*)
3872            rev-chunks))))            rev-chunks))))
3873    
3874    
3875  ;;;;; Fuzzy completion scoring  ;;;;; Fuzzy completion scoring
3876    
3877  (defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"  (defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"

Legend:
Removed from v.1.465  
changed lines
  Added in v.1.466

  ViewVC Help
Powered by ViewVC 1.1.5