diff --git a/collects/framework/exit.ss b/collects/framework/exit.ss index 260485e7..ee08f462 100644 --- a/collects/framework/exit.ss +++ b/collects/framework/exit.ss @@ -3,36 +3,44 @@ [gui-utils : framework:gui-utils^]) (rename (-exit exit)) - (define callbacks '()) + (define can?-callbacks '()) + (define on-callbacks '()) - (define insert-callback + (define insert-can?-callback (lambda (cb) - (set! callbacks (cons cb callbacks)) + (set! can?-callbacks (cons cb can?-callbacks)) (lambda () - (set! callbacks - (let loop ([cb-list callbacks]) + (set! can?-callbacks + (let loop ([cb-list can?-callbacks]) (cond [(null? cb-list) ()] [(eq? cb (car cb-list)) (cdr cb-list)] [else (cons (car cb-list) (loop (cdr cb-list)))])))))) + + (define insert-on-callback + (lambda (cb) + (set! on-callbacks (cons cb on-callbacks)) + (lambda () + (set! on-callbacks + (let loop ([cb-list on-callbacks]) + (cond + [(null? cb-list) ()] + [(eq? cb (car cb-list)) (cdr cb-list)] + [else (cons (car cb-list) (loop (cdr cb-list)))])))))) (define exiting? #f) - (define run-callbacks - (lambda () - (let loop ([cb-list callbacks]) - (cond - [(null? cb-list) #t] - [(not ((car cb-list))) #f] - [else (loop (cdr cb-list))])))) - + (define (can-exit?) (andmap (lambda (cb) (cb)) can?-callbacks)) + (define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks)) + (define -exit (opt-lambda ([just-ran-callbacks? #f]) (unless exiting? (dynamic-wind (lambda () (set! exiting? #t)) (lambda () - (if (and (let*-values ([(w capw) + (if (and (can-exit?) + (let*-values ([(w capw) (if (eq? (system-type) 'windows) (values "exit" "Exit") (values "quit" "Quit"))] @@ -40,13 +48,14 @@ (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") - #t - #f) - #t)) - (or just-ran-callbacks? - (run-callbacks))) - (exit) + #f + #t) + #t))) + (begin + (on-exit) + (printf "~a~n" '(exit))) #f)) (lambda () (set! exiting? #f))))))) \ No newline at end of file diff --git a/collects/framework/finder.ss b/collects/framework/finder.ss index ac43da89..82a800ee 100644 --- a/collects/framework/finder.ss +++ b/collects/framework/finder.ss @@ -247,7 +247,7 @@ " already exists. " "Replace it?") #f - 'yes-no) + '(yes-no)) 'yes)) (let ([normal-path (with-handlers diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index c39ff65f..04eaaea8 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -56,8 +56,9 @@ (register)) (define-signature framework:exit^ - (insert-callback - run-callbacks + (insert-on-callback + insert-can?-callback + can-exit? exit)) (define-signature framework:gui-utils^ diff --git a/collects/framework/group.ss b/collects/framework/group.ss index d150bc89..d434133d 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -184,8 +184,9 @@ (let/ec escape (for-each (lambda (f) (let ([frame (frame-frame f)]) - (if (send frame on-close) - (send frame show #f) + (if (send frame can-close?) + (begin (send frame on-close) + (send frame show #f)) (escape #f)))) frames) #t))] diff --git a/collects/framework/main.ss b/collects/framework/main.ss index d00aae65..4fddecee 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -159,62 +159,67 @@ (preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v))) main-panel)))) - (preferences:read) - ;; groups - (define at-most-one-maker - (lambda () - (let ([s (make-semaphore 1)] - [test #f]) - (lambda (return thunk) - (semaphore-wait s) - (if test - (begin (semaphore-post s) - return) - (begin - (set! test #t) - (semaphore-post s) - (begin0 (thunk) - (semaphore-wait s) - (set! test #f) - (semaphore-post s)))))))) - (preferences:set-default 'framework:exit-when-no-frames #t boolean?) - (let ([at-most-one (at-most-one-maker)]) + (let ([at-most-one + (let ([skip? #f]) + (lambda (answer thunk) + (printf "at most one: skip? ~a~n" skip?) + (if skip? + answer + (begin + (set! skip? #t) + (begin0 (thunk) + (set! skip? #f))))))]) + (send (group:get-the-frame-group) set-empty-callbacks + + ;; 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"))) + + ;; empty close down (lambda () + (printf "empty close down~n") (if (preferences:get 'framework:exit-when-no-frames) (at-most-one (void) - (lambda () (exit:exit #t))) - (void))) - (lambda () - (if (preferences:get 'framework:exit-when-no-frames) - (at-most-one #t (lambda () - (exit:run-callbacks))) - #t))) + (printf "empty close down.1~n") + (exit:exit))) + (void)))) - (exit:insert-callback + (exit:insert-can?-callback (lambda () + (printf "exit callback~n") (at-most-one #t (lambda () (send (group:get-the-frame-group) close-all)))))) - ;; misc other stuff - - (exit:insert-callback + (exit:insert-on-callback (lambda () - (with-handlers ([(lambda (x) #t) + (with-handlers ([(lambda (x) (void)) (lambda (exn) (message-box "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? + (preferences:read) + (preferences:set 'framework:exit-when-no-frames #t) + (void)) diff --git a/collects/framework/panel.ss b/collects/framework/panel.ss index 4a557ee7..35992bcd 100644 --- a/collects/framework/panel.ss +++ b/collects/framework/panel.ss @@ -17,7 +17,9 @@ (set! current-active-child c)))] [container-size (lambda (l) - (values (apply max (map car l)) (apply max (map cadr l))))] + (if (null? l) + (values 0 0) + (values (apply max (map car l)) (apply max (map cadr l)))))] [place-children (lambda (l width height) (let-values ([(h-align-spec v-align-spec) (get-alignment)])