commit 37dbe64ec48a12f14b515f8c306443b67f9134fd
parent 7a5f07fc4dd88ff2832517fdb9ed703fa3d0f542
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 3 Mar 2009 23:02:24 +0000
scriblib
svn: r13932
original commit: 826263c6297915d7735bf45b4071cb0a68bdeca8
Diffstat:
5 files changed, 187 insertions(+), 0 deletions(-)
diff --git a/collects/scriblib/gui-eval.ss b/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)))]))
diff --git a/collects/scriblib/private/mr-eval-exn.ss b/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))
diff --git a/collects/scriblib/scribblings/gui-eval.scrbl b/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]. }
diff --git a/collects/scriblib/scribblings/info.ss b/collects/scriblib/scribblings/info.ss
@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define scribblings '(("scriblib.scrbl" (multi-page))))
diff --git a/collects/scriblib/scribblings/scriblib.scrbl b/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"]
