Improved and regex-capable apropos

* sly.el (sly-apropos-symbol): New button type.
(sly-apropos-designator-string, sly-apropos-insert-symbol): New
function.
(sly-print-apropos): Rewritten. Uses more buttons.
(sly-insert-xrefs): Add `sly-location' property to area near xref
button.

* lib/lisp/swank-backend.lisp (make-cl-ppcre-matcher)
(make-plain-matcher): New functions.
(make-apropos-matcher): Redesigned.

* lib/lisp/swank.lisp (apropos-list-for-emacs): Rewrittern with
for new retval of APROPOS-SYMBOLS.
(briefly-describe-symbol-for-emacs): Designator is now a triplet.
(apropos-symbols): Rewrite. Returns a list of lists.

lib/lisp/swank-backend.lisp

@@ -869,23 +869,37 @@ TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
 
 Return a documentation string, or NIL if none is available.")
 
-(definterface make-apropos-matcher (pattern &optional case-sensitive include-qualifier)
-  "Produce a function that looks for PATTERN in symbol names.
-CASE-SENSITIVE indicates case-sensitivity.  INCLUDE-QUALIFIER
-indicates if the package's name should be included in the search."
+(defun make-cl-ppcre-matcher (pattern case-sensitive symbol-name-fn)
+  (lambda (symbol)
+    (funcall (read-from-string "cl-ppcre:scan")
+             (funcall (read-from-string "cl-ppcre:create-scanner")
+                       pattern
+                      :case-insensitive-mode (not case-sensitive))
+             (funcall symbol-name-fn symbol))))
+
+(defun make-plain-matcher (pattern case-sensitive symbol-name-fn)
   (let ((chr= (if case-sensitive #'char= #'char-equal)))
     (lambda (symbol)
       (search pattern
-              (cond (include-qualifier
-                     (concatenate 'string
-                                  (package-name (symbol-package symbol))
-                                  (if (eq :external
-                                          (find-symbol (symbol-name symbol)
-                                                       (symbol-package symbol)))
-                                      ":" "::")
-                                  (symbol-name symbol)))
-                    (t
-                     (string symbol))) :test chr=))))
+              (funcall symbol-name-fn symbol)
+              :test chr=))))
+
+(definterface make-apropos-matcher (pattern symbol-name-fn
+                                            &optional
+                                            case-sensitive)
+  "Produce a function that looks for PATTERN in symbol names.
+SYMBOL-NAME-FN must be applied to symbol-names to produce the string
+where PATTERN should be searched for.  CASE-SENSITIVE indicates
+case-sensitivity. On a positive match, the function returned must
+return non-nil values, which may be pairs of indexes to highligh in
+the symbol designation's string."
+  (cond ((find-package :cl-ppcre)
+         (make-cl-ppcre-matcher pattern case-sensitive symbol-name-fn))
+        (t
+         (prog1
+             (make-plain-matcher pattern case-sensitive symbol-name-fn)
+           (funcall (find-symbol (string :background-message) :swank)
+                    "Using plain apropos. Load CL-PPCRE for regexp version.")))))
 
 
 

lib/lisp/swank.lisp

@@ -2869,10 +2869,15 @@ The result is a list of property lists."
     ;; PACKAGE.
     (let ((*buffer-package* (or package
                                 *swank-io-package*)))
-      (mapcan (listify #'briefly-describe-symbol-for-emacs)
-              (sort (remove-duplicates
-                     (apropos-symbols name external-only case-sensitive package))
-                    #'present-symbol-before-p)))))
+      (loop for (symbol . extra)
+              in (sort (remove-duplicates
+                        (apropos-symbols name external-only case-sensitive package)
+                        :key #'first)
+                       #'present-symbol-before-p
+                       :key #'first)
+            for short = (briefly-describe-symbol-for-emacs symbol)
+            when short
+              collect (append short extra)))))
 
 (defun briefly-describe-symbol-for-emacs (symbol)
   "Return a property list describing SYMBOL.
@@ -2883,7 +2888,10 @@ Like `describe-symbol-for-emacs' but with at most one line per item."
     (let ((desc (map-if #'stringp #'first-line
                         (describe-symbol-for-emacs symbol))))
       (if desc
-          (list* :designator (to-string symbol) desc)))))
+          (list* :designator (list (symbol-name symbol)
+                                   (package-name (symbol-package symbol))
+                                   (symbol-external-p symbol))
+                 desc)))))
 
 (defun map-if (test fn &rest lists)
   "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
@@ -2918,19 +2926,30 @@ that symbols accessible in the current package go first."
                      (string< (package-name px) (package-name py)))))))))
 
 (defun apropos-symbols (string external-only case-sensitive package)
-  (let ((packages (or package (remove (find-package :keyword)
-                                      (list-all-packages))))
-        (matcher  (swank-backend:make-apropos-matcher string
-                                                      case-sensitive
-                                                      (not package)))
-        (result))
+  (let* ((packages (or package (remove (find-package :keyword)
+                                       (list-all-packages))))
+         (symbol-name-fn
+           (lambda (symbol)
+             (cond ((not package)
+                    ;; include qualifier in search if user didn't pass
+                    ;; PACKAGE.
+                    (concatenate 'string
+                                 (package-name (symbol-package symbol))
+                                 (if (symbol-external-p symbol) ":" "::")
+                                 (symbol-name symbol)))
+                   (t
+                    (string symbol)))))
+         (matcher  (swank-backend:make-apropos-matcher string
+                                                       symbol-name-fn
+                                                       case-sensitive)))
     (with-package-iterator (next packages :external :internal)
-      (loop (multiple-value-bind (morep symbol) (next)
-              (cond ((not morep) (return))
-                    ((and (if external-only (symbol-external-p symbol) t)
-                          (funcall matcher symbol))
-                     (push symbol result))))))
-    result))
+      (loop for (morep symbol) = (multiple-value-list (next))
+            while morep
+            for (match end) = (and (or (not external-only)
+                                       (symbol-external-p symbol))
+                                   (multiple-value-list (funcall matcher symbol)))
+            when match
+              collect `(,symbol ,@(when end `(:bounds (,match ,end))))))))
 
 (defun call-with-describe-settings (fn)
   (let ((*print-readably* nil))

sly.el

@@ -4105,49 +4105,81 @@ TODO"
       (set-syntax-table lisp-mode-syntax-table)
       (goto-char (point-min)))))
 
