drdr-ized the rest of the drscheme test suite

svn: r17945

collects/mrlib/text-string-style-desc.ss

@@ -1,16 +1,15 @@
-(module text-string-style-desc mzscheme
+#lang scheme/base
+
 (provide get-string/style-desc)
-  (require mred
+(require scheme/gui/base
-           mzlib/etc
+         scheme/class)
-           mzlib/class)
 
 ;; get-string/style-desc : text -> (listof str/ann)
-  (define get-string/style-desc
+(define (get-string/style-desc text [start 0] [end (send text last-position)])
-    (opt-lambda (text [start 0] [end (send text last-position)])
   (let* ([snips (get-snips text start end)]
          [str/ann (map snip->str/ann snips)]
          [joined-str/ann (join-like str/ann)])
-        joined-str/ann)))
+    joined-str/ann))
 
 ;; get-snips : text -> (listof snip)
 ;; extracts the snips from a text
@@ -87,4 +86,4 @@
                       (cdr rest))
                 (cons first
                       (loop second
-                              (cdr rest)))))]))])))
+                            (cdr rest)))))]))]))

collects/tests/drscheme/README.ss

@@ -1,55 +0,0 @@
-#lang scheme/base
-(provide all-tests)
-(define all-tests (map symbol->string '(
-#|
-
-This directory contains code for testing DrScheme. To run the tests,
-load run-test.ss. It will return a function that accepts the names of
-tests. Those names must be listed here. If no arguments are passed to
-the function, all tests will be run.
-
-   stepper-test.ss 
-
-   runs the stepper on the sample solutions and
-   checks the results.
-   (this test suite is not being maintained)  
- 
-|# io.ss #|
-
-   This tests the drscheme's io implementation.
-   
-|# repl-test.ss #|
-
-   This tests various interactions between parameters in the 
-   implementation of drscheme.
-
-|# language-test.ss #|   
-
-   This tests that all of the individual settings in the language dialog 
-   take effect in the repl.
-
-|# module-lang-test.ss #|
-
-   This tests the code involved in implementing the new module language.
-   
-   graphics.ss
-
-   This tests the various graphic elements that can appear
-   in programs.
-
-  launcher.ss
-
-   This tests the launcher feature of drscheme.
-
-|# sample-solutions-one-window.ss #|
-
-   This tests the sample solutions in HtDP,
-   but reuses the same drscheme window.
-   There is a race condition in this test,
-   so it is commented out here, for now.
-   
-|# teachpack.ss #|
-
-   Tests the teachpacks
-
-|#)))

collects/tests/drscheme/io.ss

@@ -1,3 +1,5 @@
+#lang scheme/base
+
 #|
 
 add this test:
@@ -10,20 +12,13 @@ add this test:
 
 |#
 
-(module io mzscheme
 (require "drscheme-test-util.ss"
          tests/utils/gui
          mzlib/class
-           mzlib/list
          mzlib/pretty
          mred
-           framework
+         mrlib/text-string-style-desc)
-           mrlib/text-string-style-desc
-           (prefix fw: framework))
 
-  (provide run-test)
-  
-  (define (output-err-port-checking)
 (define (check-output expression expected)
   (begin
     (clear-definitions drs-frame)
@@ -40,7 +35,7 @@ add this test:
                            expected 
                            got))
         (fprintf (current-error-port)
-                     "expected ~s, got ~s for ~s\n\n"
+                 "expected ~s\n     got ~s\nfor ~s\n\n"
                  expected
                  got
                  expression)))))
@@ -55,16 +50,18 @@ add this test:
                                              (send text paragraph-start-position 2))))))
     (channel-get chan)))
 
