Various tweaks

Show documentation "from" using path->main-doc-relative, and with a lozenge prefix. Rename some things. Add some variables for intermediate values.
greghendershott · Oct 9, 2024 · a3fb074 · a3fb074
1 parent 3c90efb
commit a3fb074
Show file tree

Hide file tree

Showing 2 changed files with 47 additions and 43 deletions.
diff --git a/racket-describe.el b/racket-describe.el
@@ -584,7 +584,7 @@ point if any.
   (interactive)
   (let* ((name (racket--symbol-at-point-or-prompt t "Describe: "
                                                   (racket--describe-terms)))
-         (buf-name (format "*Racket Search Describe `%s` <%s>*"
+         (buf-name (format "*Racket Describe Search `%s` <%s>*"
                            name
                            (racket-back-end-name))))
     (racket--cmd/async
@@ -626,7 +626,7 @@ point if any.
               (setq tabulated-list-format
                     (vector (list "Name" (max max-term (length "Name ")) nil)
                             (list "Kind" (max max-what (length "Kind ")) t)
-                            (list "Provided from" (max max-from (length "Provided from")) t)
+                            (list "From" (max max-from (length "From")) t)
                             (list "Language families" 99 t)))
               (setq tabulated-list-padding 0)
               (tabulated-list-init-header)

diff --git a/racket/scribble.rkt b/racket/scribble.rkt
@@ -17,6 +17,7 @@
          scribble/manual-struct
          scribble/xref
          scribble/tag
+         setup/main-doc
          setup/xref
          syntax/parse/define
          version/utils
@@ -149,32 +150,33 @@
                  [desc (in-value (entry-desc entry))]
                  #:when desc
                  ;;[_ (in-value (println desc))] ;;; DEBUG
-                 #:unless (hide-desc? desc))
-        (define tag (entry-tag entry))
-        (define (what/method tag)
+                 #:unless (hide-desc? desc)
+                 [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-values (path anchor) (xref-tag->path+anchor xref tag))
-        (define (doc-in)
-          (match (reverse (explode-path path))
-            [(list* html-file dir _)
-             (format "in ~a ~a"
-                     (path->string dir)
-                     (path->string (path-replace-extension html-file
-                                                           #"")))]
-            [_
-             (format "tag ~a") tag]))
+        (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")
-                              (what/method tag)
+                              (method-what)
                               kind))
              (define from
                (string-join (match (hash-ref ht 'display-from-libs #f)
@@ -200,7 +202,7 @@
                (match (hash-ref ht 'display-from-libs #f)
                  [(? list? contents)
                   (string-join (map content->string contents) ", ")]
-                 [#f (doc-in)]))
+                 [#f (doc-from)]))
              (define fams (match (hash-ref ht 'language-family #f)
                             [(? list? fams) (string-join (map ~a fams) ", ")]
                             [#f "Racket"]))
@@ -219,39 +221,41 @@
                  [(? class-index-desc?)     "class"]
                  [(? interface-index-desc?) "interface"]
                  [(? mixin-index-desc?)     "mixin"]
-                 [(? method-index-desc?)    (what/method tag)]
+                 [(? 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-in) "" 0)]))
+             (values "documentation" (doc-from) "" 0)]))
         (list sort-order term what from fams path anchor)))
-    (map
-     cdr
-     (sort (set->list results)
-           string<?
-           #:cache-keys? #t
-           #:key
-           (match-lambda
-             [(list sort-order _term what from fams _path _anchor)
-              (string-append (match fams
-                               ["Racket" " Racket"]
-                               [v v])
-                             (~r sort-order
-                                 #:min-width 9
-                                 #:pad-string "0")
-                             (match from
-                               [(and (pregexp "^racket/") v)
-                                (string-append " 0_" v)]
-                               [(and (pregexp "^typed/racket/") v)
-                                (string-append " 1_" v)]
-                               [(and (pregexp "^rhombus") v)
-                                (string-append " 2_" v)]
-                               ["" (make-string 64 #\z)]
-                               [v v])
-                             what)])))))
+    (define sort-key
+      (match-lambda
+        [(list sort-order _term what from fams _path _anchor)
+         (string-append (match fams
+                          ["Racket" " Racket"]
+                          [v v])
+                        (~r sort-order
+                            #:min-width 9
+                            #:pad-string "0")
+                        (match from
+                          [(and (pregexp "^racket/") v)
+                           (string-append " 0_" v)]
+                          [(and (pregexp "^typed/racket/") v)
+                           (string-append " 1_" v)]
+                          [(and (pregexp "^rhombus") v)
+                           (string-append " 2_" v)]
+                          ["" (make-string 64 #\z)]
+                          [v v])
+                        what)]))
+    (define sorted
+      (sort (set->list results)
+            string<?
+            #:cache-keys? #t
+            #:key sort-key))
+    ;; Slice off the first, "sort-order" element
+    (map cdr sorted)))
 
 (module+ test
   ;; Experimental hack to debug test failures happening only on CI and