add traverse-part and cond-part

Enable selection of document parts (not just blocks and elements) at
traverse time.

This adition requires a small extra pass between the traverse pass and
collects pass as reflected by the `traversed-parts` method of a
renderer. The extra pass is only needed (i.e., things work if it is
omitted) if `traverse-part` is not used.

Author: mflatt

scribble-doc/scribblings/scribble/core.scrbl

@@ -31,8 +31,9 @@ A document is processed in four passes:
        document order so that information from one part of a document
        can be communicated to other parts of the same document. The
        information is transmitted through a symbol-keyed mapping that
-       can be inspected and extended by @racket[traverse-element]s and
-       @racket[traverse-block]s in the document. The @tech{traverse
+       can be inspected and extended by @racket[traverse-element]s,
+       @racket[traverse-block]s, and @racket[traverse-part]s in the
+       document. The @tech{traverse
        pass} iterates the traversal until it obtains a fixed point
        (i.e., the mapping from one iteration is unchanged from the
        previous iteration).}
@@ -52,11 +53,12 @@ A document is processed in four passes:
 None of the passes mutate the document representation. Instead, the
  @tech{traverse pass}, @tech{collect pass}, and @tech{resolve pass}
  accumulate information in a side hash table, @racket[collect-info]
- table, and @racket[resolve-info] table. The @tech{collect pass} and
- @tech{resolve pass} are effectively specialized version of
- @tech{traverse pass} that work across separately built documents.
+ table, and @racket[resolve-info] table, except that
+ @racket[traverse-part]s are replaced just after the traverse pass
+ by rebuilding enclosing @racket[part] structures. The collect pass and
+ resolve pass are effectively specialized version of
+ traverse pass that work across separately built documents.
 
