From 9361b1e709bc7a75822c7da68530cbe0fef4ae28 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 May 2013 22:22:42 -0400 Subject: [PATCH] render non-installaction-scoped package docs with an indirection The indirection uses a "local-redirect.js" script to rewrite the document links to local links within the browser. This mechanism is a step towards distributing compiled packages that include already-built documentation, where paths to other documentation can be different than in the build environment. If the links are not rewritten, they are queries to "pkg-docs.racket-lang.org", with the idea tha such a server will exist for reading all package documentation online. Also, a package's documentation that refer to documentation for uninstalled packages, in which case the corresponding links will not get rewritten and will continue to point to the server. Rendering the "local-redirect.js" script spends a lot of time just converting among different path formats. Various library changes in this commit are aimed at speed up those conversions, but the big improvement came from a `path->url-string' that shortcuts conversion os simple Unix paths. --- collects/meta/dist-specs.rkt | 4 +- collects/net/uri-codec.rkt | 18 ++- collects/net/url.rkt | 96 ++++++++------ collects/racket/path.rkt | 32 ++--- collects/scribble/base-render.rkt | 2 +- collects/scribble/base.rkt | 5 +- collects/scribble/core.rkt | 7 +- collects/scribble/html-render.rkt | 125 ++++++++++-------- collects/scribblings/main/info.rkt | 3 +- .../scribblings/main/local-redirect.scrbl | 8 ++ .../main/private/local-redirect.rkt | 75 +++++++++++ collects/scribblings/main/user/info.rkt | 3 +- .../main/user/local-redirect.scrbl | 8 ++ collects/setup/scribble.rkt | 79 +++++++---- 14 files changed, 305 insertions(+), 160 deletions(-) create mode 100644 collects/scribblings/main/local-redirect.scrbl create mode 100644 collects/scribblings/main/private/local-redirect.rkt create mode 100644 collects/scribblings/main/user/local-redirect.scrbl diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index 7ebecf4b83..ca157f5fdc 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -359,12 +359,12 @@ mz-base := "/racket/README" => (- (collects: "repo-time-stamp/") (cond (not dr) => (srcfile: "time-stamp.rkt")))) mz-manuals := (scribblings: "main/") ; generates main pages (next line) - (doc: "license/" "release/" "acks/" "search/" + (doc: "license/" "release/" "acks/" "search/" "local-redirect/" "getting-started/") (notes: "COPYING*.txt") (doc: "doc-license.txt") ; needed (when docs are included) (doc+src: "reference/" "guide/" "quick/" "more/" - "foreign/" "inside/" ;; "places/" <- not ready yet + "foreign/" "inside/" "scheme/" "honu/") (doc: "*.{html|css|js|sxref}") diff --git a/collects/net/uri-codec.rkt b/collects/net/uri-codec.rkt index da4b106ea1..4e24f0f060 100644 --- a/collects/net/uri-codec.rkt +++ b/collects/net/uri-codec.rkt @@ -193,11 +193,19 @@ See more in PR8831. ;; vector string -> string (define (encode table str) - (apply string-append (map (lambda (byte) - (if (< byte ascii-size) - (vector-ref table byte) - (number->hex-string byte))) - (bytes->list (string->bytes/utf-8 str))))) + ;; First, check for an ASCII string with no conversion needed: + (if (for/and ([char (in-string str)]) + (define v (char->integer char)) + (and (byte? v) + (let ([s (vector-ref table v)]) + (and (= 1 (string-length s)) + (eq? char (string-ref s 0)))))) + str + (apply string-append + (for/list ([byte (in-bytes (string->bytes/utf-8 str))]) + (if (< byte ascii-size) + (vector-ref table byte) + (number->hex-string byte)))))) ;; vector string -> string (define (decode table str) diff --git a/collects/net/url.rkt b/collects/net/url.rkt index ab9f32eeee..cf2a318535 100644 --- a/collects/net/url.rkt +++ b/collects/net/url.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/port racket/string racket/contract/base + racket/list "url-connect.rkt" "url-structs.rkt" "uri-codec.rkt") @@ -68,28 +69,37 @@ [path (url-path url)] [query (url-query url)] [fragment (url-fragment url)] - [sa string-append]) + [sa list] + [sa* (lambda (l) + (apply string-append + (let loop ([l l]) + (cond + [(null? l) l] + [(pair? (car l)) + (append (loop (car l)) + (loop (cdr l)))] + [(null? (car l)) (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))]))))]) (when (and (equal? scheme "file") (not (url-path-absolute? url))) (raise-mismatch-error 'url->string "cannot convert relative file URL to a string: " url)) - (sa (if scheme (sa scheme ":") "") - (if (or user host port) + (sa* + (append + (if scheme (sa scheme ":") null) + (if (or user host port) (sa "//" - (if user (sa (uri-userinfo-encode user) "@") "") - (if host host "") - (if port (sa ":" (number->string port)) "") - ;; There used to be a "/" here, but that causes an - ;; extra leading slash -- wonder why it ever worked! - ) + (if user (sa (uri-userinfo-encode user) "@") null) + (if host host null) + (if port (sa ":" (number->string port)) null)) (if (equal? "file" scheme) ; always need "//" for "file" URLs - "//" - "")) - (combine-path-strings (url-path-absolute? url) path) - ;; (if query (sa "?" (uri-encode query)) "") - (if (null? query) "" (sa "?" (alist->form-urlencoded query))) - (if fragment (sa "#" (uri-encode* fragment)) "")))) + '("//") + null)) + (combine-path-strings (url-path-absolute? url) path) + ;; (if query (sa "?" (uri-encode query)) "") + (if (null? query) null (sa "?" (alist->form-urlencoded query))) + (if fragment (sa "#" (uri-encode* fragment)) null))))) ;; url->default-port : url -> num (define (url->default-port url) @@ -594,14 +604,16 @@ [else (uri-path-segment-encode* p)])) (define (combine-path-strings absolute? path/params) - (cond [(null? path/params) ""] - [else (let ([p (string-join (map join-params path/params) "/")]) - (if absolute? (string-append "/" p) p))])) + (cond [(null? path/params) null] + [else (let ([p (add-between (map join-params path/params) "/")]) + (if absolute? (cons "/" p) p))])) (define (join-params s) - (string-join (map path-segment-encode - (cons (path/param-path s) (path/param-param s))) - ";")) + (if (null? (path/param-param s)) + (path-segment-encode (path/param-path s)) + (string-join (map path-segment-encode + (cons (path/param-path s) (path/param-param s))) + ";"))) (define (path->url path) (let* ([spath (simplify-path path #f)] @@ -614,30 +626,30 @@ (let-values ([(base name dir?) (split-path path)]) (cond [(not base) - (append (map - (lambda (s) - (make-path/param s null)) - (if (eq? (path-convention-type path) 'windows) - ;; For Windows, massage the root: + (if (eq? (path-convention-type path) 'windows) + ;; For Windows, massage the root: + (append (map + (lambda (s) + (make-path/param s null)) (let ([s (regexp-replace #rx"[/\\\\]$" (bytes->string/utf-8 (path->bytes name)) "")]) (cond - [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) - ;; \\?\: path: - (regexp-split #rx"[/\\]+" (substring s 4))] - [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) - ;; \\?\ UNC path: - (regexp-split #rx"[/\\]+" (substring s 7))] - [(regexp-match? #rx"^[/\\]" s) - ;; UNC path: - (regexp-split #rx"[/\\]+" s)] - [else - (list s)])) - ;; On other platforms, we drop the root: - null)) - accum)] + [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) + ;; \\?\: path: + (regexp-split #rx"[/\\]+" (substring s 4))] + [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) + ;; \\?\ UNC path: + (regexp-split #rx"[/\\]+" (substring s 7))] + [(regexp-match? #rx"^[/\\]" s) + ;; UNC path: + (regexp-split #rx"[/\\]+" s)] + [else + (list s)]))) + accum) + ;; On other platforms, we drop the root: + accum)] [else (let ([accum (cons (make-path/param (if (symbol? name) @@ -649,7 +661,9 @@ (if (eq? base 'relative) accum (loop base accum)))])))]) - (make-url "file" #f "" #f (absolute-path? path) (append url-path url-tail) '() #f))) + (make-url "file" #f "" #f (absolute-path? path) + (if (null? url-tail) url-path (append url-path url-tail)) + '() #f))) (define (url->path url [kind (system-path-convention-type)]) diff --git a/collects/racket/path.rkt b/collects/racket/path.rkt index 5c9b4600f9..efbcda963c 100644 --- a/collects/racket/path.rkt +++ b/collects/racket/path.rkt @@ -1,7 +1,6 @@ #lang racket/base (provide find-relative-path - explode-path simple-form-path normalize-path filename-extension @@ -111,30 +110,19 @@ [else (path->complete-path resolved base)]))]))))]) normalize-path)) -;; Argument must be in simple form -(define (do-explode-path who orig-path simple?) - (let loop ([path orig-path] [rest '()]) - (let-values ([(base name dir?) (split-path path)]) - (when simple? - (when (or (and base (not (path-for-some-system? base))) - (not (path-for-some-system? name))) - (raise-argument-error who - "(and/c path-for-some-system? simple-form?)" - orig-path))) - (if (path-for-some-system? base) - (loop base (cons name rest)) - (cons name rest))))) - -(define (explode-path orig-path) - (unless (or (path-string? orig-path) - (path-for-some-system? orig-path)) - (raise-argument-error 'explode-path "(or/c path-string? path-for-some-system?)" orig-path)) - (do-explode-path 'explode-path orig-path #f)) +(define (do-explode-path who orig-path) + (define l (explode-path orig-path)) + (for ([p (in-list l)]) + (when (not (path-for-some-system? p)) + (raise-argument-error who + "(and/c path-for-some-system? simple-form?)" + orig-path))) + l) ;; Arguments must be in simple form (define (find-relative-path directory filename #:more-than-root? [more-than-root? #f]) - (let ([dir (do-explode-path 'find-relative-path directory #t)] - [file (do-explode-path 'find-relative-path filename #t)]) + (let ([dir (do-explode-path 'find-relative-path directory)] + [file (do-explode-path 'find-relative-path filename)]) (if (and (equal? (car dir) (car file)) (or (not more-than-root?) (not (eq? 'unix (path-convention-type directory))) diff --git a/collects/scribble/base-render.rkt b/collects/scribble/base-render.rkt index 537250ae30..c9b9f7cd16 100644 --- a/collects/scribble/base-render.rkt +++ b/collects/scribble/base-render.rkt @@ -177,7 +177,7 @@ (extract-style-style-files (compound-paragraph-style p) ht pred extract) (extract-flow-style-files (compound-paragraph-blocks p) d ri ht pred extract)] [(delayed-block? p) - (let ([v ((delayed-block-resolve p) this d ri)]) + (let ([v (delayed-block-blocks p ri)]) (extract-block-style-files v d ri ht pred extract))] [(traverse-block? p) (extract-block-style-files (traverse-block-block p ri) d ri ht pred extract)] diff --git a/collects/scribble/base.rkt b/collects/scribble/base.rkt index c77425dd3d..bc7641836f 100644 --- a/collects/scribble/base.rkt +++ b/collects/scribble/base.rkt @@ -726,8 +726,9 @@ (provide/contract [table-of-contents (-> delayed-block?)] - ; XXX Should have a style/c contract - [local-table-of-contents (() (#:style any/c) . ->* . delayed-block?)]) + [local-table-of-contents (() + (#:style (or/c style? string? symbol? (listof symbol?) #f)) + . ->* . delayed-block?)]) (define (table-of-contents) (make-delayed-block diff --git a/collects/scribble/core.rkt b/collects/scribble/core.rkt index 3a6acfd1db..e49641f92d 100644 --- a/collects/scribble/core.rkt +++ b/collects/scribble/core.rkt @@ -76,7 +76,12 @@ (resolve-get* part ri key search-key)) (define (resolve-get-keys part ri key-pred) - (for/list ([k (in-hash-keys (collected-info-info (part-collected-info part ri)))] + (for/list ([k (in-hash-keys (if part + (collected-info-info (part-collected-info part ri)) + (let ([ci (resolve-info-ci ri)]) + ;; Force all xref info: + ((collect-info-ext-demand ci) #f ci) + (collect-info-ext-ht ci))))] #:when (key-pred k)) k)) diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt index edd1ef0074..c27e6e7699 100644 --- a/collects/scribble/html-render.rkt +++ b/collects/scribble/html-render.rkt @@ -131,9 +131,10 @@ (if (< v 16) (string-append "0" s) s))) c)))) -(define (style->attribs style) +(define (style->attribs style [extras null]) (let ([a (apply append + extras (map (lambda (v) (cond [(attributes? v) @@ -350,6 +351,10 @@ (define/public (set-external-root-url p) (set! external-root-url p)) + (define extra-script-files null) + (define/public (add-extra-script-file s) + (set! extra-script-files (cons s extra-script-files))) + (define (try-relative-to-external-root dest) (cond [(let ([rel (find-relative-path @@ -385,6 +390,22 @@ (and (not (dest-page? dest)) (anchor-name (dest-anchor dest))))]))) + (define/public (tag->url-string ri tag #:absolute? [abs? #f]) + ;; Called externally; not used internally + (let-values ([(dest ext?) (resolve-get/ext? #f ri tag)]) + (cond [(not dest) ""] + [else (dest->url dest abs?)]))) + + (define/public (tag->query-string tag) + (define (simple? s) + (or (symbol? s) + (string? s) + (number? s) + (and (list? s) (andmap simple? s)))) + (anchor-name (format "~s" (if (simple? tag) + tag + (serialize tag))))) + ;; ---------------------------------------- (define/private (reveal-subparts? p) ;!!! need to use this @@ -393,13 +414,15 @@ (define/public (toc-wrap table) null) - (define/private (dest->url dest) + (define/private (dest->url dest [abs? #f]) (if dest (format "~a~a~a" (let ([p (relative->path (dest-path dest))]) - (if (equal? p (current-output-file)) - "" - (from-root p (get-dest-directory)))) + (if abs? + (path->url-string (path->complete-path p)) + (if (equal? p (current-output-file)) + "" + (from-root p (get-dest-directory))))) (if (dest-page? dest) "" "#") (if (dest-page? dest) "" @@ -711,12 +734,14 @@ (let ([p (lookup-path script-file alt-paths)]) (unless p (install-file script-file)) (scribble-js-contents script-file p)))) - (extract-part-style-files - d - ri - (lambda (p) (part-whole-page? p ri)) - js-addition? - js-addition-path)) + (append + (extract-part-style-files + d + ri + (lambda (p) (part-whole-page? p ri)) + js-addition? + js-addition-path) + (reverse extra-script-files))) ,(xml:comment "[if IE 6]>attribs (style-name s) s) - (element-style->attribs s #f)))) + (element-style->attribs (style-name s) s extras) + (element-style->attribs s #f extras)))) (define/override (render-content e part ri) - (define (attribs) (content-attribs e)) + (define (attribs [extras null]) (content-attribs e extras)) (cond [(string? e) (super render-content e part ri)] ; short-cut for common case [(list? e) (super render-content e part ri)] ; also a short-cut @@ -1157,17 +1182,14 @@ url u [query - (cons (cons 'tag - (bytes->string/utf-8 - (base64-encode - (string->bytes/utf-8 - (format "~s" (serialize - (link-element-tag e))))))) + (cons (cons 'tag (tag->query-string (link-element-tag e))) (url-query u))])))] [else ;; Normal link: (dest->url dest)])) - ,@(attribs) + ,@(attribs (if (and ext? external-tag-path) + '((class "Sq")) + null)) [data-pltdoc "x"]] ,@(if (empty-content? (element-content e)) (render-content (strip-aux (dest-title dest)) part ri) @@ -1253,7 +1275,7 @@ ,attribs ,@content)))))) - (define/private (element-style->attribs name style) + (define/private (element-style->attribs name style [extras null]) (combine-class (cond [(symbol? name) @@ -1274,8 +1296,10 @@ [(string? name) (if style null `([class ,name]))] [else null]) (if style - (style->attribs style) - null))) + (style->attribs style extras) + (if (pair? extras) + (style->attribs (make-style #f null) extras) + null)))) (define/override (render-table t part ri starting-item?) (define (make-row flows column-styles) @@ -1627,39 +1651,22 @@ ;; ---------------------------------------- ;; utils -(define (explode p) - (reverse (let loop ([p p]) - (let-values ([(base name dir?) (split-path p)]) - (let ([name (if base - (if (path? name) - (path-element->string name) - name) - name)]) - (if (path? base) - (cons name (loop base)) - (list name))))))) +(define (explode p) (explode-path p)) (define in-plt? (let ([roots (map explode (filter values (list (find-doc-dir) (find-collects-dir))))]) (lambda (path) - (ormap (lambda (root) - (let loop ([path path] [root root]) - (or (null? root) - (and (pair? path) - (equal? (car path) (car root)) - (loop (cdr path) (cdr root)))))) - roots)))) - -(define exploded (make-weak-hash)) -(define (explode/cache p) - (or (hash-ref exploded p #f) - (let ([v (explode p)]) - (hash-set! exploded p v) - v))) + (for/or ([root (in-list roots)]) + (let loop ([path path] [root root]) + (or (null? root) + (and (pair? path) + (equal? (car path) (car root)) + (loop (cdr path) (cdr root))))))))) (define (from-root p d) - (define e-p (explode/cache (path->complete-path p (current-directory)))) - (define e-d (and d (explode/cache (path->complete-path d (current-directory))))) + (define c-p (path->complete-path p)) + (define e-p (explode c-p)) + (define e-d (and d (explode (path->complete-path d)))) (define p-in? (in-plt? e-p)) (define d-in? (and d (in-plt? e-d))) ;; use an absolute link if the link is from outside the plt tree @@ -1670,19 +1677,27 @@ "got a link from the PLT tree going out; ~e" p)] [else #f]))) - (url->string (path->url (path->complete-path p))) + (path->url-string c-p) (let loop ([e-d e-d] [e-p e-p]) (cond [(null? e-d) (string-append* (let loop ([e-p e-p]) (cond [(null? e-p) '("/")] - [(null? (cdr e-p)) (list (car e-p))] + [(null? (cdr e-p)) (list (path->string (car e-p)))] [(eq? 'same (car e-p)) (loop (cdr e-p))] [(eq? 'up (car e-p)) (cons "../" (loop (cdr e-p)))] - [else (cons (car e-p) (cons "/" (loop (cdr e-p))))])))] + [else (cons (path->string (car e-p)) (cons "/" (loop (cdr e-p))))])))] [(equal? (car e-d) (car e-p)) (loop (cdr e-d) (cdr e-p))] [(eq? 'same (car e-d)) (loop (cdr e-d) e-p)] [(eq? 'same (car e-p)) (loop e-d (cdr e-p))] [else (string-append (string-append* (map (lambda (x) "../") e-d)) (loop null e-p))])))) + +(define (path->url-string p) + (if (eq? 'unix (path-convention-type p)) + (let ([p (simplify-path p #f)]) + (if (regexp-match? #rx#"^[-a-zA-Z0-9_/.]*$" (path->bytes p)) + (string-append "file://" (path->string p)) + (url->string (path->url p)))) + (url->string (path->url p)))) diff --git a/collects/scribblings/main/info.rkt b/collects/scribblings/main/info.rkt index fd177418dd..75c7241f66 100644 --- a/collects/scribblings/main/info.rkt +++ b/collects/scribblings/main/info.rkt @@ -3,7 +3,8 @@ (define scribblings '(("start.scrbl" (main-doc-root depends-all-main no-depend-on) (omit)) - ("search.scrbl" (depends-all-main no-depend-on) (omit)) + ("search.scrbl" (depends-all-main no-depend-on) (omit)) + ("local-redirect.scrbl" (depends-all-main no-depend-on) (omit)) ("getting-started.scrbl" () (omit)) ("license.scrbl" () (omit)) ("acks.scrbl" () (omit)) diff --git a/collects/scribblings/main/local-redirect.scrbl b/collects/scribblings/main/local-redirect.scrbl new file mode 100644 index 0000000000..21c1e0229d --- /dev/null +++ b/collects/scribblings/main/local-redirect.scrbl @@ -0,0 +1,8 @@ +#lang scribble/manual +@(require "private/local-redirect.rkt") + +@title{Local Redirections} + +This document causes the redirection table to be built. + +@(make-local-redirect #f) diff --git a/collects/scribblings/main/private/local-redirect.rkt b/collects/scribblings/main/private/local-redirect.rkt new file mode 100644 index 0000000000..3d1c867725 --- /dev/null +++ b/collects/scribblings/main/private/local-redirect.rkt @@ -0,0 +1,75 @@ +#lang at-exp racket/base +(require scribble/core + racket/serialize + racket/class + racket/match + setup/dirs + net/url) + +(provide make-local-redirect) + +(define rewrite-code + @string-append|{ + function bsearch(str, start, end) { + if (start >= end) + return false; + else { + var mid = Math.floor((start + end) / 2); + if (link_targets[mid][0] == str) + return mid; + else if (link_targets[mid][0] < str) + return bsearch(str, mid+1, end); + else + return bsearch(str, start, mid); + } + } + + function 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); + if (pos) { + elem.href = link_targets[pos][1]; + } + } + } + } + + AddOnLoad(convert_all_links); + }|) + +(define (make-local-redirect user?) + (make-render-element + #f + null + (lambda (renderer p ri) + (define keys (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 db + (sort (for/list ([k (in-list keys)] + #:when (tag? k) + #:when (target? (resolve-get p ri k))) + (list (send renderer tag->query-string k) + (send renderer tag->url-string ri k #:absolute? user?))) + stringstring path->url) (prefix-in html: scribble/html-render) (prefix-in latex: scribble/latex-render) (prefix-in contract: scribble/contract-render)) @@ -37,7 +39,7 @@ (define-logger setup) -(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? category out-count) +(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? pkg? category out-count) #:transparent) (define-serializable-struct info (doc ; doc structure above undef ; unresolved requires @@ -68,7 +70,8 @@ (define (parallel-do-error-handler setup-printf doc errmsg outstr errstr) (setup-printf "error running" (module-path-prefix->string (doc-src-spec doc))) - (eprintf errstr)) + (eprintf "~a" errmsg) + (eprintf "~a" errstr)) ;; We use a lock to control writing to the database. It's not ;; strictly necessary, but place channels can deal with blocking @@ -148,6 +151,7 @@ (or (memq 'main-doc flags) (hash-ref main-dirs dir #f) (pair? (path->main-collects-relative dir))))]) + (define src (doc-path dir (cadddr d) flags under-main?)) (make-doc dir (let ([spec (directory-record-spec rec)]) (list* (car spec) @@ -158,8 +162,9 @@ (list '= (directory-record-min rec))))) (cdr spec)))) (simplify-path (build-path dir (car d)) #f) - (doc-path dir (cadddr d) flags under-main?) - flags under-main? (caddr d) + src + flags under-main? (and (path->pkg src) #t) + (caddr d) (list-ref d 4)))) s) (begin (setup-printf @@ -577,30 +582,43 @@ [contract-override-mixin (if multi? contract:override-render-mixin-multi - contract:override-render-mixin-single)]) - (new (contract-override-mixin - ((if multi? html:render-multi-mixin values) - (html:render-mixin render%))) - [dest-dir (if multi? - (let-values ([(base name dir?) (split-path ddir)]) base) - ddir)] - [alt-paths (if main? - (let ([std-path (lambda (s) - (cons (collection-file-path s "scribble") - (format "../~a" s)))]) - (list (std-path "scribble.css") - (std-path "scribble-style.css") - (std-path "racket.css") - (std-path "scribble-common.js"))) - null)] - ;; For main-directory, non-start files, up-path is #t, which makes the - ;; "up" link go to the (user's) start page using cookies. For other files, - ;; - [up-path (and (not root?) - (if main? - #t - (build-path (find-user-doc-dir) "index.html")))] - [search-box? #t])))) + contract:override-render-mixin-single)] + [local-redirect-file (build-path (if main? + (find-doc-dir) + (find-user-doc-dir)) + "local-redirect" + "local-redirect.js")]) + (define r + (new (contract-override-mixin + ((if multi? html:render-multi-mixin values) + (html:render-mixin render%))) + [dest-dir (if multi? + (let-values ([(base name dir?) (split-path ddir)]) base) + ddir)] + [alt-paths (if main? + (let ([std-path (lambda (s) + (cons (collection-file-path s "scribble") + (format "../~a" s)))]) + (list (std-path "scribble.css") + (std-path "scribble-style.css") + (std-path "racket.css") + (std-path "scribble-common.js") + (cons local-redirect-file "../local-redirect/local-redirect.js"))) + (list (cons local-redirect-file + (url->string (path->url local-redirect-file)))))] + ;; For main-directory, non-start files, up-path is #t, which makes the + ;; "up" link go to the (user's) start page using cookies. For other files, + ;; + [up-path (and (not root?) + (if main? + #t + (build-path (find-user-doc-dir) "index.html")))] + [search-box? #t])) + (when (and (not main?) (doc-pkg? doc)) + (send r set-external-tag-path + (format "http://pkg-docs.racket-lang.org?version=~a" (version))) + (send r add-extra-script-file local-redirect-file)) + r))) (define (pick-dest latex-dest doc) (cond [(path? latex-dest) @@ -817,7 +835,10 @@ null ; known deps (none at this point) can-run? my-time info-out-time - (and can-run? (memq 'always-run (doc-flags doc))) + (and can-run? + (or (memq 'always-run (doc-flags doc)) + ;; maybe info is up-to-date but not rendered doc: + (not (my-time . >= . src-time)))) #f #f vers