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

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

@ -221,7 +221,9 @@
(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)])
@ -232,6 +234,7 @@
(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)]
@ -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)
@ -1131,10 +1134,14 @@
(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)])
(send ed begin-edit-sequence)
(send ed load-file/gui-error filename 'guess)
(send ed end-edit-sequence))]
[filename [filename
(send (get-editor) set-filename filename)] (send (get-editor) set-filename filename)]
[else (void)]) [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,7 +1272,6 @@
[(cancel) [(cancel)
#f])))) #f]))))
(super-instantiate ()))) (super-instantiate ())))
(define text<%> (interface (-editor<%>))) (define text<%> (interface (-editor<%>)))
@ -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])
(when search-gui-built?
(send super-root change-children (send super-root change-children
(lambda (l) (lambda (l)
(remove search-panel 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))])
(when search-gui-built?
(close-canvas find-canvas find-edit) (close-canvas find-canvas find-edit)
(close-canvas replace-canvas replace-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)])
@ -2149,20 +2163,39 @@
(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 find-canvas #f)
(define replace-canvas #f)
(define hidden? #t)
(define replace-button-panel #f)
(define middle-middle-panel #f)
(define replace-button #f)
(define replace&search-button #f)
(define replace-all-button #f)
(inherit begin-container-sequence end-container-sequence)
(define/private (build-search-gui-in-frame)
(unless search-gui-built?
(set! search-gui-built? #t)
(begin-container-sequence)
(let ()
(define _0 (set! search-panel (make-object horizontal-panel% super-root '(border))))
(define left-panel (make-object vertical-panel% search-panel)) (define left-panel (make-object vertical-panel% search-panel))
(define find-canvas (make-object searchable-canvas% left-panel)) (define _1 (set! find-canvas (make-object searchable-canvas% left-panel)))
(define replace-canvas-panel (instantiate vertical-panel% () (define _2
(set! replace-canvas-panel (instantiate vertical-panel% ()
(parent left-panel) (parent left-panel)
(stretchable-width #t) (stretchable-width #t)
(stretchable-height #f))) (stretchable-height #f))))
(define replace-canvas (make-object searchable-canvas% replace-canvas-panel)) (define _3
(set! replace-canvas (make-object searchable-canvas% replace-canvas-panel)))
(define middle-left-panel (make-object vertical-pane% search-panel)) (define middle-left-panel (make-object vertical-pane% search-panel))
(define middle-middle-panel (make-object vertical-pane% search-panel)) (define _4
(set! middle-middle-panel (make-object vertical-pane% search-panel)))
(define middle-right-panel (make-object vertical-pane% search-panel)) (define middle-right-panel (make-object vertical-pane% search-panel))
(define search-button (make-object button% (define search-button (make-object button%
@ -2170,27 +2203,31 @@
middle-left-panel middle-left-panel
(lambda args (search-again)))) (lambda args (search-again))))
(define replace-button-panel (define _5
(set! replace-button-panel
(instantiate vertical-panel% () (instantiate vertical-panel% ()
(parent middle-left-panel) (parent middle-left-panel)
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f))) (stretchable-height #f))))
(define replace-button (make-object button% (string-constant replace) (define _6
(set! replace-button (make-object button% (string-constant replace)
replace-button-panel replace-button-panel
(lambda x (replace)))) (lambda x (replace)))))
(define replace&search-button (make-object button% (define _7
(set! replace&search-button (make-object button%
(string-constant replace&find-again) (string-constant replace&find-again)
middle-middle-panel middle-middle-panel
(lambda x (replace&search)))) (lambda x (replace&search)))))
(define replace-all-button (make-object button% (define _8
(set! replace-all-button (make-object button%
(string-constant replace-to-end) (string-constant replace-to-end)
middle-middle-panel middle-middle-panel
(lambda x (replace-all)))) (lambda x (replace-all)))))
(define _9
(define dir-radio (make-object radio-box% (set! dir-radio (make-object radio-box%
#f #f
(list (string-constant forward) (list (string-constant forward)
(string-constant backward)) (string-constant backward))
@ -2200,7 +2237,8 @@
'forward 'forward
'backward)]) 'backward)])
(set-search-direction forward) (set-search-direction forward)
(reset-search-anchor (get-text-to-search)))))) (reset-search-anchor (get-text-to-search)))))))
(define hide/undock-pane (make-object horizontal-panel% middle-right-panel)) (define hide/undock-pane (make-object horizontal-panel% middle-right-panel))
(define hide-button (make-object button% (string-constant hide) (define hide-button (make-object button% (string-constant hide)
hide/undock-pane hide/undock-pane
@ -2208,8 +2246,6 @@
(define undock-button (make-object button% (string-constant undock) (define undock-button (make-object button% (string-constant undock)
hide/undock-pane hide/undock-pane
(lambda args (undock)))) (lambda args (undock))))
(define hidden? #f)
(let ([align (let ([align
(lambda (x y) (lambda (x y)
(let ([m (max (send x get-width) (let ([m (max (send x get-width)
@ -2226,8 +2262,12 @@
(list middle-left-panel middle-middle-panel middle-right-panel)) (list middle-left-panel middle-middle-panel middle-right-panel))
(send find-canvas set-editor find-edit) (send find-canvas set-editor find-edit)
(send find-canvas stretchable-height #t) (send find-canvas stretchable-height #t)
(send replace-canvas set-editor replace-edit) (send replace-canvas set-editor replace-edit))
(hide-search #t))) (end-container-sequence)))
(super-instantiate ())
(hide-search)))
(define searchable-text<%> (interface (searchable<%> text<%>))) (define searchable-text<%> (interface (searchable<%> text<%>)))