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

..

Browse Source 
original commit: 4ac45d40b2e0bf45abf6accf614760e488d3bb8f
This commit is contained in:
Robby Findler 2003-02-28 22:20:26 +00:00
parent b57ac1081e
commit 4a27a79afc
1 changed files with 34 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/framework/private/frame.ss
View File

@ -1274,7 +1274,7 @@
(super-instantiate ()))) (super-instantiate ())))
(define delegate<%> (define delegate<%>
(interface (text<%>) (interface (status-line<%> text<%>)
get-delegated-text get-delegated-text
delegated-text-shown? delegated-text-shown?
hide-delegated-text hide-delegated-text
@ -1289,16 +1289,36 @@
(define/override (on-event evt) (define/override (on-event evt)
(super-on-event evt) (super-on-event evt)
(when (and delegate-frame (when delegate-frame
(send evt button-down?))
(let ([text (get-editor)]) (let ([text (get-editor)])
(when (is-a? text text%) (when (is-a? text text%)
(let-values ([(editor-x editor-y) (cond
(send text dc-location-to-editor-location [(send evt button-down?)
(send evt get-x) (let-values ([(editor-x editor-y)
(send evt get-y))]) (send text dc-location-to-editor-location
(send delegate-frame click-in-overview (send evt get-x)
(send text find-position editor-x editor-y))))))) (send evt get-y))])
(send delegate-frame click-in-overview
(send text find-position editor-x editor-y)))]
[(or (send evt entering?)
(send evt moving?))
(let-values ([(editor-x editor-y)
(send text dc-location-to-editor-location
(send evt get-x)
(send evt get-y))])
(let* ([b (box #f)]
[pos (send text find-position editor-x editor-y #f b)])
(cond
[(unbox b)
(let* ([para (send text position-paragraph pos)]
[start-pos (send text paragraph-start-position para)]
[end-pos (send text paragraph-end-position para)])
(send delegate-frame update-status-line 'plt:delegate
(send text get-text start-pos end-pos)))]
[else
(send delegate-frame update-status-line 'plt:delegate #f)])))]
[(send evt leaving?)
(send delegate-frame update-status-line 'plt:delegate #f)])))))
(super-instantiate ()))) (super-instantiate ())))
(define delegatee-text% (define delegatee-text%
@ -1412,7 +1432,7 @@
(set-line-spacing 0))) (set-line-spacing 0)))
(define delegate-mixin (define delegate-mixin
(mixin (text<%>) (delegate<%>) (mixin (status-line<%> text<%>) (delegate<%>)
(define/public (get-delegated-text) (get-editor)) (define/public (get-delegated-text) (get-editor))
@ -1442,12 +1462,15 @@
(define/public (delegated-text-shown?) (define/public (delegated-text-shown?)
shown?) shown?)
(inherit close-status-line open-status-line)
(define/public (hide-delegated-text) (define/public (hide-delegated-text)
(close-status-line 'plt:delegate)
(set! shown? #f) (set! shown? #f)
(send (get-delegated-text) set-delegate #f) (send (get-delegated-text) set-delegate #f)
(send super-root change-children (send super-root change-children
(lambda (l) (list rest-panel)))) (lambda (l) (list rest-panel))))
(define/public (show-delegated-text) (define/public (show-delegated-text)
(open-status-line 'plt:delegate)
(set! shown? #t) (set! shown? #t)
(send (get-delegated-text) set-delegate delegatee) (send (get-delegated-text) set-delegate delegatee)
(send super-root change-children (send super-root change-children
@ -1492,6 +1515,7 @@
(inherit get-editor) (inherit get-editor)
(if (preferences:get 'framework:show-delegate?) (if (preferences:get 'framework:show-delegate?)
(begin (begin
(open-status-line 'plt:delegate)
(send (get-delegated-text) set-delegate delegatee) (send (get-delegated-text) set-delegate delegatee)
(send super-root change-children (send super-root change-children
(lambda (l) (list rest-panel delegate-ec)))) (lambda (l) (list rest-panel delegate-ec))))