doc search & redirect: user as an extension of main

When rendering the user documentation-search page or
local-redirect page, only user-specific documentation is
included, which makes rendering faster and automatically
picks up any installation-scope additions.

The documentation start page is still static, so the
user version doesn't pick up installation-scope
additions in the same way.

Related to PR 14180
(cherry picked from commit 7bba67d107)
This commit is contained in:
Matthew Flatt 2013-11-28 10:25:00 -07:00 committed by Ryan Culpepper
parent 560d4c55ad
commit e249acdbed
8 changed files with 270 additions and 75 deletions

View File

@ -347,12 +347,17 @@ Optional @filepath{info.rkt} fields trigger additional actions by
@item{@racket['depends-all] : Indicates that the document should
be re-built if any other document is rebuilt---except for
documents that have the @racket['no-depends-on] mode.}
documents that have the @racket['no-depend-on] mode.}
@item{@racket['depends-all-main] : Indicates that the document
should be re-built if any other document is rebuilt that is
installed into the main installation---except for documents
that have the @racket['no-depends-on] mode.}
that have the @racket['no-depend-on] mode.}
@item{@racket['depends-all-user] : Indicates that the document
should be re-built if any other document is rebuilt that is
installed into the user's space---except for documents
that have the @racket['no-depend-on] mode.}
@item{@racket['always-run] : Build the document every time that
@exec{raco setup} is run, even if none of its dependencies

View File

@ -0,0 +1,19 @@
#lang racket/base
(require setup/dirs
racket/path)
(provide index-at-user?)
(define (index-at-user?)
(define p
(find-relative-path
(collection-file-path "index-scope.rkt" "scribblings/main/private")
(find-user-pkgs-dir)
#:more-than-root? #t))
(and (path? p)
(let loop ([p p])
(let-values ([(base name dir?) (split-path p)])
(and (eq? name 'up)
(or (and (path? base)
(loop base))
(eq? base 'relative)))))))

View File

@ -5,41 +5,51 @@
racket/match
setup/dirs
net/url
scribble/html-properties)
scribble/html-properties
"index-scope.rkt")
(provide make-local-redirect)
(define rewrite-code
(define (rewrite-code user?)
(define prefix (if user? "user_" ""))
@string-append|{
function bsearch(str, start, end) {
function |@|prefix|bsearch(str, start, end) {
if (start >= end)
return false;
else {
var mid = Math.floor((start + end) / 2);
if (link_targets[mid][0] == str)
if (|@|prefix|link_targets[mid][0] == str)
return mid;
else if (link_targets[mid][0] < str)
return bsearch(str, mid+1, end);
else if (|@|prefix|link_targets[mid][0] < str)
return |@|prefix|bsearch(str, mid+1, end);
else
return bsearch(str, start, mid);
return |@|prefix|bsearch(str, start, mid);
}
}
function convert_all_links() {
var |@|prefix|link_target_prefix = false;
function |@|prefix|convert_all_links() {
var elements = document.getElementsByClassName("Sq");
for (var i = 0; i < elements.length; i++) {
var elem = elements[i];
var n = elem.href.match(/tag=[^&]*/);
if (n) {
var pos = bsearch(decodeURIComponent(n[0].substring(4)), 0, link_targets.length);
var pos = |@|prefix|bsearch(decodeURIComponent(n[0].substring(4)),
0,
|@|prefix|link_targets.length);
if (pos) {
elem.href = link_targets[pos][1];
var p = |@|prefix|link_targets[pos][1];
if (|@|prefix|link_target_prefix) {
p = |@|prefix|link_target_prefix + p;
}
elem.href = p;
}
}
}
}
AddOnLoad(convert_all_links);
AddOnLoad(|@|prefix|convert_all_links);
}|)
(define search-code
@ -66,15 +76,29 @@
}|)
(define (make-local-redirect user?)
(define main-at-user? (index-at-user?))
(list
(make-render-element
#f
null
(lambda (renderer p ri)
(define keys (resolve-get-keys #f ri (lambda (v) #t)))
(define keys (if (and main-at-user? (not user?))
;; If there's no installation-scope "doc", then
;; the "main" redirection table is useless.
null
(resolve-get-keys #f ri (lambda (v) #t))))
(define (target? v) (and (vector? v) (= 5 (vector-length v))))
(define dest (build-path (send renderer get-dest-directory #t)
"local-redirect.js"))
(define dest-dir (send renderer get-dest-directory #t))
(define (make-dest user?)
(build-path dest-dir
(if user?
"local-user-redirect.js"
"local-redirect.js")))
(define dest (make-dest user?))
(define alt-dest (make-dest (not user?)))
;; Whether references include user and/or main docs is determined
;; by 'depends-all-main, 'depends-all-user, or 'depends-all flag
;; in "info.rkt".
(define db
(sort (for/list ([k (in-list keys)]
#:when (tag? k)
@ -91,16 +115,31 @@
(fprintf o "// This script is included by generated documentation to rewrite\n")
(fprintf o "// links expressed as tag queries into local-filesystem links.\n")
(newline o)
(fprintf o "var link_targets = [")
(fprintf o "link_target_prefix = ~s;\n" (url->string
(path->url
(path->directory-path
(build-path (find-doc-dir) "local-redirect")))))
(newline o)
(fprintf o "var ~alink_targets = [" (if user? "user_" ""))
(for ([e (in-list db)]
[i (in-naturals)])
(fprintf o (if (zero? i) "\n" ",\n"))
(fprintf o " [~s, ~s]" (car e) (cadr e)))
(fprintf o "];\n\n")
(fprintf o rewrite-code)))))
(fprintf o (rewrite-code user?))))
(unless (file-exists? alt-dest)
;; make empty alternate file; in `user?` mode, this
;; file will get used only when "racket-index" is not
;; in installation scope
(call-with-output-file* alt-dest void))))
(element
(style #f (list
(js-addition (string->url "local-redirect.js"))
(js-addition (if (and user? (not main-at-user?))
(path->url (build-path (find-doc-dir)
"local-redirect"
"local-redirect.js"))
(string->url "local-redirect.js")))
(js-addition (string->url "local-user-redirect.js"))
(js-addition
(string->bytes/utf-8 search-code))))
null)))

View File

@ -21,11 +21,13 @@
"utils.rkt"
(for-syntax racket/base)
(for-syntax racket/runtime-path)
(for-syntax compiler/cm-accomplice))
(for-syntax compiler/cm-accomplice)
"index-scope.rkt")
(provide make-search)
(define-runtime-path search-script "search.js")
(define-runtime-path search-merge-script "search-merge.js")
;; this file is used as a trampoline to set a context (a pre-filter cookie) and
;; then hop over to the search page (the search page can do it itself, but it's
@ -38,8 +40,10 @@
;; installing, and they would just do that when appropriate.
(begin-for-syntax
(define-runtime-path search-script "search.js")
(define-runtime-path search-merge-script "search-merge.js")
(define-runtime-path search-context-page "search-context.html")
(register-external-file search-script)
(register-external-file search-merge-script)
(register-external-file search-context-page))
(define (quote-string val)
@ -57,7 +61,7 @@
;; Quote unicode chars:
(regexp-replace* #px"[^[:ascii:]]" str hex4)))
(define (make-script user-dir? renderer sec ri)
(define (make-script as-empty? user-dir? renderer sec ri)
(define dest-dir (send renderer get-dest-directory #t))
(define span-classes null)
;; To make the index smaller, html contents is represented as one of these:
@ -109,7 +113,9 @@
(define manual-refs (make-hash))
(define idx -1)
(define l
(for/list ([i (get-index-entries sec ri)]
(for/list ([i (if as-empty?
null
(get-index-entries sec ri))]
;; don't index constructors (the class itself is already indexed)
#:unless (constructor-index-desc? (list-ref i 3)))
(set! idx (add1 idx))
@ -166,6 +172,8 @@
(quote-string href) ","
html "," from-libs "]")))
(define user (if user-dir? "user_" ""))
(with-output-to-file (build-path dest-dir "plt-index.js") #:exists 'truncate
(lambda ()
(for-each
@ -179,7 +187,7 @@
@||
// classes to be used for compact representation of html strings in
// plt_search_data below (see also the UncompactHtml function)
var plt_span_classes = [
var plt_@,|user|span_classes = [
@,@(add-between (map (lambda (x) (quote-string (car x)))
(reverse span-classes))
",\n ")
@ -192,12 +200,12 @@
// index into plt_span_classes (note: this is recursive)
// - from_lib is an array of module names for bound identifiers,
// or the string "module" for a module entry
var plt_search_data = [
var plt_@,|user|search_data = [
@,@(add-between l ",\n")
];
@||
// array of pointers to the previous array, for items that are manuals
var plt_manual_ptrs = {
var plt_@,|user|manual_ptrs = {
@,@(let* ([ms (hash-map manual-refs cons)]
[ms (sort ms < #:key cdr)]
[ms (map (lambda (x)
@ -207,23 +215,42 @@
(add-between ms ",\n "))};
@||})))
(for ([src (list search-script search-context-page)])
(for ([src (append (list search-script search-context-page)
(if user-dir? (list search-merge-script) null))])
(define dest (build-path dest-dir (file-name-from-path src)))
(when (file-exists? dest) (delete-file dest))
(copy-file src dest)))
(define (make-search user-dir?)
(define (make-search in-user-dir?)
(define main-at-user? (index-at-user?))
(define user-dir? (and in-user-dir? (not main-at-user?)))
(make-splice
(list
(make-paragraph
plain
(list
(script-ref "plt-index.js"
#:noscript
@list{Sorry, you must have JavaScript to use this page.})
(script-ref "search.js")
(make-render-element #f null
(lambda (r s i) (make-script user-dir? r s i)))))
(append
(if user-dir?
(list (script-ref (url->string
(path->url
(build-path (find-doc-dir) "search" "plt-index.js")))))
null)
(list
(script-ref "plt-index.js"
#:noscript
@list{Sorry, you must have JavaScript to use this page.})
(script-ref "search.js"))
(if user-dir?
(list (script-ref "search-merge.js"))
null)
(list
(make-render-element #f null
(lambda (r s i) (make-script
;; If there's no installaton-scope docs,
;; don't both creating "main" search page:
(and main-at-user?
(not in-user-dir?))
user-dir?
r s i))))))
(make-paragraph (make-style #f
(list 'div
(make-attributes '([id . "plt_search_container"]))))

View File

@ -0,0 +1,57 @@
// Merge user and main search arrays
{
var orig_span_length = plt_span_classes.length;
plt_span_classes = plt_span_classes.concat(plt_user_span_classes);
var rev_map = [], user_rev_map = [];
for (name in plt_manual_ptrs)
rev_map[plt_manual_ptrs[name]] = name;
for (name in plt_user_manual_ptrs)
user_rev_map[plt_manual_ptrs[name]] = name;
// Convert a span by adjusting the span-index offset
function convert_span(x) {
if (typeof x == "string") {
return x;
} else if ((x.length == 2) && (typeof(x[0]) == "number")) {
return [x[0] + orig_span_length, convert_span(x[1])];
} else {
var res = [];
for (var i=0; i<x.length; i++)
res[i] = convert_span(x[i]);
return res;
}
}
function convert(line) {
return [line[0], line[1], convert_span(line[2]), line[3]];
}
var i = 0, j = 0;
var ilen = plt_search_data.length;
var jlen = plt_user_search_data.length;
var result = []
while ((i < ilen) || (j < jlen)) {
if (j >= jlen) {
if (rev_map[i]) plt_manual_ptrs[rev_map[i]] = result.length;
result.push(plt_search_data[i]);
i++;
} else if (i >= ilen) {
if (user_rev_map[j]) plt_manual_ptrs[user_rev_map[j]] = result.length;
result.push(convert(plt_user_search_data[j]));
j++;
} else if (plt_search_data[i][0] < plt_user_search_data[j][0]) {
if (rev_map[i]) plt_manual_ptrs[rev_map[i]] = result.length;
result.push(plt_search_data[i]);
i++;
} else {
if (user_rev_map[j]) plt_manual_ptrs[user_rev_map[j]] = result.length;
result.push(convert(plt_user_search_data[j]));
j++;
}
}
plt_search_data = result;
}

View File

@ -2,6 +2,6 @@
(define scribblings
'(("start.scrbl" (user-doc-root depends-all no-depend-on) (omit))
("search.scrbl" (user-doc depends-all no-depend-on) (omit))
("local-redirect.scrbl" (user-doc depends-all no-depend-on) (omit))
("search.scrbl" (user-doc depends-all-user no-depend-on) (omit))
("local-redirect.scrbl" (user-doc depends-all-user no-depend-on) (omit))
("release.scrbl" (user-doc depends-all no-depend-on) (omit))))

View File

@ -146,7 +146,8 @@
(log-setup-info "latex working directory: ~a" latex-dest))
(define (scribblings-flag? sym)
(memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
depends-all depends-all-main no-depend-on always-run)))
depends-all depends-all-main depends-all-user
no-depend-on always-run)))
(define (validate-scribblings-infos infos)
(define (validate path [flags '()] [cat '(library)] [name #f] [out-count 1] [order-hint 0])
(and (string? path) (relative-path? path)
@ -435,7 +436,9 @@
[added? #f]
[deps (make-hasheq)]
[known-deps (make-hasheq)]
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))])
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))]
[all-user? (memq 'depends-all-user (doc-flags (info-doc info)))]
[all? (memq 'depends-all (doc-flags (info-doc info)))])
;; Convert current deps from paths to infos, keeping paths that have no info
(set-info-deps!
info
@ -458,10 +461,14 @@
(hash-set! deps i #t)
;; Path has no info; normally keep it as expected, and it gets
;; removed later.
(unless (or (memq 'depends-all (doc-flags (info-doc info)))
(unless (or all?
(and (info? d)
(doc-under-main? (info-doc d))
all-main?))
(cond
[all-main?
(doc-under-main? (info-doc d))]
[all-user?
(not (doc-under-main? (info-doc d)))]
[else #f])))
(set! added? #t)
(verbose/log "Removed Dependency for ~a: ~a"
(doc-name (info-doc info))
@ -489,23 +496,28 @@
(set! added? #t)
(hash-set! deps i #t)]))
;; Add expected dependencies for an "all dependencies" doc:
(when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?)
(when (or all? all-main? all-user?)
(verbose/log "Adding all~a as dependencies for ~a"
(if all-main? " main" "")
(cond
[all-main? " main"]
[all-user? " user"]
[else ""])
(doc-name (info-doc info)))
(for ([i infos])
(hash-set! known-deps i #t)
(when (and (not (eq? i info))
(not (hash-ref deps i #f))
(or (not all-main?) (doc-under-main? (info-doc i)))
(cond
[all-main? (doc-under-main? (info-doc i))]
[all-user? (not (doc-under-main? (info-doc i)))]
[else #t])
(not (memq 'no-depend-on (doc-flags (info-doc i)))))
(add-dependency info i))))
;; Determine definite dependencies based on referenced keys, and also
;; report missing links.
(let ([not-found
(lambda (k)
(unless (or (memq 'depends-all (doc-flags (info-doc info)))
(memq 'depends-all-main (doc-flags (info-doc info))))
(unless (or all? all-main? all-user?)
(unless one?
(setup-printf
"WARNING" "undefined tag in ~a:"
@ -697,7 +709,7 @@
(define shared-empty-script-files
(list "doc-site.js"))
(define (make-renderer latex-dest doc)
(define (make-renderer latex-dest doc main-doc-exists?)
(if latex-dest
(new (latex:render-mixin render%)
[dest-dir latex-dest]
@ -722,11 +734,16 @@
[allow-indirect? (and (doc-pkg? doc)
;; (not main?)
(not (memq 'no-depend-on (doc-flags doc))))]
[local-redirect-file (build-path (if main?
[local-redirect-file (build-path (if main-doc-exists?
(find-doc-dir)
(find-user-doc-dir))
"local-redirect"
"local-redirect.js")])
"local-redirect.js")]
[local-user-redirect-file (build-path (if main?
(find-doc-dir)
(find-user-doc-dir))
"local-redirect"
"local-user-redirect.js")])
(define r
(new (contract-override-mixin
((if multi? html:render-multi-mixin values)
@ -743,14 +760,18 @@
(if root?
s
(format "../~a" s))))])
(cons (cons local-redirect-file
(if main?
"../local-redirect/local-redirect.js"
(u:url->string (u:path->url local-redirect-file))))
(map std-path (append
shared-style-files
shared-empty-style-files
shared-empty-script-files))))]
(list* (cons local-redirect-file
(if main?
"../local-redirect/local-redirect.js"
(u:url->string (u:path->url local-redirect-file))))
(cons local-user-redirect-file
(if main?
"../local-redirect/local-user-redirect.js"
(u:url->string (u:path->url local-user-redirect-file))))
(map std-path (append
shared-style-files
shared-empty-style-files
shared-empty-script-files))))]
[up-path (cond
[root? #f] ; no up from root
[main?
@ -783,7 +804,7 @@
;; For documentation that might be moved into a binary package
;; or that can contain an indirect reference, use a server indirection
;; for all links external to the document, but also install the
;; "local-redirect.js" hook:
;; "local-[user-]redirect.js" hooks:
(send r set-external-tag-path
(u:url->string
(let ([u (u:string->url (get-doc-search-url))])
@ -793,7 +814,8 @@
[query
(cons (cons 'version (version))
(u:url-query u))]))))
(send r add-extra-script-file local-redirect-file))
(send r add-extra-script-file local-redirect-file)
(send r add-extra-script-file local-user-redirect-file))
;; Result is the renderer:
r)))
@ -827,7 +849,8 @@
(and auto-main?
(memq 'depends-all-main (doc-flags doc)))
(and auto-user?
(memq 'depends-all (doc-flags doc)))
(or (memq 'depends-all (doc-flags doc))
(memq 'depends-all-user (doc-flags doc))))
(ormap (lambda (d)
(let ([d (path->directory-path d)])
(let loop ([dir (path->directory-path (doc-src-dir doc))])
@ -902,7 +925,8 @@
(define xref (make-collections-xref
#:quiet-fail? quiet-fail?
#:no-user? (main-doc? doc)
#:no-main? (not main-doc-exists?)
#:no-main? (or (not main-doc-exists?)
(memq 'depends-all-user (doc-flags doc)))
#:doc-db (and latex-dest
(find-doc-db-path latex-dest #t main-doc-exists?))
#:register-shutdown! (lambda (s)
@ -955,7 +979,7 @@
;; need to render, so complain if no source is available:
path)))]
[src-sha1 (and src-zo (get-compiled-file-sha1 src-zo))]
[renderer (make-renderer latex-dest doc)]
[renderer (make-renderer latex-dest doc main-doc-exists?)]
[can-run? (can-build? only-dirs doc)]
[stamp-data (with-handlers ([exn:fail:filesystem? (lambda (exn) (list "" "" ""))])
(let ([v (call-with-input-file* stamp-file read)])
@ -1007,7 +1031,8 @@
(and auto-main?
(memq 'depends-all-main (doc-flags doc)))
(and auto-user?
(memq 'depends-all (doc-flags doc)))))])
(or (memq 'depends-all (doc-flags doc))
(memq 'depends-all-user (doc-flags doc))))))])
(when (or (and (not up-to-date?) (not only-fast?))
(verbose))
@ -1224,11 +1249,20 @@
;; and fix up the path if there is a reference:
(define js-path (if (doc-under-main? doc)
"../local-redirect"
(u:url->string (u:path->url (build-path (find-user-doc-dir)
"local-redirect")))))
(u:url->string
(u:path->url
(build-path (if main-doc-exists?
(find-doc-dir)
(find-user-doc-dir))
"local-redirect")))))
(define user-js-path (if (doc-under-main? doc)
"../local-redirect"
(u:url->string
(u:path->url
(build-path (find-user-doc-dir) "local-redirect")))))
(for ([p (in-directory dest-dir)])
(when (regexp-match? #rx#"[.]html$" (path->bytes p))
(fixup-local-redirect-reference p js-path)))
(fixup-local-redirect-reference p js-path #:user user-js-path)))
;; The existence of "synced.rktd" means that the db is in sync
;; with "provides.sxref" and ".html" files have been updated.
(let ([provided-path (build-path dest-dir "synced.rktd")])
@ -1324,7 +1358,7 @@
(load-sxref (sxref-path latex-dest doc (format "out~a.sxref" i))))))
(define info (and (info? info-or-list) info-or-list))
(define doc (if info (info-doc info) (car info-or-list)))
(define renderer (make-renderer latex-dest doc))
(define renderer (make-renderer latex-dest doc main-doc-exists?))
(with-record-error
(doc-src-file doc)
(lambda ()

View File

@ -157,7 +157,7 @@
[else (void)]))
(define (fixup-html new-p)
;; strip full path to "local-redirect.js"
;; strip full path to "local-[user-]redirect.js"
(fixup-local-redirect-reference new-p ".."))
(define (fixup-zo new-p)
@ -194,13 +194,18 @@
#:exists 'truncate/replace
(lambda (out) (write new-mod out)))))
(define (fixup-local-redirect-reference p js-path)
(define (fixup-local-redirect-reference p js-path #:user [user-js-path js-path])
;; Relying on this HTML pattern (as generated by Scribble's HTML
;; renderer) is a little fragile. Any better idea?
(define rx #rx"<script type=\"text/javascript\" src=\"([^\"]*)/local-redirect.js\">")
(define m (call-with-input-file*
p
(lambda (i) (regexp-match-positions rx i))))
(define rx #rx"<script type=\"text/javascript\" src=\"([^\"]*)/local-(?:user-)?redirect[.]js\">")
(define ms (call-with-input-file*
p
(lambda (i)
;; search twice to hit normal and user:
(list (regexp-match-positions rx i)
(regexp-match-positions rx i)))))
(define m (car ms))
(define m2 (cadr ms))
(when m
(define start (caadr m))
(define end (cdadr m))
@ -208,8 +213,17 @@
(define new-bstr
(bytes-append (subbytes bstr 0 start)
(string->bytes/utf-8 js-path)
(subbytes bstr end)))
(call-with-output-file*
(let ([s (subbytes bstr end)])
(cond
[m2
(define delta (- (cdar m) end))
(define start2 (caadr m2))
(define end2 (cdadr m2))
(bytes-append (subbytes s 0 (+ delta start2))
(string->bytes/utf-8 user-js-path)
(subbytes s (+ delta end2)))]
[else s]))))
(call-with-output-file*
p
#:exists 'truncate/replace
(lambda (out) (write-bytes new-bstr out)))))