From 64dca5f9f6eeef155a7a24916be21f195d7d5b1f Mon Sep 17 00:00:00 2001 From: Greg Hendershott Date: Tue, 12 Nov 2024 13:45:43 -0500 Subject: [PATCH] racket-describe-search: Various improvements 1. Redesign to be lazy and incremental: Previously we eagerly built a data structure for all xref-index items, to use as the completion-table. Because computing and transferring this to the front end could be slow, we had a couple layers of caching. Instead: Use a new "doc-search" back end command much like Emacs' `all-completions`, which returns data for items matching a prefix. It is backed by a doc index fully stored only on the back end server. The index is organized as a trie. Furthermore, although the entire trie is built eagerly so it knows all keys, the values for each node are computed lazily. 2. Implement something like the package and sorting ("base" vs. "main-dist" vs. other) recently added to web doc search. Since AFAICT we must use resolve-module-path and pkg->path, which can be somewhat slow, the new lazier design helps even more here. These details are calculated only when a user prefix matches those items. 3. Re-implement module-doc-path for package details, as well as the racket-add-require-for-identifier command, in terms of the new trie index. In fact the latter command now shares the completing-read UX of racket-describe-search -- the only difference being the final action is to insert a require statement, rather than to visit a doc page. --- doc/racket-mode.texi | 28 ++- racket-describe.el | 250 ++++++++++++------------ racket-edit.el | 68 ++++--- racket/command-server.rkt | 6 +- racket/commands/help.rkt | 5 +- racket/lib-pkg.rkt | 102 ++++++++++ racket/package.rkt | 4 +- racket/scribble.rkt | 386 ++++++++++++++++++-------------------- racket/util.rkt | 19 ++ racket/xref.rkt | 13 ++ 10 files changed, 498 insertions(+), 383 deletions(-) create mode 100644 racket/lib-pkg.rkt create mode 100644 racket/xref.rkt diff --git a/doc/racket-mode.texi b/doc/racket-mode.texi index 650c3436..d5f1ddde 100644 --- a/doc/racket-mode.texi +++ b/doc/racket-mode.texi @@ -1157,15 +1157,29 @@ typed/racket/base''. @kbd{M-x} @code{racket-add-require-for-identifier} -Add a require for the identifier at point. +Add a require for an identifier. -When more than one module supplies an identifer with the same -name, they are listed for you to choose one. The list is sorted -alphabetically, except modules starting with ``racket/'' and -``typed/racket/'' are sorted before others. +Useful when you know the name of an export but don't remember +from what module it is exported. + +At the prompt: + +Use @kbd{} or @kbd{} or @kbd{M-n} to load the identifier at point. +You may also need to @kbd{C-e} or @kbd{} to see candidates. + +Or type anything. -A ``require'' form is inserted into the buffer, followed by doing -a @ref{racket-tidy-requires}. +After you choose: + +The identifier you chose is inserted at point if not already +there. + +A ``require'' form is inserted, followed by doing a +@ref{racket-tidy-requires}. + +When more than one module supplies an identifer with the same +name, the first is used -- for example ``racket/base'' instead of +``racket''. Caveat: This works in terms of identifiers that are documented. The mechanism is similar to that used for Racket's ``Search diff --git a/racket-describe.el b/racket-describe.el index 62da2820..f9f8278d 100644 --- a/racket-describe.el +++ b/racket-describe.el @@ -610,150 +610,134 @@ browser program -- are given `racket-ext-link-face'. ;;; Search local docs -;; For people who don't want to use a web browser: Search local -;; documentation, and view in a `racket-describe-mode' buffer. - -(defvar racket--doc-index (make-hash-table :test 'equal) - "Hash-table from back end name to association list of doc index info.") - -(defun racket--remove-doc-index () - "A `racket-stop-back-end-hook' to clean up `racket--doc-index'." - (when-let (key (racket-back-end-name)) - (remhash key racket--doc-index))) - -(add-hook 'racket-stop-back-end-hook #'racket--remove-doc-index) - -(defun racket--doc-index-file-name (key) - (make-directory racket-doc-index-directory t) - (expand-file-name (concat (racket--file-name-slug - (concat "doc-index-" key)) - ".eld") - racket-doc-index-directory)) - -(defun racket--doc-index-file-write (key data) - (write-region (format ";; -*- no-byte-compile: t; lexical-binding: nil -*-\n%S" - data) - nil - (racket--doc-index-file-name key) - nil - 'no-message)) - -(defun racket--doc-index-file-read (key) - (with-temp-buffer - (ignore-errors - (insert-file-contents (racket--doc-index-file-name key)) - (goto-char (point-min)) - (read (current-buffer))))) - -(defun racket--doc-index () - "Get the doc index items. - -For the item format, see `racket--doc-index-make-alist'. - -Because the doc index is somewhat large and slow to get from the -back end, we use a couple levels of caching: 1. Memory, for the -duration of the Emacs session or back end lifetime, whichever is -shorter. 2. Local file system, between sessions. For this latter -we do want to make sure the file isn't outdated, e.g. user -installed new packages. The back end commands works like an HTTP -request with an If-None-Match header: We supply an \"etag\" value -it previously gave us. If that still matches the response is just -\"not modified\", otherwise a new etag and items." - (let ((key (racket-back-end-name))) - (or - (gethash key racket--doc-index) - (pcase-let* - ((`(,old-etag . ,old-items) (racket--doc-index-file-read key)) - (items - (pcase (with-temp-message "Checking back end doc index..." - (racket--cmd/await nil `(doc-index ,old-etag))) - ('not-modified old-items) - (`(,etag . ,items) - (with-temp-message "Doc index changed; updating local file..." - (racket--doc-index-file-write key (cons etag items))) - items))) - (items - (with-temp-message "Processing doc index items for memory cache..." - (racket--doc-index-make-alist items)))) - (puthash key items racket--doc-index) - items)))) - -(defun racket--doc-index-make-alist (items) - "Given back end ITEMS make an association list. - -A list is a valid collection for completion, where the `car' is -the completion string. For this we use a string with invisible -text to influence sorting, appended to the visible search term. -This is vastly faster than using a :display-sort-function. - -Our affixation function gets the propertized string, so we can -tuck the values it needs into a text property. - -However the final result from `completing-read' is stripped of -text properties -- which is the only reason we need an -association list, to look up the path and anchor." - (cl-flet ((wstr (width s) - (let ((len (length s))) - (if (<= len width) - (concat s - (make-string (- width len) 32)) - (substring s 0 width))))) - (mapcar - (pcase-lambda (`(,uid ,term ,sort ,what ,from ,fams ,path ,anchor)) - (let* ((term (propertize term - 'racket-affix (list what from fams))) - (sort (let ((fams (wstr 32 - (pcase fams - ("Racket" " Racket") - (v v)))) - (from (wstr 64 - (cond - ((string-match-p "^racket/" from) - (concat " 0_" from)) - ((string-match-p "^typed/racket/" from) - (concat " 1_" from)) - ((string-match-p "^rhombus" from) - (concat " 2_" from)) - ((string-equal "" from) - (make-string 16 ?z)) - (t from)))) - (what (wstr 32 what)) - (sort (format "%09d" sort)) - (uid (format "%05d" uid))) - ;; We need uid only to guarantee uniqueness, not - ;; to influence sorting, so it goes last. - (concat fams from what sort uid))) - (str (concat term (propertize sort 'display "")))) - (list str path anchor))) - items))) - (defun racket-describe-search () "Search installed documentation; view using `racket-describe-mode'." (interactive) + (pcase (racket--describe-search-completing-read) + (`(,term ,path ,anchor ,_lib) + (racket--do-describe (cons (racket-file-name-back-to-front path) + anchor) + nil + term)))) + +(defun racket--describe-search-completing-read () + "A `completing-read' UX for user to pick doc index item. +Return nil or \(term path anchor lib\)." (let* ((affixator (racket--make-affix [16 [16 racket-describe-search-kind] [32 racket-describe-search-from-libs] + 16 [0 racket-describe-search-lang-fams]])) - (collection (racket--completion-table - (racket--doc-index) - `((category . ,racket--identifier-category) - (affixation-function . ,affixator)))) - (predicate (lambda (v) - (apply racket-doc-index-predicate-function - (get-text-property 0 'racket-affix (car v))))) + (candidates nil) + (collection + (lambda (string predicate action) + (cond + ((eq action 'metadata) + `(metadata + (category . ,racket--identifier-category) + (display-sort-function . ,#'racket--describe-search-display-sort) + (affixation-function . ,affixator))) + ((eq (car-safe action) 'boundaries) nil) + (t + (when (eq action t) + (setq candidates + (racket--describe-search-make-strings + (racket--cmd/await nil `(doc-search ,string))))) + (funcall (cond + ((null action) #'try-completion) + ((eq action t) #'all-completions) + (t #'test-completion)) + string + candidates + predicate))))) + (predicate + (lambda (v) + (apply racket-doc-index-predicate-function + (get-text-property 0 'racket-affix v)))) + (prompt "Search Racket documentation: ") (require-match t) - (initial-input (racket--thing-at-point 'symbol t))) - (when-let (str (completing-read "Describe: " + (initial-input nil) + (history 'racket-identifier) + (default (racket--thing-at-point 'symbol t)) + (history-add-new-input nil)) ;we'll add history below + (when-let (str (completing-read prompt collection predicate require-match - initial-input)) - (pcase (assoc str (racket--doc-index)) - (`(,_str ,path ,anchor) - (racket--do-describe (cons (racket-file-name-back-to-front path) - anchor) - nil - (substring-no-properties str))))))) + initial-input + history + default)) + (pcase (racket--describe-search-parse-result str) + (`(,term ,path ,anchor ,lib) + (add-to-history 'racket-identifier term) ;just term + (list term path anchor lib)))))) + +(defun racket--describe-search-make-strings (items) + "Make a list of candidate strings from back end ITEMS. + +Each string has text properties needed by our affixation and +display-sort functions. + +However `completing-read' returns a string stripped of text +properties. :( So we append the path and anchor, tab separated, +as invisible text. Use `racket--describe-search-parse-result' to +extract." + (mapcar + (pcase-lambda (`(,term ,sort ,what ,from ,fams (,pkg ,pkg-sort) + ,path ,anchor)) + (let* ((term (propertize term + 'racket-affix (list what from pkg fams) + 'racket-sort (list (format "%09d" sort) + (format "%09d" pkg-sort)))) + (lib (substring from 0 (string-match (rx ?,) from))) + (data (concat "\t" path "\t" anchor "\t" lib)) + (data (propertize data 'display ""))) + (concat term data))) + items)) + +(defun racket--describe-search-parse-result (str) + (when (string-match (rx bos + (group-n 1 (+? (not (any ?\t)))) ?\t + (group-n 2 (+? (not (any ?\t)))) ?\t + (group-n 3 (+? (not (any ?\t)))) ?\t + (group-n 4 (+? any)) + eos) + str) + (list (match-string 1 str) + (match-string 2 str) + (match-string 3 str) + (match-string 4 str)))) + +(defun racket--describe-search-display-sort (strs) + "A value for display-sort-function metadata." + (cl-flet* + ((term (s) + (substring s 0 (string-match (rx ?\t) s))) + (adjust-fams (fams) + (pcase fams + ("Racket" " Racket") + (v v))) + (key (v) + (pcase-let + ((`(,what ,from ,fams) (get-text-property 0 'racket-affix v)) + (`(,sort ,pkg-sort) (get-text-property 0 'racket-sort v))) + (list (term v) + (adjust-fams fams) + pkg-sort + from + what + sort))) + (key< (as bs) + (cl-loop for a in as + for b in bs + unless (string= a b) return (string< a b) + finally return nil))) + ;; `seq-sort-by' unavailable in Emacs 25, so instead of + ;; (seq-sort-by #'key #'key< strs) spell it out: + (seq-sort (lambda (a b) + (key< (key a) + (key b))) + strs))) (provide 'racket-describe) diff --git a/racket-edit.el b/racket-edit.el index 9a28af02..38f241aa 100644 --- a/racket-edit.el +++ b/racket-edit.el @@ -263,15 +263,30 @@ module form, meaning the outermost, file module." (looking-at-p "require")))) (defun racket-add-require-for-identifier () - "Add a require for the identifier at point. + "Add a require for an identifier. -When more than one module supplies an identifer with the same -name, they are listed for you to choose one. The list is sorted -alphabetically, except modules starting with \"racket/\" and -\"typed/racket/\" are sorted before others. +Useful when you know the name of an export but don't remember +from what module it is exported. + +At the prompt: +\\ + +Use \\[next-history-element] to load the identifier at point. +You may also need to \\[move-end-of-line] to see candidates. + +Or type anything. + +After you choose: -A \"require\" form is inserted into the buffer, followed by doing -a `racket-tidy-requires'. +The identifier you chose is inserted at point if not already +there. + +A \"require\" form is inserted, followed by doing a +`racket-tidy-requires'. + +When more than one module supplies an identifer with the same +name, the first is used -- for example \"racket/base\" instead of +\"racket\". Caveat: This works in terms of identifiers that are documented. The mechanism is similar to that used for Racket's \"Search @@ -279,35 +294,18 @@ Manuals\" feature. Today there exists no system-wide database of identifiers that are exported but not documented." (interactive) (racket--assert-sexp-edit-mode) - (let ((sym-at-point (thing-at-point 'symbol t))) - (unless sym-at-point - (user-error "There does not seem to be an identifier at point")) - (racket--cmd/async - nil - `(requires/find ,sym-at-point) - (lambda (result) - (let ((lib - (pcase result - (`() - (message "\"%s\" is not a documented export of any installed library" - sym-at-point) - nil) - (`(,lib) - lib) - (libs - (completing-read - (format "\"%s\" is provided by multiple libraries, choose one: " - sym-at-point) - libs))))) - (when lib - (let ((pt (copy-marker (point))) + (when-let (result (racket--describe-search-completing-read)) + (pcase-let* ((`(,term ,_path ,_anchor ,lib) result) (req `(require ,(intern lib)))) - (racket--tidy-requires - (list req) - (lambda (result) - (goto-char pt) - (when result - (message "Added \"%s\" and did racket-tidy-requires" req))))))))))) + (unless (equal (racket--thing-at-point 'symbol) term) + (insert term)) + (let ((pt (copy-marker (point)))) + (racket--tidy-requires + (list req) + (lambda (result) + (goto-char pt) + (when result + (message "Added \"%s\" and did racket-tidy-requires" req)))))))) ;;; align diff --git a/racket/command-server.rkt b/racket/command-server.rkt index 8d71c92a..42b6cbce 100644 --- a/racket/command-server.rkt +++ b/racket/command-server.rkt @@ -18,8 +18,7 @@ "repl-session.rkt" (only-in "scribble.rkt" bluebox-command - doc-index - libs-exporting-documented) + doc-search) "util.rkt") (lazy-require @@ -144,8 +143,7 @@ [`(requires/tidy ,reqs) (requires/tidy reqs)] [`(requires/trim ,path-str ,reqs) (requires/trim path-str reqs)] [`(requires/base ,path-str ,reqs) (requires/base path-str reqs)] - [`(requires/find ,str) (libs-exporting-documented str)] - [`(doc-index ,etag) (doc-index etag)] + [`(doc-search ,prefix) (doc-search prefix)] [`(hash-lang . ,more) (apply hash-lang more)] [`(pkg-list) (package-list)] [`(pkg-details ,str) (package-details str)] diff --git a/racket/commands/help.rkt b/racket/commands/help.rkt index 647f0f37..96757861 100644 --- a/racket/commands/help.rkt +++ b/racket/commands/help.rkt @@ -5,11 +5,11 @@ (require (only-in scribble/core tag?) scribble/xref - setup/xref racket/contract racket/format racket/match - "../identifier.rkt") + "../identifier.rkt" + "../xref.rkt") (provide doc) @@ -28,7 +28,6 @@ (->identifier how str stx->uri-string)) (define (stx->uri-string stx) - (define xref (load-collections-xref)) (match (and xref (xref-binding->definition-tag xref stx 0)) [(? tag? tag) (define-values (path anchor) (xref-tag->path+anchor xref tag)) diff --git a/racket/lib-pkg.rkt b/racket/lib-pkg.rkt new file mode 100644 index 00000000..cb5af0f5 --- /dev/null +++ b/racket/lib-pkg.rkt @@ -0,0 +1,102 @@ +;; Copyright (c) 2024 by Greg Hendershott. +;; SPDX-License-Identifier: GPL-3.0-or-later + +#lang racket/base + +(require racket/match + racket/set + (only-in syntax/modresolve + resolve-module-path) + setup/dirs + setup/getinfo + pkg/lib + "define-fallbacks.rkt") + +(define-fallbacks setup/dirs + [(get-base-documentation-packages) '("racket-doc")] + [(get-distribution-documentation-packages) '("main-distribution") ]) + +(provide lib-pkg) + +;; This code for classifying packages as "base" or "main-dist" is +;; borrowed from racket-index/scribblings/main/private/pkg.rkt +(define base-pkgs #f) +(define main-dist-pkgs #f) +(define pkg-cache-for-pkg-directory (make-hash)) + +(define (get-base-pkgs) + (unless base-pkgs + (set! base-pkgs (find-pkgs (get-base-documentation-packages)))) + base-pkgs) + +(define (get-main-dist-pkgs) + (unless main-dist-pkgs + (set! main-dist-pkgs (find-pkgs (get-distribution-documentation-packages) + #:exclude (list->set (get-base-pkgs))))) + main-dist-pkgs) + +(define (find-pkgs root-pkg-names #:exclude [excludes (set)]) + (define result '()) + (define seen (set-copy excludes)) + (for ([root-pkg-name (in-list root-pkg-names)]) + (match (pkg-directory + root-pkg-name + #:cache pkg-cache-for-pkg-directory) + [#f '()] + [_ + (let loop ([pkg root-pkg-name]) + (unless (set-member? seen pkg) + (set-add! seen pkg) + (match (pkg-directory pkg #:cache pkg-cache-for-pkg-directory) + [#f + ;; these are platform dependent packages (like racket-win32-i386-3) + ;; they have no deps, and if they are platform dependent, + ;; they are not that useful (for documentation search) anyway + (set! result (cons pkg result))] + [dir + (set! result (cons pkg result)) + (define get-info (get-info/full dir)) + (define direct-deps + (for/list ([dep (extract-pkg-dependencies get-info #:build-deps? #f)]) + (match dep + [(? string?) dep] + [(cons dep _) dep]))) + ;; we need to recur. For example, 2dtabular is in 2d-lib, + ;; which is not a direct dep of main-distribution + (for ([dep direct-deps]) + (loop dep))])))])) + result) + +;; However we can't follow the example of web search, which builds its +;; index at doc build time. The package info known at doc build time +;; doesn't make it into the xref index. +;; +;; So instead: When a doc index item has an "exported from lib", we +;; use resolve-module-path and path->pkg. However this is moderately +;; expensive, and should be done lazily (definitely not eagerly for +;; all 32K+ xref-index items) and cached. + +(define pkg-cache-for-path->pkg (make-hash)) +(define (pkg-name mp) + (match (resolve-module-path mp) + [(or (? path? p) + (list* 'submod (? path? p))) + (path->pkg p + #:cache pkg-cache-for-path->pkg)] + [_ #f])) + +(define cache (make-hash)) +(define (lib-pkg maybe-mod-path) ;=> (list pkg-name, sort) + (hash-ref! + cache + maybe-mod-path + (λ () + (cond + [(module-path? maybe-mod-path) + (define p (pkg-name maybe-mod-path)) + (list (or p "") + (cond [(not p) 0] + [(member p (get-base-pkgs)) 1] + [(member p (get-main-dist-pkgs)) 2] + [else 3]))] + [else (list "" 9)])))) diff --git a/racket/package.rkt b/racket/package.rkt index e64cba89..190ec1d8 100644 --- a/racket/package.rkt +++ b/racket/package.rkt @@ -30,7 +30,7 @@ net/url (only-in "scribble.rkt" module-doc-path - refresh-module-doc-path-index!)) + refresh-doc-index!)) (provide package-list package-details @@ -312,7 +312,7 @@ (act!)) (flush-output out) (close-output-port out) - (refresh-module-doc-path-index!))) + (refresh-doc-index!))) (module+ example (define (pump) diff --git a/racket/scribble.rkt b/racket/scribble.rkt index ee1c3d90..63e2fa90 100644 --- a/racket/scribble.rkt +++ b/racket/scribble.rkt @@ -18,12 +18,11 @@ scribble/xref scribble/tag setup/main-doc - setup/xref - (only-in setup/dirs get-doc-search-dirs) - syntax/parse/define version/utils "define-fallbacks.rkt" - "elisp.rkt") + "lib-pkg.rkt" + "util.rkt" + "xref.rkt") ;; Fallbacks when new index structs aren't available (before ;; scribble-lib 1.54, which ~= Racket 8.14.0.6). @@ -36,36 +35,18 @@ (provide binding->path+anchor identifier->bluebox bluebox-command - doc-index - libs-exporting-documented + doc-search module-doc-path - refresh-module-doc-path-index!) + refresh-doc-index!) (module+ test (require rackunit)) -;; When running on a machine with little memory, such as a small VPS -;; or AWS instance, I have seen the oom-killer terminate the process -;; after we try to handle a back end command that does some of these -;; documentation operations. Presumably they use enough memory that -;; Racket asks the OS for more? To make that less likely, do a major -;; GC before/after. So far this seems to be a successful mitigation, -;; although it also seems like a kludge. -(define (call-avoiding-oom-killer thunk) - (collect-garbage 'major) - (begin0 (thunk) - (collect-garbage 'major))) - -(define-simple-macro (with-less-memory-pressure e:expr ...+) - (call-avoiding-oom-killer (λ () e ...))) - (define/contract (binding->path+anchor stx) (-> identifier? (or/c #f (cons/c path-string? (or/c #f string?)))) - (with-less-memory-pressure - (let* ([xref (load-collections-xref)] - [tag (xref-binding->definition-tag xref stx 0)] - [p+a (and tag (tag->path+anchor xref tag))]) - p+a))) + (let* ([tag (xref-binding->definition-tag xref stx 0)] + [p+a (and tag (tag->path+anchor xref tag))]) + p+a)) (define (tag->path+anchor xref tag) (define-values (path anchor) (xref-tag->path+anchor xref tag)) @@ -91,7 +72,7 @@ (define/contract (identifier->bluebox stx) (-> identifier? (or/c #f string?)) - (match (xref-binding->definition-tag (load-collections-xref) stx 0) + (match (xref-binding->definition-tag xref stx 0) [(? tag? tag) (get-bluebox-string tag)] [_ #f])) @@ -112,184 +93,191 @@ "(list v ...) -> list?\n v : any/c")) (check-false (identifier->bluebox (datum->syntax #f (gensym))))) -;;; Documentation index - -;; Note that `xref-index` returns a list of 30K+ `entry` structs. We -;; can't avoid that with the official API. That will bump peak memory -;; use. :( Best we can do is sandwich it in major GCs, to avoid the -;; peak going even higher. Furthermore in doc-index-names we avoid -;; making _another_ 30K+ list, by returning a thunk for elisp-write -;; to call, to do "streaming" writes. - -;; This is like an HTTP request with an If-None-Match header. -(define (doc-index last-etag) - (match (doc-index-etag) - [(== last-etag) 'not-modified] - [etag (make-doc-index-thunk etag)])) +;;; Documentation search -(define (doc-index-etag) - (~s - (for/list ([dir (in-list (get-doc-search-dirs))]) - (define file (build-path dir "docindex.sqlite")) - (cons dir - (and (file-exists? file) - (file-or-directory-modify-seconds file)))))) +;; A trie where a node's children are represented as a hash-table from +;; char to node. Each node also has a set of zero or more values +;; (multiple, since we have so many duplicate keys e.g. various +;; flavors of "define" or "print"). The values are promises: Although +;; the trie is built for all search terms, the initial promise +;; contains just a `desc` and tag; the full doc-index-value is not +;; computed until retrieved. +(struct node (kids values)) +;; kids: (hash/c char? node?) +;; values: (set/c (promise/c doc-trie-value)) +(define (empty-node) (node (make-hasheq) (set))) -(define (hide-desc? desc) - ;; Don't show doc for constructors; class doc suffices. - (or (constructor-index-desc? desc) - (and (exported-index-desc*? desc) - (let ([ht (exported-index-desc*-extras desc)]) - (or (hash-ref ht 'hidden? #f) - (hash-ref ht 'constructor? #f)))))) +(define doc-index-trie-root #f) -(define ((make-doc-index-thunk etag)) - (with-less-memory-pressure - (with-parens - (elisp-writeln etag) - (define xref (load-collections-xref)) - (for* ([(entry uid) (in-indexed (xref-index xref))] - [desc (in-value (entry-desc entry))] - #:when desc - #:unless (hide-desc? desc) - [term (in-value (car (entry-words entry)))] - [tag (in-value (entry-tag entry))]) - (define-values (path anchor) (xref-tag->path+anchor xref tag)) - (define (method-what) - (cond - [(method-tag? tag) - (define-values (c/i _m) (get-class/interface-and-method tag)) - (format "method of ~a" c/i)] - [else "method"])) - (define (doc-from) - (string-append - "◊ " - (match (path->main-doc-relative path) - [(cons 'doc byte-strings) - (define path-parts (map bytes->path byte-strings)) - (define rel-html (apply build-path path-parts)) - (path->string - (path-replace-extension rel-html #""))] - [_ (~a tag)]))) - (define-values (what from fams sort-order) - (cond - ;; New structs - [(exported-index-desc*? desc) - (define ht (exported-index-desc*-extras desc)) - (define kind (hash-ref ht 'kind)) - (define what (if (string=? kind "method") - (method-what) - kind)) - (define from - (string-join (match (hash-ref ht 'display-from-libs #f) - [(? list? contents) - (map content->string contents)] - [#f - (map ~s (exported-index-desc-from-libs desc))]) - ", ")) - (define fams (match (hash-ref ht 'language-family #f) - [(? list? fams) (string-join (map ~a fams) ", ")] - [#f "Racket"])) - (define sort-order (hash-ref ht 'sort-order 0)) - (values what from fams sort-order)] - [(index-desc? desc) - (define ht (index-desc-extras desc)) - (define what (match (hash-ref ht 'module-kind #f) - ['lib "module"] - ['lang "language"] - ['reader "reader"] - [#f "documentation"] - [v (~a v)])) - (define from - (match (hash-ref ht 'display-from-libs #f) - [(? list? contents) - (string-join (map content->string contents) ", ")] - [#f (doc-from)])) - (define fams (match (hash-ref ht 'language-family #f) - [(? list? fams) (string-join (map ~a fams) ", ")] - [#f "Racket"])) - (define sort-order (hash-ref ht 'sort-order 0)) - (values what from fams sort-order)] - ;; Older structs - [(exported-index-desc? desc) - (define what - (match desc - [(? language-index-desc?) "language"] - [(? reader-index-desc?) "reader"] - [(? form-index-desc?) "syntax"] - [(? procedure-index-desc?) "procedure"] - [(? thing-index-desc?) "value"] - [(? struct-index-desc?) "structure"] - [(? class-index-desc?) "class"] - [(? interface-index-desc?) "interface"] - [(? mixin-index-desc?) "mixin"] - [(? method-index-desc?) (method-what)] - [_ ""])) - (define from (string-join (map ~s (exported-index-desc-from-libs desc)) ", ")) - (values what from "" 0)] - [(module-path-index-desc? desc) - (values "module" "" "" 0)] - [else - (values "documentation" (doc-from) "" 0)])) - (elisp-writeln (list uid term sort-order what from fams path anchor))) - (newline)))) +(define (refresh-doc-index!) + (set! doc-index-trie-root + (with-memory-use/log "build-doc-search-trie" + (with-time/log "build-doc-search-trie" + (build-doc-search-trie))))) -;;; This is for the requires/find command +(define (doc-search prefix [limit 256]) + (unless doc-index-trie-root + (refresh-doc-index!)) + (trie-find doc-index-trie-root prefix limit)) -;; Given some symbol as a string, return the modules providing it, -;; sorted by most likely to be desired. -(define (libs-exporting-documented sym-as-str) - (with-less-memory-pressure - (define xref (load-collections-xref)) - (define results - (for*/set ([entry (in-list (xref-index xref))] - [desc (in-value (entry-desc entry))] - #:when (exported-index-desc? desc) - [name (in-value (symbol->string - (exported-index-desc-name desc)))] - #:when (equal? name sym-as-str) - [libs (in-value (map symbol->string - (exported-index-desc-from-libs desc)))] - #:when (not (null? libs))) - ;; Take just the first lib. This usually seems to be the - ;; most-specific, e.g. (racket/base racket). - (car libs))) - (sort (set->list results) - stringlist prefix) + [(list) + null] + [chs + (define results (mutable-set)) + (let find! ([n root] + [chs chs]) + (match-define (cons ch more) chs) + (define sub (hash-ref (node-kids n) ch (empty-node))) + (cond + [(null? more) + (define (report! n) + (for ([v (in-set (node-values n))]) + (set-add! results (force v))) + (when (< (set-count results) limit) + (for ([n (in-hash-values (node-kids n))]) + (report! n)))) + (report! sub)] + [else + (find! sub more)])) + (set->list results)])) -;; This is for package-details - -(define (build-module-doc-path-index) - (delay/thread - (define xref (load-collections-xref)) - (for*/hash ([entry (in-list (xref-index xref))] - [desc (in-value (entry-desc entry))] - [module? (in-value (module-path-index-desc? desc))] - [lang? (in-value (language-index-desc? desc))] - #:when (or module? lang?)) - (define k (cons (car (entry-words entry)) - lang?)) - (define v (let-values ([(p a) (xref-tag->path+anchor xref (entry-tag entry))]) - (let ([p (path->string p)] - [a a]) - (cons p a)))) - (values k v)))) +;; Find values for all nodes for which `prefix` is an exact full or +;; prefix match -- for use producing completion candidates. +(define (trie-add! root str value) + (let add! ([n root] + [chs (string->list str)]) + (match chs + [(list ch) + (hash-update! (node-kids n) + ch + (λ (n) + (node (node-kids n) + (set-add (node-values n) value))) + empty-node)] + [(cons ch more) + (add! (hash-ref! (node-kids n) ch (empty-node)) + more)]))) -(define module-doc-path-index (build-module-doc-path-index)) +(define (build-doc-search-trie) + (define root (empty-node)) + (define (hide-desc? desc) + ;; Don't show doc for constructors; class doc suffices. + (or (constructor-index-desc? desc) + (and (exported-index-desc*? desc) + (let ([ht (exported-index-desc*-extras desc)]) + (or (hash-ref ht 'hidden? #f) + (hash-ref ht 'constructor? #f)))))) + (for* ([entry (in-list (xref-index xref))] + [desc (in-value (entry-desc entry))] + #:when desc + #:unless (hide-desc? desc) + [term (in-value (car (entry-words entry)))] + [tag (in-value (entry-tag entry))]) + (trie-add! root + term + (delay (doc-trie-value desc term tag)))) + root) -(define (refresh-module-doc-path-index!) - (set! module-doc-path-index (build-module-doc-path-index))) +(define (doc-trie-value desc term tag) + (define-values (path anchor) (xref-tag->path+anchor xref tag)) + (define (method-what) + (cond + [(method-tag? tag) + (define-values (c/i _m) (get-class/interface-and-method tag)) + (format "method of ~a" c/i)] + [else "method"])) + (define (doc-from) + (string-append + "◊ " + (match (path->main-doc-relative path) + [(cons 'doc byte-strings) + (define path-parts (map bytes->path byte-strings)) + (define rel-html (apply build-path path-parts)) + (path->string + (path-replace-extension rel-html #""))] + [_ (~a tag)]))) + (define-values (what from fams pkg sort-order) + (cond + ;; New structs + [(exported-index-desc*? desc) + (define ht (exported-index-desc*-extras desc)) + (define kind (hash-ref ht 'kind)) + (define what (if (string=? kind "method") + (method-what) + kind)) + (define from + (string-join (match (hash-ref ht 'display-from-libs #f) + [(? list? contents) + (map content->string contents)] + [#f + (map ~s (exported-index-desc-from-libs desc))]) + ", ")) + (define fams (match (hash-ref ht 'language-family #f) + [(? list? fams) (string-join (map ~a fams) ", ")] + [#f "Racket"])) + (define pkg (lib-pkg + (match (exported-index-desc-from-libs desc) + [(cons lib _) lib] + [_ #f]))) + (define sort-order (hash-ref ht 'sort-order 0)) + (values what from fams pkg sort-order)] + [(index-desc? desc) + (define ht (index-desc-extras desc)) + (define what (match (hash-ref ht 'module-kind #f) + ['lib "module"] + ['lang "language"] + ['reader "reader"] + [#f "documentation"] + [v (~a v)])) + (define from + (match (hash-ref ht 'display-from-libs #f) + [(? list? contents) + (string-join (map content->string contents) ", ")] + [#f (doc-from)])) + (define fams (match (hash-ref ht 'language-family #f) + [(? list? fams) (string-join (map ~a fams) ", ")] + [#f "Racket"])) + (define pkg (lib-pkg + (match (hash-ref ht 'module-kind #f) + ['lib (string->symbol term)] + [_ #f]))) + (define sort-order (hash-ref ht 'sort-order 0)) + (values what from fams pkg sort-order)] + ;; Older structs + [(exported-index-desc? desc) + (define what + (match desc + [(? language-index-desc?) "language"] + [(? reader-index-desc?) "reader"] + [(? form-index-desc?) "syntax"] + [(? procedure-index-desc?) "procedure"] + [(? thing-index-desc?) "value"] + [(? struct-index-desc?) "structure"] + [(? class-index-desc?) "class"] + [(? interface-index-desc?) "interface"] + [(? mixin-index-desc?) "mixin"] + [(? method-index-desc?) (method-what)] + [_ ""])) + (define from (string-join (map ~s (exported-index-desc-from-libs desc)) ", ")) + (define pkg (lib-pkg + (match (exported-index-desc-from-libs desc) + [(cons lib _) lib] + [_ #f]))) + (values what from "" pkg 0)] + [(module-path-index-desc? desc) + (define pkg (lib-pkg (string->symbol term))) + (values "module" "" "" pkg 0)] + [else + (define pkg (lib-pkg #f)) + (values "documentation" (doc-from) "" pkg 0)])) + (list term sort-order what from fams pkg path anchor)) +;; This is for package-details (define (module-doc-path mod-path-str lang?) - (hash-ref (force module-doc-path-index) - (cons mod-path-str lang?) - #f)) + (for/or ([v (in-list (doc-search mod-path-str 0))]) + (match-define (list term _sort what _from _fams _pkg path anchor) v) + (and (equal? term mod-path-str) + (equal? what (if lang? "language" "module")) + (cons path anchor)))) diff --git a/racket/util.rkt b/racket/util.rkt index 70990dbf..baaedd00 100644 --- a/racket/util.rkt +++ b/racket/util.rkt @@ -22,6 +22,7 @@ log-racket-mode-fatal time-apply/log with-time/log + with-memory-use/log (all-from-out "define-fallbacks.rkt") (all-from-out "safe-dynamic-require.rkt")) @@ -58,3 +59,21 @@ (define-simple-macro (with-time/log what e ...+) (time-apply/log what (λ () e ...) '())) + +(define (memory-use/log what thunk) + (define before (current-memory-use)) + (begin0 (thunk) + (let ([after (current-memory-use)]) + (define (mb n) + (~a (~r #:min-width 4 + #:precision 0 + (/ n 1024.0 1024.0)) + " MB")) + (log-racket-mode-debug "~a [~a => ~a] :: ~a" + (mb (- after before)) + (mb before) + (mb after) + what)))) + +(define-simple-macro (with-memory-use/log what e ...+) + (memory-use/log what (λ () e ...))) diff --git a/racket/xref.rkt b/racket/xref.rkt new file mode 100644 index 00000000..b55b90ec --- /dev/null +++ b/racket/xref.rkt @@ -0,0 +1,13 @@ +;; Copyright (c) 2013-2024 by Greg Hendershott. +;; SPDX-License-Identifier: GPL-3.0-or-later + +#lang racket/base + +(require setup/xref) + +(provide xref + xref-ready-evt) + +(define xref-ready-evt never-evt) +(define xref (begin0 (load-collections-xref) + (set! xref-ready-evt always-evt)))