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

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

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

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

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

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

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

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

@ -64,7 +64,7 @@
l))))])
(inherit get-children)
(private [current-active-child #f])
(private-field [current-active-child #f])
(public
[active-child
(case-lambda
@ -106,7 +106,11 @@
collapse))
(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
[get-editor-canvas%
(lambda ()
@ -118,6 +122,7 @@
(lambda ()
horizontal-panel%)])
(private
[split
(lambda (p%)