diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index a59708d991..f86f95303b 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -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)))) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 3f8abef864..8b2bcc5fab 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -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") diff --git a/collects/tests/drscheme/module-lang-test-utils.ss b/collects/tests/drscheme/module-lang-test-utils.ss index bc16fc483b..0a2e14a53e 100644 --- a/collects/tests/drscheme/module-lang-test-utils.ss +++ b/collects/tests/drscheme/module-lang-test-utils.ss @@ -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")) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 6d89c636b5..418957a608 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -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