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

improved behavior of clicking on the line/column display (a little bit)

Browse Source 
svn: r4297

original commit: cb6c8d00f3369ebc2d64ae9c5d174cddbd2cbfe2
This commit is contained in:
Robby Findler 2006-09-10 21:14:56 +00:00
parent e3a459ae9d
commit df2d0ed10c
1 changed files with 60 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -503,38 +503,30 @@
(set! rest-panel r-root) (set! rest-panel r-root)
r-root)) r-root))
[define info-canvas #f] (define info-canvas #f)
(public get-info-canvas set-info-canvas get-info-editor) (define/public (get-info-canvas) info-canvas)
[define get-info-canvas (define/public (set-info-canvas c) (set! info-canvas c))
(λ () (define/public (get-info-editor)
info-canvas)] (and info-canvas
[define set-info-canvas (send info-canvas get-editor)))
(λ (c)
(set! info-canvas c))]
[define get-info-editor
(λ ()
(and info-canvas
(send info-canvas get-editor)))]
(public determine-width) (define/public (determine-width string canvas edit)
[define determine-width (send edit set-autowrap-bitmap #f)
(λ (string canvas edit) (send canvas call-as-primary-owner
(send edit set-autowrap-bitmap #f) (λ ()
(send canvas call-as-primary-owner (let ([lb (box 0)]
(λ () [rb (box 0)])
(let ([lb (box 0)] (send edit erase)
[rb (box 0)]) (send edit insert string)
(send edit erase) (send edit position-location
(send edit insert string) (send edit last-position)
(send edit position-location rb)
(send edit last-position) (send edit position-location 0 lb)
rb) (send canvas min-width
(send edit position-location 0 lb) (+ magic-space (- (inexact->exact (floor (unbox rb)))
(send canvas min-width (inexact->exact (floor (unbox lb))))))))))
(+ magic-space (- (inexact->exact (floor (unbox rb)))
(inexact->exact (floor (unbox lb))))))))))]
[define outer-info-panel 'top-info-panel-uninitialized] (define outer-info-panel 'top-info-panel-uninitialized)
;; this flag is specific to this frame ;; this flag is specific to this frame
;; the true state of the info panel is ;; the true state of the info panel is
@ -597,32 +589,25 @@
[else [else
(when (send lock-canvas is-shown?) (when (send lock-canvas is-shown?)
(send lock-canvas show #f))]))) (send lock-canvas show #f))])))
(public update-info) (define/public (update-info) (lock-status-changed))
[define update-info
(λ ()
(lock-status-changed))]
(super-new) (super-new)
(set! outer-info-panel (make-object horizontal-panel% super-root)) (set! outer-info-panel (make-object horizontal-panel% super-root))
(send outer-info-panel stretchable-height #f) (send outer-info-panel stretchable-height #f)
[define info-panel (make-object horizontal-panel% outer-info-panel)] (define info-panel (new horizontal-panel% [parent outer-info-panel]))
(make-object grow-box-spacer-pane% outer-info-panel) (new grow-box-spacer-pane% [parent outer-info-panel])
(public get-info-panel)
[define get-info-panel (define/public (get-info-panel) info-panel)
(λ () (define/public (update-memory-text)
info-panel)] (when show-memory-text?
(public update-memory-text) (send memory-text begin-edit-sequence)
[define update-memory-text (send memory-text lock #f)
(λ () (send memory-text erase)
(when show-memory-text? (send memory-text insert (format-number (current-memory-use)))
(send memory-text begin-edit-sequence) (send memory-text lock #t)
(send memory-text lock #f) (send memory-text end-edit-sequence)))
(send memory-text erase)
(send memory-text insert (format-number (current-memory-use)))
(send memory-text lock #t)
(send memory-text end-edit-sequence)))]
(define/private (format-number n) (define/private (format-number n)
(let loop ([n n]) (let loop ([n n])
@ -700,22 +685,22 @@
(define text-info-mixin (define text-info-mixin
(mixin (info<%>) (text-info<%>) (mixin (info<%>) (text-info<%>)
(inherit get-info-editor) (inherit get-info-editor)
[define remove-first (define remove-first
(preferences:add-callback (preferences:add-callback
'framework:col-offsets 'framework:col-offsets
(λ (p v) (λ (p v)
(editor-position-changed-offset/numbers (editor-position-changed-offset/numbers
v v
(preferences:get 'framework:display-line-numbers)) (preferences:get 'framework:display-line-numbers))
#t))] #t)))
[define remove-second (define remove-second
(preferences:add-callback (preferences:add-callback
'framework:display-line-numbers 'framework:display-line-numbers
(λ (p v) (λ (p v)
(editor-position-changed-offset/numbers (editor-position-changed-offset/numbers
(preferences:get 'framework:col-offsets) (preferences:get 'framework:col-offsets)
v) v)
#t))] #t)))
(define/augment (on-close) (define/augment (on-close)
(remove-first) (remove-first)
(remove-second) (remove-second)
@ -869,13 +854,20 @@
b b
(string-constant auto-extend-selection))) (string-constant auto-extend-selection)))
(get-info-panel))] (get-info-panel))]
[define overwrite-message (define overwrite-message
(make-object message% (new message%
(string-constant overwrite) [label (string-constant overwrite)]
(get-info-panel))] [parent (get-info-panel)]))
[define position-canvas (make-object click-pref-editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
[define position-edit (make-object text%)]
(define position-parent (new click-pref-panel%
[border 2]
[parent (get-info-panel)]
[stretchable-width #f]
[stretchable-height #f]))
(define position-canvas (new editor-canvas%
[parent position-parent]
[style '(no-hscroll no-vscroll)]))
(define position-edit (new text%))
(define macro-recording-message (define macro-recording-message
(instantiate message% () (instantiate message% ()
@ -895,7 +887,7 @@
(move-front (move-front
overwrite-message overwrite-message
(move-front (move-front
position-canvas position-parent
l))))))) l)))))))
(send macro-recording-message show #f) (send macro-recording-message show #f)
(send anchor-message show #f) (send anchor-message show #f)
@ -912,10 +904,10 @@
(send position-edit hide-caret #t) (send position-edit hide-caret #t)
(send position-edit lock #t))) (send position-edit lock #t)))
(define click-pref-editor-canvas% (define click-pref-panel%
(class editor-canvas% (class horizontal-panel%
(inherit popup-menu) (inherit popup-menu)
(define/override (on-event evt) (define/override (on-subwindow-event receiver evt)
(cond (cond
[(send evt button-down? 'right) [(send evt button-down? 'right)
(let ([menu (new popup-menu%)] (let ([menu (new popup-menu%)]
@ -932,9 +924,10 @@
[checked (not line-numbers?)]) [checked (not line-numbers?)])
(popup-menu menu (popup-menu menu
(+ 1 (send evt get-x)) (+ 1 (send evt get-x))
(+ 1 (send evt get-y))))] (+ 1 (send evt get-y))))
#t]
[else [else
(super on-event evt)])) (super on-subwindow-event receiver evt)]))
(super-new))) (super-new)))
(define pasteboard-info<%> (interface (info<%>))) (define pasteboard-info<%> (interface (info<%>)))