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

.

Browse Source 
original commit: c022e6499475455f0aac92117c44317e5cba075e
This commit is contained in:
Robby Findler 2004-02-17 14:31:48 +00:00
parent 61a3a41fcd
commit 59ab491de6
4 changed files with 41 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,15 +2,13 @@
(module editor mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(lib "class100.ss")
(lib "string-constant.ss" "string-constants")
"sig.ss"
"../gui-utils.ss"
"../macro.ss"
(lib "etc.ss")
(lib "mred-sig.ss" "mred")
(lib "file.ss")
(lib "list.ss"))
(lib "file.ss"))
(provide editor@)
@ -36,7 +34,6 @@
(define basic<%>
(interface (editor<%>)
has-focus?
editing-this-file?
local-edit-sequence?
run-after-edit-sequence
get-top-level-window
@ -194,8 +191,6 @@
(send canvas get-top-level-window))]
[else #f]))))
[define/public editing-this-file? (lambda () #f)]
[define edit-sequence-queue null]
[define edit-sequence-ht (make-hash-table)]
[define in-local-edit-sequence? #f]
@ -402,8 +397,6 @@
[super-after-load-file after-load-file]
[super-get-keymaps get-keymaps]
[super-set-filename set-filename])
(define/override (editing-this-file?) #t)
(inherit get-canvases)
(define/private (check-lock)

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

@ -125,7 +125,9 @@
get-menu-bar%
make-root-area-container
close
get-filename))
editing-this-file?
get-filename
make-visible))
(define basic-mixin
(mixin ((class->interface frame%)) (basic<%>)
@ -148,53 +150,52 @@
(lambda ()
(exit)
(exit:set-exiting #f))))
(public get-filename)
[define get-filename
(define/public (make-visible filename) (void))
(define/public get-filename
(case-lambda
[() (get-filename #f)]
[(b) #f])]
[(b) #f]))
(define/public (editing-this-file? filename) #f)
(override on-superwindow-show)
(rename [super-on-superwindow-show on-superwindow-show])
(define (on-superwindow-show shown?)
(define/override (on-superwindow-show shown?)
(send (group:get-the-frame-group) frame-shown/hidden this)
(super-on-superwindow-show shown?))
(define after-init? #f)
[define/override on-drop-file
(define/override on-drop-file
(lambda (filename)
(handler:edit-file filename))]
(handler:edit-file filename)))
;; added call to set label here to hopefully work around a problem in mac mred
(inherit set-label change-children)
(override after-new-child)
[define after-new-child
(define/override after-new-child
(lambda (child)
(when after-init?
(change-children (lambda (l) (remq child l)))
(error 'frame:basic-mixin
"do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead"
)))]
))))
(public get-area-container% get-menu-bar% make-root-area-container close)
[define get-area-container% (lambda () vertical-panel%)]
[define get-menu-bar% (lambda () menu-bar%)]
[define make-root-area-container
(define/public get-area-container% (lambda () vertical-panel%))
(define/public get-menu-bar% (lambda () menu-bar%))
(define/public make-root-area-container
(lambda (% parent)
(make-object % parent))]
(make-object % parent)))
(inherit can-close? on-close)
[define close
(define/public close
(lambda ()
(when (can-close?)
(on-close)
(show #f)))]
(show #f))))
(inherit accept-drop-files)
(super-instantiate ())
(super-new)
(accept-drop-files #t)
@ -207,8 +208,7 @@
(reorder-menus this)
[define panel (make-root-area-container (get-area-container%) this)]
(public get-area-container)
[define get-area-container (lambda () panel)]
(define/public (get-area-container) panel)
(set! after-init? #t)))
(define register-group<%> (interface ()))
@ -942,17 +942,25 @@
(rename [super-on-close on-close]
[super-set-label set-label])
(override get-filename on-close)
[define get-filename
(define/override get-filename
(case-lambda
[() (get-filename #f)]
[(b)
(let ([e (get-editor)])
(and e (send e get-filename b)))])]
[define on-close
(lambda ()
(super-on-close)
(send (get-editor) on-close))]
(and e (send e get-filename b)))]))
(define/override (editing-this-file? filename)
(let ([path-equal?
(lambda (x y)
(equal? (normal-case-path (normalize-path x))
(normal-case-path (normalize-path y))))])
(let ([this-fn (get-filename)])
(and this-fn
(path-equal? filename (get-filename))))))
(define/override (on-close)
(super-on-close)
(send (get-editor) on-close))
[define label ""]
[define label-prefix (application:current-app-name)]
(define (do-label)

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

@ -247,14 +247,7 @@
[test-frame
(lambda (frame)
(and (is-a? frame frame:basic<%>)
(let* ([filename (send frame get-filename)])
(and (string? filename)
(string=? normalized
(with-handlers ([(lambda (x) #t)
(lambda (x) filename)])
(normal-case-path
(normalize-path
filename))))))))])
(send frame editing-this-file? normalized)))])
(let loop ([frames frames])
(cond
[(null? frames) #f]

3
collects/framework/private/handler.ss
View File

@ -131,7 +131,8 @@
filename)])
(cond
[already-open
(send already-open show #t)
(send already-open make-visible filename)
(send already-open show #t)
already-open]
[(and (preferences:get 'framework:open-here?)
(send (group:get-the-frame-group) get-open-here-frame))