(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 view%)
(define tree-view%
(class* hierarchical-list% ()
(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-instantiate ())))
(define tree-view-item-mixin
(mixin (hierarchical-list-item<%>) (hierarchical-list-item<%>)
(super-instantiate())))
(define tree-view-compound-item-mixin
(mixin (hierarchical-list-compound-item<%>) (hierarchical-list-compound-item<%>)
(super-instantiate ())))
(define view%
(class* object% (view<%>)
(init ((-controller controller))
((-root-model root-model)))
(public show
show-model
set-selection
update-model-view
get-controller
get-selected-model)
(super-instantiate ())
(define root-model -root-model)
(define controller -controller)
(define frame #f)
(define details #f)
(define tree-view #f)
(define model->rml (instantiate model->rml% () (controller controller)))
(define style-map schemeunit-style-map)
(define editor (instantiate rml:text% () (style-map style-map)))
(define (create)
(define -frame
(instantiate frame% ()
(label FRAME-LABEL) (height FRAME-INIT-HEIGHT)
(width (+ TREE-INIT-WIDTH DETAILS-CANVAS-INIT-WIDTH))))
(define -hpane
(instantiate panel:horizontal-dragable% () (parent -frame)))
(define -lpane
(instantiate vertical-pane% () (parent -hpane)))
(define -rpane
(instantiate vertical-pane% () (parent -hpane)))
(define -details-canvas
(instantiate canvas:wide-snip% () (parent -rpane) (editor editor)))
(define -tree-view (build-tree-view -lpane))
(define -buttonpane
(instantiate horizontal-pane% () (parent -lpane) (stretchable-height #f)))
(instantiate button% ()
(label "Run") (callback run-callback) (parent -buttonpane))
(instantiate 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! frame -frame)
(set! tree-view -tree-view))
(define (show ?)
(send frame show ?))
(define model-shown #f)
(define 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
(lock #f)
(display (send model->rml model->rml/long model))
(lock #t)))]))
(define (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 (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 (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 (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 (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 (get-controller) controller)
(define (get-selected-model)
(let [(item (send tree-view get-selected))]
(and item (send item user-data))))
(create)
))
)