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