(module view mzscheme
(require (lib "class.ss")
(lib "list.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 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))))
(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)))
(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))
(define view%
(class* object% (view<%>)
(init ((-parent parent))
((-controller controller))
((-root-model root-model)))
(super-new)
(define root-model -root-model)
(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))
(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)
(erase))
(send renderer render-model/long model)
(send* editor
(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)
(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)))))))
(define/public (get-controller) controller)
(define/public (get-selected-model)
(let [(item (send tree-view get-selected))]
(and item (send item user-data))))
(define worker #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)
))
)