From fff0344f4eb489b360780949b57d8fefd2dc27ce 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. original commit: 9361b1e709bc7a75822c7da68530cbe0fef4ae28 --- collects/scribble/base-render.rkt | 2 +- collects/scribble/base.rkt | 5 +- collects/scribble/core.rkt | 7 +- collects/scribble/html-render.rkt | 125 +++++++++++++++++------------- 4 files changed, 80 insertions(+), 59 deletions(-) diff --git a/collects/scribble/base-render.rkt b/collects/scribble/base-render.rkt index 537250ae..c9b9f7cd 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 c77425dd..bc764183 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 3a6acfd1..e49641f9 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 edd1ef00..c27e6e76 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))))