-(defvar sly-apropos-namespaces
-  '((:variable "Variable")
-    (:function "Function")
-    (:generic-function "Generic Function")
-    (:macro "Macro")
-    (:special-operator "Special Operator")
-    (:setf "Setf")
-    (:type "Type")
-    (:class "Class")
-    (:alien-type "Alien type")
-    (:alien-struct "Alien struct")
-    (:alien-union "Alien type")
-    (:alien-enum "Alien enum")))
+(define-button-type 'sly-apropos-symbol :supertype 'sly-part
+  'face nil
+  'action 'sly-button-show-source ;default action
+  'sly-button-inspect
+  #'(lambda (name _type)
+      (sly-inspect (format "(quote %s)" name)))
+  'sly-button-show-source
+  #'(lambda (name _type)
+      (sly-edit-definition name 'window))
+  'sly-button-describe
+  #'(lambda (name _type)
+      (sly-eval-describe `(swank:describe-symbol ,name))))
+
+(defun sly-apropos-designator-string (designator)
+  (cond ((listp designator)
+         (concat (cadr designator)
+                 (if (caddr designator) ":" "::")
+                 (propertize (car designator)
+                             'face 'sly-apropos-symbol)))
+        ((stringp designator)
+         designator)
+        (t
+         (error "unknown designator type"))))
+
+(defun sly-apropos-insert-symbol (designator item bounds)
+  (let ((start (point)))
+    (insert (make-text-button (sly-apropos-designator-string designator) nil
+                              'part-args (list item nil)
+                              'part-label "Symbol"
+                              :type 'sly-apropos-symbol))
+    (when bounds
+      (let ((ov (make-overlay (+ start (cl-first bounds))
+                              (+ start (cl-second bounds)))))
+        (overlay-put ov 'face 'highlight)))))
 
 (defun sly-print-apropos (plists)
-  (dolist (plist plists)
-    (let ((designator (plist-get plist :designator)))
-      (cl-assert designator)
-      (sly-insert-propertized `(face sly-apropos-symbol) designator))
-    (terpri)
-    (cl-loop for (prop value) on plist by #'cddr
-             unless (eq prop :designator) do
-             (let ((namespace (cadr (or (assq prop sly-apropos-namespaces)
-                                        (error "Unknown property: %S" prop))))
-                   (start (point)))
-               (princ "  ")
-               (sly-insert-propertized `(face sly-apropos-label) namespace)
-               (princ ": ")
-               (princ (cl-etypecase value
-                        (string value)
-                        ((member nil :not-documented) "(not documented)")))
-               (add-text-properties
-                start (point)
-                (list 'type prop 'action 'sly-call-describer
-                      'button t 'apropos-label namespace
-                      'item (plist-get plist :designator)))
-               (terpri)))))
-
-(defun sly-call-describer (arg)
-  (let* ((pos (if (markerp arg) arg (point)))
-         (type (get-text-property pos 'type))
-         (item (get-text-property pos 'item)))
-    (sly-eval-describe `(swank:describe-definition-for-emacs ,item ,type))))
+  (cl-loop
+   for plist in plists
+   for designator = (plist-get plist :designator)
+   for item = (substring-no-properties
+               (sly-apropos-designator-string designator))
+   do
+   (sly-apropos-insert-symbol designator item (plist-get plist :bounds))
+   (terpri)
+   (cl-loop for (prop value) on plist by #'cddr
+            for start = (point)
+            unless (memq prop '(:designator
+                                :package
+                                :bounds))
+            do
+            (let ((namespace (upcase-initials
+                              (replace-regexp-in-string
+                               "-" " " (substring (symbol-name prop) 1)))))
+              (princ "  ")
+              (insert (propertize namespace
+                                  'face 'sly-apropos-label))
+              (princ ": ")
+              (princ (cond ((and value
+                                 (not (eq value :not-documented)))
+                            value)
+                           (t
+                            "(not documented)")))
+              (add-text-properties
+               start (point)
+               (list 'action 'sly-button-describe
+                     'sly-button-describe
+                     #'(lambda (name type)
+                         (sly-eval-describe `(swank:describe-definition-for-emacs ,name
+                                                                                  ,type)))
+                     'part-args (list item prop)
+                     'button t 'apropos-label namespace))
+              (terpri)))))
+
+(defun sly-apropos-describe (name type)
+  (sly-eval-describe `(swank:describe-definition-for-emacs ,name ,type)))
 
 (defun sly-info ()
   "Open SLY manual"
@@ -4234,11 +4266,13 @@ source-location."
   (cl-loop for (group . refs) in xref-alist do
            (sly-insert-propertized '(face bold) group "\n")
            (cl-loop for (label location) in refs
+                    for start = (point)
                     do
                     (insert
                      " "
                      (sly-xref-button (sly-one-line-ify label) location)
-                    "\n")))
+                    "\n")
+                    (add-text-properties start (point) (list 'sly-location location))))
   ;; Remove the final newline to prevent accidental window-scrolling
   (backward-delete-char 1))