fixed PR 8925
svn: r7470
This commit is contained in:
Robby Findler
parent
375b356eb7
commit
21851f9833
|
|
@ -259,6 +259,63 @@
|
|||
(define unlocked-message-line1 (string-constant read/write-line1))
|
||||
(define unlocked-message-line2 (string-constant read/write-line2))
|
||||
|
||||
(define lock-canvas%
|
||||
(class canvas%
|
||||
(field [locked? #f])
|
||||
(inherit refresh)
|
||||
(define/public (set-locked l)
|
||||
(unless (eq? locked? l)
|
||||
(set! locked? l)
|
||||
(setup-sizes)
|
||||
(refresh)))
|
||||
(inherit get-client-size get-dc)
|
||||
(define/override (on-paint)
|
||||
(let* ([dc (get-dc)]
|
||||
[draw
|
||||
(λ (str1 str2 bg-color bg-style line-color line-style)
|
||||
(send dc set-font small-control-font)
|
||||
(let-values ([(w h) (get-client-size)]
|
||||
[(tw1 th1 _1 _2) (send dc get-text-extent str1)]
|
||||
[(tw2 th2 _3 _4) (send dc get-text-extent str2)])
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
|
||||
(send dc draw-rectangle 0 0 w h)
|
||||
(cond
|
||||
[(string=? str2 "")
|
||||
(send dc draw-text str1
|
||||
(- (/ w 2) (/ tw1 2))
|
||||
(- (* h 1/2) (/ th1 2)))]
|
||||
[else
|
||||
(send dc draw-text str1
|
||||
(- (/ w 2) (/ tw1 2))
|
||||
(- (* h 1/2) th1))
|
||||
(send dc draw-text str2
|
||||
(- (/ w 2) (/ tw2 2))
|
||||
(* h 1/2))])))])
|
||||
(when locked?
|
||||
(draw locked-message-line1 locked-message-line2
|
||||
"yellow" 'solid "black" 'solid))))
|
||||
|
||||
(inherit get-parent min-width min-height stretchable-width stretchable-height)
|
||||
(define/private (setup-sizes)
|
||||
(let ([dc (get-dc)])
|
||||
(if locked?
|
||||
(let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)]
|
||||
[(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)])
|
||||
(min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2))))))
|
||||
(min-height (inexact->exact (floor (+ 2 hl1 hl2)))))
|
||||
(begin
|
||||
(min-width 0)
|
||||
(min-height 0)))))
|
||||
|
||||
(super-new [style '(transparent)])
|
||||
|
||||
(send (get-dc) set-font small-control-font)
|
||||
(setup-sizes)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #t)))
|
||||
|
||||
#;
|
||||
(define lock-canvas%
|
||||
(class canvas%
|
||||
(field [locked? #f])
|
||||
|
|
@ -480,7 +537,7 @@
|
|||
;; need high priority callbacks to ensure ordering wrt other callbacks
|
||||
(queue-callback t #t))))
|
||||
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
(define info<%> (interface (basic<%>)
|
||||
determine-width
|
||||
|
|
@ -608,15 +665,11 @@
|
|||
|
||||
(define/public (get-info-panel) info-panel)
|
||||
(define/public (update-memory-text)
|
||||
(when (and show-memory-text?
|
||||
memory-canvas)
|
||||
(send memory-text begin-edit-sequence)
|
||||
(send memory-text lock #f)
|
||||
(send memory-text erase)
|
||||
(send memory-text insert (format-number (current-memory-use)))
|
||||
(ensure-enough-width memory-canvas memory-text)
|
||||
(send memory-text lock #t)
|
||||
(send memory-text end-edit-sequence)))
|
||||
(when show-memory-text?
|
||||
(for-each
|
||||
(λ (memory-canvas)
|
||||
(send memory-canvas set-str (format-number (current-memory-use))))
|
||||
memory-canvases)))
|
||||
|
||||
(define/private (format-number n)
|
||||
(let* ([mbytes (/ n 1024 1024)]
|
||||
|
|
@ -627,7 +680,8 @@
|
|||
"."
|
||||
(cond
|
||||
[(<= after-decimal 9) (format "0~a" after-decimal)]
|
||||
[else (number->string after-decimal)]))))
|
||||
[else (number->string after-decimal)])
|
||||
" MB")))
|
||||
|
||||
(define/private (pad-to-3 n)
|
||||
(cond
|
||||
|
|
@ -639,27 +693,21 @@
|
|||
(when show-memory-text?
|
||||
(let* ([panel (new horizontal-panel%
|
||||
[parent (get-info-panel)]
|
||||
[style '(border)]
|
||||
;[style '(border)]
|
||||
[stretchable-width #f]
|
||||
[stretchable-height #f])]
|
||||
[button (new button%
|
||||
[label (string-constant collect-button-label)]
|
||||
[parent panel]
|
||||
[callback
|
||||
(λ x
|
||||
(collect-garbage)
|
||||
(update-memory-text))])]
|
||||
[ec (new editor-canvas%
|
||||
[ec (new position-canvas%
|
||||
[parent panel]
|
||||
[editor memory-text]
|
||||
[line-count 1]
|
||||
[style '(no-hscroll no-vscroll)])])
|
||||
(set! memory-canvas ec)
|
||||
(determine-width "99.99" ec memory-text)
|
||||
[button-up
|
||||
(λ ()
|
||||
(collect-garbage)
|
||||
(update-memory-text))]
|
||||
[init-width "99.99 MB"])])
|
||||
(set! memory-canvases (cons ec memory-canvases))
|
||||
(update-memory-text)
|
||||
(set! memory-cleanup
|
||||
(λ ()
|
||||
(send ec set-editor #f)))
|
||||
(remq ec memory-canvases)))
|
||||
(send panel stretchable-width #f)))
|
||||
|
||||
[define lock-canvas (make-object lock-canvas% (get-info-panel))]
|
||||
|
|
@ -722,6 +770,40 @@
|
|||
(let-values ([(cw ch) (send position-canvas get-client-size)])
|
||||
(inexact->exact (floor (- cw (unbox wb)))))))
|
||||
|
||||
(define position-canvas%
|
||||
(class canvas%
|
||||
(inherit min-client-height min-client-width get-dc get-client-size refresh)
|
||||
(init init-width)
|
||||
(init-field [button-up #f])
|
||||
(define str "")
|
||||
(define/public (set-str _str)
|
||||
(set! str _str)
|
||||
(update-client-width str)
|
||||
(refresh))
|
||||
(define/private (update-client-width str)
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(cw _4) (get-client-size)]
|
||||
[(tw _1 _2 _3) (send dc get-text-extent str)])
|
||||
(when (< cw tw)
|
||||
(min-client-width (inexact->exact (floor tw)))))))
|
||||
(define/override (on-paint)
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(cw ch) (get-client-size)]
|
||||
[(tw th _1 _2) (send dc get-text-extent str)])
|
||||
(send dc draw-text str 0 (/ (- ch th) 2)))))
|
||||
(define/override (on-event evt)
|
||||
(when button-up
|
||||
(when (send evt button-up?)
|
||||
(let-values ([(cw ch) (get-client-size)])
|
||||
(when (and (<= (send evt get-x) cw)
|
||||
(<= (send evt get-y) ch))
|
||||
(button-up))))))
|
||||
(super-new (style '(transparent)))
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(_1 th _2 _3) (send dc get-text-extent str)])
|
||||
(min-client-height (inexact->exact (floor th)))))
|
||||
(update-client-width init-width)))
|
||||
|
||||
(define text-info<%> (interface (info<%>)
|
||||
set-macro-recording
|
||||
overwrite-status-changed
|
||||
|
|
@ -757,15 +839,15 @@
|
|||
(let* ([edit (get-info-editor)]
|
||||
[make-one
|
||||
(λ (pos)
|
||||
(let* ([line (send edit position-paragraph pos)]
|
||||
[col (find-col edit line pos)])
|
||||
(if line-numbers?
|
||||
(if line-numbers?
|
||||
(let* ([line (send edit position-paragraph pos)]
|
||||
[col (find-col edit line pos)])
|
||||
(format "~a:~a"
|
||||
(add1 line)
|
||||
(if offset?
|
||||
(add1 col)
|
||||
col))
|
||||
(format "~a" pos))))])
|
||||
col)))
|
||||
(format "~a" pos)))])
|
||||
(cond
|
||||
[(not (object? position-canvas))
|
||||
(void)]
|
||||
|
|
@ -781,7 +863,7 @@
|
|||
(set! last-params (list offset? line-numbers?))
|
||||
(set! last-start start)
|
||||
(set! last-end end)
|
||||
(when (object? position-edit)
|
||||
(when (object? position-canvas)
|
||||
(change-position-edit-contents
|
||||
(if (= start end)
|
||||
(make-one start)
|
||||
|
|
@ -893,20 +975,9 @@
|
|||
[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 position-canvas (new position-canvas% [parent position-parent] [init-width "000:00-000:00"]))
|
||||
(define/private (change-position-edit-contents str)
|
||||
(send position-edit begin-edit-sequence)
|
||||
(send position-edit lock #f)
|
||||
(send position-edit erase)
|
||||
(send position-edit insert str)
|
||||
(ensure-enough-width position-canvas position-edit)
|
||||
(send position-edit lock #t)
|
||||
(send position-edit end-edit-sequence))
|
||||
(send position-canvas set-str str))
|
||||
|
||||
(send (get-info-panel) change-children
|
||||
(λ (l)
|
||||
|
|
@ -952,17 +1023,7 @@
|
|||
(send macro-recording-message show #f)
|
||||
(send anchor-message show #f)
|
||||
(send overwrite-message show #f)
|
||||
(send* position-canvas
|
||||
(set-line-count 1)
|
||||
(set-editor position-edit)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))
|
||||
(determine-width "000:00-000:00"
|
||||
position-canvas
|
||||
position-edit)
|
||||
(editor-position-changed)
|
||||
(send position-edit hide-caret #t)
|
||||
(send position-edit lock #t)))
|
||||
(editor-position-changed)))
|
||||
|
||||
(define click-pref-panel%
|
||||
(class horizontal-panel%
|
||||
|
|
@ -993,7 +1054,7 @@
|
|||
(define pasteboard-info<%> (interface (info<%>)))
|
||||
(define pasteboard-info-mixin
|
||||
(mixin (basic<%>) (pasteboard-info<%>)
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
(include "standard-menus.ss")
|
||||
|
||||
|
|
@ -1654,7 +1715,7 @@
|
|||
|
||||
(define/public (get-delegatee) delegatee)
|
||||
|
||||
(super-instantiate ())
|
||||
(super-new)
|
||||
|
||||
(define delegatee (instantiate delegatee-text% ()))
|
||||
(define delegate-ec (instantiate delegatee-editor-canvas% ()
|
||||
|
|
@ -2049,7 +2110,7 @@
|
|||
(define replace-text%
|
||||
(class text:keymap%
|
||||
(inherit set-styles-fixed)
|
||||
(super-instantiate ())
|
||||
(super-new)
|
||||
(set-styles-fixed #t)))
|
||||
|
||||
(define find-edit #f)
|
||||
|
|
@ -2408,7 +2469,7 @@
|
|||
(send replace-canvas set-editor replace-edit))
|
||||
(end-container-sequence)))
|
||||
|
||||
(super-instantiate ())
|
||||
(super-new)
|
||||
|
||||
(hide-search #t)))
|
||||
|
||||
|
|
@ -2421,12 +2482,9 @@
|
|||
(get-editor))
|
||||
(define/override (get-editor<%>) text:searching<%>)
|
||||
(define/override (get-editor%) text:searching%)
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
(define memory-text% (class text% (super-new)))
|
||||
(define memory-text (make-object memory-text%))
|
||||
(define memory-canvas #f)
|
||||
(send memory-text hide-caret #t)
|
||||
(define memory-canvases '())
|
||||
(define show-memory-text?
|
||||
(or (with-handlers ([exn:fail:filesystem?
|
||||
(λ (x) #f)])
|
||||
|
|
@ -2446,7 +2504,7 @@
|
|||
(message-box (string-constant drscheme)
|
||||
(string-constant happy-birthday-matthew))]
|
||||
[else (super on-event evt)]))
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
(define basic% (register-group-mixin (basic-mixin frame%)))
|
||||
(define size-pref% (size-pref-mixin basic%))
|
||||
|
|
|
|||
|
|
@ -394,7 +394,7 @@
|
|||
(send style-list find-named-style "Matching Parenthesis Style")))
|
||||
|
||||
(define text-mixin
|
||||
(mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
|
||||
(mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>) (-text<%>)
|
||||
(inherit begin-edit-sequence
|
||||
delete
|
||||
end-edit-sequence
|
||||
|
|
@ -433,12 +433,34 @@
|
|||
(inherit has-focus? find-snip split-snip
|
||||
position-location get-dc)
|
||||
|
||||
(define/override (get-word-at current-pos)
|
||||
(let ([no-word ""])
|
||||
(cond
|
||||
[(or (is-stopped?) (is-frozen?))
|
||||
no-word]
|
||||
[else
|
||||
(let ([type (classify-position current-pos)])
|
||||
(cond
|
||||
[(eq? 'symbol type)
|
||||
(get-text (look-for-non-symbol current-pos)
|
||||
current-pos)]
|
||||
[else no-word]))])))
|
||||
|
||||
(define/private (look-for-non-symbol start)
|
||||
(let loop ([i start])
|
||||
(cond
|
||||
[(< i 0) 0]
|
||||
[(eq? (classify-position i) 'symbol)
|
||||
(loop (- i 1))]
|
||||
[else (+ i 1)])))
|
||||
|
||||
(public tabify-on-return? tabify
|
||||
tabify-all insert-return calc-last-para
|
||||
box-comment-out-selection comment-out-selection uncomment-selection
|
||||
flash-forward-sexp
|
||||
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
|
||||
remove-parens-forward)
|
||||
|
||||
(define/public (get-limit pos) 0)
|
||||
|
||||
(define/public (balance-parens key-event)
|
||||
|
|
@ -1165,8 +1187,9 @@
|
|||
|
||||
(define -text% (set-mode-mixin
|
||||
(text-mixin
|
||||
(mode:host-text-mixin
|
||||
color:text%))))
|
||||
(text:autocomplete-mixin
|
||||
(mode:host-text-mixin
|
||||
color:text%)))))
|
||||
|
||||
(define text-mode% (text-mode-mixin color:text-mode%))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user