500 lines
21 KiB
Scheme
500 lines
21 KiB
Scheme
;;; util.ss
|
|
|
|
;;; utility functions for DrScheme GUI testing
|
|
|
|
;;; Authors: Robby Findler, Paul Steckler
|
|
|
|
(module drscheme-test-util mzscheme
|
|
(require (prefix fw: (lib "framework.ss" "framework"))
|
|
(lib "hierlist.ss" "hierlist")
|
|
(lib "mred.ss" "mred")
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "contract.ss")
|
|
(lib "etc.ss")
|
|
(lib "gui.ss" "tests" "utils")
|
|
(lib "contract.ss"))
|
|
|
|
(provide/contract
|
|
[use-get/put-dialog ((-> any) path? . -> . void?)])
|
|
|
|
(provide save-drscheme-window-as
|
|
do-execute
|
|
test-util-error
|
|
poll-until
|
|
wait-for-computation
|
|
wait-for-drscheme-frame
|
|
wait-for-new-frame
|
|
clear-definitions
|
|
type-in-definitions
|
|
type-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)
|
|
|
|
;; save-drscheme-window-as : string -> void
|
|
;; use the "save as" dialog in drscheme to save the definitions
|
|
;; window to a file.
|
|
(define (save-drscheme-window-as filename)
|
|
(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)
|
|
(let ([drs (wait-for-drscheme-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 "Full pathname") 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
|
|
(opt-lambda (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 (drscheme-frame? frame)
|
|
(method-in-interface? 'get-execute-button (object-interface frame)))
|
|
|
|
(define wait-for-drscheme-frame
|
|
(case-lambda
|
|
[() (wait-for-drscheme-frame #t)]
|
|
[(print-message?)
|
|
(let ([wait-for-drscheme-frame-pred
|
|
(lambda ()
|
|
(let ([active (get-top-level-focus-window)])
|
|
(if (and active
|
|
(drscheme-frame? active))
|
|
active
|
|
#f)))])
|
|
(or (wait-for-drscheme-frame-pred)
|
|
(begin
|
|
(when print-message?
|
|
(printf "Select DrScheme frame~n"))
|
|
(poll-until wait-for-drscheme-frame-pred))))]))
|
|
|
|
;; 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
|
|
(case-lambda
|
|
[(old-frame) (wait-for-new-frame old-frame null)]
|
|
[(old-frame extra-eventspaces)
|
|
(wait-for-new-frame old-frame extra-eventspaces 10)]
|
|
[(old-frame extra-eventspaces timeout)
|
|
(let ([wait-for-new-frame-pred
|
|
(lambda ()
|
|
(let ([active (or (get-top-level-focus-window)
|
|
(ormap
|
|
(lambda (eventspace)
|
|
(parameterize ([current-eventspace eventspace])
|
|
(get-top-level-focus-window)))
|
|
extra-eventspaces))])
|
|
(if (and active
|
|
(send active get-focus-window)
|
|
(not (eq? active old-frame)))
|
|
active
|
|
#f)))])
|
|
(poll-until wait-for-new-frame-pred timeout))]))
|
|
|
|
;; wait-for-computation : frame -> void
|
|
;; waits until the drscheme 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)
|
|
(verify-drscheme-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)))
|
|
|
|
(define do-execute
|
|
(case-lambda
|
|
[(frame)
|
|
(do-execute frame #t)]
|
|
[(frame wait-for-finish?)
|
|
(verify-drscheme-frame-frontmost 'do-execute frame)
|
|
(let ([button (send frame get-execute-button)])
|
|
(fw:test:button-push button)
|
|
(when wait-for-finish?
|
|
(wait-for-computation frame)))]))
|
|
|
|
(define (verify-drscheme-frame-frontmost function-name frame)
|
|
(unless (and (eq? frame (get-top-level-focus-window))
|
|
(drscheme-frame? frame))
|
|
(error function-name "drscheme frame not frontmost: ~e" frame)))
|
|
|
|
(define (clear-definitions frame)
|
|
(verify-drscheme-frame-frontmost 'clear-definitions frame)
|
|
(fw:test:new-window (send frame get-definitions-canvas))
|
|
(let ([window (send frame get-focus-window)])
|
|
(let-values ([(cw ch) (send window get-client-size)]
|
|
[(w h) (send window get-size)])
|
|
(fw:test:mouse-click 'left
|
|
(inexact->exact (+ cw (floor (/ (- w cw) 2))))
|
|
(inexact->exact (+ ch (floor (/ (- 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)
|
|
(type-in-definitions/interactions (lambda (x) (send x get-definitions-canvas)) frame str))
|
|
(define (type-in-interactions frame str)
|
|
(type-in-definitions/interactions (lambda (x) (send x get-interactions-canvas)) frame str))
|
|
|
|
(define (type-in-definitions/interactions get-canvas frame str/sexp)
|
|
(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)))])
|
|
(verify-drscheme-frame-frontmost 'type-in-definitions/interactions frame)
|
|
(let ([canvas (get-canvas frame)])
|
|
(fw:test:new-window canvas)
|
|
(send (send canvas get-editor) set-caret-owner #f)
|
|
(type-string str))))
|
|
|
|
;; type-string : string -> void
|
|
;; to call test:keystroke repeatedly with the characters
|
|
(define (type-string str)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(poll-until
|
|
(let ([wait-for-button-pred
|
|
(lambda ()
|
|
(send button is-enabled?))])
|
|
wait-for-button-pred)))
|
|
|
|
(define (push-button-and-wait button)
|
|
(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 DrScheme frame (resets settings to defaults)
|
|
;; If `close-dialog?' it #t,
|
|
(define set-language-level!
|
|
(opt-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))
|
|
(let ([drs-frame (get-top-level-focus-window)])
|
|
(fw:test:menu-select "Language" "Choose Language...")
|
|
(let* ([language-dialog (wait-for-new-frame drs-frame)]
|
|
[language-choice (find-labelled-window #f hierarchical-list%)]
|
|
[b1 (box 0)]
|
|
[b2 (box 0)]
|
|
[click-on-snip
|
|
(lambda (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 (+ gx between-threshold 1))]
|
|
[y (inexact->exact (+ gy between-threshold 1))])
|
|
(fw:test:mouse-click 'left x y)))))])
|
|
(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))])
|
|
(when (null? which)
|
|
(error 'set-language-level! "couldn't find language: ~e, no match at ~e"
|
|
in-language-spec name))
|
|
(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? (rest 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))
|
|
(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))]))))
|
|
|
|
(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 drscheme frame back, got: ~s\n" new-frame))))))))
|
|
|
|
(provide/contract [check-language-level ((union string? regexp?) . -> . void?)])
|
|
;; checks that the language in the drscheme window is set to the given one.
|
|
;; clears the definitions, clicks execute and checks the interactions window.
|
|
(define (check-language-level lang-spec)
|
|
(let* ([drs-frame (get-top-level-focus-window)]
|
|
[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 (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?)
|
|
(send (send (wait-for-drscheme-frame) 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)
|
|
(run-one/sync
|
|
(lambda ()
|
|
(verify-drscheme-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)])
|
|
(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)
|
|
(run-one/sync
|
|
(lambda ()
|
|
(verify-drscheme-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))]
|
|
|
|
[else (error 'find-output "{unknown snip: ~e}~n" snip)])]))))))]))
|
|
|
|
;; run-one/sync : (-> A) -> A
|
|
;; runs the thunk `f' as a test action, and
|
|
;; waits for it to complete. Also propogates
|
|
;; exceptions.
|
|
(define (run-one/sync f)
|
|
(let ([s (make-semaphore 0)]
|
|
[exn #f]
|
|
[anss #f])
|
|
(fw:test:run-one
|
|
(lambda ()
|
|
(with-handlers ([exn:fail? (lambda (exn) (set! exn exn))])
|
|
(call-with-values f (lambda x (set! anss x))))
|
|
(semaphore-post s)))
|
|
(semaphore-wait s)
|
|
(if anss
|
|
(apply values anss)
|
|
(raise exn))))) |