From 202e18ef85226e08c9a4294ee49ae7f641d0295f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 1 Aug 2010 11:04:35 -0600
Subject: [PATCH] dialog show & button width fixes

---
 collects/mred/private/app.rkt                |  3 ++-
 collects/mred/private/wx/cocoa/button.rkt    | 17 ++++++++++++-
 collects/mred/private/wx/cocoa/check-box.rkt |  2 +-
 collects/mred/private/wx/cocoa/dialog.rkt    | 25 +++++++++++---------
 collects/mred/private/wx/cocoa/queue.rkt     |  2 ++
 collects/mred/private/wx/common/queue.rkt    |  1 +
 collects/racket/draw/lock.rkt                | 10 +++++++-
 7 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/collects/mred/private/app.rkt b/collects/mred/private/app.rkt
index ac3eaaa063..67948560e3 100644
--- a/collects/mred/private/app.rkt
+++ b/collects/mred/private/app.rkt
@@ -42,7 +42,8 @@
 			 (dynamic-wind
 			     void
 			     (lambda ()
-			       (send af on-exit)
+                               (as-exit (lambda ()
+                                          (send af on-exit)))
 			       (unless (null? (wx:get-top-level-windows))
 				 (wx:cancel-quit)))
 			     (lambda () 
diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt
index 54b379a932..f6dd2c7257 100644
--- a/collects/mred/private/wx/cocoa/button.rkt
+++ b/collects/mred/private/wx/cocoa/button.rkt
@@ -14,19 +14,22 @@
 (objc-unsafe!)
 
 (provide button%
+         core-button%
          MyButton)
 
 ;; ----------------------------------------
 
 (import-class NSButton NSView NSImageView)
 
+(define MIN-BUTTON-WIDTH 72)
+
 (define-objc-class MyButton NSButton
   #:mixins (FocusResponder)
   [wx]
   (-a _void (clicked: [_id sender])
       (queue-window-event wx (lambda () (send wx clicked)))))
 
-(defclass button% item%
+(defclass core-button% item%
   (init parent cb label x y w h style font
         [button-type #f])
   (init-field [event-type 'button])
@@ -55,6 +58,14 @@
         (tellv cocoa setTitle: #:type _NSString "<bad>")])
       (init-font cocoa font)
       (tellv cocoa sizeToFit)
+      (when (and (eq? event-type 'button)
+                 (string? label))
+        (let ([frame (tell #:type _NSRect cocoa frame)])
+          (when ((NSSize-width (NSRect-size frame)) . < . MIN-BUTTON-WIDTH)
+            (tellv cocoa setFrame: #:type _NSRect 
+                   (make-NSRect (NSRect-origin frame)
+                                (make-NSSize MIN-BUTTON-WIDTH
+                                             (NSSize-height (NSRect-size frame))))))))
       cocoa))
 
   (define cocoa (if (and button-type
@@ -119,3 +130,7 @@
                         [time-stamp (current-milliseconds)])))
   
   (def/public-unimplemented set-border))
+
+(define button%
+  (class core-button% (super-new)))
+
diff --git a/collects/mred/private/wx/cocoa/check-box.rkt b/collects/mred/private/wx/cocoa/check-box.rkt
index 7a7cacac33..6241bb17a8 100644
--- a/collects/mred/private/wx/cocoa/check-box.rkt
+++ b/collects/mred/private/wx/cocoa/check-box.rkt
@@ -13,7 +13,7 @@
 
 ;; ----------------------------------------
 
-(defclass check-box% button%
+(defclass check-box% core-button%
   (inherit get-cocoa)
   (super-new [button-type NSSwitchButton]
              [event-type 'check-box])
diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt
index ea21aaf5d5..423ff1da6b 100644
--- a/collects/mred/private/wx/cocoa/dialog.rkt
+++ b/collects/mred/private/wx/cocoa/dialog.rkt
@@ -2,6 +2,7 @@
 (require scheme/class
           "../../syntax.rkt"
           "../common/queue.rkt"
+          "../../lock.rkt"
          "frame.rkt")
 
 (provide dialog%)
@@ -13,19 +14,21 @@
 
   (define/override (direct-show on?)
     (unless on?
-      (when close-sema
-        (semaphore-post close-sema)
-        (set! close-sema #f)))
+      (as-entry
+       (lambda ()
+         (when close-sema
+           (semaphore-post close-sema)
+           (set! close-sema #f)))))
     (super direct-show on?))
 
   (define/override (show on?)
     (if on?
-        (unless close-sema
-          (let ([s (make-semaphore)])
-            (set! close-sema s)
-            (super show on?)
-            (yield s)))
+        (let ([s (as-entry
+                  (lambda ()
+                    (let ([s (or close-sema (make-semaphore))])
+                      (unless close-sema (set! close-sema s))
+                      s)))])
+          (super show on?)
+          (yield s)
+          (void))
         (super show on?))))
-
-    
-
diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt
index 9e45b71f7a..0be2bbcf06 100644
--- a/collects/mred/private/wx/cocoa/queue.rkt
+++ b/collects/mred/private/wx/cocoa/queue.rkt
@@ -200,6 +200,8 @@
                                (custodian-shutdown-all c)))))))
       (set! was-menu-bar #f)))
 
+(define o (current-error-port))
+
 ;; Call this function only in atomic mode:
 (define (check-one-event wait? dequeue?)
   (pre-event-sync wait?)
diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt
index 0eb66a2d96..d6b4309b2d 100644
--- a/collects/mred/private/wx/common/queue.rkt
+++ b/collects/mred/private/wx/common/queue.rkt
@@ -333,4 +333,5 @@
             (lambda (k v) k)))
 
 (define (queue-quit-event)
+  ;; called in event-pump thread
   (queue-event main-eventspace (application-quit-handler) 'med))
diff --git a/collects/racket/draw/lock.rkt b/collects/racket/draw/lock.rkt
index c66ff9c0d8..7b583fe990 100644
--- a/collects/racket/draw/lock.rkt
+++ b/collects/racket/draw/lock.rkt
@@ -4,7 +4,10 @@
 
 (provide (protect-out as-entry
                       as-exit
-                      entry-point))
+                      entry-point
+
+                      inside-lock?
+                      any-lock?))
 
 ;; We need atomic mode for a couple of reasons:
 ;;
@@ -123,3 +126,8 @@
        (syntax (case-lambda 
                 [vars (as-entry (lambda () body1 body ...))]
                 ...))])))
+
+;; For debugging: 
+(define (inside-lock?) (eq? monitor-owner (current-thread)))
+(define (any-lock?) (and monitor-owner #t))
+