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.
This commit is contained in:
Matthew Flatt
parent
53efe920b3
commit
9361b1e709
|
|
@ -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}")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
;; \\?\<drive>: 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)
|
||||
;; \\?\<drive>: 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)])
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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]><style type=\"text/css\">.SIEHidden { overflow: hidden; }</style><![endif]")
|
||||
,@(for/list ([p (style-properties (part-style d))]
|
||||
#:when (head-extra? p))
|
||||
|
|
@ -1017,14 +1042,14 @@
|
|||
[(multiarg-element? e) (multiarg-element-style e)]
|
||||
[else #f]))
|
||||
|
||||
(define/private (content-attribs e)
|
||||
(define/private (content-attribs e [extras null])
|
||||
(let ([s (content-style e)])
|
||||
(if (style? s)
|
||||
(element-style->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))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
8
collects/scribblings/main/local-redirect.scrbl
Normal file
8
collects/scribblings/main/local-redirect.scrbl
Normal file
|
|
@ -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)
|
||||
75
collects/scribblings/main/private/local-redirect.rkt
Normal file
75
collects/scribblings/main/private/local-redirect.rkt
Normal file
|
|
@ -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?)))
|
||||
string<?
|
||||
#:key car))
|
||||
(call-with-output-file*
|
||||
dest
|
||||
#:exists 'truncate/replace
|
||||
(lambda (o)
|
||||
(fprintf o "// Autogenerated by `scribblings/main/private/local-redirect'\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")
|
||||
(newline o)
|
||||
(fprintf o "var link_targets = [")
|
||||
(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))))))
|
||||
|
|
@ -2,4 +2,5 @@
|
|||
|
||||
(define scribblings
|
||||
'(("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 no-depend-on) (omit))
|
||||
("local-redirect.scrbl" (user-doc depends-all no-depend-on) (omit))))
|
||||
|
|
|
|||
8
collects/scribblings/main/user/local-redirect.scrbl
Normal file
8
collects/scribblings/main/user/local-redirect.scrbl
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#lang scribble/manual
|
||||
@(require "../private/local-redirect.rkt")
|
||||
|
||||
@title{User Local Redirections}
|
||||
|
||||
This document causes the redirection table to be built.
|
||||
|
||||
@(make-local-redirect #t)
|
||||
|
|
@ -25,6 +25,8 @@
|
|||
scribble/xref
|
||||
unstable/file
|
||||
racket/place
|
||||
pkg/lib
|
||||
(only-in net/url url->string 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user