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 (λ args
(apply fprintf op 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 ;; Compiled bitmaps
@ -4580,26 +4572,25 @@
(inherit get-info-panel) (inherit get-info-panel)
(define color-status-canvas (define color-status-canvas
(and checkout-or-nightly? (let ()
(let () (define on-string "()")
(define on-string "()") (define color-status-canvas
(define color-status-canvas (new canvas%
(new canvas% [parent (get-info-panel)]
[parent (get-info-panel)] [style '(transparent)]
[style '(transparent)] [stretchable-width #f]
[stretchable-width #f] [paint-callback
[paint-callback (λ (c dc)
(λ (c dc) (when (number? th)
(when (number? th) (unless color-valid?
(unless color-valid? (let-values ([(cw ch) (send c get-client-size)])
(let-values ([(cw ch) (send c get-client-size)]) (send dc set-font small-control-font)
(send dc set-font small-control-font) (send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))]))
(send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))])) (define-values (tw th ta td)
(define-values (tw th ta td) (send (send color-status-canvas get-dc) get-text-extent
(send (send color-status-canvas get-dc) get-text-extent on-string small-control-font))
on-string small-control-font)) (send color-status-canvas min-width (inexact->exact (ceiling tw)))
(send color-status-canvas min-width (inexact->exact (ceiling tw))) color-status-canvas))
color-status-canvas)))
(define color-valid? #t) (define color-valid? #t)
(define/public (set-color-status! v?) (define/public (set-color-status! v?)
(when color-status-canvas (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 (get-info-panel) info-panel)
(define/public (update-memory-text) (define/public (update-memory-text)
(when show-memory-text? (for ([memory-canvas (in-list memory-canvases)])
(for-each (send memory-canvas set-str (format-number (current-memory-use)))))
(λ (memory-canvas)
(send memory-canvas set-str (format-number (current-memory-use))))
memory-canvases)))
(define/private (format-number n) (define/private (format-number n)
(let* ([mbytes (/ n 1024 1024)] (let* ([mbytes (/ n 1024 1024)]
@ -900,30 +897,29 @@
[define lock-canvas (make-object lock-canvas% (get-info-panel))] [define lock-canvas (make-object lock-canvas% (get-info-panel))]
; only for checkouts and nightly build users ; set up the memory use display in the status line
(when show-memory-text? (let* ([panel (new horizontal-panel%
(let* ([panel (new horizontal-panel% [parent (get-info-panel)]
[parent (get-info-panel)] [stretchable-width #f]
[stretchable-width #f] [stretchable-height #f])]
[stretchable-height #f])] [ec (new position-canvas%
[ec (new position-canvas% [parent panel]
[parent panel] [button-up
[button-up (λ (evt)
(λ (evt) (cond
(cond [(or (send evt get-alt-down)
[(or (send evt get-alt-down) (send evt get-control-down))
(send evt get-control-down)) (dynamic-require 'tests/drracket/follow-log #f)]
(dynamic-require 'tests/drracket/follow-log #f)] [else
[else (collect-garbage)
(collect-garbage) (update-memory-text)]))]
(update-memory-text)]))] [init-width "99.99 MB"])])
[init-width "99.99 MB"])]) (set! memory-canvases (cons ec memory-canvases))
(set! memory-canvases (cons ec memory-canvases)) (update-memory-text)
(update-memory-text) (set! memory-cleanup
(set! memory-cleanup (λ ()
(λ () (set! memory-canvases (remq ec memory-canvases))))
(set! memory-canvases (remq ec memory-canvases)))) (send panel stretchable-width #f))
(send panel stretchable-width #f)))
(define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)])) (define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)]))
(define/private (register-gc-blit) (define/private (register-gc-blit)
@ -2731,16 +2727,7 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%))) (define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new))) (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 memory-canvases '())
(define show-memory-text? checkout-or-nightly?)
(define bday-click-canvas% (define bday-click-canvas%
(class canvas% (class canvas%