Better code to generate main page titles and toc

svn: r9955

collects/scribblings/main/acks.scrbl

@@ -1,11 +1,9 @@
 #lang scribble/doc
 @(require scribble/manual
           drscheme/acks
-          "private/front-toc.ss")
+          "private/utils.ss")
 
-@title[#:style '(no-toc)]{Acknowledgements}
+@main-page['acks]
-
-@front-toc['acks #f]
 
 @(get-general-acks)
 

collects/scribblings/main/config.ss

@@ -4,6 +4,27 @@
 
 ;; Configuration of various parts of the main pages
 
+(define bug-url "http://bugs.plt-scheme.org/")
+
+;; Link definitions: (id-sym title root-sym/#f-for-url subpath/url),
+;; or a `---' for a spacer; the root-sym can be `plt' for standard
+;; pages, or `user' for pages that have an installation and a
+;; user-specific version (and navigating to them should get to the
+;; user-specific pages using cookies).  (Note: the subpath must match
+;; where the corresponding document is generated, this is a hack.)
+(define links
+  `((start   "PLT Manuals"      user "index.html")
+    (search  "Search Manuals"   user "search/index.html")
+    ---
+    (index   "Master Index"     user "master-index/index.html")
+    ---
+    (license "License"          plt  "license/index.html")
+    (acks    "Acknowledgements" plt  "acks/index.html")
+    (release "Release Notes"    plt  "release/index.html")
+    ---
+    (bugreport "Report a Bug"   #f ,(format "~a?v=~a" bug-url (version)))))
+
+;; Section definitions for manuals that appear on the start page.
 (define manual-sections
   '((getting-started "Getting Started")
     (language        "Languages")

collects/scribblings/main/license.scrbl

@@ -1,12 +1,10 @@
 #lang scribble/doc
 @(require scribble/manual
-          "private/front-toc.ss")
+          "private/utils.ss")
 
 @(define (copyright . strs) (apply verbatim #:indent 2 strs))
 
-@front-toc['license #f]
+@main-page['license]
-
-@title[#:style '(no-toc)]{License}
 
 PLT software and documentation is distributed under the GNU Lesser
 General Public License (LGPL).  This means

collects/scribblings/main/master-index.scrbl

@@ -1,10 +1,8 @@
 #lang scribble/doc
 @(require scribble/basic
           scribble/decode
-          "private/front-toc.ss")
+          "private/utils.ss")
 
-@title[#:style '(no-toc)]{Master Index (installation)}
+@main-page['index #t]
-
-@front-toc['index #f]
 
 @(make-splice (index-blocks))

collects/scribblings/main/private/front-toc.ss

@@ -1,45 +0,0 @@
-#lang scheme/base
-
-(require scribble/manual
-         scribble/struct
-         scribble/decode
-         setup/dirs)
-(provide front-toc)
-
-(define bug-url "http://bugs.plt-scheme.org/")
-
-(define spacer
-  (make-toc-element #f null '(nbsp)))
-
-(define ((to-toc here) there target label)
-  (let* ([elt (make-element "tocsubseclink" (list label))]
-         [elt (link target #:underline? (eq? here there) elt)])
-    (make-toc-element #f null (list elt))))
-
-;; FIXME: Use this to avoid hard-wiring manual titles and paths below
-(define (resolve s [f s])
-  (resolved-module-path-name
-   (module-path-index-resolve
-    (module-path-index-join `(lib ,(format "scribblings/~a/~a.scrbl" s f))
-                            #f))))
-
-(define (front-toc here main?)
-  (define docdir (let ([d (find-doc-dir)]) (lambda (p) (build-path d p))))
-  (let ([to-toc (to-toc here)]
-        [up (lambda (s)
-              (if main?
-                  s
-                  ;; This needs to use a cookie(?) to always get to the
-                  ;; user-specific page... ?
-                  (string-append "../" s)))])
-    (make-splice
-     (list (to-toc 'start   (up "index.html") "PLT Scheme Documentation")
-           (to-toc 'search  (up "search/index.html") "Search PLT Manuals")
-           spacer
-           (to-toc 'index   (up "master-index/index.html") "Master Index")
-           spacer
-           (to-toc 'license (docdir "license/index.html") "License")
-           (to-toc 'acks    (docdir "acks/index.html")    "Acknowledgments")
-           (to-toc 'release (docdir "release/index.html") "Release Notes")
-           spacer
-           (to-toc #f (format "~a?v=~a" bug-url (version)) "Report a Bug")))))

collects/scribblings/main/private/manuals.ss

@@ -2,14 +2,12 @@
 
 (require scribble/manual
          scribble/struct
-         scribble/decode
          setup/getinfo
          setup/main-collects
          scheme/list
-         "front-toc.ss"
          "../config.ss")
 
-(provide build-contents)
+(provide make-start-page)
 
 (define-struct sec (cat label))
 
@@ -31,7 +29,7 @@
                                       (truncate (/ (caar l) 10))))])
                     (if sep? (cons (mk-sep lbl) l) l))]))))
 
-(define (build-contents all?)
+(define (make-start-page all?)
   (let* ([dirs (find-relevant-directories '(scribblings))]
          [infos (map get-info/full dirs)]
          [docs (append-map
@@ -78,10 +76,7 @@
          [line
           (lambda (doc)
             (plain-line (hspace 2) (other-manual doc #:underline? #f)))])
-    (make-splice
+    (define (contents renderer part resolve-info)
-     (list
-      (make-delayed-block
-       (lambda (renderer part resolve-info)
       (make-table
        #f
        (cdr
@@ -98,8 +93,7 @@
                  (plain-line
                   (make-element (if (string=? str "") "sepspace" "septitle")
                                 (list 'nbsp str))))
-                  (sort
+               (sort (map (lambda (doc)
-                   (map (lambda (doc)
                             (list (cadr doc) (line (cadddr doc)) (caddr doc)))
                           docs)
                      (lambda (ad bd)
@@ -107,9 +101,10 @@
                          (let ([str (lambda (x)
                                       (element->string
                                        (cadr (paragraph-content
-                                            (car (flow-paragraphs (caadr x)))))
+                                              (car (flow-paragraphs
+                                                    (caadr x)))))
                                        renderer part resolve-info))])
                            (string-ci<? (str ad) (str bd)))
                          (> (car ad) (car bd)))))))))
-            sections)))))
+         sections))))
-      (front-toc 'start #t)))))
+    (make-delayed-block contents)))

collects/scribblings/main/private/utils.ss

@@ -0,0 +1,64 @@
+#lang scheme/base
+
+(require "../config.ss"
+         scribble/manual
+         scribble/struct
+         scribble/decode
+         setup/dirs)
+
+(provide main-page)
+
+(define page-info
+  (let ([links (filter pair? links)])
+    (lambda (id)
+      (cond [(assq id links) => cdr]
+            [else (error 'main-page "page id not found: ~e" id)]))))
+
+;; the second argument specifies installation/user specific, and if
+;; it's missing, then it's a page with a single version
+(define (main-page id [installation-specific? '?])
+  (define info (page-info id))
+  (make-splice (list (title #:style '(no-toc)
+                            (car info)
+                            (case installation-specific?
+                              [(?) ""]
+                              [(#t) " (installation)"]
+                              [(#f) ""])) ; can be " (user)"
+                     (front-toc id))))
+
+;; FIXME: Use this to avoid hard-wiring manual titles and paths in config.ss
+(define (resolve s [f s])
+  (resolved-module-path-name
+   (module-path-index-resolve
+    (module-path-index-join `(lib ,(format "scribblings/~a/~a.scrbl" s f))
+                            #f))))
+
+(define (front-toc-items up)
+  (map (lambda (item)
+         (if (eq? item '---)
+           (list '--- (make-toc-element #f null '(nbsp)))
+           (let* ([id    (car item)]
+                  [info  (page-info id)]
+                  [label (car info)]
+                  [root  (cadr info)]
+                  [path  (caddr info)]
+                  [text  (make-element "tocsubseclink" (list label))]
+                  [link  (link (case root
+                                 [(plt)  (build-path (find-doc-dir) path)]
+                                 [(user) (string-append up path)]
+                                 [(#f)   path]
+                                 [else (error "internal error (main-page)")])
+                               #:underline? #f text)])
+             (list id
+                   (make-toc-element #f null (list link))
+                   (make-toc-element #f null (list text))))))
+       links))
+
+(define (front-toc here)
+  ;; massages the current path to an up string
+  (let* ([up (regexp-replace #rx"[^/]+$" (caddr (page-info here)) "")]
+         [up (regexp-replace* #rx"[^/]*/" up "../")])
+    (make-splice (map (lambda (item)
+                        (let ([id (if (pair? item) (car item) item)])
+                          ((if (eq? here id) caddr cadr) item)))
+                      (front-toc-items up)))))

collects/scribblings/main/release.scrbl

@@ -1,7 +1,7 @@
 #lang scribble/doc
 @(require scribble/manual
           setup/dirs
-          "private/front-toc.ss")
+          "private/utils.ss")
 
 @(define (rl-link path . content)
    (apply link (apply build-path (find-doc-dir) "release-notes" path)
@@ -9,9 +9,7 @@
 @(define (mzport doc from to)
    (rl-link (list "mzscheme" doc) (format "Porting from ~a to ~a" from to)))
 
-@title[#:style '(no-toc)]{Release Notes}
+@main-page['release]
-
-@front-toc['release #f]
 
 @itemize[#:style "compact"]{
 

collects/scribblings/main/start.scrbl

@@ -1,13 +1,14 @@
 #lang scribble/doc
 @(require scribble/manual
           scribble/struct
+          "private/utils.ss"
           "private/manuals.ss")
 
-@title[#:style '(no-toc)]{PLT Scheme Documentation (installation)}
+@main-page['start #t]
 
 @margin-note{This is an installation-specific listing. Running
              @exec{plt-help} may open a different page with local and
              user-specific documentation, including documentation for
              installed @|PLaneT| packages.}
 
-@(build-contents #f)
+@(make-start-page #f)

collects/scribblings/main/user/master-index.scrbl

@@ -1,10 +1,8 @@
 #lang scribble/doc
 @(require scribble/basic
           scribble/decode
-          "../private/front-toc.ss")
+          "../private/utils.ss")
 
-@title[#:style '(no-toc)]{Master Index}
+@main-page['index #f]
-
-@front-toc['index #f]
 
 @(make-splice (index-blocks))

collects/scribblings/main/user/start.scrbl

@@ -1,9 +1,10 @@
 #lang scribble/doc
 @(require scribble/manual
           scribble/struct
+          "../private/utils.ss"
           "../private/manuals.ss")
 
-@title[#:style '(no-toc)]{PLT Scheme Documentation}
+@main-page['start #f]
 
 @;{
 @; This page should always be the default, so it doesn't need to say
@@ -18,4 +19,4 @@
              user-specific packages (@|PLaneT| packages and other
              collections) that are not in the main installation.}
 
-@(build-contents #t)
+@(make-start-page #t)