commit 72ee384f64f70fa2eb56a14033bafb014563baef
parent da1bfdad733373dd6b3041946190c9799c96b171
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 30 May 2007 03:10:57 +0000
revised 'for' and docs
svn: r6400
original commit: c59c7ebab760505fc3215b4c58a823617df0bb0d
Diffstat:
3 files changed, 76 insertions(+), 59 deletions(-)
diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss
@@ -46,16 +46,39 @@
(if (flow? p)
p
(make-flow (list p))))))
- (append
- (if (string? (car val-list+outputs))
- (map
- (lambda (s)
- (list (make-flow (list (make-paragraph
- (list
- (hspace 2)
- (span-class "schemeerror"
- (italic s))))))))
- (let sloop ([s (car val-list+outputs)])
+ (if (string=? "" (cdar val-list+outputs))
+ null
+ (list
+ (list
+ (make-flow
+ (list
+ (let ([s (regexp-split #rx"\n"
+ (regexp-replace #rx"\n$"
+ (cdar val-list+outputs)
+ ""))])
+ (if (= 1 (length s))
+ (make-paragraph
+ (list
+ (hspace 2)
+ (span-class "schemestdout" (car s))))
+ (make-table
+ #f
+ (map (lambda (s)
+ (list (make-flow (list (make-paragraph
+ (list
+ (hspace 2)
+ (span-class "schemestdout" s)))))))
+ s)))))))))
+ (if (string? (caar val-list+outputs))
+ ;; Error result case:
+ (map
+ (lambda (s)
+ (list (make-flow (list (make-paragraph
+ (list
+ (hspace 2)
+ (span-class "schemeerror"
+ (italic s))))))))
+ (let sloop ([s (caar val-list+outputs)])
(if ((string-length s) . > . maxlen)
;; break the error message into multiple lines:
(let loop ([pos (sub1 maxlen)])
@@ -67,43 +90,20 @@
(sloop (substring s (add1 pos))))]
[else (loop (sub1 pos))]))
(list s))))
- (append
- (if (string=? "" (cdar val-list+outputs))
+ ;; Normal result case:
+ (let ([val-list (caar val-list+outputs)])
+ (if (equal? val-list (list (void)))
null
- (list
- (list
- (make-flow
- (list
- (let ([s (regexp-split #rx"\n"
- (regexp-replace #rx"\n$"
- (cdar val-list+outputs)
- ""))])
- (if (= 1 (length s))
- (make-paragraph
- (list
- (hspace 2)
- (span-class "schemestdout" (car s))))
- (make-table
- #f
- (map (lambda (s)
- (list (make-flow (list (make-paragraph
- (list
- (hspace 2)
- (span-class "schemestdout" s)))))))
- s)))))))))
- (let ([val-list (caar val-list+outputs)])
- (if (equal? val-list (list (void)))
- null
- (map (lambda (v)
- (list (make-flow (list (make-paragraph
- (list
- (hspace 2)
- (span-class "schemeresult"
- (to-element/no-color v))))))))
- val-list)))))
- (loop (cdr expr-paras)
- (cdr val-list+outputs)
- #f))))))))
+ (map (lambda (v)
+ (list (make-flow (list (make-paragraph
+ (list
+ (hspace 2)
+ (span-class "schemeresult"
+ (to-element/no-color v))))))))
+ val-list))))
+ (loop (cdr expr-paras)
+ (cdr val-list+outputs)
+ #f)))))))
(define (do-eval s)
(cond
@@ -121,7 +121,8 @@
(let ([o (open-output-string)])
(parameterize ([current-output-port o])
(with-handlers ([exn? (lambda (e)
- (exn-message e))])
+ (cons (exn-message e)
+ (get-output-string o)))])
(cons (let ([v (do-plain-eval s #t)])
(copy-value v (make-hash-table)))
(get-output-string o)))))]))
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -43,10 +43,16 @@
(define (to-element/id s)
(make-element "schemesymbol" (list (to-element/no-color s))))
- (define-code scheme to-element unsyntax (lambda (ctx s v) s))
- (define-code schemeresult to-element/result unsyntax (lambda (ctx s v) s))
- (define-code schemeid to-element/id unsyntax (lambda (ctx s v) s))
- (define-code schememodname to-element unsyntax (lambda (ctx s v) s))
+ (define (keep-s-expr ctx s v) s)
+ (define (add-sq-prop s name val)
+ (if (eq? name 'paren-shape)
+ (make-shaped-parens s val)
+ s))
+
+ (define-code scheme to-element unsyntax keep-s-expr add-sq-prop)
+ (define-code schemeresult to-element/result unsyntax keep-s-expr add-sq-prop)
+ (define-code schemeid to-element/id unsyntax keep-s-expr add-sq-prop)
+ (define-code schememodname to-element unsyntax keep-s-expr add-sq-prop)
(define (litchar . strs)
(unless (andmap string? strs)
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -13,7 +13,9 @@
syntax-ize
syntax-ize-hook
current-keyword-list
- current-variable-list)
+ current-variable-list
+
+ (struct shaped-parens (val shape)))
(define no-color "schemeplain")
(define meta-color "schemeplain")
@@ -26,12 +28,13 @@
(define opt-color "schemeopt")
(define current-keyword-list
- (make-parameter '(define let let* letrec require provide
+ (make-parameter '(define let let* letrec require provide let-values
lambda new send if cond begin else and or
define-syntax syntax-rules define-struct
quote quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-splicing
- fold-for list-for list-for* for)))
+ for/fold for/list for*/list for for/and for/or for* for*/or for*/and for*/fold
+ for-values for*/list-values for/first for/last)))
(define current-variable-list
(make-parameter null))
@@ -301,6 +304,7 @@
(string? (syntax-e c))
(bytes? (syntax-e c))
(char? (syntax-e c))
+ (keyword? (syntax-e c))
(boolean? (syntax-e c)))
value-color]
[(identifier? c)
@@ -336,13 +340,13 @@
(define-syntax (define-code stx)
(syntax-case stx ()
- [(_ code typeset-code uncode d->s)
+ [(_ code typeset-code uncode d->s stx-prop)
(syntax/loc stx
(define-syntax (code stx)
(define (stx->loc-s-expr v)
(cond
[(syntax? v)
- (let ([mk `(d->s
+ (let ([mk `(,#'d->s
#f
,(syntax-case v (uncode)
[(uncode e) #'e]
@@ -354,7 +358,7 @@
,(syntax-span v)))])
(let ([prop (syntax-property v 'paren-shape)])
(if prop
- `(syntax-property ,mk 'paren-shape ,prop)
+ `(,#'stx-prop ,mk 'paren-shape ,prop)
mk)))]
[(pair? v) `(cons ,(stx->loc-s-expr (car v))
,(stx->loc-s-expr (cdr v)))]
@@ -365,13 +369,13 @@
[(null? v) 'null]
[else `(quote ,v)]))
(define (cvt s)
- (d->s #'here (stx->loc-s-expr s) #f))
+ (datum->syntax-object #'here (stx->loc-s-expr s) #f))
(syntax-case stx ()
[(_ expr) #`(typeset-code #,(cvt #'expr))]
[(_ expr (... ...))
#`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
[(_ code typeset-code uncode)
- #'(define-code code typeset-code uncode datum->syntax-object)]
+ #'(define-code code typeset-code uncode datum->syntax-object syntax-property)]
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
@@ -406,10 +410,16 @@
(loop (cons (car r) r) (sub1 i)))))
l))))
+ (define-struct shaped-parens (val shape))
+
(define (syntax-ize v col)
(cond
[((syntax-ize-hook) v col)
=> (lambda (r) r)]
+ [(shaped-parens? v)
+ (syntax-property (syntax-ize (shaped-parens-val v) col)
+ 'paren-shape
+ (shaped-parens-shape v))]
[(and (list? v)
(pair? v)
(memq (car v) '(quote unquote unquote-splicing)))
