diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index 5febb020..46658697 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -37,6 +37,21 @@ [super-set-max-width set-max-width] [super-lock lock]) + (public + [get-edit-snip + (lambda () (make-object wx:media-snip% + (make-object edit%)))] + [get-pasteboard-snip + (lambda () (make-object wx:media-snip% + (make-object pasteboard%)))] + [on-new-box + (lambda (type) + (wx:message-box (format "insert-box ~a" type)) + (cond + [(= type wx:const-edit-buffer) + (get-edit-snip)] + [else (get-pasteboard-snip)]))]) + (private [auto-saved-name #f] [auto-save-out-of-date? #t] @@ -44,7 +59,7 @@ (public [set-max-width (lambda (x) - (mred:debug:printf 'rewrap "set-max-width: ~a~n" x) + (mred:debug:printf 'rewrap "set-max-width: ~a" x) (super-set-max-width x))] [get-file (lambda (d) (let ([v (mred:finder:get-file d)]) @@ -59,7 +74,7 @@ [auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)] [set-auto-set-wrap (lambda (v) - (mred:debug:printf 'rewrap "set-auto-set-wrap: ~a~n" v) + (mred:debug:printf 'rewrap "set-auto-set-wrap: ~a" v) (set! auto-set-wrap? v) (rewrap))] @@ -67,12 +82,12 @@ (let ([do-wrap (lambda (new-width) (let ([current-width (get-max-width)]) - (mred:debug:printf 'rewrap "do-wrap: new-width ~a current-width ~a~n" new-width current-width) + (mred:debug:printf 'rewrap "do-wrap: new-width ~a current-width ~a" new-width current-width) (unless (or (= current-width new-width) (and (<= current-width 0) (<= new-width 0))) (set-max-width new-width) - (mred:debug:printf 'rewrap "attempted to wrap to: ~a actually wrapped to ~a~n" + (mred:debug:printf 'rewrap "attempted to wrap to: ~a actually wrapped to ~a" new-width (get-max-width)))))]) (lambda () (if auto-set-wrap? @@ -91,7 +106,7 @@ (max (unbox w-box) sofar))) 0 canvases))) - (do-wrap -1))))] + (do-wrap 0))))] [mode #f] [set-mode (lambda (m) diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss index d72e4a4a..370323cf 100644 --- a/collects/mred/finder.ss +++ b/collects/mred/finder.ss @@ -323,7 +323,8 @@ (when (eq? wx:platform 'unix) (make-object mred:container:check-box% period-panel do-period-in/exclusion - "Show files and directories that begin with a period")) + "Show files and directories that begin with a period") + (send period-panel stretchable-in-y #f)) (send* directory-panel (stretchable-in-y #f) @@ -345,7 +346,6 @@ (send add-panel stretchable-in-y #f) (send remove-panel stretchable-in-y #f) (send result-list stretchable-in-x #t)) - (send period-panel stretchable-in-y #f) (send name-list stretchable-in-x #t) (send top-panel stretchable-in-y #f) (send bottom-panel stretchable-in-y #f) diff --git a/collects/mred/panel.ss b/collects/mred/panel.ss index 46c2b72a..a7a08911 100644 --- a/collects/mred/panel.ss +++ b/collects/mred/panel.ss @@ -11,48 +11,35 @@ (lambda (super%) (class-asi super% (rename [super-change-children change-children]) - (inherit children get-parent) + (inherit get-parent change-children children) (public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)]) - (private - [edit-mapping (make-hash-table)] - [bind - (lambda (panel edit) - (hash-table-put! edit-mapping edit panel))] - [lookup/add - (lambda (child) - (if (is-a? child wx:media-edit%) - (let ([add-new - (lambda () - (let ([p (make-object (get-canvas%) this)]) - (send p set-media child) - (send child add-canvas p) - (bind p child) - p))]) - (hash-table-get edit-mapping child add-new)) - child))]) (public - - ; this contains the edits and panels that are children of - ; this panel, but the canvases of these edits are not - ; necessarily immediate children, since they may be split. - [actual-children null] - [collapse (lambda (canvas) (letrec* ([media (send canvas get-media)] [helper (lambda (canvas/panel) - (let* ([parent (send canvas/panel get-parent)]) - (if (is-a? parent wx:frame%) - (begin (send canvas/panel change-children - (lambda (l) (list media))) - (wx:bell)) - (let* ([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)) set-focus)))))))]) + (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))))]) + (wx: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)) set-focus))))))]) (send media remove-canvas canvas) (helper canvas)))] @@ -83,16 +70,7 @@ (add-canvas left-split) (add-canvas right-split)) (send* left-split (set-media media) (set-focus)) - (send* right-split (set-media media)) - (when (eq? this parent) - (bind media new-panel))))] - [change-children - (lambda (f) - (let ([new-children (f actual-children)]) - (super-change-children (lambda (l) - (map lookup/add - new-children))) - (set! actual-children new-children)))])))) + (send* right-split (set-media media))))])))) (define horizontal-edit-panel% (make-edit-panel% mred:container:horizontal-panel%))