eval.rkt (39864B)
1 #lang racket/base 2 3 (require "manual.rkt" "struct.rkt" "scheme.rkt" "decode.rkt" 4 (only-in "core.rkt" content? compound-paragraph plain) 5 racket/contract/base 6 racket/file 7 racket/list 8 file/convertible ;; attached into new namespace via anchor 9 racket/serialize ;; attached into new namespace via anchor 10 racket/pretty ;; attached into new namespace via anchor 11 scribble/private/serialize ;; attached into new namespace via anchor 12 racket/sandbox racket/promise racket/port 13 racket/gui/dynamic 14 (for-syntax racket/base syntax/srcloc racket/struct) 15 racket/stxparam 16 racket/splicing 17 racket/string 18 scribble/text/wrap) 19 20 (provide interaction 21 interaction0 22 interaction/no-prompt 23 interaction-eval 24 interaction-eval-show 25 racketblock+eval (rename-out [racketblock+eval schemeblock+eval]) 26 racketblock0+eval 27 racketmod+eval (rename-out [racketmod+eval schememod+eval]) 28 def+int 29 defs+int 30 examples 31 examples* 32 defexamples 33 defexamples* 34 as-examples 35 36 (contract-out 37 [make-base-eval 38 (->* [] [#:pretty-print? any/c #:lang lang-option/c] #:rest any/c any)] 39 [make-base-eval-factory 40 eval-factory/c] 41 [make-eval-factory 42 eval-factory/c] 43 [close-eval 44 (-> any/c any)] 45 46 [scribble-exn->string 47 (parameter/c (-> any/c string?))] 48 [scribble-eval-handler 49 (parameter/c (-> (-> any/c any) boolean? any/c any))] 50 [make-log-based-eval 51 (-> path-string? (or/c 'record 'replay) any)]) 52 53 with-eval-preserve-source-locations) 54 55 (define lang-option/c 56 (or/c module-path? (list/c 'special symbol?) (cons/c 'begin list?))) 57 58 (define eval-factory/c 59 (->* [(listof module-path?)] [#:pretty-print? any/c #:lang lang-option/c] any)) 60 61 (define scribble-eval-handler 62 (make-parameter (lambda (ev c? x) (ev x)))) 63 64 (define image-counter 0) 65 66 (define maxlen 60) 67 68 (define-namespace-anchor anchor) 69 70 (define (literal-string style s) 71 (let ([m (regexp-match #rx"^(.*)( +|^ )(.*)$" s)]) 72 (if m 73 (make-element #f (list (literal-string style (cadr m)) 74 (hspace (string-length (caddr m))) 75 (literal-string style (cadddr m)))) 76 (make-element style (list s))))) 77 78 (define list.flow.list (compose1 list make-flow list)) 79 80 (define (format-output str style) 81 (if (string=? "" str) 82 '() 83 (list (list.flow.list 84 (let ([s (regexp-split #rx"\n" (regexp-replace #rx"\n$" str ""))]) 85 (if (= 1 (length s)) 86 (make-paragraph (list (literal-string style (car s)))) 87 (make-table 88 #f 89 (map (lambda (s) 90 (list.flow.list 91 (make-paragraph (list (literal-string style s))))) 92 s)))))))) 93 94 (define (format-output-stream in style) 95 (define (add-string string-accum line-accum) 96 (if string-accum 97 (cons (list->string (reverse string-accum)) 98 (or line-accum null)) 99 line-accum)) 100 (define (add-line line-accum flow-accum) 101 (if line-accum 102 (cons (make-paragraph 103 (map (lambda (s) 104 (if (string? s) (literal-string style s) s)) 105 (reverse line-accum))) 106 flow-accum) 107 flow-accum)) 108 (let loop ([string-accum #f] [line-accum #f] [flow-accum null]) 109 (let ([v (read-char-or-special in)]) 110 (cond 111 [(eof-object? v) 112 (let* ([line-accum (add-string string-accum line-accum)] 113 [flow-accum (add-line line-accum flow-accum)]) 114 (if (null? flow-accum) 115 null 116 (list 117 (list.flow.list 118 (if (= 1 (length flow-accum)) 119 (car flow-accum) 120 (make-table 121 #f 122 (map list.flow.list (reverse flow-accum))))))))] 123 [(equal? #\newline v) 124 (loop #f #f (add-line (add-string string-accum line-accum) 125 flow-accum))] 126 [(char? v) 127 (loop (cons v (or string-accum null)) line-accum flow-accum)] 128 [else 129 (loop #f (cons v (or (add-string string-accum line-accum) null)) 130 flow-accum)])))) 131 132 (define (string->wrapped-lines str) 133 (apply 134 append 135 (for/list ([line-str (regexp-split #rx"\n" str)]) 136 (wrap-line line-str maxlen 137 (λ (word fits) 138 (if ((string-length word) . > . maxlen) 139 (values (substring word 0 fits) (substring word fits) #f) 140 (values #f word #f))))))) 141 142 (struct formatted-result (content)) 143 144 (define (interleave inset? title expr-paras promptless?+val-list+outputs) 145 (let ([lines 146 (let loop ([expr-paras expr-paras] 147 [promptless?+val-list+outputs promptless?+val-list+outputs] 148 [first? #t] 149 [after-blank? #t]) 150 (if (null? expr-paras) 151 null 152 (append 153 (if (and (caar promptless?+val-list+outputs) 154 (not after-blank?)) 155 (list (list (list blank-line))) 156 null) 157 (list (list (let ([p (car expr-paras)]) 158 (if (flow? p) p (make-flow (list p)))))) 159 (format-output (cadr (cdar promptless?+val-list+outputs)) output-color) 160 (format-output (caddr (cdar promptless?+val-list+outputs)) error-color) 161 (cond 162 [(string? (cadar promptless?+val-list+outputs)) 163 ;; Error result case: 164 (map (lambda (s) 165 (define p (format-output s error-color)) 166 (if (null? p) 167 (list null) 168 (car p))) 169 (string->wrapped-lines (cadar promptless?+val-list+outputs)))] 170 [(box? (cadar promptless?+val-list+outputs)) 171 ;; Output written to a port 172 (format-output-stream (unbox (cadar promptless?+val-list+outputs)) 173 result-color)] 174 [else 175 ;; Normal result case: 176 (let ([val-list (cadar promptless?+val-list+outputs)]) 177 (if (equal? val-list (list (void))) 178 null 179 (map (lambda (v) 180 (list.flow.list 181 (make-paragraph 182 (list (if (formatted-result? v) 183 (formatted-result-content v) 184 (elem #:style result-color 185 (to-element/no-color 186 v #:expr? (print-as-expression)))))))) 187 val-list)))]) 188 (if (and (caar promptless?+val-list+outputs) 189 (pair? (cdr promptless?+val-list+outputs))) 190 (list (list (list blank-line))) 191 null) 192 (loop (cdr expr-paras) (cdr promptless?+val-list+outputs) #f (caar promptless?+val-list+outputs)))))]) 193 (if inset? 194 (let ([p (code-inset (make-table block-color lines))]) 195 (if title 196 (compound-paragraph 197 plain 198 (list 199 title 200 p)) 201 p)) 202 (if title 203 (compound-paragraph plain 204 (list 205 title 206 (make-table block-color lines))) 207 (make-table block-color lines))))) 208 209 ;; extracts from a datum or syntax object --- while keeping the 210 ;; syntax-objectness of the original intact, instead of always 211 ;; generating a syntax object or always generating a datum 212 (define (extract s . ops) 213 (let loop ([s s] [ops ops]) 214 (cond [(null? ops) s] 215 [(syntax? s) (loop (syntax-e s) ops)] 216 [else (loop ((car ops) s) (cdr ops))]))) 217 218 (struct nothing-to-eval ()) 219 220 (struct eval-results (contents out err)) 221 (define (make-eval-results contents out err) 222 (unless (and (list? contents) 223 (andmap content? contents)) 224 (raise-argument-error 'eval:results "(listof content?)" contents)) 225 (unless (string? out) 226 (raise-argument-error 'eval:results "string?" out)) 227 (unless (string? err) 228 (raise-argument-error 'eval:results "string?" err)) 229 (eval-results contents out err)) 230 (define (make-eval-result content out err) 231 (unless (content? content) 232 (raise-argument-error 'eval:result "content?" content)) 233 (unless (string? out) 234 (raise-argument-error 'eval:result "string?" out)) 235 (unless (string? err) 236 (raise-argument-error 'eval:result "string?" err)) 237 (eval-results (list content) out err)) 238 239 (define (extract-to-evaluate s val handle-one) 240 (let loop ([val val] [s s] [expect #f] [error-expected? #f] [promptless? #f]) 241 (syntax-case s (code:line code:comment code:contract eval:no-prompt eval:alts eval:check eval:error) 242 [(code:line v (code:comment . rest)) 243 (loop val (extract s cdr car) expect error-expected? promptless?)] 244 [(code:line v ...) 245 (for/fold ([val val]) ([v (in-list (extract s cdr))]) 246 (loop val v expect error-expected? promptless?))] 247 [(code:comment . rest) 248 (handle-one val (nothing-to-eval) expect error-expected? promptless?)] 249 [(code:contract . rest) 250 (handle-one val (nothing-to-eval) expect error-expected? promptless?)] 251 [(eval:no-prompt e ...) 252 (for/fold ([val val]) ([v (in-list (extract s cdr))]) 253 (handle-one val v expect error-expected? #t))] 254 [(eval:error e) 255 (handle-one val (extract s cdr car) expect #t promptless?)] 256 [(eval:alts p e) 257 (handle-one val (extract s cdr cdr car) expect error-expected? promptless?)] 258 [(eval:check e expect) 259 (handle-one val 260 (extract s cdr car) 261 (list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))) 262 error-expected? 263 promptless?)] 264 [else (handle-one val s expect error-expected? promptless?)]))) 265 266 (define (do-eval ev who no-errors?) 267 (define (get-outputs) 268 (define (get getter what) 269 (define s (getter ev)) 270 (if (string? s) 271 s 272 (error who "missing ~a, possibly from a sandbox without a `sandbox-~a' configured to 'string" 273 what (string-join (string-split what) "-")))) 274 (list (get get-output "output") (get get-error-output "error output"))) 275 (define (render-value v) 276 (let-values ([(eval-print eval-print-as-expr?) 277 (call-in-sandbox-context ev 278 (lambda () (values (current-print) (print-as-expression))))]) 279 (cond [(and (eq? eval-print (current-print)) 280 eval-print-as-expr?) 281 ;; default printer => get result as S-expression 282 (make-reader-graph (copy-value v (make-hasheq)))] 283 [else 284 ;; other printer => go through a pipe 285 ;; If it happens to be the pretty printer, tell it to retain 286 ;; convertible objects (via write-special) 287 (box (call-in-sandbox-context 288 ev 289 (lambda () 290 (define-values [in out] (make-pipe-with-specials)) 291 (parameterize ((current-output-port out) 292 (pretty-print-size-hook 293 (lambda (obj _mode _out) 294 (and (convertible? obj) 1))) 295 (pretty-print-print-hook 296 (lambda (obj _mode out) 297 (write-special (if (serializable? obj) 298 (make-serialized-convertible 299 (serialize obj)) 300 obj) 301 out)))) 302 (map (current-print) v)) 303 (close-output-port out) 304 in)))]))) 305 (define (do-ev/expect s expect error-expected?) 306 (define-values (val error? render+output) 307 (with-handlers ([(lambda (x) (not (exn:break? x))) 308 (lambda (e) 309 (when (and no-errors? 310 (not error-expected?)) 311 (error 'examples 312 (string-append "exception raised in example\n" 313 " error: ~s") 314 (if (exn? e) 315 (exn-message e) 316 e))) 317 (values e 318 #t 319 (cons ((scribble-exn->string) e) 320 (get-outputs))))]) 321 (define val (do-plain-eval ev s #t)) 322 (values val #f (cons (render-value val) (get-outputs))))) 323 (when (and error-expected? (not error?)) 324 (error 'eval "interaction failed to raise an expected exception: ~.s" s)) 325 (when expect 326 (let ([expect (do-plain-eval ev (car expect) #t)]) 327 (unless (equal? val expect) 328 (define result " result: ") 329 (define expected " expected: ") 330 (error 'eval "example result check failed: ~.s\n~a\n~a\n" 331 s 332 (string-append result (to-lines val (string-length result))) 333 (string-append expected (to-lines expect (string-length expected))))))) 334 render+output) 335 336 (define (to-lines exps blank-space) 337 (define blank (make-string blank-space #\space)) 338 (apply 339 string-append 340 (for/list ([exp (in-list exps)] 341 [i (in-naturals)]) 342 (define first-line? (= i 0)) 343 (if (= i 0) 344 (format "~e" exp) 345 (format "\n~a~e" blank exp))))) 346 347 (lambda (str) 348 (if (eval-results? str) 349 (list #f 350 (map formatted-result (eval-results-contents str)) 351 (eval-results-out str) 352 (eval-results-err str)) 353 (extract-to-evaluate 354 str 355 (list #f (list (void)) "" "") 356 (lambda (result s expect error-expected? promptless?) 357 (if (nothing-to-eval? s) 358 result 359 (cons promptless? (do-ev/expect s expect error-expected?)))))))) 360 361 (module+ test 362 (require rackunit) 363 (test-case 364 "eval:check in interaction" 365 (check-not-exn (λ () (interaction (eval:check #t #t)))))) 366 367 (define scribble-exn->string 368 (make-parameter 369 (λ (e) 370 (if (exn? e) 371 (exn-message e) 372 (format "uncaught exception: ~s" e))))) 373 374 ;; Since we evaluate everything in an interaction before we typeset, 375 ;; copy each value to avoid side-effects. 376 (define (copy-value v ht) 377 (define (install v v2) (hash-set! ht v v2) v2) 378 (let loop ([v v]) 379 (cond 380 [(and v (hash-ref ht v #f)) => (lambda (v) v)] 381 [(syntax? v) (make-literal-syntax v)] 382 [(string? v) (install v (string-copy v))] 383 [(bytes? v) (install v (bytes-copy v))] 384 [(pair? v) 385 (let ([ph (make-placeholder #f)]) 386 (hash-set! ht v ph) 387 (placeholder-set! ph (cons (loop (car v)) (loop (cdr v)))) 388 ph)] 389 [(mpair? v) 390 (let ([p (mcons #f #f)]) 391 (hash-set! ht v p) 392 (set-mcar! p (loop (mcar v))) 393 (set-mcdr! p (loop (mcdr v))) 394 p)] 395 [(vector? v) 396 (let ([v2 (make-vector (vector-length v))]) 397 (hash-set! ht v v2) 398 (for ([i (in-range (vector-length v2))]) 399 (vector-set! v2 i (loop (vector-ref v i)))) 400 v2)] 401 [(box? v) 402 (let ([v2 (box #f)]) 403 (hash-set! ht v v2) 404 (set-box! v2 (loop (unbox v))) 405 v2)] 406 [(hash? v) 407 (let ([ph (make-placeholder #f)]) 408 (hash-set! ht v ph) 409 (let ([a (hash-map v (lambda (k v) (cons (loop k) (loop v))))]) 410 (placeholder-set! 411 ph 412 (cond [(hash-eq? v) (make-hasheq-placeholder a)] 413 [(hash-eqv? v) (make-hasheqv-placeholder a)] 414 [else (make-hash-placeholder a)]))) 415 ph)] 416 [else v]))) 417 418 (define (strip-comments stx) 419 (cond 420 [(syntax? stx) 421 (datum->syntax stx (strip-comments (syntax-e stx)) stx stx stx)] 422 [(pair? stx) 423 (define a (car stx)) 424 (define (comment? a) 425 (and (pair? a) 426 (or (eq? (car a) 'code:comment) 427 (eq? (car a) 'code:contract) 428 (and (identifier? (car a)) 429 (or (eq? (syntax-e (car a)) 'code:comment) 430 (eq? (syntax-e (car a)) 'code:contract)))))) 431 (if (or (comment? a) (and (syntax? a) (comment? (syntax-e a)))) 432 (strip-comments (cdr stx)) 433 (cons (strip-comments a) 434 (strip-comments (cdr stx))))] 435 [(eq? stx 'code:blank) (void)] 436 [else stx])) 437 438 (define (make-base-eval #:lang [lang '(begin)] #:pretty-print? [pretty-print? #t] . ips) 439 (call-with-trusted-sandbox-configuration 440 (lambda () 441 (parameterize ([sandbox-output 'string] 442 [sandbox-error-output 'string] 443 [sandbox-propagate-breaks #f] 444 [sandbox-namespace-specs 445 (append (sandbox-namespace-specs) 446 (if pretty-print? 447 '(racket/pretty) 448 '()) 449 '(file/convertible 450 racket/serialize 451 scribble/private/serialize))]) 452 (let ([e (apply make-evaluator lang ips)]) 453 (when pretty-print? 454 (call-in-sandbox-context e 455 (lambda () 456 (current-print (dynamic-require 'racket/pretty 'pretty-print-handler))))) 457 e))))) 458 459 (define (make-base-eval-factory mod-paths 460 #:lang [lang '(begin)] 461 #:pretty-print? [pretty-print? #t] . ips) 462 (parameterize ([sandbox-namespace-specs 463 (cons (λ () (let ([ns 464 ;; This namespace-creation choice needs to be consistent 465 ;; with the sandbox (i.e., with `make-base-eval') 466 (if gui? 467 ((gui-dynamic-require 'make-gui-empty-namespace)) 468 (make-base-empty-namespace))]) 469 (parameterize ([current-namespace ns]) 470 (for ([mod-path (in-list mod-paths)]) 471 (dynamic-require mod-path #f)) 472 (when pretty-print? (dynamic-require 'racket/pretty #f))) 473 ns)) 474 (append mod-paths (if pretty-print? '(racket/pretty) '())))]) 475 (lambda () 476 (let ([ev (apply make-base-eval #:lang lang #:pretty-print? #f ips)]) 477 (when pretty-print? 478 (call-in-sandbox-context ev 479 (lambda () 480 (current-print (dynamic-require 'racket/pretty 'pretty-print-handler))))) 481 ev)))) 482 483 (define (make-eval-factory mod-paths 484 #:lang [lang '(begin)] 485 #:pretty-print? [pretty-print? #t] . ips) 486 (let ([base-factory (apply make-base-eval-factory mod-paths #:lang lang #:pretty-print? pretty-print? ips)]) 487 (lambda () 488 (let ([ev (base-factory)]) 489 (call-in-sandbox-context 490 ev 491 (lambda () 492 (for ([mod-path (in-list mod-paths)]) 493 (namespace-require mod-path)))) 494 ev)))) 495 496 (define (make-log-based-eval logfile mode) 497 (case mode 498 ((record) (make-eval/record logfile)) 499 ((replay) (make-eval/replay logfile)))) 500 501 (define (make-eval/record logfile) 502 (let* ([ev (make-base-eval)] 503 [super-cust (current-custodian)] 504 [out (parameterize ((current-custodian (get-user-custodian ev))) 505 (open-output-file logfile #:exists 'replace))]) 506 (display ";; This file was created by make-log-based-eval\n" out) 507 (flush-output out) 508 (call-in-sandbox-context ev 509 (lambda () 510 ;; Required for serialization to work. 511 (namespace-attach-module (namespace-anchor->namespace anchor) 'racket/serialize) 512 (let ([old-eval (current-eval)] 513 [init-out-p (current-output-port)] 514 [init-err-p (current-error-port)] 515 [out-p (open-output-bytes)] 516 [err-p (open-output-bytes)]) 517 (current-eval 518 (lambda (x) 519 (let* ([x (syntax->datum (datum->syntax #f x))] 520 [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) (cdr x) x)] 521 [result 522 (with-handlers ([exn? values]) 523 (call-with-values (lambda () 524 (parameterize ((current-eval old-eval) 525 (current-custodian (make-custodian)) 526 (current-output-port out-p) 527 (current-error-port err-p)) 528 (begin0 (old-eval x) 529 (wait-for-threads (current-custodian) super-cust)))) 530 list))] 531 [out-s (get-output-bytes out-p #t)] 532 [err-s (get-output-bytes err-p #t)]) 533 (let ([result* (serialize (cond [(list? result) (cons 'values result)] 534 [(exn? result) (list 'exn (exn-message result))]))]) 535 (pretty-write (list x result* out-s err-s) out) 536 (flush-output out)) 537 (display out-s init-out-p) 538 (display err-s init-err-p) 539 (cond [(list? result) (apply values result)] 540 [(exn? result) (raise result)]))))))) 541 ev)) 542 543 ;; Wait for threads created by evaluation so that the evaluator catches output 544 ;; they generate, etc. 545 ;; FIXME: see what built-in scribble evaluators do 546 (define (wait-for-threads sub-cust super-cust) 547 (let ([give-up-evt (alarm-evt (+ (current-inexact-milliseconds) 200.0))]) 548 ;; find a thread to wait on 549 (define (find-thread cust) 550 (let* ([managed (custodian-managed-list cust super-cust)] 551 [thds (filter thread? managed)] 552 [custs (filter custodian? managed)]) 553 (cond [(pair? thds) (car thds)] 554 [else (ormap find-thread custs)]))) 555 ;; keep waiting on threads (one at a time) until time to give up 556 (define (wait-loop cust) 557 (let ([thd (find-thread cust)]) 558 (when thd 559 (cond [(eq? give-up-evt (sync thd give-up-evt)) (void)] 560 [else (wait-loop cust)])))) 561 (wait-loop sub-cust))) 562 563 (define (make-eval/replay logfile) 564 (let* ([ev (make-base-eval)] 565 [evaluations (file->list logfile)]) 566 (call-in-sandbox-context ev 567 (lambda () 568 (namespace-attach-module (namespace-anchor->namespace anchor) 'racket/serialize) 569 (let ([old-eval (current-eval)] 570 [init-out-p (current-output-port)] 571 [init-err-p (current-error-port)]) 572 (current-eval 573 (lambda (x) 574 (let* ([x (syntax->datum (datum->syntax #f x))] 575 [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) (cdr x) x)]) 576 (unless (and (pair? evaluations) (equal? x (car (car evaluations)))) 577 ;; TODO: smarter resync 578 ;; - can handle *additions* by removing next set! 579 ;; - can handle *deletions* by searching forward (but may jump to far 580 ;; if terms occur more than once, eg for stateful code) 581 ;; For now, just fail early and often. 582 (set! evaluations null) 583 (error 'eval "unable to replay evaluation of ~.s" x)) 584 (let* ([evaluation (car evaluations)] 585 [result (parameterize ((current-eval old-eval)) 586 (deserialize (cadr evaluation)))] 587 [result (case (car result) 588 ((values) (cdr result)) 589 ((exn) (make-exn (cadr result) (current-continuation-marks))))] 590 [output (caddr evaluation)] 591 [error-output (cadddr evaluation)]) 592 (set! evaluations (cdr evaluations)) 593 (display output init-out-p #| (current-output-port) |#) 594 (display error-output init-err-p #| (current-error-port) |#) 595 (cond [(exn? result) (raise result)] 596 [(list? result) (apply values result)])))))))) 597 ev)) 598 599 (define (close-eval e) 600 (kill-evaluator e) 601 "") 602 603 (define (do-plain-eval ev s catching-exns?) 604 (parameterize ([sandbox-propagate-breaks #f]) 605 (call-with-values 606 (lambda () 607 ((scribble-eval-handler) 608 ev 609 catching-exns? 610 (let ([s (strip-comments s)]) 611 (cond [(syntax? s) 612 (syntax-case s (module) 613 [(module . _rest) (syntax->datum s)] 614 [_else s])] 615 ;; a sandbox treats strings and byte strings as code 616 ;; streams, so protect them as syntax objects: 617 [(string? s) (datum->syntax #f s)] 618 [(bytes? s) (datum->syntax #f s)] 619 [else s])))) 620 list))) 621 622 (define-syntax-parameter quote-expr-preserve-source? #f) 623 624 (define-syntax (with-eval-preserve-source-locations stx) 625 (syntax-case stx () 626 [(with-eval-preserve-source-locations e ...) 627 (syntax/loc stx 628 (splicing-syntax-parameterize ([quote-expr-preserve-source? #t]) 629 e ...))])) 630 631 ;; Quote an expression to be evaluated or wrap as escaped: 632 (define-syntax quote-expr 633 (syntax-rules (eval:alts eval:result eval:results) 634 [(_ (eval:alts e1 e2)) (quote-expr e2)] 635 [(_ (eval:result e)) (make-eval-result (list e) "" "")] 636 [(_ (eval:result e out)) (make-eval-result (list e) out "")] 637 [(_ (eval:result e out err)) (make-eval-result (list e) out err)] 638 [(_ (eval:results es)) (make-eval-results es "" "")] 639 [(_ (eval:results es out)) (make-eval-results es out "")] 640 [(_ (eval:results es out err)) (make-eval-results es out err)] 641 [(_ e) (base-quote-expr e)])) 642 643 (define orig-stx (read-syntax 'orig (open-input-string "()"))) 644 645 (define-syntax (base-quote-expr stx) 646 (syntax-case stx () 647 [(_ e) 648 (cond [(syntax-parameter-value #'quote-expr-preserve-source?) 649 ;; Preserve source; produce an expression resulting in a 650 ;; syntax object with no lexical context (like strip-context) 651 ;; but with (quotable) source locations. 652 ;; Also preserve syntax-original?, since that seems important 653 ;; to some syntax-based code (eg redex term->pict). 654 (define (get-source-location e) 655 (let* ([src (build-source-location-list e)] 656 [old-source (source-location-source src)] 657 [new-source 658 (cond [(path? old-source) ;; not quotable/writable 659 ;;(path->string old-source) ;; don't leak build paths 660 'eval] 661 [(or (string? old-source) 662 (symbol? old-source)) 663 ;; Okay? Or should this be replaced also? 664 old-source] 665 [else #f])]) 666 (update-source-location src #:source new-source))) 667 (let loop ([e #'e]) 668 (cond [(syntax? e) 669 (let ([src (get-source-location e)] 670 [original? (syntax-original? (syntax-local-introduce e))]) 671 #`(syntax-property 672 (datum->syntax #f 673 #,(loop (syntax-e e)) 674 (quote #,src) 675 #,(if original? #'orig-stx #'#f)) 676 'paren-shape 677 (quote #,(syntax-property e 'paren-shape))))] 678 [(pair? e) 679 #`(cons #,(loop (car e)) #,(loop (cdr e)))] 680 [(vector? e) 681 #`(list->vector #,(loop (vector->list e)))] 682 [(box? e) 683 #`(box #,(loop (unbox e)))] 684 [(prefab-struct-key e) 685 => (lambda (key) 686 #`(apply make-prefab-struct 687 (quote #,key) 688 #,(loop (struct->list e))))] 689 [else 690 #`(quote #,e)]))] 691 [else 692 ;; Using quote means that sandbox evaluation works on 693 ;; sexprs; to get it to work on syntaxes, use 694 ;; (strip-context (quote-syntax e))) 695 ;; while importing 696 ;; (require syntax/strip-context) 697 #'(quote e)])])) 698 699 (define (do-interaction-eval ev es) 700 (for/fold ([ev ev]) ([e (in-list es)]) 701 (extract-to-evaluate 702 e 703 ev 704 (lambda (ev e expect error-expected?/ignored promptless?/ignored) 705 (cond 706 [(nothing-to-eval? e) ev] 707 [else 708 (parameterize ([current-command-line-arguments #()]) 709 (let ([ev (or ev (make-base-eval))]) 710 (do-plain-eval ev e #f) 711 ev))])))) 712 "") 713 714 (define-syntax interaction-eval 715 (syntax-rules () 716 [(_ #:eval ev e ...) (do-interaction-eval ev (list (quote-expr e) ...))] 717 [(_ e ...) (do-interaction-eval #f (list (quote-expr e) ...))])) 718 719 (define (show-val v) 720 (elem #:style result-color 721 (to-element/no-color v #:expr? (print-as-expression)))) 722 723 (define (do-interaction-eval-show ev es) 724 (parameterize ([current-command-line-arguments #()]) 725 (let ([ev (or ev (make-base-eval))]) 726 (show-val (car (for/fold ([v (list #f)]) ([e (in-list es)]) 727 (extract-to-evaluate 728 e 729 v 730 (lambda (prev-v e expect error-expected?/ignored promptless?/ignored) 731 (do-plain-eval ev e #f))))))))) 732 733 (define-syntax interaction-eval-show 734 (syntax-rules () 735 [(_ #:eval ev e ...) (do-interaction-eval-show ev (list (quote-expr e) ...))] 736 [(_ e ...) (do-interaction-eval-show #f (list (quote-expr e) ...))])) 737 738 (define-syntax racketinput* 739 (syntax-rules (eval:alts code:comment eval:check eval:no-prompt eval:error eval:result eval:results) 740 [(_ #:escape id (code:comment . rest)) (racketblock0 #:escape id (code:comment . rest))] 741 [(_ #:escape id (eval:alts a b)) (racketinput* #:escape id a)] 742 [(_ #:escape id (eval:result a . _)) (racketinput* #:escape id a)] 743 [(_ #:escape id (eval:results a . _)) (racketinput* #:escape id a)] 744 [(_ #:escape id (eval:check a b)) (racketinput* #:escape id a)] 745 [(_ #:escape id (eval:error a)) (racketinput* #:escape id a)] 746 [(_ #:escape id (eval:no-prompt a ...)) (racketblock* #:escape id (code:line a ...))] 747 [(_ #:escape id e) (racketinput0 #:escape id e)])) 748 749 (define-syntax racketblock* 750 (syntax-rules (eval:alts code:comment eval:check eval:no-prompt eval:error eval:result eval:results) 751 [(_ #:escape id (code:comment . rest)) (racketblock0 #:escape id (code:comment . rest))] 752 [(_ #:escape id (eval:alts a b)) (racketblock* #:escape id a)] 753 [(_ #:escape id (eval:result a . _)) (racketinputblock #:escape id a)] 754 [(_ #:escape id (eval:results a . _)) (racketinputblock #:escape id a)] 755 [(_ #:escape id (eval:check a b)) (racketblock #:escape id a)] 756 [(_ #:escape id (eval:no-prompt a ...)) (racketblock #:escape id (code:line a ...))] 757 [(_ #:escape id (eval:error a)) (racketblock #:escape id a)] 758 [(_ #:escape id e) (racketblock0 #:escape id e)])) 759 760 (define-code racketblock0+line (to-paragraph/prefix "" "" (list " "))) 761 762 (define-syntax (racketdefinput* stx) 763 (syntax-case stx (define define-values define-struct) 764 [(_ #:escape id (define . rest)) 765 (syntax-case stx () 766 [(_ #:escape _ e) #'(racketblock0+line #:escape id e)])] 767 [(_ #:escape id (define-values . rest)) 768 (syntax-case stx () 769 [(_ #:escape _ e) #'(racketblock0+line #:escape id e)])] 770 [(_ #:escape id (define-struct . rest)) 771 (syntax-case stx () 772 [(_ #:escape _ e) #'(racketblock0+line #:escape id e)])] 773 [(_ #:escape id (code:line (define . rest) . rest2)) 774 (syntax-case stx () 775 [(_ #:escape _ e) #'(racketblock0+line #:escape id e)])] 776 [(_ #:escape id e) #'(racketinput* #:escape id e)])) 777 778 (define (do-titled-interaction who inset? no-errors? ev t shows evals) 779 (interleave inset? t shows (map (do-eval ev who no-errors?) evals))) 780 781 (define-syntax titled-interaction 782 (syntax-rules () 783 [(_ who inset? t racketinput* 784 #:eval ev #:escape unsyntax-id #:no-errors? no-errors? 785 e ...) 786 (do-titled-interaction 787 'who inset? no-errors? ev t 788 (list (racketinput* #:escape unsyntax-id e) ...) 789 (list (quote-expr e) ...))] 790 791 [(_ who inset? t racketinput* 792 #:eval ev #:escape unsyntax-id 793 e ...) 794 (titled-interaction 795 who inset? t racketinput* 796 #:eval ev #:escape unsyntax-id #:no-errors? #f 797 e ...)] 798 [(_ who inset? t racketinput* 799 #:eval ev #:no-errors? no-errors? 800 e ...) 801 (titled-interaction 802 who inset? t racketinput* 803 #:eval ev #:escape unsyntax #:no-errors? no-errors? 804 e ...)] 805 [(_ who inset? t racketinput* 806 #:escape unsyntax-id #:no-errors? no-errors? 807 e ...) 808 (titled-interaction 809 who inset? t racketinput* 810 #:eval (make-base-eval) #:escape unsyntax-id #:no-errors? no-errors? 811 e ...)] 812 [(_ who inset? t racketinput* 813 #:eval ev 814 e ...) 815 (titled-interaction 816 who inset? t racketinput* 817 #:eval ev #:escape unsyntax #:no-errors? #f 818 e ...)] 819 [(_ who inset? t racketinput* 820 #:escape unsyntax-id 821 e ...) 822 (titled-interaction 823 who inset? t racketinput* 824 #:eval (make-base-eval) #:escape unsyntax-id 825 e ...)] 826 [(_ who inset? t racketinput* 827 #:no-errors? no-errors? 828 e ...) 829 (titled-interaction 830 who inset? t racketinput* 831 #:eval (make-base-eval) #:escape unsyntax #:no-errors? no-errors? 832 e ...)] 833 [(_ who inset? t racketinput* e ...) 834 (titled-interaction 835 who inset? t racketinput* 836 #:eval (make-base-eval) #:escape unsyntax #:no-errors? #f 837 e ...)])) 838 839 (define-syntax (-interaction stx) 840 (syntax-case stx () 841 [(_ who e ...) 842 (syntax/loc stx 843 (titled-interaction who #f #f racketinput* e ...))])) 844 845 (define-syntax (interaction stx) 846 (syntax-case stx () 847 [(H e ...) (syntax/loc stx (code-inset (-interaction H e ...)))])) 848 849 (define-syntax (interaction/no-prompt stx) 850 (syntax-case stx () 851 [(H e ...) 852 (syntax/loc stx 853 (code-inset (titled-interaction who #f #f racketblock* e ...)))])) 854 855 (define-syntax (interaction0 stx) 856 (syntax-case stx () 857 [(H e ...) (syntax/loc stx (-interaction H e ...))])) 858 859 (define-syntax racketblockX+eval 860 (syntax-rules () 861 [(_ racketblock #:eval ev #:escape unsyntax-id e ...) 862 (let ([eva ev]) 863 (#%expression 864 (begin (interaction-eval #:eval eva e ...) 865 (racketblock #:escape unsyntax-id e ...))))] 866 [(_ racketblock #:eval ev e ...) 867 (racketblockX+eval racketblock #:eval ev #:escape unsyntax e ...)] 868 [(_ racketblock #:escape unsyntax-id e ...) 869 (racketblockX+eval racketblock #:eval (make-base-eval) #:escape unsyntax-id e ...)] 870 [(_ racketblock e ...) 871 (racketblockX+eval racketblock #:eval (make-base-eval) #:escape unsyntax e ...)])) 872 873 (define-syntax racketblock+eval 874 (syntax-rules () 875 [(_ e ...) 876 (racketblockX+eval racketblock e ...)])) 877 878 (define-syntax racketblock0+eval 879 (syntax-rules () 880 [(_ e ...) 881 (racketblockX+eval racketblock0 e ...)])) 882 883 (define-syntax racketmod+eval 884 (syntax-rules () 885 [(_ #:eval ev #:escape unsyntax-id name e ...) 886 (let ([eva ev]) 887 (#%expression 888 (begin (interaction-eval #:eval eva e ...) 889 (racketmod #:escape unsyntax-id name e ...))))] 890 [(_ #:eval ev name e ...) 891 (racketmod+eval #:eval ev #:escape unsyntax name e ...)] 892 [(_ #:escape unsyntax-id name e ...) 893 (racketmod+eval #:eval (make-base-eval) #:escape unsyntax-id name e ...)] 894 [(_ name e ...) 895 (racketmod+eval #:eval (make-base-eval) #:escape unsyntax name e ...)])) 896 897 (define-syntax (defs+int stx) 898 (syntax-case stx () 899 [(H #:eval ev #:escape unsyntax-id [def ...] e ...) 900 (syntax/loc stx 901 (let ([eva ev]) 902 (column (list (racketblock0+eval #:eval eva #:escape unsyntax-id def ...) 903 blank-line 904 (-interaction H #:eval eva #:escape unsyntax-id e ...)))))] 905 [(H #:eval ev [def ...] e ...) 906 (syntax/loc stx (defs+int #:eval ev #:escape unsyntax [def ...] e ...))] 907 [(_ #:escape unsyntax-id [def ...] e ...) 908 (syntax/loc stx (defs+int #:eval (make-base-eval) #:escape unsyntax-id [def ...] e ...))] 909 [(_ [def ...] e ...) 910 (syntax/loc stx (defs+int #:eval (make-base-eval) [def ...] e ...))])) 911 912 (define-syntax def+int 913 (syntax-rules () 914 [(H #:eval ev #:escape unsyntax-id def e ...) 915 (defs+int #:eval ev #:escape unsyntax-id [def] e ...)] 916 [(H #:eval ev def e ...) 917 (defs+int #:eval ev [def] e ...)] 918 [(H #:escape unsyntax-id def e ...) 919 (defs+int #:escape unsyntax-id [def] e ...)] 920 [(H def e ...) 921 (defs+int [def] e ...)])) 922 923 (define example-title 924 (make-paragraph (list "Example:"))) 925 (define examples-title 926 (make-paragraph (list "Examples:"))) 927 928 (define-syntax pick-example-title 929 (syntax-rules () 930 [(_ e) example-title] 931 [(_ #:eval ev e) example-title] 932 [(_ #:escape id e) example-title] 933 [(_ #:eval ev #:escape id e) example-title] 934 [(_ . _) examples-title])) 935 936 (define-syntax (examples stx) 937 (syntax-case stx () 938 [(H e ...) 939 (syntax/loc stx 940 (titled-interaction 941 H #t (pick-example-title e ...) racketinput* e ...))])) 942 (define-syntax (examples* stx) 943 (syntax-case stx () 944 [(H example-title e ...) 945 (syntax/loc stx 946 (titled-interaction H #t example-title racketinput* e ...))])) 947 (define-syntax (defexamples stx) 948 (syntax-case stx () 949 [(H e ...) 950 (syntax/loc stx 951 (titled-interaction 952 H #t (pick-example-title e ...) racketdefinput* e ...))])) 953 (define-syntax (defexamples* stx) 954 (syntax-case stx () 955 [(H example-title e ...) 956 (syntax/loc stx 957 (titled-interaction H #t example-title racketdefinput* e ...))])) 958 959 (define blank-line (make-paragraph (list 'nbsp))) 960 961 (define (column l) 962 (code-inset (make-table #f (map list.flow.list l)))) 963 964 (define (do-splice l) 965 (cond [(null? l) null] 966 [(splice? (car l)) `(,@(splice-run (car l)) ,@(do-splice (cdr l)))] 967 [else (cons (car l) (do-splice (cdr l)))])) 968 969 (define as-examples 970 (case-lambda 971 [(t) (as-examples examples-title t)] 972 [(example-title t) 973 (if example-title 974 (compound-paragraph 975 plain 976 (list 977 (if (block? example-title) 978 example-title 979 (make-paragraph (list example-title))) 980 t)) 981 t)]))