(module view mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "hierlist.ss" "hierlist")
"interfaces.ss"
"config.ss"
"model2rml.ss"
"rml.ss"
"rml-styles.ss")
(provide make-view-frame
view%)
(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))))
(define (make-view-frame)
(new frame%
(label FRAME-LABEL)
(height FRAME-INIT-HEIGHT)
(width (+ TREE-INIT-WIDTH DETAILS-CANVAS-INIT-WIDTH))))
(define view%
(class* object% (view<%>)
(init ((-parent parent))
((-controller controller))
((-root-model root-model)))
(init-field (include-run+clear-buttons? #t))
(super-new)
(define root-model -root-model)
(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)))
(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))
(define model-shown #f)
(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)))]))
(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))
(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))]))
(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))]))
(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)))
(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))
(define/public (get-controller) controller)
(define/public (get-selected-model)
(let [(item (send tree-view get-selected))]
(and item (send item user-data))))
(create)
))
)