146 lines
4.7 KiB
Scheme
146 lines
4.7 KiB
Scheme
#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 ())))
|