commit d6b3461aad1940c2370243bce3b3b14bc24fdece
parent 688bb59c1ac8bea389eb9a961856c7a601ef42f9
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 31 Oct 2010 07:07:57 -0600
add `codeblock' to Scribble
original commit: aa7c4b53d9c2962536b3a37bb244600d7216289e
Diffstat:
4 files changed, 269 insertions(+), 13 deletions(-)
diff --git a/collects/scribble/manual.rkt b/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"
diff --git a/collects/scribble/private/manual-code.rkt b/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))])))
diff --git a/collects/scribblings/scribble/how-to-paper.scrbl b/collects/scribblings/scribble/how-to-paper.scrbl
@@ -2,9 +2,15 @@
@(require scribble/manual
scribble/bnf
"utils.ss"
- (for-label scriblib/figure))
-
-@(define (sample . text) (nested #:style 'inset (apply verbatim text)))
+ (for-label scriblib/figure
+ scribble/base
+ scribble/sigplan))
+
+@(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["}|"]
diff --git a/collects/scribblings/scribble/manual.scrbl b/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
