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)

430
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,25 +58,33 @@
; 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]
dirs dirs
current-dir current-dir
last-selected) last-selected)
(private (private
[set-directory ; sets directory in listbox [set-directory ; sets directory in listbox
@ -98,7 +107,7 @@
[menu-list (cons in-dir menu-list)]) [menu-list (cons in-dir menu-list)])
(if base-dir (if base-dir
(loop base-dir dir-list menu-list) (loop base-dir dir-list menu-list)
; No more ; No more
(values dir-list menu-list)))))]) (values dir-list menu-list)))))])
(set! dirs (reverse dir-list)) (set! dirs (reverse dir-list))
(send dir-choice clear) (send dir-choice clear)
@ -120,17 +129,17 @@
(let ([s (car l)] (let ([s (car l)]
[rest (loop (cdr l))]) [rest (loop (cdr l))])
(cond (cond
[(and no-periods? [(and no-periods?
(<= 1 (string-length s)) (<= 1 (string-length s))
(char=? (string-ref s 0) #\.)) (char=? (string-ref s 0) #\.))
rest] rest]
[(directory-exists? (build-path dir s)) [(directory-exists? (build-path dir s))
(cons s rest)] (cons s rest)]
[(or (not file-filter) [(or (not file-filter)
(regexp-match-exact? file-filter s)) (regexp-match-exact? file-filter s))
(cons s rest)] (cons s rest)]
[else rest]))))) [else rest])))))
;(if (eq? (system-type) 'unix) string<? string-ci<?) ;(if (eq? (system-type) 'unix) string<? string-ci<?)
string-ci<? string-ci<?
)) ))
(send name-list set-selection-and-edit 0) (send name-list set-selection-and-edit 0)
@ -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
@ -188,92 +197,92 @@
(loop (sub1 n) (loop (sub1 n)
(cons (send result-list get-string n) (cons (send result-list get-string n)
result)))) result))))
; not multi-mode ; not multi-mode
(let ([name (send name-list get-string-selection)] (let ([name (send name-list get-string-selection)]
[non-empty? (> (send name-list get-number) 0)]) [non-empty? (> (send name-list get-number) 0)])
(cond (cond
[(and save-mode? [(and save-mode?
non-empty? non-empty?
(not (string? name))) 'nothing-selected] (not (string? name))) 'nothing-selected]
[(and save-mode? [(and save-mode?
non-empty? non-empty?
(string=? name "")) (string=? name ""))
(let ([file (send directory-field get-value)]) (let ([file (send directory-field get-value)])
(if (directory-exists? file) (if (directory-exists? file)
(set-directory (normal-case-path (normalize-path file))) (set-directory (normal-case-path (normalize-path file)))
(message-box (message-box
"Error" "Error"
"You must specify a file name")))] "You must specify a file name")))]
[(and save-mode? [(and save-mode?
non-empty? non-empty?
file-filter file-filter
(not (regexp-match-exact? file-filter name))) (not (regexp-match-exact? file-filter name)))
(message-box "Error" file-filter-msg)] (message-box "Error" file-filter-msg)]
[else [else
; if dir in edit box, go to that dir ; if dir in edit box, go to that dir
(let ([dir-name (send directory-field get-value)]) (let ([dir-name (send directory-field get-value)])
(if (directory-exists? dir-name) (if (directory-exists? dir-name)
(set-directory (normal-case-path (normalize-path dir-name))) (set-directory (normal-case-path (normalize-path dir-name)))
; otherwise, try to return absolute path ; otherwise, try to return absolute path
(let* ([relative-name (make-relative name)] (let* ([relative-name (make-relative name)]
[file-in-edit (file-exists? dir-name)] [file-in-edit (file-exists? dir-name)]
[file (if (or file-in-edit [file (if (or file-in-edit
(not relative-name) (not relative-name)
save-mode?) save-mode?)
dir-name dir-name
(build-path current-dir relative-name))]) (build-path current-dir relative-name))])
; trying to open a file that doesn't exist ; trying to open a file that doesn't exist
(if (and (not save-mode?) (not file-in-edit)) (if (and (not save-mode?) (not file-in-edit))
(message-box (message-box
"Error" "Error"
(string-append "The file \"" (string-append "The file \""
dir-name dir-name
"\" does not exist.")) "\" does not exist."))
; saving a file, which may exist, or ; saving a file, which may exist, or
; opening an existing file ; opening an existing file
(if (or (not save-mode?) (if (or (not save-mode?)
(not (file-exists? file)) (not (file-exists? file))
replace-ok? replace-ok?
(eq? (message-box "Warning" (eq? (message-box "Warning"
(string-append (string-append
"The file " "The file "
file file
" already exists. " " already exists. "
"Replace it?") "Replace it?")
#f #f
'(yes-no)) '(yes-no))
'yes)) 'yes))
(let ([normal-path (let ([normal-path
(with-handlers (with-handlers
([(lambda (_) #t) ([(lambda (_) #t)
(lambda (_) (lambda (_)
(message-box (message-box
"Warning" "Warning"
(string-append (string-append
"The file " "The file "
file file
" contains nonexistent directory or cycle.")) " contains nonexistent directory or cycle."))
#f)]) #f)])
(normal-case-path (normal-case-path
(normalize-path file)))]) (normalize-path file)))])
(when normal-path (when normal-path
(set-box! result-box normal-path) (set-box! result-box normal-path)
(show #f))))))))]))))] (show #f))))))))]))))]
[add-one [add-one
(lambda (name) (lambda (name)
@ -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,12 +320,12 @@
(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))])
(override (override
[on-close (lambda () #f)]) [on-close (lambda () #f)])
(sequence (sequence
(super-init (if save-mode? "Put file" "Get file") (super-init (if save-mode? "Put file" "Get file")
@ -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,95 +352,95 @@
[name-list% [name-list%
(class-asi list-box% (class100-asi list-box%
(inherit (inherit
get-string-selection get-string-selection
get-string get-string
get-selection get-selection
get-number get-number
get-first-visible-item get-first-visible-item
number-of-visible-items number-of-visible-items
set-first-visible-item set-first-visible-item
set-selection) set-selection)
(override (override
[on-subwindow-char [on-subwindow-char
(lambda (_ key) (lambda (_ key)
(let ([code (send key get-key-code)] (let ([code (send key get-key-code)]
[num-items (get-number)] [num-items (get-number)]
[curr-pos (get-selection)]) [curr-pos (get-selection)])
(cond (cond
[(or (equal? code 'numpad-return) [(or (equal? code 'numpad-return)
(equal? code #\return)) (equal? code #\return))
(if multi-mode? (if multi-mode?
(do-add) (do-add)
(do-ok))] (do-ok))]
; look for letter at beginning of a filename ; look for letter at beginning of a filename
[(char? code) [(char? code)
(let ([next-matching (let ([next-matching
(let loop ([pos (add1 curr-pos)]) (let loop ([pos (add1 curr-pos)])
(cond (cond
[(>= pos num-items) #f] [(>= pos num-items) #f]
[else [else
(let ([first-char (string-ref (get-string pos) 0)]) (let ([first-char (string-ref (get-string pos) 0)])
(if (char-ci=? code first-char) (if (char-ci=? code first-char)
pos pos
(loop (add1 pos))))]))]) (loop (add1 pos))))]))])
(if next-matching (if next-matching
(set-selection-and-edit next-matching) (set-selection-and-edit next-matching)
;; didn't find anything forward; start again at front of list ;; didn't find anything forward; start again at front of list
(let loop ([pos 0] (let loop ([pos 0]
[last-before 0]) [last-before 0])
(cond (cond
[(<= pos num-items) [(<= pos num-items)
(let ([first-char (string-ref (get-string pos) 0)]) (let ([first-char (string-ref (get-string pos) 0)])
(cond (cond
[(char-ci=? code first-char) [(char-ci=? code first-char)
(set-selection-and-edit pos)] (set-selection-and-edit pos)]
[(char-ci<=? first-char code) [(char-ci<=? first-char code)
(loop (+ pos 1) (loop (+ pos 1)
pos)] pos)]
[else [else
(set-selection-and-edit last-before)]))] (set-selection-and-edit last-before)]))]
[else (set-selection-and-edit last-before)]))))] [else (set-selection-and-edit last-before)]))))]
; movement keys ; movement keys
[(and (eq? code 'up) [(and (eq? code 'up)
(> curr-pos 0)) (> curr-pos 0))
(set-selection-and-edit (sub1 curr-pos))] (set-selection-and-edit (sub1 curr-pos))]
[(and (eq? code 'down) [(and (eq? code 'down)
(< curr-pos (sub1 num-items))) (< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)] (let* ([num-vis (number-of-visible-items)]
[curr-first (get-first-visible-item)] [curr-first (get-first-visible-item)]
[new-curr-pos (add1 curr-pos)] [new-curr-pos (add1 curr-pos)]
[new-first (if (< new-curr-pos (+ curr-first num-vis)) [new-first (if (< new-curr-pos (+ curr-first num-vis))
curr-first ; no scroll needed curr-first ; no scroll needed
(add1 curr-first))]) (add1 curr-first))])
(set-first-visible-item new-first) (set-first-visible-item new-first)
(set-selection-and-edit new-curr-pos))] (set-selection-and-edit new-curr-pos))]
[(and (eq? code 'prior) [(and (eq? code 'prior)
(> curr-pos 0)) (> curr-pos 0))
(let* ([num-vis (number-of-visible-items)] (let* ([num-vis (number-of-visible-items)]
[new-first (- (get-first-visible-item) num-vis)]) [new-first (- (get-first-visible-item) num-vis)])
(set-first-visible-item (max new-first 0)) (set-first-visible-item (max new-first 0))
(set-selection-and-edit (max 0 (- curr-pos num-vis))))] (set-selection-and-edit (max 0 (- curr-pos num-vis))))]
[(and (eq? code 'next) [(and (eq? code 'next)
(< curr-pos (sub1 num-items))) (< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)] (let* ([num-vis (number-of-visible-items)]
[new-first (+ (get-first-visible-item) num-vis)]) [new-first (+ (get-first-visible-item) num-vis)])
(set-first-visible-item (set-first-visible-item
(min new-first (- (get-number) num-vis))) (min new-first (- (get-number) num-vis)))
(set-selection-and-edit (set-selection-and-edit
(min (sub1 num-items) (+ curr-pos num-vis))))] (min (sub1 num-items) (+ curr-pos num-vis))))]
[else #f])))]) [else #f])))])
(public (public
[set-selection-and-edit [set-selection-and-edit
@ -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,41 +553,44 @@
(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
(make-object horizontal-panel% add-panel)))] (lambda (x y) (do-add-all)))
(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)
(cond (cond
[(and start-dir [(and start-dir
(directory-exists? start-dir)) (directory-exists? start-dir))
(set-directory (normal-case-path (set-directory (normal-case-path
(normalize-path start-dir)))] (normalize-path start-dir)))]
[last-directory (set-directory last-directory)] [last-directory (set-directory last-directory)]
[else (set-directory (current-directory))]) [else (set-directory (current-directory))])
(send ok-button min-width (send cancel-button get-width)) (send ok-button min-width (send cancel-button get-width))
@ -585,9 +598,8 @@
(show #t)))) (show #t))))
; 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

28
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%)