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

..

Browse Source 
original commit: 751a47d7442fe5865e4f9ba6b2557b610f92da4f
This commit is contained in:
Robby Findler 2003-08-12 17:39:27 +00:00
parent c074ae181f
commit c911e52979
1 changed files with 164 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

288
collects/framework/private/frame.ss
View File

@ -221,17 +221,20 @@
(show #f)))] (show #f)))]
(inherit accept-drop-files) (inherit accept-drop-files)
(super-instantiate ())
(super-instantiate ())
(accept-drop-files #t) (accept-drop-files #t)
(let ([mb (make-object (get-menu-bar%) this)]) (let ([mb (make-object (get-menu-bar%) this)])
(when (or (eq? (system-type) 'macos) (when (or (eq? (system-type) 'macos)
(eq? (system-type) 'macosx)) (eq? (system-type) 'macosx))
(make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label)
mb))) mb)))
(reorder-menus this) (reorder-menus this)
(send (group:get-the-frame-group) insert-frame this) (send (group:get-the-frame-group) insert-frame this)
[define panel (make-root-area-container (get-area-container%) this)] [define panel (make-root-area-container (get-area-container%) this)]
(public get-area-container) (public get-area-container)
[define get-area-container (lambda () panel)] [define get-area-container (lambda () panel)]
@ -264,7 +267,9 @@
(draw locked-message "yellow" 'solid "black" 'solid) (draw locked-message "yellow" 'solid "black" 'solid)
(draw unlocked-message (get-panel-background) 'panel (get-panel-background) 'transparent)))) (draw unlocked-message (get-panel-background) 'panel (get-panel-background) 'transparent))))
(inherit get-parent min-width min-height stretchable-width stretchable-height) (inherit get-parent min-width min-height stretchable-width stretchable-height)
(super-instantiate ())
(super-instantiate ())
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(send dc set-font (send (get-parent) get-label-font)) (send dc set-font (send (get-parent) get-label-font))
(let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message)] (let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message)]
@ -445,7 +450,7 @@
;; need high priority callbacks to ensure ordering wrt other callbacks ;; need high priority callbacks to ensure ordering wrt other callbacks
(queue-callback t #t)))) (queue-callback t #t))))
(super-instantiate ()))) (super-instantiate ())))
(define info<%> (interface (basic<%>) (define info<%> (interface (basic<%>)
determine-width determine-width
@ -561,7 +566,7 @@
(lambda () (lambda ()
(lock-status-changed))] (lock-status-changed))]
(super-instantiate ()) (super-instantiate ())
(set! outer-info-panel (make-object horizontal-panel% super-root)) (set! outer-info-panel (make-object horizontal-panel% super-root))
(send outer-info-panel stretchable-height #f) (send outer-info-panel stretchable-height #f)
@ -827,7 +832,7 @@
(overwrite-status-changed) (overwrite-status-changed)
(anchor-status-changed) (anchor-status-changed)
(editor-position-changed))] (editor-position-changed))]
(super-instantiate ()) (super-instantiate ())
(inherit get-info-panel) (inherit get-info-panel)
@ -1109,9 +1114,7 @@
(define help-menu:about-string (lambda () (application:current-app-name))) (define help-menu:about-string (lambda () (application:current-app-name)))
(define help-menu:create-about? (lambda () #t)) (define help-menu:create-about? (lambda () #t))
(super-instantiate (super-instantiate () (label (get-entire-label)))
()
(label (get-entire-label)))
(define canvas #f) (define canvas #f)
(define editor #f) (define editor #f)
@ -1129,12 +1132,16 @@
(send (get-canvas) set-editor editor)) (send (get-canvas) set-editor editor))
editor)) editor))
(cond (cond
[(and filename (file-exists? filename)) [(and filename (file-exists? filename))
(send (get-editor) load-file/gui-error filename 'guess)] (let ([ed (get-editor)])
[filename (send ed begin-edit-sequence)
(send (get-editor) set-filename filename)] (send ed load-file/gui-error filename 'guess)
[else (void)]) (send ed end-edit-sequence))]
[filename
(send (get-editor) set-filename filename)]
[else (void)])
(let ([ed-fn (send (get-editor) get-filename)]) (let ([ed-fn (send (get-editor) get-filename)])
(set! label (if ed-fn (set! label (if ed-fn
(or (file-name-from-path ed-fn) (or (file-name-from-path ed-fn)
@ -1265,8 +1272,7 @@
[(cancel) [(cancel)
#f])))) #f]))))
(super-instantiate ())))
(super-instantiate ())))
(define text<%> (interface (-editor<%>))) (define text<%> (interface (-editor<%>)))
(define text-mixin (define text-mixin
@ -1434,7 +1440,7 @@
[b (box 0)]) [b (box 0)])
(position-location pos #f b top? #f #t) (position-location pos #f b top? #f #t)
(unbox b))) (unbox b)))
(super-instantiate ()) (super-instantiate ())
(inherit set-cursor) (inherit set-cursor)
(set-cursor (make-object cursor% 'arrow)) (set-cursor (make-object cursor% 'arrow))
@ -1514,7 +1520,7 @@
(define/public (get-delegatee) delegatee) (define/public (get-delegatee) delegatee)
(super-instantiate ()) (super-instantiate ())
(define delegatee (instantiate delegatee-text% ())) (define delegatee (instantiate delegatee-text% ()))
(define delegate-ec (instantiate delegatee-editor-canvas% () (define delegate-ec (instantiate delegatee-editor-canvas% ()
@ -1979,9 +1985,10 @@
(error 'get-text-to-search "abstract method in searchable-mixin")) (error 'get-text-to-search "abstract method in searchable-mixin"))
(define/public hide-search (define/public hide-search
(opt-lambda ([startup? #f]) (opt-lambda ([startup? #f])
(send super-root change-children (when search-gui-built?
(lambda (l) (send super-root change-children
(remove search-panel l))) (lambda (l)
(remove search-panel l))))
(clear-search-highlight) (clear-search-highlight)
(unless startup? (unless startup?
(let ([canvas (send (get-text-to-search) get-canvas)]) (let ([canvas (send (get-text-to-search) get-canvas)])
@ -1994,13 +2001,17 @@
(when (and hidden? (when (and hidden?
(not (preferences:get 'framework:search-using-dialog?))) (not (preferences:get 'framework:search-using-dialog?)))
(set! hidden? #f) (set! hidden? #f)
(build-search-gui-in-frame)
(let ([canvas (send (get-text-to-search) get-canvas)]) (let ([canvas (send (get-text-to-search) get-canvas)])
(when canvas (when canvas
(send canvas force-display-focus #t))) (send canvas force-display-focus #t)))
(show/hide-replace (send (get-text-to-search) is-locked?)) (show/hide-replace (send (get-text-to-search) is-locked?))
(send search-panel focus) (send search-panel focus)
(send find-edit set-position 0 (send find-edit last-position)) (send find-edit set-position 0 (send find-edit last-position))
(send super-root add-child search-panel) (unless (memq search-panel (send super-root get-children))
(send super-root add-child search-panel))
(reset-search-anchor (get-text-to-search)))) (reset-search-anchor (get-text-to-search))))
(define (undock) (define (undock)
@ -2008,7 +2019,8 @@
(hide-search) (hide-search)
(search-dialog this)) (search-dialog this))
(define (show/hide-replace hide?) ;; pre-condition : search-gui-built? is #t
(define/private (show/hide-replace hide?)
(cond (cond
[hide? [hide?
(send replace-canvas-panel change-children (send replace-canvas-panel change-children
@ -2038,8 +2050,9 @@
(let ([close-canvas (let ([close-canvas
(lambda (canvas edit) (lambda (canvas edit)
(send canvas set-editor #f))]) (send canvas set-editor #f))])
(close-canvas find-canvas find-edit) (when search-gui-built?
(close-canvas replace-canvas replace-edit)) (close-canvas find-canvas find-edit)
(close-canvas replace-canvas replace-edit)))
(when (eq? this searching-frame) (when (eq? this searching-frame)
(set-searching-frame #f)))) (set-searching-frame #f))))
(public set-search-direction can-replace? replace&search replace-all replace (public set-search-direction can-replace? replace&search replace-all replace
@ -2048,7 +2061,8 @@
(define set-search-direction (define set-search-direction
(lambda (x) (lambda (x)
(set-searching-direction x) (set-searching-direction x)
(send dir-radio set-selection (if (eq? x 'forward) 0 1)))) (when dir-radio
(send dir-radio set-selection (if (eq? x 'forward) 0 1)))))
(define can-replace? (define can-replace?
(lambda () (lambda ()
(let ([tx (get-text-to-search)]) (let ([tx (get-text-to-search)])
@ -2114,14 +2128,14 @@
(define (toggle-search-focus) (define (toggle-search-focus)
(set-searching-frame this) (set-searching-frame this)
(unhide-search) (unhide-search)
(send (cond (send (cond
[(send find-canvas has-focus?) [(send find-canvas has-focus?)
replace-canvas] replace-canvas]
[(send replace-canvas has-focus?) [(send replace-canvas has-focus?)
(send (get-text-to-search) get-canvas)] (send (get-text-to-search) get-canvas)]
[else [else
find-canvas]) find-canvas])
focus)) focus))
(define move-to-search-or-search (define move-to-search-or-search
(lambda () (lambda ()
(set-searching-frame this) (set-searching-frame this)
@ -2130,10 +2144,10 @@
[(preferences:get 'framework:search-using-dialog?) [(preferences:get 'framework:search-using-dialog?)
(search-dialog this)] (search-dialog this)]
[else [else
(if (or (send find-canvas has-focus?) (if (or (send find-canvas has-focus?)
(send replace-canvas has-focus?)) (send replace-canvas has-focus?))
(search-again 'forward) (search-again 'forward)
(send find-canvas focus))]))) (send find-canvas focus))])))
(define move-to-search-or-reverse-search (define move-to-search-or-reverse-search
(lambda () (lambda ()
(set-searching-frame this) (set-searching-frame this)
@ -2149,85 +2163,111 @@
(set-search-direction direction) (set-search-direction direction)
(send find-edit search #t beep?))) (send find-edit search #t beep?)))
(super-instantiate ()) (define search-panel #f)
(define search-gui-built? #f)
(define search-panel (make-object horizontal-panel% super-root '(border))) (define dir-radio #f)
(define replace-canvas-panel #f)
(define left-panel (make-object vertical-panel% search-panel)) (define find-canvas #f)
(define find-canvas (make-object searchable-canvas% left-panel)) (define replace-canvas #f)
(define replace-canvas-panel (instantiate vertical-panel% () (define hidden? #t)
(parent left-panel) (define replace-button-panel #f)
(stretchable-width #t) (define middle-middle-panel #f)
(stretchable-height #f))) (define replace-button #f)
(define replace-canvas (make-object searchable-canvas% replace-canvas-panel)) (define replace&search-button #f)
(define replace-all-button #f)
(define middle-left-panel (make-object vertical-pane% search-panel))
(define middle-middle-panel (make-object vertical-pane% search-panel)) (inherit begin-container-sequence end-container-sequence)
(define middle-right-panel (make-object vertical-pane% search-panel)) (define/private (build-search-gui-in-frame)
(unless search-gui-built?
(define search-button (make-object button% (set! search-gui-built? #t)
(string-constant find) (begin-container-sequence)
middle-left-panel (let ()
(lambda args (search-again)))) (define _0 (set! search-panel (make-object horizontal-panel% super-root '(border))))
(define left-panel (make-object vertical-panel% search-panel))
(define replace-button-panel (define _1 (set! find-canvas (make-object searchable-canvas% left-panel)))
(instantiate vertical-panel% () (define _2
(parent middle-left-panel) (set! replace-canvas-panel (instantiate vertical-panel% ()
(stretchable-width #f) (parent left-panel)
(stretchable-height #f))) (stretchable-width #t)
(stretchable-height #f))))
(define replace-button (make-object button% (string-constant replace) (define _3
replace-button-panel (set! replace-canvas (make-object searchable-canvas% replace-canvas-panel)))
(lambda x (replace))))
(define middle-left-panel (make-object vertical-pane% search-panel))
(define replace&search-button (make-object button% (define _4
(string-constant replace&find-again) (set! middle-middle-panel (make-object vertical-pane% search-panel)))
middle-middle-panel (define middle-right-panel (make-object vertical-pane% search-panel))
(lambda x (replace&search))))
(define search-button (make-object button%
(define replace-all-button (make-object button% (string-constant find)
(string-constant replace-to-end) middle-left-panel
middle-middle-panel (lambda args (search-again))))
(lambda x (replace-all))))
(define _5
(define dir-radio (make-object radio-box% (set! replace-button-panel
#f (instantiate vertical-panel% ()
(list (string-constant forward) (parent middle-left-panel)
(string-constant backward)) (stretchable-width #f)
middle-right-panel (stretchable-height #f))))
(lambda (dir-radio evt)
(let ([forward (if (= (send dir-radio get-selection) 0) (define _6
'forward (set! replace-button (make-object button% (string-constant replace)
'backward)]) replace-button-panel
(set-search-direction forward) (lambda x (replace)))))
(reset-search-anchor (get-text-to-search))))))
(define hide/undock-pane (make-object horizontal-panel% middle-right-panel)) (define _7
(define hide-button (make-object button% (string-constant hide) (set! replace&search-button (make-object button%
hide/undock-pane (string-constant replace&find-again)
(lambda args (hide-search)))) middle-middle-panel
(define undock-button (make-object button% (string-constant undock) (lambda x (replace&search)))))
hide/undock-pane
(lambda args (undock)))) (define _8
(define hidden? #f) (set! replace-all-button (make-object button%
(string-constant replace-to-end)
(let ([align middle-middle-panel
(lambda (x y) (lambda x (replace-all)))))
(let ([m (max (send x get-width) (define _9
(send y get-width))]) (set! dir-radio (make-object radio-box%
(send x min-width m) #f
(send y min-width m)))]) (list (string-constant forward)
(align search-button replace-button) (string-constant backward))
(align replace&search-button replace-all-button)) middle-right-panel
(for-each (lambda (x) (send x set-alignment 'center 'center)) (lambda (dir-radio evt)
(list middle-left-panel middle-middle-panel)) (let ([forward (if (= (send dir-radio get-selection) 0)
(for-each (lambda (x) (send x stretchable-height #f)) 'forward
(list search-panel middle-left-panel middle-middle-panel middle-right-panel)) 'backward)])
(for-each (lambda (x) (send x stretchable-width #f)) (set-search-direction forward)
(list middle-left-panel middle-middle-panel middle-right-panel)) (reset-search-anchor (get-text-to-search)))))))
(send find-canvas set-editor find-edit)
(send find-canvas stretchable-height #t) (define hide/undock-pane (make-object horizontal-panel% middle-right-panel))
(send replace-canvas set-editor replace-edit) (define hide-button (make-object button% (string-constant hide)
(hide-search #t))) hide/undock-pane
(lambda args (hide-search))))
(define undock-button (make-object button% (string-constant undock)
hide/undock-pane
(lambda args (undock))))
(let ([align
(lambda (x y)
(let ([m (max (send x get-width)
(send y get-width))])
(send x min-width m)
(send y min-width m)))])
(align search-button replace-button)
(align replace&search-button replace-all-button))
(for-each (lambda (x) (send x set-alignment 'center 'center))
(list middle-left-panel middle-middle-panel))
(for-each (lambda (x) (send x stretchable-height #f))
(list search-panel middle-left-panel middle-middle-panel middle-right-panel))
(for-each (lambda (x) (send x stretchable-width #f))
(list middle-left-panel middle-middle-panel middle-right-panel))
(send find-canvas set-editor find-edit)
(send find-canvas stretchable-height #t)
(send replace-canvas set-editor replace-edit))
(end-container-sequence)))
(super-instantiate ())
(hide-search)))
(define searchable-text<%> (interface (searchable<%> text<%>))) (define searchable-text<%> (interface (searchable<%> text<%>)))
@ -2275,7 +2315,7 @@
[else #f]))]) [else #f]))])
(and user-allowed-or-not-modified (and user-allowed-or-not-modified
(super-can-close?))))] (super-can-close?))))]
(super-instantiate ()))) (super-instantiate ())))
(define bday-click-canvas% (define bday-click-canvas%
(class canvas% (class canvas%