From be7ba71139fac07e4775f1b3a7b1bf968ff9a0d1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 24 Apr 2008 02:37:47 +0000 Subject: [PATCH] Scribble support for redirecting external links and re-rooting corss-reference paths svn: r9448 original commit: 931d93ba2fbe45bf5c91fe8dd90983e2ea2322bb --- collects/scribble/base-render.ss | 47 ++++++++++-- collects/scribble/html-render.ss | 77 ++++++++++++++------ collects/scribble/render-struct.ss | 6 ++ collects/scribble/run.ss | 6 ++ collects/scribble/struct.ss | 15 ++-- collects/scribble/xref.ss | 10 ++- collects/scribblings/scribble/renderer.scrbl | 66 ++++++++++------- collects/scribblings/scribble/struct.scrbl | 9 +++ collects/scribblings/scribble/xref.scrbl | 17 ++++- 9 files changed, 188 insertions(+), 65 deletions(-) create mode 100644 collects/scribble/render-struct.ss diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index f4707b88..f7ec4622 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require "struct.ss" @@ -6,7 +5,9 @@ mzlib/serialize scheme/file scheme/path - setup/main-collects) + setup/main-collects + setup/path-relativize + "render-struct.ss") (provide render%) @@ -14,7 +15,8 @@ (class object% (init-field dest-dir - [refer-to-existing-files #f]) + [refer-to-existing-files #f] + [root-path #f]) (define/public (get-dest-directory) dest-dir) @@ -40,21 +42,50 @@ (define/public (report-output!) (set! report-output? #t)) + ;; ---------------------------------------- + + (define root (make-mobile-root root-path)) + + (define-values (:path->root-relative + :root-relative->path) + (if root-path + (make-relativize (lambda () root-path) + root + 'path->root-relative + 'root-relative->path) + (values #f #f))) + + (define/public (path->root-relative p) + (if root-path + (:path->root-relative p) + p)) + + (define/public (root-relative->path p) + (if (and (pair? p) + (mobile-root? (car p))) + (apply build-path (mobile-root-path (car p)) + (map bytes->path-element (cdr p))) + p)) + ;; ---------------------------------------- ;; marshal info (define/public (get-serialize-version) - 1) + 2) (define/public (serialize-info ri) (parameterize ([current-serialize-resolve-info ri]) - (serialize (collect-info-ht (resolve-info-ci ri))))) + (serialize (cons root + (collect-info-ht (resolve-info-ci ri)))))) - (define/public (deserialize-info v ci) - (let ([ht (deserialize v)] + (define/public (deserialize-info v ci #:root [root-path #f]) + (let ([root+ht (deserialize v)] [in-ht (collect-info-ext-ht ci)]) - (for ([(k v) ht]) + (when root-path + (set-mobile-root-path! (car root+ht) root-path)) + (for ([(k v) (cdr root+ht)]) (hash-set! in-ht k v)))) + (define/public (get-defined ci) (hash-map (collect-info-ht ci) (lambda (k v) k))) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index de3fe3e6..f9f44358 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -9,6 +9,7 @@ setup/main-collects mzlib/list net/url + net/base64 scheme/serialize (prefix-in xml: xml/xml) (for-syntax scheme/base)) @@ -29,18 +30,6 @@ (define extra-breaking? (make-parameter #f)) (define current-version (make-parameter (version))) - (define (path->relative p) - (let ([p (path->main-doc-relative p)]) - (if (path? p) - (path->main-collects-relative p) - p))) - - (define (relative->path p) - (let ([p (main-doc-relative->path p)]) - (if (path? p) - p - (main-collects-relative->path p)))) - (define (toc-part? d) (part-style? d 'toc)) @@ -205,6 +194,29 @@ ;; ---------------------------------------- + (inherit path->root-relative + root-relative->path) + + (define (path->relative p) + (let ([p (path->main-doc-relative p)]) + (if (path? p) + (let ([p (path->main-collects-relative p)]) + (if (path? p) + (path->root-relative p) + p)) + p))) + + (define (relative->path p) + (let ([p (main-doc-relative->path p)]) + (if (path? p) + p + (let ([p (main-collects-relative->path p)]) + (if (path? p) + p + (root-relative->path p)))))) + + ;; ---------------------------------------- + (define/override (start-collect ds fns ci) (map (lambda (d fn) (parameterize ([current-output-file fn] @@ -266,14 +278,23 @@ ;; ---------------------------------------- + (define external-tag-path #f) + (define/public (set-external-tag-path p) + (set! external-tag-path p)) + (define/public (tag->path+anchor ri tag) - (let ([dest (resolve-get #f ri tag)]) + ;; Called externally; not used internally + (let-values ([(dest ext?) (resolve-get/ext? #f ri tag)]) (if dest - (values - (relative->path (dest-path dest)) - (if (dest-page? dest) - #f - (anchor-name (dest-anchor dest)))) + (if (and ext? external-tag-path) + (values + external-tag-path + (format "~a" (serialize tag))) + (values + (relative->path (dest-path dest)) + (if (dest-page? dest) + #f + (anchor-name (dest-anchor dest))))) (values #f #f)))) ;; ---------------------------------------- @@ -686,17 +707,25 @@ [(and (link-element? e) (not (current-no-links))) (parameterize ([current-no-links #t]) - (let ([dest (resolve-get part ri (link-element-tag e))]) + (let-values ([(dest ext?) (resolve-get/ext? part ri (link-element-tag e))]) (if dest - `((a ((href ,(format "~a~a~a" - (from-root (relative->path (dest-path dest)) + `((a ((href ,(if (and ext? external-tag-path) + ;; Redirected to search: + (format "~a;tag=~a" + external-tag-path + (base64-encode + (string->bytes/utf-8 + (format "~a" (serialize (link-element-tag e)))))) + ;; Normal link: + (format "~a~a~a" + (from-root (relative->path (dest-path dest)) (get-dest-directory)) (if (dest-page? dest) "" "#") (if (dest-page? dest) "" - (anchor-name (dest-anchor dest))))) + (anchor-name (dest-anchor dest)))))) ,@(if (string? (element-style e)) `((class ,(element-style e))) null)) @@ -792,7 +821,7 @@ null))))]) `((img ((src ,(let ([p (install-file src)]) (if (path? p) - (url->string (path->url p)) + (url->string (path->url (path->complete-path p))) p)))) ,@sz)))] [else (super render-element e part ri)]))) @@ -1036,7 +1065,7 @@ (define (from-root p d) (if (not d) - (url->string (path->url p)) + (url->string (path->url (path->complete-path p))) (let ([e-d (explode (path->complete-path d (current-directory)))] [e-p (explode (path->complete-path p (current-directory)))]) (let loop ([e-d e-d] diff --git a/collects/scribble/render-struct.ss b/collects/scribble/render-struct.ss new file mode 100644 index 00000000..7ad90ec2 --- /dev/null +++ b/collects/scribble/render-struct.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require scheme/serialize) +(provide (struct-out mobile-root)) + +(define-serializable-struct mobile-root (path) #:mutable) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index dc55a366..28e08c4d 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -31,6 +31,8 @@ (make-parameter null)) (define current-style-file (make-parameter #f)) + (define current-redirect + (make-parameter #f)) (define (get-command-line-files argv) (command-line @@ -52,6 +54,8 @@ (current-dest-name name)] [("--style") file "use given .css/.tex file" (current-style-file file)] + [("--redirect") url "redirect external tag links to " + (current-redirect url)] [("--info-out") file "write format-specific link information to " (current-info-output-file file)]] [multi @@ -74,6 +78,8 @@ (let ([renderer (new ((current-render-mixin) render%) [dest-dir dir] [style-file (current-style-file)])]) + (when (current-redirect) + (send renderer set-external-tag-path (current-redirect))) (send renderer report-output!) (let* ([fns (map (lambda (fn) (let-values ([(base name dir?) (split-path fn)]) diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index a507653c..e91d66da 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -41,12 +41,20 @@ #f)]) (values v #t))])))) - (define (resolve-get part ri key) + (define (resolve-get/ext? part ri key) (let-values ([(v ext?) (resolve-get/where part ri key)]) (when ext? (hash-set! (resolve-info-undef ri) (tag-key key ri) #t)) + (values v ext?))) + + (define (resolve-get part ri key) + (let-values ([(v ext?) (resolve-get/ext? part ri key)]) + v)) + + (define (resolve-get/tentative part ri key) + (let-values ([(v ext?) (resolve-get/where part ri key)]) v)) (define (resolve-search search-key part ri key) @@ -61,10 +69,6 @@ (hash-set! s-ht key #t)) (resolve-get part ri key)) - (define (resolve-get/tentative part ri key) - (let-values ([(v ext?) (resolve-get/where part ri key)]) - v)) - (define (resolve-get-keys part ri key-pred) (let ([l null]) (hash-for-each @@ -499,6 +503,7 @@ [collect-put! (collect-info? info-key? any/c . -> . any)] [resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-get/tentative ((or/c part? false/c) resolve-info? info-key? . -> . any)] + [resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)]) diff --git a/collects/scribble/xref.ss b/collects/scribble/xref.ss index a1689657..947c0970 100644 --- a/collects/scribble/xref.ss +++ b/collects/scribble/xref.ss @@ -18,6 +18,7 @@ xref-binding->definition-tag xref-tag->path+anchor xref-tag->index-entry + xref-transfer-info (struct-out entry)) (define-struct entry (words ; list of strings: main term, sub-term, etc. @@ -35,7 +36,9 @@ (define-namespace-anchor here) -(define (load-xref sources #:render% [render% (html:render-mixin render%)]) +(define (load-xref sources + #:render% [render% (html:render-mixin render%)] + #:root [root-path #f]) (let* ([renderer (new render% [dest-dir (find-system-path 'temp-dir)])] [ci (send renderer collect null null)]) @@ -43,7 +46,7 @@ (parameterize ([current-namespace (namespace-anchor->empty-namespace here)]) (let ([v (src)]) (when v - (send renderer deserialize-info v ci))))) + (send renderer deserialize-info v ci #:root root-path))))) sources) (make-xrefs renderer (send renderer resolve null null ci)))) @@ -78,6 +81,9 @@ (void) (car xs)))) +(define (xref-transfer-info renderer ci xrefs) + (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))) + ;; Returns (values ) (define xref-binding-tag (case-lambda diff --git a/collects/scribblings/scribble/renderer.scrbl b/collects/scribblings/scribble/renderer.scrbl index 466cae9f..5d723df4 100644 --- a/collects/scribblings/scribble/renderer.scrbl +++ b/collects/scribblings/scribble/renderer.scrbl @@ -45,53 +45,57 @@ object's methods directly. Represents a renderer. -@defconstructor[([dest-dir path-string?])]{ +@defconstructor[([dest-dir path-string?] + [refer-to-existing-files any/c #f] + [root-path (or/c path-string? false/c) #f])]{ Creates a renderer whose output goes to @scheme[dest-dir]. -} +If @scheme[root-path] is not @scheme[#f], it is normally the same as +@scheme[dest-dir] or a parent of @scheme[dest-dir]. It causes +cross-reference information to record destination files relative to +@scheme[root-path]; when cross-reference information is serialized, it +can be deserialized via @method[render% deserialize-info] with a +different root path (indicating that the destination files have +moved).} @defmethod[(collect [srcs (listof part?)] [dests (listof path-string?)]) collect-info?]{ -Performs the @techlink{collect pass}. - -} +Performs the @techlink{collect pass}.} @defmethod[(resolve [srcs (listof part?)] [dests (listof path-string?)] [ci collect-info?]) resolve-info?]{ -Performs the @techlink{resolve pass}. - -} +Performs the @techlink{resolve pass}.} @defmethod[(render [srcs (listof part?)] [dests (listof path-string?)] [ri resolve-info?]) void?]{ -Produces the final output. - -} +Produces the final output.} @defmethod[(serialize-info [ri resolve-info?]) any/c]{ -Serializes the collected info in @scheme[ri]. - -} +Serializes the collected info in @scheme[ri].} @defmethod[(deserialize-info [v any/c] - [ci collect-info?]) + [ci collect-info?] + [#:root root-path (or/c path-string? false/c) #f]) void?]{ Adds the deserialized form of @scheme[v] to @scheme[ci]. -} +If @scheme[root-path] is not @scheme[#f], then file paths that are +recorded in @scheme[ci] as relative to an instantiation-supplied +@scheme[root-path] are deserialized as relative instead to the given +@scheme[root-path].} } @@ -101,9 +105,9 @@ Adds the deserialized form of @scheme[v] to @scheme[ci]. @defmodule/local[scribble/text-render]{ -@defthing[render-mixin ((subclass?/c render%) . -> . (subclass?/c render%))]{ +@defmixin[render-mixin (render%) ()]{ -Specializes @scheme[render%] for generating plain text.}} +Specializes a @scheme[render%] class for generating plain text.}} @; ---------------------------------------- @@ -111,14 +115,26 @@ Specializes @scheme[render%] for generating plain text.}} @defmodule/local[scribble/html-render]{ -@defthing[render-mixin ((subclass?/c render%) . -> . (subclass?/c render%))]{ +@defmixin[render-mixin (render%) ()]{ -Specializes @scheme[render%] for generating a single HTML file.} +Specializes a @scheme[render%] class for generating HTML output. -@defthing[render-multi-mixin ((subclass?/c render%) . -> . (subclass?/c render%))]{ +@defmethod[(set-external-tag-path [url string?]) void?]{ -Further specializes @scheme[render%] for generating multiple HTML -files. The input class must be first extended with @scheme[render-mixin].}} +Configures the renderer to redirect links to external via +@scheme[url], adding a @scheme[tag] query element to the end of the +URL that contains the Base64-encoded, @scheme[print]ed, serialized +original tag (in the sense of @scheme[link-element]) for the link.} + +} + +@defmixin[render-multi-mixin (render%) ()]{ + +Further specializes a rendering class produced by +@scheme[render-mixin] for generating multiple HTML +files.} + +} @; ---------------------------------------- @@ -126,6 +142,6 @@ files. The input class must be first extended with @scheme[render-mixin].}} @defmodule/local[scribble/latex-render]{ -@defthing[render-mixin ((subclass?/c render%) . -> . (subclass?/c render%))]{ +@defmixin[render-mixin (render%) ()]{ -Specializes @scheme[render%] for generating Latex input.}} +Specializes a @scheme[render%] class for generating Latex input.}} diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 1626cdad..c5017737 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -640,6 +640,15 @@ documentation. } + +@defproc[(resolve-get/ext? [p (or/c part? false/c)] [ri resolve-info?] [key info-key?]) + (values any/c boolean?)]{ + +Like @scheme[render-get], but returns a second value to indicate +whether the resulting information originated from an external source +(i.e., a different document).} + + @defproc[(resolve-search [dep-key any/c][p (or/c part? false/c)] [ri resolve-info?] [key info-key?]) void?]{ diff --git a/collects/scribblings/scribble/xref.scrbl b/collects/scribblings/scribble/xref.scrbl index df383840..0de8ff1a 100644 --- a/collects/scribblings/scribble/xref.scrbl +++ b/collects/scribblings/scribble/xref.scrbl @@ -22,7 +22,8 @@ by @scheme[load-xref], @scheme[#f] otherwise.} @defproc[(load-xref [sources (listof (-> any/c))] [#:render% using-render% (subclass?/c render%) - (render-mixin render%)]) + (render-mixin render%)] + [#:root root-path (or/c path-string? false/c) #f]) xref?]{ Creates a cross-reference record given a list of functions that each @@ -34,6 +35,10 @@ Since the format of serialized information is specific to a rendering class, the optional @scheme[using-render%] argument accepts the relevant class. It default to HTML rendering. +If @scheme[root-path] is not @scheme[#f], then file paths that are +serialized as relative to an instantiation-supplied @scheme[root-path] +are deserialized as relative instead to the given @scheme[root-path]. + Use @scheme[load-collections-xref] from @schememodname[setup/xref] to get all cross-reference information for installed documentation.} @@ -157,6 +162,16 @@ rendering (such as image files) are referenced from their existing locations, instead of copying to the directory of @scheme[dest].} +@defproc[(xref-transfer-info [renderer (is-a?/c render%)] + [ci collect-info?] + [xref xref?]) + void?]{ + +Transfers cross-reference information to @scheme[ci], which is the +initially collected information from @scheme[renderer].} + + + @defproc[(xref-index [xref xref?]) (listof entry?)]{ Converts indexing information @scheme[xref] into a list of