...

original commit: 798c71780415bdcce317a03e3b4a4df08d51e0ff

collects/framework/finder.ss

@@ -0,0 +1,768 @@
+;;; finder.ss
+
+;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler 
+
+(unit/sig mred:finder^
+  (import mred^
+	  [preferences : framework:preferences^]
+	  [gui-utils : framework:gui-utils^]
+	  [mzlib:string : mzlib:string^]
+	  [mzlib:function : mzlib:function^]
+	  [mzlib:file : mzlib:file^])
+  
+  (define dialog-parent-parameter (make-parameter null))
+
+  (define filter-match?
+    (lambda (filter name msg)
+      (let-values ([(base name dir?) (split-path name)])
+	(if (mzlib:string:regexp-match-exact? filter name)
+	    #t
+	    (begin
+	      (message-box "Error" msg)
+	      #f)))))
+  
+  (define last-directory #f)
+  
+  (define make-relative
+    (lambda (s) s))
+  
+  (define current-find-file-directory
+    (opt-lambda ([dir 'get])
+      (cond
+	[(eq? dir 'get)
+	 (if (not last-directory)
+	     (set! last-directory (current-directory)))
+	 last-directory]
+	[(and (string? dir)
+	      (directory-exists? dir))
+	 (set! last-directory dir)
+	 #t]
+	[else #f])))
+  
+  (define build-updir
+    (lambda (dir)
+      (let-values ([(base _1 _2) (split-path dir)])
+	(or base dir))))
+  
+  
+  ; the finder-dialog% class controls the user interface for dialogs
+  
+  (define finder-dialog%
+    (class dialog-box% (parent-win
+			save-mode? 
+			replace-ok? 
+			multi-mode? 
+			result-box 
+			start-dir 
+			start-name 
+			prompt 
+			file-filter 
+			file-filter-msg)
+      
+      (inherit new-line tab fit center
+	       popup-menu show)
+      
+      (private
+	[WIDTH 500]
+	[HEIGHT 400]
+	dirs 
+	current-dir
+	last-selected
+	[select-counter 0])
+      
+      (private
+	
+	[set-directory ; sets directory in listbox 
+	 
+	 (lambda (dir) ; dir is normalized
+	   (when (directory-exists? dir)
+	     (gui-utils:show-busy-cursor
+	      (lambda ()
+		(set! current-dir dir)
+		(set! last-directory dir)
+		(let-values 
+		    ([(dir-list menu-list)
+		      (let loop ([this-dir dir]
+				 [dir-list ()]
+				 [menu-list ()])
+			(let-values ([(base-dir in-dir dir?) 
+				      (split-path this-dir)])
+			  (if (eq? (system-type) 'windows)
+			      (mzlib:string:string-lowercase! in-dir))
+			  (let* ([dir-list (cons this-dir dir-list)]
+				 [menu-list (cons in-dir menu-list)])
+			    (if base-dir
+				(loop base-dir dir-list menu-list)
+				; No more
+				(values dir-list menu-list)))))])
+		  (set! dirs (reverse dir-list))
+		  (send dir-choice clear)
+		  (let loop ([choices (reverse menu-list)])
+		    (unless (null? choices)
+		      (send dir-choice append (car choices))
+		      (loop (cdr choices))))
+		  (send dir-choice set-selection 0)
+		  (send top-panel force-redraw))
+		
+		(send name-list clear)
+		(send name-list set
+		      (mzlib:function:quicksort
+		       (let ([no-periods? 
+			      (not (preferences:get
+				    'framework:show-periods-in-dirlist))])
+			 (let loop ([l (directory-list dir)])
+			   (if (null? l)
+			       null
+			       (let ([s (car l)]
+				     [rest (loop (cdr l))])
+				 (cond
+				   [(and no-periods?
+					 (<= 1 (string-length s))
+					 (char=? (string-ref s 0) #\.))
+				    rest]
+				   [(directory-exists? (build-path dir s))
+				    (cons (string-append s (get-slash))
+					  rest)]
+				   [(or (not file-filter)
+					(mzlib:string:regexp-match-exact? 
+					 file-filter s))
+				    (cons s rest)]
+				   [else rest])))))
+		       (if (eq? (system-type) 'unix) string<? string-ci<?)))
+		(send name-list set-selection-and-edit 0)
+		(set! last-selected -1)))))]
+	
+	[set-edit
+	 (lambda ()
+	   (let* ([file (send name-list get-string-selection)]
+		  [dir-and-file 
+		   (if (null? file)
+		       current-dir
+		       (build-path current-dir file))])
+	     (send* directory-edit
+	       (begin-edit-sequence)
+	       (erase)
+	       (insert dir-and-file)
+	       (end-edit-sequence))))])
+      
+      (public
+	
+	[do-period-in/exclusion
+	 (lambda (button event)
+	   (preferences:set 'framework:show-periods-in-dirlist (send event checked?))
+	   (set-directory current-dir))]
+	
+	[do-dir
+	 (lambda (choice event)
+	   (let ([which (send event get-selection)])
+	     (if (< which (length dirs))
+		 (set-directory (list-ref dirs which)))))]
+	
+	[do-name
+	 (lambda (text event)
+	   (if (eq? (send event get-event-type)
+		    wx:const-event-type-text-enter-command)
+	       (do-ok)))]
+	
+	[do-name-list
+	 (lambda (_ event)
+	   (if (and (eq? (send event get-event-type)
+			 wx:const-event-type-listbox-command)
+		    (send event is-selection?))
+	       (set-edit)))]
+	
+	[do-result-list
+	 (lambda args #f)]
+	
+	[do-ok
+	 (lambda args
+
+	   (if multi-mode?
+
+	       (let ([dir-name (send directory-edit get-text)])
+		 (if (directory-exists? dir-name)
+		     (set-directory (mzlib:file:normalize-path dir-name))
+		     (let loop ([n (sub1 select-counter)][result ()])
+		       (if (< n 0)
+			   (begin
+			     (set-box! result-box result)
+			     (show #f))
+			   (loop (sub1 n) 
+				 (cons (send result-list get-string n)
+				       result))))))
+	       ; not multi-mode
+
+	       (let ([name (send name-list get-string-selection)]
+		     [non-empty? (> (send name-list number) 0)])
+
+		 (cond
+
+		   [(and save-mode? 
+			 non-empty?
+			 (not (string? name))) 'nothing-selected]
+
+		   [(and save-mode? 
+			 non-empty?
+			 (string=? name ""))
+		    (let ([file (send directory-edit get-text)])
+		      (if (directory-exists? file)
+			  (set-directory (mzlib:file:normalize-path file))
+			  (message-box 
+			   "Error"
+			   "You must specify a file name")))]
+
+		   [(and save-mode? 
+			 non-empty?
+			 file-filter 
+			 (not (mzlib:string:regexp-match-exact? file-filter name)))
+		    (message-box "Error" file-filter-msg)]
+
+		   [else
+		    
+		    ; if dir in edit box, go to that dir
+		    
+		    (let ([dir-name (send directory-edit get-text)])
+		      
+		      (if (directory-exists? dir-name)
+			  (set-directory (mzlib:file:normalize-path dir-name))
+			  
+			  ; otherwise, try to return absolute path
+			  
+			  (let* ([relative-name (make-relative name)]
+				 [file-in-edit (file-exists? dir-name)]
+				 [file (if (or file-in-edit
+					       (null? relative-name)
+					       save-mode?)
+					   dir-name
+					   (build-path current-dir relative-name))])
+			    
+			    ; trying to open a file that doesn't exist
+			    
+			    (if (and (not save-mode?) (not file-in-edit))
+				(message-box 
+				 "Error"
+				 (string-append "The file \"" 
+						dir-name
+						"\" does not exist."))
+				
+				; saving a file, which may exist, or
+				; opening an existing file
+				
+				(if (or (not save-mode?)
+					(not (file-exists? file))
+					replace-ok?
+					(= (wx:message-box
+					    (string-append
+					     "The file " 
+					     file
+					     " already exists. "
+					     "Replace it?")
+					    "Warning"
+					    wx:const-yes-no)
+					   wx:const-yes))
+				    (let ([normal-path
+					   (with-handlers 
+					       ([(lambda (_) #t)
+						 (lambda (_)
+						   (wx:message-box
+						    (string-append
+						     "The file " 
+						     file
+						     " contains nonexistent directory or cycle.") 
+						    "Warning")
+						   #f)])
+					     (mzlib:file:normalize-path file))])
+				      (when normal-path 
+					(set-box! result-box normal-path)
+					(show #f))))))))]))))]
+	
+	[add-one
+	 (lambda (name)
+	   (unless (or (directory-exists? name)
+		       (> (send result-list find-string name) -1))
+	     (set! select-counter (add1 select-counter))
+	     (send result-list append (mzlib:file:normalize-path name))))]
+	
+	[do-add
+	 (lambda args
+	   (let ([name (send name-list get-string-selection)])
+	     (if (string? name)
+		 (let ([name (build-path current-dir
+					 (make-relative name))])
+		   (add-one name)))))]
+	
+	[do-add-all
+	 (lambda args
+	   (let loop ([n 0])
+	     (let ([name (send name-list get-string n)])
+	       (if (and (string? name)
+			(positive? (string-length name)))
+		   (let ([name (build-path current-dir
+					   (make-relative name))])
+		     (add-one name)
+		     (loop (add1 n)))))))]
+	
+	[do-remove
+	 (lambda args
+	   (let loop ([n 0])
+	     (if (< n select-counter)
+		 (if (send result-list selected? n)
+		     (begin
+		       (send result-list delete n)
+		       (set! select-counter (sub1 select-counter))
+		       (loop n))
+		     (loop (add1 n))))))]
+	
+	[do-cancel
+	 (lambda args
+	   (set-box! result-box #f)
+	   (show #f))]
+	
+	[on-close (lambda () #f)])
+      
+      (sequence
+	(super-init (if save-mode? "Put file" "Get file")
+		    parent-win 
+		    WIDTH 
+		    HEIGHT))
+      
+      (private
+	
+	[main-panel (make-object vertical-panel% this)]
+	
+	[top-panel (make-object horizontal-panel% main-panel)]
+	
+	[_1 (make-object message% top-panel prompt)]
+	
+	[dir-choice (make-object choice% top-panel do-dir '())]
+	
+	[middle-panel (make-object horizontal-panel% main-panel)]
+	[left-middle-panel (make-object vertical-panel% middle-panel)]
+	[right-middle-panel (when multi-mode? 
+			      (make-object vertical-panel% middle-panel))]
+	[name-list%
+	 
+	 (class-asi list-box%
+	   
+	   (inherit 
+	     get-first-item
+	     get-string
+	     get-selection
+	     get-string-selection
+	     number
+	     number-of-visible-items
+	     set-first-item
+	     set-focus
+	     set-selection)
+	   
+	   (public
+	     
+	     [set-selection-and-edit ; set selection, update edit box
+	      
+	      (lambda (pos)
+		(when (> (number) 0)
+		  (let* ([first-item (get-first-item)]
+			 [last-item (sub1 (+ (number-of-visible-items) 
+					     first-item))])
+		    (if (or (< pos first-item) (> pos last-item))
+			(set-first-item pos))
+		    (set-selection pos)))
+		(set-edit))]
+	     
+	     [pre-on-char ; set selection according to keystroke
+	      
+	      (lambda (_ key) 
+		(let ([code (send key get-key-code)]
+		      [num-items (number)]
+		      [curr-pos (get-selection)])
+		  
+		  (cond 
+		    
+		    [(and (char? code)
+			  (or (char=? code #\newline)
+			      (char=? code #\return)))     ; CR or LF
+		     (do-ok)]
+		    
+		    [(and (char? code)
+			  (char=? code #\tab))
+		     (set-focus-to-directory-edit)]
+		    
+		    ; look for letter at beginning of a filename
+		    
+		    [(char? code)
+		     (letrec 
+			 ([loop
+			   (lambda (pos)
+			     (unless 
+				 (>= pos num-items)
+			       (let ([first-char (string-ref (get-string pos) 0)])
+				 (if (char=? code first-char)
+				     (set-selection-and-edit pos)
+				     (loop (add1 pos))))))])
+		       (loop (add1 curr-pos)))]
+		    
+		    ; movement keys
+		    
+		    [(and (eq? code 'up) 
+			  (> curr-pos 0))
+		     (set-selection-and-edit (sub1 curr-pos))]
+		    
+		    [(and (eq? code 'down)
+			  (< curr-pos (sub1 num-items)))
+		     (let* ([num-vis (number-of-visible-items)] 
+			    [curr-first (get-first-item)]
+			    [new-curr-pos (add1 curr-pos)]
+			    [new-first (if (< new-curr-pos (+ curr-first num-vis))
+					   curr-first ; no scroll needed
+					   (add1 curr-first))])
+		       (set-first-item new-first)
+		       (set-selection-and-edit new-curr-pos))]
+		    
+		    [(and (eq? code 'prior)
+			  (> curr-pos 0))
+		     (let* ([num-vis (number-of-visible-items)]
+			    [new-first (- (get-first-item) num-vis)])
+		       (set-first-item (max new-first 0))
+		       (set-selection-and-edit (max 0 (- curr-pos num-vis))))]
+		    
+		    [(and (eq? code 'next)
+			  (< curr-pos (sub1 num-items)))
+		     (let* ([num-vis (number-of-visible-items)]
+			    [new-first (+ (get-first-item) num-vis)])
+		       (set-first-item (min new-first (- (number) num-vis)))
+		       (set-selection-and-edit 
+			(min (sub1 num-items) (+ curr-pos num-vis))))]
+		    
+		    [else #f])))]
+	     
+	     [on-default-action
+	      (lambda ()
+		(when (> (send name-list number) 0)
+		      (let* ([which (send name-list get-string-selection)]
+			     [dir (build-path current-dir
+					      (make-relative which))])
+			(if (directory-exists? dir)
+			    (set-directory (mzlib:file:normalize-path dir))
+			    (if multi-mode?
+				(do-add)
+				(do-ok))))))]))]
+	
+	[name-list (make-object name-list%
+				#f left-middle-panel do-name-list
+				'(single))]
+	
+	[set-focus-to-name-list
+	 (lambda ()
+	   (send name-list set-focus))]
+	[set-focus-to-directory-edit
+	 (lambda ()
+	   (send directory-panel set-focus))]
+	
+	[save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
+	
+	[directory-panel (make-object horizontal-panel% main-panel)]
+	
+	[directory-edit 
+	 (make-object (class-asi text%
+			(rename [super-on-local-char on-local-char])
+			(public
+			  [on-local-char
+			   (lambda (key)
+			     (let ([code (send key get-key-code)])
+			       (cond
+				 [(or (equal? code #\return)
+				      (equal? code #\newline))
+				  (do-ok)
+				  (set-focus-to-name-list)]
+				 [(equal? code #\tab)
+				  (set-focus-to-name-list)]
+				 [else
+				  (super-on-local-char key)])))])))]
+	
+	[dot-panel (when (eq? 'unix (system-type))
+		     (make-object horizontal-panel% main-panel))]
+	
+	[bottom-panel (make-object horizontal-panel% main-panel)]
+	
+	[result-list
+	 (when multi-mode?
+	   (make-object list-box%
+			#f
+			do-result-list
+			right-middle-panel
+			void
+			'(multiple)))]
+	[add-panel 
+	 (when multi-mode? 
+	   (make-object horizontal-panel% left-middle-panel))]
+	
+	[remove-panel 
+	 (when multi-mode? 
+	   (make-object horizontal-panel% right-middle-panel))]
+	
+	[do-updir
+	 (lambda () 
+	   (set-directory (build-updir current-dir))
+	   (set-focus-to-name-list))
+	 ])
+      
+      (sequence
+	
+	(when (eq? (system-type) 'unix)
+	  (let ([dot-cb
+		 (make-object 
+		  check-box% dot-panel
+		  do-period-in/exclusion
+		  "Show files and directories that begin with a dot")])
+	    (send dot-panel stretchable-in-y #f)
+	    (send dot-cb set-value 
+		  (preferences:get 'framework:show-periods-in-dirlist))))
+	
+	(send directory-panel stretchable-in-y #f)
+	
+	(let ([canvas (make-object editor-canvas% directory-panel #f
+				   (list 'hide-h-scroll 'v-scroll))])
+	  
+	  (send* canvas
+	    (set-line-count 1)
+	    (set-media directory-edit)
+	    (set-focus)
+	    (user-min-height 20)))
+	
+	(when multi-mode?
+	  (send add-panel stretchable-in-y #f)
+	  (send remove-panel stretchable-in-y #f)
+	  (send result-list stretchable-in-x #t))
+	
+	(make-object button% 
+		     "Up directory"
+		     top-panel
+		     (lambda (button evt) (do-updir)))
+	
+	(send name-list stretchable-in-x #t)
+	
+	(send top-panel stretchable-in-y #f)
+	
+	(send bottom-panel stretchable-in-y #f)
+	
+	(when save-mode?
+	  (send save-panel stretchable-in-y #f)))
+      
+      (private
+	
+	[add-button (when multi-mode?
+		      (make-object horizontal-panel% add-panel)
+		      (make-object button%
+				   "Add"
+				   add-panel
+				   do-add))]
+	[add-all-button (when multi-mode?
+			  (begin0
+			    (make-object button%
+					 "Add all"
+					 add-panel do-add-all)
+			    (make-object horizontal-panel% add-panel)))]
+	[remove-button (when multi-mode?
+			 (make-object horizontal-panel% remove-panel)
+			 (begin0
+			   (make-object button% "Remove" remove-panel do-remove)
+			   (make-object horizontal-panel% remove-panel)))])
+      (sequence
+	(make-object vertical-panel% bottom-panel)) 
+      (private
+	[cancel-button (make-object button% "Cancel" bottom-panel do-cancel)]
+	[ok-button
+	 (make-object button%
+				"OK"
+				bottom-panel do-ok)])
+      (sequence
+	(cond
+	  [(and start-dir
+		(not (null? start-dir))
+		(directory-exists? start-dir))
+	   (set-directory (mzlib:file:normalize-path start-dir))]
+	  [last-directory (set-directory last-directory)]
+	  [else (set-directory (current-directory))])
+	
+	(send ok-button min-width (send cancel-button get-width))
+	
+	(center 'both)
+	
+	(show #t))))
+  
+  ; make-common takes a dialog-maker
+  ; used to make one dialog object per session, now created each time
+  
+  (define make-common
+    (lambda (make-dialog)
+      (lambda args
+	(let ([result-box (box #f)])
+	  (apply make-dialog result-box args)
+	  (unbox result-box)))))
+  
+  ; the common versions of these functions have their visual
+  ; interfaces under Scheme control
+  
+  (define common-put-file
+    (make-common
+     (opt-lambda (result-box 
+		  [name ()]
+		  [directory ()]
+		  [replace? #f]
+		  [prompt "Select file"]
+		  [filter #f]
+		  [filter-msg "Invalid form"]
+		  [parent-win (dialog-parent-parameter)])
+       (let* ([directory (if (and (null? directory)
+				  (string? name))
+			     (or (mzlib:file:path-only name) null)
+			     directory)]
+	      [name (or (and (string? name)
+			     (mzlib:file:file-name-from-path name))
+			name)])
+	 (make-object finder-dialog% 
+		      parent-win
+		      #t 
+		      replace? 
+		      #f 
+		      result-box 
+		      directory 
+		      name 
+		      prompt 
+		      filter 
+		      filter-msg)))))
+  
+  (define common-get-file
+    (make-common
+     (opt-lambda
+	 (result-box 
+	  [directory ()]
+	  [prompt "Select file"]
+	  [filter #f]
+	  [filter-msg "Bad name"]
+	  [parent-win (dialog-parent-parameter)])
+       (make-object finder-dialog% 
+		    parent-win   ; parent window
+		    #f           ; save-mode?
+		    #f           ; replace-ok?
+		    #f           ; multi-mode?
+		    result-box   ; boxed results
+		    directory    ; start-dir
+		    '()          ; start-name
+		    prompt       ; prompt
+		    filter       ; file-filter
+		    filter-msg   ; file-filter-msg
+		    ))))
+  
+  (define common-get-file-list
+    (make-common
+     (opt-lambda (result-box 
+		  [directory ()]
+		  [prompt "Select files"]
+		  [filter #f]
+		  [filter-msg "Bad name"]
+		  [parent-win (dialog-parent-parameter)])
+       (make-object 
+	finder-dialog% 
+	parent-win  ; parent window
+	#f          ; save-mode?
+	#f          ; replace-ok?
+	#t          ; multi-mode?
+	result-box  ; boxed results
+	directory   ; directory
+	'()         ; start-name
+	prompt      ; prompt
+	filter      ; file-filter
+	filter-msg  ; file-filter-msg
+	))))
+  
+  ; the std- and common- forms both have opt-lambda's, with the same
+  ; list of args.  Should the opt-lambda's be placed in the dispatching function?
+  
+  (define std-put-file
+    (opt-lambda ([name ()]
+		 [directory ()]
+		 [replace? #f]
+		 [prompt "Select file"]
+		 [filter #f]
+		 [filter-msg "That filename does not have the right form."]
+		 [parent-win (dialog-parent-parameter)])
+      (let* ([directory (if (and (null? directory)
+				 (string? name))
+			    (or (mzlib:file:path-only name) null)
+			    directory)]
+	     [name (or (and (string? name)
+			    (mzlib:file:file-name-from-path name))
+		       name)]
+	     [f (wx:put-file 
+		 prompt 
+		 parent-win
+		 directory 
+		 name
+		 ".ss")])
+	(if (or (null? f)
+		(and filter 
+		     (not (filter-match? filter 
+					 f
+					 filter-msg))))
+	    #f
+	    (let* ([f (mzlib:file:normalize-path f)]
+		   [dir (mzlib:file:path-only f)]
+		   [name (mzlib:file:file-name-from-path f)])
+	      (cond
+		[(not (and (string? dir) (directory-exists? dir)))
+		 (message-box "That directory does not exist." "Error")
+		 #f]
+		[(or (not name) (equal? name ""))
+		 (message-box "Empty filename." "Error")
+		 #f]
+		[else f]))))))
+  
+  (define std-get-file
+    (opt-lambda ([directory ()]
+		 [prompt "Select file"]
+		 [filter #f]
+		 [filter-msg "That filename does not have the right form."]
+		 [parent-win (dialog-parent-parameter)])
+      (let ([f (wx:file-selector 
+		prompt 
+		directory 
+		null 
+		null 
+		"*"
+		wx:const-open 
+		parent-win)])
+	(if (null? f)
+	    #f
+	    (if (or (not filter) (filter-match? filter f filter-msg))
+		(let ([f (mzlib:file:normalize-path f)])
+		  (cond
+		    [(directory-exists? f)
+		     (message-box "That is a directory name." "Error")
+		     #f]
+		    [(not (file-exists? f))
+		     (message-box "File does not exist.")
+		     #f]
+		    [else f]))
+		#f)))))
+  
+  ; external interfaces to file functions
+  
+  (define put-file
+    (lambda args
+      (let ([actual-fun 
+	     (case (preferences:get 'framework:file-dialogs)
+	       [(std) std-put-file]
+	       [(common) common-put-file])])
+	(apply actual-fun args))))
+  
+  (define get-file
+    (lambda args
+      (let ([actual-fun
+	     (case (preferences:get 'framework:file-dialogs)
+	       [(std) std-get-file]
+	       [(common) common-get-file])])
+	(apply actual-fun args)))))
+
+
+

collects/framework/group.ss

@@ -45,3 +45,237 @@ when adding a frame, do this:
 			  (set-close-menu-item-state! a-frame #t)))))
 
 
+(unit/sig mred:group^
+  (import [mred:preferences : mred:preferences^]
+	  [mred:editor-frame : mred:editor-frame^]
+	  [mred:gui-utils : mred:gui-utils^]
+	  [mred:exit : mred:exit^]
+	  [mred:autosave : mred:autosave^]
+	  [mred:handler : mred:handler^]
+	  [mzlib:function : mzlib:function^]
+	  [mzlib:file : mzlib:file^])
+  
+  (mred:debug:printf 'invoke "mred:group@")
+  
+  (define frame-group%
+    (let-struct frame (frame id)
+      (class null ()
+	(private
+	  [active-frame #f]
+	  [frame-counter 0]
+	  [frames null]
+	  [todo-to-new-frames void]
+	  [empty-close-down (lambda () (void))]
+	  [empty-test (lambda () #t)]
+	  
+	  [windows-menus null])
+	
+	(private
+	  [get-windows-menu
+	   (lambda (frame)
+	     (and (ivar-in-class? 'windows-menu (object-class frame))
+		  (ivar frame windows-menu)))]
+	  [insert-windows-menu
+	   (lambda (frame)
+	     (let ([menu (get-windows-menu frame)])
+	       (when menu
+		 (set! windows-menus (cons (list menu) windows-menus)))))]
+	  [remove-windows-menu
+	   (lambda (frame)
+	     (let* ([menu (get-windows-menu frame)])
+	       (set! windows-menus
+		     (mzlib:function:remove
+		      menu
+		      windows-menus
+		      (lambda (x y)
+			(eq? x (car y)))))))]
+
+	  [update-windows-menus
+	   (lambda ()
+	     (let* ([windows (length windows-menus)]
+		    [get-name (lambda (frame) (send (frame-frame frame) get-title))]
+		    [sorted-frames
+		     (mzlib:function:quicksort
+		      frames
+		      (lambda (f1 f2)
+			(string-ci<=? (get-name f1)
+				      (get-name f2))))])
+	       (set!
+		windows-menus
+		(map
+		 (lambda (menu-list)
+		   (let ([menu (car menu-list)]
+			 [old-ids (cdr menu-list)])
+		     (for-each (lambda (id) (send menu delete id))
+			       old-ids)
+		     (let ([new-ids
+			    (map
+			     (lambda (frame)
+			       (let ([frame (frame-frame frame)]
+				     [default-name "Untitled"])
+				 (send menu append-item
+				       (let ([title (send frame get-title)])
+					 (if (string=? title "")
+					     (if (ivar-in-class? 'get-entire-title (object-class frame))
+						 (let ([title (send frame get-entire-title)])
+						   (if (string=? title "")
+						       default-name
+						       title))
+						 default-name)
+					     title))
+				       (lambda ()
+					 (send frame show #t)))))
+			     sorted-frames)])
+		       (cons menu new-ids))))
+		 windows-menus))))])
+	       
+	
+	(public
+	  [set-empty-callbacks 
+	   (lambda (test close-down) 
+	     (set! empty-test test)
+	     (set! empty-close-down close-down))]
+	  [get-frames (lambda () (map frame-frame frames))]
+	  [frame% mred:editor-frame:editor-frame%]
+	  [get-frame% (lambda () frame%)]
+	  
+	  [frame-title-changed
+	   (lambda (frame)
+	     (when (member frame (map frame-frame frames))
+	       (update-windows-menus)))]
+	  
+	  [for-each-frame
+	   (lambda (f)
+	     (for-each (lambda (x) (f (frame-frame x))) frames)
+	     (set! todo-to-new-frames
+		   (let ([old todo-to-new-frames])
+		     (lambda (frame) (old frame) (f frame)))))]
+	  [get-active-frame
+	   (lambda ()
+	     (cond
+	       [active-frame active-frame]
+	       [(null? frames) #f]
+	       [else (frame-frame (car frames))]))]
+	  [set-active-frame
+	   (lambda (f)
+	     (set! active-frame f))]
+	  [insert-frame
+	   (lambda (f)
+	     (set! frame-counter (add1 frame-counter))
+	     (let ([new-frames (cons (make-frame f frame-counter)
+				     frames)])
+	       (set! frames new-frames)
+	       (insert-windows-menu f)
+	       (update-windows-menus))
+	     (todo-to-new-frames f))]
+	  
+	  [can-remove-frame?
+	   (opt-lambda (f)
+	     (let ([new-frames 
+		    (mzlib:function:remove
+		     f frames
+		     (lambda (f fr) (eq? f (frame-frame fr))))])
+	       (if (null? new-frames)
+		   (empty-test)
+		   #t)))]
+	  [remove-frame
+	   (opt-lambda (f)
+	     (when (eq? f active-frame)
+	       (set! active-frame #f))
+	     (let ([new-frames
+		    (mzlib:function:remove
+		     f frames
+		     (lambda (f fr) (eq? f (frame-frame fr))))])
+	       (set! frames new-frames)
+	       (remove-windows-menu f)
+	       (update-windows-menus)
+	       (when (null? frames)
+		 (empty-close-down))))]
+	  [clear
+	   (lambda ()
+	     (and (empty-test)
+		  (begin (set! frames null)
+			 (empty-close-down)
+			 #t)))]
+	  [close-all
+	   (lambda ()
+	     (let/ec escape
+	       (for-each (lambda (f)
+			   (let ([frame (frame-frame f)])
+			     (if (send frame on-close)
+				 (send frame show #f)
+				 (escape #f))))
+			 frames)
+	       #t))]
+	  [new-frame
+	   (lambda (filename)
+	     (if (string? filename)
+		 (mred:handler:edit-file filename this #f
+					 (lambda (fn group)
+					   (make-object (get-frame%)
+							fn #t group)))
+		 (make-object (get-frame%) filename #t this)))]
+	  [locate-file
+	   (lambda (name)
+	     (let* ([normalized
+		     ;; allow for the possiblity of filenames that are urls
+		     (with-handlers ([(lambda (x) #t)
+				      (lambda (x) name)])
+		       (mzlib:file:normalize-path name))]
+		    [test-frame
+		     (lambda (frame)
+		       (and (ivar-in-class? 'get-edit (object-class frame))
+			    (let* ([edit (send frame get-edit)]
+				   [filename (send edit get-filename)])
+			      (and (ivar edit editing-this-file?)
+				   (string? filename)
+				   (string=? normalized
+					     (with-handlers ([(lambda (x) #t)
+							      (lambda (x) filename)])
+					       (mzlib:file:normalize-path 
+						filename)))))))])
+	       (let loop ([frames frames])
+		 (cond
+		   [(null? frames) #f]
+		   [else
+		    (let* ([frame (frame-frame (car frames))])
+		      (if (test-frame frame)
+			  frame
+			  (loop (cdr frames))))]))))]))))
+  
+  (define the-frame-group (make-object frame-group%))
+  
+  (define at-most-one-maker
+    (lambda ()
+      (let ([s (make-semaphore 1)]
+	    [test #f])
+	(lambda (return thunk)
+	  (semaphore-wait s)
+	  (if test
+	      (begin (semaphore-post s)
+		     return)
+	      (begin
+		(set! test #t)
+		(semaphore-post s)
+		(begin0 (thunk)
+			(semaphore-wait s)
+			(set! test #f)
+			(semaphore-post s))))))))
+  
+  (define at-most-one (at-most-one-maker))
+  
+  (send the-frame-group set-empty-callbacks
+	(lambda () 
+	  (at-most-one (void) 
+		       (lambda () (mred:exit:exit #t))))
+	(lambda () 
+	  (at-most-one #t
+		       (lambda ()
+			 (mred:exit:run-exit-callbacks)))))
+  
+  (mred:exit:insert-exit-callback
+   (lambda ()
+     (at-most-one
+      #t
+      (lambda ()
+	(send the-frame-group close-all))))))

collects/framework/main.ss

@@ -4,22 +4,31 @@
   
   ;; preferences
 
-  (preferences:set-default 'mred:autosave-delay 300 number?)
+  (preferences:set-default 'framework:autosave-delay 300 number?)
-  (preferences:set-default 'mred:autosaving-on? #t 
+  (preferences:set-default 'framework:autosaving-on? #t 
 					   (lambda (x)
 					     (or (not x)
 						 (eq? x #t))))
-  (preferences:set-default 'mred:verify-exit #t
+  (preferences:set-default 'framework:verify-exit #t
 			   (lambda (x)
 			     (or (not x)
 				 (eq? x #t))))
-  
+  (preferences:set-default 'framework:delete-forward? 
-
-  (preferences:set-default 'mred:delete-forward? 
 			   (not (eq? (system-type) 'unix))
 			   (lambda (x)
 			     (or (not x)
 				 (eq? x #t))))
+  (preferences:set 'framework:show-periods-in-dirlist #f
+		   (lambda (x)
+		     (or (not x)
+			 (eq? x #t))))
+  (preferences:set 'framework:file-dialogs
+		   (if (eq? wx:platform 'unix)
+		       'common
+		       'std)
+		   (lambda (x)
+		     (or (eq? x 'common)
+			 (eq? x 'std))))
   
   (preferences:read)