Commit f2e9ec02 authored by João Távora's avatar João Távora
Browse files

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.
parent 2b3869b4
Showing with 140 additions and 73 deletions
+140 -73
......@@ -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.")))))
......
......@@ -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))
......
......@@ -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))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment