suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed a part of PR 8471

Browse Source 
svn: r5265
This commit is contained in:
Robby Findler 2007-01-08 17:02:00 +00:00
parent 5646c26ba9
commit cd2f2ee56b
1 changed files with 183 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/drscheme/private/unit.ss
View File

@ -1605,10 +1605,31 @@ module browser threading seems wrong.
(inherit get-edit-target-window) (inherit get-edit-target-window)
(define/private (split) (define/private (split)
(let* ([canvas-to-be-split (get-edit-target-window)] (let ([canvas-to-be-split (get-edit-target-window)])
[update (cond
(λ (set-canvases! canvases canvas% text) [(memq canvas-to-be-split definitions-canvases)
(split-definitions canvas-to-be-split)]
[(memq canvas-to-be-split interactions-canvases)
(split-interactions canvas-to-be-split)]
[else (bell)])))
(define/private (split-definitions canvas-to-be-split)
(handle-split canvas-to-be-split
(λ (x) (set! definitions-canvases x))
definitions-canvases
(drscheme:get/extend:get-definitions-canvas)
definitions-text))
(define/private (split-interactions canvas-to-be-split)
(handle-split canvas-to-be-split
(λ (x) (set! interactions-canvases x))
interactions-canvases
(drscheme:get/extend:get-interactions-canvas)
interactions-text))
(define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text)
(let-values ([(ox oy ow oh cursor-y) (let-values ([(ox oy ow oh cursor-y)
(get-visible-region canvas-to-be-split)]) (get-visible-region canvas-to-be-split)])
(let ([orig-percentages (send resizable-panel get-percentages)] (let ([orig-percentages (send resizable-panel get-percentages)]
@ -1658,19 +1679,7 @@ module browser threading seems wrong.
(set-visible-region new-canvas ox oy ow oh cursor-y) (set-visible-region new-canvas ox oy ow oh cursor-y)
(set-visible-region canvas-to-be-split ox oy ow oh cursor-y) (set-visible-region canvas-to-be-split ox oy ow oh cursor-y)
(send new-canvas focus))))]) (send new-canvas focus))))
(cond
[(memq canvas-to-be-split definitions-canvases)
(update (λ (x) (set! definitions-canvases x))
definitions-canvases
(drscheme:get/extend:get-definitions-canvas)
definitions-text)]
[(memq canvas-to-be-split interactions-canvases)
(update (λ (x) (set! interactions-canvases x))
interactions-canvases
(drscheme:get/extend:get-interactions-canvas)
interactions-text)]
[else (bell)])))
;; split-demand : menu-item -> void ;; split-demand : menu-item -> void
;; enables the menu-item if splitting is allowed, disables otherwise ;; enables the menu-item if splitting is allowed, disables otherwise
@ -1752,9 +1761,27 @@ module browser threading seems wrong.
(unbox bh)))) (unbox bh))))
(define/private (collapse) (define/private (collapse)
(let* ([target (get-edit-target-window)] (let* ([target (get-edit-target-window)])
[handle-collapse (cond
(λ (get-canvases set-canvases!) [(memq target definitions-canvases)
(collapse-definitions target)]
[(memq target interactions-canvases)
(collapse-interactions target)]
[else (bell)])))
(define/private (collapse-definitions target)
(handle-collapse
target
(λ () definitions-canvases)
(λ (c) (set! definitions-canvases c))))
(define/private (collapse-interactions target)
(handle-collapse
target
(λ () interactions-canvases)
(λ (c) (set! interactions-canvases c))))
(define/private (handle-collapse target get-canvases set-canvases!)
(if (= 1 (length (get-canvases))) (if (= 1 (length (get-canvases)))
(bell) (bell)
(let* ([old-percentages (send resizable-panel get-percentages)] (let* ([old-percentages (send resizable-panel get-percentages)]
@ -1815,19 +1842,8 @@ module browser threading seems wrong.
ah ah
#t)))) #t))))
(send soon-to-be-bigger-canvas focus))))]) (send target set-editor #f)
(cond (send soon-to-be-bigger-canvas focus))))
[(memq target definitions-canvases)
(handle-collapse
(λ () definitions-canvases)
(λ (c) (set! definitions-canvases c)))]
[(memq target interactions-canvases)
(handle-collapse
(λ () interactions-canvases)
(λ (c) (set! interactions-canvases c)))]
[else (bell)])))
; ;
; ;
; ;
@ -2081,6 +2097,7 @@ module browser threading seems wrong.
;; change-to-tab : tab -> void ;; change-to-tab : tab -> void
;; updates current-tab, definitions-text, and interactactions-text ;; updates current-tab, definitions-text, and interactactions-text
;; to be the nth tab. Also updates the GUI to show the new tab ;; to be the nth tab. Also updates the GUI to show the new tab
(inherit begin-container-sequence end-container-sequence)
(define/private (change-to-tab tab) (define/private (change-to-tab tab)
(let ([old-delegate (send definitions-text get-delegate)] (let ([old-delegate (send definitions-text get-delegate)]
[old-tab current-tab]) [old-tab current-tab])
@ -2089,6 +2106,8 @@ module browser threading seems wrong.
(set! definitions-text (send current-tab get-defs)) (set! definitions-text (send current-tab get-defs))
(set! interactions-text (send current-tab get-ints)) (set! interactions-text (send current-tab get-ints))
(begin-container-sequence)
(for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text)) (for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text))
definitions-canvases) definitions-canvases)
(for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text)) (for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text))
@ -2101,7 +2120,8 @@ module browser threading seems wrong.
(send definitions-text update-frame-filename) (send definitions-text update-frame-filename)
(send definitions-text set-delegate old-delegate) (send definitions-text set-delegate old-delegate)
(on-tab-change old-tab current-tab))) (on-tab-change old-tab current-tab)
(end-container-sequence)))
(define/pubment (on-tab-change from-tab to-tab) (define/pubment (on-tab-change from-tab to-tab)
(let ([old-enabled (send from-tab get-enabled)] (let ([old-enabled (send from-tab get-enabled)]
@ -2182,11 +2202,35 @@ module browser threading seems wrong.
'defs))) 'defs)))
(define/private (restore-visible-tab-regions) (define/private (restore-visible-tab-regions)
(define (set-visible-regions txt regions) (define (set-visible-regions txt regions ints?)
(when regions (when regions
(let* ([canvases (send txt get-canvases)]) (let* ([canvases (send txt get-canvases)]
(when (equal? (length canvases) (length regions)) [canvases-count (length canvases)]
(for-each (λ (c r) (set-visible-region txt c r)) canvases regions))))) [regions-count (length regions)])
(cond
[(> canvases-count regions-count)
(let loop ([i (- canvases-count regions-count)]
[canvases canvases])
(unless (zero? i)
(if ints?
(collapse-interactions (car canvases))
(collapse-definitions (car canvases)))
(loop (- i 1)
(cdr canvases))))]
[(= canvases-count regions-count)
(void)]
[(< canvases-count regions-count)
(let loop ([i (- regions-count canvases-count)]
[canvases canvases])
(unless (zero? i)
(if ints?
(split-interactions (car canvases))
(split-definitions (car canvases)))
(loop (- i 1)
(cdr canvases))))]))
(for-each (λ (c r) (set-visible-region txt c r))
(send txt get-canvases)
regions)))
(define (set-visible-region txt canvas region) (define (set-visible-region txt canvas region)
(let ([admin (send txt get-admin)]) (let ([admin (send txt get-admin)])
(send admin scroll-to (send admin scroll-to
@ -2199,8 +2243,8 @@ module browser threading seems wrong.
(set! interactions-shown? is?) (set! interactions-shown? is?)
(set! definitions-shown? ds?) (set! definitions-shown? ds?)
(update-shown) (update-shown)
(set-visible-regions definitions-text vd) (set-visible-regions definitions-text vd #f)
(set-visible-regions interactions-text vi)) (set-visible-regions interactions-text vi #t))
(case (send current-tab get-focus-d/i) (case (send current-tab get-focus-d/i)
[(defs) (send (car definitions-canvases) focus)] [(defs) (send (car definitions-canvases) focus)]
[(ints) (send (car interactions-canvases) focus)])) [(ints) (send (car interactions-canvases) focus)]))