275 lines
9.2 KiB
Racket
275 lines
9.2 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/list
|
|
scheme/gui
|
|
framework/framework
|
|
mzlib/etc)
|
|
|
|
(require macro-debugger/model/trace
|
|
macro-debugger/view/view
|
|
macro-debugger/view/prefs)
|
|
|
|
(provide test-stepper
|
|
test-stepper*)
|
|
|
|
(define (wait) (sleep .1))
|
|
(define (waitb) (sleep .025))
|
|
|
|
(define (get-active-frame)
|
|
(let ([frame (get-top-level-focus-window)])
|
|
(unless frame
|
|
(error 'get-active-frame "no active frame"))
|
|
frame))
|
|
|
|
(define (find-object base class pred)
|
|
(define (find-loop obj)
|
|
(cond [(and (is-a? obj class) (pred obj)) obj]
|
|
[(is-a? obj area-container<%>)
|
|
(ormap find-loop (send obj get-children))]
|
|
[else #f]))
|
|
(let ([obj (find-loop base)])
|
|
(unless obj
|
|
(error 'find-object "no such ~s object satisfying ~s" class pred))
|
|
obj))
|
|
|
|
(define (find:next frame)
|
|
(find-object frame button% (has-label "Step ->")))
|
|
(define (find:prev frame)
|
|
(find-object frame button% (has-label "<- Step")))
|
|
(define (find:start frame)
|
|
(find-object frame button% (has-label "<-- Start")))
|
|
(define (find:end frame)
|
|
(find-object frame button% (has-label "End -->")))
|
|
(define (find:up frame)
|
|
(find-object frame button% (has-label "Previous term")))
|
|
(define (find:down frame)
|
|
(find-object frame button% (has-label "Next term")))
|
|
|
|
(define (has-label label)
|
|
(lambda (obj) (equal? label (send obj get-label))))
|
|
|
|
(define (enabled? obj)
|
|
(send obj is-enabled?))
|
|
|
|
(define (click button)
|
|
(waitb)
|
|
(unless (enabled? button)
|
|
(error 'click "button not enabled"))
|
|
(send button command (make-object control-event% 'button)))
|
|
|
|
(define (click-until-disabled button)
|
|
(define (loop n)
|
|
(if (enabled? button)
|
|
(begin (click button)
|
|
(loop (add1 n)))
|
|
n))
|
|
(loop 0))
|
|
|
|
(define (click-if-enabled button)
|
|
(when (enabled? button)
|
|
(click button)))
|
|
|
|
(define (check check-box value)
|
|
(wait)
|
|
(unless (enabled? check-box)
|
|
(error 'check "check box not enabled"))
|
|
(send* check-box
|
|
(set-value value)
|
|
(command (make-object control-event% 'check-box))))
|
|
|
|
(define (choose choice value)
|
|
(wait)
|
|
(unless (enabled? choice)
|
|
(error 'choice "choice not enabled"))
|
|
(send* choice
|
|
(set-string-selection value)
|
|
(command (make-object control-event% 'choice))))
|
|
|
|
(define (menu-check menu-item value)
|
|
(wait)
|
|
(unless (enabled? menu-item)
|
|
(error 'menu-check "menu item not enabled"))
|
|
(send* menu-item
|
|
(check value)
|
|
(command (make-object control-event% 'menu))))
|
|
|
|
(define (set-policy frame policy-symbol)
|
|
(let ([policy (find-object frame choice% (has-label "Macro hiding: "))])
|
|
(case policy-symbol
|
|
((none)
|
|
(choose policy "Disable")
|
|
#;(check enable #f)
|
|
#;(check hide-mz #f)
|
|
#;(check hide-libs #f))
|
|
((basic)
|
|
(choose policy "Custom ...")
|
|
(check (find-object frame check-box% (has-label "Enable macro hiding")) #t)
|
|
(check (find-object frame check-box% (has-label "Hide mzscheme syntax")) #f)
|
|
(check (find-object frame check-box% (has-label "Hide library syntax")) #f))
|
|
((normal)
|
|
(choose policy "Standard")
|
|
#;(check enable #t)
|
|
#;(check hide-mz #t)
|
|
#;(check hide-libs #t)))))
|
|
|
|
(define (get-menu-item frame menu-path)
|
|
(let ([menu (send frame get-menu-bar)])
|
|
(define (menu-loop path menus)
|
|
(cond [(string? path)
|
|
(let ([item
|
|
(ormap (lambda (m)
|
|
(and (is-a? m labelled-menu-item<%>)
|
|
(equal? path (send m get-label))
|
|
m))
|
|
menus)])
|
|
(unless item
|
|
(error 'get-menu-item "no such menu item: ~s" path))
|
|
item)]
|
|
[else
|
|
(let ([menu
|
|
(ormap (lambda (m)
|
|
(and (is-a? m menu%)
|
|
(equal? (car path) (send m get-label))
|
|
m))
|
|
menus)])
|
|
(unless menu
|
|
(error 'get-menu-item "no such menu item: ~s" path))
|
|
(menu-loop (cdr path) (send menu get-items)))]))
|
|
(or (menu-loop menu-path (send menu get-items))
|
|
(error 'get-menu-item "no such menu item"))))
|
|
|
|
(define (menu-item:one-by-one frame)
|
|
(get-menu-item frame '("Stepper" "Extra options" . "One term at a time")))
|
|
(define (menu-item:show-renaming-steps frame)
|
|
(get-menu-item frame '("Stepper" "Extra options" . "Include renaming steps")))
|
|
(define (menu-item:highlight-redex/contractum frame)
|
|
(get-menu-item frame '("Stepper" "Extra options" . "Highlight redex/contractum")))
|
|
|
|
(define (set-mode frame . flags)
|
|
(menu-check (menu-item:one-by-one frame)
|
|
(memq 'one-by-one flags))
|
|
(menu-check (menu-item:show-renaming-steps frame)
|
|
(memq 'renames flags))
|
|
(menu-check (menu-item:highlight-redex/contractum frame)
|
|
(not (memq 'no-highlight flags))))
|
|
|
|
(define (run-through start prev next end)
|
|
(begin-with-definitions
|
|
(click-if-enabled start)
|
|
(begin (for-each assert-disabled (list start prev)))
|
|
(define next-clicks (click-until-disabled next))
|
|
(begin (for-each assert-disabled (list next end)))
|
|
(click-if-enabled start)
|
|
(begin (for-each assert-disabled (list start prev)))
|
|
(click-if-enabled end)
|
|
(begin (for-each assert-disabled (list next end)))
|
|
(define prev-clicks (click-until-disabled prev))
|
|
(unless (equal? next-clicks prev-clicks)
|
|
(error 'run-through
|
|
"pressed next ~s times, pressed prev ~s times"
|
|
next-clicks prev-clicks))
|
|
(begin (for-each assert-disabled (list start prev)))))
|
|
|
|
(define (assert-enabled obj)
|
|
(unless (enabled? obj)
|
|
(error 'assert-enabled "assertion failed for ~s" (send obj get-label))))
|
|
(define (assert-disabled obj)
|
|
(when (enabled? obj)
|
|
(error 'assert-disabled "assertion failed for ~s" (send obj get-label))))
|
|
|
|
;; check-threads : (-> any) -> any
|
|
;; Runs thunk; raises error if any subthreads created by thunk raise
|
|
;; errors, or if a subthread outlives thunk's computation.
|
|
(define (check-threads thunk)
|
|
(let* ([main-cust (current-custodian)]
|
|
[sub-cust (make-custodian main-cust)]
|
|
[sub-exns null]
|
|
[old-uncaught-exception-handler (uncaught-exception-handler)])
|
|
(parameterize ((current-custodian sub-cust)
|
|
(uncaught-exception-handler
|
|
(lambda (exn)
|
|
(set! sub-exns (cons exn sub-exns))
|
|
(old-uncaught-exception-handler exn))))
|
|
(let ([result (thunk)])
|
|
;; Check that sub-custodian has no living threads.
|
|
(let ([threads-still-going?
|
|
(ormap thread-running?
|
|
(filter thread?
|
|
(custodian-managed-list sub-cust main-cust)))])
|
|
(when (pair? sub-exns)
|
|
(raise (car sub-exns))
|
|
#;(error 'nice-threads "child thread raised exception"))
|
|
(when threads-still-going?
|
|
(error 'nice-threads "child thread left still running"))
|
|
result)))))
|
|
|
|
(define (new-uninitialized-stepper)
|
|
(sleep 1)
|
|
(parameterize ((current-eventspace (make-eventspace)))
|
|
(let ([frame (new macro-stepper-frame%
|
|
(config (new macro-stepper-config/prefs/readonly%))
|
|
(director (new macro-stepper-director%)))])
|
|
(send frame show #t)
|
|
frame)))
|
|
|
|
(define (new-stepper)
|
|
(let ([frame (new-uninitialized-stepper)])
|
|
frame))
|
|
|
|
(define (add-expansion frame stx)
|
|
(let ([widget (send frame get-widget)])
|
|
(send widget add-deriv (trace stx))))
|
|
|
|
(define (test-stepper* stxs policies)
|
|
(check-threads
|
|
(lambda ()
|
|
(let ([frame (new-stepper)])
|
|
(let ([start (find:start frame)]
|
|
[prev (find:prev frame)]
|
|
[next (find:next frame)]
|
|
[end (find:end frame)]
|
|
[up (find:up frame)]
|
|
[down (find:down frame)])
|
|
(define (run)
|
|
(run-down)
|
|
(click-until-disabled up))
|
|
(define (run-down)
|
|
(when (enabled? down)
|
|
(run-through start prev next end)
|
|
(click down)
|
|
(run-down)))
|
|
(define (run/all-modes)
|
|
(set-mode frame) ;; normal by default
|
|
(run)
|
|
(set-mode frame 'no-highlight)
|
|
(run)
|
|
(set-mode frame 'renames)
|
|
(run)
|
|
;;(set-mode frame 'no-highlight 'renames)
|
|
;;(run)
|
|
;;(set-mode frame 'one-by-one)
|
|
;;(run)
|
|
;;(set-mode frame 'one-by-one 'renames)
|
|
;;(run)
|
|
(set-mode frame 'one-by-one 'renames 'no-highlight)
|
|
(run)
|
|
(set-mode frame))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(for-each (lambda (stx) (add-expansion frame stx)) stxs)
|
|
;; Test different hiding policies
|
|
(for-each (lambda (policy)
|
|
(set-policy frame policy)
|
|
(run/all-modes))
|
|
policies)
|
|
(wait))
|
|
(lambda ()
|
|
(test:close-top-level-window frame)
|
|
(kill-thread
|
|
(eventspace-handler-thread
|
|
(send frame get-eventspace))))))))))
|
|
|
|
(define (test-stepper expr)
|
|
(test-stepper* (list expr) '(none basic normal)))
|