From 651e1f191f3f6876cd4092984636cd96659d1782 Mon Sep 17 00:00:00 2001 From: shhyou Date: Thu, 24 Oct 2024 15:23:36 -0500 Subject: [PATCH 01/10] Add some tests for racket/htdp#228 --- .../tests/drracket/module-lang-test.rkt | 138 ++++++++++++++++++ .../private/module-lang-test-utils.rkt | 21 ++- 2 files changed, 154 insertions(+), 5 deletions(-) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index b0f095db3..0f96e44b6 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -2,6 +2,8 @@ (require "private/module-lang-test-utils.rkt" "private/drracket-test-util.rkt" framework + drracket/private/stack-checkpoint + racket/list racket/class) (provide run-test) @@ -527,6 +529,142 @@ f: contract violation } ) +(test @t{ + #lang htdp/isl+ + + (check-expect (+ 123 45 6) even?) + +} + #f + #rx"check-expect.*function" + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? #rx"unsaved-editor:3:0" + (srcloc->string loc))) + ;; ^ check-expect is in the backtrace, not some internal test-engine modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]check-expect.*[?][)]" + (test-definitions test))) + ;; ^ check-expect is highlighted + ))) + +(test @t{ + #lang htdp/isl+ + + (check-expect (sqrt 2) (sqrt 2)) + +} + #f + #rx"check-expect.*inexact" + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? #rx"unsaved-editor:3:0" + (srcloc->string loc))) + ;; ^ check-expect is in the backtrace, not some internal test-engine modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]check-expect.*sqrt 2[)][)]" + (test-definitions test))) + ;; ^ check-expect is highlighted + ))) + +(test @t{ + #lang htdp/isl+ + (define p (make-posn 7 3)) + (check-expect posn-x 7) + +} + #f + #rx"Ran 1 test.\n0 tests passed." + #| + check-expect encountered the following error instead of the expected value, 7. + :: at line 3, column 0 first argument of equality cannot be a function, given (lambda (a1) ...) + at line 3, column 0 + |# + #:extra-assert + (λ (defs ints #:test test) + (define re + (pregexp + (string-append + "check-expect[ a-z]+error.*[^\n]+\n" + ".*::.*at line 3, column 0 first argument.*function[^\n]*\n" + "at line 3, column 0"))) + ;; 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 expected: ~s\n\n got: ~a\n" + (test-line test) + (test-definitions test) + re + full-ints-text)) + passed?)) + +(test @t{ + #lang htdp/isl+ + + + (check-random (+ (random 5) (sqrt 2)) + (+ (random 5) (sqrt 2))) + +} + #f + #rx"check-random.*inexact" + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? #rx"unsaved-editor:4:0" + (srcloc->string loc))) + ;; ^ check-random is in the backtrace, not some internal test-engine modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]check-random.*sqrt 2[)][)][)]" + (test-definitions test))) + ;; ^ check-random is highlighted + ))) + +(test @t{ + #lang htdp/isl+ + + (check-within (sqrt 2) 3/2 "0.1") + +} + #f + #rx"check-within.*\"0[.]1\".*not inexact" + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? #rx"unsaved-editor:3:1" + (srcloc->string loc))) + ;; ^ check-within is in the backtrace, not some internal test-engine modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]check-within.*0[.]1\"[)]" + (test-definitions test))) + ;; ^ check-within is highlighted + ))) + (fire-up-drracket-and-run-tests run-test) ;; Test mode: 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 3ebb5df26..ee8a50591 100644 --- a/drracket-test/tests/drracket/private/module-lang-test-utils.rkt +++ b/drracket-test/tests/drracket/private/module-lang-test-utils.rkt @@ -6,7 +6,8 @@ (for-syntax racket/base) racket/class) -(provide test t rx run-test +(provide test t rx run-test + (struct-out test-struct) in-here in-here/path write-test-modules) ;; utilities to use with scribble/reader @@ -14,15 +15,15 @@ (define (rx . strs) (regexp (regexp-replace* #rx" *\n *" (string-append* strs) ".*"))) -(define-struct test +(struct test (definitions ; Rec X = (or/c string 'xml-box (listof X)) 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) extra-assert ; (-> (is-a?/c text) (is-a?/c text) boolean) line) ; number or #f: the line number of the test case - - #:omit-define-syntaxes) + #:name test-struct + #:constructor-name make-test) (define (in-here/path file) (path->string (build-path (find-system-path 'temp-dir) file))) (define (in-here file) (format "~s" (in-here/path file))) @@ -176,7 +177,17 @@ (when has-next? (loop)))) (eprintf "----\n"))))) - (unless ((test-extra-assert test) definitions-text interactions-text) + (define the-assert (test-extra-assert test)) + (define-values (kws-req kws-acc) (procedure-keywords the-assert)) + (define-values (kws kw-vals) + (for/lists (kws kw-vals) + ;; the keywords must be sorted + ([kw-val (in-list `((#:stacks . ,stacks) + (#:test . ,test) + (#:text . ,text)))] + #:when (or (not kws-acc) (memq (car kw-val) kws-acc))) + (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))))) From 046311b3bcf75830c9a95d17a90845bfe0c517f0 Mon Sep 17 00:00:00 2001 From: shhyou Date: Thu, 24 Oct 2024 16:43:12 -0500 Subject: [PATCH 02/10] Add some tests for racket/htdp#229 --- .../tests/drracket/module-lang-test.rkt | 20 ++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 0f96e44b6..702964983 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -589,7 +589,7 @@ f: contract violation #rx"Ran 1 test.\n0 tests passed." #| check-expect encountered the following error instead of the expected value, 7. - :: at line 3, column 0 first argument of equality cannot be a function, given (lambda (a1) ...) + :: at line 3, column 0 first argument of equality cannot be a function, given posn-x at line 3, column 0 |# #:extra-assert @@ -598,7 +598,7 @@ f: contract violation (pregexp (string-append "check-expect[ a-z]+error.*[^\n]+\n" - ".*::.*at line 3, column 0 first argument.*function[^\n]*\n" + ".*::.*at line 3, column 0 first argument.*function.*given posn-x[^\n]*\n" "at line 3, column 0"))) ;; Includes the flattened test result snips. (define full-ints-text @@ -606,7 +606,7 @@ f: contract violation (define passed? (regexp-match? re full-ints-text)) (unless passed? - (eprintf "FAILED line ~a: ~a\n expected: ~s\n\n got: ~a\n" + (eprintf "FAILED line ~a: ~a\n extra assertion expected: ~s\n\n got: ~a\n" (test-line test) (test-definitions test) re @@ -665,6 +665,20 @@ f: contract violation ;; ^ check-within is highlighted ))) +(test @t{ + #lang htdp/isl+ + (define (my-add1 n) (+ n 1)) + my-add1 + (check-expect my-add1 2) +} + #f + #rx"^my-add1\nRan 1 test[.]\n0 tests passed[.]" + #:extra-assert + (λ (defs ints) + (regexp-match? #px"::\\s+at line 4, column 0[^\n]+function[^\n]+given my-add1" + ;; Includes the flattened test result snips. + (send ints get-text (send ints paragraph-start-position 2) 'eof #t)))) + (fire-up-drracket-and-run-tests run-test) ;; Test mode: From a2f27bb969262abb878c94f5f08979c5811bad37 Mon Sep 17 00:00:00 2001 From: shhyou Date: Thu, 24 Oct 2024 21:14:14 -0500 Subject: [PATCH 03/10] Manually check for empty stderr in tests/drracket/module-lang-test Somehow `-e`/`--check-stderr` does not work with `tests/drracket/module-lang-test` (perhaps due to using `test-log` + `exit 0` in `fire-up-drracket-and-run-tests`?) --- .../tests/drracket/module-lang-test.rkt | 22 +++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 702964983..414c1ee28 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -683,9 +683,27 @@ f: contract violation ;; Test mode: (module test racket/base - (require syntax/location) + (require racket/port syntax/location) + (define-values (inp outp) (make-pipe)) + (define tee-error-port (open-output-bytes 'tee-stderr)) + (define stderr (current-error-port)) + (void + (thread + (λ () (copy-port inp tee-error-port stderr)))) + (exit-handler + (let ([old-exit-hdlr (exit-handler)]) + (λ (code) + (define stderr-content-length + (bytes-length (get-output-bytes tee-error-port #t))) + (cond + [(and (zero? code) (> stderr-content-length 0)) + (write-string "non-empty stderr\n" stderr) + (old-exit-hdlr 1)] + [else + (old-exit-hdlr code)])))) (putenv "PLTDRTEST" "yes") (eval-jit-enabled #f) - (dynamic-require (quote-module-path "..") #f) + (parameterize ([current-error-port outp]) + (dynamic-require (quote-module-path "..") #f)) (module config info (define timeout 800))) From b16c8532c6e3a77f1be72145550f92fc86c7d3b1 Mon Sep 17 00:00:00 2001 From: shhyou Date: Sat, 26 Oct 2024 16:31:09 -0500 Subject: [PATCH 04/10] Add some tests for racket/htdp#230 --- .../tests/drracket/module-lang-test.rkt | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 414c1ee28..5f9844e47 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -679,6 +679,36 @@ f: contract violation ;; Includes the flattened test result snips. (send ints get-text (send ints paragraph-start-position 2) 'eof #t)))) +(test @t{#lang htdp/isl + (check-expect (* 2 3) 6) + (check-expect (+ 2 3) 5)} + #f + #rx"^Both tests passed!$") + +(test @t{#lang htdp/isl} + ;; REPL + @t{(check-expect (* 2 3) 6) + (check-expect (+ 2 3) 5)} + #rx"^The test passed!\nThe test passed!$") + +(test @t{#lang htdp/isl + (check-expect (* 2 3) 6) + (check-expect (* 2 3) 5)} + #f + #rx"^Ran 2 tests[.]\n1 of the 2 tests failed[.].*Check failures:") + +(test @t{#lang htdp/isl} + ;; REPL + @t{(check-expect (* 2 3) 6) + (check-expect (* 2 3) 5)} + #rx"^The test passed!\nRan 1 test[.]\n0 tests passed[.].*Check failures:") + +(test @t{#lang htdp/isl} + ;; REPL + @t{(check-expect (* 2 3) 5) + (check-expect (* 2 3) 6)} + #rx"^Ran 1 test[.]\n0 tests passed[.].*Check failures:.*\nThe test passed!$") + (fire-up-drracket-and-run-tests run-test) ;; Test mode: From 1f725c9d926a4c938b63b3ae99350b48c4f1d054 Mon Sep 17 00:00:00 2001 From: shhyou Date: Sat, 26 Oct 2024 17:09:33 -0500 Subject: [PATCH 05/10] Test util: sleep for 0.1s after printing error msg In tests/drracket/module-lang-test, stderr goes through a pipe to be checked for the absence of error messages. Therefore, sleep for 0.1s before existing to let the background thread pipe the messages to terminal. --- drracket-test/tests/drracket/private/drracket-test-util.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/drracket-test/tests/drracket/private/drracket-test-util.rkt b/drracket-test/tests/drracket/private/drracket-test-util.rkt index b7c7b4a0d..507729b50 100644 --- a/drracket-test/tests/drracket/private/drracket-test-util.rkt +++ b/drracket-test/tests/drracket/private/drracket-test-util.rkt @@ -649,6 +649,7 @@ (if (exn? x) (orig-display-handler (exn-message x) x) (eprintf "uncaught exception ~s\n" x)) + (sleep/yield 0.1) (exit 1)))) (run-test) (test-log #:display? #t #:exit? #t) From 98d713421c9e08b876eb5c4556eef3bf84169105 Mon Sep 17 00:00:00 2001 From: shhyou Date: Sat, 26 Oct 2024 19:13:34 -0500 Subject: [PATCH 06/10] Add one combined test for racket/htdp#230. --- .../tests/drracket/module-lang-test.rkt | 51 +++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 5f9844e47..53982f1f6 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -709,6 +709,57 @@ f: contract violation (check-expect (* 2 3) 6)} #rx"^Ran 1 test[.]\n0 tests passed[.].*Check failures:.*\nThe test passed!$") +(test @t{#lang htdp/isl + (check-expect (* 2 3) 6) + (check-expect (* 2 3) 5) + (check-expect (+ 2 3) 5)} + ;; REPL + @t{(check-expect (+ 4 5) 9) + (check-expect (+ 6 7) 42) + (check-expect (* 8 9) 72) + (check-expect (error 'oops) 111)} + #px"^Ran 3 tests[.]\\s+1 of the 3 tests failed[.]" + #t + #:extra-assert + (λ (defs ints #:test test) + (define re + (pregexp + @t{^Ran 3 tests[.] + 1 of the 3 tests failed[.] + + Check failures:\s* + +Actual value 6 differs from 5, the expected value[.]\s* + at line 3, column 0 + > @(regexp-quote (test-interactions test)) + The test passed! + Ran 1 test[.] + 0 tests passed[.] + + Check failures:\s* + +Actual value 13 differs from 42, the expected value[.]\s* + at line 10, column 0 + The test passed! + Ran 1 test[.] + 0 tests passed[.] + + Check failures:\s* + +check-expect encountered the following error instead of the expected value, 111[.]\s* + +:: +at line 12, column 14 oops:\s* + at line 12, column 0 + > })) + ;; 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)) + passed?)) + (fire-up-drracket-and-run-tests run-test) ;; Test mode: From 404c34af417c2c4977a7d480287bf5e3252dd99f Mon Sep 17 00:00:00 2001 From: shhyou Date: Fri, 1 Nov 2024 13:50:34 -0500 Subject: [PATCH 07/10] Update language-test.rkt to match racket/htdp#229. --- drracket-test/tests/drracket/language-test.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/drracket-test/tests/drracket/language-test.rkt b/drracket-test/tests/drracket/language-test.rkt index 669841c49..dcb74eaef 100644 --- a/drracket-test/tests/drracket/language-test.rkt +++ b/drracket-test/tests/drracket/language-test.rkt @@ -1326,8 +1326,8 @@ the settings above should match r5rs (test-undefined-fn "(print (floor (sqrt 2)))" "print") (test-expression "(let ([f (lambda (x) x)]) f)" - "(lambda (a1) ...)" - "(lambda (a1) ...)") + "f" + "f") (test-expression ",1" "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") @@ -1503,8 +1503,8 @@ the settings above should match r5rs (test-expression "(print (floor (sqrt 2)))" "#i1.0") (test-expression "(let ([f (lambda (x) x)]) f)" - "(lambda (a1) ...)" - "(lambda (a1) ...)") + "f" + "f") (test-expression ",1" "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") From c60fc6a3744254638d7ff75252045ec552cbc6cc Mon Sep 17 00:00:00 2001 From: shhyou Date: Fri, 1 Nov 2024 15:44:41 -0500 Subject: [PATCH 08/10] Expand the tests of racket/htdp#229 to include ISL --- .../tests/drracket/module-lang-test.rkt | 51 ++++++++++++++++++- 1 file changed, 49 insertions(+), 2 deletions(-) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 53982f1f6..79eb347f9 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -667,15 +667,62 @@ f: contract violation (test @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) + (regexp-match? #px"::\\s+at line 5, column 0[^\n]+function[^\n]+given my-add1" + ;; Includes the flattened test result snips. + (send ints get-text (send ints paragraph-start-position 2) 'eof #t)))) + +(test @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"^my-add1\nRan 1 test[.]\n0 tests passed[.]" + @rx{^function:my-add1 + function:keep-parity + function:alt-parity + Ran 1 test[.] + 0 tests passed[.]} #:extra-assert (λ (defs ints) - (regexp-match? #px"::\\s+at line 4, column 0[^\n]+function[^\n]+given my-add1" + (regexp-match? #px"::\\s+at 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)))) From af736034dddbd300cf53e28cc7175e8c2675f5ea Mon Sep 17 00:00:00 2001 From: shhyou Date: Sat, 2 Nov 2024 11:47:44 -0500 Subject: [PATCH 09/10] More racket/htdp#229: save the buffer in some test --- .../tests/drracket/module-lang-test.rkt | 140 +++++++++++++++++- .../private/module-lang-test-utils.rkt | 26 +++- 2 files changed, 160 insertions(+), 6 deletions(-) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index 79eb347f9..a1b95b3cb 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,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) 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) From 4eaf30c4c74d0309d013c9332032d779e777d647 Mon Sep 17 00:00:00 2001 From: shhyou Date: Mon, 4 Nov 2024 09:39:57 -0600 Subject: [PATCH 10/10] Port tests from htdp-test:intm-lam.rktl --- .../tests/drracket/module-lang-test.rkt | 147 +++++++++++++----- 1 file changed, 109 insertions(+), 38 deletions(-) diff --git a/drracket-test/tests/drracket/module-lang-test.rkt b/drracket-test/tests/drracket/module-lang-test.rkt index a1b95b3cb..9584421fe 100644 --- a/drracket-test/tests/drracket/module-lang-test.rkt +++ b/drracket-test/tests/drracket/module-lang-test.rkt @@ -666,25 +666,24 @@ 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))) +(define (close-current-tab-and-open-new-tab filename) + (define path (in-here/path filename)) + (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))) + +(let ([filename @t{gh208-pr229-islplus.rkt}]) +(test #:before-execute (λ () (save-drracket-window-as + (string->path (in-here/path filename)))) + #:after-test (λ () (close-current-tab-and-open-new-tab filename)) #:wait-for-drracket-frame-after-test? #t @t{ #lang htdp/isl+ @@ -782,25 +781,10 @@ 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))) +(let ([filename @t{gh208-pr229-isl.rkt}]) +(test #:before-execute (λ () (save-drracket-window-as + (string->path (in-here/path filename)))) + #:after-test (λ () (close-current-tab-and-open-new-tab filename)) #:wait-for-drracket-frame-after-test? #t @t{ #lang htdp/isl @@ -862,6 +846,93 @@ f: contract violation ;; Includes the flattened test result snips. (send ints get-text (send ints paragraph-start-position 2) 'eof #t)))) +(let ([filename @t{htdp-tests-intm-lam-map.rkt}]) +(test #:before-execute (λ () (save-drracket-window-as + (string->path (in-here/path filename)))) + #:after-test (λ () (close-current-tab-and-open-new-tab filename)) + #:wait-for-drracket-frame-after-test? #t + @t{ +#lang htdp/isl+ + (map (lambda (x y) (+ x y)) (list 2 3 4)) +} + #f + @rx{map: first argument must be a function that expects one argument, + given @regexp-quote{(lambda (a1 a2) ...)}} + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? @rx{@(regexp-quote filename):2:3} + (srcloc->string loc))) + ;; ^ foldr is in the backtrace, not some internal HtDP modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]map.*3 4[)][)]" + (test-definitions test))) + ;; ^ foldr is highlighted + )))) + +(let ([filename @t{htdp-tests-intm-lam-foldr2.rkt}]) +(test #:before-execute (λ () (save-drracket-window-as + (string->path (in-here/path filename)))) + #:after-test (λ () (close-current-tab-and-open-new-tab filename)) + #:wait-for-drracket-frame-after-test? #t + @t{ +#lang htdp/isl+ + (foldr (lambda (x y) (+ x y)) 0 (list 2 3 4) (list 2 3 4)) +} + #f + @rx{foldr: first argument must be a function that expects three arguments, + given @regexp-quote{(lambda (a1 a2) ...)}} + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? @rx{@(regexp-quote filename):2:3} + (srcloc->string loc))) + ;; ^ foldr is in the backtrace, not some internal HtDP modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]foldr.*3 4[)][)]" + (test-definitions test))) + ;; ^ foldr is highlighted + )))) + +(let ([filename @t{htdp-tests-intm-lam-foldr3.rkt}]) +(test #:before-execute (λ () (save-drracket-window-as + (string->path (in-here/path filename)))) + #:after-test (λ () (close-current-tab-and-open-new-tab filename)) + #:wait-for-drracket-frame-after-test? #t + @t{ +#lang htdp/isl+ + (foldr (lambda (x y z) (+ x y z)) 0 (list 2 3 4)) +} + #f + @rx{foldr: first argument must be a function that expects two arguments, + given @regexp-quote{(lambda (a1 a2 a3) ...)}} + #:extra-assert + (λ (defs ints #:stacks stacks #:test test) + (and (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? @rx{@(regexp-quote filename):2:3} + (srcloc->string loc))) + ;; ^ foldr is in the backtrace, not some internal HtDP modules + (equal? + (remove-duplicates + (for/list ([range (send defs get-highlighted-ranges)]) + (cons (text:range-start range) (text:range-end range)))) + (regexp-match-positions #rx"[(]foldr.*3 4[)][)]" + (test-definitions test))) + ;; ^ foldr is highlighted + )))) + (test @t{#lang htdp/isl (check-expect (* 2 3) 6) (check-expect (+ 2 3) 5)}