diff --git a/collects/framework/exit.ss b/collects/framework/exit.ss index ee08f462..b991a6a7 100644 --- a/collects/framework/exit.ss +++ b/collects/framework/exit.ss @@ -30,32 +30,29 @@ (define exiting? #f) - (define (can-exit?) (andmap (lambda (cb) (cb)) can?-callbacks)) + (define (can-exit?) (and (andmap (lambda (cb) (cb)) can?-callbacks) + (user-oks-exit))) (define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks)) + (define (user-oks-exit) + (if (preferences:get 'framework:verify-exit) + (let*-values ([(w capw) + (if (eq? (system-type) 'windows) + (values "exit" "Exit") + (values "quit" "Quit"))] + [(message) + (string-append "Are you sure you want to " + w + "?")] + [(user-says) (gui-utils:get-choice message capw "Cancel")]) + user-says) + #t)) + (define -exit - (opt-lambda ([just-ran-callbacks? #f]) + (opt-lambda () (unless exiting? - (dynamic-wind - (lambda () (set! exiting? #t)) - (lambda () - (if (and (can-exit?) - (let*-values ([(w capw) - (if (eq? (system-type) 'windows) - (values "exit" "Exit") - (values "quit" "Quit"))] - [(message) - (string-append "Are you sure you want to " - w - "?")]) - (printf "showing dialog~n") - (if (preferences:get 'framework:verify-exit) - (if (gui-utils:get-choice message capw "Cancel") - #f - #t) - #t))) - (begin - (on-exit) - (printf "~a~n" '(exit))) - #f)) - (lambda () (set! exiting? #f))))))) \ No newline at end of file + (set! exiting? #t) + (when (can-exit?) + (on-exit) + (exit)) + (set! exiting? #f))))) \ No newline at end of file diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 04eaaea8..a48bff23 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -59,6 +59,7 @@ (insert-on-callback insert-can?-callback can-exit? + on-exit exit)) (define-signature framework:gui-utils^ diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 4fddecee..5a5d48a9 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -166,7 +166,6 @@ (let ([at-most-one (let ([skip? #f]) (lambda (answer thunk) - (printf "at most one: skip? ~a~n" skip?) (if skip? answer (begin @@ -178,29 +177,23 @@ ;; empty test (lambda () - (printf "empty test~n") - (begin0 - (if (preferences:get 'framework:exit-when-no-frames) - (at-most-one #t - (lambda () - (printf "empty test.1~n") - (exit:can-exit?))) - #t) - (printf "empty test done~n"))) - + (if (preferences:get 'framework:exit-when-no-frames) + (at-most-one #t + (lambda () + (exit:can-exit?))) + #t)) + ;; empty close down (lambda () - (printf "empty close down~n") (if (preferences:get 'framework:exit-when-no-frames) (at-most-one (void) (lambda () - (printf "empty close down.1~n") - (exit:exit))) + (exit:on-exit) + (exit))) (void)))) (exit:insert-can?-callback (lambda () - (printf "exit callback~n") (at-most-one #t (lambda () @@ -214,7 +207,6 @@ "Saving Prefs" (format "Error saving preferences: ~a" (exn-message exn))))]) - (printf "saving preferences~n") (preferences:save)))) ;(wx:application-file-handler edit-file) ;; how to handle drag and drop?