+
 (define (output-style x) (eq? x '|ports out|))
 (define (error-style x) (eq? x '|ports err|))
 (define (value-style x) (eq? x '|ports value|))
 
 (define prompt '("\n> " default-color))
 
+(define (output-err-port-checking)
   ;; this test has to be first to test an uninitialized state of the port
   (check-output "(port-next-location (current-input-port))" 
-                  (list `("1\n0\n1" |ports value|)
+                (list `("1\n0\n1\n" |ports value|)
-                        prompt))
+                      '("> " default-color)))
   
   (check-output "(display 1)" (list (list "1" output-style) prompt))
   (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt))
@@ -140,7 +137,8 @@ add this test:
                            (send interactions-text paragraph-end-position
                                  (- (send interactions-text last-paragraph) 1)))])
         (unless (equal? got-value expected-transcript)
-            (printf "FAILED: expected: ~s~n             got: ~s~n         program: ~s~n           input: ~s~n"
+          (fprintf (current-error-port)
+                   "FAILED: expected: ~s~n             got: ~s~n         program: ~s~n           input: ~s~n"
                    expected-transcript got-value program input)))))
   
   (clear-definitions drs-frame)
@@ -156,7 +154,7 @@ add this test:
   (do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b")
   (do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a #<void> b c)")
   
-    (do-input-test "(begin (display 1) (read))" "2\n" "12\n2\n") ;; why an extra newline?!
+  (do-input-test "(begin (display 1) (read))" "2\n" "12\n2")
   
   (do-input-test "(read-line)" "\n" "\n\"\"")
   (do-input-test "(read-char)" "\n" "\n#\\newline")
@@ -169,7 +167,7 @@ add this test:
                  "()\n"
                  "()\n()")
   
-    (do-input-test "(begin (write (read)) (write (read)))"
+  (do-input-test "(begin (write (read)) (flush-output) (write (read)))"
                  "(1)\n(2)\n"
                  "(1)\n(1)(2)\n(2)")
   
@@ -185,11 +183,20 @@ add this test:
 (define drs-frame #f)
 (define interactions-text #f)
 
-  (define (run-test)
+(let ([s (make-semaphore)])
+  (fire-up-drscheme)
+  (thread
+   (λ ()
      (set! drs-frame (wait-for-drscheme-frame))
      (set! interactions-text  (send drs-frame get-interactions-text))
      (set-language-level! (list #rx"Pretty Big"))
+     (clear-definitions drs-frame)
+     (do-execute drs-frame)
+
      (output-err-port-checking) ;; must come first
      ;(long-io/execute-test)
      (reading-test)
-    ))
+     (semaphore-post s)))
+  (yield s)
+  (exit))
+

collects/tests/drscheme/language-test.ss

@@ -20,8 +20,6 @@ the settings above should match r5rs
          framework
          (prefix-in fw: framework))
 
-(provide run-test)
-
 (define language (make-parameter "<<not a language>>"))
 
 ;; set-language : boolean -> void
@@ -1045,7 +1043,8 @@ the settings above should match r5rs
     (do-execute drs)
     (let* ([got (fetch-output/should-be-tested drs)])
       (unless (string=? result got)
-        (printf "FAILED: ~s ~s ~s test~n expected: ~s~n      got: ~s~n"
+        (fprintf (current-error-port)
+                 "FAILED: ~s ~s ~s test~n expected: ~s~n      got: ~s~n"
                  (language) setting-name expression result got)))))
 
 (define (test-hash-bang)
@@ -1058,7 +1057,8 @@ the settings above should match r5rs
     (do-execute drs)
     (let* ([got (fetch-output/should-be-tested drs)])
       (unless (string=? "1" got)
-        (printf "FAILED: ~s ~a test~n expected: ~s~n     got: ~s~n"
+        (fprintf (current-error-port)
+                 "FAILED: ~s ~a test~n expected: ~s~n     got: ~s~n"
                  (language) expression result got)))))
 
 (define (fetch-output/should-be-tested . args)
@@ -1094,7 +1094,8 @@ the settings above should match r5rs
                                                          (min (string-length line1-expect)
                                                               (string-length line1-got))))
                        (regexp-match line1-expect line1-got)))
-        (printf "expected lines: ~n  ~a~n  ~a~ngot lines:~n  ~a~n  ~a~n" 
+        (fprintf (current-error-port)
+                 "expected lines: ~n  ~a~n  ~a~ngot lines:~n  ~a~n  ~a~n" 
                  line0-expect line1-expect
                  line0-got line1-got)
         (error 'language-test.ss "failed get top of repl test")))))
@@ -1176,7 +1177,8 @@ the settings above should match r5rs
               (unless (if (procedure? answer)
                           (answer got)
                           (whitespace-string=? answer got))
-                (printf "FAILED ~s ~a, sharing ~a pretty? ~a~n            got ~s~n       expected ~s~n"
+                (fprintf (current-error-port)
+                         "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)))))])
@@ -1244,7 +1246,8 @@ the settings above should match r5rs
               (send interactions-text paragraph-end-position
                     (- (send interactions-text last-paragraph) 1)))])
         (unless (equal? got "0")
-          (printf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got))))))
+          (fprintf (current-error-port)
+                   "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got))))))
 
 
 ;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image)))
@@ -1348,3 +1351,8 @@ the settings above should match r5rs
   (go advanced)
   (go pretty-big)
   (go r5rs))
+
+(let ()
+  (fire-up-drscheme)
+  (thread (λ () (run-test) (exit)))
+  (yield (make-semaphore)))

collects/tests/drscheme/module-lang-test-utils.ss

