diff --git a/pkgs/drracket-pkgs/drracket-test/tests/drracket/language-test.rkt b/pkgs/drracket-pkgs/drracket-test/tests/drracket/language-test.rkt index 6d0984c804..29926c15d1 100644 --- a/pkgs/drracket-pkgs/drracket-test/tests/drracket/language-test.rkt +++ b/pkgs/drracket-pkgs/drracket-test/tests/drracket/language-test.rkt @@ -1129,9 +1129,10 @@ the settings above should match r5rs (test-expression "#lang racket" "read: #lang not enabled in the current context" "read: #lang not enabled in the current context") - (test-expression "(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 + "(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}" @@ -1229,7 +1230,8 @@ the settings above should match r5rs (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" (queue-callback/res (λ () (send (send drs get-definitions-text) get-text)))) + (eprintf "defs: ~s" + (queue-callback/res (λ () (send (send drs get-definitions-text) get-text)))) (error 'language-test.rkt "failed get top of repl test"))))) @@ -1259,7 +1261,10 @@ the settings above should match r5rs (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t)) "Use decimal notation for rationals -- #t" "4/3 1/2 -1/3" - "{number 4/3 \"#e1.3\" decimal}\n{number 1/2 \"#e0.5\" decimal}\n{number -1/3 \"#e-0.3\" decimal}")) + (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 @@ -1274,94 +1279,91 @@ the settings above should match r5rs (if false/true? "true" "#t"))) (define (generic-output list? quasi-quote? has-sharing? has-print-printing?) - (let* ([plain-print-style (if has-print-printing? "print" "write")] - [drs (wait-for-drracket-frame)] - [expression "(define x (list 2))\n(list x x)"] - [set-output-choice - (lambda (option show-sharing pretty?) - (set-language #f) - (fw:test:set-radio-box! "Output Style" option) - (when (and has-sharing? show-sharing) - (fw:test:set-check-box! - "Show sharing in values" - (if (eq? show-sharing 'on) #t #f))) - (fw:test:set-check-box! - "Insert newlines in printed values" - pretty?) - (let ([f (test:get-active-top-level-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)))] - [shorten - (lambda (str) - (if ((string-length str) . <= . 45) - str - (string-append (substring str 0 45) "...")))] - [test - ;; 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 - (lambda (option show-sharing pretty? answer) - (set-output-choice option show-sharing pretty?) - (do-execute drs) - (let ([got (fetch-output/should-be-tested drs)]) - (unless (if (procedure? answer) - (answer got) - (whitespace-string=? answer got)) - (eprintf "FAILED ~s ~a, sharing ~a pretty? ~a\n got ~s\n expected ~s\n" - (language) option show-sharing pretty? - (shorten got) - (if (procedure? answer) (answer) answer)))))]) - - (clear-definitions drs) - (type-in-definitions drs expression) - - (test plain-print-style 'off #t "((2) (2))") + (define plain-print-style (if has-print-printing? "print" "write")) + (define drs (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! "Output Style" option) + (when (and has-sharing? show-sharing) + (fw:test:set-check-box! + "Show sharing in values" + (if (eq? show-sharing 'on) #t #f))) + (fw:test:set-check-box! + "Insert newlines in printed values" + pretty?) + (let ([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 drs) + (define got (fetch-output/should-be-tested drs)) + (unless (if (procedure? answer) + (answer got) + (whitespace-string=? answer got)) + (eprintf "FAILED ~s ~a, sharing ~a pretty? ~a\n got ~s\n expected ~s\n" + (language) option show-sharing pretty? + (shorten got) + (if (procedure? answer) (answer) answer)))) + + (clear-definitions drs) + (type-in-definitions drs expression) + + (test plain-print-style 'off #t "((2) (2))") + (when has-sharing? + (test plain-print-style 'on #t "(#0=(2) #0#)")) + (when quasi-quote? + (test "Quasiquote" 'off #t "`((2) (2))") (when has-sharing? - (test plain-print-style 'on #t "(#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 + (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))"))) + + (test "Constructor" 'off #t + (if list? + "(list (list 2) (list 2))" + "(cons (cons 2 empty) (cons (cons 2 empty) empty))")) + (when has-sharing? + (test "Constructor" 'on #t (if list? - "(list (list 2) (list 2))" - "(cons (cons 2 empty) (cons (cons 2 empty) empty))")) - (when has-sharing? - (test "Constructor" 'on #t - (if list? - "(shared ((-1- (list 2))) (list -1- -1-))" - "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))"))) - - ;; setup print / pretty-print difference + "(shared ((-1- (list 2))) (list -1- -1-))" + "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))"))) + + ;; setup print / pretty-print difference + (clear-definitions drs) + (insert-in-definitions + drs + "(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 drs) - (insert-in-definitions - drs - "(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 drs) - (insert-in-definitions drs "(print 'hello (current-output-port) 1)") - (test plain-print-style #f #t "hello") - (test plain-print-style #f #f "hello")))) + (insert-in-definitions drs "(print 'hello (current-output-port) 1)") + (test plain-print-style #f #t "hello") + (test plain-print-style #f #f "hello"))) (define re:out-of-sync (regexp @@ -1379,7 +1381,8 @@ the settings above should match r5rs (let ([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-start-position (+ last-para 1)))) (queue-callback/res (λ () (send interactions-text paragraph-end-position