further repairs and refinments to "langfam" navigation

Enable a language-specific landing page to have "top" and "up" in the
case that it's being viewed for a language family other than its own.

Author: mflatt

scribble-doc/scribblings/scribble/core.scrbl

@@ -491,6 +491,12 @@ The recognized @tech{style properties} are as follows:
        not include ``top,'' ``up,'', ``prev,'' and ``next'' controls
        if they would otherwise apply.}
 
+ @item{@indexed-racket['family-navigation] --- As a @tech{style
+       property} for the main part of a rendered page, causes the HTML
+       output to include ``top,'' ``up,'', ``prev,'' and ``next''
+       controls only when the viewing context indicates a language
+       family not in the page's language families.}
+
  @item{@indexed-racket['no-header-controls] --- Suppresses link and
        link-information icons (if any) as part of a section header in
        HTML output.}
@@ -602,7 +608,8 @@ The @racket[parts] field contains sub-parts.
          #:changed "1.54" @elem{Changed @racket[tag-prefix] field to allow a
                                 @tech{part context} hash table.}
          #:changed "1.57" @elem{Added @racket['no-header-controls] support.}
-         #:changed "1.59" @elem{Added @racket['no-navigation] support.}]}
+         #:changed "1.59" @elem{Added @racket['no-navigation] and
+                                @racket['family-navigation] support.}]}
 
 
 @defstruct[paragraph ([style style?] [content content?])]{

scribble-lib/scribble/base-render.rkt

@@ -326,7 +326,7 @@
              (cons p (current-tag-prefixes)))]
        [else (current-tag-prefixes)]))
 
-    (define/private (extend-part-context d)
+    (define/public (extend-part-context d)
       (define p (part-tag-prefix d))
       (cond
         [(hash? p) (merge-part-contexts p (current-part-context))]

scribble-lib/scribble/html-render.rkt

@@ -281,6 +281,7 @@
              extract-version
              extract-authors
              extract-pretitle
+             extend-part-context
              link-render-style-at-element)
     (inherit-field prefix-file style-file style-extra-files image-preferences)
 
@@ -1025,12 +1026,29 @@
            `([title . ,(if title* (string-append label " to " title*) label)]
              [data-pltdoc . "x"]
              ,@more)))))
+      (define no-nav? (and (memq 'no-navigation (style-properties (part-style d))) #t))
+      (define family-nav? (and (memq 'family-navigation (style-properties (part-style d))) #t))
+      (define fam (and family-nav?
+                       (or (search-extras (hash-ref (extend-part-context d) 'index-extras #hasheq()) 'language-family)
+                           '("Racket"))))
+      (define (wrap-family c)
+        (if family-nav?
+            `((div ([style "display: none;"]
+                    [class "family-navigation"]
+                    [data-familynav ,(string-join fam ",")])
+                   ,@c))
+            c))
       (define top-link
         (titled-url
-         "up" (if (path? up-path)
-                  (url->string* (path->url up-path))
-                  "../index.html")
-         `[onclick . ,(format "return GotoPLTRoot(\"~a\");" (get-installation-name))]))
+         "up" (cond
+                [(path? up-path) (url->string* (path->url up-path))]
+                [up-path "../index.html"]
+                [else "index.html"])
+         `[onclick . ,(format "return GotoPLTRoot(\"~a\", \"index.html\", \"~a\");"
+                              (get-installation-name)
+                              (if up-path
+                                  "../"
+                                  ""))]))
       (define tocset-toggle
         (make-element "tocsettoggle"
                       (list
@@ -1042,58 +1060,61 @@
                                          '([title . "show/hide table of contents"]
                                            [onclick . "TocsetToggle();"]))))
                         "contents"))))
