commit ea707070360ca276302f5ac0ddead8085df2850e
parent 8a490208c570b2079b8f6b1f13e5469196bf68f0
Author: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 23 Jul 2015 15:04:44 -0500
Merge unstable/sandbox with scribble/eval.
Diffstat:
2 files changed, 135 insertions(+), 0 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/eval.scrbl b/scribble-doc/scribblings/scribble/eval.scrbl
@@ -214,6 +214,32 @@ Like @racket[make-base-eval-factory], but each module in @racket[mod-paths] is
also required into the top-level environment for each generated evaluator.}
+@defproc[(make-log-based-eval [log-file path-string?]
+ [mode (or/c 'record 'replay)])
+ (-> any/c any)]{
+
+Creates an evaluator (like @racket[make-base-eval]) that uses a log
+file to either record or replay evaluations.
+
+If @racket[mode] is @racket['record], the evaluator records every
+interaction to @racket[log-file], replacing @racket[log-file] if it
+already exists. The result of each interaction must be
+@seclink["serialization" #:doc '(lib
+"scribblings/reference/reference.scrbl")]{serializable}.
+
+If @racket[mode] is @racket['replay], the evaluator uses the contents
+of @racket[log-file] instead of actually performing evaluatings. For
+each interaction, it compares the term to evaluate against the next
+interaction recorded in @racket[log-file]. If the term matches, the
+stored result is returned; if not, the evaluator raises an error
+indicating that it is out of sync with @racket[log-file].
+
+Use @racket[make-log-based-eval] to document libraries when the
+embedded examples rely on external features that may not be present or
+appropriately configured on all machines.
+}
+
+
@defproc[(close-eval [eval (any/c . -> . any)]) (one-of/c "")]{
Shuts down an evaluator produced by @racket[make-base-eval]. Use
diff --git a/scribble-lib/scribble/eval.rkt b/scribble-lib/scribble/eval.rkt
@@ -2,6 +2,8 @@
(require "manual.rkt" "struct.rkt" "scheme.rkt" "decode.rkt"
(only-in "core.rkt" content?)
+ racket/contract/base
+ racket/file
racket/list
file/convertible ;; attached into new namespace via anchor
racket/serialize ;; attached into new namespace via anchor
@@ -40,6 +42,10 @@
scribble-eval-handler
with-eval-preserve-source-locations)
+(provide/contract
+ [make-log-based-eval
+ (-> path-string? (or/c 'record 'replay) (-> any/c any))])
+
(define scribble-eval-handler
(make-parameter (lambda (ev c? x) (ev x))))
@@ -401,6 +407,109 @@
(namespace-require mod-path))))
ev))))
+(define (make-log-based-eval logfile mode)
+ (case mode
+ ((record) (make-eval/record logfile))
+ ((replay) (make-eval/replay logfile))))
+
+(define (make-eval/record logfile)
+ (let* ([ev (make-base-eval)]
+ [super-cust (current-custodian)]
+ [out (parameterize ((current-custodian (get-user-custodian ev)))
+ (open-output-file logfile #:exists 'replace))])
+ (display ";; This file was created by make-log-based-eval\n" out)
+ (flush-output out)
+ (call-in-sandbox-context ev
+ (lambda ()
+ ;; Required for serialization to work.
+ (namespace-attach-module (namespace-anchor->namespace anchor) 'racket/serialize)
+ (let ([old-eval (current-eval)]
+ [init-out-p (current-output-port)]
+ [init-err-p (current-error-port)]
+ [out-p (open-output-bytes)]
+ [err-p (open-output-bytes)])
+ (current-eval
+ (lambda (x)
+ (let* ([x (syntax->datum (datum->syntax #f x))]
+ [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) (cdr x) x)]
+ [result
+ (with-handlers ([exn? values])
+ (call-with-values (lambda ()
+ (parameterize ((current-eval old-eval)
+ (current-custodian (make-custodian))
+ (current-output-port out-p)
+ (current-error-port err-p))
+ (begin0 (old-eval x)
+ (wait-for-threads (current-custodian) super-cust))))
+ list))]
+ [out-s (get-output-bytes out-p #t)]
+ [err-s (get-output-bytes err-p #t)])
+ (let ([result* (serialize (cond [(list? result) (cons 'values result)]
+ [(exn? result) (list 'exn (exn-message result))]))])
+ (pretty-write (list x result* out-s err-s) out)
+ (flush-output out))
+ (display out-s init-out-p)
+ (display err-s init-err-p)
+ (cond [(list? result) (apply values result)]
+ [(exn? result) (raise result)])))))))
+ ev))
+
+;; Wait for threads created by evaluation so that the evaluator catches output
+;; they generate, etc.
+;; FIXME: see what built-in scribble evaluators do
+(define (wait-for-threads sub-cust super-cust)
+ (let ([give-up-evt (alarm-evt (+ (current-inexact-milliseconds) 200.0))])
+ ;; find a thread to wait on
+ (define (find-thread cust)
+ (let* ([managed (custodian-managed-list cust super-cust)]
+ [thds (filter thread? managed)]
+ [custs (filter custodian? managed)])
+ (cond [(pair? thds) (car thds)]
+ [else (ormap find-thread custs)])))
+ ;; keep waiting on threads (one at a time) until time to give up
+ (define (wait-loop cust)
+ (let ([thd (find-thread cust)])
+ (when thd
+ (cond [(eq? give-up-evt (sync thd give-up-evt)) (void)]
+ [else (wait-loop cust)]))))
+ (wait-loop sub-cust)))
+
+(define (make-eval/replay logfile)
+ (let* ([ev (make-base-eval)]
+ [evaluations (file->list logfile)])
+ (call-in-sandbox-context ev
+ (lambda ()
+ (namespace-attach-module (namespace-anchor->namespace anchor) 'racket/serialize)
+ (let ([old-eval (current-eval)]
+ [init-out-p (current-output-port)]
+ [init-err-p (current-error-port)])
+ (current-eval
+ (lambda (x)
+ (let* ([x (syntax->datum (datum->syntax #f x))]
+ [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) (cdr x) x)])
+ (unless (and (pair? evaluations) (equal? x (car (car evaluations))))
+ ;; TODO: smarter resync
+ ;; - can handle *additions* by removing next set!
+ ;; - can handle *deletions* by searching forward (but may jump to far
+ ;; if terms occur more than once, eg for stateful code)
+ ;; For now, just fail early and often.
+ (set! evaluations null)
+ (error 'eval "unable to replay evaluation of ~.s" x))
+ (let* ([evaluation (car evaluations)]
+ [result (parameterize ((current-eval old-eval))
+ (deserialize (cadr evaluation)))]
+ [result (case (car result)
+ ((values) (cdr result))
+ ((exn) (make-exn (cadr result) (current-continuation-marks))))]
+ [output (caddr evaluation)]
+ [error-output (cadddr evaluation)])
+ (set! evaluations (cdr evaluations))
+ (display output init-out-p #| (current-output-port) |#)
+ (display error-output init-err-p #| (current-error-port) |#)
+ (cond [(exn? result) (raise result)]
+ [(list? result) (apply values result)]))))))))
+ ev))
+
(define (close-eval e)
(kill-evaluator e)
"")
