fixed up module language test suite for new language dialog, plus misc cleanups based on last release
svn: r17922
This commit is contained in:
parent
9d34139659
commit
bf67e34e87
|
@ -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))))
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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"))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user