Improved decoupling of scheme tests and MrEd, including different import files for textual versus graphical reporting

svn: r9220

collects/combinator-parser/private-combinator/combinator.scm

@@ -607,14 +607,14 @@
                       (cond 
                         [(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)]
                         [(null? curr-input) 
-                         #;(printf "out of input for ~a~n" repeat-name)
+                         #;(printf "out of input for ~a~n" (repeat-name))
                          (make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)]
                         [else
                          (let ([this-res (sub curr-input curr-src)])
                            #;(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name))
                            (cond
                              [(and (res? this-res) (res-a this-res))
-                              #;(printf "loop again case for ~a~n" repeat-name)
+                              #;(printf "loop again case for ~a~n" (repeat-name))
                               (process-rest this-res 
                                             (loop (res-rest this-res)
                                                   (update-src (res-rest this-res) curr-src)))]
@@ -650,8 +650,8 @@
                                                                    curr-src)))]
                                   [else
                                    (map (lambda (match) 
-                                          #;(printf "calling repeat loop again, res-rest match ~a~n" 
+                                          #;(printf "calling repeat loop again ~a, res-rest match ~a~n" 
-                                                  (length (res-rest match)))
+                                                  (repeat-name) (length (res-rest match)))
                                           (process-rest match 
                                                         (loop (res-rest match)
                                                               (update-src (res-rest match) curr-src))))

collects/lang/htdp-langs.ss

@@ -38,8 +38,9 @@
            "run-teaching-program.ss"
            stepper/private/shared
            
-           (lib "scheme-gui.scm" "test-engine")
+           (only test-engine/scheme-gui format-value)
-	   (lib "test-display.scm" "test-engine")
+           (only test-engine/scheme-tests scheme-test-data scheme-test-format)
+           (lib "test-display.scm" "test-engine")
            )
   
   
@@ -160,7 +161,7 @@
                   [set-result-module-name 
                    ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f)]
                   [scheme-test-module-name
-                   ((current-module-name-resolver) '(lib "test-engine/scheme-gui.scm") #f #f)])
+                   ((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)])
               (run-in-user-thread
                (lambda ()
                  (read-accept-quasiquote (get-accept-quasiquote?))
@@ -175,6 +176,7 @@
                  (namespace-attach-module drs-namespace scheme-test-module-name)
                  (namespace-require scheme-test-module-name)
                  (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
+                 (scheme-test-format format-value)
                  )))
             (super on-execute settings run-in-user-thread))
           

collects/profj/comb-parsers/parser-units.scm

@@ -353,7 +353,7 @@
         init #;(sequence (new type-name init) "array initialization")))
     
     (define (binary-expression-end op)
-      (sequence (op expression) id "binary expression"))
+      (sequence (op (eta expression)) id "binary expression"))
     
     (define if-expr-end 
       (sequence (? (eta expression) : (eta expression)) id "conditional expression"))
@@ -669,11 +669,11 @@
     
     (define class
       (class-def #f #f (implements-dec identifier)
-                 (repeat-greedy (class-body (list field method constructor)))))
+                 (repeat (class-body (list field method constructor)))))
     
     (define program 
-      (make-program #f (repeat-greedy import-dec) 
+      (make-program #f (repeat import-dec) 
-                    (repeat-greedy (top-member (list class interface)))))
+                    (repeat (top-member (list class interface)))))
     
     (define interact
       (choose (field statement expression) "interactive program"))

collects/test-engine/scheme-gui.scm

