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

Merge deinprogramm contract test-engine into the regular one.

Browse Source 
This adds support for contracts.
This commit is contained in:
Mike Sperber 2010-05-20 15:31:45 +02:00
parent fb042df0c7
commit 8590e8cadf
9 changed files with 134 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/deinprogramm/DMdA.rkt
View File

@ -4,11 +4,11 @@
(require test-engine/scheme-tests (require test-engine/scheme-tests
(lib "test-info.scm" "test-engine") (lib "test-info.scm" "test-engine")
(lib "scheme-tests.rkt" "test-engine")
scheme/class) scheme/class)
(require deinprogramm/contract/module-begin (require deinprogramm/contract/module-begin
deinprogramm/contract/contract (except-in deinprogramm/contract/contract contract-violation)
deinprogramm/contract/contract-test-engine
(except-in deinprogramm/contract/contract-syntax property)) (except-in deinprogramm/contract/contract-syntax property))
(require (for-syntax scheme/base) (require (for-syntax scheme/base)

3
collects/deinprogramm/contract/contract-test-display.rkt
View File

@ -13,8 +13,7 @@
(lib "test-engine/test-info.scm") (lib "test-engine/test-info.scm")
(lib "test-engine/test-engine.scm") (lib "test-engine/test-engine.scm")
(lib "test-engine/print.ss") (lib "test-engine/print.ss")
deinprogramm/contract/contract (except-in deinprogramm/contract/contract contract-violation) ; clashes with test-engine
deinprogramm/contract/contract-test-engine
deinprogramm/quickcheck/quickcheck) deinprogramm/quickcheck/quickcheck)
(define contract-test-display% (define contract-test-display%

145
collects/deinprogramm/contract/contract-test-engine.rkt
View File

@ -1,145 +0,0 @@
#lang scheme/base
(provide build-contract-test-engine
contract-violation?
contract-violation-obj contract-violation-contract contract-violation-message
contract-violation-blame contract-violation-srcloc
contract-got? contract-got-value contract-got-format
property-fail? property-fail-result
property-error? make-property-error property-error-message property-error-exn)
(require scheme/class
(lib "test-engine/test-engine.scm")
(lib "test-engine/test-info.scm"))
(define (build-contract-test-engine)
(let ((engine (make-object contract-test-engine%)))
(send engine setup-info 'check-require)
engine))
(define contract-test-engine%
(class* test-engine% ()
(super-instantiate ())
(inherit-field test-info test-display)
(inherit setup-info display-untested display-disabled)
(define display-rep #f)
(define display-event-space #f)
(field (tests null)
(test-objs null))
(define/override (info-class) contract-test-info%)
;; need display-rep & display-event-space
(define/augment (setup-display cur-rep event-space)
(set! display-rep cur-rep)
(set! display-event-space event-space)
(inner (void) setup-display cur-rep event-space))
(define/public (add-test tst)
(set! tests (cons tst tests)))
(define/public (get-info)
(unless test-info (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))
(define/private (clear-results event-space)
(when event-space
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space])
((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send test-display report-success))))))
(define/override (summarize-results port)
(cond
((test-execute)
(unless test-display (setup-display #f #f))
(send test-display install-info test-info)
(if (pair? (send test-info failed-contracts))
(send this display-results display-rep display-event-space)
(let ((result (send test-info summarize-results)))
(case result
[(no-tests)
(clear-results display-event-space)
(display-untested port)]
[(all-passed) (display-success port display-event-space
(+ (send test-info tests-run)
(send test-info checks-run)))]
[(mixed-results)
(display-results display-rep display-event-space)]))))
(else
(display-disabled port))))
(define/private (display-success port event-space count)
(clear-results event-space)
(send test-display display-success-summary port count))
(define/override (display-results rep event-space)
(cond
[(and rep event-space)
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space])
((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send rep display-test-results test-display))))]
[event-space
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space])
((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))]
[else (send test-display display-results)]))
))
(define-struct contract-got (value format))
(define-struct contract-violation (obj contract message srcloc blame))
(define-struct (property-fail check-fail) (result))
(define-struct (property-error check-fail) (message exn))
(define contract-test-info%
(class* test-info-base% ()
(define contract-violations '())
(define/pubment (contract-failed obj contract message blame)
(let* ((cms
(continuation-mark-set->list (current-continuation-marks)
;; set from deinprogramm-langs.ss
'deinprogramm-teaching-languages-continuation-mark-key))
(srcloc
(cond
((findf (lambda (mark)
(and mark
(or (path? (car mark))
(symbol? (car mark)))))
cms)
=> (lambda (mark)
(apply (lambda (source line col pos span)
(make-srcloc source line col pos span))
mark)))
(else #f)))
(message
(or message
(make-contract-got obj (test-format)))))
(set! contract-violations
(cons (make-contract-violation obj contract message srcloc blame)
contract-violations)))
(inner (void) contract-failed obj contract message))
(define/public (failed-contracts) (reverse contract-violations))
(inherit add-check-failure)
(define/pubment (property-failed result src-info)
(add-check-failure (make-property-fail src-info (test-format) result) #f))
(define/pubment (property-error exn src-info)
(add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn))
(super-instantiate ())))

22
collects/deinprogramm/deinprogramm-langs.rkt
View File

@ -24,12 +24,12 @@
lang/stepper-language-interface lang/stepper-language-interface
lang/debugger-language-interface lang/debugger-language-interface
lang/run-teaching-program lang/run-teaching-program
lang/private/continuation-mark-key
stepper/private/shared stepper/private/shared
(only-in test-engine/scheme-gui make-formatter) (only-in test-engine/scheme-gui make-formatter)
(only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) test-engine/scheme-tests
deinprogramm/contract/contract deinprogramm/contract/contract
deinprogramm/contract/contract-test-engine
deinprogramm/contract/contract-test-display deinprogramm/contract/contract-test-display
) )
@ -190,7 +190,7 @@
(namespace-require scheme-contract-module-name) (namespace-require scheme-contract-module-name)
;; DeinProgramm hack: the test-engine code knows about the test~object name; we do, too ;; DeinProgramm hack: the test-engine code knows about the test~object name; we do, too
(namespace-set-variable-value! 'test~object (build-contract-test-engine)) (namespace-set-variable-value! 'test~object (build-test-engine))
;; record test-case failures with the test engine ;; record test-case failures with the test engine
(contract-violation-proc (contract-violation-proc
(lambda (obj contract message blame) (lambda (obj contract message blame)
@ -1157,14 +1157,6 @@
; ;
; ;
;; cm-key : symbol
;; the key used to put information on the continuation
;; DeinProgramm change: contract-test-engine.ss knows about this
(define cm-key 'deinprogramm-teaching-languages-continuation-mark-key)
(define mf-note (define mf-note
(let ([bitmap (let ([bitmap
(make-object bitmap% (make-object bitmap%
@ -1194,7 +1186,7 @@
[(exn:srclocs? exn) [(exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)] ((exn:srclocs-accessor exn) exn)]
[(exn? exn) [(exn? exn)
(let ([cms (continuation-mark-set->list (exn-continuation-marks exn) cm-key)]) (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) teaching-languages-continuation-mark-key)])
(cond (cond
((not cms) '()) ((not cms) '())
((findf (lambda (mark) ((findf (lambda (mark)
@ -1218,7 +1210,7 @@
;; with-mark : syntax syntax -> syntax ;; with-mark : syntax syntax -> syntax
;; a member of stacktrace-imports^ ;; a member of stacktrace-imports^
;; guarantees that the continuation marks associated with cm-key are ;; guarantees that the continuation marks associated with teaching-languages-continuation-mark-key are
;; members of the debug-source type ;; members of the debug-source type
(define (with-mark source-stx expr) (define (with-mark source-stx expr)
(let ([source (syntax-source source-stx)] (let ([source (syntax-source source-stx)]
@ -1231,8 +1223,8 @@
(number? span)) (number? span))
(with-syntax ([expr expr] (with-syntax ([expr expr]
[mark (list source line col start-position span)] [mark (list source line col start-position span)]
[cm-key cm-key]) [teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key])
#`(with-continuation-mark 'cm-key #`(with-continuation-mark 'teaching-languages-continuation-mark-key
'mark 'mark
expr)) expr))
expr))) expr)))

15
collects/lang/htdp-langs.rkt
View File

@ -24,6 +24,8 @@
;; and the user's namespace in the teaching languages ;; and the user's namespace in the teaching languages
"private/set-result.ss" "private/set-result.ss"
"private/continuation-mark-key.rkt"
"stepper-language-interface.ss" "stepper-language-interface.ss"
"debugger-language-interface.ss" "debugger-language-interface.ss"
"run-teaching-program.ss" "run-teaching-program.ss"
@ -953,10 +955,6 @@
;; cm-key : symbol
;; the key used to put information on the continuation
(define cm-key (gensym 'teaching-languages-continuation-mark-key))
(define mf-note (define mf-note
(let ([bitmap (let ([bitmap
(make-object bitmap% (make-object bitmap%
@ -986,7 +984,8 @@
[(exn:srclocs? exn) [(exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)] ((exn:srclocs-accessor exn) exn)]
[(exn? exn) [(exn? exn)
(let ([cms (continuation-mark-set->list (exn-continuation-marks exn) cm-key)]) (let ([cms (continuation-mark-set->list (exn-continuation-marks exn)
teaching-languages-continuation-mark-key)])
(if cms (if cms
(let loop ([cms cms]) (let loop ([cms cms])
(cond (cond
@ -1011,7 +1010,7 @@
;; with-mark : syntax syntax -> syntax ;; with-mark : syntax syntax -> syntax
;; a member of stacktrace-imports^ ;; a member of stacktrace-imports^
;; guarantees that the continuation marks associated with cm-key are ;; guarantees that the continuation marks associated with teaching-languages-continuation-mark-key are
;; members of the debug-source type ;; members of the debug-source type
(define (with-mark source-stx expr) (define (with-mark source-stx expr)
(let ([source (syntax-source source-stx)] (let ([source (syntax-source source-stx)]
@ -1022,8 +1021,8 @@
(number? span)) (number? span))
(with-syntax ([expr expr] (with-syntax ([expr expr]
[mark (list* source start-position span)] [mark (list* source start-position span)]
[cm-key cm-key]) [teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key])
#`(with-continuation-mark 'cm-key #`(with-continuation-mark 'teaching-languages-continuation-mark-key
'mark 'mark
expr)) expr))
expr))) expr)))

9
collects/lang/private/continuation-mark-key.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang scheme/base
(provide teaching-languages-continuation-mark-key)
; The test code also needs access to this.
;; cm-key : symbol
;; the key used to put information on the continuation
(define teaching-languages-continuation-mark-key (gensym 'teaching-languages-continuation-mark-key))

50
collects/test-engine/scheme-tests.rkt
View File

@ -3,7 +3,8 @@
(require lang/private/teachprims (require lang/private/teachprims
scheme/class scheme/class
scheme/match scheme/match
(only scheme/base for memf) lang/private/continuation-mark-key
(only scheme/base for memf findf)
"test-engine.scm" "test-engine.scm"
"test-info.scm" "test-info.scm"
) )
@ -340,6 +341,48 @@
(define scheme-test-data (make-parameter (list #f #f #f))) (define scheme-test-data (make-parameter (list #f #f #f)))
(define contract-test-info%
(class* test-info-base% ()
(define contract-violations '())
(define/pubment (contract-failed obj contract message blame)
(let* ((cms
(continuation-mark-set->list (current-continuation-marks)
teaching-languages-continuation-mark-key))
(srcloc
(cond
((findf (lambda (mark)
(and mark
(or (path? (car mark))
(symbol? (car mark)))))
cms)
=> (lambda (mark)
(apply (lambda (source line col pos span)
(make-srcloc source line col pos span))
mark)))
(else #f)))
(message
(or message
(make-contract-got obj (test-format)))))
(set! contract-violations
(cons (make-contract-violation obj contract message srcloc blame)
contract-violations)))
(inner (void) contract-failed obj contract message))
(define/public (failed-contracts) (reverse contract-violations))
(inherit add-check-failure)
(define/pubment (property-failed result src-info)
(add-check-failure (make-property-fail src-info (test-format) result) #f))
(define/pubment (property-error exn src-info)
(add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn))
(super-instantiate ())))
(define scheme-test% (define scheme-test%
(class* test-engine% () (class* test-engine% ()
(super-instantiate ()) (super-instantiate ())
@ -349,6 +392,8 @@
(field [tests null] (field [tests null]
[test-objs null]) [test-objs null])
(define/override (info-class) contract-test-info%)
(define/public (add-test tst) (define/public (add-test tst)
(set! tests (cons tst tests))) (set! tests (cons tst tests)))
(define/public (get-info) (define/public (get-info)
@ -366,4 +411,5 @@
(test) (test)
(inner (void) run-test test)))) (inner (void) run-test test))))
(provide scheme-test-data test-format test-execute test-silence error-handler) (provide scheme-test-data test-format test-execute test-silence error-handler
contract-test-info% build-test-engine)

44
collects/test-engine/test-engine.scm
View File

@ -147,36 +147,37 @@
(when (test-execute) (when (test-execute)
(unless test-info (setup-info 'check-base)) (unless test-info (setup-info 'check-base))
(inner (void) run))) (inner (void) run)))
(define/private (clear-results event-space)
(when event-space
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space])
((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send test-display report-success))))))
(define/public (summarize-results port) (define/public (summarize-results port)
(cond (cond
[(test-execute) ((test-execute)
(unless test-display (setup-display #f #f)) (unless test-display (setup-display #f #f))
(let ([result (send test-info summarize-results)])
(send test-display install-info test-info) (send test-display install-info test-info)
(if (pair? (send test-info failed-contracts))
(send this display-results display-rep display-event-space)
(let ((result (send test-info summarize-results)))
(case result (case result
[(no-tests) (display-untested port)] [(no-tests)
(clear-results display-event-space)
(display-untested port)]
[(all-passed) (display-success port display-event-space [(all-passed) (display-success port display-event-space
(+ (send test-info tests-run) (+ (send test-info tests-run)
(send test-info checks-run)))] (send test-info checks-run)))]
[(mixed-results) [(mixed-results)
(display-results display-rep display-event-space)]))] (display-results display-rep display-event-space)]))))
[else (else
(display-disabled port)])) (display-disabled port))))
(define/private (display-success port event count) (define/private (display-success port event-space count)
(when event (clear-results event-space)
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event])
((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send test-display report-success)))))
(send test-display display-success-summary port count)) (send test-display display-success-summary port count))
(define/public (display-untested port)
(unless silent-mode
(send test-display display-untested-summary port)))
(define/public (display-disabled port)
(send test-display display-disabled-summary port))
(define/public (display-results rep event-space) (define/public (display-results rep event-space)
(cond (cond
[(and rep event-space) [(and rep event-space)
@ -188,6 +189,13 @@
((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))] ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))]
[else (send test-display display-results)])) [else (send test-display display-results)]))
(define/public (display-untested port)
(unless silent-mode
(send test-display display-untested-summary port)))
(define/public (display-disabled port)
(send test-display display-disabled-summary port))
(define/pubment (initialize-test test) (define/pubment (initialize-test test)
(inner (void) initialize-test test)) (inner (void) initialize-test test))

22
collects/test-engine/test-info.scm
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
deinprogramm/quickcheck/quickcheck
"print.ss") "print.ss")
(provide (all-defined-out)) (provide (all-defined-out))
@ -25,6 +26,13 @@
;; (make-not-range src format scheme-val scheme-val scheme-val) ;; (make-not-range src format scheme-val scheme-val scheme-val)
(define-struct (not-range check-fail) (test min max)) (define-struct (not-range check-fail) (test min max))
(define-struct contract-got (value format))
(define-struct contract-violation (obj contract message srcloc blame))
(define-struct (property-fail check-fail) (result))
(define-struct (property-error check-fail) (message exn))
;; (make-message-error src format (listof string)) ;; (make-message-error src format (listof string))
(define-struct (message-error check-fail) (strings)) (define-struct (message-error check-fail) (strings))
@ -129,6 +137,18 @@
(formatter (not-range-test fail)) (formatter (not-range-test fail))
(formatter (not-range-min fail)) (formatter (not-range-min fail))
(formatter (not-range-max fail)))] (formatter (not-range-max fail)))]
) [(property-fail? fail)
(print-string "Property falsifiable with")
(for-each (lambda (arguments)
(for-each (lambda (p)
(if (car p)
(print " ~a = ~F" (car p) (formatter (cdr p)))
(print "~F" (formatter (cdr p)))))
arguments))
(result-arguments-list (property-fail-result fail)))]
[(property-error? fail)
(print "check-property encountered the the following error~n:: ~a"
(property-error-message fail))])
(print-string "\n"))) (print-string "\n")))