suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

revised 'for' and docs

Browse Source 
svn: r6400

original commit: c59c7ebab760505fc3215b4c58a823617df0bb0d
This commit is contained in:
Matthew Flatt 2007-05-30 03:10:57 +00:00
parent da1bfdad73
commit 72ee384f64
3 changed files with 76 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
collects/scribble/eval.ss
View File

@ -46,16 +46,39 @@
(if (flow? p) (if (flow? p)
p p
(make-flow (list p)))))) (make-flow (list p))))))
(append (if (string=? "" (cdar val-list+outputs))
(if (string? (car val-list+outputs)) null
(map (list
(lambda (s) (list
(list (make-flow (list (make-paragraph (make-flow
(list (list
(hspace 2) (let ([s (regexp-split #rx"\n"
(span-class "schemeerror" (regexp-replace #rx"\n$"
(italic s)))))))) (cdar val-list+outputs)
(let sloop ([s (car 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) (if ((string-length s) . > . maxlen)
;; break the error message into multiple lines: ;; break the error message into multiple lines:
(let loop ([pos (sub1 maxlen)]) (let loop ([pos (sub1 maxlen)])
@ -67,43 +90,20 @@
(sloop (substring s (add1 pos))))] (sloop (substring s (add1 pos))))]
[else (loop (sub1 pos))])) [else (loop (sub1 pos))]))
(list s)))) (list s))))
(append ;; Normal result case:
(if (string=? "" (cdar val-list+outputs)) (let ([val-list (caar val-list+outputs)])
(if (equal? val-list (list (void)))
null null
(list (map (lambda (v)
(list (list (make-flow (list (make-paragraph
(make-flow (list
(list (hspace 2)
(let ([s (regexp-split #rx"\n" (span-class "schemeresult"
(regexp-replace #rx"\n$" (to-element/no-color v))))))))
(cdar val-list+outputs) val-list))))
""))]) (loop (cdr expr-paras)
(if (= 1 (length s)) (cdr val-list+outputs)
(make-paragraph #f)))))))
(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))))))))
(define (do-eval s) (define (do-eval s)
(cond (cond
@ -121,7 +121,8 @@
(let ([o (open-output-string)]) (let ([o (open-output-string)])
(parameterize ([current-output-port o]) (parameterize ([current-output-port o])
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (lambda (e)
(exn-message e))]) (cons (exn-message e)
(get-output-string o)))])
(cons (let ([v (do-plain-eval s #t)]) (cons (let ([v (do-plain-eval s #t)])
(copy-value v (make-hash-table))) (copy-value v (make-hash-table)))
(get-output-string o)))))])) (get-output-string o)))))]))

14
collects/scribble/manual.ss
View File

@ -43,10 +43,16 @@
(define (to-element/id s) (define (to-element/id s)
(make-element "schemesymbol" (list (to-element/no-color s)))) (make-element "schemesymbol" (list (to-element/no-color s))))
(define-code scheme to-element unsyntax (lambda (ctx s v) s)) (define (keep-s-expr ctx s v) s)
(define-code schemeresult to-element/result unsyntax (lambda (ctx s v) s)) (define (add-sq-prop s name val)
(define-code schemeid to-element/id unsyntax (lambda (ctx s v) s)) (if (eq? name 'paren-shape)
(define-code schememodname to-element unsyntax (lambda (ctx s v) s)) (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) (define (litchar . strs)
(unless (andmap string? strs) (unless (andmap string? strs)

26
collects/scribble/scheme.ss
View File

@ -13,7 +13,9 @@
syntax-ize syntax-ize
syntax-ize-hook syntax-ize-hook
current-keyword-list current-keyword-list
current-variable-list) current-variable-list
(struct shaped-parens (val shape)))
(define no-color "schemeplain") (define no-color "schemeplain")
(define meta-color "schemeplain") (define meta-color "schemeplain")
@ -26,12 +28,13 @@
(define opt-color "schemeopt") (define opt-color "schemeopt")
(define current-keyword-list (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 lambda new send if cond begin else and or
define-syntax syntax-rules define-struct define-syntax syntax-rules define-struct
quote quasiquote unquote unquote-splicing quote quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-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 (define current-variable-list
(make-parameter null)) (make-parameter null))
@ -301,6 +304,7 @@
(string? (syntax-e c)) (string? (syntax-e c))
(bytes? (syntax-e c)) (bytes? (syntax-e c))
(char? (syntax-e c)) (char? (syntax-e c))
(keyword? (syntax-e c))
(boolean? (syntax-e c))) (boolean? (syntax-e c)))
value-color] value-color]
[(identifier? c) [(identifier? c)
@ -336,13 +340,13 @@
(define-syntax (define-code stx) (define-syntax (define-code stx)
(syntax-case stx () (syntax-case stx ()
[(_ code typeset-code uncode d->s) [(_ code typeset-code uncode d->s stx-prop)
(syntax/loc stx (syntax/loc stx
(define-syntax (code stx) (define-syntax (code stx)
(define (stx->loc-s-expr v) (define (stx->loc-s-expr v)
(cond (cond
[(syntax? v) [(syntax? v)
(let ([mk `(d->s (let ([mk `(,#'d->s
#f #f
,(syntax-case v (uncode) ,(syntax-case v (uncode)
[(uncode e) #'e] [(uncode e) #'e]
@ -354,7 +358,7 @@
,(syntax-span v)))]) ,(syntax-span v)))])
(let ([prop (syntax-property v 'paren-shape)]) (let ([prop (syntax-property v 'paren-shape)])
(if prop (if prop
`(syntax-property ,mk 'paren-shape ,prop) `(,#'stx-prop ,mk 'paren-shape ,prop)
mk)))] mk)))]
[(pair? v) `(cons ,(stx->loc-s-expr (car v)) [(pair? v) `(cons ,(stx->loc-s-expr (car v))
,(stx->loc-s-expr (cdr v)))] ,(stx->loc-s-expr (cdr v)))]
@ -365,13 +369,13 @@
[(null? v) 'null] [(null? v) 'null]
[else `(quote ,v)])) [else `(quote ,v)]))
(define (cvt s) (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 () (syntax-case stx ()
[(_ expr) #`(typeset-code #,(cvt #'expr))] [(_ expr) #`(typeset-code #,(cvt #'expr))]
[(_ expr (... ...)) [(_ expr (... ...))
#`(typeset-code #,(cvt #'(code:line expr (... ...))))])))] #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
[(_ code typeset-code uncode) [(_ 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)])) [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
@ -406,10 +410,16 @@
(loop (cons (car r) r) (sub1 i))))) (loop (cons (car r) r) (sub1 i)))))
l)))) l))))
(define-struct shaped-parens (val shape))
(define (syntax-ize v col) (define (syntax-ize v col)
(cond (cond
[((syntax-ize-hook) v col) [((syntax-ize-hook) v col)
=> (lambda (r) r)] => (lambda (r) r)]
[(shaped-parens? v)
(syntax-property (syntax-ize (shaped-parens-val v) col)
'paren-shape
(shaped-parens-shape v))]
[(and (list? v) [(and (list? v)
(pair? v) (pair? v)
(memq (car v) '(quote unquote unquote-splicing))) (memq (car v) '(quote unquote unquote-splicing)))