175 lines
7.7 KiB
Racket
175 lines
7.7 KiB
Racket
#lang racket/base
|
|
|
|
(require scribble/eval
|
|
scribble/core
|
|
scribble/scheme
|
|
racket/class
|
|
racket/file
|
|
racket/runtime-path
|
|
racket/serialize
|
|
"private/gui-eval-exn.rkt"
|
|
racket/system
|
|
racket/sandbox
|
|
(for-syntax racket/base))
|
|
|
|
(define-syntax define-mr
|
|
(syntax-rules ()
|
|
[(_ mr orig)
|
|
(begin
|
|
(provide mr)
|
|
(define-syntax (mr stx)
|
|
(syntax-case stx ()
|
|
[(_ #:eval+opts the-eval get-predicate? get-render get-get-width get-get-height x (... ...))
|
|
#'(let ([the-eval-x the-eval])
|
|
(parameterize ([scribble-eval-handler (gui-eval-handler the-eval-x
|
|
get-predicate?
|
|
get-render
|
|
get-get-width
|
|
get-get-height)])
|
|
(orig #:eval the-eval-x x (... ...))))]
|
|
[(_ x (... ...))
|
|
#'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval
|
|
(λ () (gui-eval 'pict?))
|
|
(λ () (gui-eval 'draw-pict))
|
|
(λ () (gui-eval 'pict-width))
|
|
(λ () (gui-eval 'pict-height)))])
|
|
(orig #:eval gui-eval x (... ...)))])))]))
|
|
|
|
(define gui-eval (make-base-eval #:pretty-print? #f))
|
|
|
|
(define mred? (getenv "MREVAL"))
|
|
(define-namespace-anchor anchor)
|
|
|
|
(when mred?
|
|
(call-in-sandbox-context gui-eval
|
|
(lambda ()
|
|
(namespace-attach-module (namespace-anchor->namespace anchor)
|
|
'racket/class)))
|
|
(gui-eval '(require racket/gui/base))
|
|
(gui-eval '(require slideshow)))
|
|
|
|
(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-racketmod+eval racketmod+eval)
|
|
(define-mr gui-racketblock+eval racketblock+eval)
|
|
|
|
(provide (rename-out [gui-racketmod+eval gui-schememod+eval]
|
|
[gui-racketblock+eval gui-schemeblock+eval]))
|
|
|
|
;; 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)])
|
|
(λ (gui-eval get-predicate? get-render get-get-width get-get-height)
|
|
(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)))])
|
|
;; put the call to fixup-picts in the handlers
|
|
;; so that errors in the user-supplied predicates &
|
|
;; conversion functions show up in the rendered output
|
|
(fixup-picts (get-predicate?) (get-render) (get-get-width) (get-get-height)
|
|
(eh ev catching-exns? expr)))])
|
|
(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))])
|
|
(λ (gui-eval get-predicate? get-render get-get-width get-get-height)
|
|
(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 predicate? render get-width get-height v)
|
|
(let loop ([v v])
|
|
(cond
|
|
[(predicate? 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 #".pdf"))
|
|
(parameterize ([(gui-eval 'current-ps-setup) pss])
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(send pss get-scaling xb yb)
|
|
(new (gui-eval 'pdf-dc%)
|
|
[interactive #f]
|
|
[width (* (unbox xb) (get-width v))]
|
|
[height (* (unbox yb) (get-height v))]))))])
|
|
(send dc start-doc "Image")
|
|
(send dc start-page)
|
|
(render v dc 0 0)
|
|
(send dc end-page)
|
|
(send dc end-doc))
|
|
(let* ([bm (make-object (gui-eval 'bitmap%)
|
|
(inexact->exact (ceiling (get-width v)))
|
|
(inexact->exact (ceiling (get-height v))))]
|
|
[dc (make-object (gui-eval 'bitmap-dc%) bm)])
|
|
(send dc set-smoothing 'aligned)
|
|
(send dc clear)
|
|
(render v dc 0 0)
|
|
(send bm save-file fn 'png)
|
|
(make-image-element
|
|
#f
|
|
(list "[image]")
|
|
;; Be sure to use a string rather than a path, because
|
|
;; it gets recorded in "exprs.dat".
|
|
(path->string (path-replace-suffix fn #""))
|
|
'(".pdf" ".png")
|
|
1.0)))]
|
|
[(pair? v) (cons (loop (car v))
|
|
(loop (cdr v)))]
|
|
[(serializable? v) v]
|
|
[else (make-element #f (list (format "~s" v)))])))
|