improved the icon a little bit more (making it appear on more windows)

svn: r17380

collects/drscheme/private/main.ss

@@ -25,6 +25,42 @@
         [prefix drscheme:help-desk: drscheme:help-desk^])
 (export)
 
+
+
+(when (eq? (system-type) 'unix)
+  (let ()
+    ;; avoid building the mask unless we use it
+    (define todays-icon
+      (make-object bitmap% 
+        (build-path (collection-path "icons")
+                    (case (date-week-day (seconds->date (current-seconds)))
+                      [(6 0) "plt-logo-red-shiny.png"]
+                      [else "plt-logo-red-diffuse.png"]))
+        'png/mask))
+    
+    (define todays-icon-bw-mask 
+      (and (send todays-icon ok?)
+           (send todays-icon get-loaded-mask)
+           (let* ([w (send todays-icon get-width)]
+                  [h (send todays-icon get-height)]
+                  [bm (make-object bitmap% w h #t)]
+                  [color-mask (send todays-icon get-loaded-mask)]
+                  [src-bytes (make-bytes (* w h 4) 0)]
+                  [dest-bits (make-bytes (* w h 4) 255)]
+                  [bdc (make-object bitmap-dc% bm)]
+                  [black (send the-color-database find-color "black")]
+                  [white (send the-color-database find-color "white")])
+             (send color-mask get-argb-pixels 0 0 w h src-bytes #t)
+             (for ([i (in-range 0 w)])
+               (for ([j (in-range 0 h)])
+                 (let ([b (= (bytes-ref src-bytes (* 4 (+ i (* j h)))) 0)])
+                   (send bdc set-pixel i j (if b white black)))))
+             (send bdc set-bitmap #f)
+             bm)))
+    
+    (send todays-icon set-loaded-mask todays-icon-bw-mask)
+    (frame:current-icon todays-icon)))
+  
 (application-file-handler
  (let ([default (application-file-handler)])
    (λ (name)

collects/drscheme/private/unit.ss

@@ -48,35 +48,6 @@ module browser threading seems wrong.
   (define show-planet-paths (string-constant module-browser-show-planet-paths/short))
   (define refresh (string-constant module-browser-refresh))
   
-  (define todays-icon
-    (make-object bitmap% 
-      (build-path (collection-path "icons")
-                  (case (date-week-day (seconds->date (current-seconds)))
-                    [(6 0) "plt-logo-red-shiny.png"]
-                    [else "plt-logo-red-diffuse.png"]))
-      'png/mask))
-  
-  (define todays-icon-bw-mask 
-    (and (send todays-icon ok?)
-         (send todays-icon get-loaded-mask)
-         (eq? (system-type) 'unix) ;; avoid computing this unless we use it
-         (let* ([w (send todays-icon get-width)]
-                [h (send todays-icon get-height)]
-                [bm (make-object bitmap% w h #t)]
-                [color-mask (send todays-icon get-loaded-mask)]
-                [src-bytes (make-bytes (* w h 4) 0)]
-                [dest-bits (make-bytes (* w h 4) 255)]
-                [bdc (make-object bitmap-dc% bm)]
-                [black (send the-color-database find-color "black")]
-                [white (send the-color-database find-color "white")])
-           (send color-mask get-argb-pixels 0 0 w h src-bytes #t)
-           (for ([i (in-range 0 w)])
-             (for ([j (in-range 0 h)])
-               (let ([b (= (bytes-ref src-bytes (* 4 (+ i (* j h)))) 0)])
-                 (send bdc set-pixel i j (if b white black)))))
-           (send bdc set-bitmap #f)
-           bm)))
-  
   (define-unit unit@
     (import [prefix help-desk: drscheme:help-desk^]
             [prefix drscheme:app: drscheme:app^]
@@ -4128,12 +4099,6 @@ module browser threading seems wrong.
         
         (set-label-prefix (string-constant drscheme))
         (set! newest-frame this)
-        
-        (inherit set-icon)
-        (when (send todays-icon ok?)
-          (case (system-type)
-            [(unix) (set-icon todays-icon todays-icon-bw-mask)]))
-        
         (send definitions-canvas focus)))
     
     (define execute-warning-canvas%

collects/framework/main.ss

@@ -645,6 +645,28 @@
   (frame)
   @{Removes empty menus in a frame.})
  
+ (parameter-doc
+  frame:current-icon
+  (parameter/c (or/c #f
+                     (is-a?/c bitmap%)
+                     (cons/c (is-a?/c bitmap%)
+                             (is-a?/c bitmap%))))
+  icon-spec
+  @{The value of this parameter is used by the initialization code of
+    @scheme[frame:basic-mixin].
+    @itemize[@item{If it is @scheme[#f], then its value is
+    ignored.}
+              @item{It it is a @scheme[bitmap%], then the @method[frame% set-icon] is called
+    with the bitmap, the result of invoking the @scheme[bitmap% get-loaded-mask] method,
+    and @scheme['both].}
+              @item{If it is a pair of bitmaps, then the @method[frame% set-icon]
+    method is invoked twice, once with each bitmap in the pair. The first bitmap
+    is passed (along with the result of its @scheme[bitmap% get-loaded-mask])
+    and @scheme['small], and then the second bitmap is passed
+    (also along with the result of its @scheme[bitmap% get-loaded-mask]) and @scheme['large].}]
+    
+    Defaults to @scheme[#f].})
+  
  (proc-doc/names
   group:get-the-frame-group
   (-> (is-a?/c group:%))

collects/framework/private/frame.ss

@@ -201,6 +201,16 @@
     
     (accept-drop-files #t)
     
+    (inherit set-icon)
+    (let ([icon (current-icon)])
+      (when icon
+        (if (pair? icon)
+            (let ([small (car icon)]
+                  [large (cdr icon)])
+              (set-icon small (send small get-loaded-mask) 'small)
+              (set-icon large (send large get-loaded-mask) 'large))
+            (set-icon icon (send icon get-loaded-mask) 'both))))
+    
     (let ([mb (make-object (get-menu-bar%) this)])
       (when (or (eq? (system-type) 'macos)
                 (eq? (system-type) 'macosx))
@@ -213,6 +223,8 @@
     (define/public (get-area-container) panel)
     (set! after-init? #t)))
 
+(define current-icon (make-parameter #f))
+
 (define size-pref<%>
   (interface (basic<%>)))
 

collects/framework/private/sig.ss

@@ -294,7 +294,8 @@
      text-info-mixin
      pasteboard-info-mixin))
   (define-signature frame^ extends frame-class^
-    (reorder-menus
+    (current-icon
+     reorder-menus
      remove-empty-menus
      add-snip-menu-items
      setup-size-pref))

collects/scribblings/framework/frame.scrbl

@@ -107,7 +107,7 @@
   object returned by
   @scheme[group:get-the-frame-group].
 
-  Do not give @scheme[panel%]s or @scheme[control<%>]s this frame as
+  Do not give @scheme[panel%] or @scheme[control<%>] objects this frame as
   parent. Instead, use the result of the
   @method[frame:basic<%> get-area-container]
   method.
@@ -118,6 +118,11 @@
   @method[frame:basic<%> get-menu-bar%]. It only passes the frame as an initialization argument.
   In addition, it creates the windows menu in the menu bar.
 
+  This mixin calls its @method[window<%> accept-drop-files] with @scheme[#t].
+  
+  It also calls its @method[frame% set-icon] method according to the current
+  value of @scheme[frame:current-icon].
+  
   See also
   @scheme[frame:reorder-menus].
   @defmethod*[#:mode override (((show (on? boolean?)) void))]{