add `codeblock' to Scribble

original commit: aa7c4b53d9c2962536b3a37bb244600d7216289e

collects/scribble/manual.rkt

@@ -2,6 +2,7 @@
 (require "base.ss"
          "private/manual-style.ss"
          "private/manual-scheme.ss"
+         "private/manual-code.ss"
          "private/manual-mod.ss"
          "private/manual-tech.ss"
          "private/manual-bib.ss"
@@ -18,6 +19,7 @@
          (all-from-out "base.ss"
                        "private/manual-style.ss"
                        "private/manual-scheme.ss"
+                       "private/manual-code.ss"
                        "private/manual-mod.ss"
                        "private/manual-tech.ss"
                        "private/manual-bib.ss"

collects/scribble/private/manual-code.rkt

@@ -0,0 +1,194 @@
+#lang racket/base
+(require syntax/strip-context
+         syntax-color/module-lexer
+         "../racket.rkt"
+         "../core.rkt"
+         "../base.rkt"
+         "manual-scheme.rkt"
+         (for-syntax racket/base
+                     syntax/parse))
+
+(provide codeblock
+         typeset-code)
+
+(define-syntax (codeblock stx)
+  (syntax-parse stx
+    [(_ (~seq (~or (~optional (~seq #:expand expand-expr:expr)
+                              #:defaults ([expand-expr #'#f])
+                              #:name "#:expand keyword")
+                   (~optional (~seq #:indent indent-expr:expr)
+                              #:defaults ([indent-expr #'2])
+                              #:name "#:expand keyword")
+                   (~optional (~seq #:keep-lang-line? keep-lang-line?-expr:expr)
+                              #:defaults ([keep-lang-line?-expr #'#t])
+                              #:name "#:keep-lang-line? keyword")
+                   (~optional (~seq #:context context-expr:expr)
+                              #:name "#:context keyword"))
+              ...)
+        str ...)
+     #`(typeset-code str ...
+                     #:expand expand-expr
+                     #:keep-lang-line? keep-lang-line?-expr
+                     #:indent indent-expr
+                     #:context #,(if (attribute context-expr)
+                                     #'context-expr
+                                     (or
+                                      (let ([v #'(str ...)])
+                                        (and (pair? (syntax-e v))
+                                             #`#'#,(car (syntax-e v))))
+                                      #'#f)))]))
+
+(define (typeset-code #:context [context #f]
+                      #:expand [expand #f]
+                      #:indent [indent 2]
+                      #:keep-lang-line? [keep-lang-line? #t]
+                      . strs)
+  (let* ([str (apply string-append strs)]
+         [bstr (string->bytes/utf-8 (regexp-replace* #rx"(?m:^$)" str "\xA0"))]
+         [in (open-input-bytes bstr)])
+    (let* ([tokens
+            (let loop ([mode #f])
+              (let-values ([(lexeme type data start end backup-delta mode)
+                            (module-lexer in 0 mode)])
+                (if (eof-object? lexeme)
+                    null
+                    (cons (list type (sub1 start) (sub1 end) 0)
+                          (loop mode)))))]
+           [substring* (lambda (bstr start [end (bytes-length bstr)])
+                         (bytes->string/utf-8 (subbytes bstr start end)))]
+           [e (parameterize ([read-accept-reader #t])
+                ((or expand 
+                     (lambda (stx) 
+                       (if context
+                           (replace-context context stx)
+                           stx)))
+                 (read-syntax 'prog (open-input-bytes bstr))))]
+           [ids (let loop ([e e])
+                  (cond
+                   [(and (identifier? e)
+                         (syntax-original? e))
+                    (let ([pos (sub1 (syntax-position e))])
+                      (list (list (to-element e)
+                                  pos
+                                  (+ pos (syntax-span e))
+                                  1)))]
+                   [(syntax? e) (append (loop (syntax-e e))
+                                        (loop (or (syntax-property e 'origin)
+                                                  null))
+                                        (loop (or (syntax-property e 'disappeared-use)
+                                                  null)))]
+                   [(pair? e) (append (loop (car e)) (loop (cdr e)))]
+                   [else null]))]
+           [link-mod (lambda (mp-stx priority #:orig? [always-orig? #f])
+                       (if (or always-orig?
+                               (syntax-original? mp-stx))
+                           (let ([mp (syntax->datum mp-stx)]
+                                 [pos (sub1 (syntax-position mp-stx))])
+                             (list (list (racketmodname #,mp)
+                                         pos
+                                         (+ pos (syntax-span mp-stx))
+                                         priority)))
+                           null))]
+           ;; This makes sense when `expand' actually expands, and
+           ;; probably not otherwise:
+           [mods (let loop ([e e])
+                   (syntax-case e (module require begin)
+                     [(module name lang (mod-beg form ...))
+                      (apply append
+                             (link-mod #'lang 2)
+                             (map loop (syntax->list #'(form ...))))]
+                     [(#%require spec ...)
+                      (apply append
+                             (map (lambda (spec)
+                                    ;; Need to add support for renaming forms, etc.:
+                                    (if (module-path? (syntax->datum spec))
+                                        (link-mod spec 2)
+                                        null))
+                                  (syntax->list #'(spec ...))))]
+                     [(begin form ...)
+                      (apply append
+                             (map loop (syntax->list #'(form ...))))]
+                     [else null]))]
+           [language (if (regexp-match? #rx"^#lang " bstr)
+                         (let ([m (regexp-match #rx"^#lang ([-a-zA-Z/._+]+)" bstr)])
+                           (if m
+                               (link-mod
+                                #:orig? #t
+                                (datum->syntax #f
+                                               (string->symbol (bytes->string/utf-8 (cadr m)))
+                                               (vector 'in 1 6 7 (bytes-length (cadr m))))
+                                3)
+                               null))
+                         null)]
+           [tokens (sort (append ids
+                                 mods
+                                 language
+                                 (filter (lambda (x) (not (eq? (car x) 'symbol)))
+                                         ;; Drop #lang entry:
+                                         (cdr tokens)))
+                         (lambda (a b)
+                           (or (< (cadr a) (cadr b))
+                               (and (= (cadr a) (cadr b))
+                                    (> (cadddr a) (cadddr b))))))]
+           [default-color meta-color])
+      (table
+       block-color
+       ((if keep-lang-line? values cdr) ; FIXME: #lang can span lines
+        (list->lines
+         indent
+         (let loop ([pos 0]
+                    [tokens tokens])
+           (cond
+            [(null? tokens) (split-lines default-color (substring* bstr pos))]
+            [(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))]
+            [(= pos (cadar tokens))
+             (append (let ([style (caar tokens)])
+                       (if (symbol? style)
+                           (let ([scribble-style
+                                  (case style
+                                    [(symbol) symbol-color]
+                                    [(parenthesis) paren-color]
+                                    [(constant string) value-color]
+                                    [(comment) comment-color]
+                                    [else default-color])])
+                             (split-lines scribble-style
+                                          (substring* bstr (cadar tokens) (caddar tokens))))
+                           (list (caar tokens))))
+                     (loop (caddar tokens) (cdr tokens)))]
+            [(> pos (cadar tokens))
+             (loop pos (cdr tokens))]
+            [else (append
+                   (split-lines default-color (substring* bstr pos (cadar tokens)))
+                   (loop (cadar tokens) tokens))]))))))))
+
+
+(define (split-lines style s)
+  (cond
+   [(regexp-match-positions #rx"(?:\r\n|\r|\n)" s)
+    => (lambda (m)
+         (list* (element style (substring s 0 (caar m)))
+                'newline
+                (split-lines style (substring s (cdar m)))))]
+   [(regexp-match-positions #rx" +" s)
+    => (lambda (m)
+         (append (split-lines style (substring s 0 (caar m)))
+                 (list (hspace (- (cdar m) (caar m))))
+                 (split-lines style (substring s (cdar m)))))]
+   [else (list (element style s))]))
+
+(define omitable (make-style #f '(omitable)))
+
+(define (list->lines indent-amt l)
+  (define (make-line accum-line) (list (paragraph omitable 
+                                                  (cons indent-elem
+                                                        (reverse accum-line)))))
+  (define indent-elem (hspace indent-amt))
+  (let loop ([l l] [accum-line null])
+    (cond
+     [(null? l) (if (null? accum-line)
+                    null
+                    (list (make-line accum-line)))]
+     [(eq? 'newline (car l))
+      (cons (make-line accum-line)
+            (loop (cdr l) null))]
+     [else (loop (cdr l) (cons (car l) accum-line))])))

collects/scribblings/scribble/how-to-paper.scrbl

@@ -2,9 +2,15 @@
 @(require scribble/manual
           scribble/bnf
           "utils.ss"
-          (for-label scriblib/figure))
+          (for-label scriblib/figure
+                     scribble/base
+                     scribble/sigplan))
 
-@(define (sample . text) (nested #:style 'inset (apply verbatim text)))
+@(define-syntax-rule (samplemod . text) (codeblock . text))
+@(define-syntax-rule (sample a . text) (codeblock #:context #'a 
+                                                  #:keep-lang-line? #f 
+                                                  "#lang scribble/base" "\n" 
+                                                  a . text))
 @(define (result . text) (apply nested #:style 'inset text))
 
 @title[#:tag "getting-started"]{Getting Started}
@@ -18,7 +24,7 @@ goal-specific advice on how to continue.
 
 Create a file @filepath{mouse.scrbl} with this content:
 
-          @sample|{
+          @samplemod|{
             #lang scribble/base
 
             @title{On the Cookie-Eating Habits of Mice}
@@ -65,7 +71,7 @@ for the kind of document that you want as output:
 
 Add more text to @filepath{mouse.scrbl} so that it looks like this:
 
-          @sample|{
+          @samplemod|{
             #lang scribble/base
 
             @title{On the Cookie-Eating Habits of Mice}
@@ -111,7 +117,7 @@ larger document.
 To split the example document into multiple files, change
 @filepath{mouse.scrbl} to just
 
-          @sample|{
+          @samplemod|{
             #lang scribble/base
 
             @title{On the Cookie-Eating Habits of Mice}
@@ -126,7 +132,7 @@ To split the example document into multiple files, change
 Create @filepath{milk.scrbl} and @filepath{straw.scrbl} in the same
 directory as @filepath{mouse.scrbl}. In @filepath{milk.scrbl}, put
 
-         @sample|{
+         @samplemod|{
             #lang scribble/base
 
             @title{The Consequences of Milk}
@@ -136,7 +142,7 @@ directory as @filepath{mouse.scrbl}. In @filepath{milk.scrbl}, put
 
 and in @filepath{straw.scbl}, put
 
-         @sample|{
+         @samplemod|{
             #lang scribble/base
 
             @title{Not the Last Straw}
@@ -167,14 +173,14 @@ the paper to a workshop on programming languages, then---well, you
 probably need a different topic. But you can start making the current
 content look right by changing the first line to
 
-          @sample|{
+          @samplemod|{
             #lang scribble/sigplan
           }|
 
 If you're instead working toward Racket library documentation,
 try changing the first line to 
 
-          @sample|{
+          @samplemod|{
             #lang scribble/manual
           }|
 
@@ -191,7 +197,7 @@ version number---but it changes the set of bindings available in the
 document body. For example, with @racketmodname[scribble/sigplan], the
 introductory text can be marked as an abstract:
 
-          @sample|{
+          @samplemod|{
             #lang scribble/sigplan
 
             @title{On the Cookie-Eating Habits of Mice}
@@ -573,9 +579,9 @@ renders as
 
 because the source is equivalent to
 
-    @sample|{
+    @racketblock[
       (verbatim (number->string (+ 1 2)))
-    }|
+    ]
 
 where @racket[(number->string (+ 1 2))] is evaluated to produce the
 argument to @racket[verbatim]. The @litchar["|{"]...@litchar["}|"]

collects/scribblings/scribble/manual.scrbl

@@ -30,6 +30,60 @@ includes a @racket[latex-defaults] @tech{style property}.
 @; ------------------------------------------------------------------------
 @section[#:tag "scribble:manual:code"]{Typesetting Code}
 
+@defform/subs[(codeblock option ... str-expr ...+)
+              ([option (code:line #:indent indent-expr)
+                       (code:line #:expand expand-expr)
+                       (code:line #:context context-expr)
+                       (code:line #:keep-lang-line? keep-expr)])
+              #:contracts ([indent-expr exact-nonnegative-integer?]
+                           [expand-expr (or/c #f (syntax-object? . -> . syntax-object?))]
+                           [context-expr syntax-object?]
+                           [keep-expr any/c])]{
+
+Parses the code formed by the strings produced by the
+@racket[str-expr]s as a Racket module and produces a @tech{block} that
+typesets the code. The code is indented by the amount specified by
+@racket[indent-expr], which defaults to @racket[2].
+
+When @racket[expand-expr] produces @racket[#f] (which is the default),
+identifiers in the typeset code are colored and linked based on
+for-label bindings in the lexical environment of the syntax object
+provided by @racket[context-expr]. The default @racket[context-expr]
+has the same lexical context as the first @racket[str-expr].
+
+When @racket[expand-expr] produces a procedure, it is used to
+macro-expand the parsed program, and syntax coloring is based on the
+parsed program.
+
+When @racket[keep-lang-line?-expr] produces a true value (the
+default), the @hash-lang[] line in the input is preserved in the
+typeset output, otherwise the first line is dropped.
+
+For example,
+
+@codeblock[#:keep-lang-line? #f]|<|{
+  #lang scribble/manual
+  @codeblock|{
+    #lang scribble/manual
+    @codeblock{
+      #lang scribble/manual
+      @title{Hello}
+    }
+  }|
+}|>|
+
+produces the typeset result
+
+  @codeblock|{
+    #lang scribble/manual
+    @codeblock{
+      #lang scribble/manual
+      @title{Hello}
+    }
+  }|               
+
+}
+
 @defform[(racketblock datum ...)]{
 
 Typesets the @racket[datum] sequence as a table of Racket code inset