From dd10c098ed105c6f59d7bdf82110d1d7cd3db71a Mon Sep 17 00:00:00 2001 From: Paul Steckler Date: Thu, 12 Feb 1998 22:54:59 +0000 Subject: [PATCH] Updated dialogs, added find-object, find-checkbox to MrEd test primitives original commit: 35f38ad7b876c6b24ec3e86232e26113ff7ed321 --- collects/mred/finder.ss | 473 +++++++++++++++++++++++++++++----------- 1 file changed, 351 insertions(+), 122 deletions(-) diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss index ee1d7945..dd0e889a 100644 --- a/collects/mred/finder.ss +++ b/collects/mred/finder.ss @@ -1,3 +1,6 @@ +;;; finder.ss + +;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler (unit/sig mred:finder^ (import [wx : wx^] @@ -40,16 +43,50 @@ #t] [else #f]))) + (define get-slash + (lambda () + (case wx:platform + [(unix) "/"] + [(windows) "\\"] + [else ":"]))) + + (define build-updir + (lambda (dir) + (let ([components (mzlib:file:explode-path dir)] + [slash (get-slash)]) + (letrec + ([loop + (lambda (comps) + (cond + [(null? comps) ""] + [(equal? (car comps) slash) + (string-append slash (loop (cdr comps)))] + [(eq? (length comps) 1) ""] + [else (let ([rest (loop (cdr comps))]) + (if (string=? rest "") + (car comps) + (build-path (car comps) rest)))]))]) + (loop components))))) + (mred:preferences:set-preference-default 'mred:show-periods-in-dirlist #f (lambda (x) (or (not x) (eq? x #t)))) + ; the finder-dialog% class controls the user interface for dialogs + (define finder-dialog% - (class mred:container:dialog-box% (save-mode? replace-ok? multi-mode? - result-box start-dir - start-name prompt - file-filter file-filter-msg) + (class mred:container: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 show popup-menu) @@ -57,14 +94,15 @@ (private [WIDTH 500] [HEIGHT 400] - - dirs current-dir + dirs + current-dir last-selected [select-counter 0]) (private - [set-directory - (lambda (dir) ; dir is normalied + + [set-directory ; sets directory in listbox + (lambda (dir) ; dir is normalized (mred:gui-utils:show-busy-cursor (lambda () (set! current-dir dir) @@ -84,11 +122,6 @@ ; No more (values dir-list menu-list)))))]) (set! dirs (reverse dir-list)) - (send* directory-edit - (begin-edit-sequence) - (erase) - (insert dir) - (end-edit-sequence)) (send dir-choice clear) (let loop ([choices (reverse menu-list)]) (unless (null? choices) @@ -113,50 +146,66 @@ (char=? (string-ref s 0) #\.)) rest] [(directory-exists? (build-path dir s)) - (cons (string-append s - (case wx:platform - [(unix) "/"] - [(windows) "\\"] - [else ":"])) + (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? wx:platform 'unix) string (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)]) @@ -219,6 +269,7 @@ (let ([name (build-path current-dir (make-relative name))]) (add-one name)))))] + [do-add-all (lambda args (let loop ([n 0]) @@ -229,6 +280,7 @@ (make-relative name))]) (add-one name) (loop (add1 n)))))))] + [do-remove (lambda args (let loop ([n 0]) @@ -246,22 +298,125 @@ (show #f))] [on-close (lambda () #f)]) + (sequence - (super-init () (if save-mode? "Put File" "Get File") - #t 300 300 WIDTH HEIGHT)) + (super-init parent-win + (if save-mode? "Put file" "Get file") + #t + 300 + 300 + WIDTH + HEIGHT)) (private + [main-panel (make-object mred:container:vertical-panel% this)] + [top-panel (make-object mred:container:horizontal-panel% main-panel)] + [_1 (make-object mred:container:message% top-panel prompt)] + [dir-choice (make-object mred:container:choice% top-panel do-dir '())] [middle-panel (make-object mred:container:horizontal-panel% main-panel)] [left-middle-panel (make-object mred:container:vertical-panel% middle-panel)] - [right-middle-panel (when multi-mode? (make-object mred:container:vertical-panel% middle-panel))] + [right-middle-panel (when multi-mode? + (make-object mred:container:vertical-panel% middle-panel))] [name-list% + (class-asi mred:container:list-box% + + (inherit + get-first-item + get-string + get-selection + get-string-selection + number + number-of-visible-items + set-first-item + set-selection) + (public + + [set-selection-and-edit ; set selection, update edit box + + (lambda (pos) + + (if (> (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)) + (send* directory-edit + (begin-edit-sequence) + (erase) + (end-edit-sequence))))] + + [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 + + [(or (= code 10) (= code 13)) ; CR or LF + (do-ok)] + + ; look for letter at beginning of a filename + + [(and (>= code 32) (<= code 127)) ; ASCII-dependent + ; but who uses EBCDIC? + (letrec + ([loop + (lambda (pos) + (unless + (>= pos num-items) + (let ([first-char (string-ref (get-string pos) 0)]) + (if (eq? code (char->integer first-char)) + (set-selection-and-edit pos) + (loop (add1 pos))))))]) + (loop (add1 curr-pos)))] + + ; movement keys + + [(and (= code wx:const-k-up) + (> curr-pos 0)) + (set-selection-and-edit (sub1 curr-pos))] + + [(and (= code wx:const-k-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 (= code wx:const-k-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 (= code wx:const-k-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 () (let* ([which (send name-list get-string-selection)] @@ -274,14 +429,18 @@ (if multi-mode? (do-add) (do-ok))))))]))] + [name-list (make-object name-list% left-middle-panel do-name-list () wx:const-single -1 -1 - (if multi-mode? (* 1/2 WIDTH) WIDTH) 300 + (if multi-mode? (/ WIDTH 2) WIDTH) 300 () wx:const-needed-sb)] + [save-panel (when save-mode? (make-object mred:container:horizontal-panel% main-panel))] + [directory-panel (make-object mred:container:horizontal-panel% main-panel)] + [directory-edit (make-object (class-asi mred:edit:media-edit% (rename [super-on-local-char on-local-char]) (public @@ -292,12 +451,14 @@ [code (send key get-key-code)]) (if (or (= code cr-code) (= code lf-code)) - (do-go) + (do-ok) (super-on-local-char key))))])))] - [period-panel (when (eq? 'unix wx:platform) + [dot-panel (when (eq? 'unix wx:platform) (make-object mred:container:horizontal-panel% main-panel))] + [bottom-panel (make-object mred:container:horizontal-panel% main-panel)] + [result-list (when multi-mode? (make-object mred:container:list-box% @@ -307,51 +468,60 @@ wx:const-extended wx:const-multiple) -1 -1 - (* 1/2 WIDTH) 300 + (/ WIDTH 2) 300 () wx:const-needed-sb))] - [add-panel (when multi-mode? (make-object mred:container:horizontal-panel% left-middle-panel))] - [remove-panel (when multi-mode? (make-object mred:container:horizontal-panel% right-middle-panel))] - [do-go - (lambda () - (let ([t (send directory-edit get-text)]) - (cond - [(file-exists? t) - (set-box! result-box (mzlib:file:normalize-path t)) - (show #f)] - [(directory-exists? t) - (set-directory (mzlib:file:normalize-path t))] - [else (wx:message-box (format "~a doesn't exist" t))])))]) + [add-panel + (when multi-mode? + (make-object mred:container:horizontal-panel% left-middle-panel))] + + [remove-panel + (when multi-mode? + (make-object mred:container:horizontal-panel% right-middle-panel))] + + [do-updir + (lambda () + (set-directory (build-updir current-dir))) + ]) (sequence + (when (eq? wx:platform 'unix) - (make-object mred:container:check-box% period-panel + (make-object mred:container:check-box% dot-panel do-period-in/exclusion - "Show files and directories that begin with a period") - (send period-panel stretchable-in-y #f)) + "Show files and directories that begin with a dot") + (send dot-panel stretchable-in-y #f)) (send directory-panel stretchable-in-y #f) + (let ([canvas (make-object mred:canvas:one-line-canvas% directory-panel -1 -1 -1 20 "" (+ wx:const-mcanvas-hide-h-scroll wx:const-mcanvas-hide-v-scroll))]) + (send* canvas - (set-media directory-edit) - (set-focus) - (user-min-height 20))) - (make-object mred:container:button% directory-panel - (lambda (button evt) (do-go)) - "Go") + (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)) + (send add-panel stretchable-in-y #f) + (send remove-panel stretchable-in-y #f) + (send result-list stretchable-in-x #t)) + + (make-object mred:container:button% top-panel + (lambda (button evt) (do-updir)) + "Up") + (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 + [name-field (when save-mode? (let* ([% (class-asi mred:container:text% @@ -370,10 +540,7 @@ (send v set-value start-name)) (new-line) v))] - [into-dir-button - (when save-mode? - (make-object mred:container:button% - save-panel do-into-dir "Open Directory"))] + [add-button (when multi-mode? (make-object mred:container:horizontal-panel% add-panel) (make-object mred:container:button% @@ -383,7 +550,7 @@ (begin0 (make-object mred:container:button% add-panel do-add-all - "Add All") + "Add all") (make-object mred:container:horizontal-panel% add-panel)))] [remove-button (when multi-mode? (make-object mred:container:horizontal-panel% remove-panel) @@ -418,15 +585,17 @@ (show #t)))) + ; make-common takes a dialog function + (define make-common - (lambda (box-value make-dialog) + (lambda (make-dialog) (let ([s (make-semaphore 1)] - [v (box box-value)] - [d #f]) + [v (box #f)] + [d #f]) ; d is a flag, what does it mean? (lambda x (semaphore-wait s) - (if d - (let ([my-d d] + (if d + (let ([my-d d] ; this case isn't used currently [my-v v]) (set! d #f) (set! v #f) @@ -439,54 +608,92 @@ (semaphore-post s))) (begin (semaphore-post s) - (let* ([my-v (box box-value)] + (let* ([my-v (box #f)] [my-d (apply make-dialog my-v x)]) (semaphore-wait s) - (unless d + (unless d ; I don't understand this, since d, v not used - PAS (set! d my-d) (set! v my-v)) (begin0 (unbox my-v) (semaphore-post s))))))))) + ; the common versions of these functions have their visual + ; interfaces under Scheme control + (define common-put-file (make-common - #f (opt-lambda (box - [name ()][directory ()][replace? #f] - [prompt "Select File"][filter #f] - [filter-msg "That name does not have the right form"]) - (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% #t replace? #f box - directory name prompt filter filter-msg))))) + [parent-win null] + [name ()] + [directory ()] + [replace? #f] + [prompt "Select file"] + [filter #f] + [filter-msg "Invalid form"]) + (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 + box + directory + name + prompt + filter + filter-msg))))) - (define common-get-file + (define common-get-file (make-common - #f (opt-lambda - (box [directory ()][prompt "Select File"][filter #f] + (box [parent-win null] + [directory ()] + [prompt "Select file"] + [filter #f] [filter-msg "Bad name"]) - (make-object finder-dialog% #f #f #f box directory '() prompt - filter filter-msg)))) + (make-object finder-dialog% + parent-win ; parent window + #f ; save-mode? + #f ; replace-ok? + #f ; multi-mode? + box ; result-box + directory ; start-dir + '() ; start-name + prompt ; prompt + filter ; file-filter + filter-msg ; file-filter-msg + )))) (define common-get-file-list (make-common - null - (opt-lambda (box [directory ()][prompt "Select Files"][filter #f] + (opt-lambda (box [directory ()][prompt "Select files"][filter #f] [filter-msg "Bad name"]) (make-object finder-dialog% #f #f #t box directory '() prompt filter filter-msg)))) + ; the std- versions of these functions rely on wx: for their + ; visible interfaces + + ; 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."]) + (opt-lambda ([name ()] + [directory ()] + [replace? #f] + [prompt "Select file"] + [filter #f] + [filter-msg "That filename does not have the right form."] + + ; quick-and-dirty solution ... probably should be first arg + + [parent-win null]) (let* ([directory (if (and (null? directory) (string? name)) (or (mzlib:file:path-only name) null) @@ -494,12 +701,14 @@ [name (or (and (string? name) (mzlib:file:file-name-from-path name)) name)] - [f (wx:file-selector prompt directory name - '() - (if (eq? wx:platform 'windows) - "*.*" - "*") - wx:const-save)]) + [f (wx:file-selector + prompt + directory + name + '() + (if (eq? wx:platform 'windows) "*.*" "*") + wx:const-save + parent-win)]) (if (or (null? f) (and filter (not (filter-match? filter @@ -519,10 +728,22 @@ [else f])))))) (define std-get-file - (opt-lambda ([directory ()][prompt "Select File"][filter #f] - [filter-msg - "That filename does not have the right form."]) - (let ([f (wx:file-selector prompt directory)]) + (opt-lambda ([directory ()] + [prompt "Select file"] + [filter #f] + [filter-msg "That filename does not have the right form."] + + ; quick-and-dirty solution ... probably should be 1st arg + + [parent-win null]) + (let ([f (wx:file-selector + prompt + directory + null + null + "*" + 0 + parent-win)]) (if (null? f) #f (if (or (not filter) (filter-match? filter f filter-msg)) @@ -533,7 +754,7 @@ "That is a directory name.") #f] [(not (file-exists? f)) - (wx:message-box "That file does not exist.") + (wx:message-box "File does not exist.") #f] [else f])) #f))))) @@ -546,15 +767,23 @@ (or (eq? x 'common) (eq? x 'std)))) + ; external interfaces to file functions + (define put-file (lambda args - (apply (case (mred:preferences:get-preference 'mred:file-dialogs) + (let ([actual-fun + (case (mred:preferences:get-preference 'mred:file-dialogs) [(std) std-put-file] - [(common) common-put-file]) - args))) + [(common) common-put-file])]) + (apply actual-fun args)))) + (define get-file (lambda args - (apply (case (mred:preferences:get-preference 'mred:file-dialogs) + (let ([actual-fun + (case (mred:preferences:get-preference 'mred:file-dialogs) [(std) std-get-file] - [(common) common-get-file]) - args)))) + [(common) common-get-file])]) + (apply actual-fun args))))) + + +