scribble: add --html-tree <n> mode for rendering to depth <n>

Depth 0 is the same as `--html`, depth 1 is the same as `--htmls`,
and higher depths cause sections and subsections to be rendered
into separate directories when they have their own pages.

original commit: a0c306e2ed0fe9c367cc939de946576552157dac

pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/renderer.scrbl

@@ -15,11 +15,12 @@
      (intro)))
 
 @(begin
-  (define-syntax-rule (def-html-render-mixin id)
+  (define-syntax-rule (def-html-render-mixin id mid)
     (begin
       (require (for-label scribble/html-render))
-      (define id @racket[render-mixin])))
+      (define id @racket[render-mixin])
-  (def-html-render-mixin html:render-mixin))
+      (define mid @racket[render-multi-mixin])))
+  (def-html-render-mixin html:render-mixin html:render-multi-mixin))
 @(begin
   (define-syntax-rule (def-latex-render-mixin id)
     (begin
@@ -53,6 +54,7 @@ function to render a document.
                  [#:info-out-file info-out-file (or/c #f path-string?) #f]
                  [#:redirect redirect (or/c #f string?) #f]
                  [#:redirect-main redirect-main (or/c #f string?) #f]
+                 [#:directory-depth directory-depth exact-nonnegative-integer? 0]
                  [#:quiet? quiet? any/c #t]
                  [#:warn-undefined? warn-undefined? any/c (not quiet?)])
           void?]{
@@ -87,6 +89,9 @@ to the @racket[set-external-tag-path] and
 @racketmodname[scribble/html-render], so they should be
 non-@racket[#f] only for HTML rendering.
 
+The @racket[directory-depth] arguments correspond to the
+@racket[set-directory-depth] method of @|html:render-multi-mixin|.
+
 If @racket[quiet?] is a false value, output-file information is
 written to the current output port.
 
@@ -333,7 +338,15 @@ directory.}
 
 Further specializes a rendering class produced by
 @racket[render-mixin] for generating multiple HTML
-files.}
+files.
+
+@defmethod[(set-directory-depth [depth exact-nonnegative-integer?]) void?]{
+
+Sets the depth of directory structure used when rendering parts that
+are own their own pages. A value of @racket[0] is treated the same as
+@racket[1].}
+
+}
 
 }
 

pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/running.scrbl

@@ -23,6 +23,11 @@ its file suffix:
        a @filepath{@|fn|} directory, starting with
        @filepath{@|fn|/index.html}}
 
+ @item{@DFlag{html-tree} @nonterm{n} --- HTML pages in a directory
+       tree up to @nonterm{n} layers deep; a tree of depth @exec{0} is
+       equivalent to using @DFlag{html}, and a tree of depth @exec{1}
+       is equivalent to using @DFlag{htmls}}
+
  @item{@DFlag{latex} --- LaTeX source @filepath{@|fn|.tex}, plus
        any needed additional files (such as non-standard class files)
        needed to run @exec{latex} or @exec{pdflatex}}

pkgs/scribble-pkgs/scribble-lib/scribble/base-render.rkt

@@ -116,6 +116,14 @@
            (string-append (loop (quotient n 10) X L C D M D M)
                           (loop (modulo n 10) I V X L C D M))])))
 
+    ;; ----------------------------------------
+    ;; Methods that really only work on some renderers:
+
+    (define/public (set-external-tag-path p) (void))
+    (define/public (set-external-root-url p) (void))    
+    (define/public (add-extra-script-file s) (void))
+    (define/public (set-directory-depth n) (void))
+
     ;; ----------------------------------------
 
     (define/public (extract-part-style-files d ri stop-at-part? pred extract)

pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt

@@ -58,18 +58,29 @@
                 ;; note: file-size can be bigger than the string, but
                 ;; that's fine.
                 (read-string (file-size file)))))]
