From be7ba71139fac07e4775f1b3a7b1bf968ff9a0d1 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
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 <url>"
+ (current-redirect url)]
[("--info-out") file "write format-specific link information to <file>"
(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 <tag-or-#f> <form?>)
(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