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

Switch to `#lang', reformat, and some minor improvements.

Browse Source 
original commit: d4dec81c91a3d95ce8d252a2b63bdc3fe8c79128
This commit is contained in:
Eli Barzilay 2011-06-16 09:52:21 -04:00
parent 09eb2cc7b7
commit bf18603b97
1 changed files with 479 additions and 544 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

301
collects/scribble/eval.rkt
View File

@ -1,15 +1,8 @@
#lang racket/base
(module eval racket/base (require "manual.ss" "struct.ss" "scheme.ss" "decode.ss"
(require "manual.ss" racket/string racket/list racket/file
"struct.ss" racket/sandbox racket/promise racket/port file/convertible
"scheme.ss"
"decode.ss"
racket/file
racket/sandbox
racket/promise
racket/string
racket/port
file/convertible
(for-syntax racket/base)) (for-syntax racket/base))
(provide interaction (provide interaction
@ -34,9 +27,8 @@
scribble-eval-handler) scribble-eval-handler)
(define scribble-eval-handler (make-parameter (define scribble-eval-handler
(lambda (ev c? x) (make-parameter (lambda (ev c? x) (ev x))))
(ev x))))
(define image-counter 0) (define image-counter 0)
@ -50,33 +42,28 @@
(define (literal-string style s) (define (literal-string style s)
(let ([m (regexp-match #rx"^(.*)( +)(.*)$" s)]) (let ([m (regexp-match #rx"^(.*)( +)(.*)$" s)])
(if m (if m
(make-element #f (make-element #f (list (literal-string style (cadr m))
(list (literal-string style (cadr m))
(hspace (string-length (caddr m))) (hspace (string-length (caddr m)))
(literal-string style (cadddr m)))) (literal-string style (cadddr m))))
(make-element style (list s))))) (make-element style (list s)))))
(define list.flow.list (compose1 list make-flow list))
(define (format-output str style) (define (format-output str style)
(cond (unless (string? str)
[(not (string? str))
(error 'format-output "missing output, possibly from a sandbox ~a" (error 'format-output "missing output, possibly from a sandbox ~a"
"without a `sandbox-output' configured to 'string")] "without a `sandbox-output' configured to 'string"))
[(string=? "" str) null] (and (not (string=? "" str))
[else (list.flow.list
(list
(list
(make-flow
(list
(let ([s (regexp-split #rx"\n" (regexp-replace #rx"\n$" str ""))]) (let ([s (regexp-split #rx"\n" (regexp-replace #rx"\n$" str ""))])
(if (= 1 (length s)) (if (= 1 (length s))
(make-paragraph (list (literal-string style (car s)))) (make-paragraph (list (literal-string style (car s))))
(make-table (make-table
#f #f
(map (lambda (s) (map (lambda (s)
(list (make-flow (list.flow.list
(list (make-paragraph (make-paragraph (list (literal-string style s)))))
(list (literal-string style s))))))) s)))))))
s))))))))]))
(define (format-output-stream in style) (define (format-output-stream in style)
(define (add-string string-accum line-accum) (define (add-string string-accum line-accum)
@ -88,9 +75,7 @@
(if line-accum (if line-accum
(cons (make-paragraph (cons (make-paragraph
(map (lambda (s) (map (lambda (s)
(if (string? s) (if (string? s) (literal-string style s) s))
(literal-string style s)
s))
(reverse line-accum))) (reverse line-accum)))
flow-accum) flow-accum)
flow-accum)) flow-accum))
@ -101,16 +86,12 @@
(let* ([line-accum (add-string string-accum line-accum)] (let* ([line-accum (add-string string-accum line-accum)]
[flow-accum (add-line line-accum flow-accum)]) [flow-accum (add-line line-accum flow-accum)])
(list (list
(list (list.flow.list
(make-flow
(list
(if (= 1 (length flow-accum)) (if (= 1 (length flow-accum))
(car flow-accum) (car flow-accum)
(make-table (make-table
#f #f
(map (lambda (l) (map list.flow.list (reverse flow-accum)))))))]
(list (make-flow (list l))))
(reverse flow-accum)))))))))]
[(equal? #\newline v) [(equal? #\newline v)
(loop #f #f (add-line (add-string string-accum line-accum) (loop #f #f (add-line (add-string string-accum line-accum)
flow-accum))] flow-accum))]
@ -120,6 +101,20 @@
(loop #f (cons v (or (add-string string-accum line-accum) null)) (loop #f (cons v (or (add-string string-accum line-accum) null))
flow-accum)])))) flow-accum)]))))
;; This is probably good to make into some library function at some
;; point (but in that case will need to improve, eg, wrapped lines
;; should start at the same indentation level, etc)
(define (string->wrapped-lines str)
(define (wrap-line str)
(if ((string-length str) . <= . maxlen)
(if (equal? str "") '() (list str))
(let* ([m (cond [(regexp-match-positions #px"^.*\\S(\\s+).*" str 0 maxlen)
=> cadr]
[else (cons maxlen maxlen)])]
[r (wrap-line (substring str (cdr m)))])
(if (= 0 (car m)) r (cons (substring str 0 (car m)) r)))))
(append-map wrap-line (regexp-split #px"\\s*\n" str)))
(define (interleave inset? title expr-paras val-list+outputs) (define (interleave inset? title expr-paras val-list+outputs)
(let ([lines (let ([lines
(let loop ([expr-paras expr-paras] (let loop ([expr-paras expr-paras]
@ -129,75 +124,44 @@
null null
(append (append
(list (list (let ([p (car expr-paras)]) (list (list (let ([p (car expr-paras)])
(if (flow? p) (if (flow? p) p (make-flow (list p))))))
p (or (format-output (cadar val-list+outputs) output-color) '())
(make-flow (list p)))))) (or (format-output (caddar val-list+outputs) error-color) '())
(format-output (cadar val-list+outputs) output-color)
(format-output (caddar val-list+outputs) error-color)
(cond (cond
[(string? (caar val-list+outputs)) [(string? (caar val-list+outputs))
;; Error result case: ;; Error result case:
(map (map (lambda (s) (format-output s error-color))
(lambda (s) (string->wrapped-lines (caar val-list+outputs)))]
(car (format-output s error-color)))
(filter
(lambda (s) (not (equal? s "")))
(let sloop ([s (caar val-list+outputs)])
(apply
append
(map (lambda (s)
(if ((string-length s) . > . maxlen)
;; break the error message into multiple lines:
(let loop ([pos (sub1 maxlen)])
(cond
[(zero? pos) (cons (substring s 0 maxlen)
(sloop (substring s maxlen)))]
[(char-whitespace? (string-ref s pos))
(cons (substring s 0 pos)
(sloop (substring s (add1 pos))))]
[else (loop (sub1 pos))]))
(list s)))
(regexp-split #rx"\n" s))))))]
[(box? (caar val-list+outputs)) [(box? (caar val-list+outputs))
;; Output witten to a port ;; Output written to a port
(format-output-stream (unbox (caar val-list+outputs)) result-color)] (format-output-stream (unbox (caar val-list+outputs))
result-color)]
[else [else
;; Normal result case: ;; Normal result case:
(let ([val-list (caar val-list+outputs)]) (let ([val-list (caar val-list+outputs)])
(if (equal? val-list (list (void))) (if (equal? val-list (list (void)))
null null
(map (lambda (v) (map (lambda (v)
(list (make-flow (list (make-paragraph (list.flow.list
(list (make-paragraph
(elem #:style result-color (list (elem #:style result-color
(to-element/no-color v #:expr? (print-as-expression))))))))) (to-element/no-color
v #:expr? (print-as-expression)))))))
val-list)))]) val-list)))])
(loop (cdr expr-paras) (loop (cdr expr-paras) (cdr val-list+outputs) #f))))])
(cdr val-list+outputs)
#f))))])
(if inset? (if inset?
(let ([p (code-inset (make-table #f lines))]) (let ([p (code-inset (make-table #f lines))])
(if title (if title
(make-table (make-table #f (list (list.flow.list title) (list.flow.list p)))
#f
(list
(list (make-flow (list title)))
(list (make-flow (list p)))))
p)) p))
(make-table #f (make-table #f (if title (cons (list.flow.list title) lines) lines)))))
(append
(if title
(list (list (make-flow (list title))))
null)
lines)))))
;; extracts from a datum or syntax object --- while keeping the ;; extracts from a datum or syntax object --- while keeping the
;; syntax-objectness of the original intact, instead of always ;; syntax-objectness of the original intact, instead of always
;; generating a syntax object or always generating a datum ;; generating a syntax object or always generating a datum
(define (extract s . ops) (define (extract s . ops)
(let loop ([s s] [ops ops]) (let loop ([s s] [ops ops])
(cond (cond [(null? ops) s]
[(null? ops) s]
[(syntax? s) (loop (syntax-e s) ops)] [(syntax? s) (loop (syntax-e s) ops)]
[else (loop ((car ops) s) (cdr ops))]))) [else (loop ((car ops) s) (cdr ops))])))
@ -215,14 +179,12 @@
[(eval:check e expect) [(eval:check e expect)
(loop (extract s cdr car) (loop (extract s cdr car)
(list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))] (list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))]
[else [else (values s expect)])))
(values s expect)])))
(define ((do-eval ev) s) (define ((do-eval ev) s)
(let-values ([(s expect) (extract-to-evaluate s)]) (let-values ([(s expect) (extract-to-evaluate s)])
(if (not (nothing-to-eval? s)) (if (not (nothing-to-eval? s))
(let ([r (with-handlers ([(lambda (x) (let ([r (with-handlers ([(lambda (x) (not (exn:break? x)))
(not (exn:break? x)))
(lambda (e) (lambda (e)
(list (if (exn? e) (list (if (exn? e)
(exn-message e) (exn-message e)
@ -243,7 +205,8 @@
(call-in-sandbox-context (call-in-sandbox-context
ev ev
(lambda () (lambda ()
(let-values ([(in out) (make-pipe-with-specials)]) (let-values ([(in out)
(make-pipe-with-specials)])
(parameterize ([current-output-port out]) (parameterize ([current-output-port out])
(map (current-print) v)) (map (current-print) v))
(close-output-port out) (close-output-port out)
@ -257,80 +220,65 @@
r) r)
(values (list (list (void)) "" ""))))) (values (list (list (void)) "" "")))))
(define (install ht v v2)
(hash-set! ht v v2)
v2)
;; Since we evaluate everything in an interaction before we typeset, ;; Since we evaluate everything in an interaction before we typeset,
;; copy each value to avoid side-effects. ;; copy each value to avoid side-effects.
(define (copy-value v ht) (define (copy-value v ht)
(define (install v v2) (hash-set! ht v v2) v2)
(let loop ([v v])
(cond (cond
[(and v (hash-ref ht v #f)) [(and v (hash-ref ht v #f)) => (lambda (v) v)]
=> (lambda (v) v)]
[(syntax? v) (make-literal-syntax v)] [(syntax? v) (make-literal-syntax v)]
[(string? v) (install ht v (string-copy v))] [(string? v) (install v (string-copy v))]
[(bytes? v) (install ht v (bytes-copy v))] [(bytes? v) (install v (bytes-copy v))]
[(pair? v) [(pair? v)
(let ([ph (make-placeholder #f)]) (let ([ph (make-placeholder #f)])
(hash-set! ht v ph) (hash-set! ht v ph)
(placeholder-set! ph (placeholder-set! ph (cons (loop (car v)) (loop (cdr v))))
(cons (copy-value (car v) ht)
(copy-value (cdr v) ht)))
ph)] ph)]
[(mpair? v) (let ([p (mcons #f #f)]) [(mpair? v)
(let ([p (mcons #f #f)])
(hash-set! ht v p) (hash-set! ht v p)
(set-mcar! p (copy-value (mcar v) ht)) (set-mcar! p (loop (mcar v)))
(set-mcdr! p (copy-value (mcdr v) ht)) (set-mcdr! p (loop (mcdr v)))
p)] p)]
[(vector? v) (let ([v2 (make-vector (vector-length v))]) [(vector? v)
(let ([v2 (make-vector (vector-length v))])
(hash-set! ht v v2) (hash-set! ht v v2)
(let loop ([i (vector-length v2)]) (for ([i (in-range (vector-length v2))])
(unless (zero? i) (vector-set! v2 i (loop (vector-ref v i))))
(let ([i (sub1 i)])
(vector-set! v2 i (copy-value (vector-ref v i) ht))
(loop i))))
v2)] v2)]
[(box? v) (let ([v2 (box #f)]) [(box? v)
(let ([v2 (box #f)])
(hash-set! ht v v2) (hash-set! ht v v2)
(set-box! v2 (copy-value (unbox v) ht)) (set-box! v2 (loop (unbox v)))
v2)] v2)]
[(hash? v) (let ([ph (make-placeholder #f)]) [(hash? v)
(let ([ph (make-placeholder #f)])
(hash-set! ht v ph) (hash-set! ht v ph)
(let ([a (hash-map v (lambda (k v) (let ([a (hash-map v (lambda (k v) (cons (loop k) (loop v))))])
(cons (copy-value k ht)
(copy-value v ht))))])
(placeholder-set! (placeholder-set!
ph ph
((if (hash-eq? v) (cond [(hash-eq? v) (make-hasheq-placeholder a)]
make-hasheq-placeholder [(hash-eqv? v) (make-hasheqv-placeholder a)]
(if (hash-eqv? v) [else (make-hash-placeholder a)])))
make-hasheqv-placeholder
make-hash-placeholder))
a)))
ph)] ph)]
[else v])) [else v])))
(define (strip-comments stx) (define (strip-comments stx)
(cond (cond
[(syntax? stx) [(syntax? stx)
(datum->syntax stx (datum->syntax stx (strip-comments (syntax-e stx)) stx stx stx)]
(strip-comments (syntax-e stx))
stx
stx
stx)]
[(pair? stx) [(pair? stx)
(let ([a (car stx)] (define a (car stx))
[comment? (lambda (a) (define (comment? a)
(and (pair? a) (and (pair? a)
(or (eq? (car a) 'code:comment) (or (eq? (car a) 'code:comment)
(and (identifier? (car a)) (and (identifier? (car a))
(eq? (syntax-e (car a)) 'code:comment)))))]) (eq? (syntax-e (car a)) 'code:comment)))))
(if (or (comment? a) (if (or (comment? a) (and (syntax? a) (comment? (syntax-e a))))
(and (syntax? a) (comment? (syntax-e a))))
(strip-comments (cdr stx)) (strip-comments (cdr stx))
(cons (strip-comments a) (cons (strip-comments a)
(strip-comments (cdr stx)))))] (strip-comments (cdr stx))))]
[(eq? stx 'code:blank) (void)] [(eq? stx 'code:blank) (void)]
[else stx])) [else stx]))
@ -342,18 +290,16 @@
[sandbox-propagate-breaks #f]) [sandbox-propagate-breaks #f])
(let ([e (make-evaluator '(begin))]) (let ([e (make-evaluator '(begin))])
(let ([ns (namespace-anchor->namespace anchor)]) (let ([ns (namespace-anchor->namespace anchor)])
(call-in-sandbox-context e (call-in-sandbox-context
(lambda () e
(namespace-attach-module ns 'file/convertible)))) (lambda () (namespace-attach-module ns 'file/convertible))))
e))))) e)))))
(define (make-base-eval-factory mod-paths) (define (make-base-eval-factory mod-paths)
(let ([ns (delay (let ([ns (make-base-empty-namespace)]) (let ([ns (delay (let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(for-each (for ([mod-path (in-list mod-paths)])
(lambda (mod-path) (dynamic-require mod-path #f)))
(dynamic-require mod-path #f))
mod-paths))
ns))]) ns))])
(lambda () (lambda ()
(let ([ev (make-base-eval)] (let ([ev (make-base-eval)]
@ -361,9 +307,8 @@
((scribble-eval-handler) ((scribble-eval-handler)
ev #f ev #f
`(,(lambda () `(,(lambda ()
(for-each (lambda (mod-path) (for ([mod-path (in-list mod-paths)])
(namespace-attach-module ns mod-path)) (namespace-attach-module ns mod-path)))))
mod-paths))))
ev)))) ev))))
(define (make-eval-factory mod-paths) (define (make-eval-factory mod-paths)
@ -373,8 +318,8 @@
((scribble-eval-handler) ((scribble-eval-handler)
ev #f ev #f
`(,(lambda () `(,(lambda ()
(for-each (lambda (mod-path) (namespace-require mod-path)) (for ([mod-path (in-list mod-paths)])
mod-paths)))) (namespace-require mod-path)))))
ev)))) ev))))
(define (close-eval e) (define (close-eval e)
@ -383,21 +328,18 @@
(define (do-plain-eval ev s catching-exns?) (define (do-plain-eval ev s catching-exns?)
(parameterize ([sandbox-propagate-breaks #f]) (parameterize ([sandbox-propagate-breaks #f])
(call-with-values (lambda () (call-with-values
(lambda ()
((scribble-eval-handler) ((scribble-eval-handler)
ev ev
catching-exns? catching-exns?
(let ([s (strip-comments s)]) (let ([s (strip-comments s)])
(cond (cond [(syntax? s)
[(syntax? s)
(syntax-case s (module) (syntax-case s (module)
[(module . _rest) [(module . _rest) (syntax->datum s)]
(syntax->datum s)]
[_else s])] [_else s])]
[(bytes? s) [(bytes? s) `(begin ,s)]
`(begin ,s)] [(string? s) `(begin ,s)]
[(string? s)
`(begin ,s)]
[else s])))) [else s]))))
list))) list)))
@ -420,7 +362,6 @@
[(_ #:eval ev e) (do-interaction-eval ev (quote-expr e))] [(_ #:eval ev e) (do-interaction-eval ev (quote-expr e))]
[(_ e) (do-interaction-eval #f (quote-expr e))])) [(_ e) (do-interaction-eval #f (quote-expr e))]))
(define (show-val v) (define (show-val v)
(elem #:style result-color (elem #:style result-color
(to-element/no-color v #:expr? (print-as-expression)))) (to-element/no-color v #:expr? (print-as-expression))))
@ -459,17 +400,16 @@
[(_ e) #'(racketinput* e)])) [(_ e) #'(racketinput* e)]))
(define (do-titled-interaction inset? ev t shows evals) (define (do-titled-interaction inset? ev t shows evals)
(interleave inset? (interleave inset? t shows (map (do-eval ev) evals)))
t
shows
(map (do-eval ev) evals)))
(define-syntax titled-interaction (define-syntax titled-interaction
(syntax-rules () (syntax-rules ()
[(_ inset? #:eval ev t racketinput* e ...) [(_ inset? #:eval ev t racketinput* e ...)
(do-titled-interaction inset? ev t (list (racketinput* e) ...) (list (quote-expr e) ...))] (do-titled-interaction
inset? ev t (list (racketinput* e) ...) (list (quote-expr e) ...))]
[(_ inset? t racketinput* e ...) [(_ inset? t racketinput* e ...)
(titled-interaction inset? #:eval (make-base-eval) t racketinput* e ...)])) (titled-interaction
inset? #:eval (make-base-eval) t racketinput* e ...)]))
(define (code-inset p) (define (code-inset p)
(make-blockquote 'code-inset (list p))) (make-blockquote 'code-inset (list p)))
@ -480,7 +420,8 @@
(define-syntax interaction0 (define-syntax interaction0
(syntax-rules () (syntax-rules ()
[(_ #:eval ev e ...) (titled-interaction #f #:eval ev #f racketinput* e ...)] [(_ #:eval ev e ...)
(titled-interaction #f #:eval ev #f racketinput* e ...)]
[(_ e ...) (titled-interaction #f #f racketinput* e ...)])) [(_ e ...) (titled-interaction #f #f racketinput* e ...)]))
(define-syntax racketblock+eval (define-syntax racketblock+eval
@ -497,8 +438,7 @@
(syntax-rules () (syntax-rules ()
[(_ #:eval ev e ...) [(_ #:eval ev e ...)
(let ([eva ev]) (let ([eva ev])
(#%expression (#%expression (begin (interaction-eval #:eval eva e) ...
(begin (interaction-eval #:eval eva e) ...
(racketblock0 e ...))))] (racketblock0 e ...))))]
[(_ e ...) [(_ e ...)
(racketblock0+eval #:eval (make-base-eval) e ...)])) (racketblock0+eval #:eval (make-base-eval) e ...)]))
@ -546,7 +486,8 @@
(define-syntax examples (define-syntax examples
(syntax-rules () (syntax-rules ()
[(_ #:eval ev e ...) [(_ #:eval ev e ...)
(titled-interaction #t #:eval ev (pick-example-title e ...) racketinput* e ...)] (titled-interaction #t #:eval ev
(pick-example-title e ...) racketinput* e ...)]
[(_ e ...) [(_ e ...)
(titled-interaction #t (pick-example-title e ...) racketinput* e ...)])) (titled-interaction #t (pick-example-title e ...) racketinput* e ...)]))
(define-syntax examples* (define-syntax examples*
@ -558,9 +499,11 @@
(define-syntax defexamples (define-syntax defexamples
(syntax-rules () (syntax-rules ()
[(_ #:eval ev e ...) [(_ #:eval ev e ...)
(titled-interaction #t #:eval ev (pick-example-title e ...) racketdefinput* e ...)] (titled-interaction #t #:eval ev
(pick-example-title e ...) racketdefinput* e ...)]
[(_ e ...) [(_ e ...)
(titled-interaction #t (pick-example-title e ...) racketdefinput* e ...)])) (titled-interaction #t
(pick-example-title e ...) racketdefinput* e ...)]))
(define-syntax defexamples* (define-syntax defexamples*
(syntax-rules () (syntax-rules ()
[(_ #:eval ev example-title e ...) [(_ #:eval ev example-title e ...)
@ -571,24 +514,16 @@
(define blank-line (make-paragraph (list 'nbsp))) (define blank-line (make-paragraph (list 'nbsp)))
(define (column l) (define (column l)
(code-inset (code-inset (make-table #f (map list.flow.list l))))
(make-table #f (map
(lambda (t)
(list (make-flow (list t))))
l))))
(define (do-splice l) (define (do-splice l)
(cond (cond [(null? l) null]
[(null? l) null] [(splice? (car l)) `(,@(splice-run (car l)) ,@(do-splice (cdr l)))]
[(splice? (car l)) (append (splice-run (car l))
(do-splice (cdr l)))]
[else (cons (car l) (do-splice (cdr l)))])) [else (cons (car l) (do-splice (cdr l)))]))
(define as-examples (define as-examples
(case-lambda (case-lambda
[(t) (as-examples examples-title t)] [(t) (as-examples examples-title t)]
[(example-title t) [(example-title t)
(make-table #f (make-table #f (list (list.flow.list example-title)
(list (list (make-flow (do-splice (list t))))))]))
(list (make-flow (list example-title)))
(list (make-flow (do-splice (list t))))))])))