diff --git a/collects/framework/canvas.ss b/collects/framework/canvas.ss index ba9154f0..bc0c5133 100644 --- a/collects/framework/canvas.ss +++ b/collects/framework/canvas.ss @@ -2,6 +2,9 @@ (import mred^ [preferences : framework:preferences^]) + ;; wx: this need to collude with + ;; the edit, since the edit has the right callbacks. + (define make-wide-snip% (lambda (super%) (class-asi super% @@ -10,7 +13,6 @@ (private [wide-snips null] [tall-snips null] - [autowrap-snips (preferences:get 'framework:auto-set-wrap?)] [update-snip-size (lambda (width?) (lambda (s) @@ -65,7 +67,7 @@ (set-max-width snip-width)) (when snip-media (send snip-media set-max-width - (if autowrap-snips? + (if (send snip-media auto-wrap) snip-width 0)))) (let ([snip-height (- (unbox height) @@ -76,10 +78,6 @@ (set-min-height snip-height) (set-max-height snip-height)))))))))))]) (public - [set-autowrap-snips - (lambda (x) - (set! autowrap-snips? x) - (for-each (update-snip-size #t) wide-snips))] [add-wide-snip (lambda (snip) (set! wide-snips (cons snip wide-snips)) @@ -94,4 +92,4 @@ (for-each (update-snip-size #t) wide-snips) (for-each (update-snip-size #f) tall-snips))])))) - (define wide-snip% (make-wide-snip-canvas% editor-canvas%))) \ No newline at end of file + (define wide-snip% (make-wide-snip% editor-canvas%))) \ No newline at end of file diff --git a/collects/framework/finder.ss b/collects/framework/finder.ss index 759fd5e0..31704f10 100644 --- a/collects/framework/finder.ss +++ b/collects/framework/finder.ss @@ -10,8 +10,8 @@ [mzlib:function : mzlib:function^] [mzlib:file : mzlib:file^]) - (rename [put-file -put-file] - [get-file -get-file]) + (rename [-put-file put-file] + [-get-file get-file]) (define dialog-parent-parameter (make-parameter #f)) @@ -51,7 +51,7 @@ ; the finder-dialog% class controls the user interface for dialogs (define finder-dialog% - (class dialog-box% (parent-win + (class dialog% (parent-win save-mode? replace-ok? multi-mode? @@ -124,8 +124,7 @@ (char=? (string-ref s 0) #\.)) rest] [(directory-exists? (build-path dir s)) - (cons (string-append s (get-slash)) - rest)] + (cons s rest)] [(or (not file-filter) (mzlib:string:regexp-match-exact? file-filter s)) diff --git a/collects/framework/group.ss b/collects/framework/group.ss index a4240224..19ec6fbe 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -1,6 +1,7 @@ (unit/sig framework:group^ (import mred^ [exit : framework:exit^] + [frame : framework:frame^] [mzlib:function : mzlib:function^] [mzlib:file : mzlib:file^]) diff --git a/collects/framework/panel.ss b/collects/framework/panel.ss index fcb70056..5026e34b 100644 --- a/collects/framework/panel.ss +++ b/collects/framework/panel.ss @@ -1,81 +1,93 @@ - - (unit/sig framework:panel^ - (import mred^ - [mzlib:function : mzlib:function^]) - - (define make-edit% - (lambda (super%) - (class-asi super% - (rename [super-change-children change-children]) - (inherit get-parent change-children children) - (public [get-canvas% (lambda () editor-canvas%)]) - (private - [split-edits null]) - (public - [collapse - (lambda (canvas) - (let ([media (send canvas get-media)]) - (if (memq media split-edits) - (letrec ([helper - (lambda (canvas/panel) - (if (eq? canvas/panel this) - (begin (cond - [(and (= (length children) 1) - (eq? canvas (car children))) - (void)] - [(member canvas children) - (change-children (lambda (l) (list canvas)))] - [else - (change-children - (lambda (l) - (let ([c (make-object (object-class canvas) this)]) - (send c set-media media) - (list c))))]) - (bell)) - (let* ([parent (send canvas/panel get-parent)] - [parents-children (ivar parent children)] - [num-children (length parents-children)]) - (if (<= num-children 1) - (helper parent) - (begin (send parent delete-child canvas/panel) - (send (car (ivar parent children)) focus))))))]) - (send media remove-canvas canvas) - (helper canvas)) - (bell))))] - [split - (opt-lambda (canvas [panel% horizontal-panel%]) - (let* ([frame (ivar canvas frame)] - [media (send canvas get-media)] - [canvas% (object-class canvas)] - [parent (send canvas get-parent)] - [new-panel #f] - [left-split #f] - [right-split #f] - [before #t]) - (set! split-edits (cons media split-edits)) - (dynamic-wind - (lambda () - (set! before (send frame delay-updates)) - (send frame delay-updates #t)) - (lambda () - (set! new-panel (make-object panel% parent)) - (set! left-split (make-object canvas% new-panel)) - (set! right-split (make-object canvas% new-panel)) - (send parent change-children - (lambda (l) - (let ([before (remq new-panel l)]) - (map (lambda (x) (if (eq? x canvas) - new-panel - x)) - before))))) - (lambda () (send frame delay-updates before))) - (send* media (remove-canvas canvas) - (add-canvas left-split) - (add-canvas right-split)) - (send* left-split (set-media media) (focus)) - (send* right-split (set-media media))))])))) - - (define horizontal-edit% - (make-edit% horizontal-panel%)) - (define vertical-edit% - (make-edit% vertical-panel%))) \ No newline at end of file +(unit/sig framework:panel^ + (import mred-interfaces^ + [mzlib:function : mzlib:function^]) + + (define single<%> (interface (panel%))) + (define make-single% + (mixin (panel<%>) (single<%>) args + (sequence + (apply super-init args)))) + (define single% vertical-panel%) + + (define edit<%> + (interface () + get-canvas% + collapse + split)) + + (define make-edit% + (mixin (panel<%>) (edit<%>) args + (rename [super-change-children change-children]) + (inherit get-parent change-children children) + (public [get-canvas% (lambda () editor-canvas%)]) + (private + [split-edits null]) + (public + [collapse + (lambda (canvas) + (let ([media (send canvas get-media)]) + (if (memq media split-edits) + (letrec ([helper + (lambda (canvas/panel) + (if (eq? canvas/panel this) + (begin (cond + [(and (= (length children) 1) + (eq? canvas (car children))) + (void)] + [(member canvas children) + (change-children (lambda (l) (list canvas)))] + [else + (change-children + (lambda (l) + (let ([c (make-object (object-class canvas) this)]) + (send c set-media media) + (list c))))]) + (bell)) + (let* ([parent (send canvas/panel get-parent)] + [parents-children (ivar parent children)] + [num-children (length parents-children)]) + (if (<= num-children 1) + (helper parent) + (begin (send parent delete-child canvas/panel) + (send (car (ivar parent children)) focus))))))]) + (send media remove-canvas canvas) + (helper canvas)) + (bell))))] + [split + (opt-lambda (canvas [panel% horizontal-panel%]) + (let* ([frame (ivar canvas frame)] + [media (send canvas get-media)] + [canvas% (object-class canvas)] + [parent (send canvas get-parent)] + [new-panel #f] + [left-split #f] + [right-split #f] + [before #t]) + (set! split-edits (cons media split-edits)) + (dynamic-wind + (lambda () + (set! before (send frame delay-updates)) + (send frame delay-updates #t)) + (lambda () + (set! new-panel (make-object panel% parent)) + (set! left-split (make-object canvas% new-panel)) + (set! right-split (make-object canvas% new-panel)) + (send parent change-children + (lambda (l) + (let ([before (mzlib:function:remq new-panel l)]) + (map (lambda (x) (if (eq? x canvas) + new-panel + x)) + before))))) + (lambda () (send frame delay-updates before))) + (send* media (remove-canvas canvas) + (add-canvas left-split) + (add-canvas right-split)) + (send* left-split (set-media media) (focus)) + (send* right-split (set-media media))))]) + (sequence (apply super-init args)))) + + (define horizontal-edit% + (make-edit% horizontal-panel%)) + (define vertical-edit% + (make-edit% vertical-panel%))) \ No newline at end of file diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index ddf77734..6c2edfa9 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -2,6 +2,7 @@ (import mred^ [exn : framework:exn^] [exit : framework:exit^] + [panel : framework:panel^] [mzlib:pretty-print : mzlib:pretty-print^] [mzlib:function : mzlib:function^]) @@ -559,7 +560,7 @@ (send menu stretchable-in-x #f) menu))] [popup-menu (make-popup-menu)] - [single-panel (make-object vertical-panel%; This should be single-panel%. wx: + [single-panel (make-object panel:single% panel '(border))] [bottom-panel (make-object horizontal-panel% panel)] [ensure-constructed diff --git a/collects/framework/sig.ss b/collects/framework/sig.ss index 53420612..ce2a27c2 100644 --- a/collects/framework/sig.ss +++ b/collects/framework/sig.ss @@ -38,7 +38,11 @@ version)) (define-signature framework:panel^ - (make-edit% + (make-single% + single<%> + single% + + make-edit% edit<%> horizontal-edit% vertical-edit%)) @@ -171,8 +175,8 @@ media-snip%)) (define-signature framework:canvas^ - (make-wide-snip-canvas% - wide-snip-canvas%)) + (make-wide-snip% + wide-snip%)) (define-signature framework:frame^ (empty<%> @@ -203,7 +207,7 @@ pasteboard-info-file%)) (define-signature framework:group^ - (frame-group% + (% the-frame-group)) (define-signature framework:handler^