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%)

  (define style-map schemeunit-style-map)

  ;; tree-view% <: hierarchical-list%
  (define model-tree-view%
    (class* hierarchical-list% ()
      (init-field view)
      (init-field root-model)
      (super-new (style '(auto-hscroll)))

      (define model=>view-link (make-hash-table))
      (define/public (set-view-link model item)
        (hash-table-put! model=>view-link model item))
      (define/public (get-view-link model)
        (hash-table-get model=>view-link model #f))
      (define/private (remove-view-link/recursive model)
        (hash-table-remove! model=>view-link model)
        (when (is-a? model model-suite<%>)
          (for-each (lambda (c) (remove-view-link/recursive c))
                    (send model get-children))))

      (define filter-procedure #f)
      (define/public (set-filter proc)
        (set! filter-procedure proc))
      (define/public (remove-filter)
        (set-filter #f))
      (define/public (show? m)
        (or (not filter-procedure) (filter-procedure m)))

      ;; Behavior

      (define/override (on-select item)
        (let [(model (send item user-data))]
          (ensure-tree-visible model)
          (send view show-model model #f)))
      (define/override (on-double-select item)
        (when (is-a? item hierarchical-list-compound-item<%>)
          (if (send item is-open?)
              (send item close)
              (send item open))))
      (define/private (ensure-tree-visible model)
        (let* [(parent (send model get-parent))
               (parent-view-link (and parent (get-view-link parent)))]
          (when (and parent (not (send parent-view-link is-open?)))
            (ensure-tree-visible parent)
            (send parent-view-link open))))

      ;; Construction

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

      ;; rebuild-tree : -> void
      (define/public (rebuild-tree)
        (refresh/parent root-model this))

      ;; refresh/parent : model compound-item -> void
      (define/private (refresh/parent model parent)
        (if (show? model)
            (refresh/item model (get/create-view-link model parent))
            (let ([view-link (get-view-link model)])
              (when view-link
                (send parent delete-item view-link)
                (remove-view-link/recursive model)))))

      ;; refresh/item : model item -> void
      (define/private (refresh/item model item)
        (when (is-a? model model-suite<%>)
          (for-each (lambda (c) (refresh/parent c item))
                    (send model get-children))))

      ;; get/create-view-link : model -> item
      (define/private (get/create-view-link model parent)
        (or (get-view-link model)
            (cond [(is-a? model model-suite<%>)
                   (initialize-view-link (send parent new-list) model)]
                  [(is-a? model model-case<%>)
                   (initialize-view-link (send parent new-item) model)])))
      
      ;; initialize-view-link : model<%> (union compound-item% item%) -> item
      (define/private (initialize-view-link item model)
        (set-view-link model 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))]
              [(is-a? model model-case<%>)
               (insert-text (send item get-editor)
                            (send model get-name)
                            (send style-map get-style 'normal))])
        item)


      (build-tree)))

  ;; 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)

      ;; View Link

      (define/public (get-view-link model)
        (send tree-view get-view-link model))

      (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)))

      ;; FIXME: Enable this code later, once hierarchical-list widget
      ;; gets better (needs support for show/hide items)
      #;
      (define tree-panel
        (new tab-panel% (choices (list "All" "Failed"))
             (parent -lpane)
             (style '(no-border))
             (stretchable-height #f)
             (callback
              (lambda _
                (send tree-view set-filter
                      (if (= (send tree-panel get-selection) 1)
                          (lambda (m)
                            (or (send m failure?)
                                (send m error?)))
                          #f))
                (send tree-view rebuild-tree)))))
      (define tree-view
        (new model-tree-view% (parent -lpane) (view this) (root-model root-model)))

      (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)))]))

      ;; 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 (get-view-link model) select #t)
          (send controller on-view-selection-change this 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))))

      ;; Update Management

      (define update-queue (make-hash-table))
      (define update-lock (make-semaphore 1))

      ;; queue-for-update : model -> void
      (define/public (queue-for-update model)
        (semaphore-wait update-lock)
        (hash-table-put! update-queue model #t)
        (semaphore-post update-lock)
        (process-updates))

      (define/private (process-updates)
        (parameterize ((current-eventspace eventspace))
          (queue-callback
           (lambda ()
             (let ([models-to-update (grab+clear-update-queue)])
               (when (pair? models-to-update)
                 (do-models-update models-to-update)))))))

      (define/private (grab+clear-update-queue)
        (semaphore-wait update-lock)
        (if (positive? (hash-table-count update-queue))
            (let ([old-queue update-queue])
              (set! update-queue (make-hash-table))
              (semaphore-post update-lock)
              (reverse
               (hash-table-map old-queue (lambda (k v) k))))
            (begin (semaphore-post update-lock)
                   null)))

      ;; do-models-update : (list-of model<%>) -> void
      ;; Must be called from eventspace thread.
      (define/private (do-models-update models)
        (for-each (lambda (model) (do-model-update model)) models))

      ;; do-model-update : model<%> -> void
      ;; Must be called from eventspace thread.
      (define/private (do-model-update model)
        (let ([view-link (get-view-link model)])
          (when view-link
            (let* [(editor (send 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)))
            (when (eq? model (get-selected-model))
              (show-model model)))))

      ;; 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)

      ))
  )