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

always show the memory use and the () status indicators in drracket's status line

Browse Source
This commit is contained in:
Robby Findler 2014-02-22 07:44:55 -06:00
parent a2b03a083a
commit 51adb339d5
2 changed files with 44 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
View File

@ -57,14 +57,6 @@
(λ args
(apply fprintf op args))))
;; code copied from framework/private/frame.rkt
(define checkout-or-nightly?
(or (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(directory-exists? (collection-path "repo-time-stamp")))
(with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(let ([fw (collection-path "framework")])
(directory-exists? (build-path fw 'up 'up ".git"))))))
;; ===================================================================================================
;; Compiled bitmaps
@ -4580,26 +4572,25 @@
(inherit get-info-panel)
(define color-status-canvas
(and checkout-or-nightly?
(let ()
(define on-string "()")
(define color-status-canvas
(new canvas%
[parent (get-info-panel)]
[style '(transparent)]
[stretchable-width #f]
[paint-callback
(λ (c dc)
(when (number? th)
(unless color-valid?
(let-values ([(cw ch) (send c get-client-size)])
(send dc set-font small-control-font)
(send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))]))
(define-values (tw th ta td)
(send (send color-status-canvas get-dc) get-text-extent
on-string small-control-font))
(send color-status-canvas min-width (inexact->exact (ceiling tw)))
color-status-canvas)))
(let ()
(define on-string "()")
(define color-status-canvas
(new canvas%
[parent (get-info-panel)]
[style '(transparent)]
[stretchable-width #f]
[paint-callback
(λ (c dc)
(when (number? th)
(unless color-valid?
(let-values ([(cw ch) (send c get-client-size)])
(send dc set-font small-control-font)
(send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))]))
(define-values (tw th ta td)
(send (send color-status-canvas get-dc) get-text-extent
on-string small-control-font))
(send color-status-canvas min-width (inexact->exact (ceiling tw)))
color-status-canvas))
(define color-valid? #t)
(define/public (set-color-status! v?)
(when color-status-canvas

63
pkgs/gui-pkgs/gui-lib/framework/private/frame.rkt
View File

@ -870,11 +870,8 @@
(define/public (get-info-panel) info-panel)
(define/public (update-memory-text)
(when show-memory-text?
(for-each
(λ (memory-canvas)
(send memory-canvas set-str (format-number (current-memory-use))))
memory-canvases)))
(for ([memory-canvas (in-list memory-canvases)])
(send memory-canvas set-str (format-number (current-memory-use)))))
(define/private (format-number n)
(let* ([mbytes (/ n 1024 1024)]
@ -900,30 +897,29 @@
[define lock-canvas (make-object lock-canvas% (get-info-panel))]
; only for checkouts and nightly build users
(when show-memory-text?
(let* ([panel (new horizontal-panel%
[parent (get-info-panel)]
[stretchable-width #f]
[stretchable-height #f])]
[ec (new position-canvas%
[parent panel]
[button-up
(λ (evt)
(cond
[(or (send evt get-alt-down)
(send evt get-control-down))
(dynamic-require 'tests/drracket/follow-log #f)]
[else
(collect-garbage)
(update-memory-text)]))]
[init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases))
(update-memory-text)
(set! memory-cleanup
(λ ()
(set! memory-canvases (remq ec memory-canvases))))
(send panel stretchable-width #f)))
; set up the memory use display in the status line
(let* ([panel (new horizontal-panel%
[parent (get-info-panel)]
[stretchable-width #f]
[stretchable-height #f])]
[ec (new position-canvas%
[parent panel]
[button-up
(λ (evt)
(cond
[(or (send evt get-alt-down)
(send evt get-control-down))
(dynamic-require 'tests/drracket/follow-log #f)]
[else
(collect-garbage)
(update-memory-text)]))]
[init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases))
(update-memory-text)
(set! memory-cleanup
(λ ()
(set! memory-canvases (remq ec memory-canvases))))
(send panel stretchable-width #f))
(define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)]))
(define/private (register-gc-blit)
@ -2731,16 +2727,7 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new)))
;; code copied to drracket/private/unit.rkt
(define checkout-or-nightly?
(or (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(directory-exists? (collection-path "repo-time-stamp")))
(with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(let ([fw (collection-path "framework")])
(directory-exists? (build-path fw 'up 'up ".git"))))))
(define memory-canvases '())
(define show-memory-text? checkout-or-nightly?)
(define bday-click-canvas%
(class canvas%