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

           ;(prefix drlink: "drscheme-ui.ss")
           "interfaces.ss"
           "config.ss"
           "model2rml.ss"
           "rml.ss"
           "rml-styles.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 (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))))

  ;; make-view-frame : -> frame%
  (define (make-view-frame)
    (new frame%
         (label FRAME-LABEL) 
         (height FRAME-INIT-HEIGHT)
         (width (+ TREE-INIT-WIDTH DETAILS-CANVAS-INIT-WIDTH))))

  ;; View
  (define view%
    (class* object% (view<%>)
      (init ((-parent parent))
            ((-controller controller))
            ((-root-model root-model)))
      (init-field (include-run+clear-buttons? #t))
      
      (super-new)
      
      ;; root-model : model<%>
      (define root-model -root-model)
      
      ;; controller : controller<%>
      (define controller -controller)

      (define parent -parent)
      (define details #f)
      (define tree-view #f)
      (define model->rml (new model->rml% (controller controller)))
      (define style-map schemeunit-style-map)
      (define editor (new rml:text% (style-map style-map)))
      
      ;; create : -> void
      (define/private (create)
        (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))
        (when include-run+clear-buttons?
          (let ((-buttonpane 
                 (new horizontal-pane% (parent -lpane) (stretchable-height #f))))
            (new button%
                 (label "Run") (callback run-callback) (parent -buttonpane))
            (new button% 
                 (label "Clear") (callback clear-callback) (parent -buttonpane))))
        (send editor lock #t)
        (with-handlers ([exn:fail? void])
          (send -hpane set-percentages VIEW-PANE-PERCENTS))
        (set! tree-view -tree-view))
      
      ;; 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)
               (display (send model->rml model->rml/long model))
               (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.
      (define/public (update-model-view model)
        (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)
            (select-all)
            (change-style style)
            (end-edit-sequence)))
        (let* [(displayed-model (get-selected-model))]
          (when (eq? displayed-model model)
            (show-model model))))

      (define (run-callback . _)
        (let ([selected-model (get-selected-model)])
        (when selected-model
          (send controller run-model selected-model))))

      (define (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))
      
      ;; 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))))
      
      (create)
      ))
  
  )