From 46dfd90701b70e8b6605ce80a31dd136abf8f022 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 9 Sep 2005 20:21:21 +0000 Subject: [PATCH] , svn: r816 --- collects/framework/private/group.ss | 167 ++++++++++++------------- collects/framework/private/main.ss | 3 +- collects/tests/framework/group-test.ss | 5 +- 3 files changed, 88 insertions(+), 87 deletions(-) diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index b734c8e1a7..b803268364 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -47,10 +47,12 @@ x #f)) menus))))) + (define/private (insert-windows-menu frame) (let ([menu (get-windows-menu frame)]) (when menu (set! windows-menus (cons menu windows-menus))))) + (define/private (remove-windows-menu frame) (let ([menu (get-windows-menu frame)]) @@ -149,109 +151,106 @@ 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 - (λ () - (when (and (eq? (system-type) 'windows) - (preferences:get 'framework:windows-mdi) - (not mdi-parent)) - (set! mdi-parent (make-object frame% (application:current-app-name) - #f #f #f #f #f - '(mdi-parent))) - (send mdi-parent show #t)) - mdi-parent)] + (define (get-mdi-parent) + (when (and (eq? (system-type) 'windows) + (preferences:get 'framework:windows-mdi) + (not mdi-parent)) + (set! mdi-parent (make-object frame% (application:current-app-name) + #f #f #f #f #f + '(mdi-parent))) + (send mdi-parent show #t)) + mdi-parent) (define (get-frames) (map frame-frame frames)) - [define frame-label-changed - (λ (frame) - (when (memq frame (map frame-frame frames)) - (update-windows-menus)))] + (define (frame-label-changed frame) + (when (memq frame (map frame-frame frames)) + (update-windows-menus))) - [define frame-shown/hidden - (λ (frame) - (when (memq frame (map frame-frame frames)) - (update-windows-menus)))] + (define (frame-shown/hidden frame) + (when (memq frame (map frame-frame frames)) + (update-windows-menus))) + + (define (for-each-frame f) + (for-each (λ (x) (f (frame-frame x))) frames) + (set! todo-to-new-frames + (let ([old todo-to-new-frames]) + (λ (frame) (old frame) (f frame))))) - [define for-each-frame - (λ (f) - (for-each (λ (x) (f (frame-frame x))) frames) - (set! todo-to-new-frames - (let ([old todo-to-new-frames]) - (λ (frame) (old frame) (f frame)))))] (define (get-active-frame) (cond [active-frame active-frame] [(null? frames) #f] [else (frame-frame (car frames))])) + (define (set-active-frame f) (when (and active-frame (not (eq? active-frame f))) (set! most-recent-window-box (make-weak-box active-frame))) (set! active-frame f)) - [define insert-frame - (λ (new-frame) - (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame)) - frames) - (set! frame-counter (add1 frame-counter)) - (let ([new-frames (cons (make-frame new-frame frame-counter) - frames)]) - (set! frames new-frames) - (update-close-menu-item-state) - (insert-windows-menu new-frame) - (update-windows-menus)) - (todo-to-new-frames new-frame)))] - [define remove-frame - (λ (f) - (when (eq? f active-frame) - (set! active-frame #f)) - (let ([new-frames - (remove - f frames - (λ (f fr) (eq? f (frame-frame fr))))]) + (define (insert-frame new-frame) + (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame)) + frames) + (set! frame-counter (add1 frame-counter)) + (let ([new-frames (cons (make-frame new-frame frame-counter) + frames)]) (set! frames new-frames) (update-close-menu-item-state) - (remove-windows-menu f) - (update-windows-menus)))] - [define clear - (λ () - (set! frames null) - #t)] - [define on-close-all - (λ () - (for-each (λ (f) - (let ([frame (frame-frame f)]) - (send frame on-close) - (send frame show #f))) - frames))] - [define can-close-all? - (λ () - (andmap (λ (f) - (let ([frame (frame-frame f)]) - (send frame can-close?))) - frames))] - [define locate-file - (λ (name) - (let* ([normalized - ;; allow for the possiblity of filenames that are urls - (with-handlers ([(λ (x) #t) - (λ (x) name)]) - (normal-case-path - (normalize-path name)))] - [test-frame - (λ (frame) - (and (is-a? frame frame:basic<%>) - (send frame editing-this-file? normalized)))]) - (let loop ([frames frames]) - (cond - [(null? frames) #f] - [else - (let* ([frame (frame-frame (car frames))]) - (if (test-frame frame) - frame - (loop (cdr frames))))]))))] + (insert-windows-menu new-frame) + (update-windows-menus)) + (todo-to-new-frames new-frame))) - (super-instantiate ()))) + (define (remove-frame f) + (when (eq? f active-frame) + (set! active-frame #f)) + (let ([new-frames + (remove + f frames + (λ (f fr) (eq? f (frame-frame fr))))]) + (set! frames new-frames) + (update-close-menu-item-state) + (remove-windows-menu f) + (update-windows-menus))) + + (define (clear) + (set! frames null) + #t) + + (define (on-close-all) + (for-each (λ (f) + (let ([frame (frame-frame f)]) + (send frame on-close) + (send frame show #f))) + frames)) + + (define (can-close-all?) + (andmap (λ (f) + (let ([frame (frame-frame f)]) + (send frame can-close?))) + frames)) + + (define (locate-file name) + (let* ([normalized + ;; allow for the possiblity of filenames that are urls + (with-handlers ([(λ (x) #t) + (λ (x) name)]) + (normal-case-path + (normalize-path name)))] + [test-frame + (λ (frame) + (and (is-a? frame frame:basic<%>) + (send frame editing-this-file? normalized)))]) + (let loop ([frames frames]) + (cond + [(null? frames) #f] + [else + (let* ([frame (frame-frame (car frames))]) + (if (test-frame frame) + frame + (loop (cdr frames))))])))) + + (super-new))) (define (choose-a-frame parent) (letrec-values ([(sorted-frames) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index ef397ec647..eea3ef4b14 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -264,7 +264,8 @@ ;; groups (preferences:set-default 'framework:exit-when-no-frames #t boolean?) - + (preferences:set 'framework:exit-when-no-frames #t) + (exit:insert-can?-callback (λ () (send (group:get-the-frame-group) can-close-all?))) diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss index 36fb5dbab3..7a5e91107b 100644 --- a/collects/tests/framework/group-test.ss +++ b/collects/tests/framework/group-test.ss @@ -3,7 +3,7 @@ (test 'exit-on - (lambda (x) #t) + (lambda (x) (equal? x '("first"))) (lambda () (send-sexp-to-mred '(begin (send (make-object frame:basic% "first") show #t) @@ -15,7 +15,8 @@ (send-sexp-to-mred `(test:button-push "Cancel")) (wait-for-frame "first") - 'passed)) + (send-sexp-to-mred + `(map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames))))) ;; after the first test, we should have one frame that will always ;; be in the group.