From 7f04c359e72112c43c5fedf82e7f7de6cc535f47 Mon Sep 17 00:00:00 2001 From: shhyou Date: Tue, 4 Aug 2026 16:36:38 +0800 Subject: [PATCH 1/6] Initial commit: copy files from drracket-test --- htdp-drracket-test/LICENSE | 10 + htdp-drracket-test/info.rkt | 35 + .../tests/htdp-lang/language-test.rkt | 1982 +++++++++++++++++ .../tests/htdp-lang/module-lang-test.rkt | 1261 +++++++++++ .../htdp-lang/private/drracket-test-util.rkt | 643 ++++++ .../tests/htdp-lang/private/gui.rkt | 114 + .../private/module-lang-test-utils.rkt | 282 +++ .../htdp-lang/private/no-fw-test-util.rkt | 155 ++ 8 files changed, 4482 insertions(+) create mode 100644 htdp-drracket-test/LICENSE create mode 100644 htdp-drracket-test/info.rkt create mode 100644 htdp-drracket-test/tests/htdp-lang/language-test.rkt create mode 100644 htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt create mode 100644 htdp-drracket-test/tests/htdp-lang/private/drracket-test-util.rkt create mode 100644 htdp-drracket-test/tests/htdp-lang/private/gui.rkt create mode 100644 htdp-drracket-test/tests/htdp-lang/private/module-lang-test-utils.rkt create mode 100644 htdp-drracket-test/tests/htdp-lang/private/no-fw-test-util.rkt 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..e36078a3 --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/language-test.rkt @@ -0,0 +1,1982 @@ +;; From: drracket/drracket-test/tests/drracket/language-test.rkt +;; 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 (module-lang) + (parameterize ([language '(module "racket")] + [defs-prefix "#lang racket\n"]) + + (check-top-of-repl) + + (generic-output #t #t #t #t #t #t) + + (test-setting + (lambda () (fw:test:set-check-box! #rx"Enforce constant definitions" #f)) + "enforce-module-constants -- #f" + "#lang racket/base\n(define x 1)\n" + #:interactions "(set! x 2)" + "> (set! x 2)") + (test-setting + (lambda () (fw:test:set-check-box! #rx"Enforce constant definitions" #t)) + "enforce-module-constants -- #t" + "#lang racket/base\n(define x 1)\n" + #:interactions "(set! x 2)" + #rx"cannot modify a constant") + + (prepare-for-test-expression) + + (test-expression + (format "~s" + `(let () + (define (enum-write-proc enum port mode) + (define recur + (case mode + [(#t) write] + [(#f) display] + [else (lambda (p port) (print p port mode))])) + (display "#" port)) + + (struct enum (val) + #:methods gen:custom-write + [(define write-proc enum-write-proc)]) + + (enum 1))) + "#") + + (test-expression "(print 'hello (current-output-port) 1)" "hello") + (test-expression "(print 'hello (current-output-port) 0)" "'hello") + (test-expression "(print '((x)) (current-output-port) 0)" "'((x))") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}") + + (test-expression "'|.|" "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#t") + (test-expression "(define x 1)(define x 2)" #rx"identifier already defined in: x" "") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "#" + #rx"define-values: assignment disallowed.*struct:spider") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" (regexp "class: bad syntax in: class")) + (test-expression "shared" (regexp "shared: bad syntax in: shared")) + + (test-expression "(define (. x y) (* x y))" #rx"read-syntax: illegal use of `\\.`" "") + (test-expression "'(1 . 2)" "'(1 . 2)") + + (test-expression "(define (f define) 1)" "" #rx"define-values: assignment disallowed.*: f") + (test-expression "(define (f car) 1)" "" #rx"define-values: assignment disallowed.*: f") + (test-expression "(define (f empty) 1)" "" #rx"define-values: assignment disallowed.*: f") + + (test-expression "call/cc" "#") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" "#t") + (test-expression "mred^" + #rx"unbound identifier in: mred\\^" + #rx"mred\\^.*cannot reference an identifier before its definition") + (test-expression "(eq? 'a 'A)" "#f") + (test-expression "(set! x 1)" + #rx"set!: unbound identifier in: x" + #rx"set!:.*cannot set variable before its definition.*: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "'(1 . 2)") + (test-expression "(+ (list 1) 2)" #rx"[+]: contract violation.*given: '[(]1[)]") + (test-expression "'(1)" "'(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "'(#&1 #&1)" + #rx"define-values: assignment disallowed.*: shrd") + (test-expression "(local ((define x x)) 1)" #rx"x: undefined;\n cannot use before initialization") + (test-expression "(letrec ([x x]) 1)" #rx"x: undefined;\n cannot use before initialization") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + (test-expression "(print (floor (sqrt 2)))" "1.0") + + (test-expression "(let ([f (lambda (x) x)]) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "'(1)") + (test-expression "(car (list))" + #rx"{stop-multi.png} {stop-22x22.png} car: contract violation.*given: '[(][)]") + + (test-expression "(current-command-line-arguments)" "'#()") + (test-expression "(define-syntax app syntax-case)" + "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") + + (test-expression "#lang racket" #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)") + "a: b") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}") + + (test-expression "(syntax-source #'x)" + #rx"'[0-9]+-unsaved-editor" + #rx"'|[0-9]+-interactions from an unsaved editor|"))) + + +; +; +; +; ; ; ;;;; ;; +; ;; ;; ;;;; ;; +; ;;;;;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;;;; +; ;;;;;;;; ;;;;;;; ;;;;; ;;;;;; ;;;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;;;;;; +; ;;;;;;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;;;;; ;;;;;;;;; ;;;; ;;; ;;;; +; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; +; ;;;;;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;; ;;;;;;;;; ;;;; ;;;;;;; +; ;;;;;;;; ;;;; ;;;;;; ;;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ; ;;;; +; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;;; +; ;;;; ;;;; ;;;;;;;; +; ;;;; ;;;; ;;;;;; +; + +(define (pretty-big) + (parameterize ([language (list #rx"Pretty Big")]) + + (check-top-of-repl) + + (generic-settings #f) + (generic-output #t #f #t #t #f #f) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "(print '((x)))" "((x))") + + (test-expression "'|.|" "|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#t") + (test-expression "(define x 1)(define x 2)" "") + + (test-expression "(define-struct spider (legs))(make-spider 4)" "#") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" (regexp "class: bad syntax in: class")) + (test-expression "shared" (regexp "shared: bad syntax in: shared")) + + (test-expression "(define (. x y) (* x y))" #rx"read-syntax: illegal use of `\\.`") + (test-expression "'(1 . 2)" "(1 . 2)") + + (test-expression "(define (f define) 1)" "") + (test-expression "(define (f car) 1)" "") + (test-expression "(define (f empty) 1)" "") + + (test-expression "call/cc" "#") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" "#t") + (test-expression + "mred^" + #rx"{stop-multi.png} {stop-22x22.png} mred\\^.*cannot reference an identifier before its definition") + (test-expression "(eq? 'a 'A)" "#f") + (test-expression "(set! x 1)" + #rx"{stop-multi.png} {stop-22x22.png} set!:.*cannot set variable before its definition.*: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "(+ (list 1) 2)" + #rx"{stop-multi.png} {stop-22x22.png} [+]: contract violation.*given: [(]1[)]") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" #rx"x: undefined;\n cannot use before initialization") + (test-expression "(letrec ([x x]) 1)" #rx"x: undefined;\n cannot use before initialization") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + (test-expression "(print (floor (sqrt 2)))" "1.0") + + (test-expression "(let ([f (lambda (x) x)]) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "(1)") + (test-expression "(car (list))" + #rx"{stop-multi.png} {stop-22x22.png} car: contract violation.*given: [(][)]") + + (test-expression "(current-command-line-arguments)" "#()") + (test-expression "(define-syntax app syntax-case)" + "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") + + (test-expression "#lang racket" + "" + #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)") + "a: b") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + "{image}" + "{image}"))) + +; +; +; ;;;;;;; ;;;;;;; ;;;;;; +; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;;;;; ;; ;; ;;;; +; ;;;;;; ; ;;;;;; ;;;;; +; ;; ;; ;;;; ;; ;; ;;; +; ;; ;; ;; ;; ;; ; ;; +; ;; ;; ;; ;; ;; ;; ;; +; ;;;; ;;; ;; ;; ;;;; ;;;;;;;;; +; ;; ;; +; ;;;; +; + + +(define (r5rs) + (parameterize ([language (list (regexp "R5RS"))]) + + (check-top-of-repl) + + (generic-settings #f) + (generic-output #t #f #t #f #f #f) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" "|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#t") + (test-expression "(define x 1)(define x 2)" "") + + (test-expression + "(define-struct spider (legs))(make-spider 4)" + #rx"{stop-multi.png} {stop-22x22.png} define-struct:.*cannot reference an identifier before its definition") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression + "class" + #rx"{stop-multi.png} {stop-22x22.png} class:.*cannot reference an identifier before its definition") + (test-expression + "shared" + #rx"{stop-multi.png} {stop-22x22.png} shared:.*cannot reference an identifier before its definition") + + (test-expression "(define (. x y) (* x y))" #rx"read-syntax: illegal use of `\\.`") + (test-expression "'(1 . 2)" "(1 . 2)") + + (test-expression "(define (f define) 1)" "") + (test-expression "(define (f car) 1)" "") + (test-expression "(define (f empty) 1)" "") + + (test-expression + "call/cc" + #rx"{stop-multi.png} {stop-22x22.png} call/cc:.*cannot reference an identifier before its definition") + + (test-expression + "(error 'a \"~a\" 1)" + #rx"{stop-multi.png} {stop-22x22.png} error:.*cannot reference an identifier before its definition") + (test-expression + "(error \"a\" \"a\")" + #rx"{stop-multi.png} {stop-22x22.png} error:.*cannot reference an identifier before its definition") + + (test-expression + "(time 1)" + #rx"{stop-multi.png} {stop-22x22.png} time.*cannot reference an identifier before its definition") + + (test-expression + "true" + #rx"{stop-multi.png} {stop-22x22.png} true.*cannot reference an identifier before its definition") + (test-expression + "mred^" + #rx"{stop-multi.png} {stop-22x22.png} mred\\^.*cannot reference an identifier before its definition") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" + #rx"{stop-multi.png} {stop-22x22.png} set!:.*cannot set variable before its definition.*: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond ((= 1 2) 3))" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "(+ (list 1) 2)" + #rx"{stop-multi.png} {stop-22x22.png} [+]: contract violation.*given: [(]1[)]") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (cons 1 1)) (list shrd shrd)" + "((1 . 1) (1 . 1))") + (test-expression + "(local ((define x x)) 1)" + #rx"define: not allowed in an expression context") + (test-expression "(letrec ((x x)) 1)" #rx"x: undefined;\n cannot use before initialization") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + (test-expression "(print (floor (sqrt 2)))" #rx"print:.*cannot reference an identifier before its definition") + + (test-expression "(let ((f (lambda (x) x))) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "(1)") + (test-expression "(car (list))" + #rx"{stop-multi.png} {stop-22x22.png} mcar: contract violation.*given: [(][)]") + + (test-expression + "argv" + #rx"{stop-multi.png} {stop-22x22.png} argv:.*cannot reference an identifier before its definition") + (test-expression + "(define-syntax app syntax-case)" + "{stop-22x22.png} macro-transformer: only a `syntax-rules' form is allowed in: syntax-case") + + (test-expression + "#lang racket" + #rx"module-begin: not in a module-definition context" + #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"cannot reference an identifier before its definition") + + (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" + #rx"require: undefined" + #rx"require: undefined"))) + + +; +; ;;; ;; +; ;; ;; +; ;; +; ;;;;; ;;;; ;;;;;;;;; ;;; ;; ;;; ;; ;;;; ;;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;;;;;; ;; +; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ; ;;;;; ;; ;; ;; ;; ;; ;; ; ;; +; ;;;;; ;;;; ;;;;;;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; +; ;; ;; +; ;; ;; +; ;;;;; + +(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}"))) + +(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 '()) '()))") + + (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 only test passed!" + "") ;; somewhat dubious -- it should either be a syntax error or work... + (test-expression "(check-expect 1 2)" + #rx"Actual value 1 differs from 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") + + (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 `.`"))) + (test-expression "'(1 . 2)" + (regexp (regexp-quote "read-syntax: illegal use of `.`"))) + + (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) + + (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"))) + (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"))) + (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 `,`"))) + + (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"))) + (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]) + (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))) + + (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) + (go module-lang) + (go pretty-big) + (go r5rs) + (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..2be10b9b --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt @@ -0,0 +1,1261 @@ +;; From: drracket/drracket-test/tests/drracket/module-lang-test.rkt +;; 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 @t{} + #f + @rx{Module Language: There must be a valid module + Try starting your program with + Interactions disabled} + #t) +(test @t{1} + #f + @rx{Module Language: only a module expression is allowed + Interactions disabled} + #t) +(test @t{(module m racket) 1} + #f + @rx{Module Language: there can only be one expression in the definitions + Interactions disabled} + #t) +(test @t{.} + #f + @rx{read-syntax: illegal + Interactions disabled} + #t) +(test @t{#lang mzscheme + (define x 1)} + @t{x} + "1") +(test @t{#lang m-z-scheme + (define x 1)} + #f + @rx{collection not found + Interactions disabled} + #t) +(test @t{#lang racket + 3} + #f + "3") +(test @t{(module m racket (provide x) (define x 1))} + @t{x} + "1") +(test @t{(module m racket (define x 1))} + @t{x} + "1") +(test @t{(module m racket (define x 1) (define y 1) (provide y))} + @t{x} + "1") +(test @t{(module m racket (define x 1) (define y 2) (provide y))} + @t{y} + "2") +(test @t{(module m mzscheme (require mzlib/list))} + @t{foldl} + #rx"foldl") +(test @t{(module m mzscheme (require (rename mzlib/list local-foldl foldl)))} + @t{local-foldl} + #rx"foldl>") +(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))} + @t{first} + #rx"first>") +(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))} + @t{foldl} + #rx"[.] [.] foldl:.*cannot reference an identifier before its definition") +(test @t{(module m mzscheme (require (prefix mz: mzscheme)))} + @t{mz:+} + #rx"procedure:[+]") +(test @t{(module n mzscheme (provide (all-from-except mzscheme +)))} + @t{+} + #rx"procedure:[+]") +(test @t{(module m mzscheme + (require (prefix x: mzlib/list) mzlib/list))} + @t{foldl} + #rx"foldl>") +(test @t{(module m mzscheme + (require (prefix x: mzlib/list) mzlib/list))} + @t{x:foldl} + #rx"foldl>") +(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) x)} + @t{x} + "1") +;; + shouldn't be bound in the REPL because it isn't bound in the module. +(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) x)} + @t{+} + #rx"[.] [.] [+]:.*cannot reference an identifier before its definition") +(test @t{(module m mzscheme (provide lambda))} + @t{(lambda (x) x)} + #rx"namespace module->namespace)) + (define x 2) + (define -current-namespace error) + (define -module->namespace error) + (define-syntax app (syntax-rules () ((app . x) '(app . x)))))} + @t{x} + "2") +(test @t{#lang racket + (eval 'cons)} + #f + @rx{cons: unbound identifier.*no #%top syntax transformer is bound}) +(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) 1 2 3)} + @t{1} ;; just make sure no errors. + "1") + +(test @t{#lang racket} + @t{(begin-for-syntax (+ 1 2))} + @t{}) + +(test @t{#lang racket} + @t{(begin (struct s (x)) (struct t s (y)) (s-x (t 1 2)))} + "1") + +(test @t{#lang racket/base + (read-accept-reader) + (read-accept-compiled)} + #f + @t{#f + #f}) + +;; check that we have a working repl in the right language after +;; syntax errors, unless it's a bad language +(test @t{#lang racket + (define x 1) + (define y (/ 0))} + @t{(+ 122 x)} + @rx{. /: division by zero + 123} + #t) +(test @t{#lang racket + (define x 1) + (define y (/ 0))} + @t{(if x 123)} + @rx{/: division by zero.*if: missing an "else"} + #t) +(test @t{#lang mzscheme + (define x 1) + (define y (/ 0))} + @t{(if x 123)} + @rx{. /: division by zero + 123} + #t) +(test @t{(module xx scheme/list + (define x 1) + (define y (/ 0)))} + #f + @rx{no #%module-begin binding in the module's language + Interactions disabled: + does not support a REPL \(no #%top-interaction\)} + #t) +(test @t{(module xx (file @in-here{module-lang-test-tmp4.rkt}) + (define x 1) + (* x 123))} + #f + @rx{444 + 123 + Interactions disabled: + does not support a REPL \(no #%top-interaction\) + } + #t) +(test @t{(module xx (file @in-here{this-file-does-not-exist}) + (define x 1) + (* x 123))} + #f + @rx{cannot open module file + Module Language: invalid language specification + Interactions disabled} + #t) +(test @t{#lang info} + #f + ;; test the complete buffer, to make sure that there is no error + ;; would be better if this said "lang" and not "setup/infotab" but + ;; leave it like this for now. + "\nInteractions disabled: setup/infotab does not support a REPL (no #%top-interaction)" + #t) + +;; test racket/load behavior +(test @t{#lang racket/load + (module m mzscheme (provide x) (define x 2)) + (require 'm) + (printf "~s\n" x) + (flush-output)} + #f + "2") +(test @t{#lang racket/load + (module m mzscheme (provide x) (define x 2)) + (module n racket/base (require 'm) (provide y) (define y (* x x))) + (require 'n) + (printf "~s\n" y) + (flush-output)} + #f + "4") + +(test @t{#lang racket + (define-syntax (f stx) + (syntax-case stx () + [(f) + (raise (make-exn:fail:syntax "both" (current-continuation-marks) (list #'f stx)))]))} + @t{(f)} + (string-append "> (f)\n" + ". both in:\n" + " f\n" + " (f)") + #t) + +(test @t{#lang racket/base} + @t{(begin (values) 1)} + "1") + +(test @t{#lang racket/base} + @t{ (eval '(values 1 2))} + @t{1@"\n"2}) +(test @t{#lang racket/base} + @t{ (eval '(list 1 2))} + @t{'(1 2)}) +(test @t{#lang racket/base} + @t{ (eval '(lambda ()))} + @t{lambda: bad syntax in: (lambda ())}) +(test @t{#lang racket/base} + @t{(expt 3 (void))} + @rx{expt: contract violation.*given: #}) +(test @t{#lang racket/base} + @t{1 2 ( 3 4} + #rx"1\n2\n[.][^\n]*read-syntax: expected a `[)]` to close `[(]`") +(test @t{#lang racket/base} + "1 2 . 3 4" + #rx"1\n2\n[.][^\n]*read-syntax: illegal use of `[.]`") +(test @t{#lang racket/base} + "1 2 (lambda ()) 3 4" + "1\n2\n. lambda: bad syntax in: (lambda ())") +(test @t{#lang racket/base} + "1 2 x 3 4" + #rx"1\n2\n[.] [.] x:.*cannot reference an identifier before its definition") +(test @t{#lang racket/base} + "1 2 (raise 1) 3 4" + "1\n2\nuncaught exception: 1") +(test @t{#lang racket/base} + "1 2 (raise #f) 3 4" + "1\n2\nuncaught exception: #f") +(test @t{#lang racket/base} + "(current-namespace (make-empty-namespace)) if" + #rx". #%top-interaction: unbound identifier.*no #%app syntax transformer is bound") +(test @t{#lang racket/base} + (string-append + "(let ([old (error-escape-handler)])\n" + "(+ (let/ec k\n(dynamic-wind\n" + "(lambda () (error-escape-handler (lambda () (k 5))))\n" + "(lambda () (expt 3 #f))\n" + "(lambda () (error-escape-handler old))))\n" + "10))") + #rx"[.] [.] expt: contract violation.*given: #f\n15") +(test @t{#lang racket/base} + "(write (list (syntax x)))" + "(.)") +(test @t{#lang racket/base} + "(parameterize ([current-output-port (open-output-string)]) (write #'1))" + "") +(test @t{#lang racket/base} + "(write-special 1)" + "1#t") +(test @t{#lang racket/gui} + (format "~s ~s ~s" + '(define s (make-semaphore 0)) + '(queue-callback + (lambda () + (dynamic-wind + void + (lambda () (expt 3 #f)) + (lambda () (semaphore-post s))))) + '(begin (yield s) (void))) + #rx"[.] [.] expt: contract violation.*given: #f") +(test @t{#lang racket/base} + (format "~s ~s" + '(define x 1) + '((λ (x y) y) (set! x (call/cc (lambda (x) x))) (x 3))) + #rx". . application:.*given: 3") +(test @t{#lang racket/base} + (format "~s ~s ~s ~s" + '(begin (define k (call/cc (λ (x) x))) + (define x 'wrong)) + '(set! x 'right) + '(k 1) + 'x) + "'right") +(test @t{#lang racket/base} + (format "~s" + '(call-with-continuation-prompt + (lambda () + (eval '(begin (abort-current-continuation + (default-continuation-prompt-tag) + 1 2 3) + 10))) + (default-continuation-prompt-tag) + list)) + "'(1 2 3)") +(test @t{#lang racket/gui} + "(vector (new snip%))" + "(vector .)") +(test @t{#lang racket/base} + "(begin (thread (lambda () x)) (sleep 1/10))" + #rx"[.] [.] x:.*cannot reference an identifier before its definition") +(test @t{#lang racket/base} + "(require texpict/utils)(disk 3)" + ".") +(test @t{#lang racket/base} + (string-append + "(require mzlib/pretty)" + "(pretty-print-print-hook (lambda x (expt 3 #f)))" + "(list 1 2 3)") + "'(1 2 3)") + +;; test protection against user-code changing the namespace +(test @t{#lang racket/base + (current-namespace (make-base-namespace))} + "(+ 1 2)" + "3") +(test @t{#lang racket/base + (current-namespace (make-base-empty-namespace))} + "(+ 1 2)" + "3") +(test @t{#lang racket/base} + @t{(parameterize ([current-directory "/does/not/exists/well/it/better/not/anwyays"]) + (load @in-here{module-lang-test-syn-error.rkt}))} + ;; test to make sure that we don't get "exception raised by error display handler" + #rx"module-lang-test-syn-error.rkt:[0-9]+:[0-9]+: lambda: bad syntax in: \\(lambda\\)") + +(test @t{#lang racket +(module+ main (printf "main\n")) +(module+ test (printf "test\n")) +(module+ other (printf "other\n"))} + #f + #rx"test\nmain") + + +(test @t{#lang racket} + (format "~s" '(+ 1 (+ 1 (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () + (abort-current-continuation + (default-continuation-prompt-tag) + (λ () 0))))))) + "0") + +(test @t{#lang racket} + (format "~s ~s ~s" + '1 + '(+ 1 (+ 1 (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () + (abort-current-continuation + (default-continuation-prompt-tag) + (λ () 0)))))) + '2) + "1\n0") + +(test @t{#lang racket} + (format "~s" + '(begin + 1 + (+ 1 (+ 1 (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () + (abort-current-continuation + (default-continuation-prompt-tag) + (λ () 0)))))) + 2)) + "0") + +(test '("#lang racket\n" xml-box) + #f + @t{'(a () "x")}) + + +(test @t{#lang racket/base + (define os (open-output-string)) + (display "before\n") + (parameterize ([current-output-port os]) + (displayln "not shown") + ((current-print) 'aaa)) + (display "after\n")} + #f + #rx"before\nafter") + +(test @t{#lang racket/base + ((current-print) 1) + ((current-print) 2) + ((current-print) 3)} + #f + "1\n2\n3") +(test @t{#lang racket/base + (define (f n) ((global-port-print-handler) n (current-output-port))) + (f 1) (f 2) (f 3)} + #f + "123") +(test @t{#lang htdp/bsl + 1 2 3} + #f + "1\n2\n3") +(test @t{#lang racket + (require pict) + (define-values (in out) (make-pipe-with-specials)) + (print (colorize (filled-rectangle 4 4) "red") out)} + #f + "") +(test @t{#lang racket + (require pict) + (scale (blank 1 1) -1 1)} + #f + ".") +(test @t{#lang racket + (void "🏴‍☠️") + free-🏴‍☠️-var} + #f + #rx"unbound identifier in: free-🏴‍☠️-var" + #:extra-assert (λ (defs ints) + (equal? + (for/list ([range (send defs get-highlighted-ranges)]) + (list (text:range-start range) (text:range-end range))) + '((27 40))))) +(test @t{ +#lang racket +(struct exn:fail:user-srcloc exn:fail:user (srclocs) + #:property prop:exn:srclocs + (λ (s) (exn:fail:user-srcloc-srclocs s))) + +(define-syntax (m stx) + (syntax-case stx () + [(_ expr) + #`(raise (exn:fail:user-srcloc "srcloc" (current-continuation-marks) + (list + (srcloc '#,(syntax-source #'expr) + '#,(syntax-line #'expr) + '#,(syntax-column #'expr) + '#,(syntax-position #'expr) + '#,(syntax-span #'expr)))))])) + +(m abc) +} + #f + #rx"^[.] srcloc" + #:extra-assert + (λ (defs ints) + (equal? + (for/list ([range (send defs get-highlighted-ranges)]) + (list (text:range-start range) (text:range-end range))) + '((680 683))))) + +(test @t{ +#lang racket +(define sp (open-output-string)) +(let/ec k + (parameterize ([error-escape-handler k]) + (parameterize ([current-error-port sp]) + (raise-argument-error 'f "string?" 1 0 1 2 3)))) +(display (get-output-string sp)) +} + #f + @t{ +f: contract violation + expected: string? + given: 1 + argument position: 2nd + other arguments...: + 0 + 2 + 3 +} + ) + +;; 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"))) From 9fc80b928df331aa35ce23012bef042df8f4bb90 Mon Sep 17 00:00:00 2001 From: shhyou Date: Tue, 4 Aug 2026 16:36:49 +0800 Subject: [PATCH 2/6] Import test-engine-test from drracket-test --- .../tests/htdp-lang/test-engine-test.rkt | 562 ++++++++++++++++++ 1 file changed, 562 insertions(+) create mode 100644 htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt 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..f36f75ef --- /dev/null +++ b/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt @@ -0,0 +1,562 @@ +;; From: drracket/drracket-test/tests/drracket/test-engine-test.rkt +;; 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))) From 67c1f516eedc90c5192b11ae0772884b1d0be122 Mon Sep 17 00:00:00 2001 From: shhyou Date: Tue, 4 Aug 2026 16:33:42 +0800 Subject: [PATCH 3/6] Remove non-HtDP tests --- .../tests/htdp-lang/language-test.rkt | 421 --------------- .../tests/htdp-lang/module-lang-test.rkt | 491 ------------------ 2 files changed, 912 deletions(-) diff --git a/htdp-drracket-test/tests/htdp-lang/language-test.rkt b/htdp-drracket-test/tests/htdp-lang/language-test.rkt index e36078a3..0e09b0f5 100644 --- a/htdp-drracket-test/tests/htdp-lang/language-test.rkt +++ b/htdp-drracket-test/tests/htdp-lang/language-test.rkt @@ -32,424 +32,6 @@ the settings above should match r5rs (set-language-level! (language) close-dialog?))) -; -; -; -; -; ;; ;; -; ;; ;; -; ;;;;; ;; ;;; ;;;;; ;; ;; ;; ;;;; -; ;;;;;;;;; ;;;;; ;;;;; ;; ;; ;; ;; ;;; -; ;; ;; ;; ;;; ;;;;; ;; ;; ;; ;; ;;;;;;; -; ;; ;; ;; ;;; ;;;;; ;; ;; ;; ;; ;;; -; ;; ;; ;; ;;;;; ;;;;; ;;;;; ;; ;; ;; -; ;; ;; ;; ;;; ;;;;; ;;;;; ;; ;;;; -; -; -; -; - -(define (module-lang) - (parameterize ([language '(module "racket")] - [defs-prefix "#lang racket\n"]) - - (check-top-of-repl) - - (generic-output #t #t #t #t #t #t) - - (test-setting - (lambda () (fw:test:set-check-box! #rx"Enforce constant definitions" #f)) - "enforce-module-constants -- #f" - "#lang racket/base\n(define x 1)\n" - #:interactions "(set! x 2)" - "> (set! x 2)") - (test-setting - (lambda () (fw:test:set-check-box! #rx"Enforce constant definitions" #t)) - "enforce-module-constants -- #t" - "#lang racket/base\n(define x 1)\n" - #:interactions "(set! x 2)" - #rx"cannot modify a constant") - - (prepare-for-test-expression) - - (test-expression - (format "~s" - `(let () - (define (enum-write-proc enum port mode) - (define recur - (case mode - [(#t) write] - [(#f) display] - [else (lambda (p port) (print p port mode))])) - (display "#" port)) - - (struct enum (val) - #:methods gen:custom-write - [(define write-proc enum-write-proc)]) - - (enum 1))) - "#") - - (test-expression "(print 'hello (current-output-port) 1)" "hello") - (test-expression "(print 'hello (current-output-port) 0)" "'hello") - (test-expression "(print '((x)) (current-output-port) 0)" "'((x))") - - (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" - "{image}" - "{image}") - - (test-expression "'|.|" "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#t") - (test-expression "(define x 1)(define x 2)" #rx"identifier already defined in: x" "") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "#" - #rx"define-values: assignment disallowed.*struct:spider") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" (regexp "class: bad syntax in: class")) - (test-expression "shared" (regexp "shared: bad syntax in: shared")) - - (test-expression "(define (. x y) (* x y))" #rx"read-syntax: illegal use of `\\.`" "") - (test-expression "'(1 . 2)" "'(1 . 2)") - - (test-expression "(define (f define) 1)" "" #rx"define-values: assignment disallowed.*: f") - (test-expression "(define (f car) 1)" "" #rx"define-values: assignment disallowed.*: f") - (test-expression "(define (f empty) 1)" "" #rx"define-values: assignment disallowed.*: f") - - (test-expression "call/cc" "#") - - (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") - (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "#t") - (test-expression "mred^" - #rx"unbound identifier in: mred\\^" - #rx"mred\\^.*cannot reference an identifier before its definition") - (test-expression "(eq? 'a 'A)" "#f") - (test-expression "(set! x 1)" - #rx"set!: unbound identifier in: x" - #rx"set!:.*cannot set variable before its definition.*: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "'(1 . 2)") - (test-expression "(+ (list 1) 2)" #rx"[+]: contract violation.*given: '[(]1[)]") - (test-expression "'(1)" "'(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "'(#&1 #&1)" - #rx"define-values: assignment disallowed.*: shrd") - (test-expression "(local ((define x x)) 1)" #rx"x: undefined;\n cannot use before initialization") - (test-expression "(letrec ([x x]) 1)" #rx"x: undefined;\n cannot use before initialization") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - (test-expression "(print (floor (sqrt 2)))" "1.0") - - (test-expression "(let ([f (lambda (x) x)]) f)" "#") - (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "'(1)") - (test-expression "(car (list))" - #rx"{stop-multi.png} {stop-22x22.png} car: contract violation.*given: '[(][)]") - - (test-expression "(current-command-line-arguments)" "'#()") - (test-expression "(define-syntax app syntax-case)" - "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") - - (test-expression "#lang racket" #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)") - "a: b") - - (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" - "{image}" - "{image}") - - (test-expression "(syntax-source #'x)" - #rx"'[0-9]+-unsaved-editor" - #rx"'|[0-9]+-interactions from an unsaved editor|"))) - - -; -; -; -; ; ; ;;;; ;; -; ;; ;; ;;;; ;; -; ;;;;;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;;;; -; ;;;;;;;; ;;;;;;; ;;;;; ;;;;;; ;;;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;;;;;; -; ;;;;;;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;;;;; ;;;;;;;;; ;;;; ;;; ;;;; -; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; -; ;;;;;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;; ;;;;;;;;; ;;;; ;;;;;;; -; ;;;;;;;; ;;;; ;;;;;; ;;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ; ;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;;; -; ;;;; ;;;; ;;;;;;;; -; ;;;; ;;;; ;;;;;; -; - -(define (pretty-big) - (parameterize ([language (list #rx"Pretty Big")]) - - (check-top-of-repl) - - (generic-settings #f) - (generic-output #t #f #t #t #f #f) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "(print '((x)))" "((x))") - - (test-expression "'|.|" "|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#t") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression "(define-struct spider (legs))(make-spider 4)" "#") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" (regexp "class: bad syntax in: class")) - (test-expression "shared" (regexp "shared: bad syntax in: shared")) - - (test-expression "(define (. x y) (* x y))" #rx"read-syntax: illegal use of `\\.`") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression "call/cc" "#") - - (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") - (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "#t") - (test-expression - "mred^" - #rx"{stop-multi.png} {stop-22x22.png} mred\\^.*cannot reference an identifier before its definition") - (test-expression "(eq? 'a 'A)" "#f") - (test-expression "(set! x 1)" - #rx"{stop-multi.png} {stop-22x22.png} set!:.*cannot set variable before its definition.*: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" - #rx"{stop-multi.png} {stop-22x22.png} [+]: contract violation.*given: [(]1[)]") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" #rx"x: undefined;\n cannot use before initialization") - (test-expression "(letrec ([x x]) 1)" #rx"x: undefined;\n cannot use before initialization") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - (test-expression "(print (floor (sqrt 2)))" "1.0") - - (test-expression "(let ([f (lambda (x) x)]) f)" "#") - (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" - #rx"{stop-multi.png} {stop-22x22.png} car: contract violation.*given: [(][)]") - - (test-expression "(current-command-line-arguments)" "#()") - (test-expression "(define-syntax app syntax-case)" - "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") - - (test-expression "#lang racket" - "" - #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)") - "a: b") - - (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" - "{image}" - "{image}"))) - -; -; -; ;;;;;;; ;;;;;;; ;;;;;; -; ;; ;; ;; ;; ;; ;; -; ;; ;; ;;;;; ;; ;; ;; ; -; ;; ;; ;;;;; ;; ;; ;;;; -; ;;;;;; ; ;;;;;; ;;;;; -; ;; ;; ;;;; ;; ;; ;;; -; ;; ;; ;; ;; ;; ; ;; -; ;; ;; ;; ;; ;; ;; ;; -; ;;;; ;;; ;; ;; ;;;; ;;;;;;;;; -; ;; ;; -; ;;;; -; - - -(define (r5rs) - (parameterize ([language (list (regexp "R5RS"))]) - - (check-top-of-repl) - - (generic-settings #f) - (generic-output #t #f #t #f #f #f) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#t") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression - "(define-struct spider (legs))(make-spider 4)" - #rx"{stop-multi.png} {stop-22x22.png} define-struct:.*cannot reference an identifier before its definition") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression - "class" - #rx"{stop-multi.png} {stop-22x22.png} class:.*cannot reference an identifier before its definition") - (test-expression - "shared" - #rx"{stop-multi.png} {stop-22x22.png} shared:.*cannot reference an identifier before its definition") - - (test-expression "(define (. x y) (* x y))" #rx"read-syntax: illegal use of `\\.`") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression - "call/cc" - #rx"{stop-multi.png} {stop-22x22.png} call/cc:.*cannot reference an identifier before its definition") - - (test-expression - "(error 'a \"~a\" 1)" - #rx"{stop-multi.png} {stop-22x22.png} error:.*cannot reference an identifier before its definition") - (test-expression - "(error \"a\" \"a\")" - #rx"{stop-multi.png} {stop-22x22.png} error:.*cannot reference an identifier before its definition") - - (test-expression - "(time 1)" - #rx"{stop-multi.png} {stop-22x22.png} time.*cannot reference an identifier before its definition") - - (test-expression - "true" - #rx"{stop-multi.png} {stop-22x22.png} true.*cannot reference an identifier before its definition") - (test-expression - "mred^" - #rx"{stop-multi.png} {stop-22x22.png} mred\\^.*cannot reference an identifier before its definition") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" - #rx"{stop-multi.png} {stop-22x22.png} set!:.*cannot set variable before its definition.*: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond ((= 1 2) 3))" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" - #rx"{stop-multi.png} {stop-22x22.png} [+]: contract violation.*given: [(]1[)]") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (cons 1 1)) (list shrd shrd)" - "((1 . 1) (1 . 1))") - (test-expression - "(local ((define x x)) 1)" - #rx"define: not allowed in an expression context") - (test-expression "(letrec ((x x)) 1)" #rx"x: undefined;\n cannot use before initialization") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - (test-expression "(print (floor (sqrt 2)))" #rx"print:.*cannot reference an identifier before its definition") - - (test-expression "(let ((f (lambda (x) x))) f)" "#") - (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" - #rx"{stop-multi.png} {stop-22x22.png} mcar: contract violation.*given: [(][)]") - - (test-expression - "argv" - #rx"{stop-multi.png} {stop-22x22.png} argv:.*cannot reference an identifier before its definition") - (test-expression - "(define-syntax app syntax-case)" - "{stop-22x22.png} macro-transformer: only a `syntax-rules' form is allowed in: syntax-case") - - (test-expression - "#lang racket" - #rx"module-begin: not in a module-definition context" - #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"cannot reference an identifier before its definition") - - (test-expression "(require racket/gui/base)(require racket/class)(make-object bitmap% 1 1)" - #rx"require: undefined" - #rx"require: undefined"))) ; @@ -1960,9 +1542,6 @@ the settings above should match r5rs (define (run-test) ;(go bsl) - (go module-lang) - (go pretty-big) - (go r5rs) (go beginner) (go beginner/abbrev) (go intermediate) diff --git a/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt index 2be10b9b..62baada2 100644 --- a/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt +++ b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt @@ -34,505 +34,14 @@ (module module-lang-test-syn-error racket/base (lambda))) -(test @t{} - #f - @rx{Module Language: There must be a valid module - Try starting your program with - Interactions disabled} - #t) -(test @t{1} - #f - @rx{Module Language: only a module expression is allowed - Interactions disabled} - #t) -(test @t{(module m racket) 1} - #f - @rx{Module Language: there can only be one expression in the definitions - Interactions disabled} - #t) -(test @t{.} - #f - @rx{read-syntax: illegal - Interactions disabled} - #t) -(test @t{#lang mzscheme - (define x 1)} - @t{x} - "1") -(test @t{#lang m-z-scheme - (define x 1)} - #f - @rx{collection not found - Interactions disabled} - #t) -(test @t{#lang racket - 3} - #f - "3") -(test @t{(module m racket (provide x) (define x 1))} - @t{x} - "1") -(test @t{(module m racket (define x 1))} - @t{x} - "1") -(test @t{(module m racket (define x 1) (define y 1) (provide y))} - @t{x} - "1") -(test @t{(module m racket (define x 1) (define y 2) (provide y))} - @t{y} - "2") -(test @t{(module m mzscheme (require mzlib/list))} - @t{foldl} - #rx"foldl") -(test @t{(module m mzscheme (require (rename mzlib/list local-foldl foldl)))} - @t{local-foldl} - #rx"foldl>") -(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))} - @t{first} - #rx"first>") -(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))} - @t{foldl} - #rx"[.] [.] foldl:.*cannot reference an identifier before its definition") -(test @t{(module m mzscheme (require (prefix mz: mzscheme)))} - @t{mz:+} - #rx"procedure:[+]") -(test @t{(module n mzscheme (provide (all-from-except mzscheme +)))} - @t{+} - #rx"procedure:[+]") -(test @t{(module m mzscheme - (require (prefix x: mzlib/list) mzlib/list))} - @t{foldl} - #rx"foldl>") -(test @t{(module m mzscheme - (require (prefix x: mzlib/list) mzlib/list))} - @t{x:foldl} - #rx"foldl>") -(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) x)} - @t{x} - "1") -;; + shouldn't be bound in the REPL because it isn't bound in the module. -(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) x)} - @t{+} - #rx"[.] [.] [+]:.*cannot reference an identifier before its definition") -(test @t{(module m mzscheme (provide lambda))} - @t{(lambda (x) x)} - #rx"namespace module->namespace)) - (define x 2) - (define -current-namespace error) - (define -module->namespace error) - (define-syntax app (syntax-rules () ((app . x) '(app . x)))))} - @t{x} - "2") -(test @t{#lang racket - (eval 'cons)} - #f - @rx{cons: unbound identifier.*no #%top syntax transformer is bound}) -(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) 1 2 3)} - @t{1} ;; just make sure no errors. - "1") - -(test @t{#lang racket} - @t{(begin-for-syntax (+ 1 2))} - @t{}) - -(test @t{#lang racket} - @t{(begin (struct s (x)) (struct t s (y)) (s-x (t 1 2)))} - "1") - -(test @t{#lang racket/base - (read-accept-reader) - (read-accept-compiled)} - #f - @t{#f - #f}) - -;; check that we have a working repl in the right language after -;; syntax errors, unless it's a bad language -(test @t{#lang racket - (define x 1) - (define y (/ 0))} - @t{(+ 122 x)} - @rx{. /: division by zero - 123} - #t) -(test @t{#lang racket - (define x 1) - (define y (/ 0))} - @t{(if x 123)} - @rx{/: division by zero.*if: missing an "else"} - #t) -(test @t{#lang mzscheme - (define x 1) - (define y (/ 0))} - @t{(if x 123)} - @rx{. /: division by zero - 123} - #t) -(test @t{(module xx scheme/list - (define x 1) - (define y (/ 0)))} - #f - @rx{no #%module-begin binding in the module's language - Interactions disabled: - does not support a REPL \(no #%top-interaction\)} - #t) -(test @t{(module xx (file @in-here{module-lang-test-tmp4.rkt}) - (define x 1) - (* x 123))} - #f - @rx{444 - 123 - Interactions disabled: - does not support a REPL \(no #%top-interaction\) - } - #t) -(test @t{(module xx (file @in-here{this-file-does-not-exist}) - (define x 1) - (* x 123))} - #f - @rx{cannot open module file - Module Language: invalid language specification - Interactions disabled} - #t) -(test @t{#lang info} - #f - ;; test the complete buffer, to make sure that there is no error - ;; would be better if this said "lang" and not "setup/infotab" but - ;; leave it like this for now. - "\nInteractions disabled: setup/infotab does not support a REPL (no #%top-interaction)" - #t) - -;; test racket/load behavior -(test @t{#lang racket/load - (module m mzscheme (provide x) (define x 2)) - (require 'm) - (printf "~s\n" x) - (flush-output)} - #f - "2") -(test @t{#lang racket/load - (module m mzscheme (provide x) (define x 2)) - (module n racket/base (require 'm) (provide y) (define y (* x x))) - (require 'n) - (printf "~s\n" y) - (flush-output)} - #f - "4") - -(test @t{#lang racket - (define-syntax (f stx) - (syntax-case stx () - [(f) - (raise (make-exn:fail:syntax "both" (current-continuation-marks) (list #'f stx)))]))} - @t{(f)} - (string-append "> (f)\n" - ". both in:\n" - " f\n" - " (f)") - #t) - -(test @t{#lang racket/base} - @t{(begin (values) 1)} - "1") - -(test @t{#lang racket/base} - @t{ (eval '(values 1 2))} - @t{1@"\n"2}) -(test @t{#lang racket/base} - @t{ (eval '(list 1 2))} - @t{'(1 2)}) -(test @t{#lang racket/base} - @t{ (eval '(lambda ()))} - @t{lambda: bad syntax in: (lambda ())}) -(test @t{#lang racket/base} - @t{(expt 3 (void))} - @rx{expt: contract violation.*given: #}) -(test @t{#lang racket/base} - @t{1 2 ( 3 4} - #rx"1\n2\n[.][^\n]*read-syntax: expected a `[)]` to close `[(]`") -(test @t{#lang racket/base} - "1 2 . 3 4" - #rx"1\n2\n[.][^\n]*read-syntax: illegal use of `[.]`") -(test @t{#lang racket/base} - "1 2 (lambda ()) 3 4" - "1\n2\n. lambda: bad syntax in: (lambda ())") -(test @t{#lang racket/base} - "1 2 x 3 4" - #rx"1\n2\n[.] [.] x:.*cannot reference an identifier before its definition") -(test @t{#lang racket/base} - "1 2 (raise 1) 3 4" - "1\n2\nuncaught exception: 1") -(test @t{#lang racket/base} - "1 2 (raise #f) 3 4" - "1\n2\nuncaught exception: #f") -(test @t{#lang racket/base} - "(current-namespace (make-empty-namespace)) if" - #rx". #%top-interaction: unbound identifier.*no #%app syntax transformer is bound") -(test @t{#lang racket/base} - (string-append - "(let ([old (error-escape-handler)])\n" - "(+ (let/ec k\n(dynamic-wind\n" - "(lambda () (error-escape-handler (lambda () (k 5))))\n" - "(lambda () (expt 3 #f))\n" - "(lambda () (error-escape-handler old))))\n" - "10))") - #rx"[.] [.] expt: contract violation.*given: #f\n15") -(test @t{#lang racket/base} - "(write (list (syntax x)))" - "(.)") -(test @t{#lang racket/base} - "(parameterize ([current-output-port (open-output-string)]) (write #'1))" - "") -(test @t{#lang racket/base} - "(write-special 1)" - "1#t") -(test @t{#lang racket/gui} - (format "~s ~s ~s" - '(define s (make-semaphore 0)) - '(queue-callback - (lambda () - (dynamic-wind - void - (lambda () (expt 3 #f)) - (lambda () (semaphore-post s))))) - '(begin (yield s) (void))) - #rx"[.] [.] expt: contract violation.*given: #f") -(test @t{#lang racket/base} - (format "~s ~s" - '(define x 1) - '((λ (x y) y) (set! x (call/cc (lambda (x) x))) (x 3))) - #rx". . application:.*given: 3") -(test @t{#lang racket/base} - (format "~s ~s ~s ~s" - '(begin (define k (call/cc (λ (x) x))) - (define x 'wrong)) - '(set! x 'right) - '(k 1) - 'x) - "'right") -(test @t{#lang racket/base} - (format "~s" - '(call-with-continuation-prompt - (lambda () - (eval '(begin (abort-current-continuation - (default-continuation-prompt-tag) - 1 2 3) - 10))) - (default-continuation-prompt-tag) - list)) - "'(1 2 3)") -(test @t{#lang racket/gui} - "(vector (new snip%))" - "(vector .)") -(test @t{#lang racket/base} - "(begin (thread (lambda () x)) (sleep 1/10))" - #rx"[.] [.] x:.*cannot reference an identifier before its definition") -(test @t{#lang racket/base} - "(require texpict/utils)(disk 3)" - ".") -(test @t{#lang racket/base} - (string-append - "(require mzlib/pretty)" - "(pretty-print-print-hook (lambda x (expt 3 #f)))" - "(list 1 2 3)") - "'(1 2 3)") - -;; test protection against user-code changing the namespace -(test @t{#lang racket/base - (current-namespace (make-base-namespace))} - "(+ 1 2)" - "3") -(test @t{#lang racket/base - (current-namespace (make-base-empty-namespace))} - "(+ 1 2)" - "3") -(test @t{#lang racket/base} - @t{(parameterize ([current-directory "/does/not/exists/well/it/better/not/anwyays"]) - (load @in-here{module-lang-test-syn-error.rkt}))} - ;; test to make sure that we don't get "exception raised by error display handler" - #rx"module-lang-test-syn-error.rkt:[0-9]+:[0-9]+: lambda: bad syntax in: \\(lambda\\)") - -(test @t{#lang racket -(module+ main (printf "main\n")) -(module+ test (printf "test\n")) -(module+ other (printf "other\n"))} - #f - #rx"test\nmain") - - -(test @t{#lang racket} - (format "~s" '(+ 1 (+ 1 (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () - (abort-current-continuation - (default-continuation-prompt-tag) - (λ () 0))))))) - "0") - -(test @t{#lang racket} - (format "~s ~s ~s" - '1 - '(+ 1 (+ 1 (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () - (abort-current-continuation - (default-continuation-prompt-tag) - (λ () 0)))))) - '2) - "1\n0") - -(test @t{#lang racket} - (format "~s" - '(begin - 1 - (+ 1 (+ 1 (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () - (abort-current-continuation - (default-continuation-prompt-tag) - (λ () 0)))))) - 2)) - "0") - (test '("#lang racket\n" xml-box) #f @t{'(a () "x")}) - -(test @t{#lang racket/base - (define os (open-output-string)) - (display "before\n") - (parameterize ([current-output-port os]) - (displayln "not shown") - ((current-print) 'aaa)) - (display "after\n")} - #f - #rx"before\nafter") - -(test @t{#lang racket/base - ((current-print) 1) - ((current-print) 2) - ((current-print) 3)} - #f - "1\n2\n3") -(test @t{#lang racket/base - (define (f n) ((global-port-print-handler) n (current-output-port))) - (f 1) (f 2) (f 3)} - #f - "123") (test @t{#lang htdp/bsl 1 2 3} #f "1\n2\n3") -(test @t{#lang racket - (require pict) - (define-values (in out) (make-pipe-with-specials)) - (print (colorize (filled-rectangle 4 4) "red") out)} - #f - "") -(test @t{#lang racket - (require pict) - (scale (blank 1 1) -1 1)} - #f - ".") -(test @t{#lang racket - (void "🏴‍☠️") - free-🏴‍☠️-var} - #f - #rx"unbound identifier in: free-🏴‍☠️-var" - #:extra-assert (λ (defs ints) - (equal? - (for/list ([range (send defs get-highlighted-ranges)]) - (list (text:range-start range) (text:range-end range))) - '((27 40))))) -(test @t{ -#lang racket -(struct exn:fail:user-srcloc exn:fail:user (srclocs) - #:property prop:exn:srclocs - (λ (s) (exn:fail:user-srcloc-srclocs s))) - -(define-syntax (m stx) - (syntax-case stx () - [(_ expr) - #`(raise (exn:fail:user-srcloc "srcloc" (current-continuation-marks) - (list - (srcloc '#,(syntax-source #'expr) - '#,(syntax-line #'expr) - '#,(syntax-column #'expr) - '#,(syntax-position #'expr) - '#,(syntax-span #'expr)))))])) - -(m abc) -} - #f - #rx"^[.] srcloc" - #:extra-assert - (λ (defs ints) - (equal? - (for/list ([range (send defs get-highlighted-ranges)]) - (list (text:range-start range) (text:range-end range))) - '((680 683))))) - -(test @t{ -#lang racket -(define sp (open-output-string)) -(let/ec k - (parameterize ([error-escape-handler k]) - (parameterize ([current-error-port sp]) - (raise-argument-error 'f "string?" 1 0 1 2 3)))) -(display (get-output-string sp)) -} - #f - @t{ -f: contract violation - expected: string? - given: 1 - argument position: 2nd - other arguments...: - 0 - 2 - 3 -} - ) ;; Test that big-bang is in the stacktrace if the state-expr errors at start time. (test @t{ From ca0f7801e2e4e7c8282d3632eba17e17ee102ebe Mon Sep 17 00:00:00 2001 From: shhyou Date: Tue, 4 Aug 2026 16:43:03 +0800 Subject: [PATCH 4/6] Record commit hash --- htdp-drracket-test/tests/htdp-lang/language-test.rkt | 1 + htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt | 1 + htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt | 1 + 3 files changed, 3 insertions(+) diff --git a/htdp-drracket-test/tests/htdp-lang/language-test.rkt b/htdp-drracket-test/tests/htdp-lang/language-test.rkt index 0e09b0f5..c40b9461 100644 --- a/htdp-drracket-test/tests/htdp-lang/language-test.rkt +++ b/htdp-drracket-test/tests/htdp-lang/language-test.rkt @@ -1,4 +1,5 @@ ;; From: drracket/drracket-test/tests/drracket/language-test.rkt +;; At: e94a69c80ae82954ec9ce6ebdec784a99f2b9b98 ;; Original author: Robby #lang racket diff --git a/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt index 62baada2..e1c886fb 100644 --- a/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt +++ b/htdp-drracket-test/tests/htdp-lang/module-lang-test.rkt @@ -1,4 +1,5 @@ ;; From: drracket/drracket-test/tests/drracket/module-lang-test.rkt +;; At: e94a69c80ae82954ec9ce6ebdec784a99f2b9b98 ;; Infrastructure: Robby ;; Test author: Shu-Hung #lang at-exp racket/base diff --git a/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt b/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt index f36f75ef..d90b9b4d 100644 --- a/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt +++ b/htdp-drracket-test/tests/htdp-lang/test-engine-test.rkt @@ -1,4 +1,5 @@ ;; From: drracket/drracket-test/tests/drracket/test-engine-test.rkt +;; At: e94a69c80ae82954ec9ce6ebdec784a99f2b9b98 ;; Original author: Mike Sperber #lang racket From 5ed20018b72768446c48a959740e2e5bc125eafb Mon Sep 17 00:00:00 2001 From: shhyou Date: Tue, 4 Aug 2026 18:17:33 +0800 Subject: [PATCH 5/6] Uncomment some passing bsl tests from 2015 --- .../tests/htdp-lang/language-test.rkt | 103 ++++++++++-------- 1 file changed, 59 insertions(+), 44 deletions(-) diff --git a/htdp-drracket-test/tests/htdp-lang/language-test.rkt b/htdp-drracket-test/tests/htdp-lang/language-test.rkt index c40b9461..25270ef9 100644 --- a/htdp-drracket-test/tests/htdp-lang/language-test.rkt +++ b/htdp-drracket-test/tests/htdp-lang/language-test.rkt @@ -211,6 +211,7 @@ the settings above should match r5rs "{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"]) @@ -246,7 +247,9 @@ the settings above should match r5rs (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))] @@ -259,11 +262,11 @@ the settings above should match r5rs (prepare-for-test-expression) (test-expression "(check-expect 1 1)" - "The only test passed!" - "") ;; somewhat dubious -- it should either be a syntax error or work... + "The test passed!" + "The test passed!") (test-expression "(check-expect 1 2)" - #rx"Actual value 1 differs from 2" - "") + #rx"Actual value {embedded \"1\"} differs from {embedded \"2\"}" + #rx"Actual value {embedded \"1\"} differs from {embedded \"2\"}") (test-expression "'|.|" "'|.|" @@ -277,7 +280,10 @@ the settings above should match r5rs "{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") - (test-expression + ;; 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") @@ -289,9 +295,11 @@ the settings above should match r5rs (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 `.`"))) + (regexp (regexp-quote "read-syntax: illegal use of `.`")) + #:has-repl? #f) (test-expression "'(1 . 2)" - (regexp (regexp-quote "read-syntax: illegal use of `.`"))) + (regexp (regexp-quote "read-syntax: illegal use of `.`")) + #:has-repl? #f) (test-undefined-var "call/cc" #:icon+in? #t) @@ -309,8 +317,9 @@ the settings above should match r5rs "#false") (test-undefined-fn "(set! x 1)" "set!" #:icon+in? #t) (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!" #:icon+in? #t) - - (test-expression "(cond [(= 1 2) 3])" + + ;; 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)" @@ -329,7 +338,8 @@ the settings above should match r5rs (regexp (regexp-quote "shrd: this name was defined previously and cannot be re-defined"))) - (test-expression + ;; Crashes subsequent tests + #;(test-expression "(local ((define x x)) 1)" (regexp (regexp-quote @@ -345,7 +355,8 @@ the settings above should match r5rs (regexp (regexp-quote "function call: expected a function after the open parenthesis, but found a part"))) - (test-expression "(if 1 1 1)" + ;; 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"))) @@ -395,7 +406,8 @@ the settings above should match r5rs (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 `,`"))) + (regexp (regexp-quote "read-syntax: illegal use of `,`")) + #:has-repl? #f) (test-expression "(list 1)" "(cons 1 '())" @@ -407,7 +419,8 @@ the settings above should match r5rs (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"))) + (regexp (regexp-quote "read-syntax: `#lang` not enabled")) + #:has-repl? #f) (test-expression (string-append "(define (f)\n" "(+ (raise-user-error 'a \"b\")))\n" @@ -1430,7 +1443,8 @@ the settings above should match r5rs ;; -> 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]) +(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)))] @@ -1486,34 +1500,35 @@ the settings above should match r5rs (eprintf (make-err-msg defs-expected) 'definitions (language) expression defs-expected got))) - (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)))) + (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 @@ -1542,7 +1557,7 @@ the settings above should match r5rs (flush-output)))])) (define (run-test) - ;(go bsl) + (go bsl) ;; Some failed test cases are commented out; they never worked. (go beginner) (go beginner/abbrev) (go intermediate) From f5ca8e545b53e6fef189123d6ea5981868891924 Mon Sep 17 00:00:00 2001 From: shhyou Date: Tue, 4 Aug 2026 18:31:28 +0800 Subject: [PATCH 6/6] CI: include the htdp-drracket-test package --- .github/workflows/ci.yml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) 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