8907daf65f
This should have been like this all along; I think it can lead to race-conditions with high-priority events. In particular, something might be pending in the event queue and then the test suite might queue a high-priority event to check for it, which could happen before the event that actually does the work that's being checked for!
725 lines
32 KiB
Racket
725 lines
32 KiB
Racket
#lang scheme/base
|
|
|
|
(require (prefix-in fw: framework)
|
|
mrlib/hierlist
|
|
scheme/gui/base
|
|
scheme/class
|
|
scheme/contract
|
|
"../../utils/gui.rkt")
|
|
|
|
(provide/contract
|
|
[use-get/put-dialog (-> (-> any) path? void?)]
|
|
[set-module-language! (->* () (boolean?) void?)])
|
|
|
|
(provide queue-callback/res
|
|
fire-up-drracket-and-run-tests
|
|
fire-up-separate-drracket-and-run-tests
|
|
save-drracket-window-as
|
|
do-execute
|
|
test-util-error
|
|
poll-until
|
|
wait-for-computation
|
|
wait-for-drracket-frame
|
|
wait-for-new-frame
|
|
clear-definitions
|
|
type-in-definitions
|
|
type-in-interactions
|
|
insert-in-definitions
|
|
insert-in-interactions
|
|
type-string
|
|
wait
|
|
wait-pending
|
|
get-sub-panel
|
|
get-text-pos
|
|
wait-for-button
|
|
push-button-and-wait
|
|
set-language-level!
|
|
repl-in-edit-sequence?
|
|
fetch-output
|
|
has-error?
|
|
run-one/sync
|
|
alt-return-in-interactions)
|
|
|
|
;; save-drracket-window-as : string -> void
|
|
;; use the "save as" dialog in drracket to save the definitions
|
|
;; window to a file.
|
|
(define (save-drracket-window-as filename)
|
|
(not-on-eventspace-handler-thread 'save-drracket-window-as)
|
|
(use-get/put-dialog
|
|
(lambda ()
|
|
(fw:test:menu-select "File" "Save Definitions As..."))
|
|
filename))
|
|
|
|
;; open-dialog is a thunk that should open the dialog
|
|
;; filename is a string naming a file that should be typed into the dialog
|
|
(define (use-get/put-dialog open-dialog filename)
|
|
(not-on-eventspace-handler-thread 'use-get/put-dialog)
|
|
(let ([drs (wait-for-drracket-frame)])
|
|
(with-handlers ([(lambda (x) #t)
|
|
(lambda (x)
|
|
(fw:preferences:set 'framework:file-dialogs 'std)
|
|
(raise x))])
|
|
(fw:preferences:set 'framework:file-dialogs 'common)
|
|
(open-dialog)
|
|
(let ([dlg (wait-for-new-frame drs)])
|
|
(send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus)
|
|
(fw:test:keystroke #\a (list (case (system-type)
|
|
[(windows) 'control]
|
|
[(macosx macos) 'meta]
|
|
[(unix) 'meta]
|
|
[else (error 'use-get/put-dialog "unknown platform: ~s\n"
|
|
(system-type))])))
|
|
(for-each fw:test:keystroke (string->list (path->string filename)))
|
|
(fw:test:button-push "OK")
|
|
(wait-for-new-frame dlg))
|
|
(fw:preferences:set 'framework:file-dialogs 'std))))
|
|
|
|
(define (test-util-error fmt . args)
|
|
(raise (make-exn (apply fmt args) (current-continuation-marks))))
|
|
|
|
;; poll-until : (-> alpha) number (-> alpha) -> alpha
|
|
;; waits until pred return a true value and returns that.
|
|
;; if that doesn't happen by `secs', calls fail and returns that.
|
|
(define (poll-until pred
|
|
[secs 10]
|
|
[fail (lambda ()
|
|
(error 'poll-until
|
|
"timeout after ~e secs, ~e never returned a true value"
|
|
secs pred))])
|
|
(let ([step 1/20])
|
|
(let loop ([counter secs])
|
|
(if (<= counter 0)
|
|
(fail)
|
|
(let ([result (pred)])
|
|
(or result
|
|
(begin
|
|
(sleep step)
|
|
(loop (- counter step)))))))))
|
|
|
|
(define (drracket-frame? frame)
|
|
(method-in-interface? 'get-execute-button (object-interface frame)))
|
|
|
|
(define (wait-for-drracket-frame [print-message? #f])
|
|
(define (wait-for-drracket-frame-pred)
|
|
(define active (fw:test:get-active-top-level-window))
|
|
(if (and active
|
|
(drracket-frame? active))
|
|
active
|
|
#f))
|
|
(define drr-fr
|
|
(or (wait-for-drracket-frame-pred)
|
|
(begin
|
|
(when print-message?
|
|
(printf "Select DrRacket frame\n"))
|
|
(poll-until wait-for-drracket-frame-pred))))
|
|
(when drr-fr
|
|
(wait-for-events-in-frame-eventspace drr-fr))
|
|
drr-fr)
|
|
|
|
;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame
|
|
;; returns the newly opened frame, waiting until old-frame
|
|
;; is no longer frontmost. Optionally checks other eventspaces
|
|
;; waits until the new frame has a focus'd window, too.
|
|
(define (wait-for-new-frame old-frame [extra-eventspaces '()] [timeout 10])
|
|
(define (wait-for-new-frame-pred)
|
|
(define active (or (fw:test:get-active-top-level-window)
|
|
(for/or ([eventspace (in-list extra-eventspaces)])
|
|
(parameterize ([current-eventspace eventspace])
|
|
(fw:test:get-active-top-level-window)))))
|
|
(if (and active
|
|
(not (eq? active old-frame)))
|
|
active
|
|
#f))
|
|
(define fr (poll-until wait-for-new-frame-pred timeout))
|
|
(when fr (wait-for-events-in-frame-eventspace fr))
|
|
(sleep 1)
|
|
fr)
|
|
|
|
(define (wait-for-events-in-frame-eventspace fr)
|
|
(define sema (make-semaphore 0))
|
|
(parameterize ([current-eventspace (send fr get-eventspace)])
|
|
(queue-callback
|
|
(λ () (semaphore-post sema))
|
|
#f))
|
|
(semaphore-wait sema))
|
|
|
|
;; wait-for-computation : frame -> void
|
|
;; waits until the drracket frame finishes some computation.
|
|
;; uses the state of the execute button to indicate when the
|
|
;; computations is finished. That is, waits for the execute
|
|
;; button to dim, indicating a computation is running. Then,
|
|
;; waits for it to be re-enabled, indicating that the computation
|
|
;; is complete.
|
|
(define (wait-for-computation frame)
|
|
(not-on-eventspace-handler-thread 'wait-for-computation)
|
|
(queue-callback/res (λ () (verify-drracket-frame-frontmost 'wait-for-computation frame)))
|
|
(let* ([wait-for-computation-to-start
|
|
(lambda ()
|
|
(fw:test:reraise-error)
|
|
(not (send (send frame get-execute-button) is-enabled?)))]
|
|
[wait-for-computation-to-finish
|
|
(lambda ()
|
|
(fw:test:reraise-error)
|
|
(send (send frame get-execute-button) is-enabled?))])
|
|
;(poll-until wait-for-computation-to-start 60) ;; hm.
|
|
(poll-until wait-for-computation-to-finish 60)
|
|
(sync (system-idle-evt))))
|
|
|
|
(define do-execute
|
|
(case-lambda
|
|
[(frame)
|
|
(do-execute frame #t)]
|
|
[(frame wait-for-finish?)
|
|
(not-on-eventspace-handler-thread 'do-execute)
|
|
(queue-callback/res (λ () (verify-drracket-frame-frontmost 'do-execute frame)))
|
|
(let ([button (queue-callback/res (λ () (send frame get-execute-button)))])
|
|
(fw:test:run-one (lambda () (send button command)))
|
|
(when wait-for-finish?
|
|
(wait-for-computation frame)))]))
|
|
|
|
(define (verify-drracket-frame-frontmost function-name frame)
|
|
(on-eventspace-handler-thread 'verify-drracket-frame-frontmost)
|
|
(let ([tl (fw:test:get-active-top-level-window)])
|
|
(unless (and (eq? frame tl)
|
|
(drracket-frame? tl))
|
|
(error function-name "drracket frame not frontmost: ~e (found ~e)" frame tl))))
|
|
|
|
(define (clear-definitions frame)
|
|
(queue-callback/res (λ () (verify-drracket-frame-frontmost 'clear-definitions frame)))
|
|
(fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas))))
|
|
(let ([window (queue-callback/res (λ () (send frame get-edit-target-window)))])
|
|
(let-values ([(cw ch) (queue-callback/res (λ () (send window get-client-size)))]
|
|
[(w h) (queue-callback/res (λ () (send window get-size)))])
|
|
(fw:test:mouse-click 'left
|
|
(inexact->exact (floor (+ cw (/ (- w cw) 2))))
|
|
(inexact->exact (floor (+ ch (/ (- h ch) 2)))))))
|
|
(fw:test:menu-select "Edit" "Select All")
|
|
(fw:test:menu-select "Edit" (if (eq? (system-type) 'macos)
|
|
"Clear"
|
|
"Delete")))
|
|
|
|
(define (type-in-definitions frame str)
|
|
(not-on-eventspace-handler-thread 'type-in-definitions)
|
|
(put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #f 'type-in-definitions))
|
|
(define (type-in-interactions frame str)
|
|
(not-on-eventspace-handler-thread 'type-in-interactions)
|
|
(put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #f 'type-in-interactions))
|
|
(define (insert-in-definitions frame str)
|
|
(not-on-eventspace-handler-thread 'insert-in-definitions)
|
|
(put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #t 'insert-in-definitions))
|
|
(define (insert-in-interactions frame str)
|
|
(not-on-eventspace-handler-thread 'insert-in-interactions)
|
|
(put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #t 'insert-in-interactions))
|
|
|
|
(define (put-in-frame get-canvas frame str/sexp just-insert? who)
|
|
(not-on-eventspace-handler-thread 'put-in-frame)
|
|
(unless (and (object? frame) (is-a? frame top-level-window<%>))
|
|
(error who "expected a frame or a dialog as the first argument, got ~e" frame))
|
|
(let ([str (if (string? str/sexp)
|
|
str/sexp
|
|
(let ([port (open-output-string)])
|
|
(parameterize ([current-output-port port])
|
|
(write str/sexp port))
|
|
(get-output-string port)))])
|
|
(queue-callback/res (λ () (verify-drracket-frame-frontmost who frame)))
|
|
(let ([canvas (queue-callback/res (λ () (get-canvas frame)))])
|
|
(fw:test:new-window canvas)
|
|
(let ([editor (queue-callback/res (λ () (send canvas get-editor)))])
|
|
(cond
|
|
[just-insert?
|
|
(let ([s (make-semaphore 0)])
|
|
(queue-callback
|
|
(λ ()
|
|
(send editor set-caret-owner #f)
|
|
(send editor insert str)
|
|
(semaphore-post s)))
|
|
(unless (sync/timeout 3 s)
|
|
(error who "callback didn't run for 3 seconds; trying to insert ~s" str/sexp)))]
|
|
[else
|
|
(queue-callback/res (λ () (send editor set-caret-owner #f)))
|
|
(type-string str)])))))
|
|
|
|
(define (queue-callback/res thunk)
|
|
(not-on-eventspace-handler-thread 'queue-callback/res)
|
|
(let ([c (make-channel)])
|
|
(queue-callback (λ () (channel-put c (with-handlers ((exn:fail? values)) (call-with-values thunk list))))
|
|
#f)
|
|
(define res (channel-get c))
|
|
(when (exn? res) (raise res))
|
|
(apply values res)))
|
|
|
|
(define (alt-return-in-interactions frame)
|
|
(not-on-eventspace-handler-thread 'alt-return-in-interactions)
|
|
(queue-callback/res (λ () (verify-drracket-frame-frontmost 'alt-return-in-interactions frame)))
|
|
(let ([canvas (send frame get-interactions-canvas)])
|
|
(fw:test:new-window canvas)
|
|
(let ([editor (send canvas get-editor)])
|
|
(send editor set-caret-owner #f)
|
|
(fw:test:keystroke #\return '(alt)))))
|
|
|
|
;; type-string : string -> void
|
|
;; to call test:keystroke repeatedly with the characters
|
|
(define (type-string str)
|
|
(not-on-eventspace-handler-thread 'type-string)
|
|
(let ([len (string-length str)])
|
|
(let loop ([i 0])
|
|
(unless (>= i len)
|
|
(let ([c (string-ref str i)])
|
|
(fw:test:keystroke
|
|
(if (char=? c #\newline)
|
|
#\return
|
|
c)))
|
|
(loop (+ i 1))))))
|
|
|
|
(define wait
|
|
(case-lambda
|
|
[(test desc-string) (wait test desc-string 5)]
|
|
[(test desc-string time)
|
|
(let ([int 1/2])
|
|
(let loop ([sofar 0])
|
|
(cond
|
|
[(> sofar time) (error 'wait desc-string)]
|
|
[(test) (void)]
|
|
[else (sleep int)
|
|
(loop (+ sofar int))])))]))
|
|
|
|
(define (wait-pending)
|
|
(wait (lambda () (= 0 (fw:test:number-pending-actions)))
|
|
"Pending actions didn't terminate")
|
|
(fw:test:reraise-error))
|
|
|
|
|
|
;;; get-sub-panel takes
|
|
;;; a list of integers describing the path from a frame to the desired panel
|
|
;;; the frame
|
|
;;; based on code by Mark Krentel
|
|
|
|
;;; Examples:
|
|
;;; (get-sub-panel '() frame) gets the top-panel in frame
|
|
;;; (get-sub-panel '(2) frame) gets the 2nd child of the top-panel
|
|
;;; (get-sub-panel '(2 0) frame) gets the 0th child of the 2nd child of the top-panel
|
|
|
|
(define (get-sub-panel path frame)
|
|
(on-eventspace-handler-thread 'get-sub-panel)
|
|
(letrec ([loop
|
|
(lambda (path panel)
|
|
(if (null? path)
|
|
(if (is-a? panel panel%)
|
|
panel
|
|
(test-util-error "not a panel"))
|
|
(loop
|
|
(cdr path)
|
|
(list-ref (send panel get-children) (car path)))))])
|
|
(loop path frame)))
|
|
|
|
;;; get-text-pos returns the offset in an text buffer of the beginning
|
|
;;; of the last line
|
|
|
|
(define (get-text-pos text)
|
|
(on-eventspace-handler-thread 'get-text-pos)
|
|
(let* ([last-pos (send text last-position)]
|
|
[last-line (send text position-line last-pos)])
|
|
(send text line-start-position last-line)))
|
|
|
|
; poll for enabled button
|
|
|
|
(define (wait-for-button button)
|
|
(not-on-eventspace-handler-thread 'wait-for-button)
|
|
(poll-until
|
|
(let ([wait-for-button-pred
|
|
(lambda ()
|
|
(queue-callback/res (λ () (send button is-enabled?))))])
|
|
wait-for-button-pred)))
|
|
|
|
(define (push-button-and-wait button)
|
|
(not-on-eventspace-handler-thread 'push-button-and-wait)
|
|
(fw:test:button-push button)
|
|
(poll-until
|
|
(let ([button-push-and-wait-pred
|
|
(lambda ()
|
|
(fw:test:reraise-error)
|
|
(= 0 (fw:test:number-pending-actions)))])
|
|
button-push-and-wait-pred))
|
|
(wait-for-button button))
|
|
|
|
;; set-language-level! : (cons (union regexp string) (listof (union regexp string))) boolean -> void
|
|
;; set language level in the frontmost DrRacket frame (resets settings to defaults)
|
|
;; If `close-dialog?' it #t,
|
|
(define set-language-level!
|
|
(lambda (in-language-spec [close-dialog? #t])
|
|
(unless (and (pair? in-language-spec)
|
|
(list? in-language-spec)
|
|
(andmap (lambda (x) (or string? regexp?)) in-language-spec))
|
|
(error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec))
|
|
(not-on-eventspace-handler-thread 'set-language-level!)
|
|
(let ([drs-frame (fw:test:get-active-top-level-window)])
|
|
(fw:test:menu-select "Language" "Choose Language...")
|
|
(define language-dialog (wait-for-new-frame drs-frame))
|
|
(fw:test:set-radio-box-item! #rx"Other Languages")
|
|
(define language-choices (find-labelled-windows #f hierarchical-list% (fw:test:get-active-top-level-window)))
|
|
(define b1 (box 0))
|
|
(define b2 (box 0))
|
|
(define (click-on-snip snip)
|
|
(let* ([editor (send (send snip get-admin) get-editor)]
|
|
[between-threshold (send editor get-between-threshold)])
|
|
(send editor get-snip-location snip b1 b2)
|
|
(let-values ([(gx gy) (send editor editor-location-to-dc-location
|
|
(unbox b1)
|
|
(unbox b2))])
|
|
(let ([x (inexact->exact (floor (+ gx between-threshold 1)))]
|
|
[y (inexact->exact (floor (+ gy between-threshold 1)))])
|
|
(fw:test:mouse-click 'left x y)))))
|
|
|
|
(define found-language? #f)
|
|
|
|
(for ([language-choice (in-list language-choices)])
|
|
(send language-choice focus)
|
|
(let loop ([list-item language-choice]
|
|
[language-spec in-language-spec])
|
|
(let* ([name (car language-spec)]
|
|
[which (filter (lambda (child)
|
|
(let* ([text (send (send child get-editor) get-text)]
|
|
[matches
|
|
(or (and (regexp? name)
|
|
(regexp-match name text))
|
|
(and (string? name)
|
|
(string=? name text)))])
|
|
(and matches
|
|
child)))
|
|
(send list-item get-items))])
|
|
(unless (null? which)
|
|
(unless (= 1 (length which))
|
|
(error 'set-language-level! "couldn't find language: ~e, double match ~e"
|
|
in-language-spec name))
|
|
(let ([next-item (car which)])
|
|
(cond
|
|
[(null? (cdr language-spec))
|
|
(when (is-a? next-item hierarchical-list-compound-item<%>)
|
|
(error 'set-language-level! "expected no more languages after ~e, but still are, input ~e"
|
|
name in-language-spec))
|
|
(set! found-language? #t)
|
|
(click-on-snip (send next-item get-clickable-snip))]
|
|
[else
|
|
(unless (is-a? next-item hierarchical-list-compound-item<%>)
|
|
(error 'set-language-level! "expected more languages after ~e, but got to end, input ~e"
|
|
name in-language-spec))
|
|
(unless (send next-item is-open?)
|
|
(click-on-snip (send next-item get-arrow-snip)))
|
|
(loop next-item (cdr language-spec))]))))))
|
|
|
|
(unless found-language?
|
|
(error 'set-language-level! "couldn't find language: ~e" in-language-spec))
|
|
|
|
(with-handlers ([exn:fail? (lambda (x) (void))])
|
|
(fw:test:button-push "Show Details"))
|
|
|
|
(fw:test:button-push "Revert to Language Defaults")
|
|
|
|
(when close-dialog?
|
|
(fw:test:button-push "OK")
|
|
(let ([new-frame (wait-for-new-frame language-dialog)])
|
|
(unless (eq? new-frame drs-frame)
|
|
(error 'set-language-level!
|
|
"didn't get drracket frame back, got: ~s (drs-frame ~s)\n"
|
|
new-frame
|
|
drs-frame)))))))
|
|
|
|
(define (set-module-language! [close-dialog? #t])
|
|
(not-on-eventspace-handler-thread 'set-module-language!)
|
|
(let ([drs-frame (fw:test:get-active-top-level-window)])
|
|
(fw:test:menu-select "Language" "Choose Language...")
|
|
(let* ([language-dialog (wait-for-new-frame drs-frame)])
|
|
(fw:test:set-radio-box-item! #rx"The Racket Language")
|
|
|
|
(with-handlers ([exn:fail? (lambda (x) (void))])
|
|
(fw:test:button-push "Show Details"))
|
|
|
|
(fw:test:button-push "Revert to Language Defaults")
|
|
|
|
(when close-dialog?
|
|
(fw:test:button-push "OK")
|
|
(let ([new-frame (wait-for-new-frame language-dialog)])
|
|
(unless (eq? new-frame drs-frame)
|
|
(error 'set-language-level!
|
|
"didn't get drracket frame back, got: ~s (drs-frame ~s)\n"
|
|
new-frame
|
|
drs-frame)))))))
|
|
|
|
(provide/contract [check-language-level ((or/c string? regexp?) . -> . void?)])
|
|
;; checks that the language in the drracket window is set to the given one.
|
|
;; clears the definitions, clicks execute and checks the interactions window.
|
|
(define (check-language-level lang-spec)
|
|
(not-on-eventspace-handler-thread 'check-language-level!)
|
|
(let* ([drs-frame (wait-for-drracket-frame)]
|
|
[interactions (send drs-frame get-interactions-text)]
|
|
[definitions-canvas (send drs-frame get-definitions-canvas)])
|
|
(fw:test:new-window definitions-canvas)
|
|
(fw:test:menu-select "Edit" "Select All")
|
|
(fw:test:menu-select "Edit" "Delete")
|
|
(do-execute drs-frame)
|
|
(let ([lang-line (queue-callback/res
|
|
(λ ()
|
|
(send interactions get-text
|
|
(send interactions line-start-position 1)
|
|
(send interactions line-end-position 1))))])
|
|
(unless (regexp-match lang-spec lang-line)
|
|
(error 'check-language-level "expected ~s to match ~s"
|
|
lang-line lang-spec)))))
|
|
|
|
|
|
(define (repl-in-edit-sequence?)
|
|
(not-on-eventspace-handler-thread 'repl-in-edit-sequence?)
|
|
(let ([drr (wait-for-drracket-frame)])
|
|
(queue-callback/res
|
|
(λ ()
|
|
(send (send drr get-interactions-text) refresh-delayed?)))))
|
|
|
|
;; has-error? : frame -> (union #f string)
|
|
;; returns the error text of an error in the interactions window of the frame or #f if there is none.
|
|
;; ensures that frame is front most.
|
|
(define (has-error? frame)
|
|
(not-on-eventspace-handler-thread 'repl-in-edit-sequence?)
|
|
(run-one/sync
|
|
(lambda ()
|
|
(verify-drracket-frame-frontmost 'had-error? frame)
|
|
(let* ([interactions-text (send frame get-interactions-text)]
|
|
[last-para (send interactions-text last-paragraph)])
|
|
(unless (>= last-para 2)
|
|
(error 'has-error? "expected at least 2 paragraphs in interactions window, found ~a"
|
|
(+ last-para 1)))
|
|
(let ([start (send interactions-text paragraph-start-position 2)]
|
|
[end (send interactions-text paragraph-end-position
|
|
(- (send interactions-text last-paragraph) 1))])
|
|
(send interactions-text split-snip start)
|
|
(send interactions-text split-snip end)
|
|
(let loop ([pos start])
|
|
(cond
|
|
[(<= end pos) #f]
|
|
[else
|
|
(let ([snip (send interactions-text find-snip pos 'after-or-none)])
|
|
(cond
|
|
[(not snip) #f]
|
|
[else
|
|
(let ([color (send (send snip get-style) get-foreground)])
|
|
(if (and (= 255 (send color red))
|
|
(= 0 (send color blue) (send color green)))
|
|
|
|
;; return the text of the entire line containing the red text
|
|
(let ([para (send interactions-text position-paragraph pos)])
|
|
(unless (exact-nonnegative-integer? para)
|
|
(error 'has-error? "got back a bad result from position-paragraph: ~s ~s\n"
|
|
para
|
|
(list pos (send interactions-text last-position))))
|
|
(send interactions-text get-text
|
|
(send interactions-text paragraph-start-position para)
|
|
(send interactions-text paragraph-end-position para)))
|
|
|
|
(loop (+ pos (send snip get-count)))))]))])))))))
|
|
|
|
(define fetch-output
|
|
(case-lambda
|
|
[(frame) (fetch-output frame #f #f)]
|
|
[(frame _start _end)
|
|
(not-on-eventspace-handler-thread 'fetch-output)
|
|
(run-one/sync
|
|
(lambda ()
|
|
(verify-drracket-frame-frontmost 'fetch-output frame)
|
|
(let-values ([(start end)
|
|
(if (and _start _end)
|
|
(values _start _end)
|
|
(let* ([interactions-text (send frame get-interactions-text)]
|
|
[last-para (send interactions-text last-paragraph)])
|
|
(unless (>= last-para 2)
|
|
(error 'fetch-output "expected at least 2 paragraphs in interactions window, found ~a"
|
|
(+ last-para 1)))
|
|
(values (send interactions-text paragraph-start-position 2)
|
|
(send interactions-text paragraph-end-position
|
|
(- (send interactions-text last-paragraph) 1)))))])
|
|
(let ([interactions-text (send frame get-interactions-text)])
|
|
|
|
(send interactions-text split-snip start)
|
|
(send interactions-text split-snip end)
|
|
|
|
(let loop ([snip (send interactions-text find-snip end 'before)]
|
|
[strings null])
|
|
(cond
|
|
[(< (send interactions-text get-snip-position snip) start)
|
|
(apply string-append strings)]
|
|
[else
|
|
(cond
|
|
[(is-a? snip string-snip%)
|
|
(loop (send snip previous)
|
|
(cons (send snip get-text 0 (send snip get-count)) strings))]
|
|
[(is-a? snip editor-snip%)
|
|
(let ([editor (send snip get-editor)])
|
|
(cond
|
|
[(is-a? editor pasteboard%)
|
|
(loop (send snip previous)
|
|
(cons "<pasteboard>" strings))]
|
|
[(is-a? editor text%)
|
|
(loop (send snip previous)
|
|
(list* "{embedded \""
|
|
(send editor get-text)
|
|
"\"}"
|
|
strings))]))]
|
|
[(is-a? snip image-snip%)
|
|
(loop (send snip previous)
|
|
(cons (with-handlers ([exn:fail? (lambda (x) "{image}")])
|
|
(format "{~a}" (send snip get-image-name)))
|
|
strings))]
|
|
|
|
[;; this test is an approximation of
|
|
;; (is-a? snip drscheme:snip:number-snip%)
|
|
(and (method-in-interface? 'get-fraction-view (object-interface snip)))
|
|
(loop (send snip previous)
|
|
(cons (format "{number ~s ~s ~s}"
|
|
(send snip get-number)
|
|
(send snip get-text 0 (send snip get-count))
|
|
(send snip get-fraction-view))
|
|
strings))]
|
|
[;; this test is an approximation of
|
|
;; (is-a? snip pict-snip%) from drracket/private/pict-snip%
|
|
(let ([sc (send snip get-snipclass)])
|
|
(and sc (regexp-match #rx"pict-snip.rkt" (send sc get-classname))))
|
|
(loop (send snip previous)
|
|
(cons "{pict-snip}" strings))]
|
|
|
|
[else
|
|
(loop (send snip previous)
|
|
(cons (format "{unknown snip: ~e}\n" snip)
|
|
strings))])]))))))]))
|
|
|
|
;; run-one/sync : (-> A) -> A
|
|
;; runs the thunk `f' as a test action, and
|
|
;; waits for it to complete. Also propagates
|
|
;; exceptions.
|
|
(define (run-one/sync f)
|
|
(not-on-eventspace-handler-thread 'repl-in-edit-sequence?)
|
|
(let ([s (make-semaphore 0)]
|
|
[raised-exn? #f]
|
|
[exn #f]
|
|
[anss #f])
|
|
(fw:test:run-one
|
|
(lambda ()
|
|
(with-handlers ([exn:fail? (lambda (-exn)
|
|
(set! raised-exn? #t)
|
|
(set! exn -exn))])
|
|
(call-with-values f (lambda x (set! anss x))))
|
|
(semaphore-post s)))
|
|
(semaphore-wait s)
|
|
(if raised-exn?
|
|
(raise exn)
|
|
(apply values anss))))
|
|
|
|
;; this is assumed to not open an windows or anything like that
|
|
;; but just to print and return.
|
|
(define orig-display-handler (error-display-handler))
|
|
|
|
(define (fire-up-drracket-and-run-tests
|
|
#:use-focus-table? [use-focus-table? #t]
|
|
#:prefs [prefs '()]
|
|
run-test)
|
|
(on-eventspace-handler-thread 'fire-up-drracket-and-run-tests)
|
|
(let ()
|
|
(use-hash-for-prefs fw:preferences:low-level-get-preference
|
|
fw:preferences:low-level-put-preferences
|
|
fw:preferences:restore-defaults
|
|
prefs)
|
|
|
|
(parameterize ([current-command-line-arguments #()])
|
|
(dynamic-require 'drracket #f))
|
|
|
|
(fw:test:use-focus-table use-focus-table?)
|
|
|
|
(thread (λ ()
|
|
(let ([orig-display-handler (error-display-handler)])
|
|
(uncaught-exception-handler
|
|
(λ (x)
|
|
(if (exn? x)
|
|
(orig-display-handler (exn-message x) x)
|
|
(eprintf "uncaught exception ~s\n" x))
|
|
(exit 1))))
|
|
(run-test)
|
|
(exit)))
|
|
(yield (make-semaphore 0))))
|
|
|
|
;; fire-up-separate-drracket-and-run-tests : (-> any) -> any
|
|
;; creates a separate custodian, eventspace, namespace, etc to
|
|
;; start up a new DrRacket. This has the advantage over fire-up-drracket-and-run-tests
|
|
;; that a single test suite can start up DrRacket multiple times, but it has the
|
|
;; disadvantage that there is little sharing between the test suite implementation code and
|
|
;; DrRacket, so writing the testing code is more painful
|
|
;;
|
|
;; the only things shared are mred/mred (and its dependencies).
|
|
(define (fire-up-separate-drracket-and-run-tests run-test)
|
|
(define c (make-custodian))
|
|
(define s (make-semaphore 0))
|
|
(define orig-ns (current-namespace))
|
|
(parameterize ([current-custodian c])
|
|
(parameterize ([exit-handler (λ (v)
|
|
(semaphore-post s)
|
|
(custodian-shutdown-all c))]
|
|
[current-namespace (make-empty-namespace)]
|
|
[current-command-line-arguments #()])
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(namespace-attach-module orig-ns 'mred/mred)
|
|
|
|
;; do this now so that dynamically requiring framework
|
|
;; exports during the call to 'run-test' is safe
|
|
(namespace-require 'framework)
|
|
|
|
(queue-callback
|
|
(λ ()
|
|
(use-hash-for-prefs (dynamic-require 'framework 'preferences:low-level-get-preference)
|
|
(dynamic-require 'framework 'preferences:low-level-put-preferences)
|
|
(dynamic-require 'framework 'preferences:restore-defaults)
|
|
'())
|
|
(dynamic-require 'drracket #f)
|
|
(thread (λ ()
|
|
(run-test)
|
|
(exit)))
|
|
(yield (make-semaphore 0)))))))
|
|
(semaphore-wait s))
|
|
|
|
(define (use-hash-for-prefs preferences:low-level-get-preference
|
|
preferences:low-level-put-preferences
|
|
preferences:restore-defaults
|
|
prefs)
|
|
;; change the preferences system so that it doesn't write to
|
|
;; a file; partly to avoid problems of concurrency in drdr
|
|
;; but also to make the test suite easier for everyone to run.
|
|
(let ([prefs-table (make-hash)])
|
|
(preferences:low-level-put-preferences
|
|
(λ (names vals)
|
|
(for ([name (in-list names)]
|
|
[val (in-list vals)])
|
|
(hash-set! prefs-table name val))))
|
|
(preferences:low-level-get-preference
|
|
(λ (name [fail (lambda () #f)])
|
|
(hash-ref prefs-table name fail)))
|
|
|
|
;; set all preferences to their defaults (some pref values may have
|
|
;; been read by this point, but hopefully that won't affect the
|
|
;; startup of drracket)
|
|
(preferences:restore-defaults)
|
|
|
|
;; initialize some preferences to simulate these
|
|
;; being saved already in the user's prefs file
|
|
(for ([pref (in-list prefs)])
|
|
(define pref-key (list-ref pref 0))
|
|
(define pref-val (list-ref pref 1))
|
|
(unless (regexp-match #rx"^plt:framework-pref:" (symbol->string pref-key))
|
|
;; this currently doesn't happen, and it is easy to forget
|
|
;; that prefix, so print a message here to remind
|
|
(printf "WARNING: setting a preference that isn't set via the framework: ~s\n"
|
|
pref-key))
|
|
(hash-set! prefs-table pref-key pref-val))))
|
|
|
|
(define (not-on-eventspace-handler-thread fn)
|
|
(when (eq? (current-thread) (eventspace-handler-thread (current-eventspace)))
|
|
(error fn "expected to be run on some thread other than the eventspace handler thread")))
|
|
|
|
(define (on-eventspace-handler-thread fn)
|
|
(unless (eq? (current-thread) (eventspace-handler-thread (current-eventspace)))
|
|
(error fn "expected to be run on the eventspace handler thread")))
|