plt/gui/model.ss
(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)
      ))

  ;; model-case%
  (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))
      ))
  
  ;; model-suite%
  (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))
      
      ;; on-child-status-change : model<%> -> void
      ;; The flag is set if the child's status actually changed--changes are
      ;; propagated one level *past* that.
      (define/public (on-child-status-change child child-changed?)
        (let* ([new-status (calculate-status)]
               [changed? (not (eq? status new-status))])
          (when #t ;; (or child-changed? changed?)
            (set! status new-status)
            (send (get-controller) on-model-status-change this changed?))))
      ))
  
  )