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

11
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,7 +4572,6 @@
(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
@ -4599,7 +4590,7 @@
(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

21
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,8 +897,7 @@
[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]
@ -923,7 +919,7 @@
(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%