diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 79eb347f9..fdbe97d4d 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -2,6 +2,7 @@ (require "private/module-lang-test-utils.rkt" "private/drracket-test-util.rkt" framework + (only-in racket/gui/base sleep/yield) drracket/private/stack-checkpoint racket/list racket/class) @@ -665,6 +666,74 @@ f: contract violation ;; ^ check-within is highlighted ))) +(let () +(define filename @t{gh208-pr229-islplus.rkt}) +(define path (string->path (in-here/path filename))) +(test #:before-execute + (λ () + (save-drracket-window-as path)) + #:after-test + (λ () + (define drs (wait-for-drracket-frame)) + (test:menu-select "File" "New Tab") + (with-handlers ([(λ (e) + (regexp-match? #rx"didn't find a menu: \"Windows\"" (exn-message e))) + (λ (e) + (test:menu-select "Tabs" (format "Tab 1: ~a" filename)))]) + (test:menu-select "Windows" (format "Tab 1: ~a" filename))) + (test:menu-select "File" "Close Tab") + (when (file-exists? path) + (delete-file path))) + #:wait-for-drracket-frame-after-test? #t + @t{ + #lang htdp/isl+ + + (define (my-add1 n) (+ n 1)) + my-add1 + (check-expect my-add1 2) + + (let ([keep-parity (lambda (m) + (+ m 2))]) + keep-parity) + + (local [(define alt-parity (lambda (m) + (- 1 m)))] + alt-parity) + + (let () + (lambda (m) + (+ m 2))) + +} + #f + @rx{^my-add1 + keep-parity + alt-parity + [(]lambda [(]a1[)] [.][.][.][)] + Ran 1 test[.] + 0 tests passed[.]} + #:extra-assert + (λ (defs ints #:test test) + (define ^\n "[^\n]+") + (define re + (pregexp + @t{::\s+in @(regexp-quote filename), line 5, column 0@|^\n|function@|^\n|given my-add1})) + ;; Includes the flattened test result snips. + (define full-ints-text + (send ints get-text (send ints paragraph-start-position 2) 'eof #t)) + (define passed? + (regexp-match? re full-ints-text)) + (unless passed? + (eprintf "FAILED line ~a: ~a\n extra assertion expected: ~s\n\n got: ~a\n" + (test-line test) + (test-definitions test) + re + full-ints-text) + (flush-output (current-error-port)) + (sleep/yield 0.1)) + passed?))) + +;; Run the same test, but in an unsaved buffer. (test @t{ #lang htdp/isl+ @@ -698,6 +767,57 @@ f: contract violation ;; Includes the flattened test result snips. (send ints get-text (send ints paragraph-start-position 2) 'eof #t)))) +(let () +(define filename @t{gh208-pr229-isl.rkt}) +(define path (string->path (in-here/path filename))) +(test #:before-execute + (λ () + (save-drracket-window-as path)) + #:after-test + (λ () + (define drs (wait-for-drracket-frame)) + (test:menu-select "File" "New Tab") + (with-handlers ([(λ (e) + (regexp-match? #rx"didn't find a menu: \"Windows\"" (exn-message e))) + (λ (e) + (test:menu-select "Tabs" (format "Tab 1: ~a" filename)))]) + (test:menu-select "Windows" (format "Tab 1: ~a" filename))) + (test:menu-select "File" "Close Tab") + (when (file-exists? path) + (delete-file path))) + #:wait-for-drracket-frame-after-test? #t + @t{ + #lang htdp/isl + + (define (my-add1 n) (+ n 1)) + my-add1 + (check-expect my-add1 2) + + (let ([keep-parity (lambda (m) + (+ m 2))]) + keep-parity) + + (local [(define alt-parity (lambda (m) + (- 1 m)))] + alt-parity) + +} + #f + @rx{^function:my-add1 + function:keep-parity + function:alt-parity + Ran 1 test[.] + 0 tests passed[.]} + #:extra-assert + (λ (defs ints) + (define ^\n "[^\n]+") + (regexp-match? + (pregexp + @t{::\s+in @(regexp-quote filename), line 5, column 0@|^\n|function@|^\n|given function:my-add1}) + ;; Includes the flattened test result snips. + (send ints get-text (send ints paragraph-start-position 2) 'eof #t))))) + +;; Run the same test, but in an unsaved buffer. (test @t{ #lang htdp/isl @@ -804,7 +924,9 @@ f: contract violation (test-line test) (test-definitions test) re - full-ints-text)) + full-ints-text) + (flush-output (current-error-port)) + (sleep/yield 0.1)) passed?)) (fire-up-drracket-and-run-tests run-test) diff --git a/drracket-test/tests/drracket/private/module-lang-test-utils.rkt b/drracket-test/tests/drracket/private/module-lang-test-utils.rkt index ee8a50591..3c68ea7fd 100644 --- a/drracket-test/tests/drracket/private/module-lang-test-utils.rkt +++ b/drracket-test/tests/drracket/private/module-lang-test-utils.rkt @@ -20,6 +20,9 @@ interactions ; (union #f string) result ; (or/c string regexp) all? ; boolean (#t => compare all of the text between the 3rd and n-1-st line) + before-exec ; (-> any) + after-test ; (-> any) + wait-for-drracket-frame-after-test? ; boolean extra-assert ; (-> (is-a?/c text) (is-a?/c text) boolean) line) ; number or #f: the line number of the test case #:name test-struct @@ -35,11 +38,17 @@ (with-syntax ([line (syntax-line stx)]) #'(test/proc line args ...))])) (define (test/proc line definitions interactions results [all? #f] - #:extra-assert [extra-assert (λ (x y) #t)]) + #:extra-assert [extra-assert (λ (x y) #t)] + #:before-execute [before-exec (λ () (void))] + #:after-test [after-test (λ () (void))] + #:wait-for-drracket-frame-after-test? [wait-for-drs? #f]) (set! tests (cons (make-test definitions interactions results - all? + all? + before-exec + after-test + wait-for-drs? extra-assert line) tests))) @@ -82,6 +91,7 @@ (error 'module-lang-test-utils.rkt "unknown thing in test-definitions field ~s" to-handle)])) + ((test-before-exec test)) (do-execute drs) (define ints (test-interactions test)) @@ -189,16 +199,22 @@ (values (car kw-val) (cdr kw-val)))) (unless (keyword-apply the-assert kws kw-vals definitions-text interactions-text '()) (eprintf "FAILED line ~a; extra assertion returned #f\n" - (test-line test))))) + (test-line test))) + ((test-after-test test)) + (when (test-wait-for-drracket-frame-after-test? test) + (retrieve-drracket-frames!)))) (define drs 'not-yet-drs-frame) (define interactions-text 'not-yet-interactions-text) (define definitions-text 'not-yet-definitions-text) -(define (run-test) +(define (retrieve-drracket-frames!) (set! drs (wait-for-drracket-frame)) (set! interactions-text (send drs get-interactions-text)) - (set! definitions-text (send drs get-definitions-text)) + (set! definitions-text (send drs get-definitions-text))) + +(define (run-test) + (retrieve-drracket-frames!) (init-temp-files) (run-use-compiled-file-paths-tests) (set-module-language! #f)