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

..

Browse Source 
original commit: fe9b150214380547fb9c4a7c82bfc619e2ac338e
This commit is contained in:
Robby Findler 2002-09-11 03:29:44 +00:00
parent e52d2b6740
commit ac6fa73807
8 changed files with 110 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/framework/framework.ss
View File

@ -274,21 +274,26 @@
"This function doesn't return until the user has finished"
"restoring the autosave files. (It uses yield to handle events"
"however).")
(exit:frame-exiting
(case->
((union false? (is-a?/c frame%) (is-a?/c dialog%))
. -> .
void?)
(-> (union false? (is-a?/c frame%) (is-a?/c dialog%))))
((frame) ())
"This is a parameter whose value is used as the parent of the ``Are you"
"sure you want to exit'' dialog."
(exit:exiting?
(-> boolean?)
()
"Returns \\rawscm{\\#t} to indicate that an exit"
"operation is taking place. Does not indicate that the"
"app will actually exit, since the user may cancel"
"the exit."
""
"The first case of the case-lambda sets"
"the value of the parameter to \\var{frame}."
"The second case of the case-lambda "
"returns the current value of the parameter.")
"See also"
"@flink exit:insert-on-callback"
"and"
"@flink exit:insert-can?-callback %"
".")
(exit:set-exiting
(boolean? . -> . void?)
(exiting?)
"Sets a flag that affects the result of"
"@flink exit:exiting? %"
".")
(exit:insert-on-callback
((-> void?) . -> . (-> void?))
(callback)
@ -305,18 +310,12 @@
"@flink exit:insert-on-callback"
"for callbacks that clean up state.")
(exit:can-exit?
(boolean? . -> . void?)
(skip-user-query?)
"Calls the ``can-callbacks''. See"
(-> boolean?)
()
"Calls the ``can-callbacks'' and returns their results."
"See"
"@flink exit:insert-can?-callback"
"for more information."
""
"If \\var{skip-user-query?} is \\rawscm{\\#f}, "
"and the preference \\rawscm{'framework:verify-exit} is not \\rawscm{\\#f},"
"(see \\hyperref{the preferences section}{section~}{ for more info about"
"preferences}{fw:preferences})"
"this procedure asks the user if they want to exit."
"Otherwise it doesn't ask the user.")
"for more information.")
(exit:on-exit
(-> void?)
()
@ -324,13 +323,13 @@
"@flink exit:insert-on-callback"
"for more information.")
(exit:exit
(opt->
()
(boolean?)
any?)
(() ((skip-user-query? #f)))
"\\rawscm{exit:exit} performs three actions:"
(-> any)
()
"\\rawscm{exit:exit} performs four actions:"
"\\begin{itemize}"
"\\item sets the result of the"
"@flink exit:exiting?"
"function to \\rawscm{\\#t}."
"\\item invokes the exit-callbacks, with "
"@flink exit:can-exit? %"
"If none of the ``can?'' callbacks return \\rawscm{\\#f}, "
@ -339,13 +338,20 @@
"@flink exit:on-exit %"
"and then "
"\\item"
"\\rawscm{exit} (a mzscheme procedure)."
"\\end{itemize}"
""
"Passes \\var{skip-user-query?} to "
"@flink exit:can-exit? %"
".")
"queues a callback that calls"
"\\rawscm{exit} (a mzscheme procedure)"
"and (if \\rawscm{exit} returns) sets the"
"result of"
"@flink exit:exiting?"
"back to \\rawscm{\\#t}."
"\\end{itemize}")
(exit:user-oks-exit
(-> boolean?)
()
"Opens a dialog that queries the user"
"about exiting. Returns the user's decision.")
(path-utils:generate-autosave-name
(string? . -> . string?)
(filename)

8
collects/framework/private/autosave.ss
View File

@ -20,7 +20,8 @@
[scheme : framework:scheme^]
[editor : framework:editor^]
[text : framework:text^]
[finder : framework:finder^])
[finder : framework:finder^]
[group : framework:group^])
(define autosavable<%>
(interface ()
@ -143,8 +144,11 @@
(define final-frame%
(class frame:basic%
(rename [super-on-close on-close])
(define/override (can-close?) #t)
(define/override (on-close)
(super-on-close)
(send (group:get-the-frame-group)
remove-frame
this)
(semaphore-post done-semaphore))
(super-instantiate ())))

36
collects/framework/private/exit.ss
View File

@ -16,8 +16,6 @@
[preferences : framework:preferences^])
(rename (-exit exit))
(define frame-exiting (make-parameter #f))
(define can?-callbacks '())
(define on-callbacks '())
@ -43,13 +41,11 @@
[(eq? cb (car cb-list)) (cdr cb-list)]
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
(define exiting? #f)
(define can-exit?
(opt-lambda ([skip-user-query? #f])
(and (or skip-user-query?
(user-oks-exit))
(andmap (lambda (cb) (cb)) can?-callbacks))))
(define is-exiting? #f)
(define (set-exiting b) (set! is-exiting? b))
(define (exiting?) is-exiting?)
(define (can-exit?) (andmap (lambda (cb) (cb)) can?-callbacks))
(define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
(define (user-oks-exit)
@ -63,15 +59,17 @@
(string-constant quit))
(string-constant cancel)
(string-constant warning)
#f
(frame-exiting))
#f)
#t))
(define -exit
(opt-lambda ([skip-user-query? #f])
(unless exiting?
(set! exiting? #t)
(when (can-exit? skip-user-query?)
(on-exit)
(queue-callback (lambda () (exit))))
(set! exiting? #f)))))))
(define (-exit)
(set! is-exiting? #t)
(cond
[(can-exit?)
(on-exit)
(queue-callback
(lambda ()
(exit)
(set! is-exiting? #f)))]
[else
(set! is-exiting? #f)])))))

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

@ -129,12 +129,18 @@
(define basic-mixin
(mixin ((class->interface frame%)) (basic<%>)
(define/override (can-exit?) (exit:can-exit?))
(define/override (on-exit) (exit:on-exit) (exit))
(rename [super-can-close? can-close?]
[super-on-close on-close]
[super-on-focus on-focus])
(define/override (can-exit?)
(exit:set-exiting #t)
(let ([res (exit:can-exit?)])
(unless res
(exit:set-exiting #f))
res))
(define/override (on-exit)
(exit:on-exit)
(queue-callback
(lambda ()
(exit)
(exit:set-exiting #f))))
(public get-filename)
[define get-filename
@ -149,22 +155,30 @@
(super-on-superwindow-show shown?))
(rename [super-can-close? can-close?]
[super-on-close on-close]
[super-on-focus on-focus])
(define after-init? #f)
(override can-close? on-close on-focus on-drop-file)
[define can-close?
(lambda ()
(let ([super (super-can-close?)]
[group
(send (group:get-the-frame-group)
can-remove-frame?
this)])
(and super group)))]
(let ([number-of-frames
(length (send (group:get-the-frame-group)
get-frames))])
(and (super-can-close?)
(or (exit:exiting?)
(not (= 1 number-of-frames))
(exit:user-oks-exit)))))]
[define on-close
(lambda ()
(super-on-close)
(send (group:get-the-frame-group)
remove-frame
this))]
this)
(unless (exit:exiting?)
(when (null? (send (group:get-the-frame-group) get-frames))
(exit:exit))))]
[define on-focus
(lambda (on?)
(super-on-focus on?)

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

@ -34,10 +34,6 @@
[define frames null]
[define todo-to-new-frames void]
(define ignore-empty-test? #f)
[define empty-close-down (lambda () (void))]
[define empty-test (lambda () #t)]
[define windows-menus null]
[define get-windows-menu
@ -181,8 +177,8 @@
#f
(frame-frame (car candidates))))]))
(public get-mdi-parent set-empty-callbacks frame-label-changed for-each-frame
get-active-frame set-active-frame insert-frame can-remove-frame?
(public get-mdi-parent frame-label-changed for-each-frame
get-active-frame set-active-frame insert-frame
remove-frame clear on-close-all can-close-all? locate-file get-frames
frame-shown/hidden)
[define get-mdi-parent
@ -196,13 +192,6 @@
(send mdi-parent show #t))
mdi-parent)]
[define set-empty-callbacks
(lambda (test close-down)
(set! empty-test test)
(set! empty-close-down close-down))]
(define/public (set-ignore-empty-test b)
(set! ignore-empty-test? b))
[define get-frames (lambda () (map frame-frame frames))]
[define frame-label-changed
@ -243,16 +232,6 @@
(update-windows-menus))
(todo-to-new-frames f))]
[define can-remove-frame?
(lambda (f)
(let ([new-frames
(remove
f frames
(lambda (f fr) (eq? f (frame-frame fr))))])
(if (null? new-frames)
(or ignore-empty-test?
(empty-test))
#t)))]
[define remove-frame
(lambda (f)
(when (eq? f active-frame)
@ -264,16 +243,11 @@
(set! frames new-frames)
(update-close-menu-item-state)
(remove-windows-menu f)
(update-windows-menus)
(when (null? frames)
(unless ignore-empty-test?
(empty-close-down)))))]
(update-windows-menus)))]
[define clear
(lambda ()
(and (empty-test)
(begin (set! frames null)
(empty-close-down)
#t)))]
(set! frames null)
#t)]
[define on-close-all
(lambda ()
(for-each (lambda (f)

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

@ -143,48 +143,13 @@
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
(let ([at-most-one
(let ([skip? #f])
(lambda (answer thunk)
(if skip?
answer
(begin
(set! skip? #t)
(begin0 (thunk)
(set! skip? #f))))))])
(send (group:get-the-frame-group) set-empty-callbacks
;; empty test
(lambda ()
(if (preferences:get 'framework:exit-when-no-frames)
(at-most-one #t
(lambda ()
(exit:can-exit?)))
#t))
;; empty close down
(lambda ()
(if (preferences:get 'framework:exit-when-no-frames)
(at-most-one (void)
(lambda ()
(exit:on-exit)
(queue-callback (lambda () (exit)))))
(void))))
(exit:insert-can?-callback
(lambda ()
(at-most-one
#t
(lambda ()
(send (group:get-the-frame-group) can-close-all?)))))
(exit:insert-on-callback
(lambda ()
(at-most-one
#t
(lambda ()
(send (group:get-the-frame-group) on-close-all))))))
(exit:insert-can?-callback
(lambda ()
(send (group:get-the-frame-group) can-close-all?)))
(exit:insert-on-callback
(lambda ()
(send (group:get-the-frame-group) on-close-all)))
(exit:insert-can?-callback
(lambda ()

4
collects/framework/private/sig.ss
View File

@ -202,7 +202,9 @@
(define-signature framework:exit-class^
())
(define-signature framework:exit-fun^
(frame-exiting
(set-exiting
exiting?
user-oks-exit
insert-on-callback
insert-can?-callback
can-exit?

3
collects/framework/private/standard-menus-items.ss
View File

@ -275,8 +275,7 @@
(make-an-item 'file-menu 'quit
'(string-constant quit-info)
'(lambda (item control)
(parameterize ([exit:frame-exiting this])
(exit:exit)))
(exit:exit))
#\q
'(if (eq? (system-type) 'windows)
(string-constant quit-menu-item-windows)