diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 3010f372..a990dd54 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -621,7 +621,7 @@ (union false? regexp?) string? (union false? (is-a?/c top-level-window<%>))) - (union string? false?)) + (union (listof string?) false?)) (() ((directory #f) (prompt "Select File") diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index c6af5592..a3f0e5a7 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -4,7 +4,6 @@ (lib "unitsig.ss") "sig.ss" "../gui-utils.ss" - (lib "class100.ss") (lib "class.ss") (lib "mred-sig.ss" "mred") (lib "string.ss") @@ -51,552 +50,526 @@ ; the finder-dialog% class controls the user interface for dialogs (define finder-dialog% - (class100 dialog% (parent-win - _save-mode? - _replace-ok? - _multi-mode? - _result-box - start-dir - start-name - prompt - _file-filter - _file-filter-msg) + (class dialog% + (init parent-win) + (init-field save-mode?) + (init-field replace-ok?) + (init-field multi-mode?) + (init-field result-box) + (init start-dir) + (init start-name) + (init prompt) + (init-field file-filter) + (init-field file-filter-msg) (inherit center show) - - (private-field - [replace-ok? _replace-ok?] - [file-filter-msg _file-filter-msg] - [save-mode? _save-mode?] - [result-box _result-box] - [multi-mode? _multi-mode?] - [file-filter _file-filter]) - (private-field - [default-width 500] - [default-height 400] - dirs - current-dir - last-selected) + (define default-width 500) + (define default-height 400) + (define dirs #f) + (define current-dir #f) - (private - [set-listbox-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 null] - [menu-list null]) - (let-values ([(base-dir in-dir dir?) - (split-path this-dir)]) - (if (eq? (system-type) 'windows) - (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 name-list clear) - (send name-list set - (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 s rest)] - [(or (not file-filter) - (regexp-match-exact? file-filter s)) - (cons s rest)] - [else rest]))))) - ;(if (eq? (system-type) 'unix) string (send name-list get-number) 0)]) - - (cond - - [(and save-mode? - non-empty? - (not (string? name))) 'nothing-selected] - - [(and save-mode? - non-empty? - (string=? name "")) - (let ([file (send directory-field get-value)]) - (if (directory-exists? file) - (set-listbox-directory (normal-case-path (normalize-path file))) - (message-box - (string-constant error) - (string-constant must-specify-a-filename))))] - - [(and save-mode? - non-empty? - file-filter - (not (regexp-match-exact? file-filter name))) - (message-box (string-constant error) file-filter-msg)] - - [else - - ; if dir in edit box, go to that dir - - (let ([dir-name (send directory-field get-value)]) - - (if (directory-exists? dir-name) - (set-listbox-directory (normal-case-path (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 - (not 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 - (string-constant error) - (format (string-constant file-does-not-exist) dir-name)) - - ; saving a file, which may exist, or - ; opening an existing file - - (if (or (not save-mode?) - (not (file-exists? file)) - replace-ok? - (eq? (message-box - (string-constant warning) - (format - (string-constant ask-because-file-exists) - file) - #f - '(yes-no)) - 'yes)) - (let ([normal-path - (with-handlers - ([(lambda (_) #t) - (lambda (_) - (message-box - (string-constant warning) - (format - (string-constant dne-or-cycle) - file)) - #f)]) - (normal-case-path - (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)) - (send result-list append - (normal-case-path (normalize-path name)))))] - - [do-add - (lambda () - (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 () - (let loop ([n 0]) - (when (< n (send name-list get-number)) - (let ([name (send name-list get-string n)]) - (let ([name (build-path current-dir - (make-relative name))]) - (add-one name) - (loop (add1 n)))))))] - - [do-remove - (lambda () - (let loop ([n 0]) - (if (< n (send result-list get-number)) - (if (send result-list is-selected? n) - (begin - (send result-list delete n) - (loop n)) - (loop (add1 n))))))] - - [do-cancel - (lambda () - (set-box! result-box #f) - (show #f))]) + (send name-list clear) + (send name-list set + (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 s rest)] + [(or (not file-filter) + (regexp-match-exact? file-filter s)) + (cons s rest)] + [else rest]))))) + ;(if (eq? (system-type) 'unix) string= pos num-items) #f] - [else - (let ([first-char (string-ref (get-string pos) 0)]) - (if (char-ci=? code first-char) - pos - (loop (add1 pos))))]))]) - (if next-matching - (set-selection-and-edit next-matching) + (let loop ([n (sub1 (send result-list get-number))] + [result null]) + (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 get-number) 0)]) + + (cond + + [(and save-mode? + non-empty? + (not (string? name))) 'nothing-selected] + + [(and save-mode? + non-empty? + (string=? name "")) + (let ([file (send directory-field get-value)]) + (if (directory-exists? file) + (set-listbox-directory (normal-case-path (normalize-path file))) + (message-box + (string-constant error) + (string-constant must-specify-a-filename))))] + + [(and save-mode? + non-empty? + file-filter + (not (regexp-match-exact? file-filter name))) + (message-box (string-constant error) file-filter-msg)] + + [else + + ; if dir in edit box, go to that dir + + (let ([dir-name (send directory-field get-value)]) + + (if (directory-exists? dir-name) + (set-listbox-directory (normal-case-path (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 + (not relative-name) + save-mode?) + dir-name + (build-path current-dir relative-name))]) - ;; didn't find anything forward; start again at front of list - (let loop ([pos 0] - [last-before 0]) - (cond - [(<= pos num-items) - (let ([first-char (string-ref (get-string pos) 0)]) - (cond - [(char-ci=? code first-char) - (set-selection-and-edit pos)] - [(char-ci<=? first-char code) - (loop (+ pos 1) - pos)] - [else - (set-selection-and-edit last-before)]))] - [else (set-selection-and-edit last-before)]))))] - - ; 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-visible-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-visible-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-visible-item) num-vis)]) - (set-first-visible-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-visible-item) num-vis)]) - (set-first-visible-item - (min new-first (- (get-number) num-vis))) - (set-selection-and-edit - (min (sub1 num-items) (+ curr-pos num-vis))))] - - [else #f])))]) - - (public - [set-selection-and-edit - (lambda (pos) - (when (> (get-number) 0) - (let* ([first-item (get-first-visible-item)] - [last-item (sub1 (+ (number-of-visible-items) - first-item))]) - (if (or (< pos first-item) (> pos last-item)) - (set-first-visible-item pos)) - (set-selection pos))) - (set-edit))] - [on-default-action - (lambda () - (when (> (get-number) 0) - (let* ([which (get-string-selection)] - [dir (build-path current-dir - (make-relative which))]) - (if (directory-exists? dir) - (set-listbox-directory (normal-case-path - (normalize-path dir))) - (if multi-mode? - (do-add) - (do-ok))))))]))] - - [name-list (make-object name-list% - #f null left-middle-panel (lambda (x y) (do-name-list x y)) - '(single))] - - [save-panel (when save-mode? (make-object horizontal-panel% main-panel))] - - [directory-panel (make-object horizontal-panel% main-panel)] - - [dot-panel (when (eq? 'unix (system-type)) - (make-object horizontal-panel% main-panel))] - - [bottom-panel (make-object horizontal-panel% main-panel)] - - [directory-field - (keymap:call/text-keymap-initializer - (lambda () - (make-object text-field% - (string-constant full-pathname) - directory-panel - (lambda (txt evt) - (when (eq? (send evt get-event-type) 'text-field-enter) - (let ([dir (send directory-field get-value)]) - (if (directory-exists? dir) - (set-listbox-directory (normal-case-path - (normalize-path dir))) - (if multi-mode? - (do-add) - (do-ok)))))))))] - - [result-list - (when multi-mode? - (make-object list-box% - #f - null - right-middle-panel - (lambda (x y) (do-result-list)) - '(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-listbox-directory (build-updir current-dir)) - (set-focus-to-name-list))]) + ; trying to open a file that doesn't exist + + (if (and (not save-mode?) (not file-in-edit)) + (message-box + (string-constant error) + (format (string-constant file-does-not-exist) dir-name)) + + ; saving a file, which may exist, or + ; opening an existing file + + (if (or (not save-mode?) + (not (file-exists? file)) + replace-ok? + (eq? (message-box + (string-constant warning) + (format + (string-constant ask-because-file-exists) + file) + #f + '(yes-no)) + 'yes)) + (let ([normal-path + (with-handlers + ([(lambda (_) #t) + (lambda (_) + (message-box + (string-constant warning) + (format + (string-constant dne-or-cycle) + file)) + #f)]) + (normal-case-path + (normalize-path file)))]) + (when normal-path + (set-box! result-box normal-path) + (show #f))))))))]))))] - (private - [set-focus-to-name-list - (lambda () - (send name-list focus))]) + [define/public add-one + (lambda (name) + (unless (or (directory-exists? name) + (send result-list find-string name)) + (send result-list append + (normal-case-path (normalize-path name)))))] + + [define/public do-add + (lambda () + (let ([name (send name-list get-string-selection)]) + (if (string? name) + (let ([name (build-path current-dir + (make-relative name))]) + (add-one name)))))] + + [define/public do-add-all + (lambda () + (let loop ([n 0]) + (when (< n (send name-list get-number)) + (let ([name (send name-list get-string n)]) + (let ([name (build-path current-dir + (make-relative name))]) + (add-one name) + (loop (add1 n)))))))] + + [define/public do-remove + (lambda () + (let loop ([n 0]) + (if (< n (send result-list get-number)) + (if (send result-list is-selected? n) + (begin + (send result-list delete n) + (loop n)) + (loop (add1 n))))))] + + [define/public do-cancel + (lambda () + (set-box! result-box #f) + (show #f))] - (sequence - - (when (eq? (system-type) 'unix) - (let ([dot-cb - (make-object check-box% - (string-constant show-dot-files) - dot-panel - (lambda (x y) (do-period-in/exclusion x y)))]) - (send dot-panel stretchable-height #f) - (send dot-cb set-value - (preferences:get 'framework:show-periods-in-dirlist)))) - - (send directory-panel stretchable-height #f) - - (when multi-mode? - (send add-panel stretchable-height #f) - (send remove-panel stretchable-height #f) - (send result-list stretchable-width #t)) - - (make-object button% - (string-constant up-directory-button-label) - top-panel - (lambda (button evt) (do-updir))) - - (send dir-choice stretchable-width #t) - (send name-list stretchable-width #t) - (send top-panel stretchable-height #f) - (send bottom-panel stretchable-height #f) - - (when save-mode? - (send save-panel stretchable-height #f))) + (define/override on-close (lambda () #f)) - (private-field - - [add-button (when multi-mode? - (make-object horizontal-panel% add-panel) - (make-object button% - (string-constant add-button-label) - add-panel - (lambda (x y) (do-add))))] - [add-all-button (when multi-mode? - (begin0 - (make-object button% - (string-constant add-all-button-label) - add-panel - (lambda (x y) (do-add-all))) - (make-object horizontal-panel% add-panel)))] - [remove-button (when multi-mode? - (make-object horizontal-panel% remove-panel) - (begin0 - (make-object button% - (string-constant remove-button-label) - remove-panel - (lambda (x y) (do-remove))) - (make-object horizontal-panel% remove-panel)))]) - (sequence - (make-object vertical-panel% bottom-panel)) - (private-field - [ok-button - (make-object button% (string-constant ok) bottom-panel - (lambda (x y) (do-ok)) - (if multi-mode? '() '(border)))] - [cancel-button (make-object button% - (string-constant cancel) - bottom-panel - (lambda (x y) (do-cancel)))]) - (sequence - (make-object grow-box-spacer-pane% bottom-panel) + (super-new (label (if save-mode? + (string-constant put-file) + (string-constant get-file))) + (parent parent-win) + (width default-width) + (height default-height) + (style '(resize-border))) + + [define main-panel (make-object vertical-panel% this)] + + [define top-panel (make-object horizontal-panel% main-panel)] + + (make-object message% prompt top-panel) + + [define dir-choice (make-object choice% #f null top-panel + (lambda (choice event) (do-dir choice event)))] + + [define middle-panel (make-object horizontal-panel% main-panel)] + [define left-middle-panel (make-object vertical-panel% middle-panel)] + [define right-middle-panel (when multi-mode? + (make-object vertical-panel% middle-panel))] + + [define name-list% - (cond - [(and start-dir - (directory-exists? start-dir)) - (set-listbox-directory (normal-case-path - (normalize-path start-dir)))] - [(get-last-directory) - => - (lambda (dir) - (set-listbox-directory dir))] - [else (set-listbox-directory (current-directory))]) - - (send ok-button min-width (send cancel-button get-width)) - - (center 'both) - - (show #t)))) + (class list-box% + + (inherit + get-string-selection + get-string + get-selection + get-number + get-first-visible-item + number-of-visible-items + set-first-visible-item + set-selection) + + (define/override (on-subwindow-char _ key) + (let ([code (send key get-key-code)] + [num-items (get-number)] + [curr-pos (get-selection)]) + (cond + [(or (equal? code 'numpad-return) + (equal? code #\return)) + (if multi-mode? + (do-add) + (do-ok))] + + ; look for letter at beginning of a filename + [(char? code) + (let ([next-matching + (let loop ([pos (add1 curr-pos)]) + (cond + [(>= pos num-items) #f] + [else + (let ([first-char (string-ref (get-string pos) 0)]) + (if (char-ci=? code first-char) + pos + (loop (add1 pos))))]))]) + (if next-matching + (set-selection-and-edit next-matching) + + ;; didn't find anything forward; start again at front of list + (let loop ([pos 0] + [last-before 0]) + (cond + [(<= pos num-items) + (let ([first-char (string-ref (get-string pos) 0)]) + (cond + [(char-ci=? code first-char) + (set-selection-and-edit pos)] + [(char-ci<=? first-char code) + (loop (+ pos 1) + pos)] + [else + (set-selection-and-edit last-before)]))] + [else (set-selection-and-edit last-before)]))))] + + ; 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-visible-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-visible-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-visible-item) num-vis)]) + (set-first-visible-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-visible-item) num-vis)]) + (set-first-visible-item + (min new-first (- (get-number) num-vis))) + (set-selection-and-edit + (min (sub1 num-items) (+ curr-pos num-vis))))] + + [else #f]))) + + [define/public set-selection-and-edit + (lambda (pos) + (when (> (get-number) 0) + (let* ([first-item (get-first-visible-item)] + [last-item (sub1 (+ (number-of-visible-items) + first-item))]) + (if (or (< pos first-item) (> pos last-item)) + (set-first-visible-item pos)) + (set-selection pos))) + (set-edit))] + [define/public on-default-action + (lambda () + (when (> (get-number) 0) + (let* ([which (get-string-selection)] + [dir (build-path current-dir + (make-relative which))]) + (if (directory-exists? dir) + (set-listbox-directory (normal-case-path + (normalize-path dir))) + (if multi-mode? + (do-add) + (do-ok))))))] + + (super-new))] + + [define name-list (make-object name-list% + #f null left-middle-panel (lambda (x y) (do-name-list x y)) + '(single))] + + [define save-panel (when save-mode? (make-object horizontal-panel% main-panel))] + + [define directory-panel (make-object horizontal-panel% main-panel)] + + [define dot-panel (when (eq? 'unix (system-type)) + (make-object horizontal-panel% main-panel))] + + [define bottom-panel (make-object horizontal-panel% main-panel)] + + [define directory-field + (keymap:call/text-keymap-initializer + (lambda () + (make-object text-field% + (string-constant full-pathname) + directory-panel + (lambda (txt evt) + (when (eq? (send evt get-event-type) 'text-field-enter) + (let ([dir (send directory-field get-value)]) + (if (directory-exists? dir) + (set-listbox-directory (normal-case-path + (normalize-path dir))) + (if multi-mode? + (do-add) + (do-ok)))))))))] + + [define result-list + (when multi-mode? + (make-object list-box% + #f + null + right-middle-panel + (lambda (x y) (do-result-list)) + '(multiple)))] + [define add-panel + (when multi-mode? + (make-object horizontal-panel% left-middle-panel))] + + [define remove-panel + (when multi-mode? + (make-object horizontal-panel% right-middle-panel))] + + [define/private do-updir + (lambda () + (set-listbox-directory (build-updir current-dir)) + (set-focus-to-name-list))] + + [define/private set-focus-to-name-list + (lambda () + (send name-list focus))] + + + (when (eq? (system-type) 'unix) + (let ([dot-cb + (make-object check-box% + (string-constant show-dot-files) + dot-panel + (lambda (x y) (do-period-in/exclusion x y)))]) + (send dot-panel stretchable-height #f) + (send dot-cb set-value + (preferences:get 'framework:show-periods-in-dirlist)))) + + (send directory-panel stretchable-height #f) + + (when multi-mode? + (send add-panel stretchable-height #f) + (send remove-panel stretchable-height #f) + (send result-list stretchable-width #t)) + + (make-object button% + (string-constant up-directory-button-label) + top-panel + (lambda (button evt) (do-updir))) + + (send dir-choice stretchable-width #t) + (send name-list stretchable-width #t) + (send top-panel stretchable-height #f) + (send bottom-panel stretchable-height #f) + + (when save-mode? + (send save-panel stretchable-height #f)) + + [define add-button (when multi-mode? + (make-object horizontal-panel% add-panel) + (make-object button% + (string-constant add-button-label) + add-panel + (lambda (x y) (do-add))))] + [define add-all-button (when multi-mode? + (begin0 + (make-object button% + (string-constant add-all-button-label) + add-panel + (lambda (x y) (do-add-all))) + (make-object horizontal-panel% add-panel)))] + [define remove-button (when multi-mode? + (make-object horizontal-panel% remove-panel) + (begin0 + (make-object button% + (string-constant remove-button-label) + remove-panel + (lambda (x y) (do-remove))) + (make-object horizontal-panel% remove-panel)))] + (make-object vertical-panel% bottom-panel) + [define ok-button + (make-object button% (string-constant ok) bottom-panel + (lambda (x y) (do-ok)) + (if multi-mode? '() '(border)))] + [define cancel-button (make-object button% + (string-constant cancel) + bottom-panel + (lambda (x y) (do-cancel)))] + (make-object grow-box-spacer-pane% bottom-panel) + + (cond + [(and start-dir + (directory-exists? start-dir)) + (set-listbox-directory (normal-case-path + (normalize-path start-dir)))] + [(get-last-directory) + => + (lambda (dir) + (set-listbox-directory dir))] + [else (set-listbox-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 @@ -628,17 +601,17 @@ [name (or (and (string? name) (file-name-from-path name)) name)]) - (make-object finder-dialog% - parent-win - #t - replace? - #f - result-box - directory - name - prompt - filter - filter-msg) + (new finder-dialog% + (parent-win parent-win) + (save-mode? #t) + (replace-ok? replace?) + (multi-mode? #f) + (result-box result-box ) + (start-dir directory) + (start-name name) + (prompt prompt) + (file-filter filter) + (file-filter-msg filter-msg)) (when in-directory (set-last-directory saved-directory)))))) (define common-get-file @@ -651,17 +624,17 @@ [filter-msg (string-constant file-wrong-form)] [parent-win (dialog-parent-parameter)]) (let ([saved-directory (get-last-directory)]) - (make-object finder-dialog% - parent-win ; parent window - #f ; save-mode? - #f ; replace-ok? - #f ; multi-mode? - result-box ; boxed results - directory ; start-dir - #f ; start-name - prompt ; prompt - filter ; file-filter - filter-msg) ; file-filter-msg + (new finder-dialog% + (parent-win parent-win) + (save-mode? #f) + (replace-ok? #f) + (multi-mode? #f) + (result-box result-box) + (start-dir directory) + (start-name #f) + (prompt prompt) + (file-filter filter) + (file-filter-msg filter-msg)) (when directory (set-last-directory saved-directory)))))) (define common-get-file-list @@ -672,19 +645,17 @@ [filter #f] [filter-msg (string-constant file-wrong-form)] [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 - #f ; start-name - prompt ; prompt - filter ; file-filter - filter-msg ; file-filter-msg - )))) + (new finder-dialog% + (parent-win parent-win) + (save-mode? #f) + (replace-ok? #f) + (multi-mode? #t) + (result-box result-box) + (start-dir directory) + (start-name #f) + (prompt prompt) + (file-filter filter) + (file-filter-msg 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? diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index beb7283a..15561192 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -518,7 +518,6 @@ (+ magic-space (- (inexact->exact (floor (unbox rb))) (inexact->exact (floor (unbox lb))))))))))] - (rename [super-on-close on-close]) [define outer-info-panel 'top-info-panel-uninitialized] ;; this flag is specific to this frame @@ -556,8 +555,9 @@ (lambda (p v) (update-info-visibility v)))] [define memory-cleanup void] ;; only for CVSers; used with memory-text - (override on-close) - [define on-close + + (rename [super-on-close on-close]) + [define/override on-close (lambda () (super-on-close) (unregister-collecting-blit gc-canvas) @@ -687,7 +687,6 @@ (define text-info-mixin (mixin (info<%>) (text-info<%>) (inherit get-info-editor) - (rename [super-on-close on-close]) [define remove-first (preferences:add-callback 'framework:col-offsets @@ -703,9 +702,9 @@ (editor-position-changed-offset/numbers (preferences:get 'framework:col-offsets) v) - #t))] - (override on-close) - [define on-close + #t))] + (rename [super-on-close on-close]) + [define/override on-close (lambda () (super-on-close) (remove-first) @@ -2065,8 +2064,7 @@ (lambda (p v) (when p (hide-search))))) - (override on-close) - (define on-close + (define/override on-close (lambda () (super-on-close) (remove-callback) diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss index 9baa9140..4c0fbb55 100644 --- a/collects/framework/private/menu.ss +++ b/collects/framework/private/menu.ss @@ -1,7 +1,6 @@ (module menu mzscheme (require (lib "unitsig.ss") (lib "class.ss") - (lib "class100.ss") "sig.ss" "../macro.ss" (lib "mred-sig.ss" "mred")) diff --git a/collects/framework/private/pasteboard.ss b/collects/framework/private/pasteboard.ss index a5a5dd66..e9fdb5d1 100644 --- a/collects/framework/private/pasteboard.ss +++ b/collects/framework/private/pasteboard.ss @@ -1,9 +1,6 @@ (module pasteboard mzscheme (require (lib "unitsig.ss") - (lib "class.ss") - (lib "class100.ss") "sig.ss" - "../macro.ss" (lib "mred-sig.ss" "mred")) (provide pasteboard@) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index ca430c90..50c47d4b 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -3,7 +3,6 @@ (require (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") (lib "class.ss") - (lib "class100.ss") "sig.ss" "../macro.ss" "../gui-utils.ss"