@@ -75,7 +75,8 @@
                      (send interactions-text paragraph-start-position 2)
                      (send interactions-text paragraph-end-position 2))])
           (unless (or (test-all? test) (string=? "> " after-execute-output))
-            (printf "FAILED (line ~a): ~a\n        ~a\n        expected no output after execution, got: ~s\n"
+            (fprintf (current-error-port)
+                     "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)
@@ -107,7 +108,8 @@
                                       [else 'module-lang-test "bad test value: ~e" r])
                                 r text))])
         (unless output-passed?
-          (printf "FAILED (line ~a): ~a\n        ~a\n  expected: ~s\n       got: ~s\n"
+          (fprintf (current-error-port)
+                   "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)
@@ -120,7 +122,8 @@
            (let ([error-ranges-expected
                   ((test-error-ranges test) definitions-text interactions-text)])
              (unless (equal? error-ranges-expected (send interactions-text get-error-ranges))
-               (printf "FAILED (line ~a; ranges): ~a\n  expected: ~s\n       got: ~s\n"
+               (fprintf (current-error-port)
+                        "FAILED (line ~a; ranges): ~a\n  expected: ~s\n       got: ~s\n"
                         (test-line test)
                         (test-definitions test)
                         error-ranges-expected

collects/tests/drscheme/module-lang-test.ss

@@ -262,3 +262,10 @@
          (current-namespace (make-base-empty-namespace))}
       "(+ 1 2)"
       "3")
+
+
+(require "drscheme-test-util.ss")
+(let ()
+  (fire-up-drscheme)
+  (thread (λ () (run-test) (exit)))
+  (yield (make-semaphore 0)))

collects/tests/drscheme/repl-test.ss

@@ -17,8 +17,6 @@ This produces an ACK message
          mred
          framework)
 
-(provide run-test)
-
 (define-struct loc (line col offset))
 ;; loc = (make-loc number number number)
 ;; all numbers in loc structs start at zero.
@@ -1186,11 +1184,13 @@ This produces an ACK message
            (cond
              [(eq? source-location 'definitions)
               (unless (send definitions-canvas has-focus?)
-                (printf "FAILED execute test for ~s\n  expected definitions to have the focus\n"
+                (fprintf (current-error-port)
+                         "FAILED execute test for ~s\n  expected definitions to have the focus\n"
                          program))]
              [(eq? source-location 'interactions)
               (unless (send interactions-canvas has-focus?)
-                (printf "FAILED execute test for ~s\n  expected interactions to have the focus\n"
+                (fprintf (current-error-port)
+                         "FAILED execute test for ~s\n  expected interactions to have the focus\n"
                          program))]
              [(send definitions-canvas has-focus?)
               (let ([start (car source-location)]
@@ -1203,7 +1203,8 @@ This produces an ACK message
                                (= (+ (srcloc-position error-range) -1) (loc-offset start))
                                (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) 
                                   (loc-offset finish)))
-                    (printf "FAILED execute test for ~s\n  error-range is ~s\n  expected ~s\n"
+                    (fprintf (current-error-port)
+                             "FAILED execute test for ~s\n  error-range is ~s\n  expected ~s\n"
                              program
                              (and error-range
                                   (list (+ (srcloc-position error-range) -1)
@@ -1220,7 +1221,8 @@ This produces an ACK message
                    (regexp-match execute-answer received-execute)]
                   [else #f])
           (failure)
-          (printf "FAILED execute test for ~s (~a)\n  expected: ~s\n       got: ~s\n"
+          (fprintf (current-error-port)
+                   "FAILED execute test for ~s (~a)\n  expected: ~s\n       got: ~s\n"
                    program
                    language-cust
                    execute-answer received-execute))
@@ -1274,7 +1276,8 @@ This produces an ACK message
                                 (regexp-match load-answer received-load)]
                                [else #f])
                        (failure)
-                       (printf "FAILED load test ~a for ~s\n  expected: ~s\n       got: ~s\n"
+                       (fprintf (current-error-port)
+                                "FAILED load test ~a for ~s\n  expected: ~s\n       got: ~s\n"
                                 short-filename
                                 program load-answer received-load)))))])
           (load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f))
@@ -1287,7 +1290,7 @@ This produces an ACK message
         
         ; check for edit-sequence
         (when (repl-in-edit-sequence?)
-          (printf "FAILED: repl in edit-sequence")
+          (fprintf (current-error-port) "FAILED: repl in edit-sequence")
           (escape)))))
   
   (define tests 0)
@@ -1298,7 +1301,7 @@ This produces an ACK message
   (define (final-report)
     (if (= 0 failures)
         (printf "tests finished: all ~a tests passed\n" tests)
-        (printf "tests finished: ~a failed out of ~a total\n" failures tests)))
+        (fprintf (current-error-port) "tests finished: ~a failed out of ~a total\n" failures tests)))
   
   (define (run-test-in-language-level language-cust)
     (let ([level (list #rx"Pretty Big")])
@@ -1470,8 +1473,7 @@ This produces an ACK message
   (kill-tests)
   (callcc-test)
   (top-interaction-test)
-  (final-report)
+  (final-report))
-  )
 
 (define (insert-in-definitions/newlines drs str)
   (let loop ([strs (regexp-split #rx"\n" str)])
@@ -1504,3 +1506,9 @@ This produces an ACK message
   (if (regexp? b)
       (regexp (string-append (regexp-quote a) (object-name b)))
       (string-append a b)))
+
+
+(let ()
+  (fire-up-drscheme)
+  (thread (λ () (run-test) (exit)))
+  (yield (make-semaphore 0)))

collects/tests/drscheme/run-tests.ss

@@ -1,143 +0,0 @@
-;; load this file as a tool to run the test suites
-
-#lang scheme/base
-(require scheme/class
-         scheme/gui/base 
-         framework
-         "README.ss")
-
-(provide ask-test-suite run-test-suite)
-
-(define test-thread
-  (let ([kill-old void])
-    (lambda (test thunk)
-      (kill-old)
-      (let ([thread-desc (thread
-                          (lambda ()
-                            (printf "t>> ~a started~n" test)
-                            (thunk)
-                            (printf "t>> ~a finished~n" test)))])
-        (set! kill-old
-              (lambda ()
-                (when (thread-running? thread-desc)
-                  (kill-thread thread-desc)
-                  (printf "t>> killed ~a~n" test))))))))
-
-(define (make-repl)
-  (test-thread
-   "REPL"
-   (lambda ()
-     (let ([startup "~/.mzschemerc"])
-       (when (file-exists? startup)
-         (load startup)))
-     (case (system-type)
-       [(windows macos)
-        (graphical-read-eval-print-loop (current-eventspace))]
-       [else
-        (read-eval-print-loop)]))))
-
-(define (run-test-suite filename [die-afterwards? #f])
-  (test-thread
-   filename
-   (lambda ()
-     ((dynamic-require `(lib ,filename "tests" "drscheme") 'run-test))
-     (when die-afterwards? (exit)))))
-
-(define current-test-suite-frame #f)
-
-(define test-suite-frame%
-  (class frame%
-    (define/override (on-size w h)
-      (preferences:set 'drscheme:test-suite:frame-width w)
-      (preferences:set 'drscheme:test-suite:frame-height h))
-    (define/augment (on-close)
-      (inner (void) on-close)
-      (set! current-test-suite-frame #f))
-    (super-new)))
-
-(define (ask-test-suite parent)
-  (if current-test-suite-frame
-      (send current-test-suite-frame show #t)
-      (let* ([drscheme-test-dir (collection-path "tests" "drscheme")]
-             [frame (make-object test-suite-frame% 
-                      "Test Suites"
-                      parent
-                      (preferences:get 'drscheme:test-suite:frame-width)
-                      (preferences:get 'drscheme:test-suite:frame-height))]
-             [panel (make-object vertical-panel% frame)]
-             [top-panel (make-object vertical-panel% panel)]
-             [bottom-panel (make-object horizontal-panel% panel)])
-        (send top-panel stretchable-height #f)
-        (make-object button%
-          "REPL" 
-          bottom-panel
-          (lambda (_1 _2)
-            (send frame show #f)
-            (make-repl)))
-        
-        (when drscheme-test-dir
-          (send top-panel stretchable-height #t)
-          (send bottom-panel stretchable-height #f)
-          (letrec ([lb (make-object list-box%
-                         #f
-                         all-tests
-                         top-panel
-                         (lambda (b e)
-                           (when (eq? (send e get-event-type) 'list-box-dclick)
-                             (run-test-suite-callback))))]
-                   [run-test-suite-callback
-                    (lambda ()
-                      (let ([selection (send lb get-selection)])
-                        (when selection
-                          (send frame show #f)
-                          (let ([test (list-ref all-tests selection)])
-                            (preferences:set
-                             'drscheme:test-suite:file-name
-                             test)
-                            (run-test-suite test)))))])
-            
-            ;; set values from preferences
-            (let* ([test-suite (preferences:get 'drscheme:test-suite:file-name)]
-                   [num (send lb find-string test-suite)])
-              (when num
-                (send lb set-string-selection test-suite)
-                (send lb set-first-visible-item num)
-                (test:run-interval (preferences:get 'drscheme:test-suite:run-interval))))
-            
-            (send
-             (make-object button%
-               "Run Test Suite"
-               bottom-panel
-               (lambda (_1 _2)
-                 (run-test-suite-callback))
-               '(border))
-             focus))
-          
-          (let* ([pre-times (list 0 10 50 100 500)]
-                 [times (if (member (test:run-interval) pre-times)
-                            pre-times
-                            (append pre-times (list (test:run-interval))))]
-                 [choice
-                  (make-object choice%
-                    "Run Interval"
-                    (map number->string times)
-                    top-panel
-                    (lambda (choice event)
-                      (let ([time (list-ref times (send choice get-selection))])
-                        (preferences:set 'drscheme:test-suite:run-interval time)
-                        (test:run-interval time))))])
-            (send choice set-selection
-                  (let loop ([l times]
-                             [n 0])
-                    (if (= (car l) (test:run-interval))
-                        n
-                        (loop (cdr l)
-                              (+ n 1)))))))
-        (make-object button%
-          "Cancel" 
-          bottom-panel
-          (lambda (_1 _2)
-            (send frame show #f)))
-        (make-object grow-box-spacer-pane% bottom-panel)
-        (send frame show #t)
-        (set! current-test-suite-frame frame))))

collects/tests/drscheme/teachpack.ss

@@ -1,11 +1,10 @@
+#lang scheme/base
 
-(module teachpack mzscheme
 (require "drscheme-test-util.ss"
-           mzlib/class
+         scheme/class
-           mzlib/file
+         scheme/path
-           mred
+         scheme/gui/base
-           framework
+         (prefix-in fw: framework))
-           (prefix fw: framework))
 
 (provide run-test)
 
@@ -237,4 +236,9 @@
   (set! interactions-text (send drs-frame get-interactions-text))
   ;(good-tests)
   ;(bad-tests)
-    (test-built-in-teachpacks)))
+  (test-built-in-teachpacks))
+
+(let ()
+  (fire-up-drscheme)
+  (thread (λ () (run-test) (exit)))
+  (yield (make-semaphore)))

collects/tests/drscheme/tool.ss

@@ -1,58 +0,0 @@
-;; load this file as a tool to run the test suites
-
-(module tool mzscheme
-  (require drscheme/tool
-           mzlib/list
-           mzlib/unit
-           mzlib/class
-           mred
-           framework
-           "README.ss")
-  
-  (provide tool@)
-
-  (define tool@
-    (unit
-      (import drscheme:tool^)
-      (export drscheme:tool-exports^)
-      (define (phase1) (void))
-      (define (phase2) (void))
-      
-      (preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?)
-      (preferences:set-default 'drscheme:test-suite:run-interval 10 number?)
-      
-      (preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x))))
-      (preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x))))
-      
-      (define (tool-mixin super%)
-        (class super%
-          (inherit get-button-panel)
-          (super-new)
-          (let* ([bitmap (make-object bitmap% 
-                           (if (<= (get-display-depth) 1)
-                               (build-path (collection-path "icons") "bb-sm-bw.bmp")
-                               (build-path (collection-path "icons") "bb-small.bmp"))
-                           'bmp)]
-                 [button (make-object button%
-                           (if (send bitmap ok?) bitmap "Console")
-                           (get-button-panel)
-                           (lambda (button evt) 
-                             (let ([ask-test-suite (dynamic-require 'tests/drscheme/run-tests
-                                                                    'ask-test-suite)])
-                               (ask-test-suite this))))])
-            (send (get-button-panel) change-children
-                  (lambda (l)
-                    (cons button (remq button l)))))))
-      
-      (define tests (getenv "PLTDRTESTS")) 
-      
-      (cond
-        [(not tests) (void)]
-        [(member tests all-tests)
-         ((dynamic-require 'tests/drscheme/run-tests 'run-test-suite)
-          tests
-          #t)]
-        [else
-         (printf "PLTDRTESTS: installing unit frame mixin\n")
-         (drscheme:get/extend:extend-unit-frame tool-mixin)]))))
-

collects/tests/info.ss

@@ -1,8 +1,8 @@
 #lang setup/infotab
 
 (define name "Test Suites")
-(define tools '(("tool.ss" "drscheme") ("time-keystrokes.ss" "drscheme")))
+(define tools '(("time-keystrokes.ss" "drscheme")))
-(define tool-names '("DrScheme Test Suites" "Time Keystrokes"))
+(define tool-names '("Time Keystrokes"))
 
 (define compile-omit-paths
   '("2htdp"