From 51adb339d5b7d59a29c46e2444e9879811dd7ce7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 22 Feb 2014 07:44:55 -0600 Subject: [PATCH] always show the memory use and the () status indicators in drracket's status line --- .../drracket/drracket/private/unit.rkt | 47 ++++++-------- .../gui-lib/framework/private/frame.rkt | 63 ++++++++----------- 2 files changed, 44 insertions(+), 66 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt index 87c3bd3e24..914079a897 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt @@ -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 diff --git a/pkgs/gui-pkgs/gui-lib/framework/private/frame.rkt b/pkgs/gui-pkgs/gui-lib/framework/private/frame.rkt index a46a58764b..972c2ce757 100644 --- a/pkgs/gui-pkgs/gui-lib/framework/private/frame.rkt +++ b/pkgs/gui-pkgs/gui-lib/framework/private/frame.rkt @@ -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%