From 53f9aad182b8aed14b47e00f24e0d94ad910ad1a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 4 Nov 2008 12:16:45 +0000
Subject: [PATCH] add --redirect-main to scribble

svn: r12230

original commit: 04369a39c7886125501cdb5e0ec79b91a2c33e78
---
 collects/scribble/html-render.ss | 32 ++++++++++++++++++++++++++++----
 collects/scribble/run.ss         |  8 +++++++-
 2 files changed, 35 insertions(+), 5 deletions(-)

diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
index 8b9089c8..a67e5d19 100644
--- a/collects/scribble/html-render.ss
+++ b/collects/scribble/html-render.ss
@@ -340,12 +340,16 @@
     (define/public (set-external-tag-path p)
       (set! external-tag-path p))
 
+    (define external-root-url #f)
+    (define/public (set-external-root-url p)
+      (set! external-root-url p))
+
     (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-tag-path)
-               (values external-tag-path (format "~a" (serialize tag)))]
+               (values (string->url external-tag-path) (format "~a" (serialize tag)))]
               [else (values (relative->path (dest-path dest))
                             (and (not (dest-page? dest))
                                  (anchor-name (dest-anchor dest))))])))
@@ -845,7 +849,26 @@
                          (resolve-get/ext? part ri (link-element-tag e))])
              (if dest
                `((a [(href
-                      ,(if (and ext? external-tag-path)
+                      ,(cond
+                        [(and ext? external-root-url
+                              (let ([rel (find-relative-path
+                                          (find-doc-dir)
+                                          (relative->path (dest-path dest)))])
+                                (and (relative-path? rel)
+                                     rel)))
+                         => (lambda (rel)
+                              (url->string
+                               (struct-copy
+                                url
+                                (combine-url/relative
+                                 (string->url external-root-url)
+                                 (string-join (map path-element->string
+                                                   (explode-path rel))
+                                              "/"))
+                                [fragment
+                                 (and (not (dest-page? dest))
+                                      (anchor-name (dest-anchor dest)))])))]
+                        [(and ext? external-tag-path)
                          ;; Redirected to search:
                          (url->string
                           (let ([u (string->url external-tag-path)])
@@ -859,7 +882,8 @@
                                             (string->bytes/utf-8
                                              (format "~a" (serialize
                                                            (link-element-tag e)))))))
-                                    (url-query u))])))
+                                    (url-query u))])))]
+                        [else
                          ;; Normal link:
                          (format "~a~a~a"
                                  (from-root (relative->path (dest-path dest))
@@ -867,7 +891,7 @@
                                  (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)]
diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss
index e79b6f71..58bd4961 100644
--- a/collects/scribble/run.ss
+++ b/collects/scribble/run.ss
@@ -38,6 +38,8 @@
     (make-parameter null))
   (define current-redirect
     (make-parameter #f))
+  (define current-redirect-main
+    (make-parameter #f))
 
   (define (read-one str)
     (let ([i (open-input-string str)])
@@ -67,8 +69,10 @@
        (current-dest-name name)]
       [("--style") file "use given base .css/.tex file"
        (current-style-file file)]
-      [("--redirect") url "redirect external tag links to <url>"
+      [("--redirect") url "redirect external links to tag search via <url>"
        (current-redirect url)]
+      [("--redirect-main") url "redirect main doc links to <url>"
+       (current-redirect-main url)]
       [("--info-out") file "write format-specific link information to <file>"
        (current-info-output-file file)]]
      [multi
@@ -110,6 +114,8 @@
                            [style-extra-files (reverse (current-style-extra-files))])])
         (when (current-redirect)
           (send renderer set-external-tag-path (current-redirect)))
+        (when (current-redirect-main)
+          (send renderer set-external-root-url (current-redirect-main)))
         (send renderer report-output!)
         (let* ([fns (map (lambda (fn)
                            (let-values ([(base name dir?) (split-path fn)])