54 lines
1.5 KiB
Racket
54 lines
1.5 KiB
Racket
(module simple frtime
|
|
|
|
(require "fred.ss"
|
|
mzlib/class
|
|
(rename mred frame% frame%))
|
|
|
|
(define widget (lambda (x) x))
|
|
(define value-b (lambda (x) (send x get-value-b)))
|
|
(define value-e (lambda (x) (send x get-value-e)))
|
|
|
|
(define default-parent
|
|
(let ([fr #f])
|
|
(lambda ()
|
|
(unless fr
|
|
(set! fr (new ft-frame%)))
|
|
fr)))
|
|
|
|
(define creation-filter (make-parameter value-b
|
|
(lambda (f) (if (and (procedure? f) (procedure-arity-includes? f 1))
|
|
f
|
|
(error 'creation-filter
|
|
"expected a procedure of arity 1")))))
|
|
|
|
(define current-widget-parent (make-parameter #f))
|
|
|
|
(define-syntax add-widget
|
|
(syntax-rules ()
|
|
[(_ type arg ...)
|
|
((creation-filter) (new type (parent (current-widget-parent)) arg ...))]))
|
|
|
|
|
|
(define (filter-widget w)
|
|
((creation-filter) w))
|
|
|
|
(define-syntax mode
|
|
(syntax-rules ()
|
|
[(_ proc type arg ...) (parameterize ([creation-filter proc])
|
|
(add-widget type arg ...))]))
|
|
|
|
(define-syntax define-values-rec
|
|
(syntax-rules ()
|
|
[(_ [id0 exp0] [id exp] ...)
|
|
(define-values (id0 id ...)
|
|
(letrec ([id0 exp0]
|
|
[id exp] ...)
|
|
(values id0 id ...)))]))
|
|
|
|
|
|
|
|
|
|
(provide (all-defined)
|
|
(all-from "fred.ss")
|
|
(all-from mzlib/class)))
|