fixed a part of PR 8471
svn: r5265
This commit is contained in:
Robby Findler
parent
5646c26ba9
commit
cd2f2ee56b
|
|
@ -1605,73 +1605,82 @@ 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
|
|
||||||
(λ (set-canvases! canvases canvas% text)
|
|
||||||
(let-values ([(ox oy ow oh cursor-y)
|
|
||||||
(get-visible-region canvas-to-be-split)])
|
|
||||||
(let ([orig-percentages (send resizable-panel get-percentages)]
|
|
||||||
[orig-canvases (send resizable-panel get-children)]
|
|
||||||
[new-canvas (new canvas%
|
|
||||||
(parent resizable-panel)
|
|
||||||
(editor text)
|
|
||||||
(style '()))])
|
|
||||||
|
|
||||||
(set-canvases!
|
|
||||||
(let loop ([canvases canvases])
|
|
||||||
(cond
|
|
||||||
[(null? canvases) (error 'split "couldn't split; didn't find canvas")]
|
|
||||||
[else
|
|
||||||
(let ([canvas (car canvases)])
|
|
||||||
(if (eq? canvas canvas-to-be-split)
|
|
||||||
(list* new-canvas
|
|
||||||
canvas
|
|
||||||
(cdr canvases))
|
|
||||||
(cons canvas (loop (cdr canvases)))))])))
|
|
||||||
|
|
||||||
(update-shown)
|
|
||||||
|
|
||||||
;; with-handlers prevents bad calls to set-percentages
|
|
||||||
;; might still leave GUI in bad state, however.
|
|
||||||
(with-handlers ([exn:fail? (λ (x) (void))])
|
|
||||||
(send resizable-panel set-percentages
|
|
||||||
(let loop ([canvases orig-canvases]
|
|
||||||
[percentages orig-percentages])
|
|
||||||
(cond
|
|
||||||
[(null? canvases)
|
|
||||||
(error 'split "couldn't split; didn't find canvas")]
|
|
||||||
[(null? percentages)
|
|
||||||
(error 'split "wrong number of percentages: ~s ~s"
|
|
||||||
orig-percentages
|
|
||||||
(send resizable-panel get-children))]
|
|
||||||
[else (let ([canvas (car canvases)])
|
|
||||||
(if (eq? canvas-to-be-split canvas)
|
|
||||||
(list* (/ (car percentages) 2)
|
|
||||||
(/ (car percentages) 2)
|
|
||||||
(cdr percentages))
|
|
||||||
(cons
|
|
||||||
(car percentages)
|
|
||||||
(loop (cdr canvases)
|
|
||||||
(cdr percentages)))))]))))
|
|
||||||
|
|
||||||
(set-visible-region new-canvas ox oy ow oh cursor-y)
|
|
||||||
(set-visible-region canvas-to-be-split ox oy ow oh cursor-y)
|
|
||||||
|
|
||||||
(send new-canvas focus))))])
|
|
||||||
(cond
|
(cond
|
||||||
[(memq canvas-to-be-split definitions-canvases)
|
[(memq canvas-to-be-split definitions-canvases)
|
||||||
(update (λ (x) (set! definitions-canvases x))
|
(split-definitions canvas-to-be-split)]
|
||||||
definitions-canvases
|
|
||||||
(drscheme:get/extend:get-definitions-canvas)
|
|
||||||
definitions-text)]
|
|
||||||
[(memq canvas-to-be-split interactions-canvases)
|
[(memq canvas-to-be-split interactions-canvases)
|
||||||
(update (λ (x) (set! interactions-canvases x))
|
(split-interactions canvas-to-be-split)]
|
||||||
interactions-canvases
|
|
||||||
(drscheme:get/extend:get-interactions-canvas)
|
|
||||||
interactions-text)]
|
|
||||||
[else (bell)])))
|
[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)
|
||||||
|
(get-visible-region canvas-to-be-split)])
|
||||||
|
(let ([orig-percentages (send resizable-panel get-percentages)]
|
||||||
|
[orig-canvases (send resizable-panel get-children)]
|
||||||
|
[new-canvas (new canvas%
|
||||||
|
(parent resizable-panel)
|
||||||
|
(editor text)
|
||||||
|
(style '()))])
|
||||||
|
|
||||||
|
(set-canvases!
|
||||||
|
(let loop ([canvases canvases])
|
||||||
|
(cond
|
||||||
|
[(null? canvases) (error 'split "couldn't split; didn't find canvas")]
|
||||||
|
[else
|
||||||
|
(let ([canvas (car canvases)])
|
||||||
|
(if (eq? canvas canvas-to-be-split)
|
||||||
|
(list* new-canvas
|
||||||
|
canvas
|
||||||
|
(cdr canvases))
|
||||||
|
(cons canvas (loop (cdr canvases)))))])))
|
||||||
|
|
||||||
|
(update-shown)
|
||||||
|
|
||||||
|
;; with-handlers prevents bad calls to set-percentages
|
||||||
|
;; might still leave GUI in bad state, however.
|
||||||
|
(with-handlers ([exn:fail? (λ (x) (void))])
|
||||||
|
(send resizable-panel set-percentages
|
||||||
|
(let loop ([canvases orig-canvases]
|
||||||
|
[percentages orig-percentages])
|
||||||
|
(cond
|
||||||
|
[(null? canvases)
|
||||||
|
(error 'split "couldn't split; didn't find canvas")]
|
||||||
|
[(null? percentages)
|
||||||
|
(error 'split "wrong number of percentages: ~s ~s"
|
||||||
|
orig-percentages
|
||||||
|
(send resizable-panel get-children))]
|
||||||
|
[else (let ([canvas (car canvases)])
|
||||||
|
(if (eq? canvas-to-be-split canvas)
|
||||||
|
(list* (/ (car percentages) 2)
|
||||||
|
(/ (car percentages) 2)
|
||||||
|
(cdr percentages))
|
||||||
|
(cons
|
||||||
|
(car percentages)
|
||||||
|
(loop (cdr canvases)
|
||||||
|
(cdr percentages)))))]))))
|
||||||
|
|
||||||
|
(set-visible-region new-canvas ox oy ow oh cursor-y)
|
||||||
|
(set-visible-region canvas-to-be-split ox oy ow oh cursor-y)
|
||||||
|
|
||||||
|
(send new-canvas focus))))
|
||||||
|
|
||||||
;; 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
|
||||||
(define/private (split-demand item)
|
(define/private (split-demand item)
|
||||||
|
|
@ -1752,82 +1761,89 @@ 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
|
|
||||||
(λ (get-canvases set-canvases!)
|
|
||||||
(if (= 1 (length (get-canvases)))
|
|
||||||
(bell)
|
|
||||||
(let* ([old-percentages (send resizable-panel get-percentages)]
|
|
||||||
[soon-to-be-bigger-canvas #f]
|
|
||||||
[percentages
|
|
||||||
(if (eq? (car (get-canvases)) target)
|
|
||||||
(begin
|
|
||||||
(set! soon-to-be-bigger-canvas (cadr (get-canvases)))
|
|
||||||
(cons (+ (car old-percentages)
|
|
||||||
(cadr old-percentages))
|
|
||||||
(cddr old-percentages)))
|
|
||||||
(let loop ([canvases (cdr (get-canvases))]
|
|
||||||
[prev-canvas (car (get-canvases))]
|
|
||||||
[percentages (cdr old-percentages)]
|
|
||||||
[prev-percentage (car old-percentages)])
|
|
||||||
(cond
|
|
||||||
[(null? canvases)
|
|
||||||
(error 'collapse "internal error.1")]
|
|
||||||
[(null? percentages)
|
|
||||||
(error 'collapse "internal error.2")]
|
|
||||||
[else
|
|
||||||
(if (eq? (car canvases) target)
|
|
||||||
(begin
|
|
||||||
(set! soon-to-be-bigger-canvas prev-canvas)
|
|
||||||
(cons (+ (car percentages)
|
|
||||||
prev-percentage)
|
|
||||||
(cdr percentages)))
|
|
||||||
(cons prev-percentage
|
|
||||||
(loop (cdr canvases)
|
|
||||||
(car canvases)
|
|
||||||
(cdr percentages)
|
|
||||||
(car percentages))))])))])
|
|
||||||
(unless soon-to-be-bigger-canvas
|
|
||||||
(error 'collapse "internal error.3"))
|
|
||||||
(set-canvases! (remq target (get-canvases)))
|
|
||||||
(update-shown)
|
|
||||||
|
|
||||||
(let ([target-admin
|
|
||||||
(send target call-as-primary-owner
|
|
||||||
(λ ()
|
|
||||||
(send (send target get-editor) get-admin)))]
|
|
||||||
[to-be-bigger-admin
|
|
||||||
(send soon-to-be-bigger-canvas call-as-primary-owner
|
|
||||||
(λ ()
|
|
||||||
(send (send soon-to-be-bigger-canvas get-editor) get-admin)))])
|
|
||||||
(let-values ([(bx by bw bh) (get-visible-area target-admin)])
|
|
||||||
|
|
||||||
;; this line makes the soon-to-be-bigger-canvas bigger
|
|
||||||
;; if it fails, we're out of luck, but at least we don't crash.
|
|
||||||
(with-handlers ([exn:fail? (λ (x) (void))])
|
|
||||||
(send resizable-panel set-percentages percentages))
|
|
||||||
|
|
||||||
(let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)])
|
|
||||||
(send soon-to-be-bigger-canvas scroll-to
|
|
||||||
bx
|
|
||||||
(- by (/ (- ah bh) 2))
|
|
||||||
aw
|
|
||||||
ah
|
|
||||||
#t))))
|
|
||||||
|
|
||||||
(send soon-to-be-bigger-canvas focus))))])
|
|
||||||
(cond
|
(cond
|
||||||
[(memq target definitions-canvases)
|
[(memq target definitions-canvases)
|
||||||
(handle-collapse
|
(collapse-definitions target)]
|
||||||
(λ () definitions-canvases)
|
|
||||||
(λ (c) (set! definitions-canvases c)))]
|
|
||||||
[(memq target interactions-canvases)
|
[(memq target interactions-canvases)
|
||||||
(handle-collapse
|
(collapse-interactions target)]
|
||||||
(λ () interactions-canvases)
|
|
||||||
(λ (c) (set! interactions-canvases c)))]
|
|
||||||
[else (bell)])))
|
[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)))
|
||||||
|
(bell)
|
||||||
|
(let* ([old-percentages (send resizable-panel get-percentages)]
|
||||||
|
[soon-to-be-bigger-canvas #f]
|
||||||
|
[percentages
|
||||||
|
(if (eq? (car (get-canvases)) target)
|
||||||
|
(begin
|
||||||
|
(set! soon-to-be-bigger-canvas (cadr (get-canvases)))
|
||||||
|
(cons (+ (car old-percentages)
|
||||||
|
(cadr old-percentages))
|
||||||
|
(cddr old-percentages)))
|
||||||
|
(let loop ([canvases (cdr (get-canvases))]
|
||||||
|
[prev-canvas (car (get-canvases))]
|
||||||
|
[percentages (cdr old-percentages)]
|
||||||
|
[prev-percentage (car old-percentages)])
|
||||||
|
(cond
|
||||||
|
[(null? canvases)
|
||||||
|
(error 'collapse "internal error.1")]
|
||||||
|
[(null? percentages)
|
||||||
|
(error 'collapse "internal error.2")]
|
||||||
|
[else
|
||||||
|
(if (eq? (car canvases) target)
|
||||||
|
(begin
|
||||||
|
(set! soon-to-be-bigger-canvas prev-canvas)
|
||||||
|
(cons (+ (car percentages)
|
||||||
|
prev-percentage)
|
||||||
|
(cdr percentages)))
|
||||||
|
(cons prev-percentage
|
||||||
|
(loop (cdr canvases)
|
||||||
|
(car canvases)
|
||||||
|
(cdr percentages)
|
||||||
|
(car percentages))))])))])
|
||||||
|
(unless soon-to-be-bigger-canvas
|
||||||
|
(error 'collapse "internal error.3"))
|
||||||
|
(set-canvases! (remq target (get-canvases)))
|
||||||
|
(update-shown)
|
||||||
|
|
||||||
|
(let ([target-admin
|
||||||
|
(send target call-as-primary-owner
|
||||||
|
(λ ()
|
||||||
|
(send (send target get-editor) get-admin)))]
|
||||||
|
[to-be-bigger-admin
|
||||||
|
(send soon-to-be-bigger-canvas call-as-primary-owner
|
||||||
|
(λ ()
|
||||||
|
(send (send soon-to-be-bigger-canvas get-editor) get-admin)))])
|
||||||
|
(let-values ([(bx by bw bh) (get-visible-area target-admin)])
|
||||||
|
|
||||||
|
;; this line makes the soon-to-be-bigger-canvas bigger
|
||||||
|
;; if it fails, we're out of luck, but at least we don't crash.
|
||||||
|
(with-handlers ([exn:fail? (λ (x) (void))])
|
||||||
|
(send resizable-panel set-percentages percentages))
|
||||||
|
|
||||||
|
(let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)])
|
||||||
|
(send soon-to-be-bigger-canvas scroll-to
|
||||||
|
bx
|
||||||
|
(- by (/ (- ah bh) 2))
|
||||||
|
aw
|
||||||
|
ah
|
||||||
|
#t))))
|
||||||
|
|
||||||
|
(send target set-editor #f)
|
||||||
|
(send soon-to-be-bigger-canvas focus))))
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
@ -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)]))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user