68 lines
2.2 KiB
Racket
68 lines
2.2 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
unstable/class-iop
|
|
unstable/gui/notify
|
|
"../base.rkt"
|
|
"interfaces.rkt"
|
|
"model.rkt"
|
|
"view.rkt")
|
|
(provide controller%)
|
|
|
|
(define controller%
|
|
(class* object% (controller<%>)
|
|
(super-new)
|
|
|
|
;; model-shown : (notify-box (U model<%> #f))
|
|
;; The model currently displayed in the Details view, of #f is none.
|
|
(define-notify selected-model (new notify-box% (value #f)))
|
|
|
|
;; locked? : (notify-box boolean)
|
|
(define-notify locked? (new notify-box% (value #f)))
|
|
|
|
;; view : #f or view<%>
|
|
(define view #f)
|
|
|
|
;; check-ready : -> void
|
|
(define/private (check-ready)
|
|
(unless view
|
|
(error 'rackunit "The RackUnit GUI is no longer running."))
|
|
(when (get-locked?)
|
|
(error 'rackunit "The RackUnit GUI is locked and not accepting tests.")))
|
|
|
|
;; create-model : test suite<%>/#f -> result<%>
|
|
(define/public (create-model test parent)
|
|
(define _ (check-ready))
|
|
(define result
|
|
(cond [(rackunit-test-case? test)
|
|
(new case-result%
|
|
(controller this)
|
|
(test test)
|
|
(name (or (rackunit-test-case-name test)
|
|
"<unnamed test-case>"))
|
|
(parent parent))]
|
|
[(rackunit-test-suite? test)
|
|
(new suite-result%
|
|
(controller this)
|
|
(test test)
|
|
(name (or (rackunit-test-suite-name test)
|
|
"<unnamed test-suite>"))
|
|
(parent parent))]))
|
|
(send/i view view<%> create-view-link result parent)
|
|
result)
|
|
|
|
;; on-model-status-change : model<%> -> void
|
|
(define/public (on-model-status-change model)
|
|
;; (check-ready) ;; allow completion of tests to change status
|
|
(send view queue-for-update model)
|
|
(let [(parent (send model get-parent))]
|
|
(when parent (send parent on-child-status-change model))))
|
|
|
|
;; register-view : view<%> -> void
|
|
(define/public (register-view v)
|
|
(set! view v))
|
|
|
|
;; on-view-shutdown : -> void
|
|
(define/public (on-view-shutdown)
|
|
(set! view #f))
|
|
))
|