(module model mzscheme
(require (lib "class.ss")
(lib "list.ss")
"../test.ss"
"config.ss"
"interfaces.ss")
(provide model-case%
model-suite%)
(define model%
(class* object% ()
(super-instantiate ())
(init-field test
parent
controller)
(define/public (get-parent) parent)
(define/public (get-test) test)
(define/public (get-name)
(cond [(schemeunit-test-suite? test) (schemeunit-test-suite-name test)]
[(schemeunit-test-case? test) (schemeunit-test-case-name test)]))
(define view-link #f)
(define/public (get-view-link) view-link)
(define/public (set-view-link vl) (set! view-link vl))
(define/public (get-controller) controller)
))
(define model-case%
(class* model% (model-case<%>)
(super-instantiate ())
(inherit get-test
get-controller)
(define status STATUS-UNEXECUTED)
(define result #f)
(define properties #f)
(define timing #f)
(define output null)
(define/public (run)
(let [(primerr (current-error-port))
(oport (make-output-collector 'output))
(errport (make-output-collector 'error))
(iport (open-input-string ""))]
(parameterize [(current-input-port iport)
(current-output-port oport)
(current-error-port errport)]
(let-values ([(test-result times)
(run/time-test (get-test))])
(set! timing times)
(cond [(test-success? test-result)
(set! status STATUS-SUCCESS)
(set! properties null)
(set! result (test-success-result test-result))]
[(test-failure? test-result)
(let* ([exn (test-failure-result test-result)]
[property-stack (exn:test:check-stack exn)])
(set! status STATUS-FAILURE)
(set! properties
(map cons
(map check-info-name property-stack)
(map check-info-value property-stack)))
(set! result exn))]
[(test-error? test-result)
(set! status STATUS-ERROR)
(set! properties null)
(set! result (test-error-result test-result))]))))
(send (get-controller) on-model-status-change this #t))
(define/private (run/time-test test)
(let-values ([(results cputime realtime gctime)
(time-apply run-test-case
(list (schemeunit-test-case-name test)
(schemeunit-test-case-action test)))])
(values (car results) (list cputime realtime gctime))))
(define/public (clear)
(set! status STATUS-UNEXECUTED)
(set! result #f)
(set! properties #f)
(set! timing #f)
(set! output null)
(send (get-controller) on-model-status-change this #t))
(define/public (get-status) status)
(define/public (executed?) (not (eq? status STATUS-UNEXECUTED)))
(define/public (success?) (eq? status STATUS-SUCCESS))
(define/public (failure?) (eq? status STATUS-FAILURE))
(define/public (error?) (eq? status STATUS-ERROR))
(define/public (get-result) result)
(define/public (get-timing) timing)
(define/public (get-property p)
(let [(v (assq p properties))]
(and v (cdr v))))
(define/public (get-property-set p)
(map cdr (filter (lambda (kv) (eq? (car kv) p)) properties)))
(define/public (get-output) (reverse output))
(define/private (make-output-collector tag)
(make-output-port
#f
always-evt
(lambda (buf start end buffer? enable-break?)
(let [(str (bytes->string/utf-8 (subbytes buf start end)))]
(set! output (cons (list tag str) output))
(string-length str)))
void
void))
))
(define model-suite%
(class* model% (model-suite<%>)
(super-new)
(inherit get-controller)
(define/public (run)
(let [(custodian (make-custodian))]
(parameterize [(current-custodian custodian)]
(for-each (lambda (c) (send c run)) (get-children))
(custodian-shutdown-all custodian))))
(define/public (clear)
(for-each (lambda (c) (send c clear)) (get-children)))
(define status STATUS-UNEXECUTED)
(define/private (calculate-status)
(let loop ([children children] [any-unexec? #f] [any-failed? #f])
(cond [(null? children)
(cond [any-failed? STATUS-FAILURE]
[any-unexec? STATUS-UNEXECUTED]
[else STATUS-SUCCESS])]
[else
(let ((first (car children))
(rest (cdr children))
(first-status (send (car children) get-status)))
(cond [(eq? first-status STATUS-SUCCESS)
(loop rest any-unexec? any-failed?)]
[(eq? first-status STATUS-FAILURE)
(loop rest any-unexec? #t)]
[(eq? first-status STATUS-ERROR)
(loop rest any-unexec? #t)]
[(eq? first-status STATUS-UNEXECUTED)
(loop rest #t any-failed?)]
[else (error 'impossible)]))])))
(define/public (get-status) status)
(define/public (executed?) (not (eq? status STATUS-UNEXECUTED)))
(define/public (success?) (eq? status STATUS-SUCCESS))
(define/public (failure?) (eq? status STATUS-FAILURE))
(define/public (error?) #f)
(define children null)
(define/public (get-children) children)
(define/public (set-children c) (set! children c))
(define/public (on-child-status-change child child-changed?)
(let* ([new-status (calculate-status)]
[changed? (not (eq? status new-status))])
(when #t (set! status new-status)
(send (get-controller) on-model-status-change this changed?))))
))
)