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
                  controller)
      (field [parent #f])
      
      (define/public (get-parent) parent)
      (define/public (set-parent m)
        (when parent
          (error 'model%:set-parent "test already has a parent"))
        (set! parent m))
      
      (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/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 trash null)

      (define/public (run) 
        (let [(primerr (current-error-port))
              (oport (make-output-collector 'output))
              (errport (make-output-collector 'error))
              (iport (open-input-string ""))
              (super-cust (current-custodian))
              (cust (make-custodian))]
          (parameterize [(current-input-port iport)
                         (current-output-port oport)
                         (current-error-port errport)
                         (current-custodian cust)]
            (let-values ([(test-result times)
                          (run/time-test (get-test))])
              (set! timing times)
              (set! trash
                    (map (lambda (x) (format "~s" x))
                         (custodian-managed-list cust super-cust)))
              (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))

      (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)
        (set! trash null)
        (send (get-controller) on-model-status-change this))

      (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-total-cases) 1)
      (define/public (get-total-successes)
        (if (success?) 1 0))
      (define/public (get-total-failures)
        (if (or (failure?) (error?)) 1 0))

      (define/public (get-result) result)
      (define/public (get-timing) timing)
      (define/public (get-trash) trash)
      (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-all-properties)
        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<%>)
      (inherit get-controller)
      (inherit-field test)
      
      (init-field children)
      (super-new)
      (for-each (lambda (c) (send c set-parent this)) children)
      
      (define total-cases (count-total-cases))
      (define status STATUS-UNEXECUTED)
      (define total-successes 0)
      (define total-failures 0)
      
      (define/private (count-total-cases)
        (apply + (map (lambda (c) (send c get-total-cases)) children)))
      
      (define/public (get-total-cases)
        total-cases)
      
      (define/public (run)
        (let ([custodian (make-custodian)]
              [before (schemeunit-test-suite-before test)]
              [after (schemeunit-test-suite-after test)])
          (parameterize [(current-custodian custodian)]
            (dynamic-wind
                before
                (lambda ()
                  (for-each (lambda (c) (send c run)) (get-children))
                  (custodian-shutdown-all custodian))
                after))))
      
      (define/public (clear)
        (for-each (lambda (c) (send c clear)) (get-children)))
      
      (define/private (compute-status+successes+failures)
        (let loop ([children children] [successes 0] [failures 0] [any-unexec? #f])
          (cond [(null? children)
                 (values (cond [(positive? failures) STATUS-FAILURE]
                               [any-unexec? STATUS-UNEXECUTED]
                               [else STATUS-SUCCESS])
                         successes
                         failures)]
                [else
                 (let ((first (car children))
                       (rest (cdr children))
                       (first-status (send (car children) get-status)))
                   (loop rest
                         (+ successes
                            (send first get-total-successes))
                         (+ failures
                            (send first get-total-failures))
                         (or any-unexec? (eq? first-status STATUS-UNEXECUTED))))])))

      (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/public (get-children) children)
      (define/public (get-total-successes) total-successes)
      (define/public (get-total-failures) total-failures)

      ;; 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)
        (let-values ([(new-status new-total-successes new-total-failures)
                      (compute-status+successes+failures)])
          (let ([big-change (not (eq? status new-status))]
                [little-change
                 (or (not (eq? total-successes new-total-successes))
                     (not (eq? total-failures new-total-failures)))])
            (set! status new-status)
            (set! total-successes new-total-successes)
            (set! total-failures new-total-failures)
            (when (or big-change little-change)
              (send (get-controller) on-model-status-change this)))))
      ))
  )