diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ad286e29..8516ed4a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -11,8 +11,8 @@ jobs: racket-variant: ["CS"] steps: - - uses: actions/checkout@v4.3.0 - - uses: Bogdanp/setup-racket@v1.14 + - uses: actions/checkout@v7 + - uses: Bogdanp/setup-racket@v1.15 with: architecture: 'x64' distribution: 'full' @@ -22,8 +22,10 @@ jobs: dest: '${HOME}/racket' local_catalogs: $GITHUB_WORKSPACE - run: raco pkg update -i --no-setup htdp-lib htdp-doc htdp - - name: Install htdp-test (depends on htdp-lib) - run: raco pkg install --auto -i --skip-installed --no-setup htdp-test - - run: raco setup --check-pkg-deps --pkgs htdp-lib htdp-doc htdp-test + - name: Install htdp-test and htdp-drracket-test (depends on htdp-lib) + run: raco pkg install --auto -i --skip-installed --no-setup htdp-test htdp-drracket-test + - run: raco setup --check-pkg-deps --pkgs htdp-lib htdp-doc htdp-test htdp-drracket-test - name: Run tests run: xvfb-run raco test htdp-test + - name: Run DrRacket integration tests + run: xvfb-run raco test -p htdp-drracket-test diff --git a/htdp-drracket-test/LICENSE b/htdp-drracket-test/LICENSE new file mode 100644 index 00000000..d1b1288b --- /dev/null +++ b/htdp-drracket-test/LICENSE @@ -0,0 +1,10 @@ +This component of Racket is distributed under the Apache 2.0 and MIT +licenses. The user can choose the license under which they will be +using the software. There may be other licenses within the +distribution with which the user must also comply. + +See the files + https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt +and + https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt +for the full text of the licenses. diff --git a/htdp-drracket-test/info.rkt b/htdp-drracket-test/info.rkt new file mode 100644 index 00000000..2543fbbe --- /dev/null +++ b/htdp-drracket-test/info.rkt @@ -0,0 +1,35 @@ +#lang info + +#| +This package contains HtDP tests that launch DrRacket and inspect the execution +results. For example, language-test.rkt sets the language to each teaching language +and runs TL expressions and check-expects. Similarly, module-lang-test.rkt directly +verifies the output of test engine in DrRacket. + +Without working with DrRacket, it's rather difficult to fully set up everything +and observe the expected behavior, such as image output, the interaction between +printer configuration and test engine, or the right language bindings. +See, e.g., racket/htdp@e6b79368c and racket/htdp@dc985b3cc for the missing setup. + +The infrastructure for this package is copied from Robby's drracket-test. +Due to its dependency on DrRacket, this package is separated +from the more self-contained htdp-test package. + +There may be some overlap between the tests in this package and +those in drracket-test, but the primary goal of drracket-test is +testing DrRacket while this package aims at testing HtDP. +|# + +(define collection 'multi) +(define deps '("base" + "htdp-lib")) +(define build-deps '("at-exp-lib" + "rackunit" + "gui-lib" + "drracket")) +(define update-implies '("htdp-lib")) + +(define pkg-desc "extra tests for \"htdp\" that depend on DrRacket integration") + +(define license + '(Apache-2.0 OR MIT)) diff --git a/htdp-drracket-test/tests/htdp-lang/language-test.rkt b/htdp-drracket-test/tests/htdp-lang/language-test.rkt new file mode 100644 index 00000000..25270ef9 --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/language-test.rkt @@ -0,0 +1,1577 @@ +;; From: drracket/drracket-test/tests/drracket/language-test.rkt +;; At: e94a69c80ae82954ec9ce6ebdec784a99f2b9b98 +;; Original author: Robby +#lang racket + +#| + +Make sure there are tests that cover these parameters: + + (read-case-sensitive #f) + (read-square-bracket-as-paren #f) -- test: (symbol? '[]) + (read-curly-brace-as-paren #f) + (print-vector-length #f) + +the settings above should match r5rs + +|# + + +(require "private/drracket-test-util.rkt" + "private/gui.rkt" + mred + framework + (prefix-in fw: framework)) + +(define language (make-parameter "<>")) +(define defs-prefix (make-parameter "")) + +;; set-language : boolean -> void +(define (set-language close-dialog?) + (if (equal? (car (language)) 'module) + (set-module-language! close-dialog?) + (set-language-level! (language) close-dialog?))) + + + + +; +; ;;; ;; +; ;; ;; +; ;; +; ;;;;; ;;;; ;;;;;;;;; ;;; ;; ;;; ;; ;;;; ;;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;;;;;; ;; +; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ; ;;;;; ;; ;; ;; ;; ;; ;; ; ;; +; ;;;;; ;;;; ;;;;;;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; +; ;; ;; +; ;; ;; +; ;;;;; + +(define (beginner) + (parameterize ([language (list #rx"Beginning Student(;|$)")]) + (check-top-of-repl) + (generic-settings #t) + (generic-output #f #f #f #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#true" + "#true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i\n") + + (test-undefined-var "class") + (test-undefined-var "shared") + (test-expression "(define (. x y) (* x y))" "read-syntax: illegal use of `.`") + (test-expression "'(1 . 2)" "read-syntax: illegal use of `.`") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(check-expect 1 1)" + "The test passed!" + "Both tests passed!") + (test-expression "(check-expect 1 1)\n(check-expect 2 2)\n(+ \"hello\" \"world\")\n(check-expect 3 3)\n" + (λ (got) + (define m (regexp-match #rx"(.*)0 tests passed(.*)" got)) + (cond + [m + (define before (list-ref m 1)) + (define after (list-ref m 2)) + (and (not (regexp-match? #rx"tests? passed" before)) + (not (regexp-match? #rx"tests? passed" after)))] + [else #f])) + (λ (got) #t)) ;; just skip the interactions test + (test-expression "(define (badfn x) (error \"hello\"))\n(check-expect (badfn 1) 1)\n(error \"hello\")" + #rx"0 tests passed[.].*hello" + (λ (got) #t)) + + (test-undefined-fn "(time 1)" "time") + + (test-expression "true" + "#true" + "#true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "#false" + "#false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + + (test-expression "(cond [(= 1 2) 3])" + "cond: all question results were false") + (test-expression "(cons 1 2)" + "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" + #rx"[+]: expects a number(?: as 1st argument)?, given [(]cons 1 '[(][)][)]") + (test-expression "'(1)" + "quote: expected the name of a symbol or () after the quote, but found a part") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(cons (cons 1 '()) (cons (cons 1 '()) '()))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression + "(local ((define x x)) 1)" + "local: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression + "(letrec ([x x]) 1)" + "letrec: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, but found only 1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "#true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression + "(let ([f (lambda (x) x)]) f)" + "let: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression ",1" + "read-syntax: illegal use of `,`") + + (test-expression "(list 1)" + "(cons 1 '())" + "(cons 1 '())") + (test-expression "(car (list))" + "car: expects a pair, given '()") + + (test-undefined-var "argv") + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + #rx"read-syntax: `#lang` not enabled" + #rx"read-syntax: `#lang` not enabled") + (test-expression (string-append "(define (f)\n" + "(+ (raise-user-error 'a \"b\")))\n" + "(if (zero? (random 1)) (void) (set! f void))\n" + "(f)") + "define: expected at least one variable after the function name, but found none" + #rx"define: function definitions are not allowed in the interactions window") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + +;; This test suite from 2015 has some failing cases; they are commented out +(define (bsl) + (parameterize ([language '(module "htdp/bsl")] + [defs-prefix "#lang htdp/bsl\n"]) + (check-top-of-repl) + + ;; specialized version of the generic-output function that makes sense for #lang htdp/bsl + (define (bsl-generic-output) + (define drs (wait-for-drracket-frame)) + (define (shorten str) + (if ((string-length str) . <= . 45) + str + (string-append (substring str 0 45) "..."))) + (define (test program answer) + (clear-definitions drs) + (insert-in-definitions drs (defs-prefix)) + (insert-in-definitions drs program) + + + ;; answer must either be a string, or a procedure that accepts both zero and 1 + ;; argument. When the procedure accepts 1 arg, the argument is `got' and + ;; the result must be a boolean indicating if the result was satisfactory. + ;; if the procedure receives no arguments, it must return a descriptive string + ;; for the error message + (set-language #t) + (do-execute drs) + (define got (fetch-output/should-be-tested drs)) + (unless (if (procedure? answer) + (answer got) + (whitespace-string=? answer got)) + (eprintf "FAILED ~s\n" (language)) + (eprintf " got ~s\n" (shorten got)) + (eprintf "expected ~s\n" (if (procedure? answer) (answer) answer)))) + + (test "(define x (list 2))\n(list x x)" + "(cons (cons 2 '()) (cons (cons 2 '()) '()))") + + ;; not passing + #; + (test "(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)" + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"]))) + + (bsl-generic-output) + + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "(check-expect 1 1)" + "The test passed!" + "The test passed!") + (test-expression "(check-expect 1 2)" + #rx"Actual value {embedded \"1\"} differs from {embedded \"2\"}" + #rx"Actual value {embedded \"1\"} differs from {embedded \"2\"}") + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#true" + "#true") + + (test-expression + "(define x 1)(define x 2)" + "{stop-22x22.png} x: this name was defined previously and cannot be re-defined in: x" + "{stop-22x22.png} x: this name was defined previously and cannot be re-defined in: x") + + ;; Not sure why but this crashed subsequent tests by putting the DrRacket frame into a strange state + ;; error: insert-in-definitions: drracket frame not frontmost: + ;; (object:...ket/version/tool.rkt:178:9 ...) (found (object:focus-table-mixin ...)) + #;(test-expression + "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "{stop-22x22.png} spider: this name was defined previously and cannot be re-defined in: spider") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i\n") + + (test-undefined-var "class" #:icon+in? #t) + (test-undefined-var "shared" #:icon+in? #t) + (test-expression "(define (. x y) (* x y))" + (regexp (regexp-quote "read-syntax: illegal use of `.`")) + #:has-repl? #f) + (test-expression "'(1 . 2)" + (regexp (regexp-quote "read-syntax: illegal use of `.`")) + #:has-repl? #f) + + (test-undefined-var "call/cc" #:icon+in? #t) + + (test-expression "(error 'a \"~a\" 1)" #rx"a: ~a1") + (test-expression "(error \"a\" \"a\")" #rx"aa") + + (test-undefined-fn "(time 1)" "time" #:icon+in? #t) + + (test-expression "true" + "#true" + "#true") + (test-undefined-var "mred^" #:icon+in? #t) + (test-expression "(eq? 'a 'A)" + "#false" + "#false") + (test-undefined-fn "(set! x 1)" "set!" #:icon+in? #t) + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!" #:icon+in? #t) + + ;; Crashes subsequent tests + #;(test-expression "(cond [(= 1 2) 3])" + "{stop-multi.png} {stop-22x22.png} cond: all question results were false") + (test-expression + "(cons 1 2)" + #rx"cons: second argument must be a list, but received 1 and 2") + (test-expression + "(+ (list 1) 2)" + #rx"[+]: expects a number(?: as 1st argument)?, given [(]cons 1 '[(][)][)]") + (test-expression + "'(1)" + (regexp + (regexp-quote + "quote: expected the name of a symbol or () after the quote, but found a part"))) + (test-expression + "(define shrd (list 1)) (list shrd shrd)" + "(cons (cons 1 '()) (cons (cons 1 '()) '()))" + (regexp + (regexp-quote + "shrd: this name was defined previously and cannot be re-defined"))) + ;; Crashes subsequent tests + #;(test-expression + "(local ((define x x)) 1)" + (regexp + (regexp-quote + "local: this function is not defined")) + (regexp + (regexp-quote + "function call: expected a function after the open parenthesis, but found a part"))) + (test-expression + "(letrec ([x x]) 1)" + (regexp + (regexp-quote + "letrec: this function is not defined")) + (regexp + (regexp-quote + "function call: expected a function after the open parenthesis, but found a part"))) + ;; Crashes subsequent tests + #;(test-expression "(if 1 1 1)" + (regexp (regexp-quote "if: question result is not true or false: 1"))) + (test-expression "(+ 1)" + (regexp (regexp-quote "+: expects at least 2 arguments, but found only 1"))) + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "#true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print" #:icon+in? #t) + + (test-expression + "(let ([f (lambda (x) x)]) f)" + (regexp (regexp-quote "let: this function is not defined")) + (regexp + (regexp-quote + "function call: expected a function after the open parenthesis, but found a part"))) + (test-expression ",1" + (regexp (regexp-quote "read-syntax: illegal use of `,`")) + #:has-repl? #f) + + (test-expression "(list 1)" + "(cons 1 '())" + "(cons 1 '())") + (test-expression "(car (list))" + (regexp (regexp-quote "car: expects a pair, given '()"))) + + (test-undefined-var "argv" #:icon+in? #t) + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax" #:icon+in? #t) + + (test-expression "#lang racket" + (regexp (regexp-quote "read-syntax: `#lang` not enabled")) + #:has-repl? #f) + (test-expression + (string-append "(define (f)\n" + "(+ (raise-user-error 'a \"b\")))\n" + "(if (zero? (random 1)) (void) (set! f void))\n" + "(f)") + (regexp + (regexp-quote + "define: expected at least one variable after the function name, but found none")) + #rx"define: function definitions are not allowed in the interactions window") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + + +; +; ;;; ;;; ;;; +; ;; ; ;; ;; +; ;; ; ;; ;; +; ;;;;; ;;;; ;;;;;; ; ;;;; ;;;;; ;;;;; ;;; ;; ;;;; ;;; ;;; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ; +; ;; ;; ;;;;;; ;;;; ; ;;;;; ;; ;; ;; ;; ;; ;;;;;; ;;; +; ;; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;;; +; ;; ;; ;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ; ;;; +; ;;;;; ;;;; ;;;;;; ; ;;;;;; ;;;;; ;;;;; ;;;; ;;;; ; +; ;; ;;; +; ;; ;;; +; ;;;;; + + +(define (beginner/abbrev) + (parameterize ([language (list #rx"Beginning Student with List Abbreviations(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#true" + "#true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + (test-undefined-var "shared") + + (test-expression "(define (. x y) (* x y))" "read-syntax: illegal use of `.`") + (test-expression "'(1 . 2)" "read-syntax: illegal use of `.`") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(check-expect 1 1)" + "The test passed!" + "Both tests passed!") + (test-expression "(check-expect 1 1)\n(check-expect 2 2)\n(+ \"hello\" \"world\")\n(check-expect 3 3)\n" + (λ (got) + (define m (regexp-match #rx"(.*)0 tests passed(.*)" got)) + (cond + [m + (define before (list-ref m 1)) + (define after (list-ref m 2)) + (and (not (regexp-match? #rx"tests? passed" before)) + (not (regexp-match? #rx"tests? passed" after)))] + [else #f])) + (λ (got) #t)) ;; just skip the interactions test + (test-expression "(define (badfn x) (error \"hello\"))\n(check-expect (badfn 1) 1)\n(error \"hello\")" + #rx"0 tests passed[.].*hello" + (λ (got) #t)) + +(test-undefined-fn "(time 1)" "time") + + (test-expression "true" + "#true" + "#true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "#false" + "#false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" #rx"[+]: expects a number(?: as 1st argument)?, given [(]list 1[)]") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression + "(local ((define x x)) 1)" + "local: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression + "(letrec ([x x]) 1)" + "letrec: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, but found only 1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "#true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression + "(let ([f (lambda (x) x)]) f)" + "let: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair, given '()") + + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + #rx"read-syntax: `#lang` not enabled" + #rx"read-syntax: `#lang` not enabled") + (test-expression (string-append "(define (f)\n" + "(+ (raise-user-error 'a \"b\")))\n" + "(if (zero? (random 1)) (void) (set! f void))\n" + "(f)") + "define: expected at least one variable after the function name, but found none" + #rx"define: function definitions are not allowed in the interactions window") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + + +; +; ;; ;;; ;; +; ;; ;; ;; ;; ;; +; ;; ;; ;; +; ;;; ;;; ;; ;;;;; ;;;; ;;; ;; ;;; ;; ;; ;;;; ;;;;; ;;; ;;;; ;;;;; ;;;; +; ;; ;;; ;; ;; ;; ;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;;;; ;; ;;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ; +; ;;;; ;;;; ;;; ;;; ;;;; ;;;; ;;;; ;;; ;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;; ;;;; +; +; +; + + +(define (intermediate) + (parameterize ([language (list #rx"Intermediate Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#true" + "#true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + (test-undefined-var "shared") + + (test-expression "(define (. x y) (* x y))" "read-syntax: illegal use of `.`") + (test-expression "'(1 . 2)" "read-syntax: illegal use of `.`") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(check-expect 1 1)" + "The test passed!" + "Both tests passed!") + (test-expression "(check-expect 1 1)\n(check-expect 2 2)\n(+ \"hello\" \"world\")\n(check-expect 3 3)\n" + (λ (got) + (define m (regexp-match #rx"(.*)0 tests passed(.*)" got)) + (cond + [m + (define before (list-ref m 1)) + (define after (list-ref m 2)) + (and (not (regexp-match? #rx"tests? passed" before)) + (not (regexp-match? #rx"tests? passed" after)))] + [else #f])) + (λ (got) #t)) ;; just skip the interactions test + (test-expression "(define (badfn x) (error \"hello\"))\n(check-expect (badfn 1) 1)\n(error \"hello\")" + #rx"0 tests passed[.].*hello" + (λ (got) #t)) + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "#true" + "#true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "#false" + "#false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" #rx"[+]: expects a number(?: as 1st argument)?, given [(]list 1[)]") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") + (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "#true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "function:f" + "function:f") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair, given '()") + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + #rx"read-syntax: `#lang` not enabled" + #rx"read-syntax: `#lang` not enabled") + (test-expression + (string-append "(define (f)\n" + "(+ (raise-user-error 'a \"b\")))\n" + "(if (zero? (random 1)) (void) (set! f void))\n" + "(f)") + "define: expected at least one variable after the function name, but found none" + #rx"define: expected at least one variable after the function name, but found none") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + + + +; +; +; +; ;; ; ;;;;;; ;;;; ;;;; +; ;; ;; ;;;;;; ;;;; ;;;; +; ;;;; ;;; ;;;;; ;;;;;; ;;;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;; ;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; +; ;; +; +; + + +(define (intermediate/lambda) + (parameterize ([language (list #rx"Intermediate Student with lambda(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#true" + "#true") + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + (test-undefined-var "shared") + + (test-expression "(define (. x y) (* x y))" "read-syntax: illegal use of `.`") + (test-expression "'(1 . 2)" "read-syntax: illegal use of `.`") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(check-expect 1 1)" + "The test passed!" + "Both tests passed!") + (test-expression "(check-expect 1 1)\n(check-expect 2 2)\n(+ \"hello\" \"world\")\n(check-expect 3 3)\n" + (λ (got) + (define m (regexp-match #rx"(.*)0 tests passed(.*)" got)) + (cond + [m + (define before (list-ref m 1)) + (define after (list-ref m 2)) + (and (not (regexp-match? #rx"tests? passed" before)) + (not (regexp-match? #rx"tests? passed" after)))] + [else #f])) + (λ (got) #t)) ;; just skip the interactions test + (test-expression "(define (badfn x) (error \"hello\"))\n(check-expect (badfn 1) 1)\n(error \"hello\")" + #rx"0 tests passed[.].*hello" + (λ (got) #t)) + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "#true" + "#true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "#false" + "#false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" #rx"[+]: expects a number(?: as 1st argument)?, given [(]list 1[)]") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") + (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" "0+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+0.5i" "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "#true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "f" + "f") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair, given '()") + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + #rx"read-syntax: `#lang` not enabled" + #rx"read-syntax: `#lang` not enabled") + (test-expression + (string-append "(define (f)\n" + "(+ (raise-user-error 'a \"b\")))\n" + "(if (zero? (random 1)) (void) (set! f void))\n" + "(f)") + "define: expected at least one variable after the function name, but found none" + #rx"define: expected at least one variable after the function name, but found none") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + + + +; +; +; +; ;;;; ;;;; +; ;;;; ;;;; +; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;; ;;; ;;;;; ;;; ;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;; ;;; ;;;;;;;; ;;;;;;;;; ;;;;;; ;;;;; ;;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;;;;;; +; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; +; ;; ;;;; ;;;;;;;;; ;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;;;;;; +; ;; ;;;; ;;;;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;; +; +; +; + + +(define (advanced) + (parameterize ([language (list #rx"Advanced Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #t #t #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#true" + "#true") + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + + (test-expression "shared" "shared: expected an open parenthesis before shared, but found none") + + (test-expression "(define (. x y) (* x y))" "read-syntax: illegal use of `.`") + (test-expression "'(1 . 2)" "read-syntax: illegal use of `.`") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(check-expect 1 1)" + "The test passed!" + "Both tests passed!") + (test-expression "(check-expect 1 1)\n(check-expect 2 2)\n(+ \"hello\" \"world\")\n(check-expect 3 3)\n" + (λ (got) + (define m (regexp-match #rx"(.*)0 tests passed(.*)" got)) + (cond + [m + (define before (list-ref m 1)) + (define after (list-ref m 2)) + (and (not (regexp-match? #rx"tests? passed" before)) + (not (regexp-match? #rx"tests? passed" after)))] + [else #f])) + (λ (got) #t)) ;; just skip the interactions test + (test-expression "(define (badfn x) (error \"hello\"))\n(check-expect (badfn 1) 1)\n(error \"hello\")" + #rx"0 tests passed[.].*hello" + (λ (got) #t)) + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "#true" + "#true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "#false" + "#false") + (test-expression "(set! x 1)" + "x: this variable is not defined" + "set!: cannot set variable before its definition: x") + (test-expression "(define qqq 2) (set! qqq 1)" + "(void)" + "qqq: this name was defined previously and cannot be re-defined") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" #rx"[+]: expects a number(?: as 1st argument)?, given [(]list 1[)]") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(shared ((-1- (list 1))) (list -1- -1-))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") + (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "#true") + (test-expression "(print (floor (sqrt 2)))" "#i1.0") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "f" + "f") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair, given '()") + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + #rx"read-syntax: `#lang` not enabled" + #rx"read-syntax: `#lang` not enabled") + (test-expression (string-append "(define (f)\n" + "(+ (raise-user-error 'a \"b\")))\n" + "(if (zero? (random 1)) (void) (set! f void))\n" + "(f)") + #rx"raise-user-error" + #rx"raise-user-error") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + + +(define (prepare-for-test-expression) + (define drs (wait-for-drracket-frame)) + (clear-definitions drs) + (set-language #t) + (sleep 1) ;; this shouldn't be neccessary.... + (do-execute drs)) + +;; test-setting : (-> void) string string string -> void +;; opens the language dialog, runs `set-setting' +;; closes the language dialog, executes, +;; makes sure that `expression' produces +;; `result'. `set-setting' is expected to click around +;; in the language dialog. +;; `setting-name' is used in the error message when the test fails. +(define (test-setting set-setting setting-name expression result + #:interactions [interactions-expr #f]) + (set-language #f) + (set-setting) + (let ([f (test:get-active-top-level-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)) + (define drs (test:get-active-top-level-window)) + (send drs get-interactions-text) + (clear-definitions drs) + (insert-in-definitions drs expression) + (do-execute drs) + (when interactions-expr + (insert-in-interactions drs interactions-expr) + (alt-return-in-interactions drs) + (wait-for-computation drs)) + (define got (fetch-output/should-be-tested drs)) + (unless (if (regexp? result) + (regexp-match? result got) + (string=? result got)) + (eprintf "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n" + (language) + setting-name + expression + result + got))) + +(define (test-hash-bang) + (define expression "#!/bin/sh\n1") + (define result "1") + (define drs (test:get-active-top-level-window)) + (queue-callback (λ () (send drs get-interactions-text))) + (clear-definitions drs) + (insert-in-definitions drs expression) + (do-execute drs) + (define got (fetch-output/should-be-tested drs)) + (unless (string=? "1" got) + (eprintf "FAILED: ~s ~a test\n expected: ~s\n got: ~s\n" (language) expression result got))) + +(define (fetch-output/should-be-tested . args) + (regexp-replace (regexp + (string-append + (regexp-quote "") + "$")) + (apply fetch-output args) + "")) + +(define (check-top-of-repl) + (define drs (wait-for-drracket-frame)) + (clear-definitions drs) + (insert-in-definitions drs (defs-prefix)) + (set-language #t) + (with-handlers ([exn:fail? void]) + (fw:test:menu-select "Testing" "Disable tests")) + (do-execute drs) + (define interactions (send drs get-interactions-text)) + (define short-lang (last (language))) + (define (get-line n) + (queue-callback/res + (λ () + (send interactions get-text + (send interactions paragraph-start-position n) + (send interactions paragraph-end-position n))))) + (define line0-expect + (format "Welcome to DrRacket, version ~a [~a]." + (version:version) + (system-type 'gc))) + (define line1-expect + (if (string? short-lang) + (format "Language: ~a" short-lang) + short-lang)) + (define line0-got (get-line 0)) + (define line1-got (get-line 1)) + (unless (and (string=? line0-expect line0-got) + (if (string? short-lang) + (string=? line1-expect (substring line1-got + 0 + (min (string-length line1-expect) + (string-length line1-got)))) + (regexp-match line1-expect line1-got))) + (eprintf "expected lines: \n ~a\n ~a\ngot lines:\n ~a\n ~a\n" + line0-expect line1-expect + line0-got line1-got) + (eprintf "defs: ~s\n" + (queue-callback/res (λ () (send (send drs get-definitions-text) get-text)))) + (error 'language-test.rkt "failed get top of repl test"))) + + +;; teaching-language-fraction-output +;; tests that the teaching languages properly handle repeating decimals +(define (teaching-language-fraction-output) + (test-setting + (lambda () (fw:test:set-radio-box! (find-output-radio-box "Fraction Style") "Mixed fractions")) + "Fraction Style -- Mixed fractions" + "4/3" + "{number 4/3 \"1 1/3\" mixed}") + (test-setting + (lambda () (fw:test:set-radio-box! (find-output-radio-box "Fraction Style") "Repeating decimals")) + "Fraction Style -- Repeating decimals" + "4/3" + "{number 4/3 \"1.3\" decimal}")) + +;; plt-language-fraction-output : -> void +;; tests that the PLT languages properly handle repeating decimals +(define (plt-language-fraction-output) + (test-setting + (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #f)) + "Use decimal notation for rationals -- #f" + "4/3 1/2 -1/3" + "{number 4/3 \"1 1/3\" mixed}\n{number 1/2 \"1/2\" mixed}\n{number -1/3 \"- 1/3\" mixed}") + (test-setting + (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t)) + "Use decimal notation for rationals -- #t" + "4/3 1/2 -1/3" + (string-append + "{number 4/3 \"#e1.3\" decimal}\n" + "{number 1/2 \"#e0.5\" decimal}\n" + "{number -1/3 \"#e-0.3\" decimal}"))) + +(define (generic-settings false/true?) + (test-setting + (lambda () (fw:test:set-check-box! "Case sensitive" #t)) + "Case sensitive -- #t" + "(eq? 'g 'G)" + (if false/true? "#false" "#f")) + (test-setting + (lambda () (fw:test:set-check-box! "Case sensitive" #f)) + "Case sensitive -- #f" + "(eq? 'g 'G)" + (if false/true? "#true" "#t"))) + +(define (generic-output list? uses-qq-for-plain-print? quasi-quote? has-sharing? has-print-printing? print-value-columns?) + (define plain-print-style (if has-print-printing? "print" "write")) + (define drr (wait-for-drracket-frame)) + (define expression "(define x (list 2))\n(list x x)") + (define (set-output-choice option show-sharing pretty?) + (set-language #f) + (fw:test:set-radio-box! (find-output-radio-box "Output Style") option) + (when (and has-sharing? show-sharing) + (fw:test:set-check-box! + "Show sharing in values" + (eq? show-sharing 'on))) + (fw:test:set-check-box! + "Insert newlines in printed values" + pretty?) + (define f (test:get-active-top-level-window)) + (fw:test:button-push "OK") + (wait-for-new-frame f)) + (define (shorten str) + (if ((string-length str) . <= . 45) + str + (string-append (substring str 0 45) "..."))) + (define (test option show-sharing pretty? answer) + ;; answer must either be a string, or a procedure that accepts both zero and 1 + ;; argument. When the procedure accepts 1 arg, the argument is `got' and + ;; the result must be a boolean indicating if the result was satisfactory. + ;; if the procedure receives no arguments, it must return a descriptive string + ;; for the error message + (set-output-choice option show-sharing pretty?) + (do-execute drr) + (define got (fetch-output/should-be-tested drr)) + (unless (if (procedure? answer) + (answer got) + (whitespace-string=? answer got)) + (eprintf "FAILED ~s ~a, sharing ~a \"Insert newlines in printed values\" ~a\n" + (language) option show-sharing pretty?) + (eprintf " got ~s\n" (shorten got)) + (eprintf "expected ~s\n" (if (procedure? answer) (answer) answer)))) + + (clear-definitions drr) + (insert-in-definitions drr (defs-prefix)) + (insert-in-definitions drr expression) + + (test plain-print-style 'off #t (if uses-qq-for-plain-print? "'((2) (2))" "((2) (2))")) + (when has-sharing? + (test plain-print-style 'on #t (if uses-qq-for-plain-print? "'(#0=(2) #0#)" "(#0=(2) #0#)"))) + (when quasi-quote? + (test "Quasiquote" 'off #t "`((2) (2))") + (when has-sharing? + (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))"))) + + (test "Constructor" 'off #t + (if list? + "(list (list 2) (list 2))" + "(cons (cons 2 '()) (cons (cons 2 '()) '()))")) + (when has-sharing? + (test "Constructor" 'on #t + (if list? + "(shared ((-1- (list 2))) (list -1- -1-))" + "(shared ((-1- (cons 2 '()))) (cons -1- (cons -1- '())))"))) + + ;; setup print / pretty-print difference + (clear-definitions drr) + (insert-in-definitions drr (defs-prefix)) + (insert-in-definitions + drr + "(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)") + (test "Constructor" #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test "Constructor" #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])) + (test plain-print-style #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test plain-print-style #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])) + + (when has-print-printing? + (clear-definitions drr) + (insert-in-definitions drr (defs-prefix)) + (insert-in-definitions drr "(print 'hello (current-output-port) 1)") + (test plain-print-style #f #t "hello") + (test plain-print-style #f #f "hello")) + + (when print-value-columns? + (set-output-choice plain-print-style #f #t) + (let () + (clear-definitions drr) + (insert-in-definitions drr (defs-prefix)) + (insert-in-definitions drr "(build-list 100 values)") + (do-execute drr) + (define got (fetch-output/should-be-tested drr)) + (unless (member #\newline (string->list got)) + (eprintf "long output should have contained newlines, got ~s\n" got))) + + (clear-definitions drr) + (insert-in-definitions drr (defs-prefix)) + (insert-in-definitions drr "(print-value-columns 1000)") + (insert-in-definitions drr "(build-list 100 values)") + (do-execute drr) + (define got (fetch-output/should-be-tested drr)) + (when (member #\newline (string->list got)) + (eprintf "long output should not have contained newlines, got ~s\n" got)))) + +(define (find-output-radio-box label) + (define frame (test:get-active-top-level-window)) + (let/ec k + (let loop ([gui-thing frame] + [parent #f]) + (cond + [(is-a? gui-thing panel:single<%>) + (loop (send gui-thing active-child) gui-thing)] + [(is-a? gui-thing area-container<%>) + (for ([child (in-list (send gui-thing get-children))]) + (loop child gui-thing))] + [(is-a? gui-thing radio-box%) + (when (equal? label (send gui-thing get-label)) + (k gui-thing))] + [(is-a? gui-thing message%) + + ;; if we find a message%, go up one level + ;; in the GUI and just get any radio box under there. + (when (equal? label (send gui-thing get-label)) + (let loop ([gui-thing parent]) + (cond + [(is-a? gui-thing area-container<%>) + (for ([child (in-list (send gui-thing get-children))]) + (loop child))] + [(is-a? gui-thing radio-box%) + (k gui-thing)])))])) + (error 'find-output-radio-box "could not find `~a' radio box" + label))) + +(define re:out-of-sync + (regexp + "WARNING: Interactions window is out of sync with the definitions window\\.")) + +(define (test-error-after-definition) + (define drs (wait-for-drracket-frame)) + (define interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))) + (clear-definitions drs) + (insert-in-definitions drs (defs-prefix)) + (insert-in-definitions drs "(define y 0) (define (f x) (/ x y)) (f 2)") + (do-execute drs) + (define last-para (queue-callback/res (λ () (send interactions-text last-paragraph)))) + (type-in-interactions drs "y\n") + (wait-for-computation drs) + (define got + (fetch-output/should-be-tested + drs + (queue-callback/res (λ () (send interactions-text paragraph-start-position (+ last-para 1)))) + (queue-callback/res (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))) + (unless (equal? got "0") + (eprintf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got))) + + +;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) +;; (union string regexp (string -> boolean)) +;; -> void +;; types an expression in the definitions window, executes it and tests the output +;; types an expression in the REPL and tests the output from the REPL. +(define (test-expression expression defs-expected [repl-expected defs-expected] + #:has-repl? [has-repl? #t]) + (let* ([drs (wait-for-drracket-frame)] + [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))] + [definitions-text (queue-callback/res (λ () (send drs get-definitions-text)))] + [handle-insertion + (lambda (item) + (cond + [(eq? item 'image) + (use-get/put-dialog + (lambda () (fw:test:menu-select "Insert" "Insert Image…")) + (simplify-path (build-path (collection-file-path "recycle.png" "icons"))))] + [(string? item) + (insert-in-definitions drs item)] + [(eq? item 'xml) + (fw:test:menu-select "Insert" "Insert XML Box") + (for-each fw:test:keystroke (string->list ""))] + [else (error 'handle-insertion "unknown thing to insert ~s" item)]))] + [check-expectation + (lambda (expected got) + (cond + [(string? expected) + (whitespace-string=? expected got)] + [(regexp? expected) + (regexp-match expected got)] + [(procedure? expected) + (expected got)]))] + [make-err-msg + (lambda (expected) + (cond + [(string? expected) + "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"] + [(regexp? expected) + "FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"] + [(procedure? expected) + "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))]) + (clear-definitions drs) + (insert-in-definitions drs (defs-prefix)) + (cond + [(pair? expression) (for-each handle-insertion expression)] + [else (handle-insertion expression)]) + (do-execute drs) + + (let ([got + (fetch-output + drs + (queue-callback/res (λ () (send interactions-text paragraph-start-position 2))) + (queue-callback/res + (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))]) + (when (regexp-match re:out-of-sync got) + (error 'text-expression "got out of sync message")) + (unless (check-expectation defs-expected got) + (eprintf (make-err-msg defs-expected) + 'definitions (language) expression defs-expected got))) + + (when has-repl? + (let ([dp (defs-prefix)]) + (queue-callback/res + (λ () + ;; select all except the defs-prefix + (send definitions-text set-position + (string-length dp) + (send definitions-text last-position)) + (send definitions-text move/copy-to-edit + interactions-text + (send definitions-text get-start-position) + (send definitions-text get-end-position) + (send interactions-text last-position) + #:try-to-move? #f)))) + + (define last-para (queue-callback/res (λ () (send interactions-text last-paragraph)))) + (alt-return-in-interactions drs) + (wait-for-computation drs) + (define got + (fetch-output + drs + (queue-callback/res (λ () (send interactions-text paragraph-start-position (+ last-para 1)))) + (queue-callback/res (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))) + (when (regexp-match re:out-of-sync got) + (error 'text-expression "got out of sync message")) + (unless (check-expectation repl-expected got) + (eprintf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got))))) + +(define (test-undefined-var id #:icon+in? [icon+in? #f]) + (test-expression + id + (string-append (if icon+in? "{stop-22x22.png} " "") + (format "~a: this variable is not defined" id) + (if icon+in? (format " in: ~a " id) "")))) + +(define (test-undefined-fn exp id #:icon+in? [icon+in? #f]) + (test-expression + exp + (string-append (if icon+in? "{stop-22x22.png} " "") + (format "~a: this function is not defined" id) + (if icon+in? (format " in: ~a " id) "")))) + +(define-syntax (go stx) + (syntax-case stx () + [(_ arg) + (identifier? (syntax arg)) + (syntax (begin (flush-output) + (printf ">> starting ~a\n" 'arg) + (flush-output) + (arg) + (flush-output) + (printf ">> finished ~a\n" 'arg) + (flush-output)))])) + +(define (run-test) + (go bsl) ;; Some failed test cases are commented out; they never worked. + (go beginner) + (go beginner/abbrev) + (go intermediate) + (go intermediate/lambda) + (go advanced) + + (define drr (wait-for-drracket-frame)) + (queue-callback/res + (λ () + (define defs (send drr get-definitions-text)) + (send defs remove-autosave)))) + +(fire-up-drracket-and-run-tests run-test) + +(module+ test + (module config info + (define timeout 2000))) diff --git a/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt new file mode 100644 index 00000000..e1c886fb --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt @@ -0,0 +1,771 @@ +;; From: drracket/drracket-test/tests/drracket/module-lang-test.rkt +;; At: e94a69c80ae82954ec9ce6ebdec784a99f2b9b98 +;; Infrastructure: Robby +;; Test author: Shu-Hung +#lang at-exp racket/base + +(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) +(provide run-test) + +;; set up for tests that need external files +(write-test-modules + (module module-lang-test-tmp1 mzscheme + (provide (all-from-except mzscheme +) + x) + (define x 1)) + (module module-lang-test-tmp2 mzscheme + (provide e) + (define e #'1)) + (module module-lang-test-tmp3 mzscheme + (define-syntax (bug-datum stx) + (syntax-case stx () + [(dat . thing) + (number? (syntax-e (syntax thing))) + (syntax/loc stx (#%datum . thing))])) + (provide #%module-begin [rename bug-datum #%datum])) + (module module-lang-test-tmp4 racket/base + (/ 888 2) + (provide (except-out (all-from-out racket/base) #%top-interaction))) + (module module-lang-test-syn-error racket/base + (lambda))) + +(test '("#lang racket\n" xml-box) + #f + @t{'(a () "x")}) + +(test @t{#lang htdp/bsl + 1 2 3} + #f + "1\n2\n3") + +;; Test that big-bang is in the stacktrace if the state-expr errors at start time. +(test @t{ + #lang htdp/isl+ + + (require 2htdp/image) + (require 2htdp/universe) + + (big-bang (+ 2 #false) + (to-draw (lambda (s) (empty-scene 200 200)))) + +} + #f + #rx"[+]: expects a number(?: as 2nd argument)?, given #false" + #: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:6:10" + (srcloc->string loc))) + ;; ^ (+ 2 #false) is in the backtrace + (for*/or ([stack (in-list stacks)] + #:when stack + [loc (in-list (viewable-stack->red-arrows-backtrace-srclocs stack))]) + (regexp-match? #rx"unsaved-editor:6:0" + (srcloc->string loc))) + ;; ^ big-bang 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"[(][+] 2.*false[)]" + (test-definitions test))) + ;; ^ (+ 2 #false) is highlighted + ))) + +;; Test that big-bang is highlighted for (initial) check-with errors +;; Note that, however, this only works when big-bang check-with fails at start time. +(test @t{ + #lang htdp/isl+ + + (require 2htdp/image) + (require 2htdp/universe) + + (big-bang -1 + (to-draw (lambda (s) (empty-scene 200 200))) + (check-with string?)) + +} + #f + #rx"check-with: the initial expression.*fails to pass.*string[?] test" + #: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:6:0" + (srcloc->string loc))) + ;; ^ big-bang 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"[(]big-bang.*[(]check-with string[?][)][)]" + (test-definitions test))) + ;; ^ big-bang is highlighted + ))) + +;; Needs 2htdp/universe fixing: this does not work at the moment (v8.15) +;; check-with errors triggered by on-{tick,key} etc do not work. +#; +(test @t{ + #lang htdp/isl+ + + (require 2htdp/image) + (require 2htdp/universe) + + (big-bang -1 + (to-draw (lambda (n) (empty-scene 200 200))) + (on-tick (lambda (n) "oops")) + (check-with number?)) + +} + #f + #rx"check-with: on-tick handler.*fails to pass.*number[?] test" + #: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:6:0" + (srcloc->string loc))) + ;; ^ user code 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"[(]big-bang.*[(]check-with number[?][)][)]" + (test-definitions test))) + ;; ^ user code is highlighted (if not on-tick, at least it should be big-bang) + ))) + +(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 posn-x + 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.*given posn-x[^\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 extra assertion 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 + ))) + +;; NOTE. If check-satisfied no longer errs immediately in the future, +;; merge this test into the last check-satisfied test below. +(test @t{ + #lang htdp/isl+ + + (check-satisfied (+ 2 2) 4) + +} + #f + #rx"check-satisfied: expect.*function.*one argument.*second position.*iven 4" + #: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-satisfied 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-satisfied.*4[)]" + (test-definitions test))) + ;; ^ check-satisfied is highlighted + ))) + +;; NOTE. If the error-check printing bug is fixed, replace the printed procedure +;; # with (appropriately escaped) (lambda (a1 a2) ...) +(test @t{ + #lang htdp/isl+ + + (check-satisfied 4 (lambda (n bad) (even? n))) + +} + #f + #rx"check-satisfied: expect.*function.*one argument.*second position.*#" + #: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-satisfied 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-satisfied.*[(]even[?] n[)][)][)]" + (test-definitions test))) + ;; ^ check-satisfied is highlighted + ))) + +;; NOTE. +;; 1. After the error-check printing bug is fixed, add the "function:" prefix +;; to all the functions in the error messsage in this test. +;; 2. The column numbers after "::" in each error could be further improved/refined, +;; but the srclocs should include at least the line numbers of the user code. +;; 3. Also remember to test this in a _saved_ buffer. +(test @t{#lang htdp/isl + + (define local-even + (local [(define (my-even m k) + (even? (+ m k)))] + my-even)) + + (define (real-my-even m k) + (even? (+ m k))) + + (check-satisfied (rest (list 3514)) empty) + (check-satisfied 4 local-even) + (check-satisfied 4 real-my-even)} + #f + #px"^Ran 3 tests[.]\\s+0 tests passed[.]" + #t + #:extra-assert + (λ (defs ints #:test test) + (define re + (pregexp + @t{^Ran 3 tests[.] + 0 tests passed[.] + + Check failures:\s* + +check-satisfied for empty encountered an error[.]\s* + +:: +at line 11, column 0 +function call: expect.+function.+open parenthesis.+received '[(][)]\s* + at line 11, column 0 *caused by expression *at line 11, column 0 + +check-satisfied for local-even encountered an error[.]\s* + +:: +at line 12, column 0 +my-even: expect.+2 arguments.+found only 1\s* + at line 12, column 0 *caused by expression *at line 12, column 0 + +check-satisfied for real-my-even encountered an error[.]\s* + +:: +at line 13, column 0 +check-satisfied: expect.+function.+one argument.+second position.+real-my-even\s* + at line 13, column 0 *caused by expression *at line 13, 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) + (flush-output (current-error-port)) + (sleep/yield 0.1)) + passed?)) + +(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+ + + (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+ + + (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) + (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)))) + +(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 + + (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 + + (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) + (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)))) + +(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)} + #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!$") + +(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 *caused by expression *at line 12, column 14 + > })) + ;; 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?)) + +(fire-up-drracket-and-run-tests run-test) + +;; Test mode: +(module test racket/base + (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 (number? code) (zero? code) (> stderr-content-length 0)) + (write-string "non-empty stderr\n" stderr) + (old-exit-hdlr 1)] + [else + (old-exit-hdlr code)])))) + (void (putenv "PLTDRTEST" "yes")) + (eval-jit-enabled #f) + (parameterize ([current-error-port outp]) + (dynamic-require (quote-module-path "..") #f)) + (module config info + (define timeout 800))) diff --git a/htdp-drracket-test/tests/htdp-lang/private/drracket-test-util.rkt b/htdp-drracket-test/tests/htdp-lang/private/drracket-test-util.rkt new file mode 100644 index 00000000..b4bd598f --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/private/drracket-test-util.rkt @@ -0,0 +1,643 @@ +;; From: drracket/drracket-test/tests/drracket/private/drracket-test-util.rkt +;; Original author: Robby +#lang racket/base + +(require (prefix-in fw: framework) + mrlib/hierlist + racket/gui/base + racket/class + racket/contract + rackunit/log + drracket/private/local-member-names + (for-syntax racket/base) + "gui.rkt" + "no-fw-test-util.rkt") + + (provide (contract-out [use-get/put-dialog (-> (-> any) path? void?)] + [set-module-language! (->* () (boolean?) void?)])) + + (provide queue-callback/res + fire-up-drracket-and-run-tests + fire-up-separate-drracket-and-run-tests + save-drracket-window-as + do-execute + test-util-error + poll-until + wait-for-computation + wait-for-drracket-frame + wait-for-new-frame + clear-definitions + type-in-definitions + type-in-interactions + insert-in-definitions + insert-in-interactions + type-string + wait + wait-pending + get-sub-panel + get-text-pos + wait-for-button + push-button-and-wait + set-language-level! + repl-in-edit-sequence? + fetch-output + has-error? + run-one/sync + alt-return-in-interactions + wait-for-online-compilation-to-finish + set-focus-and-wait) + + ;; save-drracket-window-as : string -> void + ;; use the "save as" dialog in drracket to save the definitions + ;; window to a file. + (define (save-drracket-window-as filename) + (not-on-eventspace-handler-thread 'save-drracket-window-as) + (use-get/put-dialog + (lambda () + (fw:test:menu-select "File" "Save Definitions As…")) + filename)) + + ;; open-dialog is a thunk that should open the dialog + ;; filename is a string naming a file that should be typed into the dialog + (define (use-get/put-dialog open-dialog filename) + (not-on-eventspace-handler-thread 'use-get/put-dialog) + (define drs (wait-for-drracket-frame)) + (with-handlers ([(lambda (x) #t) (lambda (x) + (fw:preferences:set 'framework:file-dialogs 'std) + (raise x))]) + (fw:preferences:set 'framework:file-dialogs 'common) + (open-dialog) + (let ([dlg (wait-for-new-frame drs)]) + (send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus) + (fw:test:keystroke + #\a + (list (case (system-type) + [(windows) 'control] + [(macosx macos) 'meta] + [(unix) 'control] + [else (error 'use-get/put-dialog "unknown platform: ~s\n" (system-type))]))) + (for-each fw:test:keystroke (string->list (path->string filename))) + (fw:test:button-push "OK") + (wait-for-new-frame dlg)) + (fw:preferences:set 'framework:file-dialogs 'std))) + + (define (test-util-error fmt . args) + (raise (make-exn (apply fmt args) (current-continuation-marks)))) + + + (define (drracket-frame? frame) + (method-in-interface? 'get-execute-button (object-interface frame))) + + (define (wait-for-drracket-frame [print-message? #f]) + (define (wait-for-drracket-frame-pred) + (define active (fw:test:get-active-top-level-window)) + (and (and active (drracket-frame? active)) active)) + (define drr-fr + (or (wait-for-drracket-frame-pred) + (begin + (when print-message? + (printf "Select DrRacket frame\n")) + (poll-until wait-for-drracket-frame-pred)))) + (when drr-fr + (wait-for-events-in-frame-eventspace drr-fr)) + drr-fr) + + ;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame + ;; returns the newly opened frame, waiting until old-frame + ;; is no longer frontmost. Optionally checks other eventspaces + ;; waits until the new frame has a focus'd window, too. + (define (wait-for-new-frame/proc #:line line #:source source + old-frame old-frame-id-name + [extra-eventspaces '()] [timeout 10]) + (define (wait-for-new-frame-pred) + (define active (or (fw:test:get-active-top-level-window) + (for/or ([eventspace (in-list extra-eventspaces)]) + (parameterize ([current-eventspace eventspace]) + (fw:test:get-active-top-level-window))))) + (and (and active (not (eq? active old-frame))) active)) + (define lab (send old-frame get-label)) + (define fr (poll-until + (procedure-rename wait-for-new-frame-pred + (string->symbol + (format "wait-for-new-frame-pred; old: ~s id: ~a call on ~a:~a" + lab old-frame-id-name + source line))) + timeout)) + (when fr (wait-for-events-in-frame-eventspace fr)) + fr) + +(define (set-focus-and-wait window) + (not-on-eventspace-handler-thread 'set-focus-and-wait) + (queue-callback (λ () (send window focus))) + (define (waiting-for-focus) + (queue-callback/res + (λ () (send window has-focus?)))) + (poll-until waiting-for-focus)) + +(define-syntax (wait-for-new-frame stx) + (syntax-case stx () + [(_ a b ...) + #`(wait-for-new-frame/proc + #:line #,(syntax-line stx) + #:source '#,(syntax-source stx) + a 'a b ...)])) + + + + ;; wait-for-computation : frame -> void + ;; waits until the drracket frame finishes some computation. + (define (wait-for-computation frame) + (not-on-eventspace-handler-thread 'wait-for-computation) + (queue-callback/res (λ () (verify-drracket-frame-frontmost 'wait-for-computation frame))) + (define (computation-running?) + (define-values (thd cust) (send (send frame get-current-tab) get-breakables)) + (and (or thd cust) #t)) + (define (wait-for-computation-to-start) + (fw:test:reraise-error) + (computation-running?)) + (define (wait-for-computation-to-finish) + (fw:test:reraise-error) + (not (computation-running?))) + (sync (system-idle-evt)) ; intended to ensure that the computation has started + (poll-until wait-for-computation-to-finish 60) + (sync (system-idle-evt))) + + (define (do-execute frame [wait-for-finish? #t]) + (not-on-eventspace-handler-thread 'do-execute) + (queue-callback/res (λ () (verify-drracket-frame-frontmost 'do-execute frame))) + (let ([button (queue-callback/res (λ () (send frame get-execute-button)))]) + (fw:test:run-one (lambda () (send button command))) + (when wait-for-finish? + (wait-for-computation frame)))) + + (define (verify-drracket-frame-frontmost function-name frame) + (on-eventspace-handler-thread 'verify-drracket-frame-frontmost) + (define tl (fw:test:get-active-top-level-window)) + (unless (and (eq? frame tl) (drracket-frame? tl)) + (error function-name "drracket frame not frontmost: ~e (found ~e)" frame tl))) + + (define (clear-definitions frame) + (queue-callback/res (λ () (verify-drracket-frame-frontmost 'clear-definitions frame))) + (fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas)))) + (let ([window (queue-callback/res (λ () (send frame get-edit-target-window)))]) + (define-values (cw ch) (queue-callback/res (λ () (send window get-client-size)))) + (define-values (w h) (queue-callback/res (λ () (send window get-size)))) + (fw:test:mouse-click 'left + (inexact->exact (floor (+ cw (/ (- w cw) 2)))) + (inexact->exact (floor (+ ch (/ (- h ch) 2)))))) + (fw:test:menu-select "Edit" "Select All") + (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) + "Clear" + "Delete"))) + + (define (type-in-definitions frame str) + (not-on-eventspace-handler-thread 'type-in-definitions) + (put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #f 'type-in-definitions)) + (define (type-in-interactions frame str) + (not-on-eventspace-handler-thread 'type-in-interactions) + (put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #f 'type-in-interactions)) + (define (insert-in-definitions frame str) + (not-on-eventspace-handler-thread 'insert-in-definitions) + (put-in-frame (lambda (x) (send x get-definitions-canvas)) frame str #t 'insert-in-definitions)) + (define (insert-in-interactions frame str) + (not-on-eventspace-handler-thread 'insert-in-interactions) + (put-in-frame (lambda (x) (send x get-interactions-canvas)) frame str #t 'insert-in-interactions)) + + (define (put-in-frame get-canvas frame str/sexp just-insert? who) + (not-on-eventspace-handler-thread 'put-in-frame) + (unless (and (object? frame) (is-a? frame top-level-window<%>)) + (error who "expected a frame or a dialog as the first argument, got ~e" frame)) + (define str + (if (string? str/sexp) + str/sexp + (let ([port (open-output-string)]) + (parameterize ([current-output-port port]) + (write str/sexp port)) + (get-output-string port)))) + (queue-callback/res (λ () (verify-drracket-frame-frontmost who frame))) + (define canvas (queue-callback/res (λ () (get-canvas frame)))) + (fw:test:new-window canvas) + (define editor (queue-callback/res (λ () (send canvas get-editor)))) + (cond + [just-insert? + (let ([s (make-semaphore 0)]) + (queue-callback (λ () + (send editor set-caret-owner #f) + (send editor insert str) + (semaphore-post s))) + (unless (sync/timeout 3 s) + (error who "callback didn't run for 3 seconds; trying to insert ~s" str/sexp)))] + [else + (queue-callback/res (λ () (send editor set-caret-owner #f))) + (type-string str)])) + + (define (alt-return-in-interactions frame) + (not-on-eventspace-handler-thread 'alt-return-in-interactions) + (queue-callback/res (λ () (verify-drracket-frame-frontmost 'alt-return-in-interactions frame))) + (define canvas (send frame get-interactions-canvas)) + (fw:test:new-window canvas) + (define editor (send canvas get-editor)) + (send editor set-caret-owner #f) + (fw:test:keystroke #\return '(alt))) + + ;; type-string : string -> void + ;; to call test:keystroke repeatedly with the characters + (define (type-string str) + (not-on-eventspace-handler-thread 'type-string) + (define len (string-length str)) + (let loop ([i 0]) + (unless (>= i len) + (let ([c (string-ref str i)]) (fw:test:keystroke (if (char=? c #\newline) #\return c))) + (loop (+ i 1))))) + + (define (wait test desc-string [time 5]) + (let ([int 1/2]) + (let loop ([sofar 0]) + (cond + [(> sofar time) (error 'wait desc-string)] + [(test) (void)] + [else + (sleep int) + (loop (+ sofar int))])))) + + (define (wait-pending) + (wait (lambda () (= 0 (fw:test:number-pending-actions))) + "Pending actions didn't terminate") + (fw:test:reraise-error)) + + +;;; get-sub-panel takes +;;; a list of integers describing the path from a frame to the desired panel +;;; the frame +;;; based on code by Mark Krentel + +;;; Examples: +;;; (get-sub-panel '() frame) gets the top-panel in frame +;;; (get-sub-panel '(2) frame) gets the 2nd child of the top-panel +;;; (get-sub-panel '(2 0) frame) gets the 0th child of the 2nd child of the top-panel + + (define (get-sub-panel path frame) + (on-eventspace-handler-thread 'get-sub-panel) + (letrec ([loop + (lambda (path panel) + (if (null? path) + (if (is-a? panel panel%) + panel + (test-util-error "not a panel")) + (loop + (cdr path) + (list-ref (send panel get-children) (car path)))))]) + (loop path frame))) + +;;; get-text-pos returns the offset in an text buffer of the beginning +;;; of the last line + + (define (get-text-pos text) + (on-eventspace-handler-thread 'get-text-pos) + (define last-pos (send text last-position)) + (define last-line (send text position-line last-pos)) + (send text line-start-position last-line)) + + ; poll for enabled button + + (define (wait-for-button button) + (not-on-eventspace-handler-thread 'wait-for-button) + (poll-until + (let ([wait-for-button-pred + (lambda () + (queue-callback/res (λ () (send button is-enabled?))))]) + wait-for-button-pred))) + + (define (push-button-and-wait button) + (not-on-eventspace-handler-thread 'push-button-and-wait) + (fw:test:button-push button) + (poll-until + (let ([button-push-and-wait-pred + (lambda () + (fw:test:reraise-error) + (= 0 (fw:test:number-pending-actions)))]) + button-push-and-wait-pred)) + (wait-for-button button)) + + ;; set-language-level! : (cons (union regexp string) (listof (union regexp string))) boolean -> void + ;; set language level in the frontmost DrRacket frame (resets settings to defaults) + ;; If `close-dialog?' it #t, + (define (set-language-level! 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)) + (not-on-eventspace-handler-thread 'set-language-level!) + (let ([drs-frame (fw:test:get-active-top-level-window)]) + (fw:test:menu-select "Language" "Choose Language…") + (define language-dialog (wait-for-new-frame drs-frame)) + (fw:test:set-radio-box-item! #rx"Other Languages") + (define language-choices + (find-labelled-windows #f hierarchical-list% (fw:test:get-active-top-level-window))) + (define (click-on-snip snip) + (define-values (x y) + (queue-callback/res (λ () + (define b1 (box 0)) + (define b2 (box 0)) + (define editor (send (send snip get-admin) get-editor)) + (define between-threshold (send editor get-between-threshold)) + (send editor get-snip-location snip b1 b2) + (define-values (gx gy) + (send editor editor-location-to-dc-location (unbox b1) (unbox b2))) + (define x (inexact->exact (floor (+ gx between-threshold 1)))) + (define y (inexact->exact (floor (+ gy between-threshold 1)))) + (values x y)))) + (fw:test:mouse-click 'left x y)) + + (define found-language? #f) + + (for ([language-choice (in-list language-choices)]) + (queue-callback/res (λ () (send language-choice focus))) + (let loop ([list-item language-choice] + [language-spec in-language-spec]) + (let* ([name (car language-spec)] + [which (queue-callback/res + (λ () + (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))))]) + (unless (null? which) + (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)) + (set! found-language? #t) + (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 (queue-callback/res (λ () (send next-item is-open?))) + (click-on-snip (send next-item get-arrow-snip))) + (loop next-item (cdr language-spec))])))))) + + (unless found-language? + (error 'set-language-level! "couldn't find language: ~e" in-language-spec)) + + (with-handlers ([exn:fail? (lambda (x) (void))]) + (fw:test:button-push #rx"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 drracket frame back, got: ~s (drs-frame ~s)\n" + new-frame + drs-frame)))))) + + (define (set-module-language! [close-dialog? #t]) + (not-on-eventspace-handler-thread 'set-module-language!) + (define drs-frame (fw:test:get-active-top-level-window)) + (fw:test:menu-select "Language" "Choose Language…") + (define language-dialog (wait-for-new-frame drs-frame)) + (fw:test:set-radio-box-item! #rx"The Racket Language") + + (with-handlers ([exn:fail? (lambda (x) (void))]) + (fw:test:button-push #rx"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-module-language! + "didn't get drracket frame back, got: ~s (drs-frame ~s)\n" + new-frame + drs-frame))))) + + (provide (contract-out [check-language-level ((or/c string? regexp?) . -> . void?)])) + ;; checks that the language in the drracket window is set to the given one. + ;; clears the definitions, clicks execute and checks the interactions window. + (define (check-language-level lang-spec) + (not-on-eventspace-handler-thread 'check-language-level!) + (define drs-frame (wait-for-drracket-frame)) + (define interactions (send drs-frame get-interactions-text)) + (define definitions-canvas (send drs-frame get-definitions-canvas)) + (fw:test:new-window definitions-canvas) + (fw:test:menu-select "Edit" "Select All") + (fw:test:menu-select "Edit" "Delete") + (do-execute drs-frame) + (define lang-line + (queue-callback/res (λ () + (send interactions get-text + (send interactions line-start-position 1) + (send interactions line-end-position 1))))) + (unless (regexp-match lang-spec lang-line) + (error 'check-language-level "expected ~s to match ~s" lang-line lang-spec))) + + + (define (repl-in-edit-sequence?) + (not-on-eventspace-handler-thread 'repl-in-edit-sequence?) + (define drr (wait-for-drracket-frame)) + (queue-callback/res (λ () (send (send drr get-interactions-text) refresh-delayed?)))) + + ;; has-error? : frame -> (union #f string) + ;; returns the text of an error in the interactions window of the frame or #f if there is none. + ;; ensures that frame is front most. + (define (has-error? frame) + (not-on-eventspace-handler-thread 'repl-in-edit-sequence?) + (run-one/sync + (lambda () + (verify-drracket-frame-frontmost 'had-error? frame) + (define interactions-text (send frame get-interactions-text)) + (define last-para (send interactions-text last-paragraph)) + (unless (>= last-para 2) + (error 'has-error? + "expected at least 2 paragraphs in interactions window, found ~a" + (+ last-para 1))) + (define start (send interactions-text paragraph-start-position 2)) + (define end + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1))) + (send interactions-text split-snip start) + (send interactions-text split-snip end) + (let loop ([pos start]) + (cond + [(<= end pos) #f] + [else + (let ([snip (send interactions-text find-snip pos 'after-or-none)]) + (cond + [(not snip) #f] + [else + (let ([color (send (send snip get-style) get-foreground)]) + (if (and (= 255 (send color red)) (= 0 (send color blue) (send color green))) + + ;; return the text of the entire line containing the red text + (let ([para (send interactions-text position-paragraph pos)]) + (unless (exact-nonnegative-integer? para) + (error 'has-error? + "got back a bad result from position-paragraph: ~s ~s\n" + para + (list pos (send interactions-text last-position)))) + (send interactions-text get-text + (send interactions-text paragraph-start-position para) + (send interactions-text paragraph-end-position para))) + + (loop (+ pos (send snip get-count)))))]))]))))) + + (define fetch-output + (case-lambda + [(frame) (fetch-output frame #f #f)] + [(frame _start _end) + (not-on-eventspace-handler-thread 'fetch-output) + (run-one/sync + (lambda () + (verify-drracket-frame-frontmost 'fetch-output frame) + (define-values (start end) + (cond + [(and _start _end) (values _start _end)] + [else + (define interactions-text (send frame get-interactions-text)) + (define last-para (send interactions-text last-paragraph)) + (unless (>= last-para 2) + (error 'fetch-output + "expected at least 2 paragraphs in interactions window, found ~a" + (+ last-para 1))) + (values (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))])) + + (define (fetch-text-content text start end) + (send text split-snip start) + (send text split-snip end) + (let loop ([snip (send text find-snip end 'before)] + [strings null]) + (cond + [(or (not snip) + (< (send text get-snip-position snip) start)) + (apply string-append strings)] + [else + (cond + [(is-a? snip string-snip%) + (loop (send snip previous) + (cons (send snip get-text 0 (send snip get-count)) strings))] + [(is-a? snip editor-snip%) + (let ([editor (send snip get-editor)]) + (cond + [(is-a? editor pasteboard%) + (loop (send snip previous) + (cons "" strings))] + [(is-a? editor text%) + (loop (send snip previous) + (list* "{embedded \"" + (fetch-text-content editor 0 (send editor last-position)) + "\"}" + strings))]))] + [(is-a? snip image-snip%) + (loop (send snip previous) + (cons (with-handlers ([exn:fail? (lambda (x) "{image}")]) + (format "{~a}" (send snip get-image-name))) + strings))] + + [;; this test is an approximation of + ;; (is-a? snip drscheme:snip:number-snip%) + (and (method-in-interface? 'get-fraction-view (object-interface snip))) + (loop (send snip previous) + (cons (format "{number ~s ~s ~s}" + (send snip get-number) + (send snip get-text 0 (send snip get-count)) + (send snip get-fraction-view)) + strings))] + [;; this test is an approximation of + ;; (is-a? snip pict-snip%) from drracket/private/pict-snip% + (let ([sc (send snip get-snipclass)]) + (and sc (regexp-match #rx"pict-snip.rkt" (send sc get-classname)))) + (loop (send snip previous) + (cons "{pict-snip}" strings))] + + [else + (loop (send snip previous) + (cons (format "{unknown snip: ~e}\n" snip) + strings))])]))) + + (fetch-text-content (send frame get-interactions-text) start end)))])) + + ;; run-one/sync : (-> A) -> A + ;; runs the thunk `f' as a test action, and + ;; waits for it to complete. Also propagates + ;; exceptions. + (define (run-one/sync f) + (not-on-eventspace-handler-thread 'run-one/sync) + (let ([s (make-semaphore 0)] + [raised-exn? #f] + [exn #f] + [anss #f]) + (fw:test:run-one + (lambda () + (with-handlers ([exn:fail? (lambda (-exn) + (set! raised-exn? #t) + (set! exn -exn))]) + (call-with-values f (lambda x (set! anss x)))) + (semaphore-post s))) + (semaphore-wait s) + (when raised-exn? + (raise exn)) + (apply values anss))) + + ;; this is assumed to not open an windows or anything like that + ;; but just to print and return. + (define orig-display-handler (error-display-handler)) + + (define (fire-up-drracket-and-run-tests + #:use-focus-table? [use-focus-table? #t] + #:prefs [prefs '()] + run-test) + (on-eventspace-handler-thread 'fire-up-drracket-and-run-tests) + (let () + (use-hash-for-prefs fw:preferences:low-level-get-preference + fw:preferences:low-level-put-preferences + fw:preferences:restore-defaults + fw:preferences:set + fw:preferences:default-set? + prefs) + + (parameterize ([current-command-line-arguments #()]) + (dynamic-require 'drracket #f)) + + (fw:test:use-focus-table use-focus-table?) + + (thread (λ () + (let ([orig-display-handler (error-display-handler)]) + (uncaught-exception-handler + (λ (x) + (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) + (exit 0))) + (yield (make-semaphore 0)))) + +(define (wait-for-online-compilation-to-finish frame) + (let loop ([i 0]) + (define current-colors (send frame get-online-expansion-colors)) + (unless (equal? current-colors '("forestgreen")) + (sleep 1) + (loop (+ i 1))))) diff --git a/htdp-drracket-test/tests/htdp-lang/private/gui.rkt b/htdp-drracket-test/tests/htdp-lang/private/gui.rkt new file mode 100644 index 00000000..0a041317 --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/private/gui.rkt @@ -0,0 +1,114 @@ +;; From: drracket/drracket-test/tests/drracket/private/gui.rkt +;; Original author: Robby +#lang racket/base + + (require racket/gui/base + racket/class) + (provide find-labelled-window + find-labelled-windows + whitespace-string=?) + + ;; whitespace-string=? : string string -> boolean + ;; determines if two strings are equal, up to their whitespace. + ;; each string is required to have whitespace in the same place, + ;; but not necessarily the same kinds or amount. + (define (whitespace-string=? string1 string2) + (let loop ([i 0] + [j 0] + [in-whitespace? #t]) + (cond + [(= i (string-length string1)) (only-whitespace? string2 j)] + [(= j (string-length string2)) (only-whitespace? string1 i)] + [else (define c1 (string-ref string1 i)) + (define c2 (string-ref string2 j)) + (cond + [in-whitespace? + (cond + [(whitespace? c1) (loop (+ i 1) j #t)] + [(whitespace? c2) (loop i (+ j 1) #t)] + [else (loop i j #f)])] + [(and (whitespace? c1) (whitespace? c2)) (loop (+ i 1) (+ j 1) #t)] + [(char=? c1 c2) (loop (+ i 1) (+ j 1) #f)] + [else #f])]))) + + ;; whitespace? : char -> boolean + ;; deteremines if `c' is whitespace + (define (whitespace? c) + (or (char=? c #\newline) + (char=? c #\space) + (char=? c #\tab) + (char=? c #\return))) + + ;; only-whitespace? : string number -> boolean + ;; returns true if string only contains whitespace, from index `i' onwards + (define (only-whitespace? str i) + (let loop ([n i]) + (cond + [(= n (string-length str)) + #t] + [(whitespace? (string-ref str n)) + (loop (+ n 1))] + [else #f]))) + + ;; whitespace-string=? tests + (module+ test + (require rackunit) + (check-equal? #t (whitespace-string=? "a" "a")) + (check-equal? #f (whitespace-string=? "a" "A")) + (check-equal? #f (whitespace-string=? "a" " ")) + (check-equal? #f (whitespace-string=? " " "A")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? " a" "a")) + (check-equal? #t (whitespace-string=? "a" " a")) + (check-equal? #t (whitespace-string=? "a " "a")) + (check-equal? #t (whitespace-string=? "a" "a "))) + + ;;; find-labelled-window : (union ((union #f string) -> window<%>) + ;;; ((union #f string) (union #f class) -> window<%>) + ;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) + ;;;; may call error, if no control with the label is found + (define (find-labelled-window label + [class #f] + [window (get-top-level-focus-window)] + [failure (λ () + (error 'find-labelled-window "no window labelled ~e in ~e~a" + label + window + (if class + (format " matching class ~e" class) + "")))]) + (define windows (find-labelled-windows label class window)) + (cond + [(null? windows) (failure)] + [else (car windows)])) + + (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)]) + (unless (or (not label) + (string? label)) + (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e" + label class window)) + (unless (or (class? class) + (not class)) + (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e" + class label window)) + (unless (is-a? window area-container<%>) + (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e" + window label class)) + (let loop ([window window]) + (cond + [(and (or (not class) + (is-a? window class)) + (let ([win-label (and (is-a? window window<%>) + (send window get-label))]) + (equal? label win-label))) + (list window)] + [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))] + [else '()]))) + + diff --git a/htdp-drracket-test/tests/htdp-lang/private/module-lang-test-utils.rkt b/htdp-drracket-test/tests/htdp-lang/private/module-lang-test-utils.rkt new file mode 100644 index 00000000..185ef92d --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/private/module-lang-test-utils.rkt @@ -0,0 +1,282 @@ +;; From: drracket/drracket-test/tests/drracket/private/module-lang-test-utils.rkt +;; Original author: Robby +#lang racket/base +(require "drracket-test-util.rkt" + framework + drracket/private/stack-checkpoint + racket/string + (for-syntax racket/base) + racket/class) + +(provide test t rx run-test + (struct-out test-struct) + in-here in-here/path write-test-modules) + +;; utilities to use with scribble/reader +(define t string-append) +(define (rx . strs) + (regexp (regexp-replace* #rx" *\n *" (string-append* strs) ".*"))) + +(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) + 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 + #: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))) + +(define tests '()) +(define-syntax (test stx) + (syntax-case stx () + [(_ args ...) + (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)] + #: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? + before-exec + after-test + wait-for-drs? + extra-assert + line) + tests))) + +(define temp-files '()) +(define init-temp-files void) + +(define (write-test-modules* name code) + (set! init-temp-files + (let ([old init-temp-files]) + (λ () + (let ([file (build-path (find-system-path 'temp-dir) (format "~a.rkt" name))]) + (set! temp-files (cons file temp-files)) + (with-output-to-file file #:exists 'truncate + (lambda () (printf "~s\n" code)))) + (old))))) + +(define-syntax write-test-modules + (syntax-rules (module) + [(_ (module name lang x ...) ...) + (begin (write-test-modules* 'name '(module name lang x ...)) ...)])) + +(define (single-test test) + (let/ec k + (clear-definitions drs) + (let loop ([to-handle (test-definitions test)]) + (cond + [(list? to-handle) + (for-each loop to-handle)] + [(string? to-handle) + (insert-in-definitions drs to-handle)] + [(equal? to-handle 'xml-box) + (test:menu-select "Insert" "Insert XML Box") + (for ([c (in-string "x")]) + (test:keystroke c)) + (queue-callback/res + (λ () + (send definitions-text set-caret-owner #f)))] + [else + (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)) + + (define output-start-paragraph 2) + + (when ints + (let ([after-execute-output + (queue-callback/res + (λ () + (send interactions-text + get-text + (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position 2))))]) + (unless (or (test-all? test) (string=? "> " after-execute-output)) + (eprintf (string-append + "FAILED (line ~a): ~a\n" + " ~a\n" + " expected no output after execution, got: ~s\n") + (test-line test) + (test-definitions test) + (or (test-interactions test) 'no-interactions) + after-execute-output) + (k (void))) + (insert-in-interactions drs ints) + ;; set to be the paragraph right after the insertion. + (set! output-start-paragraph + (queue-callback/res + (λ () (+ (send interactions-text position-paragraph + (send interactions-text last-position)) + 1)))) + (test:keystroke #\return '(alt)) + (wait-for-computation drs))) + + (define text + (queue-callback/res + (λ () + (define para-before-prompt + (- (send interactions-text position-paragraph + (send interactions-text last-position)) + 1)) + (if (test-all? test) + (send interactions-text + get-text + (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position para-before-prompt)) + (send interactions-text + get-text + (send interactions-text paragraph-start-position output-start-paragraph) + (send interactions-text paragraph-end-position para-before-prompt)))))) + (define stacks + (queue-callback/res + (λ () + (let loop ([snip (send interactions-text find-first-snip)]) + (cond + [(not snip) '()] + [else + (cond + [(method-in-interface? 'get-stacks (object-interface snip)) + (define-values (s1 s2) (send snip get-stacks)) + (list* s1 s2 (loop (send snip next)))] + [else + (loop (send snip next))])]))))) + (define output-passed? + (let ([r (test-result test)]) + ((cond [(string? r) string=?] + [(regexp? r) regexp-match?] + [else 'module-lang-test "bad test value: ~e" r]) + r text))) + (unless output-passed? + (eprintf "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n" + (test-line test) + (test-definitions test) + (or (test-interactions test) 'no-interactions) + (test-result test) + text) + (unless (null? stacks) + (eprintf "stacks from error message:\n") + (for ([stack (in-list stacks)]) + (when stack + (eprintf "\n----\n") + (unless (empty-viewable-stack? stack) + (define stack-iterator (copy-viewable-stack stack)) + (let loop () + (define-values (list-of-srcloc-count has-next?) + (viewable-stack-get-next-items! stack-iterator)) + (for ([srcloc-count (in-list list-of-srcloc-count)]) + (define frame (srcloc->string (car srcloc-count))) + (define count (+ 1 (cdr srcloc-count))) + (if (> count 1) + (eprintf " ~a [repeated ~a times]\n" frame count) + (eprintf " ~a\n" frame))) + (when has-next? + (loop)))) + (eprintf "----\n"))))) + (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))) + ((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 (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))) + +(define (run-test) + (retrieve-drracket-frames!) + (init-temp-files) + (run-use-compiled-file-paths-tests) + (set-module-language! #f) + (test:set-radio-box-item! #rx"Debugging") + (let ([f (queue-callback/res (λ () (test:get-active-top-level-window)))]) + (test:button-push "OK") + (wait-for-new-frame f)) + (for-each single-test (reverse tests)) + (clear-definitions drs) + (queue-callback/res (λ () (send (send drs get-definitions-text) set-modified #f))) + (for ([file temp-files]) + (when (file-exists? file) + (delete-file file)))) + +(define (run-use-compiled-file-paths-tests) + (define (setup-dialog/run proc) + (set-module-language! #f) + (proc) + (let ([f (test:get-active-top-level-window)]) + (test:button-push "OK") + (wait-for-new-frame f)) + (do-execute drs) + (fetch-output drs)) + + (define (run-one-test radio-box expected [no-check-expected #f]) + (let ([got (setup-dialog/run (λ () (test:set-radio-box-item! radio-box)))]) + (unless (spaces-equal? got (format "~s" expected)) + (error 'r-u-c-f-p-t "test failed\n got: ~s\n expected: ~s\n radio-box: ~s" + got + (format "~s" expected) + radio-box))) + + (when no-check-expected + (define got + (setup-dialog/run + (λ () + (test:set-radio-box-item! radio-box) + (test:set-check-box! #rx"Populate “compiled” directories" #f)))) + (unless (spaces-equal? got (format "~s" no-check-expected)) + (error 'r-u-c-f-p-t.2 "test-failed\n got: ~s\n expected: ~s\n radio-box: ~s" + got + (format "~s" no-check-expected) + radio-box)))) + + (define (spaces-equal? a b) + (equal? (regexp-replace* #rx"[\n\t ]+" a " ") + (regexp-replace* #rx"[\n\t ]+" b " "))) + + (define compiled-dir (let ([l (use-compiled-file-paths)]) + (if (null? l) + "compiled" + (car l)))) + + (define drs/compiled/et (build-path compiled-dir "drracket" "errortrace")) + (define drs/compiled (build-path compiled-dir "drracket")) + (define compiled (build-path compiled-dir)) + + (clear-definitions drs) + (insert-in-definitions drs "#lang scheme\n(use-compiled-file-paths)") + (run-one-test #rx"No debugging or profiling" (list drs/compiled compiled) (list compiled)) + (run-one-test #rx"^Debugging [(]" (list drs/compiled/et compiled) (list compiled)) + (run-one-test #rx"Debugging and profiling" (list compiled)) + (run-one-test #rx"Syntactic test suite coverage" (list compiled))) diff --git a/htdp-drracket-test/tests/htdp-lang/private/no-fw-test-util.rkt b/htdp-drracket-test/tests/htdp-lang/private/no-fw-test-util.rkt new file mode 100644 index 00000000..ad401c2d --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/private/no-fw-test-util.rkt @@ -0,0 +1,155 @@ +;; From: drracket/drracket-test/tests/drracket/private/no-fw-test-util.rkt +;; Original author: Robby +#lang racket/base +(require racket/gui/base + racket/class) + +(provide use-hash-for-prefs + fire-up-separate-drracket-and-run-tests + queue-callback/res + not-on-eventspace-handler-thread + on-eventspace-handler-thread + poll-until + wait-for-events-in-frame-eventspace) + +;; fire-up-separate-drracket-and-run-tests : (-> any) -> any +;; creates a separate custodian, eventspace, namespace, etc to +;; start up a new DrRacket. This has the advantage over fire-up-drracket-and-run-tests +;; that a single test suite can start up DrRacket multiple times, but it has the +;; disadvantage that there is little sharing between the test suite implementation code and +;; DrRacket, so writing the testing code is more painful +;; +;; the only things shared are mred/mred (and its dependencies). +(define (fire-up-separate-drracket-and-run-tests run-test) + (define c (make-custodian)) + (define s (make-semaphore 0)) + (define orig-ns (current-namespace)) + (parameterize ([current-custodian c]) + (parameterize ([exit-handler (λ (v) + (semaphore-post s) + (custodian-shutdown-all c))] + [current-namespace (make-empty-namespace)] + [current-command-line-arguments #()]) + (parameterize ([current-eventspace (make-eventspace)]) + (namespace-attach-module orig-ns 'mred/mred) + + (let ([s (make-semaphore)]) + (queue-callback + (λ () + (use-hash-for-prefs + (dynamic-require 'framework/preferences 'preferences:low-level-get-preference) + (dynamic-require 'framework/preferences 'preferences:low-level-put-preferences) + (dynamic-require 'framework/preferences 'preferences:restore-defaults) + (dynamic-require 'framework/preferences 'preferences:set) + (dynamic-require 'framework/preferences 'preferences:default-set?) + '()) + (semaphore-post s))) + (semaphore-wait s)) + + ;; do this now so that dynamically requiring framework + ;; exports during the call to 'run-test' is safe + (namespace-require 'framework) + + (queue-callback + (λ () + (dynamic-require 'drracket #f) + (thread (λ () + (run-test) + (exit))) + (yield (make-semaphore 0))))))) + (semaphore-wait s)) + +(define (use-hash-for-prefs preferences:low-level-get-preference + preferences:low-level-put-preferences + preferences:restore-defaults + preferences:set + preferences:default-set? + prefs) + ;; change the preferences system so that it doesn't write to + ;; a file; partly to avoid problems of concurrency in drdr + ;; but also to make the test suite easier for everyone to run. + (define prefs-table (make-hash)) + (preferences:low-level-put-preferences (λ (names vals) + (for ([name (in-list names)] + [val (in-list vals)]) + (hash-set! prefs-table name val)))) + (preferences:low-level-get-preference (λ (name [fail (lambda () #f)]) + (hash-ref prefs-table name fail))) + + ;; set all preferences to their defaults (some pref values may have + ;; been read by this point, but hopefully that won't affect the + ;; startup of drracket) + (preferences:restore-defaults) + + ;; initialize some preferences to simulate these + ;; being saved already in the user's prefs file + ;; call preferences:set too since the prefs file + ;; may have been "read" already at this point + (for ([pref (in-list prefs)]) + (define pref-key (list-ref pref 0)) + (define pref-val (list-ref pref 1)) + (define m (regexp-match #rx"^plt:framework-pref:(.*)$" (symbol->string pref-key))) + (cond + [m + (hash-set! prefs-table pref-key pref-val) + (define fw-pref-key (string->symbol (list-ref m 1))) + (when (preferences:default-set? fw-pref-key) + (preferences:set fw-pref-key pref-val))] + [else + ;; this currently doesn't happen, and it is easy to forget + ;; that prefix, so print a message here to remind + (printf "WARNING: setting a preference that isn't set via the framework: ~s\n" pref-key)]))) + +(define (queue-callback/res thunk) + (not-on-eventspace-handler-thread + 'queue-callback/res + #:more (λ () (format "\n thunk: ~e" thunk))) + (define c (make-channel)) + (queue-callback (λ () + (channel-put c + (with-handlers ([exn:fail? values]) + (call-with-values thunk list)))) + #f) + (define res (channel-get c)) + (when (exn? res) + (raise res)) + (apply values res)) + +;; poll-until : (-> alpha) number (-> alpha) -> alpha +;; 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 + pred + [secs 10] + [fail + (lambda () + (error 'poll-until "timeout after ~e secs, ~e never returned a true value" secs pred))]) + (define step 1/20) + (let loop ([counter secs]) + (if (<= counter 0) + (fail) + (let ([result (pred)]) + (or result + (begin + (sleep step) + (loop (- counter step)))))))) + +(define (wait-for-events-in-frame-eventspace fr) + (define sema (make-semaphore 0)) + (parameterize ([current-eventspace (send fr get-eventspace)]) + (queue-callback + (λ () (semaphore-post sema)) + #f)) + (semaphore-wait sema)) + + +(define (not-on-eventspace-handler-thread fn #:more [more #f]) + (when (eq? (current-thread) (eventspace-handler-thread (current-eventspace))) + (error fn + (string-append + "expected to be run on some thread other than the eventspace handler thread" + (if more (more) ""))))) + +(define (on-eventspace-handler-thread fn) + (unless (eq? (current-thread) (eventspace-handler-thread (current-eventspace))) + (error fn "expected to be run on the eventspace handler thread"))) diff --git a/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt b/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt new file mode 100644 index 00000000..d90b9b4d --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt @@ -0,0 +1,563 @@ +;; From: drracket/drracket-test/tests/drracket/test-engine-test.rkt +;; At: e94a69c80ae82954ec9ce6ebdec784a99f2b9b98 +;; Original author: Mike Sperber +#lang racket + +(require "private/drracket-test-util.rkt" + "private/gui.rkt" + mred + framework + (prefix-in fw: framework)) + +(define language (make-parameter "<>")) + +;; set-language : boolean -> void +(define (set-language close-dialog?) + (set-language-level! (language) close-dialog?)) + +(define (common-test-engine dmda?) + (test-expression "(check-expect 1 1)" + "The test passed!" + #:repl-expected "Both tests passed!") + + (test-expression "(check-within 1 1.1 0.5)" + "The test passed!" + #:repl-expected "Both tests passed!") + + (test-expression "(check-expect 1 2)" + "" + #:check-failures-expected + (list (make-check-expect-failure "1" "2" 1 0)) + #:repl-check-failures-expected + (list (make-check-expect-failure "1" "2" 3 2))) + + ; number snips + (test-expression "(check-within 1/3 5/3 1/2)" + "" + #:check-failures-expected + (list (make-check-within-failure "0.3" "0.5" "1.6" 1 0)) + #:repl-check-failures-expected + (list (make-check-within-failure "0.3" "0.5" "1.6" 3 2))) + + (define image-markup-test + (string-append + "(require 2htdp/image)\n" + "(check-expect" + " (circle 20 \"solid\" \"red\")" + " (circle 10 \"outline\" \"blue\"))")) + (test-expression image-markup-test + "" + ;; If image snips are in the output of test failure + ;; messages, they will be replaced by "." when extracting + ;; texts from the editor. + #:check-failures-expected + (list (make-check-expect-failure "." "." 2 0)) + #:repl-check-failures-expected + (list (make-check-expect-failure "." "." 4 0))) + + (unless dmda? + (test-expression (format "~s" '(check-error (first 212) "first: expects a non-empty list; given: 212")) + "The test passed!" + #:repl-expected "Both tests passed!")) + + (unless dmda? + (test-expression "(check-expect (car 0) 2)" + "" + #:check-failures-expected + (list (make-check-expect-error "2." ":: car: expects a pair, given 0" 1 0 1 14)) + #:repl-check-failures-expected + (list (make-check-expect-error "2." ":: car: expects a pair, given 0" 3 2 3 16))))) + +(define (common-signatures-*sl) + (test-expression "(: foo Integer) (define foo 5)" + "" + #:repl-expected "foo: this name was defined previously and cannot be re-defined") + (test-expression "(: foo Integer) (define foo \"bar\")" + "" + #:repl-expected "foo: this name was defined previously and cannot be re-defined" + #:signature-violations-expected + (list (make-signature-violation "\"bar\" at line 1, column 28" 1 7))) + (test-expression "(: foo (Integer -> Integer)) (define (foo x) x) (foo \"foo\")" + "\"foo\"" + #:repl-expected "foo: this name was defined previously and cannot be re-defined\n" + #:signature-violations-expected + (list (make-signature-violation "\"foo\" at line 1, column 48" 1 8)) + #:repl-signature-violations-expected + (list)) + (test-expression "(: foo (Integer -> Integer)) (define foo (lambda (x) x))" + "" + #:repl-expression "(foo \"foo\")" + #:repl-expected "\"foo\"" + #:repl-signature-violations-expected + (list (make-signature-violation "\"foo\" at line 3, column 2" 1 8)))) + +(define (common-signatures-sdp) + (test-expression "(: foo integer) (define foo 5)" + "" + #:repl-expected "define: Zweite Definition für denselben Namen") + (test-expression "(: foo integer) (define foo \"bar\")" + "" + #:repl-expected "define: Zweite Definition für denselben Namen" + #:signature-violations-expected + (list (make-signature-violation "\"bar\" at line 1, column 28" 1 7))) + (test-expression "(: foo (integer -> integer)) (define foo (lambda (x) x)) (foo \"foo\")" + "\"foo\"" + #:repl-expected "define: Zweite Definition für denselben Namen" + #:signature-violations-expected + (list (make-signature-violation "\"foo\" at line 1, column 57" 1 8)) + #:repl-signature-violations-expected + (list)) + (test-expression "(: foo (integer -> integer)) (define foo (lambda (x) x))" + "" + #:repl-expression "(foo \"foo\")" + #:repl-expected "\"foo\"" + #:repl-signature-violations-expected + (list (make-signature-violation "\"foo\" at line 3, column 2" 1 8)))) + + + +; +; ;;; ;; +; ;; ;; +; ;; +; ;;;;; ;;;; ;;;;;;;;; ;;; ;; ;;; ;; ;;;; ;;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;;;;;; ;; +; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ; ;;;;; ;; ;; ;; ;; ;; ;; ; ;; +; ;;;;; ;;;; ;;;;;;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; +; ;; ;; +; ;; ;; +; ;;;;; + +(define (beginner) + (parameterize ([language (list #rx"Beginning Student(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #f))) + + +; +; ;;; ;;; ;;; +; ;; ; ;; ;; +; ;; ; ;; ;; +; ;;;;; ;;;; ;;;;;; ; ;;;; ;;;;; ;;;;; ;;; ;; ;;;; ;;; ;;; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ; +; ;; ;; ;;;;;; ;;;; ; ;;;;; ;; ;; ;; ;; ;; ;;;;;; ;;; +; ;; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;;; +; ;; ;; ;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ; ;;; +; ;;;;; ;;;; ;;;;;; ; ;;;;;; ;;;;; ;;;;; ;;;; ;;;; ; +; ;; ;;; +; ;; ;;; +; ;;;;; + + +(define (beginner/abbrev) + (parameterize ([language (list #rx"Beginning Student with List Abbreviations(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #f))) + + +; +; ;; ;;; ;; +; ;; ;; ;; ;; ;; +; ;; ;; ;; +; ;;; ;;; ;; ;;;;; ;;;; ;;; ;; ;;; ;; ;; ;;;; ;;;;; ;;; ;;;; ;;;;; ;;;; +; ;; ;;; ;; ;; ;; ;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;;;; ;; ;;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ; +; ;;;; ;;;; ;;; ;;; ;;;; ;;;; ;;;; ;;; ;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;; ;;;; +; +; +; + + +(define (intermediate) + (parameterize ([language (list #rx"Intermediate Student(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #f))) + +; +; +; +; ;; ; ;;;;;; ;;;; ;;;; +; ;; ;; ;;;;;; ;;;; ;;;; +; ;;;; ;;; ;;;;; ;;;;;; ;;;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;; ;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; +; ;; +; +; + + +(define (intermediate/lambda) + (parameterize ([language (list #rx"Intermediate Student with lambda(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #f))) + + +; +; +; +; ;;;; ;;;; +; ;;;; ;;;; +; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;; ;;; ;;;;; ;;; ;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;; ;;; ;;;;;;;; ;;;;;;;;; ;;;;;; ;;;;; ;;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;;;;;; +; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; +; ;; ;;;; ;;;;;;;;; ;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;;;;;; +; ;; ;;;; ;;;;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;; +; +; +; + + +(define (advanced) + (parameterize ([language (list #rx"Advanced Student(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #f) + (common-signatures-*sl))) + + +(define (sdp-beginner) + (parameterize ([language (list #rx"Schreibe Dein Programm! - Anfänger(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #t) + (common-signatures-sdp))) + +(define (sdp-vanilla) + (parameterize ([language (list #rx"Schreibe Dein Programm!(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #t) + (common-signatures-sdp))) + +(define (sdp-advanced) + (parameterize ([language (list #rx"Schreibe Dein Programm! - fortgeschritten(;|$)")]) + (prepare-for-test-expression) + (common-test-engine #t) + (common-signatures-sdp))) + +(define (prepare-for-test-expression) + (let ([drs (wait-for-drracket-frame)]) + (clear-definitions drs) + (set-language #t) + (sleep 1) ;; this shouldn't be neccessary.... + (do-execute drs))) + +;; test-setting : (-> void) string string string -> void +;; opens the language dialog, runs `set-setting' +;; closes the language dialog, executes, +;; makes sure that `expression' produces +;; `result'. `set-setting' is expected to click around +;; in the language dialog. +;; `setting-name' is used in the error message when the test fails. +(define (test-setting set-setting setting-name expression result) + (set-language #f) + (set-setting) + (let ([f (test:get-active-top-level-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)) + (let* ([drs (test:get-active-top-level-window)] + [interactions (send drs get-interactions-text)]) + (clear-definitions drs) + (insert-in-definitions drs expression) + (do-execute drs) + (let ([got (fetch-output/should-be-tested drs)]) + (unless (string=? result got) + (eprintf "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n" + (language) setting-name expression result got))))) + +(define (fetch-output/should-be-tested . args) + (regexp-replace (regexp + (string-append + (regexp-quote "") + "$")) + (apply fetch-output args) + "")) + +(define re:out-of-sync + (regexp + "WARNING: Interactions window is out of sync with the definitions window\\.")) + +(define (parse-number txt) + (cond + ((not txt) 0) + ((string=? txt "No") 0) + ((string=? txt "One") 1) + ((string=? txt "Two") 2) + (else (string->number txt)))) + +(define (parse-test-failure-header txt) + (cond + ((regexp-match #rx"^Ran ([NoOneTwo0-9]+) tests?.\n([NoOneTwo0-9]+) tests? passed.\n(([NoOneTwo0-9]+) signature violations?.)?" + txt) + => (lambda (match) + (let-values (((_ test-count-text test-passed-count-text __ signature-violations-count-text) + (apply values match))) + (values (parse-number test-count-text) + (parse-number test-passed-count-text) + (parse-number signature-violations-count-text))))) + ((regexp-match #rx"^This program must be tested!\n(([NoOneTwo0-9]+) signature violations?.)?" txt) + => (lambda (match) + (values 0 0 (parse-number (caddr match))))) + (else + (error 'parse-test-failure-header "bad test failure header" txt)))) + +(define (parse-test-failures txt) + (let-values (((test-count test-passed-count signature-violations-count) + (parse-test-failure-header txt))) + (let ((check-failures + (cond + ((regexp-match #rx"Check failures:\n(.*)" txt) + => (lambda (res) + (parse-check-failures (cadr res)))) + (else '()))) + (signature-violations + (cond + ((regexp-match #rx"Signature violations:\n(.*)" txt) + => (lambda (res) + (parse-signature-violations (cadr res)))) + (else '())))) + (values test-count test-passed-count signature-violations-count + check-failures + signature-violations)))) + +(define-struct check-expect-failure + (actual expected line column) + #:transparent) + +(define-struct check-within-failure + (actual within expected line column) + #:transparent) + +(define-struct check-expect-error + (value message line column expr-line expr-column) + #:transparent) + +(define (parse-check-failures txt) + (cond + ((string=? txt "") '()) + ((regexp-match #rx"^Signature violations:" txt) + '()) + ((regexp-match #rx"^[ \t]*\n(.*)" txt) + => (lambda (match) + (parse-check-failures (cadr match)))) + ((regexp-match #rx"^[ \t]+Actual value ([^\n]+) differs from ([^\n]+), the expected value.\nat line ([0-9]+), column ([0-9]+)(.*)" + txt) + => (lambda (match) + (let-values (((_ actual expected line-text col-text rest) (apply values match))) + (cons + (make-check-expect-failure actual expected + (string->number line-text) + (string->number col-text)) + (parse-check-failures rest))))) + ((regexp-match #rx"^[ \t]+check-expect encountered the following error instead of the expected value, ([^\n]*). *\n[ \t]*([^\n]*)\n[^\n]*line ([0-9]+), column ([0-9]+)[^\n]*line ([0-9]+), column ([0-9]+)(.*)" + txt) + => (lambda (match) + (define-values (_ value message line-text col-text line-expr col-expr rest) (apply values match)) + (cons + (make-check-expect-error value + message + (string->number line-text) + (string->number col-text) + (string->number line-expr) + (string->number col-expr)) + (parse-check-failures rest)))) + ((regexp-match #rx"^[ \t]+Actual value ([^\n]+) is not within ([^\n]+) of expected value ([^\n]+).\nat line ([0-9]+), column ([0-9]+)(.*)" + txt) + => (lambda (match) + (define-values (_ actual within expected line-text col-text rest) (apply values match)) + (cons + (make-check-within-failure actual within expected + (string->number line-text) + (string->number col-text)) + (parse-check-failures rest)))) + (else + (error "unknown check failure" txt (string-ref txt 0))))) + +(define-struct signature-violation + (got line column) + #:transparent) + +(define (parse-signature-violations txt) + (cond + ((string=? txt "") '()) + ((regexp-match #rx"^[ \t]*\n(.*)" txt) + => (lambda (match) + (parse-signature-violations (cadr match)))) + ((regexp-match "got ([^\n]+), signature at line ([0-9]+), column ([0-9]+)(.*)" + txt) + => (lambda (match) + (let-values (((_ got line-text col-text rest) (apply values match))) + (cons + (make-signature-violation got + (string->number line-text) + (string->number col-text)) + (parse-signature-violations rest))))) + (else '()))) + + +;; types an expression in the definitions window, executes it and tests the output +;; types an expression in the REPL and tests the output from the REPL. +(define (test-expression expression defs-expected + #:repl-expression (repl-expression expression) + #:repl-expected (repl-expected defs-expected) + #:check-failures-expected (check-failures-expected '()) + #:signature-violations-expected (signature-violations-expected '()) + #:repl-check-failures-expected (repl-check-failures-expected '()) + #:repl-signature-violations-expected (repl-signature-violations-expected '())) + (let* ([drs (wait-for-drracket-frame)] + [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))] + [definitions-text (queue-callback/res (λ () (send drs get-definitions-text)))] + [handle-definition-insertion + (lambda (item) + (insert-in-definitions drs item))] + [handle-interaction-insertion + (lambda (item) + (insert-in-interactions drs item))] + [check-expectation + (lambda (expected got) + (cond + [(string? expected) + (whitespace-string=? expected got)] + [(regexp? expected) + (regexp-match expected got)] + [(procedure? expected) + (expected got)]))] + [check-failures + (lambda (where signature-violations-expected check-failures-expected) + (let ((text + (cond + ((send (send definitions-text get-tab) get-test-editor) + => (lambda (test-editor) + (let ((text (send test-editor get-text 0 'eof #t))) + (if (string=? text "") + #f + text)))) + (else #f)))) + + (cond + ((and (null? signature-violations-expected) + (null? check-failures-expected)) + (when text + (eprintf "FAILED: ~s ~s expected ~s to produce no check failures or signature violations:\ngot:\n~a\ninstead\n" + where (language) expression text))) + (text + (let-values (((test-count test-passed-count signature-violation-count check-failures signature-violations) + (parse-test-failures text))) + (when (not (equal? check-failures check-failures-expected)) + (eprintf "FAILED: ~s ~s expected ~s to produce check failures:\n~s\ngot:\n~s\ninstead\n" + where (language) expression check-failures-expected check-failures)) + (when (not (equal? signature-violations signature-violations-expected)) + (eprintf "FAILED: ~s ~s expected ~s to produce signature violations:\n~s\ngot:\n~s\ninstead\n" + where (language) expression signature-violations-expected signature-violations)))) + (else + (eprintf "expected ~a check failures and ~a signature violations but got none" + (length check-failures-expected) (length signature-violations-expected))))))] + + [make-err-msg + (lambda (expected) + (cond + [(string? expected) + "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"] + [(regexp? expected) + "FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"] + [(procedure? expected) + "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))]) + (clear-definitions drs) + (cond + [(pair? expression) (for-each handle-definition-insertion expression)] + [else (handle-definition-insertion expression)]) + (do-execute drs) + + (let ([got + (fetch-output + drs + (queue-callback/res (λ () (send interactions-text paragraph-start-position 2))) + (queue-callback/res + (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))]) + (when (regexp-match re:out-of-sync got) + (error 'test-expression "got out of sync message")) + (unless (check-expectation defs-expected got) + (eprintf (make-err-msg defs-expected) + 'definitions (language) expression defs-expected got))) + + (check-failures 'definitions signature-violations-expected check-failures-expected) + + (cond + [(pair? repl-expression) (for-each handle-interaction-insertion repl-expression)] + [else (handle-interaction-insertion repl-expression)]) + + (let ([last-para (queue-callback/res (lambda () (send interactions-text last-paragraph)))]) + (alt-return-in-interactions drs) + (wait-for-computation drs) + (let ([got + (fetch-output + drs + (queue-callback/res + (λ () + (send interactions-text paragraph-start-position (+ last-para 1)))) + (queue-callback/res + (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))]) + (when (regexp-match re:out-of-sync got) + (error 'test-expression "got out of sync message")) + (unless (check-expectation repl-expected got) + (eprintf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got)))) + + ;; the failures from the definition window stick around + (check-failures 'interactions + (append signature-violations-expected repl-signature-violations-expected) + (append check-failures-expected repl-check-failures-expected)))) + +(define (test-disabling-tests) + (define drs (wait-for-drracket-frame)) + + (parameterize ([language (list #rx"Beginning Student(;|$)")]) + (prepare-for-test-expression) + (test:menu-select "Racket" "Disable Tests") + (test-expression "(check-expect 1 2)" "Tests disabled.") + (test:menu-select "Racket" "Enable Tests")) + + (parameterize ([language (list #rx"Schreibe Dein Programm! - Anfänger(;|$)")]) + (prepare-for-test-expression) + (test:menu-select "Racket" "Disable Tests") + (test-expression "(check-expect 1 2)" "Tests disabled.") + (test:menu-select "Racket" "Enable Tests"))) + +(define-syntax (go stx) + (syntax-case stx () + [(_ arg) + (identifier? (syntax arg)) + (syntax (begin (printf ">> starting ~a\n" 'arg) + (arg) + (printf ">> finished ~a\n" 'arg)))])) + +(define (run-test) + (preferences:set 'test-engine:test-window:docked? #t) + (go beginner) + (go beginner/abbrev) + (go intermediate) + (go intermediate/lambda) + (go advanced) + (go sdp-beginner) + (go sdp-vanilla) + (go sdp-advanced) + (go test-disabling-tests)) + +(fire-up-drracket-and-run-tests run-test) + +(module+ test + (module config info + (define timeout 480)))