(module controller mzscheme
(require (lib "class.ss")
"interfaces.ss"
"../base.ss")
(provide controller%)
(define controller%
(class* object% (controller<%>)
(init-field model-case%
model-suite%
view%
display-window
test)
(define root-model #f)
(define view #f)
(define/public (get-root-model) root-model)
(define/public (get-view) view)
(define/public (run)
(send view run root-model))
(define/public (run-model model)
(send model run))
(define/public (clear-model model)
(send model clear))
(define/public (select-model model)
(send view set-selection model))
(define/private (create)
(set! root-model (create-model test))
(set! view (new view%
(root-model root-model)
(controller this)
(parent display-window))))
(define/private (create-model test)
(cond [(schemeunit-test-case? test)
(new model-case% (controller this) (test test))]
[(schemeunit-test-suite? test)
(let ([children
(map (lambda (c) (create-model c))
(schemeunit-test-suite-tests test))])
(new model-suite%
(controller this)
(test test)
(children children)))]))
(define/public (on-model-status-change model)
(send (get-view) queue-for-update model)
(let [(parent (send model get-parent))]
(when parent (send parent on-child-status-change model))))
(define/public (on-view-selection-change view model)
(send (get-view) set-selection model))
(super-new)
(create)
))
)