scriblib

svn: r13932

original commit: 826263c6297915d7735bf45b4071cb0a68bdeca8

collects/scriblib/gui-eval.ss

@@ -0,0 +1,140 @@
+#lang scheme/base
+
+(require scribble/eval
+         scribble/struct
+         scribble/scheme
+         scheme/class
+         scheme/file
+         scheme/runtime-path
+         scheme/serialize
+         "private/mr-eval-exn.ss"
+         scheme/system)
+
+(define-syntax define-mr
+  (syntax-rules ()
+    [(_ mr orig)
+     (begin
+       (provide mr)
+       (define-syntax mr
+         (syntax-rules ()
+           [(_ x (... ...))
+            (parameterize ([scribble-eval-handler gui-eval-handler])
+              (orig #:eval gui-eval x (... ...)))])))]))
+
+(define gui-eval (make-base-eval))
+
+(define-mr gui-interaction interaction)
+(define-mr gui-interaction-eval interaction-eval)
+(define-mr gui-interaction-eval-show interaction-eval-show)
+(define-mr gui-def+int def+int)
+(define-mr gui-defs+int defs+int)
+(define-mr gui-schememod+eval schememod+eval)
+(define-mr gui-schemeblock+eval schemeblock+eval)
+
+(define mred? (getenv "MREVAL"))
+
+(when mred?
+  (gui-eval '(require scheme/gui/base))
+  (gui-eval '(require slideshow)))
+
+;; This one needs to be relative, because it ends up in the
+;;  exprs.dat file:
+(define img-dir "images") ; relative to src dir
+
+;; This one can be absolute:
+(define exprs-dat-file (build-path "images"
+                                   "exprs.dat"))
+
+(define gui-eval-handler
+  (if mred?
+      (let ([eh (scribble-eval-handler)]
+            [log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)])
+        (lambda (ev catching-exns? expr)
+          (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file)
+          (newline log-file)
+          (flush-output log-file)
+          (let ([result
+                 (with-handlers ([exn:fail?
+                                  (lambda (exn)
+                                    (make-gui-exn (exn-message exn)))])
+                   (eh ev catching-exns? expr))])
+            (let ([result (fixup-picts result)])
+              (write (serialize result) log-file)
+              (newline log-file)
+              (flush-output log-file)
+              (if (gui-exn? result)
+                  (raise (make-exn:fail
+                          (gui-exn-message result)
+                          (current-continuation-marks)))
+                  result)))))
+      (let ([log-file (with-handlers ([exn:fail:filesystem?
+                                       (lambda (exn)
+                                         (open-input-string ""))])
+                        (open-input-file exprs-dat-file))])
+        (lambda (ev catching-exns? expr)
+          (with-handlers ([exn:fail? (lambda (exn)
+                                       (if catching-exns?
+                                           (raise exn)
+                                           (void)))])
+            (let ([v (read log-file)])
+              (if (eof-object? v)
+                  (error "expression not in log file")
+                  (let ([v (deserialize v)])
+                    (if (equal? v (if (syntax? expr)
+                                      (syntax->datum expr)
+                                      expr))
+                        (let ([v (read log-file)])
+                          (if (eof-object? v)
+                              (error "expression result missing in log file")
+                              (let ([v (deserialize v)])
+                                (if (gui-exn? v)
+                                    (raise (make-exn:fail
+                                            (gui-exn-message v)
+                                            (current-continuation-marks)))
+                                    v))))
+                        (error 'mreval
+                               "expression does not match log file: ~e versus: ~e"
+                               expr
+                               v))))))))))
+
+(define image-counter 0)
+
+;; This path will be marshaled for use on multiple platforms
+(define (build-string-path a b) (string-append a "/" b))
+
+(define (fixup-picts v)
+  (cond
+   [((gui-eval 'pict?) v)
+    (let ([fn (build-string-path img-dir
+                                 (format "img~a.png" image-counter))])
+      (set! image-counter (add1 image-counter))
+      (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))])
+                  (send pss set-mode 'file)
+                  (send pss set-file (path-replace-suffix fn #".ps"))
+                  (parameterize ([(gui-eval 'current-ps-setup) pss])
+                    (make-object (gui-eval 'post-script-dc%) #f)))])
+        (send dc start-doc "Image")
+        (send dc start-page)
+        (((gui-eval 'make-pict-drawer) v) dc 0 0)
+        (send dc end-page)
+        (send dc end-doc)
+        (system (format "epstopdf ~a" (path-replace-suffix fn #".ps"))))
+      (let* ([bm (make-object (gui-eval 'bitmap%)
+                              (inexact->exact (ceiling ((gui-eval 'pict-width) v)))
+                              (inexact->exact (ceiling ((gui-eval 'pict-height) v))))]
+             [dc (make-object (gui-eval 'bitmap-dc%) bm)])
+        (send dc set-smoothing 'aligned)
+        (send dc clear)
+        (((gui-eval 'make-pict-drawer) v) dc 0 0)
+        (send bm save-file fn 'png)
+        (make-element #f (list (make-element (make-image-file 
+                                              ;; For HTML output, .pdf is automatically changed to .png.
+                                              ;; Be sure to use a string rather than a path, because
+                                              ;; it gets recorded in "exprs.dat".
+                                              (path->string (path-replace-suffix fn #".pdf"))
+                                              1.0) 
+                                             (list "[image]"))))))]
+   [(pair? v) (cons (fixup-picts (car v))
+                    (fixup-picts (cdr v)))]
+   [(serializable? v) v]
+   [else (make-element #f (list (format "~s" v)))]))

collects/scriblib/private/mr-eval-exn.ss

@@ -0,0 +1,6 @@
+#lang scheme/base
+(require mzlib/serialize)
+
+(define-serializable-struct gui-exn (message))
+
+(provide (struct-out gui-exn))

collects/scriblib/scribblings/gui-eval.scrbl

@@ -0,0 +1,31 @@
+#lang scribble/manual
+@(require (for-label scribble/eval scriblib/gui-eval))
+
+@title[#:tag "gui-eval"]{Writing Examples with Pict Results}
+
+@defmodule[scriblib/gui-eval]{The
+@schememodname[scriblib/gui-eval] library support example
+evaluations with results that are @schememodname[slideshow] picts.}
+
+The trick is that @schememodname[scheme/gui] is not generally
+available when rendering documentation, because it requires a GUI
+context. The picture output is rendered to an image file when the
+@envvar{MREVAL} environment variable is set, so run the enclosing
+document once with the environment varibale to generate the
+images. Future runs (with the environment variable unset) use the
+generated image.
+
+@deftogether[(
+@defform[(gui-interaction datum ...)]
+@defform[(gui-interaction-eval datum ...)]
+@defform[(gui-interaction-eval-show datum ...)]
+@defform[(gui-schemeblock+eval datum ...)]
+@defform[(gui-schememod+eval datum ...)]
+@defform[(gui-def+int datum ...)]
+@defform[(gui-defs+int datum ...)]
+)]{
+
+Like @scheme[interaction], etc., but actually evaluating the forms
+only when the @envvar{MREVAL} environment variable is set, and then in
+an evaluator that is initialized with @schememodname[scheme/gui/base]
+and @schememodname[slideshow]. }

collects/scriblib/scribblings/info.ss

@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define scribblings '(("scriblib.scrbl" (multi-page))))

collects/scriblib/scribblings/scriblib.scrbl

@@ -0,0 +1,7 @@
+#lang scribble/manual
+
+@title{@bold{Scriblib}: Extra Scribble Libraries}
+
+@table-of-contents[]
+
+@include-section["gui-eval.scrbl"]