suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improved decoupling of scheme tests and MrEd, including different import files for textual versus graphical reporting

Browse Source 
svn: r9220
This commit is contained in:
Kathy Gray 2008-04-09 13:28:22 +00:00
parent 6a4414c82b
commit 0584d7fc53
6 changed files with 116 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/combinator-parser/private-combinator/combinator.scm
View File

@ -607,14 +607,14 @@
(cond
[(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)]
[(null? curr-input)
#;(printf "out of input for ~a~n" repeat-name)
#;(printf "out of input for ~a~n" (repeat-name))
(make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)]
[else
(let ([this-res (sub curr-input curr-src)])
#;(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name))
(cond
[(and (res? this-res) (res-a this-res))
#;(printf "loop again case for ~a~n" repeat-name)
#;(printf "loop again case for ~a~n" (repeat-name))
(process-rest this-res
(loop (res-rest this-res)
(update-src (res-rest this-res) curr-src)))]
@ -650,8 +650,8 @@
curr-src)))]
[else
(map (lambda (match)
#;(printf "calling repeat loop again, res-rest match ~a~n"
(length (res-rest match)))
#;(printf "calling repeat loop again ~a, res-rest match ~a~n"
(repeat-name) (length (res-rest match)))
(process-rest match
(loop (res-rest match)
(update-src (res-rest match) curr-src))))

6
collects/lang/htdp-langs.ss
View File

@ -38,7 +38,8 @@
"run-teaching-program.ss"
stepper/private/shared
(lib "scheme-gui.scm" "test-engine")
(only test-engine/scheme-gui format-value)
(only test-engine/scheme-tests scheme-test-data scheme-test-format)
(lib "test-display.scm" "test-engine")
)
@ -160,7 +161,7 @@
[set-result-module-name
((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f)]
[scheme-test-module-name
((current-module-name-resolver) '(lib "test-engine/scheme-gui.scm") #f #f)])
((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)])
(run-in-user-thread
(lambda ()
(read-accept-quasiquote (get-accept-quasiquote?))
@ -175,6 +176,7 @@
(namespace-attach-module drs-namespace scheme-test-module-name)
(namespace-require scheme-test-module-name)
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
(scheme-test-format format-value)
)))
(super on-execute settings run-in-user-thread))

8
collects/profj/comb-parsers/parser-units.scm
View File

@ -353,7 +353,7 @@
init #;(sequence (new type-name init) "array initialization")))
(define (binary-expression-end op)
(sequence (op expression) id "binary expression"))
(sequence (op (eta expression)) id "binary expression"))
(define if-expr-end
(sequence (? (eta expression) : (eta expression)) id "conditional expression"))
@ -669,11 +669,11 @@
(define class
(class-def #f #f (implements-dec identifier)
(repeat-greedy (class-body (list field method constructor)))))
(repeat (class-body (list field method constructor)))))
(define program
(make-program #f (repeat-greedy import-dec)
(repeat-greedy (top-member (list class interface)))))
(make-program #f (repeat import-dec)
(repeat (top-member (list class interface)))))
(define interact
(choose (field statement expression) "interactive program"))

32
collects/test-engine/scheme-gui.scm
View File

