...

original commit: 68b19a0a7745efe4d05888b6c7ca252369b24814

collects/framework/framework.ss

@@ -2,12 +2,11 @@
 (compile-allow-cond-fallthrough #t)
 (compile-allow-set!-undefined #t)
 (require-library "mred-interfaces.ss" "framework")
-(require-library "sig.ss" "framework")
+(require-library "framework.ss" "framework")
-(invoke-unit/sig
+(invoke-open-unit/sig
  (compound-unit/sig
    (import)
    (link [M : mred-interfaces^ (mred-interfaces@)]
 	 [C : mzlib:core^ ((require-library "corer.ss"))]
 	 [F : framework^ ((require-library "frameworkr.ss" "framework") C M)])
-   (export)))
+   (export (open F))))
-'done

collects/framework/main.ss

@@ -209,4 +209,5 @@
        (preferences:save))))
   
   ;(wx:application-file-handler edit-file) ;; how to handle drag and drop?
-  )
+
+  (void))

collects/framework/test.ss

@@ -10,7 +10,7 @@
 (printf "4~n")
 (require-library "mred-interfaces.ss" "framework")
 (printf "5~n")
-(require-library "sig.ss" "framework")
+(require-library "frameworks.ss" "framework")
 (printf "6~n")
 (define framework@ (require-library "frameworkr.ss" "framework"))
 (printf "7~n")

collects/tests/framework/README

@@ -11,6 +11,11 @@ There will be a main mzscheme process which will start up a new mred
 as necessary for the test suites. Since some tests actually require
 mred to exit in order to pass, this governor is required.
 
+- exit: |# exit.ss #|
+
+  | This tests that exit:exit really exits and that the exit callbacks
+  | are actually run.
+
 - preferences: |# prefs.ss #|
 
   | This tests that preferences are saved and restored correctly, both
@@ -19,10 +24,12 @@ mred to exit in order to pass, this governor is required.
 - individual object tests:
 
   | These tests are simple object creation and basic operations.
+  | Each test assumes that the others pass; this may yield strange
+  | error messages when one fails.
 
-  - edits: |# edit.ss #|
   - frames: |# frame.ss #|
   - canvases: |# canvas.ss #|
+  - edits: |# edit.ss #|
 
 - basic connections between classes
 

collects/tests/framework/exit.ss

