plt/gui/view.ss
(module view mzscheme
  (require (lib "class.ss")
           (lib "list.ss")
           ;(lib "match.ss")
           (lib "mred.ss" "mred")
           (lib "framework.ss" "framework")
           (lib "hierlist.ss" "hierlist")
           "interfaces.ss"
           "config.ss"
           "model2rml.ss"
           "rml.ss")

  (provide make-view-frame
           view%)

  ;; tree-view% <: hierarchical-list%
  (define tree-view%
    (class* hierarchical-list% ()
      (init parent)
      (init-field view)
      
      (define/override (on-select item)
        (let [(model (send item user-data))]
          (ensure-tree-visible model)
          (send view show-model model #f)))
      (define/private (ensure-tree-visible model)
        (let* [(parent (send model get-parent))
               (parent-view-link (and parent (send parent get-view-link)))]
          (when (and parent (not (send parent-view-link is-open?)))
            (ensure-tree-visible parent)
            (send parent-view-link open))))
      (super-make-object parent '(auto-hscroll))))

  ;; view-frame% <: frame%
  (define view-frame%
    (class (frame:standard-menus-mixin 
            (frame:basic-mixin frame%))
      (super-new)
      (inherit get-help-menu)

      (define-syntax override-false
        (syntax-rules ()
          [(override-false name ...)
           (begin (define/override (name . _) #f) ...)]))

      (override-false file-menu:create-new?
                      file-menu:create-open?
                      file-menu:create-open-recent?
                      file-menu:create-revert?
                      file-menu:create-save?
                      file-menu:create-save-as?
                      file-menu:create-print?
                      edit-menu:create-undo?
                      edit-menu:create-redo?
                      edit-menu:create-cut?
                      edit-menu:create-paste?
                      edit-menu:create-clear?
                      edit-menu:create-find?
                      edit-menu:create-replace-and-find-again?
                      edit-menu:create-preferences?)
      (send (get-help-menu) delete)))

  ;; make-view-frame : -> frame%
  (define (make-view-frame)
    (let ([frame 
           (new view-frame%
                (label FRAME-LABEL) 
                (height FRAME-INIT-HEIGHT)
                (width (+ TREE-INIT-WIDTH DETAILS-CANVAS-INIT-WIDTH)))])
      (send frame show #t)
      frame))

  ;; View
  (define view%
    (class* object% (view<%>)
      (init ((-parent parent))
            ((-controller controller))
            ((-root-model root-model)))

      (super-new)

      ;; root-model : model<%>
      (define root-model -root-model)

      ;; controller : controller<%>
      (define controller -controller)

      (define parent -parent)
      (define details #f)

      (define style-map schemeunit-style-map)
      (define editor (new ext:text% (style-map schemeunit-style-map)))
      (define renderer
        (new model-renderer%
             (controller controller)
             (editor editor)))

      (define eventspace
        (send (send parent get-top-level-window) get-eventspace))

      (define -hpane (new panel:horizontal-dragable% (parent parent)))
      (define -lpane (new vertical-pane% (parent -hpane)))
      (define -rpane (new vertical-pane% (parent -hpane)))
      (define -details-canvas 
        (new canvas:wide-snip% (parent -rpane) (editor editor)))
      (define tree-view (build-tree-view -lpane))

      (define -button-panel
        (new horizontal-panel%
             (parent -lpane)
             (stretchable-height #f)))
      (define run-button
        (new button%
             (label "Run") 
             (callback (lambda _ (run-callback)))
             (parent -button-panel)))
      (define clear-button
        (new button% 
             (label "Clear")
             (callback (lambda _ (clear-callback)))
             (parent -button-panel)))

      (define -work-panel
        (new vertical-panel%
             (parent -lpane)
             (stretchable-height #f)
             (alignment '(left top))
             (style '(deleted))))
      (define -work-label
        (new message%
             (label "Executing tests")
             (parent -work-panel)))
      (define -work-button-pane
        (new horizontal-pane%
             (parent -work-panel)))
      (define break-button
        (new button% (label "Break")
             (callback (lambda _ (break-callback)))
             (parent -work-button-pane)))
      (define kill-button
        (new button% (label "Kill")
             (callback (lambda _ (kill-callback)))
             (parent -work-button-pane)))

      (send editor lock #t)
      (with-handlers ([exn:fail? void])
        (send -hpane set-percentages VIEW-PANE-PERCENTS))

      ;; METHODS

      ;; model-shown : model<%> | #f
      ;; The model currently displayed in the Details view, of #f is none.
      (define model-shown #f)

      ;; show-model : model<%> [boolean] -> void
      ;; Ensures that a particular model is displayed in the Details area.
      ;; If it already is, only redraw if redisplay is provided and true.
      (define/public show-model
        (case-lambda
          [(model) (show-model model #t)]
          [(model redisplay?)
           (when (or redisplay? (not (eq? model-shown model)))
             (set! model-shown model)
             (send* editor
               (begin-edit-sequence)
               (lock #f)
               (erase))
             (send renderer render-model/long model)
             (send* editor
               (lock #t)
               (end-edit-sequence)
               (scroll-to-position 0)))]))

      ;; build-tree-view
      (define/private (build-tree-view area)
        (let ([tree (instantiate tree-view% () (parent area) (view this))])
          (populate-tree root-model tree)
          (let ([view-link (send root-model get-view-link)])
            (when (is-a? view-link hierarchical-list-compound-item<%>)
              (send view-link open))
            (send view-link select #t))
          tree))

      ;; populate-tree : model<%> (union tree-view% compound-item%) -> void
      (define/private (populate-tree model parent)
        (cond [(is-a? model model-suite<%>)
               (populate-tree/item model (send parent new-list))]
              [(is-a? model model-case<%>)
               (populate-tree/item model (send parent new-item))]))

      ;; populate-tree/item : model<%> (union compound-item% item%) -> void
      (define/private (populate-tree/item model item)
        (send model set-view-link item)
        (send item user-data model)
        (cond [(is-a? model model-suite<%>)
               (insert-text (send item get-editor)
                            (send model get-name)
                            (send style-map get-style 'bold))
               (when (is-a? model model-suite<%>)
                 (for-each (lambda (c) (populate-tree c item))
                           (send model get-children)))]
              [(is-a? model model-case<%>)
               (insert-text (send item get-editor)
                            (send model get-name)
                            (send style-map get-style 'normal))]))

      ;; set-selection
      ;; Set the selection to model and notify of change if necessary
      (define/public (set-selection model)
        (unless (eq? (get-selected-model) model)
          (send (send model get-view-link) select #t)
          (send controller on-view-selection-change this model)))

      ;; update-model-view : model<%> -> void
      ;; The given model has changed state--update the view to reflect it.
      ;; May be called from any thread.
      (define/public (update-model-view model)
        (parameterize ((current-eventspace eventspace))
          (queue-callback
           (lambda ()
             (let* [(editor (send (send model get-view-link) get-editor))
                    (style-name
                     (cond [(not (send model executed?)) 'test-unexecuted]
                           [(send model success?) 'test-success]
                           [(send model failure?) 'test-failure]
                           [(send model error?) 'test-error]))
                    (style (send style-map get-style style-name))]
               (send* editor
                 (begin-edit-sequence #f)
                 (change-style style 0 (send editor last-position) #f)
                 (end-edit-sequence)))
             (let* [(displayed-model (get-selected-model))]
               (when (eq? displayed-model model)
                 (show-model model)))))))

      ;; get-controller : -> controller<%>
      (define/public (get-controller) controller)

      ;; get-selected-model : -> model<%>
      (define/public (get-selected-model)
        (let [(item (send tree-view get-selected))]
          (and item (send item user-data))))


      ;; Work

      ;; worker : custodian/#f
      (define worker #f)

      ;; work-eventspace : eventspace/#f
      (define work-eventspace #f)

      (define/private (run-callback)
        (let ([selected-model (get-selected-model)])
          (when selected-model
            (send controller clear-model selected-model)
            (run selected-model))))

      (define/public (run selected-model)
        (parameterize ((current-custodian (make-custodian)))
          (parameterize ((current-eventspace (make-eventspace)))
            (set-worker (current-custodian) (current-eventspace))
            (queue-callback
             (lambda () 
               (send controller run-model selected-model)
               (queue-callback (lambda () (set-worker #f #f))))))))

      (define/private (clear-callback)
        (send editor begin-edit-sequence #f)
        (let ([selected-model (get-selected-model)])
          (when selected-model
            (send controller clear-model selected-model)))
        (send editor end-edit-sequence))

      (define/private (break-callback)
        (break-thread (eventspace-handler-thread work-eventspace)))

      (define/private (kill-callback)
        (custodian-shutdown-all worker)
        (set-worker #f #f))

      (define/private (set-worker w we)
        (set! worker w)
        (set! work-eventspace we)
        (let ([working? (and w #t)])
          (show-work-panel working?)
          (when run-button (send run-button enable (not working?)))
          (when clear-button (send clear-button enable (not working?)))
          (send kill-button enable working?)))

      (define/private (show-work-panel ?)
        (send -lpane change-children
              (lambda (children)
                (let ([first-part
                       (remq -button-panel (remq -work-panel children))])
                  (append first-part (list (if ? -work-panel -button-panel)))))))

      (set-worker #f #f)

      ))
  )