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

no message

Browse Source 
original commit: 638ea6a4623efa4ac7fe29b42bf7dddf0b60fd73
This commit is contained in:
Robby Findler 2001-03-30 17:21:59 +00:00
parent 604760b7be
commit 00453cd72f
5 changed files with 274 additions and 260 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/framework/private/canvas.ss
View File

@ -15,7 +15,7 @@
(define basic<%> (interface ((class->interface editor-canvas%)))) (define basic<%> (interface ((class->interface editor-canvas%))))
(define basic-mixin (define basic-mixin
(mixin ((class100->interface editor-canvas%)) (basic<%>) args (mixin ((class->interface editor-canvas%)) (basic<%>) args
(sequence (sequence
(apply super-init args)))) (apply super-init args))))
@ -61,9 +61,10 @@
(mixin (basic<%>) (wide-snip<%>) args (mixin (basic<%>) (wide-snip<%>) args
(inherit get-editor) (inherit get-editor)
(rename [super-on-size on-size]) (rename [super-on-size on-size])
(private (private-field
[wide-snips null] [wide-snips null]
[tall-snips null] [tall-snips null])
(private
[update-snip-size [update-snip-size
(lambda (width?) (lambda (width?)
(lambda (s) (lambda (s)

76
collects/framework/private/finder.ss
View File

@ -1,8 +1,9 @@
(module finder mzscheme (module finder mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss")
"sig.ss" "sig.ss"
"../gui-utils-sig.ss" "../gui-utils-sig.ss"
(lib "class100.ss")
(lib "class.ss")
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "string.ss") (lib "string.ss")
(lib "list.ss") (lib "list.ss")
@ -57,19 +58,27 @@
; the finder-dialog% class controls the user interface for dialogs ; the finder-dialog% class controls the user interface for dialogs
(define finder-dialog% (define finder-dialog%
(class dialog% (parent-win (class100 dialog% (parent-win
save-mode? _save-mode?
replace-ok? _replace-ok?
multi-mode? _multi-mode?
result-box _result-box
start-dir start-dir
start-name start-name
prompt prompt
file-filter _file-filter
file-filter-msg) _file-filter-msg)
(inherit center show) (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 (private-field
[default-width 500] [default-width 500]
[default-height 400] [default-height 400]
@ -172,7 +181,7 @@
(set-edit))))] (set-edit))))]
[do-result-list [do-result-list
(lambda args #f)] (lambda () #f)]
[do-ok [do-ok
(lambda args (lambda args
@ -283,7 +292,7 @@
(normal-case-path (normalize-path name)))))] (normal-case-path (normalize-path name)))))]
[do-add [do-add
(lambda args (lambda ()
(let ([name (send name-list get-string-selection)]) (let ([name (send name-list get-string-selection)])
(if (string? name) (if (string? name)
(let ([name (build-path current-dir (let ([name (build-path current-dir
@ -291,7 +300,7 @@
(add-one name)))))] (add-one name)))))]
[do-add-all [do-add-all
(lambda args (lambda ()
(let loop ([n 0]) (let loop ([n 0])
(when (< n (send name-list get-number)) (when (< n (send name-list get-number))
(let ([name (send name-list get-string n)]) (let ([name (send name-list get-string n)])
@ -301,7 +310,7 @@
(loop (add1 n)))))))] (loop (add1 n)))))))]
[do-remove [do-remove
(lambda args (lambda ()
(let loop ([n 0]) (let loop ([n 0])
(if (< n (send result-list get-number)) (if (< n (send result-list get-number))
(if (send result-list is-selected? n) (if (send result-list is-selected? n)
@ -311,7 +320,7 @@
(loop (add1 n))))))] (loop (add1 n))))))]
[do-cancel [do-cancel
(lambda args (lambda ()
(set-box! result-box #f) (set-box! result-box #f)
(show #f))]) (show #f))])
@ -326,15 +335,15 @@
#f #f #f #f
'(resize-border))) '(resize-border)))
(private (private-field
[main-panel (make-object vertical-panel% this)] [main-panel (make-object vertical-panel% this)]
[top-panel (make-object horizontal-panel% main-panel)] [top-panel (make-object horizontal-panel% main-panel)]
[_1 (make-object message% prompt top-panel)] [_1 (make-object message% prompt top-panel)]
[dir-choice (make-object choice% #f null top-panel do-dir)] [dir-choice (make-object choice% #f null top-panel
(lambda (choice event) (do-dir choice event)))]
[middle-panel (make-object horizontal-panel% main-panel)] [middle-panel (make-object horizontal-panel% main-panel)]
[left-middle-panel (make-object vertical-panel% middle-panel)] [left-middle-panel (make-object vertical-panel% middle-panel)]
@ -343,7 +352,7 @@
[name-list% [name-list%
(class-asi list-box% (class100-asi list-box%
(inherit (inherit
get-string-selection get-string-selection
@ -458,13 +467,9 @@
(do-ok))))))]))] (do-ok))))))]))]
[name-list (make-object name-list% [name-list (make-object name-list%
#f null left-middle-panel do-name-list #f null left-middle-panel (lambda (x y) (do-name-list x y))
'(single))] '(single))]
[set-focus-to-name-list
(lambda ()
(send name-list focus))]
[save-panel (when save-mode? (make-object horizontal-panel% main-panel))] [save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
[directory-panel (make-object horizontal-panel% main-panel)] [directory-panel (make-object horizontal-panel% main-panel)]
@ -496,7 +501,7 @@
#f #f
null null
right-middle-panel right-middle-panel
do-result-list (lambda (x y) (do-result-list))
'(multiple)))] '(multiple)))]
[add-panel [add-panel
(when multi-mode? (when multi-mode?
@ -511,6 +516,11 @@
(set-directory (build-updir current-dir)) (set-directory (build-updir current-dir))
(set-focus-to-name-list))]) (set-focus-to-name-list))])
(private
[set-focus-to-name-list
(lambda ()
(send name-list focus))])
(sequence (sequence
(when (eq? (system-type) 'unix) (when (eq? (system-type) 'unix)
@ -518,7 +528,7 @@
(make-object check-box% (make-object check-box%
"Show files and directories that begin with a dot" "Show files and directories that begin with a dot"
dot-panel dot-panel
do-period-in/exclusion)]) (lambda (x y) (do-period-in/exclusion x y)))])
(send dot-panel stretchable-height #f) (send dot-panel stretchable-height #f)
(send dot-cb set-value (send dot-cb set-value
(preferences:get 'framework:show-periods-in-dirlist)))) (preferences:get 'framework:show-periods-in-dirlist))))
@ -543,31 +553,34 @@
(when save-mode? (when save-mode?
(send save-panel stretchable-height #f))) (send save-panel stretchable-height #f)))
(private (private-field
[add-button (when multi-mode? [add-button (when multi-mode?
(make-object horizontal-panel% add-panel) (make-object horizontal-panel% add-panel)
(make-object button% (make-object button%
"Add" "Add"
add-panel add-panel
do-add))] (lambda (x y) (do-add))))]
[add-all-button (when multi-mode? [add-all-button (when multi-mode?
(begin0 (begin0
(make-object button% (make-object button%
"Add all" "Add all"
add-panel do-add-all) add-panel
(lambda (x y) (do-add-all)))
(make-object horizontal-panel% add-panel)))] (make-object horizontal-panel% add-panel)))]
[remove-button (when multi-mode? [remove-button (when multi-mode?
(make-object horizontal-panel% remove-panel) (make-object horizontal-panel% remove-panel)
(begin0 (begin0
(make-object button% "Remove" remove-panel do-remove) (make-object button% "Remove" remove-panel (lambda (x y) (do-remove)))
(make-object horizontal-panel% remove-panel)))]) (make-object horizontal-panel% remove-panel)))])
(sequence (sequence
(make-object vertical-panel% bottom-panel)) (make-object vertical-panel% bottom-panel))
(private (private-field
[ok-button [ok-button
(make-object button% "OK" bottom-panel do-ok (if multi-mode? '() '(border)))] (make-object button% "OK" bottom-panel
[cancel-button (make-object button% "Cancel" bottom-panel do-cancel)]) (lambda (x y) (do-ok))
(if multi-mode? '() '(border)))]
[cancel-button (make-object button% "Cancel" bottom-panel (lambda (x y) (do-cancel)))])
(sequence (sequence
(make-object grow-box-spacer-pane% bottom-panel) (make-object grow-box-spacer-pane% bottom-panel)
@ -587,7 +600,6 @@
; make-common takes a dialog-maker ; make-common takes a dialog-maker
; used to make one dialog object per session, now created each time ; used to make one dialog object per session, now created each time
(define make-common (define make-common
(lambda (make-dialog) (lambda (make-dialog)
(lambda args (lambda args

22
collects/framework/private/group.ss
View File

@ -1,3 +1,4 @@
(module group mzscheme (module group mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
@ -21,8 +22,8 @@
(define mdi-parent #f) (define mdi-parent #f)
(define % (define %
(class object% () (class100 object% ()
(private (private-field
[active-frame #f] [active-frame #f]
[frame-counter 0] [frame-counter 0]
[frames null] [frames null]
@ -65,7 +66,7 @@
(lambda (frame) (lambda (frame)
(let ([label (send frame get-label)]) (let ([label (send frame get-label)])
(if (string=? label "") (if (string=? label "")
(if (ivar-in-interface? 'get-entire-label (object-interface frame)) (if (method-in-interface? 'get-entire-label (object-interface frame))
(let ([label (send frame get-entire-label)]) (let ([label (send frame get-entire-label)])
(if (string=? label "") (if (string=? label "")
default-name default-name
@ -107,21 +108,16 @@
(set-close-menu-item-state! a-frame #t)) (set-close-menu-item-state! a-frame #t))
frames))))]) frames))))])
(public (public
[get-mdi-parent [get-mdi-parent
(lambda () (lambda ()
(if (and (eq? (system-type) 'windows) (when (and (eq? (system-type) 'windows)
(preferences:get 'framework:windows-mdi)) (preferences:get 'framework:windows-mdi)
(begin (not mdi-parent))
(set! get-mdi-parent (lambda () mdi-parent))
(set! mdi-parent (make-object frame% (application:current-app-name) (set! mdi-parent (make-object frame% (application:current-app-name)
#f #f #f #f #f #f #f #f #f #f
'(mdi-parent))) '(mdi-parent)))
(send mdi-parent show #t) (send mdi-parent show #t))
mdi-parent) mdi-parent)]
(begin
(set! get-mdi-parent (lambda () #f))
#f)))]
[set-empty-callbacks [set-empty-callbacks
(lambda (test close-down) (lambda (test close-down)

2
collects/framework/private/main.ss
View File

@ -71,7 +71,7 @@
case when unless match case when unless match
let-enumerate let-enumerate
class class* class-asi class-asi* class*/names class class* class-asi class-asi* class*/names
class/d class/d* class/d*/names class100 class100* class100-asi class100-asi* class100*/names
rec rec
make-object mixin make-object mixin
define-some do opt-lambda send* define-some do opt-lambda send*

9
collects/framework/private/panel.ss
View File

@ -64,7 +64,7 @@
l))))]) l))))])
(inherit get-children) (inherit get-children)
(private [current-active-child #f]) (private-field [current-active-child #f])
(public (public
[active-child [active-child
(case-lambda (case-lambda
@ -106,7 +106,11 @@
collapse)) collapse))
(define multi-view-mixin (define multi-view-mixin
(mixin (area-container<%>) (multi-view<%>) (parent editor) (mixin (area-container<%>) (multi-view<%>) (_parent _editor)
(private-field [parent _parent]
[editor _editor])
(public (public
[get-editor-canvas% [get-editor-canvas%
(lambda () (lambda ()
@ -118,6 +122,7 @@
(lambda () (lambda ()
horizontal-panel%)]) horizontal-panel%)])
(private (private
[split [split
(lambda (p%) (lambda (p%)