@@ -0,0 +1 @@
+(send-sexp-to-mred '(exit:exit))

collects/tests/framework/framework-test-engine.ss

@@ -1,33 +1,33 @@
 (thread
- (letrec ([namespace (make-namespace)]
+ (let ([print-convert
-	  [_ (parameterize ([current-namespace namespace])
+	(parameterize ([current-namespace (make-namespace)])
-	       (require-library "pconvert.ss"))]
+	  (require-library "pconvert.ss")
-	  [restart
+	  (global-defined-value 'print-convert))])
-	   (lambda ()
+
-	     (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
+   (lambda ()
-			   [(continue) (make-semaphore 0)]
+     (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
-			   [(error) #f]
+		   [(continue) (make-semaphore 0)]
-			   [(answer) (void)])
+		   [(error) #f]
-	       (let loop ()
+		   [(answer) (void)])
-		 (let ([sexp (read in)])
+       (let loop ()
-		   (if (eof-object? sexp)
+	 (let ([sexp (read in)])
-		       (begin
+	   (if (eof-object? sexp)
-			 (close-input-port in)
+	       (begin
-			 (close-output-port out)
+		 (close-input-port in)
-			 (exit))
+		 (close-output-port out)
-		       (begin
+		 (exit))
-			 (queue-callback (lambda ()
+	       (begin
-					   (set! error #f)
+		 (queue-callback (lambda ()
-					   (with-handlers ([(lambda (x) #t)
+				   (set! error #f)
-							    (lambda (exn)
+				   (with-handlers ([(lambda (x) #t)
-							      (set! error exn))])
+						    (lambda (exn)
-					     (set! answer (eval sexp)))
+						      (set! error exn))])
-					   (semaphore-post continue)))
+				     (set! answer (eval sexp)))
-			 (semaphore-wait continue)
+				   (semaphore-post continue)))
-			 (write
+		 (semaphore-wait continue)
-			  (if error
+		 (write
-			      (list 'error (exn-message error))
+		  (if error
-			      (list 'normal answer))
+		      (list 'error (exn-message error))
-			  out)
+		      (list 'normal (print-convert answer)))
-			 (loop)))))))])
+		  out)
-   restart))
+		 (loop)))))))))

collects/tests/framework/main.ss

@@ -0,0 +1,131 @@
+(require-library "launcher.ss" "launcher")
+(require-library "function.ss")
+(require-library "macro.ss")
+
+;; old, hopefully unnecessary
+'(case (system-type)
+   [(macos) 
+
+    (when running?
+      (let ([tmp-file (build-path (find-system-path 'temp-dir)
+				  "frameworkempty.ss")])
+	(call-with-output-file tmp-file
+	  (lambda (port)
+	    (newline port))
+	  'truncate)
+	(send-event "MrEd" "aevt" "quit")
+	(let loop ()
+	  (sleep 1)
+	  (with-handlers ([(lambda (x) #t) void])
+	    (printf "looping~n")
+	    (send-event "MrEd" "aevt" "odoc" (vector 'file tmp-file))
+	    (loop)))))
+    (printf "macos: mred no longer running~n")])
+
+(unless (file-exists? "receive-sexps-port.ss")
+  (call-with-output-file "receive-sexps-port.ss"
+    (lambda (port)
+      (write 6012 port))))
+
+(define-values (shutdown-listener shutdown-mred send-sexp-to-mred)
+  (let ([listener
+	 (let loop ()
+	   (let ([port (load-relative "receive-sexps-port.ss")])
+	     (with-handlers ([(lambda (x) #t)
+			      (lambda (x)
+				(let ([next (+ port 1)])
+				  (call-with-output-file "receive-sexps-port.ss"
+				    (lambda (p)
+				      (write next p))
+				    'truncate)
+				  (printf "tcp-listen failed for port ~a, attempting ~a~n"
+					  port next)
+				  (loop)))])
+	       (tcp-listen port))))]
+	[in-port #f]
+	[out-port #f])
+    (let ([restart-mred
+	   (lambda ()
+	     (shutdown-mred)
+	     (let-values ([(base _1 _2) (split-path program)])
+	       ((case (system-type)
+		  [(macos) system*]
+		  [else (lambda (x) (begin (process* x) (void)))])
+		(mred-program-launcher-path "Framework Test Engine")))
+	     (let-values ([(in out) (tcp-accept listener)])
+	       (set! in-port in)
+	       (set! out-port out))
+	     (send-sexp-to-mred '(require-library "framework.ss" "framework")))])
+      (values
+       (lambda ()
+	 (shutdown-mred)
+	 (tcp-close listener))
+       (lambda ()
+	 (when (and in-port
+		    out-port)
+	   (close-output-port out-port)
+	   (close-input-port in-port)
+	   (set! in-port #f)
+	   (set! in-port #f)))
+       (lambda (sexp)
+	 (unless (and in-port out-port)
+	   (restart-mred))
+	 (write sexp out-port)
+	 (newline out-port)
+	 (let ([answer
+		(with-handlers ([(lambda (x) #t)
+				 (lambda (x) (list 'cant-read
+						   (string-append
+						    (exn-message x)
+						    "; rest of string: "
+						    (apply
+						     string
+						     (let loop ()
+						       (if (char-ready? in-port)
+							   (cons (read-char in-port)
+								 (loop))
+							   null))))))])
+		  (read in-port))])
+	   (unless (and (list? answer)
+			(= 2 (length answer)))
+	     (error 'framework-test-suite "unpected result from mred: ~s~n" answer))
+	   (case (car answer)
+	     [(error) (error 'mred (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])
+    (let ([failed
+	   (with-handlers ([(lambda (x) #t)
+			    (lambda (x)
+			      (if (exn? x)
+				  (exn-message x)
+				  x))])
+	     (failed? (eval (send-sexp-to-mred test))))])
+      (when failed
+	(printf "FAILED ~a: ~a~n" test-name failed)
+	(case jump
+	  [(section) (section-jump)]
+	  [(continue) (void)]
+	  [else (jump)])))))
+
+(let ([all-files (map symbol->string (load-relative "README"))])
+  (for-each (lambda (x)
+	      (when (member x all-files)
+		(let ([oh (error-escape-handler)])
+		  (let/ec k
+		    (error-escape-handler (lambda ()
+					    (error-escape-handler oh)
+					    (k (void))))
+		    (set! section-jump k)
+		    (printf "beginning ~a test suite~n" x)
+		    (load-relative x)
+		    (error-escape-handler oh)))))
+	    (if (equal? (vector) argv)
+		all-files
+		(vector->list argv))))
+
+(shutdown-listener)

collects/tests/framework/prefs.ss

@@ -0,0 +1,33 @@
+(local [(define pref-file (build-path (find-system-path 'pref-dir) ".mred.prefs"))
+	(define old-prefs (if (file-exists? pref-file)
+			      (call-with-input-file pref-file read)
+			      null))
+	(define (check-eq? m s) (lambda (t) (if (eq? s t) #f m)))
+	(define pref-sym 'framework:test-suite)]
+
+  (call-with-output-file pref-file
+    (lambda (port) (write (filter (lambda (x) (not (eq? (car x) pref-sym)))
+				  old-prefs)
+			  port))
+    'truncate)
+  (shutdown-mred)
+  (test
+   'preference-unbound
+   (check-eq? "couldn't remove preference binding" 'passed)
+   `(with-handlers ([exn:unknown-preference?
+		     (lambda (x)
+		       'passed)])
+      (preferences:get ',pref-sym)))
+  (test 'preference-set-default/get
+	(check-eq? "set-default followed by get didn't work" 'passed)
+	`(begin (preferences:set-default ',pref-sym 'passed symbol?)
+		(preferences:get ',pref-sym)))
+  (test 'preference-set/get
+	(check-eq? "set followed by get didn't work" 'new-pref)
+	`(begin (preferences:set ',pref-sym 'new-pref)
+		(preferences:get ',pref-sym)))
+  (send-sexp-to-mred '(exit:exit))
+  (shutdown-mred)
+  (test 'preference-get-after-restart
+	(check-eq? "get after restart didn't work" 'new-pref)
+	`(preferences:get ',pref-sym)))