@@ -1,32 +0,0 @@
-#lang scheme/base
-
-(require scheme/class
-         "test-engine.scm")
-
-(define scheme-test-data (make-parameter (list #f #f #f)))
-(define scheme-test-format (make-parameter (lambda (v) (format "~a" v))))
-
-(define scheme-test%
-  (class* test-engine% ()
-    (super-instantiate ())
-    (inherit-field test-info test-display)
-    (inherit setup-info)
-
-    (field [tests null]
-           [test-objs null])
-
-    (define/public (add-test tst)
-      (set! tests (cons tst tests)))
-    (define/public (get-info)
-      (unless test-info (send this setup-info 'check-require))
-      test-info)
-
-    (define/augment (run)
-      (inner (void) run)
-      (for ([t (reverse tests)]) (run-test t)))
-
-    (define/augment (run-test test)
-      (test)
-      (inner (void) run-test test))))
-
-(provide scheme-test% scheme-test-data scheme-test-format)

collects/test-engine/scheme-gui.ss

@@ -0,0 +1,33 @@
+(module scheme-gui scheme/base
+  
+  (require mred framework scheme/class 
+           mzlib/pconvert mzlib/pretty)
+  
+  (require (except-in "scheme-tests.ss" test) "test-display.scm")
+  
+  (define (format-value value)
+    (cond
+      [(is-a? value snip%) value]
+      [(or (pair? value) (struct? value))
+       (parameterize ([constructor-style-printing #t]
+                      [pretty-print-columns 40])
+         (let* ([text* (new (editor:standard-style-list-mixin text%))]
+                [text-snip (new editor-snip% [editor text*])])
+           (pretty-print (print-convert value) (open-output-text-editor text*))
+           (send text* lock #t)
+           text-snip))]
+      [else (format "~v" value)]))
+  
+  (define (test) (run-tests) (pop-up))
+  
+  (define (pop-up)
+    (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
+      (parameterize ([scheme-test-format format-value])
+        (and test-info
+             (send test-info refine-display-class test-display%)
+             (send test-info setup-display #f #f)
+             (send test-info summarize-results (current-output-port))))))
+  
+  (provide test format-value (all-from-out "scheme-tests.ss"))
+  
+  )

collects/test-engine/scheme-tests.ss

@@ -1,12 +1,10 @@
 #lang mzscheme
 
 (require lang/private/teachprims
-         #;mred
+         scheme/class
-         #;framework
+         (only scheme/base for)
-         #;mzlib/pretty
+         "test-engine.scm"
-         #;mzlib/pconvert
+         )
-         mzlib/class
-         "scheme-gui.scm")
 
 (require-for-syntax stepper/private/shared)
 
@@ -16,61 +14,6 @@
  check-error  ;; syntax : (check-error <expression> <expression>)
  )
 
-(define (builder)
-  (let ([te (build-test-engine)])
-    (namespace-set-variable-value! 'test~object te (current-namespace))
-    te))
-
-(define (test)
-  (run-tests)
-  (display-results))
-
-(define (test-text)
-  (run-tests)
-  (print-results))
-
-(define-syntax (run-tests stx)
-  (syntax-case stx ()
-    [(_)
-     (syntax-property
-      #'(run (namespace-variable-value 'test~object #f builder
-                                       (current-namespace)))
-      'test-call #t)]))
-
-(define (run test-info) (and test-info (send test-info run)))
-
-(define-syntax (display-results stx) 
-  (syntax-case stx ()
-    [(_)
-     (syntax-property
-      #'(let ([test-info (namespace-variable-value 'test~object #f builder
-                                                   (current-namespace))])
-          (and test-info
-               (let ([display-data (scheme-test-data)])
-                 (send test-info refine-display-class (caddr display-data))
-                 (send test-info setup-display
-                       (car display-data) (cadr display-data))
-                 (send test-info summarize-results (current-output-port)))))
-      'test-call #t)]))
-
-(define-syntax (print-results stx)
-  (syntax-case stx ()
-    [(_)
-     (syntax-property
-      #'(let ([test-info (namespace-variable-value 'test~object #f builder
-                                                   (current-namespace))])
-          (and test-info
-               (send test-info summarize-results (current-output-port))))
-      'test-call #t)]))
-
-(provide run-tests display-results test test-text)
-
-(define (build-test-engine)
-  (let ([engine (make-object scheme-test%)])
-    (send engine setup-info 'check-require)
-    engine))
-(define (insert-test test-info test) (send test-info add-test test))
-
 (define INEXACT-NUMBERS-FMT
   "check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
 (define CHECK-ERROR-STR-FMT
@@ -272,15 +215,69 @@
            ((scheme-test-format) (expected-error-value fail))
            (format ".~n ~a~n" (expected-error-message fail)))]))
 
-#;(define (format-value value)
+
-  (cond
+(define (builder)
-    [(is-a? value snip%) value]
+  (let ([te (build-test-engine)])
-    [(or (pair? value) (struct? value))
+    (namespace-set-variable-value! 'test~object te (current-namespace))
-     (parameterize ([constructor-style-printing #t]
+    te))
-                    [pretty-print-columns 40])
+
-       (let* ([text* (new (editor:standard-style-list-mixin text%))]
+(define (test) (run-tests) (display-results))
-              [text-snip (new editor-snip% [editor text*])])
+
-         (pretty-print (print-convert value) (open-output-text-editor text*))
+(define-syntax (run-tests stx)
-         (send text* lock #t)
+  (syntax-case stx ()
-         text-snip))]
+    [(_)
-    [else (format "~v" value)]))
+     (syntax-property
+      #'(run (namespace-variable-value 'test~object #f builder (current-namespace)))
+      'test-call #t)]))
+
+(define (run test-info) (and test-info (send test-info run)))
+
+(define-syntax (display-results stx) 
+  (syntax-case stx ()
+    [(_)
+     (syntax-property
+      #'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
+          (and test-info
+               (let ([display-data (scheme-test-data)])
+                 (when (caddr display-data)
+                   (send test-info refine-display-class (caddr display-data)))
+                 (send test-info setup-display (car display-data) (cadr display-data))
+                 (send test-info summarize-results (current-output-port)))))
+      'test-call #t)]))
+
+(provide run-tests display-results test builder)
+
+(define (build-test-engine)
+  (let ([engine (make-object scheme-test%)])
+    (send engine setup-info 'check-require)
+    engine))
+
+(define (insert-test test-info test) (send test-info add-test test))
+
+(define scheme-test-data (make-parameter (list #f #f #f)))
+(define scheme-test-format (make-parameter (lambda (v) (format "~a" v))))
+
+(define scheme-test%
+  (class* test-engine% ()
+    (super-instantiate ())
+    (inherit-field test-info test-display)
+    (inherit setup-info)
+
+    (field [tests null]
+           [test-objs null])
+
+    (define/public (add-test tst)
+      (set! tests (cons tst tests)))
+    (define/public (get-info)
+      (unless test-info (send this setup-info 'check-require))
+      test-info)
+
+    (define/augment (run)
+      (inner (void) run)
+      (for ([t (reverse tests)]) (run-test t)))
+
+    (define/augment (run-test test)
+      (test)
+      (inner (void) run-test test))))
+
+(provide scheme-test-data scheme-test-format)