slynk-apropos.lisp (6982B)
1 (defpackage :slynk-apropos 2 (:use #:cl #:slynk-api) 3 (:export 4 #:apropos-list-for-emacs 5 #:*preferred-apropos-matcher*)) 6 7 (in-package :slynk-apropos) 8 9 (defparameter *preferred-apropos-matcher* 'make-cl-ppcre-matcher 10 "Preferred matcher for apropos searches. 11 Value is a function of three arguments , PATTERN, CASE-SENSITIVE and 12 SYMBOL-NAME-FN that should return a function, called MATCHER of one 13 argument, a SYMBOL. MATCHER should return non-nil if PATTERN somehow 14 matches the result of applying SYMBOL-NAME-FN to SYMBOL, according to 15 CASE-SENSITIVE. The non-nil return value can be a list of integer or 16 a list of lists of integers.") 17 18 (defslyfun apropos-list-for-emacs (pattern &optional external-only 19 case-sensitive package) 20 "Make an apropos search for Emacs. 21 The result is a list of property lists." 22 (let ((package (if package 23 (or (parse-package package) 24 (error "No such package: ~S" package))))) 25 ;; The MAPCAN will filter all uninteresting symbols, i.e. those 26 ;; who cannot be meaningfully described. 27 ;; 28 ;; *BUFFER-PACKAGE* is exceptionally set so that the symbol 29 ;; listing will only omit package qualifier iff the user specified 30 ;; PACKAGE. 31 (let* ((*buffer-package* (or package 32 slynk::*slynk-io-package*)) 33 (matcher (funcall *preferred-apropos-matcher* 34 pattern 35 case-sensitive)) 36 (seen (make-hash-table)) 37 result) 38 39 (do-all-symbols (sym) 40 (let ((external (symbol-external-p sym))) 41 (multiple-value-bind (bounds score) 42 (and 43 (symbol-package sym) ; see github#266 44 (funcall matcher 45 (if package 46 (string sym) 47 (concatenate 'string 48 (package-name (symbol-package sym)) 49 (if external ":" "::") 50 (symbol-name sym))))) 51 (unless (gethash sym seen) 52 (when bounds 53 (unless (or (and external-only 54 (not external)) 55 (and package 56 (not (eq package (symbol-package sym))))) 57 (push `(,sym :bounds ,bounds 58 ,@(and score `(:flex-score ,score)) 59 :external-p ,external) 60 result))) 61 (setf (gethash sym seen) t))))) 62 (loop for (symbol . extra) 63 in (sort result 64 (lambda (x y) 65 (let ((scorex (getf (cdr x) :flex-score)) 66 (scorey (getf (cdr y) :flex-score))) 67 (if (and scorex scorey) 68 (> scorex scorey) 69 (present-symbol-before-p (car x) (car y)))))) 70 for short = (briefly-describe-symbol-for-emacs 71 symbol (getf extra :external-p)) 72 for score = (getf extra :flex-score) 73 when score 74 do (setf (getf extra :flex-score) 75 (format nil "~2$%" 76 (* 100 score))) 77 do (remf extra :external-p) 78 when short 79 collect (append short extra))))) 80 81 (defun briefly-describe-symbol-for-emacs (symbol external-p) 82 "Return a property list describing SYMBOL. 83 Like `describe-symbol-for-emacs' but with at most one line per item." 84 (flet ((first-line (string) 85 (let ((pos (position #\newline string))) 86 (if (null pos) string (subseq string 0 pos))))) 87 (let ((desc (map-if #'stringp #'first-line 88 (slynk-backend:describe-symbol-for-emacs symbol)))) 89 (if desc 90 `(:designator ,(list (symbol-name symbol) 91 (let ((package (symbol-package symbol))) 92 (and package 93 (package-name package))) 94 external-p) 95 ,@desc 96 ,@(let ((arglist (and (fboundp symbol) 97 (slynk-backend:arglist symbol)))) 98 (when (and arglist 99 (not (eq arglist :not-available))) 100 `(:arglist ,(princ-to-string arglist))))))))) 101 102 (defun present-symbol-before-p (x y) 103 "Return true if X belongs before Y in a printed summary of symbols. 104 Sorted alphabetically by package name and then symbol name, except 105 that symbols accessible in the current package go first." 106 (declare (type symbol x y)) 107 (flet ((accessible (s) 108 ;; Test breaks on NIL for package that does not inherit it 109 (eq (find-symbol (symbol-name s) *buffer-package*) s))) 110 (let ((ax (accessible x)) (ay (accessible y))) 111 (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) 112 (ax t) 113 (ay nil) 114 (t (let ((px (symbol-package x)) (py (symbol-package y))) 115 (if (eq px py) 116 (string< (symbol-name x) (symbol-name y)) 117 (string< (package-name px) (package-name py))))))))) 118 119 (defun make-cl-ppcre-matcher (pattern case-sensitive) 120 (if (not (every #'alpha-char-p pattern)) 121 (cond ((find-package :cl-ppcre) 122 (background-message "Using CL-PPCRE for apropos on regexp \"~a\"" pattern) 123 124 (let ((matcher (funcall (read-from-string "cl-ppcre:create-scanner") 125 pattern 126 :case-insensitive-mode (not case-sensitive)))) 127 (lambda (symbol-name) 128 (multiple-value-bind (beg end) 129 (funcall (read-from-string "cl-ppcre:scan") 130 matcher 131 symbol-name) 132 (when beg `((,beg ,end))))))) 133 (t 134 (background-message "Using plain apropos. Load CL-PPCRE to enable regexps") 135 (make-plain-matcher pattern case-sensitive))) 136 (make-plain-matcher pattern case-sensitive))) 137 138 (defun make-plain-matcher (pattern case-sensitive) 139 (let ((chr= (if case-sensitive #'char= #'char-equal))) 140 (lambda (symbol-name) 141 (let ((beg (search pattern 142 symbol-name 143 :test chr=))) 144 (when beg 145 `((,beg ,(+ beg (length pattern))))))))) 146 147 (defun make-flex-matcher (pattern case-sensitive) 148 (if (zerop (length pattern)) 149 (make-plain-matcher pattern case-sensitive) 150 (let ((chr= (if case-sensitive #'char= #'char-equal))) 151 (lambda (symbol-name) 152 (slynk-completion:flex-matches 153 pattern symbol-name chr=))))) 154