suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: 2773fc646c08ad51f10f822097703eed7ddb9e81
This commit is contained in:
Robby Findler 1998-09-06 01:32:33 +00:00
parent 6a3821fe01
commit cce2a50202
5 changed files with 78 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/framework/finder.ss
View File

@ -10,7 +10,7 @@
[mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^])
(define dialog-parent-parameter (make-parameter null))
(define dialog-parent-parameter (make-parameter #f))
(define filter-match?
(lambda (filter name msg)
@ -83,8 +83,8 @@
(let-values
([(dir-list menu-list)
(let loop ([this-dir dir]
[dir-list ()]
[menu-list ()])
[dir-list null]
[menu-list null])
(let-values ([(base-dir in-dir dir?)
(split-path this-dir)])
(if (eq? (system-type) 'windows)
@ -136,9 +136,9 @@
(lambda ()
(let* ([file (send name-list get-string-selection)]
[dir-and-file
(if (null? file)
current-dir
(build-path current-dir file))])
(if file
(build-path current-dir file)
current-dir)])
(send* directory-edit
(begin-edit-sequence)
(erase)
@ -182,7 +182,7 @@
(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 ()])
(let loop ([n (sub1 select-counter)][result null])
(if (< n 0)
(begin
(set-box! result-box result)
@ -231,7 +231,7 @@
(let* ([relative-name (make-relative name)]
[file-in-edit (file-exists? dir-name)]
[file (if (or file-in-edit
(null? relative-name)
(not relative-name)
save-mode?)
dir-name
(build-path current-dir relative-name))])
@ -334,7 +334,7 @@
[_1 (make-object message% top-panel prompt)]
[dir-choice (make-object choice% top-panel do-dir '())]
[dir-choice (make-object choice% #f null top-panel do-dir)]
[middle-panel (make-object horizontal-panel% main-panel)]
[left-middle-panel (make-object vertical-panel% middle-panel)]
@ -431,7 +431,7 @@
(set-selection-and-edit
(min (sub1 num-items) (+ curr-pos num-vis))))]
[else #f])))]
[else #f]))]
[on-default-action
(lambda ()
@ -501,8 +501,7 @@
[do-updir
(lambda ()
(set-directory (build-updir current-dir))
(set-focus-to-name-list))
])
(set-focus-to-name-list))])
(sequence
@ -576,7 +575,6 @@
(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)]
@ -604,16 +602,16 @@
(define common-put-file
(make-common
(opt-lambda (result-box
[name ()]
[directory ()]
[name #f]
[directory #f]
[replace? #f]
[prompt "Select file"]
[filter #f]
[filter-msg "Invalid form"]
[parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (null? directory)
(let* ([directory (if (and (not directory)
(string? name))
(or (mzlib:file:path-only name) null)
(mzlib:file:path-only name)
directory)]
[name (or (and (string? name)
(mzlib:file:file-name-from-path name))
@ -634,7 +632,7 @@
(make-common
(opt-lambda
(result-box
[directory ()]
[directory #f]
[prompt "Select file"]
[filter #f]
[filter-msg "Bad name"]
@ -646,7 +644,7 @@
#f ; multi-mode?
result-box ; boxed results
directory ; start-dir
'() ; start-name
#f ; start-name
prompt ; prompt
filter ; file-filter
filter-msg ; file-filter-msg
@ -655,7 +653,7 @@
(define common-get-file-list
(make-common
(opt-lambda (result-box
[directory ()]
[directory #f]
[prompt "Select files"]
[filter #f]
[filter-msg "Bad name"]
@ -668,7 +666,7 @@
#t ; multi-mode?
result-box ; boxed results
directory ; directory
'() ; start-name
#f ; start-name
prompt ; prompt
filter ; file-filter
filter-msg ; file-filter-msg
@ -685,9 +683,9 @@
[filter #f]
[filter-msg "That filename does not have the right form."]
[parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (null? directory)
(let* ([directory (if (and (not directory)
(string? name))
(or (mzlib:file:path-only name) null)
(mzlib:file:path-only name)
directory)]
[name (or (and (string? name)
(mzlib:file:file-name-from-path name))
@ -726,8 +724,7 @@
prompt
parent-win
directory)])
(if (null? f)
#f
(or f
(if (or (not filter) (filter-match? filter f filter-msg))
(let ([f (mzlib:file:normalize-path f)])
(cond

64
collects/framework/group.ss
View File

@ -1,50 +1,3 @@
(private [get-standard-menu-close-item
(lambda (frame)
(let* ([close-string (if (eq? (system-type) 'windows)
"&Close"
"Close")]
[file-menu (ivar frame file-menu)])
(if file-menu
(send file-menu find-item close-string)
#f)))]
[set-close-menu-item-state!
(lambda (frame state)
(when (is-a? frame frame:standard-menus<%>)
(let ([close-menu-item
(get-standard-menu-close-item frame)])
(when close-menu-item
(send (ivar frame file-menu)
enable close-menu-item state)))))])
when removing a frame, do this:
(let ([frames (send mred:group:the-frame-group
get-frames)])
; disable File|Close if remaining frame is singleton
(when (eq? (length frames) 1)
(set-close-menu-item-state! (car frames) #f)))
when adding a frame, do this:
(let ([frames (send mred:group:the-frame-group get-frames)])
(if (eq? (length frames) 1)
; disable File|Close if frame is singleton
(set-close-menu-item-state! this #f)
; otherwise, enable for all frames
(send mred:group:the-frame-group
for-each-frame
(lambda (a-frame)
(set-close-menu-item-state! a-frame #t)))))
(unit/sig mred:group^
(import [exit : framework:exit^]
[mzlib:function : mzlib:function^]
@ -122,7 +75,20 @@ when adding a frame, do this:
(cons menu new-ids))))
windows-menus))))])
(private
[update-close-menu-item-state
(lambda ()
(let* ([set-close-menu-item-state!
(lambda (frame state)
(when (is-a? frame frame:standard-menus<%>)
(let ([close-menu-item (ivar frame file-menu:close-menu)])
(when close-menu-item
(send close-menu-item enable state)))))])
(if (eq? (length frames) 1)
(set-close-menu-item-state! (car frames) #f)
(for-each (lambda (a-frame)
(set-close-menu-item-state! a-frame #t))
frames))))])
(public
[set-empty-callbacks
(lambda (test close-down)
@ -156,6 +122,7 @@ when adding a frame, do this:
(let ([new-frames (cons (make-frame f frame-counter)
frames)])
(set! frames new-frames)
(update-close-menu-item-state)
(insert-windows-menu f)
(update-windows-menus))
(todo-to-new-frames f))]
@ -178,6 +145,7 @@ when adding a frame, do this:
f frames
(lambda (f fr) (eq? f (frame-frame fr))))])
(set! frames new-frames)
(update-close-menu-item-state)
(remove-windows-menu f)
(update-windows-menus)
(when (null? frames)

24
collects/framework/handler.ss
View File

@ -184,18 +184,18 @@
(define *open-directory* ; object to remember last directory
(make-object
(class null ()
(private
[the-dir #f])
(public
[get (lambda () the-dir)]
[set-from-file!
(lambda (file)
(set! the-dir (mzlib:file:path-only file)))]
[set-to-default
(lambda ()
(set! the-dir (current-directory)))])
(sequence
(set-to-default)))))
(private
[the-dir #f])
(public
[get (lambda () the-dir)]
[set-from-file!
(lambda (file)
(set! the-dir (mzlib:file:path-only file)))]
[set-to-default
(lambda ()
(set! the-dir (current-directory)))])
(sequence
(set-to-default)))))
(define open-file
(lambda ()

55
collects/framework/keys.ss
View File

@ -102,9 +102,9 @@
#t)]
[save-file
(lambda (edit event)
(if (null? (send edit get-filename))
(save-file-as edit event)
(send edit save-file))
(if (send edit get-filename)
(send edit save-file)
(save-file-as edit event))
#t)]
[load-file
(lambda (edit event)
@ -364,7 +364,7 @@
[real-end (send edit last-position)])
(when (= sel-start sel-end)
(let ([word-end (let ([b (box sel-start)])
(send edit find-wordbreak () b 'caret)
(send edit find-wordbreak #f b 'caret)
(min real-end (unbox b)))])
(send edit begin-edit-sequence)
(let loop ([pos sel-start]
@ -399,7 +399,7 @@
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(let ([end-box (box sel-end)])
(send edit find-wordbreak () end-box 'caret)
(send edit find-wordbreak #f end-box 'caret)
(send edit kill 0 sel-start (unbox end-box)))))]
[backward-kill-word
@ -407,7 +407,7 @@
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(let ([start-box (box sel-start)])
(send edit find-wordbreak start-box () 'caret)
(send edit find-wordbreak start-box #f 'caret)
(send edit kill 0 (unbox start-box) sel-end))))]
[region-click
@ -513,7 +513,19 @@
(send km remove-grab-key-function))])
(send km set-grab-key-function
(lambda (name local-km edit event)
(if (null? name)
(if name
(begin
(done)
(dynamic-wind
(lambda ()
(send edit begin-edit-sequence))
(lambda ()
(let loop ([n n])
(unless (zero? n)
(send local-km call-function name edit event)
(loop (sub1 n)))))
(lambda ()
(send edit end-edit-sequence))))
(let ([k (send event get-key-code)])
(if (<= (char->integer #\0) k (char->integer #\9))
(set! n (+ (* n 10) (- k (char->integer #\0))))
@ -528,19 +540,7 @@
(send edit on-char event)
(loop (sub1 n)))))
(lambda ()
(send edit end-edit-sequence))))))
(begin
(done)
(dynamic-wind
(lambda ()
(send edit begin-edit-sequence))
(lambda ()
(let loop ([n n])
(unless (zero? n)
(send local-km call-function name edit event)
(loop (sub1 n)))))
(lambda ()
(send edit end-edit-sequence)))))
(send edit end-edit-sequence)))))))
#t))
(send km set-break-sequence-callback done)
#t))]
@ -568,11 +568,10 @@
(lambda (f)
(let ([name (car f)]
[event (cdr f)])
(if (null? name)
(send edit on-char event)
(if (not (send km call-function
name edit event #t))
(escape #t)))))
(if name
(unless (send km call-function name edit event #t)
(escape #t))
(send edit on-char event))))
current-macro)))
(lambda ()
(send edit end-edit-sequence)
@ -599,9 +598,9 @@
(lambda ()
(set! build-protect? #t))
(lambda ()
(if (null? name)
(send edit on-default-char event)
(send local-km call-function name edit event)))
(if name
(send local-km call-function name edit event)
(send edit on-default-char event)))
(lambda ()
(set! build-protect? #f)))
(when building-macro

3
collects/framework/prefs.ss
View File

@ -488,8 +488,7 @@
(unless (= value (send size-slider get-value))
(send size-slider set-value value))
#t))
(make-object message% main
"Restart to see font changes")
(make-object message% main "Restart to see font changes")
main))
#f)))