...

original commit: efcc9908be570fb36d620e76d166f4574545c40f

collects/framework/framework.ss

@@ -1,5 +1,4 @@
-(require-library "mred-interfaces.ss" "framework")
-(require-library "frameworks.ss" "framework")
+(require-relative-library "frameworks.ss")
 
 (require-library "string.ss")
 (require-library "function.ss")
@@ -19,7 +18,7 @@
 	   [framework:keys : framework:keys^]
 	   [framework:test : framework:test^])
    (link [M : mred-interfaces^ (mred-interfaces@)]
-	 [F : frameworkc^ ((require-library "frameworkc.ss" "framework")
+	 [F : frameworkc^ ((require-relative-library "frameworkc.ss")
 			   core:string
 			   core:function
 			   core:pretty-print

collects/framework/frameworks.ss

@@ -12,13 +12,9 @@
 (require-library "macro.ss")
 (require-relative-library "macro.ss")
 
+(require-relative-library "mred-interfaces.ss")
 (require-relative-library "tests.ss")
 
-(define-signature framework:keys^
-  (shifted-key-list
-   get-shifted-key-list))
-
-
 (define-signature framework:version^
   (add-spec
    version))

collects/framework/keys.ss

@@ -1,8 +0,0 @@
-(unit/sig framework:keys^
-  (import)
-  
-  (define shifted-key-list
-    '("?" ":" "~" "\"" "|"
-      "<" ">" "{" "}" "[" "]" "(" ")"
-      "!" "@" "#" "$" "%" "^" "&" "*" "_" "+"))
-  (define (get-shifted-key-list) shifted-key-list))

collects/tests/framework/load.ss

@@ -0,0 +1,66 @@
+(test
+ 'testr.ss
+ (lambda (x) #f)
+ '(parameterize ([current-namespace (make-namespace 'mred)])
+    (require-library "tests.ss" "framework")
+    (invoke-open-unit/sig
+     (compound-unit/sig
+       (import)
+       (link [mred : mred-interfaces^ (mred-interfaces@)]
+	     [keys : framework:keys^ ((require-library "keys.ss" "framework"))]
+	     [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)])
+       (export (unit test))))
+    (global-defined-value 'test:run-one)
+    (global-defined-value 'test:button-push)
+    (void)))
+
+(test
+ 'test.ss
+ (lambda (x) #f)
+ '(parameterize ([current-namespace (make-namespace 'mred)])
+    (require-library "test.ss" "framework")
+    (global-defined-value 'test:run-one)
+    (global-defined-value 'test:button-push)
+    (void)))
+
+(test
+ 'mred-interfaces.ss
+ (lambda (x)
+   (printf "Called predicate: ~a~n" x)
+   #f)
+ '(parameterize ([current-namespace (make-namespace 'mred)])
+    (require-library "mred-interfaces.ss" "framework")
+    (global-defined-value 'mred-interfaces^)
+    (global-defined-value 'mred-interfaces@)
+    (void)))
+
+(test
+ 'frameworkr.ss
+ (lambda (x) #f)
+ '(parameterize ([current-namespace (make-namespace 'mred)])
+    (require-library "frameworks.ss" "framework")
+    (invoke-open-unit/sig
+     (compound-unit/sig
+       (import)
+       (link [mred : mred-interfaces^ (mred-interfaces@)]
+	     [core : mzlib:core^ ((require-library "corer.ss"))]
+	     [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)])
+       (export (open framework))))
+    (global-defined-value 'test:run-one)
+    (global-defined-value 'test:button-push)
+    (global-defined-value 'frame:basic-mixin)
+    (global-defined-value 'editor:basic-mixin)
+    (global-defined-value 'exit:exit)
+    (void)))
+
+(test
+ 'framework.ss
+ (lambda (x) #f)
+ '(parameterize ([current-namespace (make-namespace 'mred)])
+    (require-library "framework.ss" "framework")
+    (global-defined-value 'test:run-one)
+    (global-defined-value 'test:button-push)
+    (global-defined-value 'frame:basic-mixin)
+    (global-defined-value 'editor:basic-mixin)
+    (global-defined-value 'exit:exit)
+    (void)))

collects/tests/framework/main.ss

@@ -61,8 +61,17 @@
 		      (or (not (char-ready? in-port))
 			  (not (eof-object? (peek-char in-port)))))
 	   (restart-mred))
-	 (printf "send-sexp-to-mred.sending:~n")
-	 (pretty-print sexp)
+	 (printf "sending to mred:~n")
+	 (parameterize ([pretty-print-print-line
+			 (let ([prompt "  "]
+			       [old-liner (pretty-print-print-line)])
+			   (lambda (ln port ol cols)
+			     (let ([ov (old-liner ln port ol cols)])
+			       (if ln 
+				   (begin (display prompt port)
+					  (+ (string-length prompt) ov))
+				   ov))))])
+	   (pretty-print sexp))
 	 (write sexp out-port)
 	 (newline out-port)
 	 (let ([answer
@@ -79,7 +88,6 @@
 								 (loop))
 							   null))))))])
 		  (read in-port))])
-	   (printf "send-sexp-to-mred.received result~n")
 	   (unless (or (eof-object? answer)
 		       (and (list? answer)
 			    (= 2 (length answer))))
@@ -88,14 +96,16 @@
 	       (raise (make-eof-result))
 	       (case (car answer)
 		 [(error)
-		  (error 'send-sexp-to-mred (format "mred raised \"~a\" with input: ~s" (second answer) sexp))]
+		  (error 'send-sexp-to-mred (format "mred raised \"~a\"" (second answer)))]
 		 [(cant-read) (error 'mred/cant-parse (second answer))]
 		 [(normal) (second answer)]))))))))
 
 (define section-jump void)
 
 (define test
-  (opt-lambda (test-name failed? test [jump 'section])
+  (case-lambda
+   [(test-name failed? sexp/proc) (test test-name failed? sexp/proc 'section)]
+   [(test-name failed? sexp/proc jump)
     (let ([failed
 	   (with-handlers ([(lambda (x) #t)
 			    (lambda (x)
@@ -103,15 +113,15 @@
 				  (exn-message x)
 				  x))])
 	     (failed?
-	      (if (procedure? test)
-		  (test)
-		  (eval (send-sexp-to-mred test)))))])
+	      (if (procedure? sexp/proc)
+		  (sexp/proc)
+		  (eval (send-sexp-to-mred sexp/proc)))))])
       (when failed
 	(printf "FAILED ~a: ~a~n" test-name failed)
 	(case jump
 	  [(section) (section-jump)]
 	  [(continue) (void)]
-	  [else (jump)])))))
+	  [else (jump)])))]))
 
 (define preferences-file (build-path (find-system-path 'pref-dir)
 				     (case (system-type)