...

original commit: 9b09e5f114c6ace0eabc47d880b90d55010f4a08

collects/framework/private/canvas.ss

@@ -2,6 +2,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig.ss"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred"))
 
   (provide canvas@)

collects/framework/private/editor.ss

@@ -3,6 +3,7 @@
 	   (lib "class.ss")
 	   "sig.ss"
 	   "../gui-utils-sig.ss"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "file.ss"))
 

collects/framework/private/exit.ss

@@ -10,7 +10,7 @@
 
   (define exit@
     (unit/sig framework:exit^
-      (import [mred : mred^]
+      (import mred^
 	      [preferences : framework:preferences^]
 	      [gui-utils : framework:gui-utils^])
       (rename (-exit exit))

collects/framework/private/frame.ss

@@ -3,6 +3,7 @@
 	   (lib "class.ss")
 	   "sig.ss"
 	   "../gui-utils-sig.ss"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "list.ss")
 	   (lib "file.ss"))

collects/framework/private/keymap.ss

@@ -1,5 +1,7 @@
 (module keymap mzscheme
   (require (lib "unitsig.ss")
+	   "sig.ss"
+	   "../macro.ss"
 	   (lib "class.ss")
 	   (lib "list.ss")
 	   (lib "mred-sig.ss" "mred"))
@@ -9,7 +11,6 @@
   (define keymap@ 
     (unit/sig framework:keymap^
       (import mred^
-	      [keys : framework:keys^]
 	      [preferences : framework:preferences^]
 	      [finder : framework:finder^]
 	      [handler : framework:handler^]

collects/framework/private/main.ss

@@ -2,6 +2,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig.ss"
+	   "../macro"
 	   (lib "mred-sig.ss" "mred"))
   
   (provide main@)

collects/framework/private/menu.ss

@@ -2,6 +2,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred"))
 
   (provide menu@)

collects/framework/private/panel.ss

@@ -2,6 +2,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "list.ss"))
 

collects/framework/private/pasteboard.ss

@@ -2,6 +2,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred"))
 
   (provide pasteboard@)

collects/framework/private/scheme.ss

@@ -7,6 +7,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig"
+	   "../macro.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "list.ss")
 	   (lib "thread.ss"))

collects/framework/private/text.ss

@@ -2,6 +2,7 @@
   (require (lib "unitsig.ss")
 	   (lib "class.ss")
 	   "sig"
+	   "../macro.ss"
 	   "../gui-utils-sig.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "list.ss"))

collects/framework/splash.ss

@@ -2,183 +2,189 @@
 ; title : title of window
 ; width-default : number 
 
-(lambda (filename title width-default)
-  (let/ec k
-    (letrec-values
-	([(no-splash) (lambda () (k void void void))]
-	 [(funny?) (let ([date (seconds->date (current-seconds))])
-		     (and (= (date-day date) 25)
-			  (= (date-month date) 12)))]
-	 [(funny-gauge%)
-	  (class canvas% (max-value parent)
-	    (inherit get-dc min-width min-height stretchable-width stretchable-height)
-	    (private
-	      [bitmap
-	       (make-object bitmap%
-		 (build-path (collection-path "icons") "touch.bmp"))]
-	      [value 0])
-	    (public
-	      [set-value
-	       (lambda (new-value)
-		 (let ([before-x
-			(floor (* (send bitmap get-width) (/ value max-value)))]
-		       [after-x
-			(ceiling (* (send bitmap get-width) (/ (- new-value value) max-value)))])
-		   (send (get-dc) draw-line
-			 (+ before-x 2) 0
-			 (+ after-x 2) 0)
-		   (send (get-dc) draw-line
-			 (+ before-x 2) (+ (send bitmap get-height) 4)
-			 (+ after-x 2) (+ (send bitmap get-height) 4))
-		   (send (get-dc) draw-bitmap-section bitmap
-			 (+ 2 before-x) 2
-			 before-x 0
-			 after-x (send bitmap get-height)))
-		 (set! value new-value))])
-	    (override
-	     [on-paint
-	      (lambda ()
-		(let ([dc (get-dc)])
-		  (send dc clear)
-		  (send dc draw-rectangle 0 0
-			(+ (send bitmap get-width) 4)
-			(+ (send bitmap get-height) 4))
-		  (send dc draw-bitmap-section bitmap
-			2 2 0 0
-			(* (send bitmap get-width) (/ value max-value))
-			(send bitmap get-height))))])
-	    (sequence
-	      (super-init parent)
-	      (min-width (+ (send bitmap get-width) 4))
-	      (min-height (+ (send bitmap get-height) 4))
-	      (stretchable-width #f)
-	      (stretchable-height #f)))]
+(module splash mzscheme
+  (require (lib "class.ss")
+	   (lib "mred.ss" "mred"))
 
-	 [(splash-get-resource)
-	  (lambda (name default)
-	    (let ([b (box 0)])
-	      (if (get-resource "mred" name b #f)
-		  (unbox b)
-		  default)))]
-	 [(set-resource)
-	  (lambda (name value)
-	    (write-resource "mred" name value (find-graphical-system-path 'setup-file))
-	    )]
-	 [(_1)
-	  (begin
-	    (unless filename
-	      (no-splash))
-	    (unless (file-exists? filename)
-	      (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" filename)
-	      (no-splash)))]
+  (provide splash)
 
-	 [(splash-width-resource) (format "~a-splash-max-width" title)]
-	 [(splash-max-width) (max 1 (splash-get-resource splash-width-resource width-default))]
-	 
-	 [(splash-current-width) 0]
+  (define (splash filename title width-default)
+    (let/ec k
+      (letrec-values
+       ([(no-splash) (lambda () (k void void void))]
+	[(funny?) (let ([date (seconds->date (current-seconds))])
+		    (and (= (date-day date) 25)
+			 (= (date-month date) 12)))]
+	[(funny-gauge%)
+	 (class canvas% (max-value parent)
+	   (inherit get-dc min-width min-height stretchable-width stretchable-height)
+	   (private
+	     [bitmap
+	      (make-object bitmap%
+		(build-path (collection-path "icons") "touch.bmp"))]
+	     [value 0])
+	   (public
+	     [set-value
+	      (lambda (new-value)
+		(let ([before-x
+		       (floor (* (send bitmap get-width) (/ value max-value)))]
+		      [after-x
+		       (ceiling (* (send bitmap get-width) (/ (- new-value value) max-value)))])
+		  (send (get-dc) draw-line
+			(+ before-x 2) 0
+			(+ after-x 2) 0)
+		  (send (get-dc) draw-line
+			(+ before-x 2) (+ (send bitmap get-height) 4)
+			(+ after-x 2) (+ (send bitmap get-height) 4))
+		  (send (get-dc) draw-bitmap-section bitmap
+			(+ 2 before-x) 2
+			before-x 0
+			after-x (send bitmap get-height)))
+		(set! value new-value))])
+	   (override
+	    [on-paint
+	     (lambda ()
+	       (let ([dc (get-dc)])
+		 (send dc clear)
+		 (send dc draw-rectangle 0 0
+		       (+ (send bitmap get-width) 4)
+		       (+ (send bitmap get-height) 4))
+		 (send dc draw-bitmap-section bitmap
+		       2 2 0 0
+		       (* (send bitmap get-width) (/ value max-value))
+		       (send bitmap get-height))))])
+	   (sequence
+	     (super-init parent)
+	     (min-width (+ (send bitmap get-width) 4))
+	     (min-height (+ (send bitmap get-height) 4))
+	     (stretchable-width #f)
+	     (stretchable-height #f)))]
 
-	 [(splitup-path)
-	  (lambda (f)
-	    (let*-values ([(absf) (if (relative-path? f)
-				      (build-path (current-directory) f)
-				      f)]
-			  [(base name _1) (split-path absf)])
+	[(splash-get-resource)
+	 (lambda (name default)
+	   (let ([b (box 0)])
+	     (if (get-resource "mred" name b #f)
+		 (unbox b)
+		 default)))]
+	[(set-resource)
+	 (lambda (name value)
+	   (write-resource "mred" name value (find-graphical-system-path 'setup-file))
+	   )]
+	[(_1)
+	 (begin
+	   (unless filename
+	     (no-splash))
+	   (unless (file-exists? filename)
+	     (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" filename)
+	     (no-splash)))]
 
-	      (if base
-		  (let-values ([(base2 name2 _2) (split-path base)])
-		    (if base2
-			(let-values ([(base3 name3 _2) (split-path base2)])
-			  (build-path name3 name2 name))
-			(build-path name2 name)))
-		  name)))]
+	[(splash-width-resource) (format "~a-splash-max-width" title)]
+	[(splash-max-width) (max 1 (splash-get-resource splash-width-resource width-default))]
+	
+	[(splash-current-width) 0]
 
-	 [(quit-on-close?) #t]
-	 [(dropped-files) null]
-	 [(get-dropped-files) (lambda () dropped-files)]
-	 [(splash-frame%)
-	  (class frame% (title)
-	    (override
-	     [on-drop-file
-	      (lambda (filename)
-		(set! dropped-files (cons filename dropped-files)))]
-	     [on-close
-	      (lambda ()
-		(when quit-on-close?
-		  (exit)))])
-	    (sequence (super-init title)))]
-	 [(frame) (parameterize ([current-eventspace (make-eventspace)])
-		    (make-object splash-frame% title))]
-	 [(_0) (send frame accept-drop-files #t)]
-	 [(bitmap-flag)
-	  (let ([len (string-length filename)])
-	    (if (<= len 4)
-		'guess
-		(let ([suffix (substring filename (- len 4) len)])
-		  (cond
-		   [(string-ci=? ".xpm" suffix) 'xpm]
-		   [(string-ci=? ".xbm" suffix) 'xbm]
-		   [(string-ci=? ".gif" suffix) 'gif]
-		   [(string-ci=? "pict" suffix) 'pict]
-		   [else 'xpm]))))]
-	 [(bitmap) (make-object bitmap% filename bitmap-flag)]
-	 [(_2) (unless (send bitmap ok?)
+	[(splitup-path)
+	 (lambda (f)
+	   (let*-values ([(absf) (if (relative-path? f)
+				     (build-path (current-directory) f)
+				     f)]
+			 [(base name _1) (split-path absf)])
+
+	     (if base
+		 (let-values ([(base2 name2 _2) (split-path base)])
+		   (if base2
+		       (let-values ([(base3 name3 _2) (split-path base2)])
+			 (build-path name3 name2 name))
+		       (build-path name2 name)))
+		 name)))]
+
+	[(quit-on-close?) #t]
+	[(dropped-files) null]
+	[(get-dropped-files) (lambda () dropped-files)]
+	[(splash-frame%)
+	 (class frame% (title)
+	   (override
+	    [on-drop-file
+	     (lambda (filename)
+	       (set! dropped-files (cons filename dropped-files)))]
+	    [on-close
+	     (lambda ()
+	       (when quit-on-close?
+		 (exit)))])
+	   (sequence (super-init title)))]
+	[(frame) (parameterize ([current-eventspace (make-eventspace)])
+		   (make-object splash-frame% title))]
+	[(_0) (send frame accept-drop-files #t)]
+	[(bitmap-flag)
+	 (let ([len (string-length filename)])
+	   (if (<= len 4)
+	       'guess
+	       (let ([suffix (substring filename (- len 4) len)])
+		 (cond
+		  [(string-ci=? ".xpm" suffix) 'xpm]
+		  [(string-ci=? ".xbm" suffix) 'xbm]
+		  [(string-ci=? ".gif" suffix) 'gif]
+		  [(string-ci=? "pict" suffix) 'pict]
+		  [else 'xpm]))))]
+	[(bitmap) (make-object bitmap% filename bitmap-flag)]
+	[(_2) (unless (send bitmap ok?)
 		(fprintf (current-error-port) "WARNING: bad bitmap ~s" filename)
 		(no-splash))]
-	 [(splash-canvas%)
-	  (class canvas% args
-	    (inherit get-dc)
-	    (override
-	     [on-paint
-	      (lambda ()
-		(send (get-dc) draw-bitmap bitmap 0 0))])
-	    (sequence
-	      (apply super-init args)))]
-	 [(panel) (make-object vertical-pane% frame)]
-	 [(logo-canvas) (make-object splash-canvas% panel)]
-	 [(h-panel) (make-object horizontal-pane% panel)]
-	 [(gauge)
-	  (if funny?
-	      (make-object funny-gauge% splash-max-width h-panel)
-	      (make-object gauge% #f splash-max-width h-panel '(horizontal)))]
-	 [(spacer) (make-object grow-box-spacer-pane% h-panel)]
-	 [(_3) (begin
-		 (send frame set-alignment 'center 'center)
-		 (send panel stretchable-width #f)
-		 (send panel stretchable-height #f)
-		 (send h-panel set-alignment 'center 'top)
-		 (send logo-canvas min-width (send bitmap get-width))
-		 (send logo-canvas min-height (send bitmap get-height))
-		 (send logo-canvas stretchable-width #f)
-		 (send logo-canvas stretchable-height #f)
-		 (send frame center 'both)
-		 (send frame show #t)
-		 (flush-display) (yield) (sleep)
-		 (flush-display) (yield) (sleep))]
-	 [(inc-splash)
-	  (lambda ()
-	    (set! splash-current-width (+ splash-current-width 1))
-	    (when (<= splash-current-width splash-max-width)
-	      (send gauge set-value splash-current-width)))]
-	 [(splash-load-handler)
-	  (lambda (old-load f)
-	    (let ([finalf (splitup-path f)])
-	      (inc-splash)
-	      (old-load f)))]
-	 [(_4) (current-load
-		(let ([old-load (current-load)])
-		  (lambda (f)
-		    (splash-load-handler old-load f))))]
-	 [(shutdown-splash)
-	  (lambda ()
-	    (set! splash-load-handler (lambda (old-load f) (old-load f))))]
-	 [(close-splash)
-	  (lambda ()
-	    (inc-splash)
-	    (unless (= splash-max-width splash-current-width)
-	      (set-resource splash-width-resource (max 1 splash-current-width)))
-	    (set! quit-on-close? #f)
-	    (send frame show #f))])
-      (values
-       get-dropped-files
-       shutdown-splash
-       close-splash))))
+	[(splash-canvas%)
+	 (class canvas% args
+	   (inherit get-dc)
+	   (override
+	    [on-paint
+	     (lambda ()
+	       (send (get-dc) draw-bitmap bitmap 0 0))])
+	   (sequence
+	     (apply super-init args)))]
+	[(panel) (make-object vertical-pane% frame)]
+	[(logo-canvas) (make-object splash-canvas% panel)]
+	[(h-panel) (make-object horizontal-pane% panel)]
+	[(gauge)
+	 (if funny?
+	     (make-object funny-gauge% splash-max-width h-panel)
+	     (make-object gauge% #f splash-max-width h-panel '(horizontal)))]
+	[(spacer) (make-object grow-box-spacer-pane% h-panel)]
+	[(_3) (begin
+		(send frame set-alignment 'center 'center)
+		(send panel stretchable-width #f)
+		(send panel stretchable-height #f)
+		(send h-panel set-alignment 'center 'top)
+		(send logo-canvas min-width (send bitmap get-width))
+		(send logo-canvas min-height (send bitmap get-height))
+		(send logo-canvas stretchable-width #f)
+		(send logo-canvas stretchable-height #f)
+		(send frame center 'both)
+		(send frame show #t)
+		(flush-display) (yield) (sleep)
+		(flush-display) (yield) (sleep))]
+	[(inc-splash)
+	 (lambda ()
+	   (set! splash-current-width (+ splash-current-width 1))
+	   (when (<= splash-current-width splash-max-width)
+	     (send gauge set-value splash-current-width)))]
+	[(splash-load-handler)
+	 (lambda (old-load f)
+	   (let ([finalf (splitup-path f)])
+	     (inc-splash)
+	     (old-load f)))]
+	[(_4) (current-load
+	       (let ([old-load (current-load)])
+		 (lambda (f)
+		   (splash-load-handler old-load f))))]
+	[(shutdown-splash)
+	 (lambda ()
+	   (set! splash-load-handler (lambda (old-load f) (old-load f))))]
+	[(close-splash)
+	 (lambda ()
+	   (inc-splash)
+	   (unless (= splash-max-width splash-current-width)
+	     (set-resource splash-width-resource (max 1 splash-current-width)))
+	   (set! quit-on-close? #f)
+	   (send frame show #f))])
+       (values
+	get-dropped-files
+	shutdown-splash
+	close-splash)))))

collects/framework/test.ss

@@ -1,18 +1,13 @@
-(require-relative-library "tests.ss")
+(module test mzscheme
+  (require (lib "unitsig.ss")
+	   "test-sig.ss"
+	   "test-unit.ss"
+	   (lib "mred-sig.ss" "mred")
+	   (lib "mred.ss" "mred"))
 
-(begin-elaboration-time
- (require-library "invoke.ss"))
-
-(define-values/invoke-unit/sig ((open mred^)
-				(unit keys : framework:keys^)
-				(unit test : framework:test^))
-  (compound-unit/sig
-   (import)
-   (link [mred : mred^ (mred@)]
-	 [keys : framework:keys^ ((require-relative-library "keys.ss"))]
-	 [test : framework:test^ ((require-relative-library "testr.ss") mred keys)])
-   (export
-    (unit test)
-    (unit keys)
-    (open mred))))
+  (provide-signature-elements framework:test^)
 
+  (define-values/invoke-unit/sig framework:test^
+    test@
+    #f
+    mred^))