Scribble: simplify content that is conditioned on the render mode

including a new `scriblib/render-cond' library

original commit: df2a875ff4aaff90b20906a80dff6218470eb455

collects/scribble/base-render.rkt

@@ -24,6 +24,9 @@
                 [style-extra-files null]
                 [extra-files null])
 
+    (define/public (current-render-mode)
+      '())
+
     (define/public (get-dest-directory [create? #f])
       (when (and dest-dir create? (not (directory-exists? dest-dir)))
         (make-directory* dest-dir))
@@ -306,14 +309,21 @@
           (traverse-content c fp))]
        [else fp]))
 
-    (define (traverse-force fp p proc again)
+    (define/private (traverse-force fp p proc again)
       (let ([v (hash-ref fp p (lambda () proc))])
         (if (procedure? v)
             (let ([fp fp])
               (let ([v2 (v (lambda (key default)
-                             (hash-ref fp key default))
+                             (if (eq? key 'scribble:current-render-mode)
+                                 (current-render-mode)
+                                 (hash-ref fp key default)))
                            (lambda (key val)
-                             (set! fp (hash-set fp key val))))])
+                             (if (eq? key 'scribble:current-render-mode)
+                                 (raise-mismatch-error 
+                                  'traverse-info-set! 
+                                  "cannot set value for built-in key: "
+                                  key)
+                                 (set! fp (hash-set fp key val)))))])
                 (let ([fp (hash-set fp p v2)])
                   (if (procedure? v2)
                       fp

collects/scribble/html-render.rkt

@@ -199,6 +199,9 @@
                 [script-file #f]
                 [search-box? #f])
 
+    (define/override (current-render-mode)
+      '(html))
+
     (define/override (get-suffix) #".html")
 
     (define/override (index-manual-newlines?)

collects/scribble/latex-render.rkt

@@ -38,6 +38,9 @@
   (class %
     (inherit-field prefix-file style-file style-extra-files)
 
+    (define/override (current-render-mode)
+      '(latex))
+
     (define/override (get-suffix) #".tex")
 
     (inherit render-block

collects/scribble/text-render.rkt

@@ -28,6 +28,9 @@
   (define (render-mixin %)
     (class %
       
+      (define/override (current-render-mode)
+        '(text))
+
       (define/override (get-substitutions)
         '((#rx"---" "\U2014")
 	  (#rx"--" "\U2013")

collects/scribblings/scribble/core.scrbl

@@ -2,7 +2,9 @@
 @(require scribble/manual
           "utils.ss"
           (for-label scribble/manual-struct
-                     setup/main-collects))
+                     file/convertible
+                     setup/main-collects
+                     scriblib/render-cond))
 
 @title[#:tag "core"]{Structures And Processing}
 
@@ -610,15 +612,34 @@ for Latex output (see @secref["extra-style"]). The following
 @defstruct[traverse-block ([traverse block-traverse-procedure/c])]{
 
 Produces another block during the @tech{traverse pass}, eventually.
-The @scheme[traverse] procedure is called with procedures to get and
+
-set symbol-keyed information, and it should return either a
+The @scheme[traverse] procedure is called with @racket[_get] and
-@tech{block} (which effectively takes the @racket[traverse-block]'s
+@racket[_set] procedures to get and set symbol-keyed information; the
-place) or a procedure like @racket[traverse] to be called in the next
+@racket[traverse] procedure should return either a @tech{block} (which
-iteration of the @tech{traverse pass}.
+effectively takes the @racket[traverse-block]'s place) or a procedure
+like @racket[traverse] to be called in the next iteration of the
+@tech{traverse pass}.
 
 All @racket[traverse-element] and @racket[traverse-block]s that have
 not been replaced are forced in document order relative to each other
-during an iteration of the @tech{traverse pass}.}
+during an iteration of the @tech{traverse pass}.
+
+The @racket[_get] procedure passed to @scheme[traverse] takes a symbol
+and any value to act as a default; it returns information registered
+for the symbol or the given default if no value has been
+registered. The @racket[_set] procedure passed to @scheme[traverse]
+takes a symbol and a value to registered for the symbol.
+
+@margin-note*{See also @racket[cond-block] in @racketmodname[scriblib/render-cond].}
+@;
+The symbol @indexed-racket['scribble:current-render-mode] is
+automatically registered to a list of symbols that describe the
+target of document rendering. The list contains @racket['html]
+when rendering to HTML, @racket['latex] when rendering via Latex, and
+@racket['text] when rendering to text. The registration of
+@racket['scribble:current-render-mode] cannot be changed via
+@racket[_set].}
+
 
 @defstruct[delayed-block ([resolve (any/c part? resolve-info? . -> . block?)])]{
 
@@ -810,6 +831,8 @@ in curly braces) as elements of @racket[content].}
 
 @defstruct[traverse-element ([traverse element-traverse-procedure/c])]{
 
+@margin-note*{See also @racket[cond-element] in @racketmodname[scriblib/render-cond].}
+@;
 Like @racket[traverse-block], but the @racket[traverse] procedure must
 eventually produce @tech{content}, rather than a @tech{block}.}
 

collects/scriblib/render-cond.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+(require scribble/core
+         (for-syntax racket/base))
+
+(provide cond-element
+         cond-block)
+
+(define-for-syntax (render-cond stx mk check-result no-matching-case)
+  (syntax-case stx ()
+    [(_ [test body0 body ...] ...)
+     (let ([tests (syntax->list #'(test ...))])
+       (with-syntax ([(test-expr ...)
+                      (for/list ([test (in-list tests)]
+                                 [pos (in-naturals)])
+                        (let loop ([test test])
+                          (syntax-case test (else and or not)
+                            [else
+                             (unless (= pos (sub1 (length tests)))
+                               (raise-syntax-error
+                                #f
+                                "found `else' not in last clause"
+                                stx
+                                test))
+                             #'#t]
+                            [(and test ...)
+                             #`(and . #,(map loop (syntax->list #'(test ...))))]
+                            [(or test ...)
+                             #`(or . #,(map loop (syntax->list #'(test ...))))]
+                            [(not test)
+                             #`(not #,(loop #'test))]
+                            [id
+                             (identifier? #'id)
+                             #'(memq 'id mode)])))]
+                     [mk mk]
+                     [check-result check-result]
+                     [no-matching-case no-matching-case])
+         #'(mk
+            (lambda (get put)
+              (let ([mode (get 'scribble:current-render-mode 'text)])
+                (cond
+                 [test-expr (check-result (let () body0 body ...))]
+                 ...
+                 [else (no-matching-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-block v)
+  (unless (block? v)
+    (raise-mismatch-error
+     'cond-block
+     "clause result is not a block: "
+     v))
+  v)
+
+(define (check-content v)
+  (unless (content? v)
+    (raise-mismatch-error
+     'cond-element
+     "clause result is not content: "
+     v))
+  v)
+
+(define (no-block-case)
+  (raise (make-exn:fail:contract
+          "cond-element: no clause matched"
+          (current-continuation-marks))))
+
+(define (no-element-case)
+  (raise (make-exn:fail:contract
+          "cond-element: no clause matched"
+          (current-continuation-marks))))

collects/scriblib/scribblings/render-cond.scrbl

@@ -0,0 +1,63 @@
+#lang scribble/manual
+@(require (for-label scribble/core
+                     racket/base
+                     scriblib/render-cond))
+
+@(define scribble-doc '(lib "scribblings/scribble/scribble.scrbl"))
+
+@title[#:tag "render-cond"]{Conditional Content}
+
+@defmodule[scriblib/render-cond]
+
+As much as possible, Scribble documents should be independent of the
+target format for rendering the document. To customize generated
+output, use styes 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]
+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
+on SRFI-0.
+
+@defform*/subs[#:literals (and or not else)
+               [(cond-element [feature-requirement body ...+])
+                (cond-element [feature-requirement body ...+] [else body ...+])]
+               ([feature-requirement identifier
+                                     (not feature-requirement)
+                                     (and feature-requirement ...)
+                                     (or feature-requirement ...)])]{
+
+Generates a @racket[traverse-element] whose replacement content is
+produced by the @racket[body] of one of the first matching
+@racket[cond-element] clause.
+
+A @racket[feature-requirement] can be any identifier; a useful
+identifier is one whose symbol form can appear in a
+@racket['scribble:current-render-mode] list. The identifier matches
+when its symbol form is in the @racket['scribble:current-render-mode]
+list.  Typically, the identifier is @racket[html], @racket[latex], or
+@racket[text] to indicate the corresponding rendering target.
+
+A @racket[(not feature-requirement)] test matches when
+@racket[feature-requirement] does not match, and so on. An
+@racket[else] clause always matches. If no @racket[else] clause is
+present and no clause matches, then the @racket[exn:fail:contract]
+exception is raised. Similarly, if the result of the selected
+@racket[body] is not content according to @racket[content?], then the
+@racket[exn:fail:contract] exception is raised.}
+
+@defform*[[(cond-block [feature-requirement body ...+])
+           (cond-block [feature-requirement body ...+] [else body ...+])]]{
+
+Like @racket[cond-element], but generates a @racket[traverse-block]
+where the selected @racket[body] must produce a block according to
+@racket[block?].}
+
+

collects/scriblib/scribblings/scriblib.scrbl

@@ -8,3 +8,4 @@
 @include-section["figure.scrbl"]
 @include-section["autobib.scrbl"]
 @include-section["footnote.scrbl"]
+@include-section["render-cond.scrbl"]

collects/tests/scribble/docs/cond.scrbl

@@ -0,0 +1,19 @@
+#lang scribble/base
+@(require scriblib/render-cond)
+
+@(cond-element
+  [text "Text!"]
+  [html "HTML!"]
+  [latex "Latex!"])
+
+@(cond-element
+  [(or text html) "Text or HTML!"]
+  [else "Latex!"])
+
+@(cond-element
+  [(and text html) "Text and HTML?!"]
+  [else "Other!"])
+
+@(cond-element
+  [(not text) "Not Text!"]
+  [else "Text!"])

collects/tests/scribble/docs/cond.txt

@@ -0,0 +1,7 @@
+Text!
+
+Text or HTML!
+
+Other!
+
+Text!