suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

doc search & redirect: user as an extension of main

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl
View File

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

19
pkgs/racket-pkgs/racket-index/scribblings/main/private/index-scope.rkt Normal file
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)))))))

73
pkgs/racket-pkgs/racket-index/scribblings/main/private/local-redirect.rkt
View File

@ -5,41 +5,51 @@
racket/match racket/match
setup/dirs setup/dirs
net/url net/url
scribble/html-properties) scribble/html-properties
"index-scope.rkt")
(provide make-local-redirect) (provide make-local-redirect)
(define rewrite-code (define (rewrite-code user?)
(define prefix (if user? "user_" ""))
@string-append|{ @string-append|{
function bsearch(str, start, end) { function |@|prefix|bsearch(str, start, end) {
if (start >= end) if (start >= end)
return false; return false;
else { else {
var mid = Math.floor((start + end) / 2); var mid = Math.floor((start + end) / 2);
if (link_targets[mid][0] == str) if (|@|prefix|link_targets[mid][0] == str)
return mid; return mid;
else if (link_targets[mid][0] < str) else if (|@|prefix|link_targets[mid][0] < str)
return bsearch(str, mid+1, end); return |@|prefix|bsearch(str, mid+1, end);
else 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"); var elements = document.getElementsByClassName("Sq");
for (var i = 0; i < elements.length; i++) { for (var i = 0; i < elements.length; i++) {
var elem = elements[i]; var elem = elements[i];
var n = elem.href.match(/tag=[^&]*/); var n = elem.href.match(/tag=[^&]*/);
if (n) { 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) { 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 (define search-code
@ -66,15 +76,29 @@
}|) }|)
(define (make-local-redirect user?) (define (make-local-redirect user?)
(define main-at-user? (index-at-user?))
(list (list
(make-render-element (make-render-element
#f #f
null null
(lambda (renderer p ri) (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 (target? v) (and (vector? v) (= 5 (vector-length v))))
(define dest (build-path (send renderer get-dest-directory #t) (define dest-dir (send renderer get-dest-directory #t))
"local-redirect.js")) (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 (define db
(sort (for/list ([k (in-list keys)] (sort (for/list ([k (in-list keys)]
#:when (tag? k) #:when (tag? k)
@ -91,16 +115,31 @@
(fprintf o "// This script is included by generated documentation to rewrite\n") (fprintf o "// This script is included by generated documentation to rewrite\n")
(fprintf o "// links expressed as tag queries into local-filesystem links.\n") (fprintf o "// links expressed as tag queries into local-filesystem links.\n")
(newline o) (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)] (for ([e (in-list db)]
[i (in-naturals)]) [i (in-naturals)])
(fprintf o (if (zero? i) "\n" ",\n")) (fprintf o (if (zero? i) "\n" ",\n"))
(fprintf o " [~s, ~s]" (car e) (cadr e))) (fprintf o " [~s, ~s]" (car e) (cadr e)))
(fprintf o "];\n\n") (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 (element
(style #f (list (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 (js-addition
(string->bytes/utf-8 search-code)))) (string->bytes/utf-8 search-code))))
null))) null)))

57
pkgs/racket-pkgs/racket-index/scribblings/main/private/make-search.rkt
View File

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

57
pkgs/racket-pkgs/racket-index/scribblings/main/private/search-merge.js Normal file
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;
}

4
pkgs/racket-pkgs/racket-index/scribblings/main/user/info.rkt
View File

@ -2,6 +2,6 @@
(define scribblings (define scribblings
'(("start.scrbl" (user-doc-root depends-all no-depend-on) (omit)) '(("start.scrbl" (user-doc-root depends-all no-depend-on) (omit))
("search.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 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)))) ("release.scrbl" (user-doc depends-all no-depend-on) (omit))))

96
pkgs/racket-pkgs/racket-index/setup/scribble.rkt
View File

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

30
racket/collects/pkg/strip.rkt
View File

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