Add a Markdown rendering mode to Scribble.

Uses "Github flavored markdown". Specifically, code blocks are opened
using ```scheme so that Github will lex and format them as Scheme code
rather than generic monospace.

Note: I would have used ```racket, but we are still waiting for the
pygments.rb project to pull again from pygments-main -- to which I
contributed a Racket lexer back in August. After pygments.rb pulls,
can update this to use ```racket instead.

original commit: 6aa6dc0400f4fed688e6f5b5278da2e34d82ad88

collects/scribble/markdown-render.rkt

@@ -0,0 +1,225 @@
+#lang racket/base
+(require "core.rkt" "base-render.rkt"
+         racket/class racket/port racket/list racket/string
+         scribble/text/wrap)
+(provide render-mixin)
+
+(define current-preserve-spaces (make-parameter #f))
+
+(define current-indent (make-parameter 0))
+(define (make-indent amt)
+  (+ amt (current-indent)))
+(define (indent)
+  (define i (current-indent))
+  (unless (zero? i) (display (make-string i #\space))))
+(define (indented-newline)
+  (newline)
+  (indent))
+
+(define table-ticks-depth (make-parameter 0))
+(define phrase-ticks-depth (make-parameter 0))
+
+(define (render-mixin %)
+  (class %
+    
+    (define/override (current-render-mode)
+      '(markdown))
+
+    (define/override (get-suffix) #".md")
+
+    (define/override (get-substitutions)
+      '((#rx"---" "\U2014")
+        (#rx"--" "\U2013")
+        (#rx"``" "\U201C")
+        (#rx"''" "\U201D")
+        (#rx"'" "\U2019")))
+
+    (inherit render-block)
+
+    (define/override (render-part d ht)
+      (let ([number (collected-info-number (part-collected-info d ht))])
+        (printf (make-string (add1 (length number)) #\#))
+        (printf " ")
+        (for ([n (in-list (reverse number))] #:when n) (printf "~s." n))
+        (when (part-title-content d)
+          (when (ormap values number) (printf " "))
+          (render-content (part-title-content d) d ht))
+        (when (or (ormap values number) (part-title-content d))
+          (newline)
+          (newline))
+        (render-flow (part-blocks d) d ht #f)
+        (let loop ([pos 1]
+                   [secs (part-parts d)]
+                   [need-newline? (pair? (part-blocks d))])
+          (unless (null? secs)
+            (when need-newline? (newline))
+            (render-part (car secs) ht)
+            (loop (add1 pos) (cdr secs) #t)))))
+
+    (define/override (render-flow f part ht starting-item?)
+      (if (null? f)
+          null
+          (append*
+           (render-block (car f) part ht starting-item?)
+           (for/list ([p (in-list (cdr f))])
+             (indented-newline)
+             (render-block p part ht #f)))))
+
+    (define/override (render-intrapara-block p part ri first? last? starting-item?)
+      (unless first? (indented-newline))
+      (super render-intrapara-block p part ri first? last? starting-item?))
+
+    (define/override (render-table i part ht inline?)
+      (define flowss (table-blockss i))
+      (unless (null? flowss)
+        ;; Set table-ticks-depth prior to render-block calls
+        (define tick? (member (style-name (table-style i))
+                              (list 'boxed "defmodule" "RktBlk")))
+        (when tick?
+          (table-ticks-depth (add1 (table-ticks-depth))))
+        (define strs (map (lambda (flows)
+                            (map (lambda (d)
+                                   (if (eq? d 'cont)
+                                       d
+                                       (let ([o (open-output-string)])
+                                         (parameterize ([current-indent 0]
+                                                        [current-output-port o])
+                                           (render-block d part ht #f))
+                                         (regexp-split
+                                          #rx"\n"
+                                          (regexp-replace #rx"\n$"
+                                                          (get-output-string o)
+                                                          "")))))
+                                 flows))
+                          flowss))
+        (define widths (map (lambda (col)
+                              (for/fold ([d 0]) ([i (in-list col)])
+                                (if (eq? i 'cont)
+                                    0
+                                    (apply max d (map string-length i)))))
+                            (apply map list strs)))
+        (define x-length (lambda (col) (if (eq? col 'cont) 0 (length col))))
+        (when tick?
+          (displayln (string-append "```scheme")))
+        (for/fold ([indent? #f]) ([row (in-list strs)])
+          (let ([h (apply max 0 (map x-length row))])
+            (let ([row* (for/list ([i (in-range h)])
+                          (for/list ([col (in-list row)])
+                            (if (i . < . (x-length col))
+                                (list-ref col i)
+                                "")))])
+              (for/fold ([indent? indent?]) ([sub-row (in-list row*)])
+                (when indent? (indent))
+                (for/fold ([space? #f])
+                    ([col (in-list sub-row)]
+                     [w (in-list widths)])
+                  (let ([col (if (eq? col 'cont) "" col)])
+                    (display (regexp-replace* #rx"\uA0" col " "))
+                    (display (make-string (max 0 (- w (string-length col))) #\space)))
+                  #t)
+                (newline)
+                #t)))
+          #t)
+        (when tick?
+          (displayln "```")
+          (table-ticks-depth (sub1 (table-ticks-depth)))))
+      null)
+
+    (define/override (render-itemization i part ht)
+      (let ([flows (itemization-blockss i)])
+        (if (null? flows)
+            null
+            (append*
+             (begin (printf "* ")
+                    (parameterize ([current-indent (make-indent 2)])
+                      (render-flow (car flows) part ht #t)))
+             (for/list ([d (in-list (cdr flows))])
+               (indented-newline)
+               (printf "* ")
+               (parameterize ([current-indent (make-indent 2)])
+                 (render-flow d part ht #f)))))))
+
+    (define/override (render-paragraph p part ri)
+      (define o (open-output-string))
+      (parameterize ([current-output-port o])
+        (super render-paragraph p part ri))
+      (define to-wrap (regexp-replace* #rx"\n" (get-output-string o) " "))
+      (define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
+      (write-string (car lines))
+      (for ([line (in-list (cdr lines))])
+        (newline) (indent) (write-string line))
+      (newline)
+      null)
+
+    (define/override (render-content i part ri)
+      (define tick?
+        (and (zero? (table-ticks-depth))
+             (element? i)
+             (let ([s (element-style i)])
+               (or (eq? 'tt s)
+                   (and (style? s)
+                        (style-name s)
+                        (regexp-match? #rx"^Rkt[A-Z]" (style-name s)))))))
+      (when tick?
+        (when (zero? (phrase-ticks-depth))
+          (display "`"))
+        (phrase-ticks-depth (add1 (phrase-ticks-depth))))
+      (begin0
+          (if (and (element? i)
+                   (let ([s (element-style i)])
+                     (or (eq? 'hspace s)
+                         (and (style? s)
+                              (eq? 'hspace (style-name s))))))
+              (parameterize ([current-preserve-spaces #t])
+                (super render-content i part ri))
+              (super render-content i part ri))
+        (when tick?
+          (phrase-ticks-depth (sub1 (phrase-ticks-depth)))
+          (when (zero? (phrase-ticks-depth))
+            (display "`")))))
+
+    (define/override (render-nested-flow i part ri starting-item?)
+      (define s (nested-flow-style i))
+      (unless (memq 'decorative (style-properties s))
+        (super render-nested-flow i part ri starting-item?)))
+
+    (define/override (render-other i part ht)
+      (cond
+        [(symbol? i)
+         (display (case i
+                    [(mdash) "\U2014"]
+                    [(ndash) "\U2013"]
+                    [(ldquo) "\U201C"]
+                    [(rdquo) "\U201D"]
+                    [(lsquo) "\U2018"]
+                    [(rsquo) "\U2019"]
+                    [(lang) ">"]
+                    [(rang) "<"]
+                    [(rarr) "->"]
+                    [(nbsp) "\uA0"]
+                    [(prime) "'"]
+                    [(alpha) "\u03B1"]
+                    [(infin) "\u221E"]
+                    [else (error 'markdown-render "unknown element symbol: ~e"
+                                 i)]))]
+        [(string? i)
+         (let* ([i (if (or (not (zero? (phrase-ticks-depth)))
+                           (not (zero? (table-ticks-depth))))
+                       (regexp-replace** i '([#rx"``" . "\U201C"]
+                                             [#rx"''" . "\U201D"]))
+                       (regexp-replace* #px"([#_*`]{1})" i "\\\\\\1"))]
+                [i (if (current-preserve-spaces)
+                       (regexp-replace* #rx" " i "\uA0")
+                       i)])
+           (display i))]
+        [else (write i)])
+      null)
+
+    (super-new)))
+
+(define (regexp-replace** str ptns&reps)
+  (for/fold ([str str])
+            ([ptn (map car ptns&reps)]
+             [rep (map cdr ptns&reps)])
+    (regexp-replace* ptn str rep)))
+

collects/scribble/run.rkt

@@ -4,10 +4,11 @@
          "render.rkt"
          scheme/cmdline
          raco/command-name
-         (prefix-in text:  "text-render.rkt")
+         (prefix-in text:     "text-render.rkt")
-         (prefix-in html:  "html-render.rkt")
+         (prefix-in markdown: "markdown-render.rkt")
-         (prefix-in latex: "latex-render.rkt")
+         (prefix-in html:     "html-render.rkt")
-         (prefix-in pdf:   "pdf-render.rkt"))
+         (prefix-in latex:    "latex-render.rkt")
+         (prefix-in pdf:      "pdf-render.rkt"))
 
 (define multi-html:render-mixin
   (lambda (%) (html:render-multi-mixin (html:render-mixin %))))
@@ -54,6 +55,8 @@
       (current-render-mixin (latex:make-render-part-mixin v)))]
    [("--text") "generate text-format output"
     (current-render-mixin text:render-mixin)]
+   [("--markdown") "generate markdown-format output"
+    (current-render-mixin markdown:render-mixin)]
    #:once-each
    [("--dest") dir "write output in <dir>"
     (current-dest-directory dir)]

collects/scribblings/scribble/renderer.scrbl

@@ -101,6 +101,7 @@ current error port.}
 @racketmodname[scribble/base-render] module provides @racket[render%],
 which implements the core of a renderer. This rendering class must be
 refined with a mixin from @racketmodname[scribble/text-render],
+@racketmodname[scribble/markdown-render], or
 @racketmodname[scribble/html-render], or
 @racketmodname[scribble/latex-render].}
 
@@ -289,6 +290,21 @@ Specializes a @racket[render<%>] class for generating plain text.}}
 
 @; ----------------------------------------
 
+@section{Markdown Renderer}
+
+@defmodule/local[scribble/markdown-render]{
+
+@defmixin[render-mixin (render<%>) ()]{
+
+Specializes a @racket[render<%>] class for generating Markdown text.
+
+Code blocks are marked using the
+@hyperlink["http://github.github.com/github-flavored-markdown/"
+"Github convention"] @verbatim{```scheme} so that they are lexed and
+formatted as Scheme code.}}
+
+@; ----------------------------------------
+
 @section{HTML Renderer}
 
 @defmodule/local[scribble/html-render]{

collects/scribblings/scribble/running.scrbl

@@ -40,6 +40,9 @@ its file suffix:
  @item{@DFlag{text} --- plain text in a single file
        @filepath{@|fn|.txt}, with non-ASCII content encoded as UTF-8}
 
+ @item{@DFlag{markdown} --- Markdown text in a single file
+       @filepath{@|fn|.md}, with non-ASCII content encoded as UTF-8}
+
 ]
 
 Use @DFlag{dest-name} to specify a @|fn| other than the default name,

collects/tests/scribble/main.rkt

@@ -2,7 +2,7 @@
 
 (require tests/eli-tester
          "reader.rkt" "text-collect.rkt" "text-lang.rkt" "text-wrap.rkt"
-         "docs.rkt" "render.rkt" "xref.rkt")
+         "docs.rkt" "render.rkt" "xref.rkt" "markdown.rkt")
 
 (test do (reader-tests)
       do (begin/collect-tests)
@@ -10,4 +10,5 @@
       do (wrap-tests)
       do (docs-tests)
       do (render-tests)
-      do (xref-tests))
+      do (xref-tests)
+      do (markdown-tests))

collects/tests/scribble/markdown-docs/example.md

@@ -0,0 +1,43 @@
+# ```scheme
+ (require racket/string)
+```
+
+* Item 1.
+
+* Item 2.
+
+## 1. Section
+
+Italic. \_Just underlines\_.
+
+Bold. \*Just asterisks.\*
+
+“Dobule quoted”. ‘Single quoted’.
+
+`Hi, world.`  
+`A “quote”.`  
+`Second line.`
+`Last line.`  
+
+The end.
+
+`THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS`   
+`“AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT`     
+`LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR` 
+`A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT`  
+`HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,`
+`SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT`      
+`LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,` 
+`DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY` 
+`THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT`   
+`(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE` 
+`OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.`  
+
+```scheme
+(make-string k [char]) -> string?
+  k : exact-nonnegative-integer? 
+  char : char? = #\nul           
+```
+
+Returns a new mutable string of length `k` where each position in the
+string is initialized with the character `char`

collects/tests/scribble/markdown-docs/example.scrbl

@@ -0,0 +1,52 @@
+#lang scribble/doc
+
+@(require scribble/manual
+          (for-label racket/base racket/contract racket/string))
+
+@defmodule[racket/string]
+
+@itemize[
+@item{Item 1.}
+@item{Item 2.}
+]
+
+@section{Section}
+
+@italic{Italic}.
+_Just underlines_.
+
+@bold{Bold}.
+*Just asterisks.*
+
+``Dobule quoted''.
+`Single quoted'.
+
+@verbatim{
+Hi, world.
+A ``quote''.
+Second line.
+Last line.
+}
+
+The end.
+
+@verbatim{
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+}
+
+@defproc[(make-string [k exact-nonnegative-integer?][char char? #\nul]) string?]{
+
+Returns a new mutable string of length @racket[k] where each position in the
+string is initialized with the character @racket[char]
+
+}

collects/tests/scribble/markdown.rkt

@@ -0,0 +1,53 @@
+#lang racket/base
+
+;; Use text renderer to check some Scribble functionality
+
+(require scribble/base-render (prefix-in markdown: scribble/markdown-render)
+         racket/file racket/class racket/runtime-path tests/eli-tester)
+
+(define-runtime-path source-dir "markdown-docs")
+(define work-dir (build-path (find-system-path 'temp-dir)
+                             "scribble-docs-tests"))
+
+(define (build-markdown-doc src-file dest-file)
+  (let* ([renderer (new (markdown:render-mixin render%) [dest-dir work-dir])]
+         [docs     (list (dynamic-require src-file 'doc))]
+         [fns      (list (build-path work-dir dest-file))]
+         [fp       (send renderer traverse docs fns)]
+         [info     (send renderer collect  docs fns fp)]
+         [r-info   (send renderer resolve  docs fns info)])
+    (send renderer render docs fns r-info)
+    (send renderer get-undefined r-info)))
+
+(provide markdown-tests)
+(module+ main (markdown-tests))
+(define (markdown-tests)
+  (when (or (file-exists? work-dir) (directory-exists? work-dir))
+    (delete-directory/files work-dir))
+  (dynamic-wind
+    (λ() (make-directory work-dir))
+    (λ()
+      (define files (map path-element->string (directory-list source-dir)))
+      (test do
+        (for ([scrbl (in-list files)]
+              #:when (regexp-match? #rx"\\.scrbl$" scrbl)
+              [md    (in-value (regexp-replace #rx"\\.scrbl$" scrbl ".md"))]
+              #:when (member md files))
+          ;; (printf "Testing ~s -> ~s\n" scrbl md)
+          (define src-file (build-path source-dir scrbl))
+          (define expect-file (build-path source-dir md))
+          (define generated-file (build-path work-dir "gen.md"))
+          (define (contents file)
+            (regexp-replace #rx"\n+$" (file->string file) ""))
+          (define undefineds (build-markdown-doc src-file "gen.md"))
+          (for ([u (in-list undefineds)])
+            (when (eq? 'tech (car u))
+              (test #:failure-message
+                    (format "undefined tech: ~e" u)
+                    #f)))
+          (test #:failure-message
+                (format
+                 "mismatch for: \"~a\", expected text in: \"~a\", got:\n~a"
+                 scrbl md (contents generated-file))
+                (string=? (contents expect-file) (contents generated-file))))))
+    (λ() (delete-directory/files work-dir))))