60 lines
2.0 KiB
Racket
60 lines
2.0 KiB
Racket
(module scheme-gui scheme/base
|
|
|
|
(require mred framework scheme/class
|
|
mzlib/pconvert mzlib/pretty
|
|
(for-syntax scheme/base))
|
|
|
|
(require (except-in "scheme-tests.ss" test) "test-display.scm")
|
|
|
|
(define (make-formatter printer)
|
|
(lambda (value)
|
|
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
|
[text-snip (new editor-snip% [editor text*])])
|
|
(printer value (open-output-text-editor text* 0))
|
|
(send text* delete (send text* get-end-position) 'back)
|
|
(send text* lock #t)
|
|
text-snip)))
|
|
|
|
(define (format-value value)
|
|
(parameterize ([constructor-style-printing #t]
|
|
[pretty-print-columns 40])
|
|
(make-formatter (lambda (v o) (pretty-print (print-convert v) o)))))
|
|
|
|
#;(define (format-value value)
|
|
(cond
|
|
[(is-a? value snip%) value]
|
|
[(or (pair? value) (struct? value))
|
|
(parameterize ([constructor-style-printing #t]
|
|
[pretty-print-columns 40])
|
|
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
|
[text-snip (new editor-snip% [editor text*])])
|
|
(pretty-print (print-convert value) (open-output-text-editor text*))
|
|
(send text* lock #t)
|
|
text-snip))]
|
|
[else (format "~v" value)]))
|
|
|
|
(define (test*)
|
|
(printf "test*\n")
|
|
(run-tests)
|
|
(pop-up))
|
|
|
|
(define-syntax (test stx)
|
|
(syntax-case stx ()
|
|
[(_)
|
|
(syntax-property
|
|
#'(test*)
|
|
'test-call #t)]))
|
|
|
|
(define (pop-up)
|
|
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
|
(parameterize ([test-format format-value])
|
|
(and test-info
|
|
(send test-info refine-display-class test-display%)
|
|
(send test-info setup-display #f #f)
|
|
(printf "calling summarize-results method\n")
|
|
(send test-info summarize-results (current-output-port))))))
|
|
|
|
(provide test format-value make-formatter (all-from-out "scheme-tests.ss"))
|
|
|
|
)
|