From f5a0b9e613c3cc050c75ce6de2cd76a557d9cc7a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 22 May 2010 08:46:05 -0600
Subject: [PATCH] fix scribble/xref

---
 collects/scribble/html-render.rkt        | 25 ++++++++++++++++++++++++
 collects/scribble/xref.rkt               | 11 ++++++++---
 collects/scribblings/scribble/xref.scrbl |  4 ++++
 3 files changed, 37 insertions(+), 3 deletions(-)

diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt
index bcf4cc8d42..40f2220d4b 100644
--- a/collects/scribble/html-render.rkt
+++ b/collects/scribble/html-render.rkt
@@ -313,10 +313,35 @@
     (define/public (set-external-root-url p)
       (set! external-root-url p))
 
+    (define (try-relative-to-external-root dest)
+      (cond
+       [(let ([rel (find-relative-path
+                    (find-doc-dir)
+                    (relative->path (dest-path dest)))])
+          (and (relative-path? rel)
+               rel))
+        => (lambda (rel)
+             (cons
+              (url->string
+               (struct-copy
+                url
+                (combine-url/relative
+                 (string->url external-root-url)
+                 (string-join (map path-element->string
+                                   (explode-path rel))
+                              "/"))))
+              (and (not (dest-page? dest))
+                   (anchor-name (dest-anchor dest)))))]
+       [else #f]))
+
     (define/public (tag->path+anchor ri tag)
       ;; Called externally; not used internally
       (let-values ([(dest ext?) (resolve-get/ext? #f ri tag)])
         (cond [(not dest) (values #f #f)]
+              [(and ext? external-root-url
+                    (try-relative-to-external-root dest))
+               => (lambda (p)
+                    (values (car p) (cdr p)))]
               [(and ext? external-tag-path)
                (values (string->url external-tag-path) (format "~a" (serialize tag)))]
               [else (values (relative->path (dest-path dest))
diff --git a/collects/scribble/xref.rkt b/collects/scribble/xref.rkt
index aba49abf56..e0c095655c 100644
--- a/collects/scribble/xref.rkt
+++ b/collects/scribble/xref.rkt
@@ -41,7 +41,8 @@
                    #: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)])
+         [fp (send renderer traverse null null)]
+         [ci (send renderer collect null null fp)])
     (for ([src sources])
       (parameterize ([current-namespace
                       (namespace-anchor->empty-namespace here)])
@@ -121,8 +122,12 @@
     tag))
 
 (define (xref-tag->path+anchor xrefs tag
-                               #:render% [render% (html:render-mixin render%)])
-  (send (new render% [dest-dir (find-system-path 'temp-dir)])
+                               #:render% [render% (html:render-mixin render%)]
+                               #:external-root-url [redirect-main #f])
+  (send (let ([r (new render% [dest-dir (find-system-path 'temp-dir)])])
+          (when redirect-main
+            (send r set-external-root-url redirect-main))
+          r)
         tag->path+anchor (xrefs-ri xrefs) tag))
 
 (define (xref-tag->index-entry xrefs tag)
diff --git a/collects/scribblings/scribble/xref.scrbl b/collects/scribblings/scribble/xref.scrbl
index 756a155096..ccd353cce9 100644
--- a/collects/scribblings/scribble/xref.scrbl
+++ b/collects/scribblings/scribble/xref.scrbl
@@ -99,6 +99,7 @@ is found in @racket[xref], the result is @racket[#f].}
 
 @defproc[(xref-tag->path+anchor [xref xref?]
                                 [tag tag?]
+                                [#:external-root-url root-url (or/c string? #f) #f]
                                 [#:render% using-render% (subclass?/c render%)
                                            (render-mixin render%)])
          (values (or/c false/c path?)
@@ -111,6 +112,9 @@ result is @racket[#f] if the first result is @racket[#f], and it can
 also be @racket[#f] if the tag refers to a page rather than a specific
 point in a page.
 
+If @racket[root-url] is provided, then references to documentation in
+the main installation are redirected to the given URL.
+
 The optional @racket[using-render%] argument is as for
 @racket[load-xref].}