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

Pass around the form name so that an error from the sandbox will show a

Browse Source 
more useful error.
This commit is contained in:
Eli Barzilay 2011-06-16 13:39:52 -04:00
parent d4dec81c91
commit 768baa5983
1 changed files with 133 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
collects/scribble/eval.rkt
View File

@ -50,11 +50,9 @@
(define list.flow.list (compose1 list make-flow list)) (define list.flow.list (compose1 list make-flow list))
(define (format-output str style) (define (format-output str style)
(unless (string? str) (if (string=? "" str)
(error 'format-output "missing output, possibly from a sandbox ~a" '()
"without a `sandbox-output' configured to 'string")) (list (list.flow.list
(and (not (string=? "" str))
(list.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))))
@ -63,7 +61,7 @@
(map (lambda (s) (map (lambda (s)
(list.flow.list (list.flow.list
(make-paragraph (list (literal-string style s))))) (make-paragraph (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)
@ -125,12 +123,12 @@
(append (append
(list (list (let ([p (car expr-paras)]) (list (list (let ([p (car expr-paras)])
(if (flow? p) p (make-flow (list p)))))) (if (flow? p) p (make-flow (list p))))))
(or (format-output (cadar val-list+outputs) output-color) '()) (format-output (cadar val-list+outputs) output-color)
(or (format-output (caddar val-list+outputs) error-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 (lambda (s) (format-output s error-color)) (map (lambda (s) (car (format-output s error-color)))
(string->wrapped-lines (caar val-list+outputs)))] (string->wrapped-lines (caar val-list+outputs)))]
[(box? (caar val-list+outputs)) [(box? (caar val-list+outputs))
;; Output written to a port ;; Output written to a port
@ -181,44 +179,49 @@
(list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))] (list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))]
[else (values s expect)]))) [else (values s expect)])))
(define ((do-eval ev) s) (define (do-eval ev who)
(let-values ([(s expect) (extract-to-evaluate s)]) (define (get-outputs)
(if (not (nothing-to-eval? s)) (define (get getter what)
(let ([r (with-handlers ([(lambda (x) (not (exn:break? x))) (define s (getter ev))
(lambda (e) (if (string? s)
(list (if (exn? e) s
(exn-message e) (error who "missing ~a, possibly from a sandbox ~a"
(format "uncaught exception: ~s" e)) what "without a `sandbox-output' configured to 'string")))
(get-output ev) (list (get get-output "output") (get get-error-output "error output")))
(get-error-output ev)))]) (define (render-value v)
(list (let ([v (do-plain-eval ev s #t)])
(if (call-in-sandbox-context (if (call-in-sandbox-context
ev ev (let ([cp (current-print)])
(let ([cp (current-print)]) (lambda () (and (eq? (current-print) cp) (print-as-expression)))))
(lambda ()
(and (eq? (current-print) cp)
(print-as-expression)))))
;; default printer => get result as S-expression ;; default printer => get result as S-expression
(make-reader-graph (copy-value v (make-hasheq))) (make-reader-graph (copy-value v (make-hasheq)))
;; other printer => go through a string ;; other printer => go through a string
(box (box (call-in-sandbox-context
(call-in-sandbox-context
ev ev
(lambda () (lambda ()
(let-values ([(in out) (define-values [in out] (make-pipe-with-specials))
(make-pipe-with-specials)]) (parameterize ([current-output-port out]) (map (current-print) v))
(parameterize ([current-output-port out])
(map (current-print) v))
(close-output-port out) (close-output-port out)
in)))))) in)))))
(get-output ev) (define (do-ev s)
(get-error-output ev)))]) (with-handlers ([(lambda (x) (not (exn:break? x)))
(lambda (e)
(cons (if (exn? e)
(exn-message e)
(format "uncaught exception: ~s" e))
(get-outputs)))])
(cons (render-value (do-plain-eval ev s #t)) (get-outputs))))
(define (do-ev/expect s expect)
(define r (do-ev s))
(when expect (when expect
(let ([expect (do-plain-eval ev (car expect) #t)]) (let ([expect (do-plain-eval ev (car expect) #t)])
(unless (equal? (car r) expect) (unless (equal? (car r) expect)
(raise-syntax-error 'eval "example result check failed" s)))) (raise-syntax-error 'eval "example result check failed" s))))
r) r)
(values (list (list (void)) "" ""))))) (lambda (str)
(let-values ([(s expect) (extract-to-evaluate str)])
(if (nothing-to-eval? s)
(values (list (list (void)) "" ""))
(do-ev/expect s expect)))))
;; 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.
@ -399,30 +402,37 @@
[(_ e) #'(racketblock0+line e)])] [(_ e) #'(racketblock0+line e)])]
[(_ e) #'(racketinput* e)])) [(_ e) #'(racketinput* e)]))
(define (do-titled-interaction inset? ev t shows evals) (define (do-titled-interaction who inset? ev t shows evals)
(interleave inset? t shows (map (do-eval ev) evals))) (interleave inset? t shows (map (do-eval ev who) evals)))
(define-syntax titled-interaction (define-syntax titled-interaction
(syntax-rules () (syntax-rules ()
[(_ inset? #:eval ev t racketinput* e ...) [(_ who inset? #:eval ev t racketinput* e ...)
(do-titled-interaction (do-titled-interaction
inset? ev t (list (racketinput* e) ...) (list (quote-expr e) ...))] 'who inset? ev t (list (racketinput* e) ...) (list (quote-expr e) ...))]
[(_ inset? t racketinput* e ...) [(_ who inset? t racketinput* e ...)
(titled-interaction (titled-interaction
inset? #:eval (make-base-eval) t racketinput* e ...)])) who inset? #:eval (make-base-eval) t racketinput* e ...)]))
(define-syntax (-interaction stx)
(syntax-case stx ()
[(_ who #:eval ev e ...)
(syntax/loc stx
(titled-interaction who #f #:eval ev #f racketinput* e ...))]
[(_ who e ...)
(syntax/loc stx
(titled-interaction who #f #f racketinput* e ...))]))
(define (code-inset p) (define (code-inset p)
(make-blockquote 'code-inset (list p))) (make-blockquote 'code-inset (list p)))
(define-syntax interaction (define-syntax (interaction stx)
(syntax-rules () (syntax-case stx ()
[(_ e ...) (code-inset (interaction0 e ...))])) [(H e ...) (syntax/loc stx (code-inset (-interaction H e ...)))]))
(define-syntax interaction0 (define-syntax (interaction0 stx)
(syntax-rules () (syntax-case stx ()
[(_ #:eval ev e ...) [(H e ...) (syntax/loc stx (-interaction H e ...))]))
(titled-interaction #f #:eval ev #f racketinput* e ...)]
[(_ e ...) (titled-interaction #f #f racketinput* e ...)]))
(define-syntax racketblock+eval (define-syntax racketblock+eval
(syntax-rules () (syntax-rules ()
@ -453,25 +463,27 @@
[(_ name e ...) [(_ name e ...)
(racketmod+eval #:eval (make-base-eval) name e ...)])) (racketmod+eval #:eval (make-base-eval) name e ...)]))
(define-syntax def+int (define-syntax (def+int stx)
(syntax-rules () (syntax-case stx ()
[(_ #:eval ev def e ...) [(H #:eval ev def e ...)
(syntax/loc stx
(let ([eva ev]) (let ([eva ev])
(column (list (racketblock0+eval #:eval eva def) (column (list (racketblock0+eval #:eval eva def)
blank-line blank-line
(interaction0 #:eval eva e ...))))] (-interaction H #:eval eva e ...)))))]
[(_ def e ...) [(_ def e ...)
(def+int #:eval (make-base-eval) def e ...)])) (syntax/loc stx (def+int #:eval (make-base-eval) def e ...))]))
(define-syntax defs+int (define-syntax (defs+int stx)
(syntax-rules () (syntax-case stx ()
[(_ #:eval ev [def ...] e ...) [(H #:eval ev [def ...] e ...)
(syntax/loc stx
(let ([eva ev]) (let ([eva ev])
(column (list (racketblock0+eval #:eval eva def ...) (column (list (racketblock0+eval #:eval eva def ...)
blank-line blank-line
(interaction0 #:eval eva e ...))))] (-interaction H #:eval eva e ...)))))]
[(_ [def ...] e ...) [(_ [def ...] e ...)
(defs+int #:eval (make-base-eval) [def ...] e ...)])) (syntax/loc stx (defs+int #:eval (make-base-eval) [def ...] e ...))]))
(define example-title (define example-title
(make-paragraph (list "Example:"))) (make-paragraph (list "Example:")))
@ -483,33 +495,42 @@
[(_ e) example-title] [(_ e) example-title]
[(_ . _) examples-title])) [(_ . _) examples-title]))
(define-syntax examples (define-syntax (examples stx)
(syntax-rules () (syntax-case stx ()
[(_ #:eval ev e ...) [(H #:eval ev e ...)
(titled-interaction #t #:eval ev (syntax/loc stx
(pick-example-title e ...) racketinput* e ...)] (titled-interaction
[(_ e ...) H #t #:eval ev (pick-example-title e ...) racketinput* e ...))]
(titled-interaction #t (pick-example-title e ...) racketinput* e ...)])) [(H e ...)
(define-syntax examples* (syntax/loc stx
(syntax-rules () (titled-interaction
[(_ #:eval ev example-title e ...) H #t (pick-example-title e ...) racketinput* e ...))]))
(titled-interaction #t #:eval ev example-title racketinput* e ...)] (define-syntax (examples* stx)
[(_ example-title e ...) (syntax-case stx ()
(titled-interaction #t example-title racketinput* e ...)])) [(H #:eval ev example-title e ...)
(define-syntax defexamples (syntax/loc stx
(syntax-rules () (titled-interaction H #t #:eval ev example-title racketinput* e ...))]
[(_ #:eval ev e ...) [(H example-title e ...)
(titled-interaction #t #:eval ev (syntax/loc stx
(pick-example-title e ...) racketdefinput* e ...)] (titled-interaction H #t example-title racketinput* e ...))]))
[(_ e ...) (define-syntax (defexamples stx)
(titled-interaction #t (syntax-case stx ()
(pick-example-title e ...) racketdefinput* e ...)])) [(H #:eval ev e ...)
(define-syntax defexamples* (syntax/loc stx
(syntax-rules () (titled-interaction
[(_ #:eval ev example-title e ...) H #t #:eval ev (pick-example-title e ...) racketdefinput* e ...))]
(titled-interaction #t #:eval ev example-title racketdefinput* e ...)] [(H e ...)
[(_ example-title e ...) (syntax/loc stx
(titled-interaction #t example-title racketdefinput* e ...)])) (titled-interaction
H #t (pick-example-title e ...) racketdefinput* e ...))]))
(define-syntax (defexamples* stx)
(syntax-case stx ()
[(H #:eval ev example-title e ...)
(syntax/loc stx
(titled-interaction H #t #:eval ev example-title racketdefinput* e ...))]
[(H example-title e ...)
(syntax/loc stx
(titled-interaction H #t example-title racketdefinput* e ...))]))
(define blank-line (make-paragraph (list 'nbsp))) (define blank-line (make-paragraph (list 'nbsp)))