From 72ee384f64f70fa2eb56a14033bafb014563baef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 May 2007 03:10:57 +0000 Subject: [PATCH] revised 'for' and docs svn: r6400 original commit: c59c7ebab760505fc3215b4c58a823617df0bb0d --- collects/scribble/eval.ss | 95 +++++++++++++++++++------------------ collects/scribble/manual.ss | 14 ++++-- collects/scribble/scheme.ss | 26 ++++++---- 3 files changed, 76 insertions(+), 59 deletions(-) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index d4af007d..470945a8 100644 --- 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 index 9781e0f2..9a3eaf6b 100644 --- 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 index 68efc3ce..6e5590e6 100644 --- 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)))