(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 style-map schemeunit-style-map)
(define model-tree-view%
(class* hierarchical-list% ()
(init-field view)
(init-field root-model)
(super-new (style '(auto-hscroll)))
(inherit delete-item
get-items)
(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 tree-mode? #t)
(define/public (get-tree-mode) tree-mode?)
(define/public (set-tree-mode ?) (set! tree-mode? ?))
(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)))
(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)
(when tree-mode?
(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)))))
(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))))
(define/public (rebuild-tree)
(for-each (lambda (i) (delete-item i)) (get-items))
(remove-view-link/recursive root-model)
(build-tree))
(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)))))
(define/private (refresh/item model item)
(when (or (is-a? model model-case<%>) tree-mode?)
(update-item item))
(when (is-a? model model-suite<%>)
(for-each (lambda (c) (refresh/parent c item))
(send model get-children))))
(define/private (get/create-view-link model parent)
(or (get-view-link model)
(cond [(is-a? model model-suite<%>)
(if tree-mode?
(initialize-view-link (send parent new-list) model)
parent)]
[(is-a? model model-case<%>)
(initialize-view-link (send parent new-item) model)])))
(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)
(define/public (update-item view-link)
(let* [(editor (send view-link get-editor))
(model (send view-link user-data))
(name (send model get-name))
(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))
(output? (send model has-output?))
(trash? (send model has-trash?))]
(send editor begin-edit-sequence #f)
(send editor delete (string-length name) (send editor last-position) #f)
(when (or output? trash?)
(send editor insert
(output-icon)
(string-length name)
'same
#f))
(send editor change-style style 0 (send editor last-position) #f)
(send editor end-edit-sequence)))
(build-tree)))
(define view-frame%
(class (frame:standard-menus-mixin
(frame:basic-mixin frame%))
(init [width (pref:width)]
[height (pref:height)])
(super-new (width width) (height height))
(inherit get-help-menu
get-width
get-height)
(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?)
(define/augment (on-close)
(pref:width (get-width))
(pref:height (get-height))
(inner (void) on-close))
(send (get-help-menu) delete)))
(define (make-view-frame)
(let ([frame
(new view-frame%
(label FRAME-LABEL))])
(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/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)))
(define tree-panel
(new tab-panel% (choices (list "All" "Failed"))
(parent -lpane)
(style '(no-border))
(stretchable-height #t)
(callback
(lambda _
(set-tree-view-mode
(= (send tree-panel get-selection) 0))))))
(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))
(define/private (set-tree-view-mode tree-mode?)
(send tree-panel set-selection (if tree-mode? 0 1))
(unless (eq? tree-mode? (send tree-view get-tree-mode))
(let ([selection (get-selected-model)])
(if tree-mode?
(send* tree-view
(set-tree-mode #t)
(remove-filter))
(send* tree-view
(set-tree-mode #f)
(set-filter
(lambda (m) (or (send m failure?) (send m error?))))))
(send tree-view rebuild-tree)
(let ([view-link (get-view-link selection)])
(set-selection selection)))))
(define/private (ensure-tree-mode)
(set-tree-view-mode #t))
(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/public (set-selection model)
(unless (eq? (get-selected-model) model)
(let ([view-link (get-view-link model)])
(if view-link
(begin (send view-link select #t)
(send controller on-view-selection-change this model))
(begin (ensure-tree-mode)
(set-selection 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 update-queue (make-hash-table))
(define update-lock (make-semaphore 1))
(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)))
(define/private (do-models-update models)
(for-each (lambda (model) (do-model-update model)) models))
(define/private (do-model-update model)
(let ([view-link (get-view-link model)])
(when view-link
(send tree-view update-item view-link)
(when (eq? model (get-selected-model))
(show-model model)))))
(define worker #f)
(define work-eventspace #f)
(define/private (run-callback)
(ensure-tree-mode)
(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)
(ensure-tree-mode)
(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)
))
)