From 8590e8cadf08855be451f1b6a74fa65d300e4270 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Thu, 20 May 2010 15:31:45 +0200 Subject: [PATCH] Merge deinprogramm contract test-engine into the regular one. This adds support for contracts. --- collects/deinprogramm/DMdA.rkt | 4 +- .../contract/contract-test-display.rkt | 3 +- .../contract/contract-test-engine.rkt | 145 ------------------ collects/deinprogramm/deinprogramm-langs.rkt | 24 +-- collects/lang/htdp-langs.rkt | 17 +- .../lang/private/continuation-mark-key.rkt | 9 ++ collects/test-engine/scheme-tests.rkt | 50 +++++- collects/test-engine/test-engine.scm | 66 ++++---- collects/test-engine/test-info.scm | 22 ++- 9 files changed, 134 insertions(+), 206 deletions(-) delete mode 100644 collects/deinprogramm/contract/contract-test-engine.rkt create mode 100644 collects/lang/private/continuation-mark-key.rkt diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index de333e253e..fe66dc6244 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -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) diff --git a/collects/deinprogramm/contract/contract-test-display.rkt b/collects/deinprogramm/contract/contract-test-display.rkt index 906b4bccae..9d9c955885 100644 --- a/collects/deinprogramm/contract/contract-test-display.rkt +++ b/collects/deinprogramm/contract/contract-test-display.rkt @@ -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% diff --git a/collects/deinprogramm/contract/contract-test-engine.rkt b/collects/deinprogramm/contract/contract-test-engine.rkt deleted file mode 100644 index 55ef1a70df..0000000000 --- a/collects/deinprogramm/contract/contract-test-engine.rkt +++ /dev/null @@ -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 ()))) diff --git a/collects/deinprogramm/deinprogramm-langs.rkt b/collects/deinprogramm/deinprogramm-langs.rkt index 1c66b29227..239f9a5e49 100644 --- a/collects/deinprogramm/deinprogramm-langs.rkt +++ b/collects/deinprogramm/deinprogramm-langs.rkt @@ -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))) diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 385d80c073..e5b37fee9e 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -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))) diff --git a/collects/lang/private/continuation-mark-key.rkt b/collects/lang/private/continuation-mark-key.rkt new file mode 100644 index 0000000000..4646862d79 --- /dev/null +++ b/collects/lang/private/continuation-mark-key.rkt @@ -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)) diff --git a/collects/test-engine/scheme-tests.rkt b/collects/test-engine/scheme-tests.rkt index 319350bd98..9d2832ac51 100644 --- a/collects/test-engine/scheme-tests.rkt +++ b/collects/test-engine/scheme-tests.rkt @@ -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) diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index f4ac8088c3..a998ef3c22 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -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)) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index ab48376833..38f112b38a 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -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"))) +