-      (define no-nav? (and (memq 'no-navigation (style-properties (part-style d))) #t))
       (define navleft
         `(span ([class "navleft"])
            ,@(if search-box?
                  (list (if search-up-path search-box top-search-box))
                  (list `(div ([class "nosearchform"]))))
-           ,@(render
-              sep-element
-              (and up-path (not no-nav?) (make-element top-link top-content))
-              tocset-toggle
-              ;; sep-element
-              ;; (make-element
-              ;;  (if parent (make-target-url "index.html" #f) "nonavigation")
-              ;;  contents-content)
-              ;; sep-element
-              ;; (if (or (not index) (eq? d index))
-              ;;   (make-element "nonavigation" index-content)
-              ;;   (make-link-element #f index-content (car (part-tags/nonempty index))))
-              )))
+           ,@(wrap-family
+              (render
+               sep-element
+               (and (or up-path family-nav?) (not no-nav?) (make-element top-link top-content))
+               tocset-toggle
+               ;; sep-element
+               ;; (make-element
+               ;;  (if parent (make-target-url "index.html" #f) "nonavigation")
+               ;;  contents-content)
+               ;; sep-element
+               ;; (if (or (not index) (eq? d index))
+               ;;   (make-element "nonavigation" index-content)
+               ;;   (make-link-element #f index-content (car (part-tags/nonempty index))))
+               ))))
       (define navright
-        (if (or (not (or parent up-path next)) no-nav?)
-          ""
-          `(span ([class "navright"])
-             ,@(render
-                ;; put space here for text browsers and to avoid an Opera issue
-                sep-element
-                (make-element
-                 (cond [(not parent) "nonavigation"]
-                       [prev (titled-url "backward" prev '[rel . "prev"])]
-                       [else (titled-url "backward" "index.html" '[rel . "prev"]
-                                         #:title-from
-                                         (and (part? parent) parent))])
-                 prev-content)
-                sep-element
-                (make-element
-                 (cond
-                   [(and (part? parent) (toc-part? parent ri)
-                         (part-parent parent ri))
-                    (titled-url "up" parent)]
-                   [parent (titled-url "up" "index.html" #:title-from parent)]
-                   ;; up-path = #t => go up to the start page, using
-                   ;; cookies to get to the user's version of it (see
-                   ;; scribblings/main/private/utils for the code that
-                   ;; creates these cookies.)
-                   [(eq? #t up-path) top-link]
-                   [up-path (titled-url "up" up-path)]
-                   [else "nonavigation"])
-                 up-content)
-                sep-element
-                (make-element
-                 (if next (titled-url "forward" next '[rel . "next"]) "nonavigation")
-                 next-content)))))
+        (if (or (not (or parent up-path next family-nav?)) no-nav?)
+            ""
+            `(span ([class "navright"])
+                   ,@(wrap-family
+                      (render
+                       ;; put space here for text browsers and to avoid an Opera issue
+                       sep-element
+                       (make-element
+                        (cond [(not parent) "nonavigation"]
+                              [prev (titled-url "backward" prev '[rel . "prev"])]
+                              [else (titled-url "backward" "index.html" '[rel . "prev"]
+                                                #:title-from
+                                                (and (part? parent) parent))])
+                        prev-content)
+                       sep-element
+                       (make-element
+                        (cond
+                          [(and (part? parent) (toc-part? parent ri)
+                                (part-parent parent ri))
+                           (titled-url "up" parent)]
+                          [parent
+                           (titled-url "up" "index.html" #:title-from parent)]
+                          ;; up-path = #t => go up to the start page using
+                          ;; query or cookies to get to the user's version of it (see
+                          ;; scribblings/main/private/utils for the code that
+                          ;; creates these cookies.)
+                          [(or (eq? #t up-path) family-nav?)
+                           top-link]
+                          [up-path (titled-url "up" up-path)]
+                          [else "nonavigation"])
+                        up-content)
+                       sep-element
+                       (make-element
+                        (if next (titled-url "forward" next '[rel . "next"]) "nonavigation")
+                        next-content))))))
       (define navbar
         `(div ([class ,(if top? "navsettop" "navsetbottom")])
            ,navleft ,navright nbsp)) ; need nbsp to make the navset bg visible
@@ -2167,3 +2188,10 @@
             (string-append "file://" (path->string p))
             (url->string (path->url p))))
       (url->string (path->url p))))
+
+(define (search-extras extras-tree key)
+  (cond
+    [(hash? extras-tree) (hash-ref extras-tree key #f)]
+    [(pair? extras-tree) (or (search-extras (car extras-tree) key)
+                             (search-extras (cdr extras-tree) key))]
+    [else #f]))

scribble-lib/scribble/scribble-common.js

@@ -90,23 +90,26 @@ function SetPLTRoot(ver, relative) {
 }
 
 // adding index.html works because of the above
-function GotoPLTRoot(ver, relative) {
-  var famroot = (GetPageArg("fam", false) ? GetPageArg("famroot", false) : false)
+function GotoPLTRoot(ver, root_relative, here_to_root_relative) {
+  // the relative path is optional, default goes to the toplevel start page
+  if (!root_relative) root_relative = "index.html";
+  if (here_to_root_relative == undefined) here_to_root_relative = "../"
+  var famroot = false;
+  if (root_relative == "index.html") {
+    famroot = (GetPageArg("fam", false) ? GetPageArg("famroot", false) : false)
+    root_relative = famroot + "/index.html";
+  }
+
   var u = GetRootPath(ver);
   if (u == null) {
-    // no cookie: use plain up link
     if (famroot) {
-        location = MergePageArgsIntoUrl("../" + famroot + "/index.html");
-        return false;
+      location = MergePageArgsIntoUrl(here_to_root_relative + famroot + "/index.html");
+      return false;
     }
+    // no cookie and no famroot => follow href, instead
     return true;
   }
-  // the relative path is optional, default goes to the toplevel start page
-  if (!relative) relative = "index.html";
-  if (relative == "index.html" && famroot) {
-      relative = famroot + "/index.html";
-  }
-  location = MergePageArgsIntoUrl(u + relative);
+  location = MergePageArgsIntoUrl(u + root_relative);
   return false;
 }
 
@@ -200,3 +203,17 @@ AddOnLoad(function(){
     }
   }, false);
 });
+
+AddOnLoad(function(){
+  var es = document.getElementsByClassName("family-navigation");
+  if (es.length > 0) {
+    var fams = es[0].dataset.familynav.split(/,/);
+    var fam = GetPageArg("famroot", false) && GetPageArg("fam", false);
+    if (!fam) fam = "Racket";
+    if (fams.indexOf(fam) == -1) {
+      for (var i=0; i < es.length; i++) {
+        es[i].style.display = "inline-block";
+      }
+    }
+  }
+});