@ -1,32 +0,0 @@
#lang scheme/base
(require scheme/class
"test-engine.scm")
(define scheme-test-data (make-parameter (list #f #f #f)))
(define scheme-test-format (make-parameter (lambda (v) (format "~a" v))))
(define scheme-test%
(class* test-engine% ()
(super-instantiate ())
(inherit-field test-info test-display)
(inherit setup-info)
(field [tests null]
[test-objs null])
(define/public (add-test tst)
(set! tests (cons tst tests)))
(define/public (get-info)
(unless test-info (send this setup-info 'check-require))
test-info)
(define/augment (run)
(inner (void) run)
(for ([t (reverse tests)]) (run-test t)))
(define/augment (run-test test)
(test)
(inner (void) run-test test))))
(provide scheme-test% scheme-test-data scheme-test-format)

33
collects/test-engine/scheme-gui.ss Normal file
View File

@ -0,0 +1,33 @@
(module scheme-gui scheme/base
(require mred framework scheme/class
mzlib/pconvert mzlib/pretty)
(require (except-in "scheme-tests.ss" test) "test-display.scm")
(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) (run-tests) (pop-up))
(define (pop-up)
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
(parameterize ([scheme-test-format format-value])
(and test-info
(send test-info refine-display-class test-display%)
(send test-info setup-display #f #f)
(send test-info summarize-results (current-output-port))))))
(provide test format-value (all-from-out "scheme-tests.ss"))
)

143
collects/test-engine/scheme-tests.ss
View File

@ -1,12 +1,10 @@
#lang mzscheme
(require lang/private/teachprims
#;mred
#;framework
#;mzlib/pretty
#;mzlib/pconvert
mzlib/class
"scheme-gui.scm")
scheme/class
(only scheme/base for)
"test-engine.scm"
)
(require-for-syntax stepper/private/shared)
@ -16,61 +14,6 @@
check-error ;; syntax : (check-error <expression> <expression>)
)
(define (builder)
(let ([te (build-test-engine)])
(namespace-set-variable-value! 'test~object te (current-namespace))
te))
(define (test)
(run-tests)
(display-results))
(define (test-text)
(run-tests)
(print-results))
(define-syntax (run-tests stx)
(syntax-case stx ()
[(_)
(syntax-property
#'(run (namespace-variable-value 'test~object #f builder
(current-namespace)))
'test-call #t)]))
(define (run test-info) (and test-info (send test-info run)))
(define-syntax (display-results stx)
(syntax-case stx ()
[(_)
(syntax-property
#'(let ([test-info (namespace-variable-value 'test~object #f builder
(current-namespace))])
(and test-info
(let ([display-data (scheme-test-data)])
(send test-info refine-display-class (caddr display-data))
(send test-info setup-display
(car display-data) (cadr display-data))
(send test-info summarize-results (current-output-port)))))
'test-call #t)]))
(define-syntax (print-results stx)
(syntax-case stx ()
[(_)
(syntax-property
#'(let ([test-info (namespace-variable-value 'test~object #f builder
(current-namespace))])
(and test-info
(send test-info summarize-results (current-output-port))))
'test-call #t)]))
(provide run-tests display-results test test-text)
(define (build-test-engine)
(let ([engine (make-object scheme-test%)])
(send engine setup-info 'check-require)
engine))
(define (insert-test test-info test) (send test-info add-test test))
(define INEXACT-NUMBERS-FMT
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
(define CHECK-ERROR-STR-FMT
@ -272,15 +215,69 @@
((scheme-test-format) (expected-error-value fail))
(format ".~n ~a~n" (expected-error-message fail)))]))
#;(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 (builder)
(let ([te (build-test-engine)])
(namespace-set-variable-value! 'test~object te (current-namespace))
te))
(define (test) (run-tests) (display-results))
(define-syntax (run-tests stx)
(syntax-case stx ()
[(_)
(syntax-property
#'(run (namespace-variable-value 'test~object #f builder (current-namespace)))
'test-call #t)]))
(define (run test-info) (and test-info (send test-info run)))
(define-syntax (display-results stx)
(syntax-case stx ()
[(_)
(syntax-property
#'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
(and test-info
(let ([display-data (scheme-test-data)])
(when (caddr display-data)
(send test-info refine-display-class (caddr display-data)))
(send test-info setup-display (car display-data) (cadr display-data))
(send test-info summarize-results (current-output-port)))))
'test-call #t)]))
(provide run-tests display-results test builder)
(define (build-test-engine)
(let ([engine (make-object scheme-test%)])
(send engine setup-info 'check-require)
engine))
(define (insert-test test-info test) (send test-info add-test test))
(define scheme-test-data (make-parameter (list #f #f #f)))
(define scheme-test-format (make-parameter (lambda (v) (format "~a" v))))
(define scheme-test%
(class* test-engine% ()
(super-instantiate ())
(inherit-field test-info test-display)
(inherit setup-info)
(field [tests null]
[test-objs null])
(define/public (add-test tst)
(set! tests (cons tst tests)))
(define/public (get-info)
(unless test-info (send this setup-info 'check-require))
test-info)
(define/augment (run)
(inner (void) run)
(for ([t (reverse tests)]) (run-test t)))
(define/augment (run-test test)
(test)
(inner (void) run-test test))))
(provide scheme-test-data scheme-test-format)