branch: elpa/racket-mode
commit d9d78bc965c814c9c1a3d13fe5fbaa18c944ae48
Author: Greg Hendershott <[email protected]>
Commit: Greg Hendershott <[email protected]>
Support documentation language families
Implement latest concepts introduced in Racket 9.1.
As discussed in <https://github.com/racket/racket/pull/5409>.
- racket-hash-lang: Expose get-info documentation-language-family.
- Expose get-main-language and get-language-families in new
doc-families back end command. Return a cons of the main family name,
and, a list of association lists with details for each family. The
back end normalizes some variations in data, as well as changing
abstract module paths into concrete absolute real paths.
- Extract language family from documentation page. Display in header
line. Supply racket-describe-choose-language-family to pick a family
for "navigating as", akin to web browser, which ca affect "top" and
"up" navigation, as well as sorting search candidates. The command is
bound to a key, as well as button-ized family text in the header line.
- Implement racket-describe-about-language-family, to view the doc
page (if any) describing the family (often a "Guide" top page).
- describe-search: Sort by the one "preferred" family first, and then
sort by other families that an index item may supply, and using the
'order key from get-language-families. This means for example that
search candidates for HtDP will appear /after/ those for Rhombus, when
the preferred family is neither.
- Fix bug extracting prev/up/next links. (Before, when no prev link,
we'd mismatch up and next.) Strictly speaking this is independent of
doc lang families, but I didn't preserve it as a distinct commit.
---
doc/racket-mode.texi | 4 +
racket-describe.el | 263 ++++++++++++++++++++++++++++++++++----------
racket-hash-lang.el | 11 +-
racket-scribble.el | 33 +++---
racket/command-server.rkt | 3 +-
racket/hash-lang-bridge.rkt | 4 +-
racket/hash-lang.rkt | 4 +-
racket/lang-info.rkt | 3 +-
racket/scribble.rkt | 80 ++++++++++++--
9 files changed, 318 insertions(+), 87 deletions(-)
diff --git a/doc/racket-mode.texi b/doc/racket-mode.texi
index a269ed79ceb..ee99027aeb9 100644
--- a/doc/racket-mode.texi
+++ b/doc/racket-mode.texi
@@ -2204,6 +2204,10 @@ browser program -- are given @ref{racket-ext-link-face}.
@tab @code{racket-describe-nav-top}
@item @kbd{x}
@tab @code{racket-describe-browse-external}
+@item @kbd{L}
+@tab @code{racket-describe-choose-language-family}
+@item @kbd{a}
+@tab @code{racket-describe-about-language-family}
@end multitable
diff --git a/racket-describe.el b/racket-describe.el
index 026838c0257..5c6b61efc23 100644
--- a/racket-describe.el
+++ b/racket-describe.el
@@ -1,6 +1,6 @@
;;; racket-describe.el -*- lexical-binding: t -*-
-;; Copyright (c) 2013-2025 by Greg Hendershott.
+;; Copyright (c) 2013-2026 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
@@ -19,7 +19,10 @@
(require 'racket-back-end)
;; Don't (require 'racket-repl). Mutual dependency. Instead:
(declare-function racket--repl-session-id "racket-repl" ())
-(autoload 'racket--repl-session-id "racket-repl")
+(autoload 'racket--repl-session-id "racket-repl")
+;; Don't (require 'racket-hash-lang-mode). Mutual dependency. Instead:
+(declare-function racket--hash-lang-doc-family "racket-hash-lang" ())
+(autoload 'racket--hash-lang-doc-family "racket-hash-lang")
(defvar-local racket--describe-here nil
"The current navigation point. Either nil or (cons path point).")
@@ -28,6 +31,31 @@
(defvar-local racket--describe-stack-forward nil
"Forward navigation list. Each item is (cons path point).")
+(defvar-local racket--describe-page-family nil
+ "The language family extracted from documentation page.")
+
+(defvar-local racket--describe-as-family nil
+ "When not nil and not equal to `racket--describe-page-family', show
+different UX and use this family for things like top and search sort
+priority.")
+
+(defun racket--describe-family-default-and-choices ()
+ (racket--cmd/await nil `(doc-families)))
+(defun racket--describe-default-family ()
+ (or (car (racket--describe-family-default-and-choices))
+ "Racket"))
+(defun racket--describe-family-choices ()
+ (cdr (racket--describe-family-default-and-choices)))
+(defun racket--describe-family-details (family)
+ (seq-some (lambda (v)
+ (and (string-equal family (cdr (assq 'family v)))
+ v))
+ (racket--describe-family-choices)))
+(defun racket--describe-family-start-doc (family)
+ (cdr (assq 'start-doc (racket--describe-family-details family))))
+(defun racket--describe-family-describe-doc (family)
+ (cdr (assq 'describe-doc (racket--describe-family-details family))))
+
(defun racket--call-with-describe-buffer (thunk)
"Call THUNK in a blank `racket-describe-mode-buffer' and return
the buffer.
@@ -114,11 +142,6 @@ anchor. If numberp, move to that position."
(setq racket--describe-here
(if path (cons path goto) nil))
(setq racket--describe-nav nil)
- (setq header-line-format
- (propertize
- (concat path (cond ((stringp goto) (concat " " goto))
- ((numberp goto) (format " %s" goto))))
- 'face '(:height 0.75)))
;; Although `shr' carefully fills to fit window width, if user
;; resizes window or changes text scaling, we don't want it to wrap.
(setq truncate-lines t)
@@ -141,9 +164,16 @@ anchor. If numberp, move to that position."
(racket-doc-link . ,#'racket-render-tag-racket-doc-link)
(racket-ext-link . ,#'racket-render-tag-racket-ext-link)
(racket-anchor . ,#'racket-render-tag-racket-anchor)
- (racket-nav . ,#'racket-render-tag-racket-nav))))
+ (racket-nav . ,#'racket-render-tag-racket-nav)
+ (racket-family . ,#'racket-render-tag-racket-family))))
(shr-insert-document
(racket--describe-handle-toc-nodes dom)))
+ (let ((path+goto (format " %s %s" path (or goto ""))))
+ (setq header-line-format
+ `((:eval (racket--describe-family-header))
+ (:propertize ,path+goto
+ face (:height 0.75)
+ help-echo ,path+goto))))
;; See doc string for `racket--scribble-temp-nbsp'.
(goto-char (point-min))
(while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
@@ -159,11 +189,11 @@ anchor. If numberp, move to that position."
If `numberp', move to that position.
-If `stringp' move to the position after the anchor that is not
-anchor. There could be multiple anchors before some non-anchor
-text. We want point left where `racket-search-describe' can use
+If `stringp' move to the first position after the anchor that is not
+another anchor. There could be multiple anchors before some non-anchor
+text. We want to leave point where `racket-search-describe' can use
`thing-at-point' to find a symbol."
- (set-window-point ;in case buffer window isnt' selected; #590
+ (set-window-point ;in case buffer window isn't selected; #590
(get-buffer-window (current-buffer))
(cond
((numberp goto)
@@ -343,30 +373,124 @@ for our custom shr handler."
(setq racket--describe-nav dom))
(defun racket--describe-nav (which)
- (interactive)
- (let ((path (dom-attr racket--describe-nav which)))
- (unless path
- (user-error "There is no %s page available" which))
- (setq racket--describe-stack-forward nil)
- (racket--describe-maybe-push-here 'back)
- (racket--describe-fetch-and-show path nil)))
+ (cl-flet ((top ()
+ (racket--describe-family-start-doc
+ (or racket--describe-as-family
+ racket--describe-page-family))))
+ (let* ((dom-path (dom-attr racket--describe-nav which))
+ (path (pcase which
+ ;; When there's a special language family top page,
+ ;; (a) use it to go top and (b) don't go up beyond.
+ ('top (or (top) dom-path))
+ ('up (and (not (equal (top) (car racket--describe-here)))
+ dom-path))
+ (_ dom-path))))
+ (unless path
+ (user-error "No \"%s\" page is available%s"
+ which
+ (if (memq which '(top up))
+ (format " (using language family \"%s\")"
+ (or racket--describe-as-family
+ racket--describe-page-family))
+ "")))
+ (setq racket--describe-stack-forward nil)
+ (racket--describe-maybe-push-here 'back)
+ (racket--describe-fetch-and-show path nil))))
(defun racket-describe-nav-top ()
+ "Navigate to the top page."
(interactive)
(racket--describe-nav 'top))
(defun racket-describe-nav-up ()
+ "Navigate to the parent page."
(interactive)
(racket--describe-nav 'up))
(defun racket-describe-nav-prev ()
+ "Navigate to the previous page."
(interactive)
(racket--describe-nav 'prev))
(defun racket-describe-nav-next ()
+ "Navigate to the next page."
(interactive)
(racket--describe-nav 'next))
+(defun racket-render-tag-racket-family (dom)
+ (setq racket--describe-page-family (dom-attr dom 'data-fam)))
+
+(defun racket--describe-family-header ()
+ (if (not racket--describe-page-family)
+ ""
+ ;; `buttonize' not availabe in older Emacs, so...
+ (cl-flet ((button (str help-echo)
+ (propertize
+ str
+ 'button t
+ 'follow-link t
+ 'category t
+ 'keymap button-map
+ 'action #'racket-describe-choose-language-family
+ 'face '(:underline t :height 0.75)
+ 'mouse-face 'highlight
+ 'help-echo help-echo)))
+ (if (or (not racket--describe-as-family)
+ (equal racket--describe-as-family
+ racket--describe-page-family))
+ (button
+ racket--describe-page-family
+ "Documentation language family; click to navigate using another
family")
+ (concat
+ (propertize (concat racket--describe-page-family " ")
+ 'face '(:height 0.75)
+ 'help-echo "Documentation language family")
+ (button
+ (concat "(as " racket--describe-as-family ")")
+ "Navigating as family; click to change"))))))
+
+(defun racket--describe-completing-read-family (prompt)
+ (let* ((vs (racket--describe-family-choices))
+ (vs (seq-sort (lambda (a b)
+ (or (> (or (cdr (assq 'order a)) 0)
+ (or (cdr (assq 'order b)) 0))
+ (string< (cdr (assq 'family a))
+ (cdr (assq 'family b)))))
+ vs))
+ (names (seq-map (lambda (v)
+ (cdr (assq 'family v)))
+ vs)))
+ (completing-read prompt
+ names
+ nil ;predicate
+ t ;require-match
+ nil ;initial-input
+ 'racket-documentation-language-family)))
+
+(defun racket-describe-choose-language-family (&optional _button)
+ "Choose a documentation language family with which to navigate.
+
+The family can affect `racket-describe-nav-top' and order in which
+`racket-describe-search' sorts candidates."
+ (interactive)
+ (when-let (name (racket--describe-completing-read-family
+ "Navigate documentation as language family: "))
+ (setq racket--describe-as-family name)))
+
+(defun racket-describe-about-language-family ()
+ "Show the documentation page about a language family.
+
+For some languages, this will be something like a \"Guide\" table of
+contents. For other languages, it might be the same as the top page,
+i.e. `racket-describe-nav-top'."
+ (interactive)
+ (when-let (name (racket--describe-completing-read-family
+ "View documentation about language family: "))
+ (when-let (about (racket--describe-family-describe-doc name))
+ (setq racket--describe-stack-forward nil)
+ (racket--describe-maybe-push-here 'back)
+ (racket--describe-fetch-and-show about nil))))
+
(defun racket--describe-fetch-and-show (path goto)
"Insert shr dom for PATH and move point to GOTO.
@@ -547,7 +671,9 @@ current line and looking back."
("p" ,#'racket-describe-nav-prev)
("^" ,#'racket-describe-nav-up)
("C-^" ,#'racket-describe-nav-top)
- ("x" ,#'racket-describe-browse-external)))))
+ ("x" ,#'racket-describe-browse-external)
+ ("L" ,#'racket-describe-choose-language-family)
+ ("a"
,#'racket-describe-about-language-family)))))
(define-key map [XF86Back] 'racket-describe-back)
(define-key map [XF86Forward] 'racket-describe-back)
(set-keymap-parent map special-mode-map)
@@ -615,6 +741,15 @@ Return nil or \(term path anchor lib\)."
[32 racket-describe-search-from-libs]
[0
racket-describe-search-lang-fams]]))
(candidates nil)
+ (first-family (or racket--describe-as-family ;buffer-local
+ racket--describe-page-family ;buffer-local
+ (racket--hash-lang-doc-family)
+ (racket--describe-default-family)))
+ (family-orders (seq-map (lambda (v)
+ (cons (cdr (assq 'family v))
+ (- (or (cdr (assq 'order v))
+ 0))))
+ (racket--describe-family-choices)))
(collection
(lambda (string predicate action)
(cond
@@ -627,8 +762,11 @@ Return nil or \(term path anchor lib\)."
(t
(when (eq action t)
(setq candidates
- (racket--describe-search-make-strings
- (racket--cmd/await nil `(doc-search ,string)))))
+ (mapcar (apply-partially
+ #'racket--describe-search-make-string
+ first-family
+ family-orders)
+ (racket--cmd/await nil `(doc-search ,string)))))
(funcall (cond
((null action) #'try-completion)
((eq action t) #'all-completions)
@@ -640,7 +778,7 @@ Return nil or \(term path anchor lib\)."
(lambda (v)
(apply racket-doc-index-predicate-function
(get-text-property 0 'racket-affix v))))
- (prompt "Search Racket documentation: ")
+ (prompt "Search documentation: ")
(require-match t)
(initial-input (racket--thing-at-point 'symbol t))
(history 'racket-identifier)
@@ -658,28 +796,47 @@ Return nil or \(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.
+(defun racket--describe-search-make-string (first-family family-orders item)
+ "Make a candidate string from back end ITEM.
+
+FIRST-FAMILY is a language family that, if an index item says that's one
+of its families, it should sort before all other similar items.
+
+FAMILY-ORDERS is an alist from family name to the \"order\" mapping
+supplied by get-language-families, albeit negated. This is used to sort
+index items by their language families, when none are FIRST-FAMILY.
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-sort
- ,path ,anchor))
- (let* ((term (propertize term
- 'racket-affix (list what from 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))
+display-sort functions, used by `completing-read'.
+
+But note that `completing-read' returns a string stripped of text
+properties. To return values besides the term, we append them tab
+separated, as invisible text. Use `racket--describe-search-parse-result'
+to extract."
+ (pcase-let*
+ ((`(,term ,sort-order ,what ,from ,fams ,pkg-sort ,path ,anchor) item)
+ (affix (list what from (string-join fams ", ")))
+ (sort (list term
+ (if (member first-family fams)
+ " "
+ (string-join
+ (seq-map (lambda (fam)
+ (format "%09d"
+ (or (cdr (assoc fam family-orders))
+ 0)))
+ fams)))
+ (string-join fams ",")
+ (format "%09d" pkg-sort)
+ from
+ what
+ (format "%09d" sort-order)))
+ (term (propertize term
+ 'racket-affix affix
+ 'racket-sort sort))
+ (lib (substring from 0 (string-match (rx ?,) from)))
+ (data (concat "\t" path "\t" anchor "\t" lib))
+ (data (propertize data 'display "")))
+ (concat term data)))
(defun racket--describe-search-parse-result (str)
(when (string-match (rx bos
@@ -695,24 +852,8 @@ extract."
(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 (v)
+ (get-text-property 0 'racket-sort v))
(key< (as bs)
(cl-loop for a in as
for b in bs
diff --git a/racket-hash-lang.el b/racket-hash-lang.el
index fb9e4ea3342..667d3171024 100644
--- a/racket-hash-lang.el
+++ b/racket-hash-lang.el
@@ -1,6 +1,6 @@
;;; racket-hash-lang.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2020-2025 by Greg Hendershott.
+;; Copyright (c) 2020-2026 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
@@ -196,6 +196,13 @@ re-tokenization has progressed sufficiently.")
(defvar-local racket-hash-lang-mode-lighter "#lang")
+(defvar-local racket--hash-lang-doc-family nil
+ "The get-info value for the key documentation-language-family.")
+(defun racket--hash-lang-doc-family ()
+ "Exposed for `racket--describe-search-completing-read' to call."
+ (and (eq major-mode 'racket-hash-lang-mode)
+ racket--hash-lang-doc-family))
+
(defconst racket--agnostic-syntax-table
(let ((table (make-syntax-table)))
;; From Emacs Lisp Info node "Syntax Table Internals":
@@ -495,6 +502,8 @@ lang's attributes that we care about have changed."
(concat "#lang"
(when (plist-get plist 'racket-grouping) "()")
(when (plist-get plist 'range-indenter) "⇉")))
+ (setq-local racket--hash-lang-doc-family
+ (plist-get plist 'documentation-language-family))
;; Finally run user's module-language-hook.
(run-hook-with-args 'racket-hash-lang-module-language-hook
(plist-get plist 'module-language)))))
diff --git a/racket-scribble.el b/racket-scribble.el
index b427cd2467d..f220be913b7 100644
--- a/racket-scribble.el
+++ b/racket-scribble.el
@@ -1,6 +1,6 @@
;;; racket-scribble.el -*- lexical-binding: t -*-
-;; Copyright (c) 2021-2024 by Greg Hendershott.
+;; Copyright (c) 2021-2026 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
@@ -131,20 +131,25 @@ avoid penalty."
(pcase (dom-attr v 'class)
;; Page navigation.
("navsettop"
- (pcase-let* ((navleft (car (dom-by-class v "navleft")))
- (top (dom-attr (car (dom-by-tag navleft 'a)) 'href))
- (navright (car (dom-by-class v "navright")))
- (`(,prev ,up ,next)
- (mapcar (lambda (v) (dom-attr v 'href))
- (dom-by-tag navright 'a))))
- (if (and top up)
- `(racket-nav
- ((top . ,(expand-file-name top racket--scribble-base))
- (prev . ,(and prev (expand-file-name prev
racket--scribble-base)))
- (up . ,(expand-file-name up racket--scribble-base))
- (next . ,(and next (expand-file-name next
racket--scribble-base)))))
- `(span))))
+ (let* ((navleft (car (dom-by-class v "navleft")))
+ (top (dom-attr (car (dom-by-tag navleft 'a)) 'href))
+ (navright (car (dom-by-class v "navright")))
+ (as (mapcar (lambda (v)
+ (cons (or (dom-attr v 'rel) "up")
+ (dom-attr v 'href)))
+ (dom-by-tag navright 'a)))
+ (prev (cdr (assoc "prev" as)))
+ (up (cdr (assoc "up" as)))
+ (next (cdr (assoc "next" as))))
+ `(racket-nav
+ ((top . ,(and top (expand-file-name top racket--scribble-base)))
+ (prev . ,(and prev (expand-file-name prev
racket--scribble-base)))
+ (up . ,(and up (expand-file-name up racket--scribble-base)))
+ (next . ,(and next (expand-file-name next
racket--scribble-base)))))))
("navsetbottom" `(span))
+ ;; Language family
+ ("navfamily"
+ `(racket-family ((data-fam . ,(dom-attr v 'data-fam)))))
;; The kind (e.g. "procedure" or "syntax"): Add <hr>
("RBackgroundLabel SIEHidden"
`(div ()
diff --git a/racket/command-server.rkt b/racket/command-server.rkt
index 7df1dff66c2..ff31e5f28a1 100644
--- a/racket/command-server.rkt
+++ b/racket/command-server.rkt
@@ -32,7 +32,7 @@
package-details
package-op
catalog-package-doc-link)]
- ["scribble.rkt" (bluebox-command doc-search)])
+ ["scribble.rkt" (bluebox-command doc-search doc-families)])
(provide command-server-loop)
@@ -147,6 +147,7 @@
[`(requires/trim ,path-str) (requires/trim path-str)]
[`(requires/base ,path-str) (requires/base path-str)]
[`(doc-search ,prefix) (doc-search prefix)]
+ [`(doc-families) (doc-families)]
[`(hash-lang . ,more) (apply hash-lang more)]
[`(pkg-list) (package-list)]
[`(pkg-details ,str) (package-details str)]
diff --git a/racket/hash-lang-bridge.rkt b/racket/hash-lang-bridge.rkt
index 06a77206ee9..6bc07eced55 100644
--- a/racket/hash-lang-bridge.rkt
+++ b/racket/hash-lang-bridge.rkt
@@ -56,7 +56,9 @@
(cons (symbol->string o) (symbol->string c)))
'quote-matches (for/list ([c (in-list (lang-info-quote-matches
li))])
(make-string 1 c))
- 'comment-delimiters (lang-info-comment-delimiters li))))
+ 'comment-delimiters (lang-info-comment-delimiters li)
+ 'documentation-language-family
+ (lang-info-documentation-language-family li))))
(define/override (on-changed-tokens gen beg end)
(when (< beg end)
(async-channel-put hash-lang-notify-channel
diff --git a/racket/hash-lang.rkt b/racket/hash-lang.rkt
index 412562370b4..f58794cd3f2 100644
--- a/racket/hash-lang.rkt
+++ b/racket/hash-lang.rkt
@@ -693,6 +693,7 @@
#f
#f
#f
+ #f
#f))
(define (read-lang-info* in)
@@ -710,7 +711,8 @@
(info 'drracket:range-indentation #f)
(info 'drracket:range-indentation/reverse-choices #f)
(info 'drracket:submit-predicate #f)
- (comment-delimiters info mod-lang))
+ (comment-delimiters info mod-lang)
+ (info 'documentation-language-family #f))
end-pos))
;; Handle the module-language lang info key, as documented at
diff --git a/racket/lang-info.rkt b/racket/lang-info.rkt
index 076de124b58..348d5bf443f 100644
--- a/racket/lang-info.rkt
+++ b/racket/lang-info.rkt
@@ -19,7 +19,8 @@
range-indenter
reverse-range-indenter
submit-predicate
- comment-delimiters)
+ comment-delimiters
+ documentation-language-family)
#:transparent #:authentic)
(define racket-grouping-position
diff --git a/racket/scribble.rkt b/racket/scribble.rkt
index c12905422d8..74e498a957e 100644
--- a/racket/scribble.rkt
+++ b/racket/scribble.rkt
@@ -1,4 +1,4 @@
-;; Copyright (c) 2013-2025 by Greg Hendershott.
+;; Copyright (c) 2013-2026 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later
#lang racket/base
@@ -19,6 +19,7 @@
setup/main-doc
"define-fallbacks.rkt"
"lib-pkg.rkt"
+ "safe-dynamic-require.rkt"
"util.rkt"
"xref.rkt")
@@ -34,6 +35,7 @@
identifier->bluebox
bluebox-command
doc-search
+ doc-families
module-doc-path
refresh-doc-index!)
@@ -223,8 +225,8 @@
(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"]))
+ [(? list? fams) fams]
+ [#f '("Racket")]))
(define pkg-sort (lib-pkg-sort
(match (exported-index-desc-from-libs desc)
[(cons lib _) lib]
@@ -249,8 +251,8 @@
[(or 'lib 'lang 'reader) term]
[_ (doc-from)])]))
(define fams (match (hash-ref ht 'language-family #f)
- [(? list? fams) (string-join (map ~a fams) ", ")]
- [#f "Racket"]))
+ [(? list? fams) fams]
+ [#f '("Racket")]))
(define pkg-sort (lib-pkg-sort
(match module-kind
['lib (string->symbol term)]
@@ -277,13 +279,13 @@
(match (exported-index-desc-from-libs desc)
[(cons lib _) lib]
[_ #f])))
- (values what from "" pkg-sort 0)]
+ (values what from null pkg-sort 0)]
[(module-path-index-desc? desc)
(define pkg-sort (lib-pkg-sort (string->symbol term)))
(values "module" "" "" pkg-sort 0)]
[else
(define pkg-sort (lib-pkg-sort #f))
- (values "documentation" (doc-from) "" pkg-sort 0)]))
+ (values "documentation" (doc-from) null pkg-sort 0)]))
(list term sort-order what from fams pkg-sort path anchor))
;; This is for package-details
@@ -293,3 +295,67 @@
(and (equal? term mod-path-str)
(equal? what (if lang? "language" "module"))
(cons path anchor))))
+
+;; Documentation language family information added in Racket 9.1.
+(define doc-families
+ ;; Require some functions both dynamically (in case don't exist in
+ ;; older Racket) and lazily (faster initial load of back end).
+ (let ([get-main-language-family #f]
+ [get-language-families #f]
+ [get-doc-search-dirs #f])
+ (λ ()
+ (define-syntax-rule (req/set! mod fn def-val)
+ (unless fn
+ (set! fn (safe-dynamic-require 'mod 'fn (λ () (λ () def-val))))))
+ (req/set! setup/dirs get-main-language-family "Racket")
+ (req/set! setup/language-family get-language-families null)
+ (req/set! setup/dirs get-doc-search-dirs null)
+ ;; Return cons of main family name, and, list of details for all
+ ;; families. Adjust the details somewhat, from what
+ ;; get-language-families supplies.
+ (define xref (get-xref))
+ (define doc-dirs (get-doc-search-dirs))
+ (cons
+ (get-main-language-family)
+ (for/list ([ht (in-list (get-language-families))])
+ (let* (;; Convert abstract module paths to concrete absolute paths.
+ [ht (for/hash ([(k v) (in-hash ht)])
+ (cond [(memq k '(doc start-doc describe-doc))
+ (values k (module-path->absolute-path xref v))]
+ [else
+ (values k v)]))]
+ ;; If describe-doc not mapped, use doc.
+ [ht (cond
+ [(hash-has-key? ht 'describe-doc) ht]
+ [(hash-ref ht 'doc #f)
+ => (λ (v) (hash-set ht 'describe-doc v))]
+ [else ht])]
+ ;; If start-doc not mapped, use doc, else use
+ ;; family-root. See similar logic in
+ ;; send-language-family-page and send-main-page.
+ [ht (cond
+ [(hash-has-key? ht 'start-doc) ht]
+ [(hash-ref ht 'doc #f)
+ => (λ (v) (hash-set ht 'start-doc v))]
+ [(hash-ref ht 'family-root #f)
+ =>
+ (λ (sub)
+ (or (for/or ([dir (in-list doc-dirs)])
+ (define path (build-path dir sub "index.html"))
+ (and (file-exists? path)
+ (hash-set ht 'start-doc path)))
+ ht))]
+ [else ht])]
+ [ht (hash-remove ht 'doc)])
+ (hash->list ht)))))))
+
+;; Convert mod path => part tag => absolute path.
+;; See send-language-family-page.
+
+(define (module-path->absolute-path xref mp)
+ (define-values (path _anchor)
+ (xref-tag->path+anchor xref (module-path->part-tag mp)))
+ path)
+
+(define (module-path->part-tag mp)
+ `(part (,(format "~a" mp) "top")))
