From 37dbe64ec48a12f14b515f8c306443b67f9134fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Mar 2009 23:02:24 +0000 Subject: [PATCH] scriblib svn: r13932 original commit: 826263c6297915d7735bf45b4071cb0a68bdeca8 --- collects/scriblib/gui-eval.ss | 140 +++++++++++++++++++ collects/scriblib/private/mr-eval-exn.ss | 6 + collects/scriblib/scribblings/gui-eval.scrbl | 31 ++++ collects/scriblib/scribblings/info.ss | 3 + collects/scriblib/scribblings/scriblib.scrbl | 7 + 5 files changed, 187 insertions(+) create mode 100644 collects/scriblib/gui-eval.ss create mode 100644 collects/scriblib/private/mr-eval-exn.ss create mode 100644 collects/scriblib/scribblings/gui-eval.scrbl create mode 100644 collects/scriblib/scribblings/info.ss create mode 100644 collects/scriblib/scribblings/scriblib.scrbl diff --git a/collects/scriblib/gui-eval.ss b/collects/scriblib/gui-eval.ss new file mode 100644 index 00000000..e2ccbcfc --- /dev/null +++ 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 new file mode 100644 index 00000000..daad531f --- /dev/null +++ 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 new file mode 100644 index 00000000..84d1e06e --- /dev/null +++ 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 new file mode 100644 index 00000000..e7e57e04 --- /dev/null +++ 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 new file mode 100644 index 00000000..cf000654 --- /dev/null +++ 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"]