+         [adjust-rel
+          (lambda (depth p)
+            (if (and (relative-path? p)
+                     (positive? depth))
+                (let loop ([d depth] [p p])
+                  (if (zero? d)
+                      p
+                      (loop (sub1 d) (string-append "../" p))))
+                p))]
          [file-getter
           (lambda (default-file make-inline make-ref)
             (let ([c #f])
-              (lambda (file path)
+              (lambda (file path depth)
                 (cond [(bytes? file)
                        (make-inline (bytes->string/utf-8 file))]
                       [(url? file)
                        (make-ref (url->string* file))]
                       [(not (eq? 'inline path))
-                       (make-ref (or path (let-values ([(base name dir?)
+                       (make-ref (adjust-rel
-                                                        (split-path file)])
+                                  depth
-                                            (path->string name))))]
+                                  (or path (let-values ([(base name dir?)
+                                                         (split-path file)])
+                                             (path->string name)))))]
                       [(or (not file) (equal? file default-file))
                        (unless c
                          (set! c (make-inline (read-file default-file))))
@@ -209,6 +220,9 @@
       (list `(part "???"))
       l))
 
+(define (part-parent d ri)
+  (collected-info-parent (part-collected-info d ri)))
+
 ;; ----------------------------------------
 ;;  main mixin
 
@@ -361,15 +375,15 @@
     ;; ----------------------------------------
 
     (define external-tag-path #f)
-    (define/public (set-external-tag-path p)
+    (define/override (set-external-tag-path p)
       (set! external-tag-path p))
 
     (define external-root-url #f)
-    (define/public (set-external-root-url p)
+    (define/override (set-external-root-url p)
       (set! external-root-url p))
 
     (define extra-script-files null)
-    (define/public (add-extra-script-file s)
+    (define/override (add-extra-script-file s)
       (set! extra-script-files (cons s extra-script-files)))
 
     (define (try-relative-to-external-root dest)
@@ -706,7 +720,10 @@
                  (style-properties (part-style d)))
           (let ([p (part-parent d ri)])
             (and p (extract-part-body-id p ri)))))
-    
+
+    (define/public (part-nesting-depth d ri)
+      0)
+
     (define/public (render-one-part d ri fn number)
       (parameterize ([current-output-file fn])
         (let* ([defaults (ormap (lambda (v) (and (html-defaults? v) v))
@@ -730,7 +747,8 @@
                              => (lambda (c)
                                   `(title ,@(format-number number '(nbsp))
                                           ,(content->string (strip-aux c) this d ri)))]
-                            [else `(title)])])
+                            [else `(title)])]
+               [dir-depth (part-nesting-depth d ri)])
           (unless (bytes? style-file)
             (unless (lookup-path style-file alt-paths) 
               (install-file style-file)))
@@ -751,13 +769,15 @@
                    (meta ([http-equiv "content-type"]
                           [content "text/html; charset=utf-8"]))
                    ,title
-                   ,(scribble-css-contents scribble-css (lookup-path scribble-css alt-paths))
+                   ,(scribble-css-contents scribble-css
+                                           (lookup-path scribble-css alt-paths) 
+                                           dir-depth)
                    ,@(map (lambda (style-file)
                             (if (or (bytes? style-file) (url? style-file))
-                                (scribble-css-contents style-file #f)
+                                (scribble-css-contents style-file #f dir-depth)
                                 (let ([p (lookup-path style-file alt-paths)])
                                   (unless p (install-file style-file))
-                                  (scribble-css-contents style-file p))))
+                                  (scribble-css-contents style-file p dir-depth))))
                           (append (extract-part-style-files
                                    d
                                    ri
@@ -766,13 +786,15 @@
                                    css-addition-path)
                                   (list style-file)
                                   style-extra-files))
-                   ,(scribble-js-contents script-file (lookup-path script-file alt-paths))
+                   ,(scribble-js-contents script-file
+                                          (lookup-path script-file alt-paths)
+                                          dir-depth)
                    ,@(map (lambda (script-file)
                             (if (or (bytes? script-file) (url? script-file))
-                                (scribble-js-contents script-file #f)
+                                (scribble-js-contents script-file #f dir-depth)
                                 (let ([p (lookup-path script-file alt-paths)])
                                   (unless p (install-file script-file))
-                                  (scribble-js-contents script-file p))))
+                                  (scribble-js-contents script-file p dir-depth))))
                           (append
                            (extract-part-style-files
                             d
@@ -797,9 +819,6 @@
                        ,@(navigation d ri #f)))
                    (div ([id "contextindicator"]) nbsp))))))))
 
-    (define/private (part-parent d ri)
-      (collected-info-parent (part-collected-info d ri)))
-
     (define (toc-part? d ri)
       (and (part-style? d 'toc)
            ;; topmost part doesn't count as toc, since it
@@ -826,7 +845,7 @@
     (define next-content     '("next " rarr))
     (define sep-element      '(nbsp nbsp))
 
-    (define/public (derive-filename d ci ri) "bad.html")
+    (define/public (derive-filename d ci ri depth) "bad.html")
 
     (define/public (include-navigation?) search-box?)
 
@@ -1594,6 +1613,10 @@
              report-output?
              all-toc-hidden?)
 
+    (define directory-depth 1)
+    (define/override (set-directory-depth n)
+      (set! directory-depth (max 1 n)))
+
     (define/override (get-suffix) #"")
 
     (define/override (get-dest-directory [create? #f])
@@ -1621,23 +1644,34 @@
          (for/list ([p (in-list parents)])
            (or (part-tag-prefix p) "")))))
 
-    (define/override (derive-filename d ci ri)
+    (define/override (part-nesting-depth d ri)
-      (let ([fn (format "~a.html"
+      (min (part-depth d ri) (sub1 directory-depth)))
-                        (regexp-replace*
+
-                         "[^-a-zA-Z0-9_=]"
+    (define/private (part-depth d ri)
-                         (string-append
+      (define p (collected-info-parent (part-collected-info d ri)))
-                          (append-part-prefixes d ci ri)
+      (if (not p)
-                          (let ([s (cadr (car (part-tags/nonempty d)))])
+          0
-                            (cond [(string? s) s]
+          (add1 (part-depth p ri))))
-                                  [(part-title-content d)
+
-                                   (content->string (part-title-content d))]
+    (define/override (derive-filename d ci ri depth)
-                                  [else
+      (let ([base (regexp-replace*
-                                   ;; last-ditch effort to make up a unique name:
+                   "[^-a-zA-Z0-9_=]"
-                                   (format "???~a" (eq-hash-code d))])))
+                   (string-append
-                         "_"))])
+                    (append-part-prefixes d ci ri)
-        (when ((string-length fn) . >= . 48)
+                    (let ([s (cadr (car (part-tags/nonempty d)))])
-          (error "file name too long (need a tag):" fn))
+                      (cond [(string? s) s]
-        fn))
+                            [(part-title-content d)
+                             (content->string (part-title-content d))]
+                            [else
+                             ;; last-ditch effort to make up a unique name:
+                             (format "???~a" (eq-hash-code d))])))
+                   "_")])
+        (let ([fn (if (depth . < . directory-depth)
+                      (path->string (build-path base "index.html"))
+                      (format "~a.html" base))])
+          (when ((string-length fn) . >= . 48)
+            (error "file name too long (need a tag):" fn))
+          fn)))
 
     (define/override (include-navigation?) #t)
 
@@ -1677,12 +1711,13 @@
                        [collecting-whole-page (prev-sub . <= . 1)])
           (if (and (current-part-whole-page? d)
                    (not (eq? d (current-top-part))))
-            (let* ([filename (derive-filename d ci #f)]
+              (let* ([filename (derive-filename d ci #f (length number))]
-                   [full-filename (build-path (path-only (current-output-file))
+                     [full-filename (build-path (path-only (current-output-file))
-                                              filename)])
+                                                filename)])
-              (check-duplicate-filename full-filename)
+                (make-directory* (path-only full-filename))
-              (parameterize ([current-output-file full-filename])
+                (check-duplicate-filename full-filename)
-                (super collect-part d parent ci number sub-init-number)))
+                (parameterize ([current-output-file full-filename])
+                  (super collect-part d parent ci number sub-init-number)))
             (super collect-part d parent ci number sub-init-number)))))
 
     (define/override (render ds fns ri)
@@ -1720,12 +1755,15 @@
           (if (and (on-separate-page-ok)
                    (part-whole-page? d ri)
                    (not (eq? d (current-top-part))))
-            ;; Render as just a link, and put the actual content in a
+            ;; Put the actual content in a new file:
-            ;; new file:
+            (let* ([filename (derive-filename d #f ri (part-depth d ri))]
-            (let* ([filename (derive-filename d #f ri)]
                    [full-path (build-path (path-only (current-output-file))
                                           filename)])
-              (parameterize ([on-separate-page-ok #f])
+              (parameterize ([on-separate-page-ok #f]
+                             [current-subdirectory (let ([p (path-only filename)])
+                                                     (if p
+                                                         (build-path (current-subdirectory) p)
+                                                         (current-subdirectory)))])
                 ;; We use 'replace instead of the usual 'truncate/replace
                 ;;  to avoid problems where a filename changes only in case,
                 ;;  in which case some platforms will see the old file

pkgs/scribble-pkgs/scribble-lib/scribble/render.rkt

@@ -21,6 +21,7 @@
            #:extra-files (listof path-string?)
            #:redirect (or/c #f string?)
            #:redirect-main (or/c #f string?)
+           #:directory-depth exact-nonnegative-integer?
            #:xrefs (listof xref?)
            #:info-in-files (listof path-string?)
            #:info-out-file (or/c #f path-string?)
@@ -38,6 +39,7 @@
                 #:extra-files [extra-files null]
                 #:redirect [redirect #f]
                 #:redirect-main [redirect-main #f]
+                #:directory-depth [directory-depth 0]
                 #:xrefs [xrefs null]
                 #:info-in-files [info-input-files null]
                 #:info-out-file [info-output-file #f]
@@ -55,6 +57,8 @@
       (send renderer set-external-tag-path redirect))
     (when redirect-main
       (send renderer set-external-root-url redirect-main))
+    (unless (zero? directory-depth)
+      (send renderer set-directory-depth directory-depth))
     (unless quiet?
       (send renderer report-output!))
     (let* ([fns (map (lambda (fn)

pkgs/scribble-pkgs/scribble-lib/scribble/run.rkt

@@ -26,6 +26,7 @@
 (define current-extra-files        (make-parameter null))
 (define current-redirect           (make-parameter #f))
 (define current-redirect-main      (make-parameter #f))
+(define current-directory-depth    (make-parameter 0))
 (define current-quiet              (make-parameter #f))
 (define helper-file-prefix         (make-parameter #f))
 
@@ -45,6 +46,17 @@
    [("--htmls") "generate HTML-format output directory"
     (current-html #t)
     (current-render-mixin multi-html:render-mixin)]
+   [("--html-tree") n "generate HTML-format output directories <n> deep"
+    (let ([nv (string->number n)])
+      (unless (exact-nonnegative-integer? nv)
+        (raise-user-error 'scribble
+                          "invalid depth: ~a"
+                          n))
+      (current-directory-depth nv)
+      (current-html #t)
+      (current-render-mixin (if (zero? nv)
+                                html:render-mixin
+                                multi-html:render-mixin)))]
    [("--latex") "generate LaTeX-format output"
     (current-html #f)
     (current-render-mixin latex:render-mixin)]
@@ -137,6 +149,7 @@
           #:helper-file-prefix (helper-file-prefix)
           #:redirect (and (current-html) (current-redirect))
           #:redirect-main (and (current-html) (current-redirect-main))
+          #:directory-depth (current-directory-depth)
           #:quiet? (current-quiet)
           #:info-in-files (reverse (current-info-input-files))
           #:xrefs (for/list ([mod+id (in-list (reverse (current-xref-input-modules)))])