From f22b17caf3266178c69bd54f1d4c1b292c0f7481 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Jun 2001 21:02:31 +0000 Subject: [PATCH] ... original commit: 18fb67f98b884f89a9b94142fe9101b32942b368 --- collects/framework/framework.ss | 4 +- collects/framework/gui-utils.ss | 9 +- collects/framework/private/canvas.ss | 2 +- collects/framework/private/group.ss | 254 +++++++++++++-------------- collects/framework/private/sig.ss | 6 +- collects/framework/private/text.ss | 8 +- collects/tests/framework/load.ss | 11 +- 7 files changed, 149 insertions(+), 145 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 90e10efb..100d0989 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -6,10 +6,10 @@ "test.ss" "test-sig.ss" - (prefix prefs-file: "prefs-file.ss") + "prefs-file.ss" "prefs-file-sig.ss" - (prefix gui-utils: "gui-utils.ss") + "gui-utils.ss" "gui-utils-sig.ss" "framework-unit.ss" diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss index 4dbd6c60..aa219e09 100644 --- a/collects/framework/gui-utils.ss +++ b/collects/framework/gui-utils.ss @@ -5,10 +5,13 @@ (lib "mred-sig.ss" "mred") (lib "mred.ss" "mred")) - (provide-signature-elements framework:gui-utils^) + (provide-signature-elements ((unit gui-utils : framework:gui-utils^))) (define-values/invoke-unit/sig - framework:gui-utils^ - framework:gui-utils@ + ((unit gui-utils : framework:gui-utils^)) + (compound-unit/sig + (import [mred : mred^]) + (link [gui-utils : framework:gui-utils^ (framework:gui-utils@ mred)]) + (export (unit gui-utils))) #f mred^)) diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index 49110562..679c97d4 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -25,7 +25,7 @@ (inherit has-focus? get-top-level-window) (rename [super-on-focus on-focus] [super-set-editor set-editor]) - (override on-focus) + (override on-focus set-editor) [define on-focus (lambda (on?) (super-on-focus on?) diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index 8e74b29a..75a95ab7 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -2,7 +2,6 @@ (module group mzscheme (require (lib "unitsig.ss") (lib "class.ss") - (lib "class100.ss") "sig.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") @@ -22,19 +21,18 @@ (define mdi-parent #f) (define % - (class100 object% () - (private-field - [active-frame #f] - [frame-counter 0] - [frames null] - [todo-to-new-frames void] - [empty-close-down (lambda () (void))] - [empty-test (lambda () #t)] + (class object% + + [define active-frame #f] + [define frame-counter 0] + [define frames null] + [define todo-to-new-frames void] + [define empty-close-down (lambda () (void))] + [define empty-test (lambda () #t)] - [windows-menus null]) + [define windows-menus null] - (private - [get-windows-menu + [define get-windows-menu (lambda (frame) (let ([menu-bar (send frame get-menu-bar)]) (and menu-bar @@ -44,12 +42,12 @@ x #f)) menus)))))] - [insert-windows-menu + [define insert-windows-menu (lambda (frame) (let ([menu (get-windows-menu frame)]) (when menu (set! windows-menus (cons menu windows-menus)))))] - [remove-windows-menu + [define remove-windows-menu (lambda (frame) (let* ([menu (get-windows-menu frame)]) (set! windows-menus @@ -58,7 +56,7 @@ windows-menus eq?))))] - [update-windows-menus + [define update-windows-menus (lambda () (let* ([windows (length windows-menus)] [default-name "Untitled"] @@ -91,10 +89,9 @@ (lambda (_1 _2) (send frame show #t))))) sorted-frames)) - windows-menus)))]) + windows-menus)))] - (private - [update-close-menu-item-state + [define update-close-menu-item-state (lambda () (let* ([set-close-menu-item-state! (lambda (frame state) @@ -106,127 +103,128 @@ (set-close-menu-item-state! (car frames) #f) (for-each (lambda (a-frame) (set-close-menu-item-state! a-frame #t)) - frames))))]) - (public - [get-mdi-parent - (lambda () - (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)] + frames))))] + (public get-mdi-parent set-empty-callbacks frame-label-changed for-each-frame + get-active-frame set-active-frame insert-frame can-remove-frame? + remove-frame clear on-close-all can-close-all? locate-file get-frames) + [define get-mdi-parent + (lambda () + (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)] - [set-empty-callbacks - (lambda (test close-down) - (set! empty-test test) - (set! empty-close-down close-down))] - [get-frames (lambda () (map frame-frame frames))] + [define set-empty-callbacks + (lambda (test close-down) + (set! empty-test test) + (set! empty-close-down close-down))] + [define get-frames (lambda () (map frame-frame frames))] - [frame-label-changed - (lambda (frame) - (when (member frame (map frame-frame frames)) - (update-windows-menus)))] + [define frame-label-changed + (lambda (frame) + (when (member frame (map frame-frame frames)) + (update-windows-menus)))] - [for-each-frame - (lambda (f) - (for-each (lambda (x) (f (frame-frame x))) frames) - (set! todo-to-new-frames - (let ([old todo-to-new-frames]) - (lambda (frame) (old frame) (f frame)))))] - [get-active-frame - (lambda () - (cond + [define for-each-frame + (lambda (f) + (for-each (lambda (x) (f (frame-frame x))) frames) + (set! todo-to-new-frames + (let ([old todo-to-new-frames]) + (lambda (frame) (old frame) (f frame)))))] + [define get-active-frame + (lambda () + (cond [active-frame active-frame] [(null? frames) #f] [else (frame-frame (car frames))]))] - [set-active-frame - (lambda (f) - (set! active-frame f))] - [insert-frame - (lambda (f) - (set! frame-counter (add1 frame-counter)) - (let ([new-frames (cons (make-frame f frame-counter) - frames)]) - (set! frames new-frames) - (update-close-menu-item-state) - (insert-windows-menu f) - (update-windows-menus)) - (todo-to-new-frames f))] + [define set-active-frame + (lambda (f) + (set! active-frame f))] + [define insert-frame + (lambda (f) + (set! frame-counter (add1 frame-counter)) + (let ([new-frames (cons (make-frame f frame-counter) + frames)]) + (set! frames new-frames) + (update-close-menu-item-state) + (insert-windows-menu f) + (update-windows-menus)) + (todo-to-new-frames f))] - [can-remove-frame? - (lambda (f) - (let ([new-frames - (remove - f frames - (lambda (f fr) (eq? f (frame-frame fr))))]) - (if (null? new-frames) - (empty-test) - #t)))] - [remove-frame - (lambda (f) - (when (eq? f active-frame) - (set! active-frame #f)) - (let ([new-frames - (remove - f frames - (lambda (f fr) (eq? f (frame-frame fr))))]) - (set! frames new-frames) - (update-close-menu-item-state) - (remove-windows-menu f) - (update-windows-menus) - (when (null? frames) - (empty-close-down))))] - [clear - (lambda () - (and (empty-test) - (begin (set! frames null) - (empty-close-down) - #t)))] - [on-close-all - (lambda () - (for-each (lambda (f) - (let ([frame (frame-frame f)]) - (send frame on-close) - (send frame show #f))) - frames))] - [can-close-all? - (lambda () - (andmap (lambda (f) - (let ([frame (frame-frame f)]) - (send frame can-close?))) - frames))] - [locate-file - (lambda (name) - (let* ([normalized - ;; allow for the possiblity of filenames that are urls - (with-handlers ([(lambda (x) #t) - (lambda (x) name)]) - (normal-case-path - (normalize-path name)))] - [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))))))))]) - (let loop ([frames frames]) - (cond + [define can-remove-frame? + (lambda (f) + (let ([new-frames + (remove + f frames + (lambda (f fr) (eq? f (frame-frame fr))))]) + (if (null? new-frames) + (empty-test) + #t)))] + [define remove-frame + (lambda (f) + (when (eq? f active-frame) + (set! active-frame #f)) + (let ([new-frames + (remove + f frames + (lambda (f fr) (eq? f (frame-frame fr))))]) + (set! frames new-frames) + (update-close-menu-item-state) + (remove-windows-menu f) + (update-windows-menus) + (when (null? frames) + (empty-close-down))))] + [define clear + (lambda () + (and (empty-test) + (begin (set! frames null) + (empty-close-down) + #t)))] + [define on-close-all + (lambda () + (for-each (lambda (f) + (let ([frame (frame-frame f)]) + (send frame on-close) + (send frame show #f))) + frames))] + [define can-close-all? + (lambda () + (andmap (lambda (f) + (let ([frame (frame-frame f)]) + (send frame can-close?))) + frames))] + [define locate-file + (lambda (name) + (let* ([normalized + ;; allow for the possiblity of filenames that are urls + (with-handlers ([(lambda (x) #t) + (lambda (x) name)]) + (normal-case-path + (normalize-path name)))] + [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))))))))]) + (let loop ([frames frames]) + (cond [(null? frames) #f] [else (let* ([frame (frame-frame (car frames))]) (if (test-frame frame) frame - (loop (cdr frames))))]))))]) - (sequence - (super-init)))) + (loop (cdr frames))))]))))] + (super-instantiate ()))) (define (internal-get-the-frame-group) (let ([the-frame-group (make-object %)]) @@ -234,4 +232,4 @@ (internal-get-the-frame-group))) (define (get-the-frame-group) - (internal-get-the-frame-group))))) \ No newline at end of file + (internal-get-the-frame-group))))) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index ca9ecf05..784e136b 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -131,21 +131,21 @@ (define-signature framework:text^ (basic<%> - hide/selection<%> + hide-caret/selection<%> searching<%> return<%> info<%> clever-file-format<%> basic-mixin - hide/selection-mixin + hide-caret/selection-mixin searching-mixin return-mixin info-mixin clever-file-format-mixin basic% - hide/selection% + hide-caret/selection% keymap% return% autowrap% diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 94041e1f..3857eeea 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -338,9 +338,9 @@ (super-instantiate ()) (set-autowrap-bitmap (initial-autowrap-bitmap)))) - (define hide/selection<%> (interface (basic<%>))) - (define hide/selection-mixin - (mixin (basic<%>) (hide/selection<%>) + (define hide-caret/selection<%> (interface (basic<%>))) + (define hide-caret/selection-mixin + (mixin (basic<%>) (hide-caret/selection<%>) (override after-set-position) (inherit get-start-position get-end-position hide-caret) (define (after-set-position) @@ -460,7 +460,7 @@ (super-instantiate ()))) (define basic% (basic-mixin (editor:basic-mixin text%))) - (define hide/selection% (hide/selection-mixin basic%)) + (define hide-caret/selection% (hide-caret/selection-mixin basic%)) (define -keymap% (editor:keymap-mixin basic%)) (define return% (return-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%)) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index a83600d6..0a538777 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -26,17 +26,20 @@ (load-framework-automatically #f) (test/load "prefs-file-unit.ss" 'framework:prefs-file@) - (test/load "prefs-file.ss" 'get-preferences-filename) + (test/load "prefs-file.ss" 'prefs-file:get-preferences-filename) (test/load "gui-utils-unit.ss" 'framework:gui-utils@) - (test/load "gui-utils.ss" 'next-untitled-name) + (test/load "gui-utils.ss" 'gui-utils:next-untitled-name) (test/load "test-unit.ss" 'framework:test@) (test/load "test.ss" 'test:run-interval) (test/load "macro.ss" '(mixin () () ())) - (test/load "framework-unit.ss" 'framework@) - (test/load "framework.ss" 'frame:basic-mixin) + (test/load "framework-unit.ss" '(list framework@ framework-no-prefs@ framework-small-part@)) + (test/load "framework.ss" '(list prefs-file:get-preferences-filename + test:button-push + gui-utils:next-untitled-name + frame:basic-mixin)) (load-framework-automatically old-load-framework-automatically?))