Merge unstable/sandbox with scribble/eval.

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

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)
   "")