scribble: #:doc-id argument to load-xref and associated plumbing

Keep track of the target document name (i.e., the name of the
directory that will contain the target document) for a cross
reference, when known. This identification enables a simpler dynamic
resolution of a hyperlink in almost all cases, istead of requiring
a search for an arbitrary corss-reference key.

Indirect links still need a mapping of cross-reference keys
to document locations, but the mapping can be pruned to just
section and module-name keys.

This change cuts a generated "local-redirect.js" for the main
distribution to 1/8 of its size.

original commit: a956918adb1ffe69b7cefea00f3c9d594f58734a

pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl

@@ -1354,6 +1354,16 @@ whether the resulting information originated from an external source
 (i.e., a different document).}
 
 
+@defproc[(resolve-get/ext-id [p (or/c part? #f)] [ri resolve-info?] [key info-key?])
+         (values any/c (or/c boolean? string?))]{
+
+Like @racket[render-get/ext?], but the second result can be a string
+to indicate the source document's identification as established via
+@racket[load-xref] and a @racket[#:doc-id] argument.
+
+@history[#:added "1.1"]}
+
+
 @defproc[(resolve-search [dep-key any/c] [p (or/c part? #f)] [ri resolve-info?] [key info-key?])
          void?]{
 

pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/renderer.scrbl

@@ -320,10 +320,16 @@ Specializes a @racket[render<%>] class for generating HTML output.
 
 @defmethod[(set-external-tag-path [url string?]) void?]{
 
-Configures the renderer to redirect links to external via
+Configures the renderer to redirect links to external documents via
-@racket[url], adding a @racket[tag] query element to the end of the
+@racket[url], adding a @tt{tag} query element to the end of the
 URL that contains the Base64-encoded, @racket[print]ed, serialized
-original tag (in the sense of @racket[link-element]) for the link.}
+original tag (in the sense of @racket[link-element]) for the link.
+
+If the link is based on a cross-reference entry that has a
+document-identifying string (see @racket[load-xref] and its
+@racket[#:doc-id] argument), the document identifier is added as a
+@tt{doc} query element, and a path to the target within the
+document is added as a @tt{rel} query element.}
 
 @defmethod[(set-external-root-url [url string?]) void?]{
 

pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/xref.scrbl

@@ -25,7 +25,8 @@ by @racket[load-xref], @racket[#f] otherwise.}
                                      (lambda (_tag) #f)]
                     [#:render% using-render% (implementation?/c render<%>)
                                (render-mixin render%)]
-                    [#:root root-path (or/c path-string? false/c) #f])
+                    [#:root root-path (or/c path-string? false/c) #f]
+                    [#:doc-id doc-id-str (or/c path-string? false/c) #f])
          xref?]{
 
 Creates a cross-reference record given a list of functions,
@@ -38,9 +39,11 @@ serialize-info]. The result of @racket[_source] can optionally be
 another function, which is in turn responsible for returning a list of
 @racket[_info]s. Finally, each @racket[_info] can be either serialized
 information, a @racket[#f] to be ignored, or a value produced by
-@racket[make-data+root] from which @racket[_data] part is used as
+@racket[make-data+root] or @racket[make-data+root+doc-id], from which
-serialized information and the @racket[_root] part overrides
+@racket[_data] part is used as serialized information, the
-@racket[root-path] for deserialization.
+@racket[_root] part overrides @racket[root-path] for deserialization,
+and the @racket[_doc-id] part (if any) overrides
+@racket[doc-id-string] to identify the source document.
 
 The @racket[demand-source] function can effectively add a new source
 to @racket[sources] in response to a search for information on the
@@ -60,8 +63,16 @@ but a @racket[make-data+root] result for any @racket[_info] supplies
 an alternate path for deserialization of the @racket[_info]'s
 @racket[_data].
 
+If @racket[doc-id-str] is not @racket[#f], it identifies each
+cross-reference entry as originating from @racket[doc-id-str]. This
+identification is used when a rendering link to the cross-reference
+entry as an external query; see the @racket[set-external-tag-path]
+method of @racket[render-mixin].
+
 Use @racket[load-collections-xref] from @racketmodname[setup/xref] to
-get all cross-reference information for installed documentation.}
+get all cross-reference information for installed documentation.
+
+@history[#:changed "1.1" @elem{Added the @racket[#:doc-id] argument.}]}
 
 
 @defproc[(xref-binding->definition-tag [xref xref?]
@@ -213,3 +224,13 @@ the destination for the index link into the main document.}
 A value constructed by @racket[make-data+root] can be returned by a
 source procedure for @racket[load-xref] to specify a path used for
 deserialization.}
+
+@deftogether[(
+@defproc[(data+root+doc-id? [v any/c]) boolean?]
+@defproc[(make-data+root+doc-id [data any/c] [root (or/c #f path-string?)] [doc-id string?]) data+root+doc-id?]
+)]{
+
+Extends @racket[make-data+root+doc-id] to support an
+document-identifying string (see @racket[load-xref]).
+
+@history[#:added "1.1"]}

pkgs/scribble-pkgs/scribble-lib/scribble/base-render.rkt

@@ -353,13 +353,13 @@
            (when rp
              (set-mobile-root-path! root rp))))))
 
-    (define/public (deserialize-info v ci #:root [root-path #f])
+    (define/public (deserialize-info v ci #:root [root-path #f] #:doc-id [doc-id #f])
       (let ([root+ht (deserialize v)]
             [in-ht (collect-info-ext-ht ci)])
         (when root-path
           (set-mobile-root-path! (car root+ht) root-path))
         (for ([(k v) (cdr root+ht)])
-          (hash-set! in-ht k v))))
+          (hash-set! in-ht k (if doc-id (known-doc v doc-id) v)))))
 
     (define/public (get-defined ci)
       (hash-map (collect-info-ht ci) (lambda (k v) k)))

pkgs/scribble-pkgs/scribble-lib/scribble/base.rkt

@@ -729,7 +729,8 @@
          (collect-info-ext-ht ci))))
    (lambda (k v)
      (when (and (pair? k) (eq? 'index-entry (car k)))
-       (set! l (cons (cons (cadr k) v) l)))))
+       (let ([v (if (known-doc? v) (known-doc-v v) v)])
+         (set! l (cons (cons (cadr k) v) l))))))
   (sort l entry<?))
 
 (define (index-block)

pkgs/scribble-pkgs/scribble-lib/scribble/core.rkt

@@ -37,31 +37,37 @@
          (define ci (resolve-info-ci ri))
          (define (try-ext)
            (hash-ref (collect-info-ext-ht ci) key #f))
-         (values
+         (define v
-          (or (try-ext)
+           (or (try-ext)
-              (and ((collect-info-ext-demand ci) key ci)
+               (and ((collect-info-ext-demand ci) key ci)
-                   (try-ext)))
+                    (try-ext))))
-          #t)]))))
+         (if (known-doc? v)
+             (values (known-doc-v v) (known-doc-id v))
+             (values v #t))]))))
 
 (define (resolve-get/ext? part ri key)
-  (resolve-get/ext?* part ri key #f))
+  (define-values (v ext-id) (resolve-get/ext-id* part ri key #f))
+  (values v (and ext-id #t)))
 
-(define (resolve-get/ext?* part ri key search-key)
+(define (resolve-get/ext-id part ri key)
-  (let-values ([(v ext?) (resolve-get/where part ri key)])
+  (resolve-get/ext-id* part ri key #f))
-    (when ext?
+
+(define (resolve-get/ext-id* part ri key search-key)
+  (let-values ([(v ext-id) (resolve-get/where part ri key)])
+    (when ext-id
       (hash-set! (resolve-info-undef ri) (tag-key key ri) 
                  (if v 'found search-key)))
-    (values v ext?)))
+    (values v ext-id)))
 
 (define (resolve-get part ri key)
   (resolve-get* part ri key #f))
 
 (define (resolve-get* part ri key search-key)
-  (let-values ([(v ext?) (resolve-get/ext?* part ri key search-key)])
+  (let-values ([(v ext-id) (resolve-get/ext-id* part ri key search-key)])
     v))
 
 (define (resolve-get/tentative part ri key)
-  (let-values ([(v ext?) (resolve-get/where part ri key)])
+  (let-values ([(v ext-id) (resolve-get/where part ri key)])
     v))
 
 (define (resolve-search search-key part ri key)
@@ -215,7 +221,10 @@
 
  [collected-info ([number (listof (or/c false/c exact-nonnegative-integer? string?))]
                   [parent (or/c false/c part?)]
-                  [info any/c])])
+                  [info any/c])]
+
+ [known-doc ([v any/c]
+             [id string?])])
 
 (provide plain)
 (define plain (make-style #f null))
@@ -715,5 +724,6 @@
  [resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)]
  [resolve-get/tentative ((or/c part? false/c) resolve-info? info-key? . -> . any)]
  [resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)]
+ [resolve-get/ext-id ((or/c part? false/c) resolve-info? info-key? . -> . any)]
  [resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)]
  [resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)])

pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt

@@ -508,6 +508,19 @@
                            (anchor-name (dest-anchor dest))))))
           "???"))
 
+    (define/private (dest->url-in-doc dest)
+      (and dest
+           (not (dest-redirect dest))
+           (format "~a~a~a"
+                   (let-values ([(base name dir?) (split-path
+                                                   (relative->path (dest-path dest)))])
+                     name)
+                   (if (dest-page? dest) "" "#")
+                   (if (dest-page? dest)
+                       ""
+                       (uri-unreserved-encode
+                        (anchor-name (dest-anchor dest)))))))
+
     (define/public (render-toc-view d ri)
       (define has-sub-parts?
         (pair? (part-parts d)))
@@ -1239,15 +1252,15 @@
         [(and (link-element? e) (not (current-no-links)))
          (parameterize ([current-no-links #t])
            (define indirect-link? (link-element-indirect? e))
-           (let-values ([(dest ext?)
+           (let-values ([(dest ext-id)
                          (if (and indirect-link?
                                   external-tag-path)
                              (values #f #f)
-                             (resolve-get/ext? part ri (link-element-tag e)))])
+                             (resolve-get/ext-id part ri (link-element-tag e)))])
              (if (or indirect-link? dest)
-               `((a [(href
+                 `((a ([href
                       ,(cond
-                        [(and ext? external-root-url
+                        [(and ext-id external-root-url
                               (let ([rel (find-relative-path
                                           (find-doc-dir)
                                           (relative->path (dest-path dest)))])
@@ -1270,7 +1283,7 @@
                                  (and (not (dest-page? dest))
                                       (anchor-name (dest-anchor dest)))])))]
                         [(or indirect-link?
-                             (and ext? external-tag-path))
+                             (and ext-id external-tag-path))
                          ;; Redirected to search:
                          (url->string*
                           (let ([u (string->url (or external-tag-path
@@ -1279,16 +1292,20 @@
                              url
                              u
                              [query
-                              (cons (cons 'tag (tag->query-string (link-element-tag e)))
+                              (if (string? ext-id)
-                                    (url-query u))])))]
+                                  (list* (cons 'doc ext-id)
+                                         (cons 'rel (or (dest->url-in-doc dest) "???"))
+                                         (url-query u))
+                                  (cons (cons 'tag (tag->query-string (link-element-tag e)))
+                                        (url-query u)))])))]
                         [else
                          ;; Normal link:
-                         (dest->url dest)]))
+                         (dest->url dest)])]
                      ,@(attribs (if (or indirect-link?
-                                        (and ext? external-tag-path))
+                                        (and ext-id external-tag-path))
-                                    '((class "Sq"))
+                                    '([class "Sq"])
                                     null))
-                     [data-pltdoc "x"]]
+                     [data-pltdoc "x"])
                     ,@(if (empty-content? (element-content e))
                           (render-content (strip-aux (dest-title dest)) part ri)
                           (render-content (element-content e) part ri))))

pkgs/scribble-pkgs/scribble-lib/scribble/xref.rkt

@@ -1,6 +1,7 @@
 #lang scheme/base
 
 (require scribble/struct
+         (only-in scribble/core known-doc? known-doc-v)
          scribble/base-render
          scribble/search
          (prefix-in html: scribble/html-render)
@@ -17,7 +18,9 @@
          xref-transfer-info
          (struct-out entry)
          make-data+root
-         data+root?)
+         data+root?
+         make-data+root+doc-id
+         data+root+doc-id?)
 
 (define-struct entry
   (words    ; list of strings: main term, sub-term, etc.
@@ -26,6 +29,7 @@
    desc))   ; further info that depends on the kind of index entry
 
 (define-struct data+root (data root))
+(define-struct (data+root+doc-id data+root) (doc-id))
 
 ;; Private:
 (define-struct xrefs (renderer ri))
@@ -40,7 +44,8 @@
 (define (load-xref sources
                    #:demand-source [demand-source (lambda (key) #f)]
                    #:render% [render% (html:render-mixin render%)]
-                   #:root [root-path #f])
+                   #:root [root-path #f]
+                   #:doc-id [doc-id-str #f])
   (let* ([renderer (new render% [dest-dir (find-system-path 'temp-dir)])]
          [fp (send renderer traverse null null)]
          [load-source (lambda (src ci)
@@ -51,7 +56,11 @@
                               (when v
                                 (define data (if (data+root? v) (data+root-data v) v))
                                 (define root (if (data+root? v) (data+root-root v) root-path))
-                                (send renderer deserialize-info data ci #:root root))))))]
+                                (define doc-id (or (and (data+root+doc-id? v) (data+root+doc-id-doc-id v))
+                                                   doc-id-str))
+                                (send renderer deserialize-info data ci
+                                      #:root root
+                                      #:doc-id doc-id))))))]
          [ci (send renderer collect null null fp
                    (lambda (key ci)
                      (define src (demand-source key))
@@ -73,7 +82,10 @@
              #:when
              (and (pair? k)
                   (eq? (car k) 'index-entry)))
-    (make-entry (car v) (cadr v) (cadr k) (caddr v))))
+    (let ([v (if (known-doc? v)
+                 (known-doc-v v)
+                 v)])
+      (make-entry (car v) (cadr v) (cadr k) (caddr v)))))
 
 ;; dest-file can be #f, which will make it return a string holding the
 ;; resulting html
@@ -151,8 +163,11 @@
             (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
             `(index-entry ,tag)
             #f)])
-    (cond [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))]
+    (let ([v (if (known-doc? v)
-          [(and (pair? tag) (eq? 'form (car tag)))
+                 (known-doc-v v)
-           ;; Try again with 'def:
+                 v)])
-           (xref-tag->index-entry xrefs (cons 'def (cdr tag)))]
+      (cond [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))]
-          [else #f])))
+            [(and (pair? tag) (eq? 'form (car tag)))
+             ;; Try again with 'def:
+             (xref-tag->index-entry xrefs (cons 'def (cdr tag)))]
+            [else #f]))))