- 
 @; ------------------------------------------------------------------------
 
 @section[#:tag "parts"]{Parts, Flows, Blocks, and Paragraphs}
@@ -386,7 +388,7 @@ value that has been accumulated from enclosing parts.
                  [style style?]
                  [to-collect list?]
                  [blocks (listof block?)]
-                 [parts (listof part?)])]{
+                 [parts (listof (or/c part? traverse-part?))])]{
 
 The @racket[tag-prefix] field determines the optional @techlink{tag
 prefix} for the part and/or @techlink{part context} accumulation. When
@@ -611,7 +613,9 @@ passes (i.e., it doesn't directly contribute to the output).
 The @racket[blocks] field contains the part's initial flow (before
 sub-parts).
 
-The @racket[parts] field contains sub-parts.
+The @racket[parts] field contains sub-parts. A @racket[traverse-part]
+within @racket[parts] is converted to a replacement list of
+@racket[part]s just after the @tech{traverse pass}.
 
 @history[#:changed "1.25" @elem{Added @racket['no-index] support.}
          #:changed "1.26" @elem{Added @racket[link-render-style] support.}
@@ -621,7 +625,27 @@ The @racket[parts] field contains sub-parts.
          #:changed "1.57" @elem{Added @racket['no-header-controls] support.}
          #:changed "1.59" @elem{Added @racket['no-navigation],
                                 @racket['family-navigation], and
-                                @racket['show-language-family] support.}]}
+                                @racket['show-language-family] support.}
+         #:changed "1.67" @elem{Added @racket[traverse-part?] as a possible
+                                contract on an element in @racket[parts] list.}]}
+
+
+@defstruct[traverse-part ([traverse part-traverse-procedure/c])]{
+
+Produces a replacement list of parts (possibly empty) during the
+@tech{traverse pass}, eventually.
+
+The @racket[traverse] procedure is called with @racket[_get] and
+@racket[_set] procedures to get and set symbol-keyed information; the
+@racket[traverse] procedure should return either a list of
+@tech{parts} (which effectively takes the @racket[traverse-part]'s
+place) or a procedure like @racket[traverse] to be called in the next
+iteration of the @tech{traverse pass}.
+
+See @racket[traverse-block] for more information that applies to
+@racket[traverse-part], too.
+
+@history[#:added "1.67"]}
 
 
 @defstruct[paragraph ([style style?] [content content?])]{
@@ -1809,6 +1833,18 @@ Produces the block that replaces @racket[b].}
 Produces the content that replaces @racket[e].}
 
 
+@defthing[part-traverse-procedure/c contract?]{
+
+Defined as
+
+@racketblock[
+  (recursive-contract
+   ((symbol? any/c . -> . any/c)
+    (symbol? any/c . -> . any)
+    . -> . (or/c part-traverse-procedure/c
+                 (listof part?))))
+]}
+
 @defthing[block-traverse-procedure/c contract?]{
 
 Defined as

scribble-doc/scribblings/scribble/decode.scrbl

@@ -72,7 +72,7 @@ by functions like @racket[decode-flow].}
 
 Returns @racket[#t] if @racket[v] is a @deftech{pre-part} value: a
 string or other non-list @tech{content}, a @tech{block}, a
-@racket[part], a @racket[title-decl], a @racket[part-start], a
+@racket[part], a @racket[title-decl], a @racket[part-start], a @racket[traverse-part], a
 @racket[part-index-decl], a @racket[part-collect-decl], a
 @racket[part-tag-decl], @|void-const|, a list of @tech{pre-part} values, or a @racket[splice] containing
 a list of @tech{pre-part} values; otherwise returns @racket[#f].

scribble-doc/scribblings/scribble/renderer.scrbl

@@ -383,6 +383,20 @@ A renderer for a specific format is relatively unlikely to override
 any of these methods. Each method accepts the information accumulated
 so far and returns augmented information as a result.}
 
+@defmethod[(traversed-parts [parts (listof part?)]
+                            [fp (and/c hash? immutable?)])
+           (listof part?)]
+@defmethod[(traversed-parts-part [part part?]
+                                 [fp (and/c hash? immutable?)])
+           part?]{
+
+The @method[render% traversed-parts] method replaces
+@racket[traverse-part]s in the sub-parts of @racket[parts]
+(transitively) with replacement @racket[part]s. The result list has
+the same item as @racket[parts] unmodified for each part that has no
+@racket[traverse-part]s.
+
+@history[#:added "1.67"]}
 
 @defmethod[(collect [parts (listof part?)]
                     [dests (listof path-string?)]

scribble-doc/scriblib/scribblings/render-cond.scrbl

@@ -15,15 +15,15 @@ output, use styles plus ``back end'' configurations for each target
 format (see @secref[#:doc scribble-doc "config"] in
 @other-manual[scribble-doc]).
 
-As a last resort, the @racket[cond-element] and @racket[cond-block]
+As a last resort, the @racket[cond-element], @racket[cond-block], and @racket[cond-part]
 forms support varying the document content depending on the target
 format. More precisely, they generate parts of a document where
 content is delayed until the @tech[#:doc scribble-doc]{traverse pass}
 of document rendering. Format detection relies on the
 @racket['scribble:current-render-mode] registration that is accessible
 through a @racket[traverse-element] or @racket[traverse-block].
 
-The syntax of @racket[cond-element] and @racket[cond-block] is based
+The syntax of @racket[cond-element], @racket[cond-block], and @racket[cond-part] is based
 on SRFI-0.
 
 @defform*/subs[#:literals (and or not else)
@@ -60,4 +60,11 @@ Like @racket[cond-element], but generates a @racket[traverse-block]
 where the selected @racket[body] must produce a block according to
 @racket[block?].}
 
+@defform*[[(cond-part [feature-requirement body ...+])
+           (cond-part [feature-requirement body ...+] [else body ...+])]]{
 
+Like @racket[cond-element], but generates a @racket[traverse-part]
+where the selected @racket[body] must produce a list parts according to
+@racket[part?].
+
+@history[#:added "1.67"]}

scribble-lib/info.rkt

@@ -21,7 +21,7 @@
 
 (define pkg-authors '(mflatt eli))
 
-(define version "1.66")
+(define version "1.67")
 
 (define license
   '((Apache-2.0 OR MIT)

scribble-lib/scribble/base-render.rkt

@@ -458,7 +458,15 @@
              [fp (traverse-content (part-to-collect d) fp)]
              [fp (traverse-flow (part-blocks d) fp)])
         (for/fold ([fp fp]) ([p (in-list (part-parts d))])
-          (traverse-part p fp))))
+          (cond
+            [(traverse-part? p)
+             (traverse-force fp p
+                             (traverse-part-traverse p)
+                             (lambda (ps fp)
+                               (for/fold ([fp fp]) ([p (in-list ps)])
+                                 (traverse-part p fp))))]
+            [else
+             (traverse-part p fp)]))))
 
     (define/public (traverse-paragraph p fp)
       (traverse-content (paragraph-content p) fp))
@@ -527,6 +535,32 @@
             (let ([fp (hash-set fp p v2)]) (if (procedure? v2) fp (again v2 fp))))
           fp))
 
+    ;; ----------------------------------------
+    ;; replace `traverse-part`s with `part`s
+
+    (define/public (traversed-parts ds fp)
+      (for/list ([d (in-list ds)])
+        (traversed-parts-part d fp)))
+
+    (define/public (traversed-parts-part d fp)
+      (define ps
+        (apply
+         append
+         (for/list ([p (in-list (part-parts d))])
+           (cond
+             [(traverse-part? p)
+              (or (hash-ref fp p #f)
+                  (error 'traverse-part-parts "no part computed for traverse-part: ~e" p))]
+             [else
+              (list p)]))))
+      (if (and (= (length ps) (length (part-parts d)))
+               (ormap eq? ps (part-parts d)))
+          d
+          (struct-copy part
+                       d
+                       [parts (for/list ([p (in-list ps)])
+                                (traversed-parts-part p fp))])))
+
     ;; ----------------------------------------
     ;; global-info collection
 
@@ -727,7 +761,7 @@
       (collect-put! ci
                     t
                     ;; See "INFO SHAPE" above.
-                    (vector (element-content i) (add-current-tag-prefix t))))
+                    (vector (element-content i) (add-current-tag-prefix t) #f)))
 
     (define/public (collect-index-element i ci)
       (collect-put! ci

scribble-lib/scribble/core.rkt

@@ -245,6 +245,10 @@
                   hash?
                   . -> . (values part-number-item? hash?))]))
 
+;; Traverse part is not serializable, because it's
+;; replaced away after the traverse step
+(define-struct traverse-part (traverse))
+
 ;; ----------------------------------------
 
 (provide-structs
@@ -254,7 +258,7 @@
         [style style?]
         [to-collect list?]
         [blocks (listof block?)]
-        [parts (listof part?)])]
+        [parts (listof (or/c part? traverse-part?))])]
  [paragraph ([style style?]
              [content content?])]
  [table ([style style?]
@@ -369,6 +373,18 @@
 
 ;; ----------------------------------------
 
+(define part-traverse-procedure/c
+  (recursive-contract
+   ((symbol? any/c . -> . any/c)
+    (symbol? any/c . -> . any)
+    . -> . (or/c part-traverse-procedure/c
+                 (listof part?)))))
+
+(provide part-traverse-procedure/c)
+(provide (contract-out (struct traverse-part ([traverse part-traverse-procedure/c]))))
+
+;; ----------------------------------------
+
 ;; Traverse element has special serialization support:
 (define-struct traverse-element (traverse)
   #:property

scribble-lib/scribble/decode.rkt

@@ -34,6 +34,7 @@
       (part-collect-decl? v)
       (part-tag-decl? v)
       (part? v)
+      (traverse-part? v)
       (and (splice? v)
            (andmap pre-part? (splice-run v)))
       (and (list? v)
@@ -218,7 +219,8 @@
           (part-to-collect part)
           (append para (list (car l)) (part-flow part))
           (part-parts part)))]
-      [(part? (car l))
+      [(or (part? (car l))
+           (traverse-part? (car l)))
        (let ([para (decode-accum-para accum)]
              [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
                                  title index-desc part-depth)])
@@ -242,7 +244,8 @@
            (if (or (null? l)
                    (and (part-start? (car l))
                         ((part-start-depth (car l)) . <= . part-depth))
-                   (part? (car l)))
+                   (part? (car l))
+                   (traverse-part? (car l)))
              (let ([para (decode-accum-para accum)]
                    [s (decode-styled-part (reverse s-accum)
                                           (part-start-tag-prefix s)

scribble-lib/scribble/render.rkt

@@ -77,20 +77,21 @@
                    fn))))
          names))
   (define fp (send renderer traverse docs fns))
-  (define info (send renderer collect docs fns fp))
-  (for ([file (in-list info-input-files)])
-    (let ([s (with-input-from-file file read)]) (send renderer deserialize-info s info)))
-  (for ([xr (in-list xrefs)])
-    (xref-transfer-info renderer info xr))
-  (let ([r-info (send renderer resolve docs fns info)])
-    (send renderer render docs fns r-info)
-    (when info-output-file
-      (let ([s (send renderer serialize-info r-info)])
-        (with-output-to-file info-output-file #:exists 'truncate/replace (lambda () (write s)))))
-    (when warn-undefined?
-      (let ([undef (send renderer get-undefined r-info)])
-        (unless (null? undef)
-          (eprintf "Warning: some cross references may be broken due to undefined tags:\n")
-          (for ([t (in-list undef)])
-            (eprintf " ~s\n" t))))))
+  (let ([docs (send renderer traversed-parts docs fp)]) ; no `traverse-part`s after this step
+    (define info (send renderer collect docs fns fp))
+    (for ([file (in-list info-input-files)])
+      (let ([s (with-input-from-file file read)]) (send renderer deserialize-info s info)))
+    (for ([xr (in-list xrefs)])
+      (xref-transfer-info renderer info xr))
+    (let ([r-info (send renderer resolve docs fns info)])
+      (send renderer render docs fns r-info)
+      (when info-output-file
+        (let ([s (send renderer serialize-info r-info)])
+          (with-output-to-file info-output-file #:exists 'truncate/replace (lambda () (write s)))))
+      (when warn-undefined?
+        (let ([undef (send renderer get-undefined r-info)])
+          (unless (null? undef)
+            (eprintf "Warning: some cross references may be broken due to undefined tags:\n")
+            (for ([t (in-list undef)])
+              (eprintf " ~s\n" t)))))))
   (void))

scribble-lib/scriblib/render-cond.rkt

@@ -3,7 +3,8 @@
          (for-syntax racket/base))
 
 (provide cond-element
-         cond-block)
+         cond-block
+         cond-part)
 
 (define-for-syntax (render-cond stx mk check-result no-matching-case)
   (syntax-case stx ()
@@ -42,12 +43,23 @@
                  ...
                  [else (no-matching-case)]))))))]))
 
+(define-syntax (cond-part stx)
+  (render-cond stx #'traverse-part #'check-part #'no-part-case))
+
 (define-syntax (cond-block stx)
   (render-cond stx #'traverse-block #'check-block #'no-block-case))
 
 (define-syntax (cond-element stx)
   (render-cond stx #'traverse-element #'check-content #'no-element-case))
 
+(define (check-part v)
+  (unless (and (list? v) (andmap part? v))
+    (raise-mismatch-error
+     'cond-part
+     "clause result is not a list of parts: "
+     v))
+  v)
+
 (define (check-block v)
   (unless (block? v)
     (raise-mismatch-error
@@ -64,9 +76,14 @@
      v))
   v)
 
+(define (no-part-case)
+  (raise (make-exn:fail:contract
+          "cond-part: no clause matched"
+          (current-continuation-marks))))
+
 (define (no-block-case)
   (raise (make-exn:fail:contract
-          "cond-element: no clause matched"
+          "cond-block: no clause matched"
           (current-continuation-marks))))
 
 (define (no-element-case)