suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed up module language test suite for new language dialog, plus misc cleanups based on last release

Browse Source 
svn: r17922
This commit is contained in:
Robby Findler 2010-02-01 15:18:28 +00:00
parent 9d34139659
commit bf67e34e87
4 changed files with 144 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
collects/tests/drscheme/drscheme-test-util.ss
View File

@ -1,22 +1,15 @@
;;; util.ss
#lang scheme/base
;;; utility functions for DrScheme GUI testing
;;; Authors: Robby Findler, Paul Steckler
(module drscheme-test-util mzscheme
(require (prefix fw: framework)
mrlib/hierlist
mred
mzlib/class
mzlib/list
mzlib/contract
mzlib/etc
tests/utils/gui
mzlib/contract)
(require (prefix-in fw: framework)
mrlib/hierlist
scheme/gui/base
scheme/class
scheme/contract
tests/utils/gui)
(provide/contract
[use-get/put-dialog ((-> any) path? . -> . void?)])
[use-get/put-dialog (-> (-> any) path? void?)]
[set-module-language! (->* () (boolean?) void?)])
(provide save-drscheme-window-as
do-execute
@ -83,19 +76,19 @@
;; 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))])
(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))))))))))
(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)))
@ -321,7 +314,45 @@
;; 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])
(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 '(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))
@ -383,6 +414,38 @@
(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 (drs-frame ~s)\n"
new-frame
drs-frame)))))))) "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? (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))
(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)])
@ -391,7 +454,26 @@
"didn't get drscheme frame back, got: ~s (drs-frame ~s)\n"
new-frame
drs-frame))))))))
(define (set-module-language! [close-dialog? #t])
(let ([drs-frame (get-top-level-focus-window)])
(fw:test:menu-select "Language" "Choose Language...")
(let* ([language-dialog (wait-for-new-frame drs-frame)])
(fw:test:set-radio-box-item! "Use the language declared in the source")
(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 (drs-frame ~s)\n"
new-frame
drs-frame)))))))
(provide/contract [check-language-level ((or/c 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.
@ -536,4 +618,4 @@
(semaphore-wait s)
(if raised-exn?
(raise exn)
(apply values anss)))))
(apply values anss))))

30
collects/tests/drscheme/language-test.ss
View File

@ -289,10 +289,8 @@ the settings above should match r5rs
"call/cc: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: call/cc")
(test-expression "(error 'a \"~a\" 1)"
"procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
(test-expression "(error \"a\" \"a\")"
"error: expected a symbol and a string, got \"a\" and \"a\"")
(test-expression "(error 'a \"~a\" 1)" "a: ~a1")
(test-expression "(error \"a\" \"a\")" "aa")
(test-expression "(time 1)"
"time: name is not defined, not a parameter, and not a primitive name"
@ -456,10 +454,8 @@ the settings above should match r5rs
"call/cc: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: call/cc")
(test-expression "(error 'a \"~a\" 1)"
"procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
(test-expression "(error \"a\" \"a\")"
"error: expected a symbol and a string, got \"a\" and \"a\"")
(test-expression "(error 'a \"~a\" 1)" "a: ~a1")
(test-expression "(error \"a\" \"a\")" "aa")
(test-expression "(time 1)"
"time: name is not defined, not a parameter, and not a primitive name"
@ -619,10 +615,8 @@ the settings above should match r5rs
"call/cc: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: call/cc")
(test-expression "(error 'a \"~a\" 1)"
"procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
(test-expression "(error \"a\" \"a\")"
"error: expected a symbol and a string, got \"a\" and \"a\"")
(test-expression "(error 'a \"~a\" 1)" "a: ~a1")
(test-expression "(error \"a\" \"a\")" "aa")
(test-expression "(time 1)"
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
@ -778,10 +772,8 @@ the settings above should match r5rs
"call/cc: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: call/cc")
(test-expression "(error 'a \"~a\" 1)"
"procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
(test-expression "(error \"a\" \"a\")"
"error: expected a symbol and a string, got \"a\" and \"a\"")
(test-expression "(error 'a \"~a\" 1)" "a: ~a1")
(test-expression "(error \"a\" \"a\")" "aa")
(test-expression "(time 1)"
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
@ -931,10 +923,8 @@ the settings above should match r5rs
"call/cc: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: call/cc")
(test-expression "(error 'a \"~a\" 1)"
"procedure error: expects 2 arguments, given 3: 'a \"~a\" 1")
(test-expression "(error \"a\" \"a\")"
"error: expected a symbol and a string, got \"a\" and \"a\"")
(test-expression "(error 'a \"~a\" 1)" "a: ~a1")
(test-expression "(error \"a\" \"a\")" "aa")
(test-expression "(time 1)"
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")

16
collects/tests/drscheme/module-lang-test-utils.ss
View File

@ -139,7 +139,7 @@
(run-use-compiled-file-paths-tests)
(set-language-level! '("Module") #f)
(set-module-language! #f)
(test:set-radio-box-item! "Debugging")
(let ([f (get-top-level-focus-window)])
(test:button-push "OK")
@ -153,7 +153,7 @@
(define (run-use-compiled-file-paths-tests)
(define (setup-dialog/run proc)
(set-language-level! '("Module") #f)
(set-module-language! #f)
(proc)
(let ([f (get-top-level-focus-window)])
(test:button-push "OK")
@ -163,10 +163,10 @@
(define (run-one-test radio-box expected [no-check-expected #f])
(let ([got (setup-dialog/run (λ () (test:set-radio-box-item! radio-box)))])
(unless (equal? got (format "~s" expected))
(unless (spaces-equal? got (format "~s" expected))
(error 'r-u-c-f-p-t "got ~s expected ~s"
got
expected)))
(format "~s" expected))))
(when no-check-expected
(let ([got (setup-dialog/run
@ -176,8 +176,12 @@
(unless (equal? got (format "~s" no-check-expected))
(error 'r-u-c-f-p-t.2 "got ~s expected ~s"
got
expected)))))
(format "~s" no-check-expected))))))
(define (spaces-equal? a b)
(equal? (regexp-replace* #rx"[\n\t ]+" a " ")
(regexp-replace* #rx"[\n\t ]+" b " ")))
(define drs/compiled/et (build-path "compiled" "drscheme" "errortrace"))
(define drs/compiled (build-path "compiled" "drscheme"))
(define compiled/et (build-path "compiled" "errortrace"))

26
collects/tests/drscheme/repl-test.ss
View File

@ -81,7 +81,7 @@ This produces an ACK message
(define test-data
(list
#|
;; basic tests
(mktest "1"
("1"
@ -840,21 +840,18 @@ This produces an ACK message
void
void)
|#
(mktest "(new snip%)"
("1"
"1"
"1"
"1"
"1"
"1")
(mktest "(new snip%)"
("{unknown snip: #(struct:object:snip% ...)}\n"
"{unknown snip: #(struct:object:snip% ...)}\n"
"{unknown snip: #(struct:object:snip% ...)}\n"
"{unknown snip: #(struct:object:snip% ...)}\n"
"{unknown snip: #(struct:object:snip% ...)}\n"
"{unknown snip: #(struct:object:snip% ...)}\n")
'interactions
#f
void
void)
;; graphical lambda tests
(mktest (list "((" '("Insert" "Insert λ") "(x) x) 1)")
@ -999,9 +996,8 @@ This produces an ACK message
'interactions
#f
void
void)
))
void)))
;; these tests aren't used at the moment.
#;
(define xml-tests