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
(lib "test-info.scm" "test-engine")
(lib "scheme-tests.rkt" "test-engine")
scheme/class)
(require deinprogramm/contract/module-begin
deinprogramm/contract/contract
deinprogramm/contract/contract-test-engine
(except-in deinprogramm/contract/contract contract-violation)
(except-in deinprogramm/contract/contract-syntax property))
(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-engine.scm")
(lib "test-engine/print.ss")
deinprogramm/contract/contract
deinprogramm/contract/contract-test-engine
(except-in deinprogramm/contract/contract contract-violation) ; clashes with test-engine
deinprogramm/quickcheck/quickcheck)
(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 ())))

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

@ -24,12 +24,12 @@
lang/stepper-language-interface
lang/debugger-language-interface
lang/run-teaching-program
lang/private/continuation-mark-key
stepper/private/shared
(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-test-engine
deinprogramm/contract/contract-test-display
)
@ -190,7 +190,7 @@
(namespace-require scheme-contract-module-name)
;; 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
(contract-violation-proc
(lambda (obj contract message blame)
@ -1156,15 +1156,7 @@
;
;
;
;; 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
(let ([bitmap
(make-object bitmap%
@ -1194,7 +1186,7 @@
[(exn:srclocs? exn)
((exn:srclocs-accessor 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
((not cms) '())
((findf (lambda (mark)
@ -1218,7 +1210,7 @@
;; with-mark : syntax syntax -> syntax
;; 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
(define (with-mark source-stx expr)
(let ([source (syntax-source source-stx)]
@ -1231,8 +1223,8 @@
(number? span))
(with-syntax ([expr expr]
[mark (list source line col start-position span)]
[cm-key cm-key])
#`(with-continuation-mark 'cm-key
[teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key])
#`(with-continuation-mark 'teaching-languages-continuation-mark-key
'mark
expr))
expr)))

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

@ -23,7 +23,9 @@
;; this module is shared between the drscheme's namespace (so loaded here)
;; and the user's namespace in the teaching languages
"private/set-result.ss"
"private/continuation-mark-key.rkt"
"stepper-language-interface.ss"
"debugger-language-interface.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
(let ([bitmap
(make-object bitmap%
@ -986,7 +984,8 @@
[(exn:srclocs? exn)
((exn:srclocs-accessor 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
(let loop ([cms cms])
(cond
@ -1011,7 +1010,7 @@
;; with-mark : syntax syntax -> syntax
;; 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
(define (with-mark source-stx expr)
(let ([source (syntax-source source-stx)]
@ -1022,8 +1021,8 @@
(number? span))
(with-syntax ([expr expr]
[mark (list* source start-position span)]
[cm-key cm-key])
#`(with-continuation-mark 'cm-key
[teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key])
#`(with-continuation-mark 'teaching-languages-continuation-mark-key
'mark
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
scheme/class
scheme/match
(only scheme/base for memf)
lang/private/continuation-mark-key
(only scheme/base for memf findf)
"test-engine.scm"
"test-info.scm"
)
@ -340,6 +341,48 @@
(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%
(class* test-engine% ()
(super-instantiate ())
@ -349,6 +392,8 @@
(field [tests null]
[test-objs null])
(define/override (info-class) contract-test-info%)
(define/public (add-test tst)
(set! tests (cons tst tests)))
(define/public (get-info)
@ -366,4 +411,5 @@
(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)

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

@ -147,29 +147,48 @@
(when (test-execute)
(unless test-info (setup-info 'check-base))
(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)
(cond
[(test-execute)
(unless test-display (setup-display #f #f))
(let ([result (send test-info summarize-results)])
(send test-display install-info test-info)
(case result
[(no-tests) (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)]))
((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 count)
(when event
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event])
((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send test-display report-success)))))
(define/private (display-success port event-space count)
(clear-results event-space)
(send test-display display-success-summary port count))
(define/public (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/public (display-untested port)
(unless silent-mode
(send test-display display-untested-summary port)))
@ -177,17 +196,6 @@
(define/public (display-disabled port)
(send test-display display-disabled-summary port))
(define/public (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/pubment (initialize-test test)
(inner (void) initialize-test test))

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

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
deinprogramm/quickcheck/quickcheck
"print.ss")
(provide (all-defined-out))
@ -25,6 +26,13 @@
;; (make-not-range src format scheme-val scheme-val scheme-val)
(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))
(define-struct (message-error check-fail) (strings))
@ -129,6 +137,18 @@
(formatter (not-range-test fail))
(formatter (not-range-min 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")))