More racket/htdp#229: save the buffer in some test

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,82 @@ 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")
+        (case (system-type 'os)
+          [(macosx windows)
+           (test:menu-select "Windows" (format "Tab 1: ~a" filename))
+           (test:menu-select "File" "Close Tab")]
+          [(unix)
+           (test:menu-select "Tabs" (format "Tab 1: ~a" filename))
+           (test:menu-select "File" "Close")])
+        (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)))
+
+ (local [(define lam-in-if
+          (if (> (random 10) 5)
+              (lambda (x) (+ x 5))
+              (lambda (y) (* y 2))))]
+  lam-in-if)
+
+}
+      #f
+      @rx{^my-add1
+          keep-parity
+          alt-parity
+          [(]lambda [(]a1[)] [.][.][.][)]
+          lam-in-if
+          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+
 
@@ -684,12 +761,19 @@ f: contract violation
    (lambda (m)
      (+ m 2)))
 
+ (local [(define lam-in-if
+          (if (> (random 10) 5)
+              (lambda (x) (+ x 5))
+              (lambda (y) (* y 2))))]
+  lam-in-if)
+
 }
       #f
       @rx{^my-add1
           keep-parity
           alt-parity
           [(]lambda [(]a1[)] [.][.][.][)]
+          lam-in-if
           Ran 1 test[.]
           0 tests passed[.]}
       #:extra-assert
@@ -698,6 +782,58 @@ 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")
+        (case (system-type 'os)
+          [(macosx windows)
+           (test:menu-select "Windows" (format "Tab 1: ~a" filename))
+           (test:menu-select "File" "Close Tab")]
+          [(unix)
+           (test:menu-select "Tabs" (format "Tab 1: ~a" filename))
+           (test:menu-select "File" "Close")])
+        (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 +940,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)

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)