018521cbc3
This adds the language levels, teachpacks, and documentation for the textbook "Die Macht der Abstraktion". svn: r14019
139 lines
4.3 KiB
Scheme
139 lines
4.3 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide build-contract-test-engine
|
|
contract-violation?
|
|
contract-violation-obj contract-violation-contract contract-violation-messages
|
|
contract-violation-blame contract-violation-srcloc)
|
|
|
|
(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)
|
|
|
|
(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
|
|
(fprintf port "Tests disabled.\n"))))
|
|
|
|
(define/private (display-success port event-space count)
|
|
(clear-results event-space)
|
|
(unless (test-silence)
|
|
(fprintf port "~a test~a passed!\n"
|
|
(case count
|
|
[(0) "Zero"]
|
|
[(1) "The only"]
|
|
[(2) "Both"]
|
|
[else (format "All ~a" count)])
|
|
(if (= count 1) "" "s"))))
|
|
|
|
(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-violation (obj contract messages srcloc blame))
|
|
|
|
(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)))
|
|
(messages
|
|
(if message
|
|
(list message)
|
|
(list "got " ((test-format) obj)))))
|
|
|
|
(set! contract-violations
|
|
(cons (make-contract-violation obj contract messages srcloc blame)
|
|
contract-violations)))
|
|
(inner (void) contract-failed obj contract message))
|
|
|
|
(define/public (failed-contracts) (reverse contract-violations))
|
|
|
|
(super-instantiate ())))
|