up links in all documents, and they go to the user docs using cookies

svn: r9992

original commit: 9127cdaaf832b8bab1353eecbfc47d5e7fe96fe4

collects/scribble/html-render.ss

@@ -219,6 +219,9 @@
              quiet-table-of-contents)
 
     (init-field [css-path #f]
+                ;; up-path is either a link "up", or #t which uses
+                ;; goes to start page (using cookies to get to the
+                ;; user start page)
                 [up-path #f]
                 [style-file #f]
                 [script-path #f]
@@ -620,14 +623,26 @@
                   prev-content)
                  sep-element
                  (make-element
-                  (if (or parent up-path)
+                  (cond
-                    (make-target-url
+                    ;; up-path = #t => go up to the start page, using
-                     (cond [(not parent) up-path]
+                    ;; cookies to get to the user's version of it (see
-                           [(and (toc-part? parent) (part-parent parent ri))
+                    ;; scribblings/main/private/utils for the code
-                            (derive-filename parent)]
+                    ;; that creates these cookies.)
-                           [else "index.html"])
+                    [(and (eq? #t up-path) (not parent))
-                     #f)
+                     (make-target-url
-                    "nonavigation")
+                      "../index.html"
+                      (make-with-attributes
+                       #f `([onclick
+                             . ,(format "return GotoPLTRoot(\"~a\");"
+                                        (version))])))]
+                    [(or parent up-path)
+                     (make-target-url
+                      (cond [(not parent) up-path]
+                            [(and (toc-part? parent) (part-parent parent ri))
+                             (derive-filename parent)]
+                            [else "index.html"])
+                      #f)]
+                    [else "nonavigation"])
                   up-content)
                  sep-element
                  (make-element
@@ -754,18 +769,18 @@
     (define/private (render-plain-element e part ri)
       (let* ([raw-style (flatten-style (and (element? e) (element-style e)))]
              [style (if (with-attributes? raw-style)
-                        (with-attributes-style raw-style)
+                      (with-attributes-style raw-style)
-                        raw-style)]
+                      raw-style)]
              [attribs (lambda ()
                         (if (with-attributes? raw-style)
-                            (map (lambda (p) (list (car p) (cdr p)))
+                          (map (lambda (p) (list (car p) (cdr p)))
-                                 (with-attributes-assoc raw-style))
+                               (with-attributes-assoc raw-style))
-                            null))]
+                          null))]
              [super-render/attribs
               (lambda ()
                 (if (with-attributes? raw-style)
-                    `((span ,(attribs) ,@(super render-element e part ri)))
+                  `((span ,(attribs) ,@(super render-element e part ri)))
-                    (super render-element e part ri)))])
+                  (super render-element e part ri)))])
         (cond
          [(symbol? style)
           (case style
@@ -809,20 +824,20 @@
                   ,@(super render-element e part ri)))]
          [(target-url? style)
           (if (current-no-links)
-              (super-render/attribs)
+            (super-render/attribs)
-              (parameterize ([current-no-links #t])
+            (parameterize ([current-no-links #t])
-                `((a ([href ,(let ([addr (target-url-addr style)])
+              `((a ([href ,(let ([addr (target-url-addr style)])
-                               (if (path? addr)
+                             (if (path? addr)
-                                   (from-root addr (get-dest-directory))
+                               (from-root addr (get-dest-directory))
-                                   addr))]
+                               addr))]
-                      ;; The target-url chains to another style. Allow
+                    ;; The target-url chains to another style,
-                      ;;  `with-attributes' inside as well as outside:
+                    ;; flatten-style above takes care of it though.
-                      ,@(let ([style (target-url-style style)])
+                    ,@(let ([style (target-url-style style)])
-                          (if (string? style)
+                        (if (string? style)
-                              `([class ,style])
+                          `([class ,style])
-                              null))
+                          null))
-                      . ,(attribs))
+                    . ,(attribs))
-                     ,@(super render-element e part ri)))))]
+                   ,@(super render-element e part ri)))))]
          [(url-anchor? style)
           `((a ([name ,(url-anchor-name style)] . ,(attribs))
                ,@(super render-element e part ri)))]

collects/scribble/scribble-common.js

@@ -19,19 +19,21 @@ function SetCookie(key, val) {
     key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/";
 }
 
-function GotoPLTRoot(ver) {
+// note that this always stores a directory name, ending with a "/"
-  var u = GetCookie("PLT_Root."+ver);
-  if (u == null) return true; // no cookie: use plain up link
-  location = u;
-  return false;
-}
-
 function SetPLTRoot(ver, relative) {
   var root = location.protocol + "//" + location.host
            + NormalizePath(location.pathname.replace(/[^\/]*$/, relative));
   SetCookie("PLT_Root."+ver, root);
 }
 
+// adding index.html works because of the above
+function GotoPLTRoot(ver) {
+  var u = GetCookie("PLT_Root."+ver);
+  if (u == null) return true; // no cookie: use plain up link
+  location = u + "index.html";
+  return false;
+}
+
 normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
 function NormalizePath(path) {
   var tmp, i;

collects/scribble/struct.ss

@@ -172,7 +172,7 @@
                   [parent (or/c false/c part?)]
                   [info any/c])]
 
- [target-url ([addr (or/c string? path?)][style any/c])]
+ [target-url ([addr (or/c string? path?)] [style any/c])]
  [url-anchor ([name string?])]
  [image-file ([path (or/c path-string?
                           (cons/c (one-of/c 'collects)