frame, dialog, and stock-icon repairs

collects/mred/private/wx/cocoa/message.rkt

@@ -2,6 +2,7 @@
 (require scheme/class
          scheme/foreign
          ffi/objc
+         racket/draw/bitmap
           "../../syntax.rkt"
          "item.rkt"
          "utils.rkt"
@@ -14,7 +15,20 @@
 
 ;; ----------------------------------------
 
-(import-class NSTextField NSImageView)
+(import-class NSTextField NSImageView NSWorkspace)
+
+(define _OSType _uint32)
+
+(define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id))
+
+(define (get-app-icon)
+  (tell (tell NSWorkspace sharedWorkspace)
+        iconForFile:
+        (tell (tell (tell NSWorkspace sharedWorkspace)
+                    activeApplication)
+              objectForKey:
+              #:type _NSString
+              "NSApplicationPath")))
 
 (defclass message% item%
   (init parent label
@@ -25,7 +39,21 @@
   (super-new [parent parent]
              [cocoa (let* ([label (cond
                                    [(string? label) label]
-                                   [(symbol? label) (format "<~a>" label)]
+                                   [(symbol? label)
+                                    (let ([icon
+                                           (if (eq? label 'app)
+                                               (get-app-icon)
+                                               (let ([id (integer-bytes->integer
+                                                          (case label
+                                                            [(caution) #"caut"]
+                                                            [(stop) #"stop"])
+                                                          #f
+                                                          #t)])
+                                                 (tell (tell NSWorkspace sharedWorkspace)
+                                                       iconForFileType:
+                                                       (NSFileTypeForHFSTypeCode id))))])
+                                      (tellv icon setSize: #:type _NSSize (make-NSSize 64 64))
+                                      icon)]
                                    [(send label ok?) label]
                                    [else "<bad>"])]
                            [cocoa
@@ -43,11 +71,15 @@
                         (tellv cocoa setTitleWithMnemonic: #:type _NSString label)
                         (tellv cocoa sizeToFit)]
                        [else
-                        (tellv cocoa setImage: (bitmap->image label))
+                        (tellv cocoa setImage: (if (label . is-a? . bitmap%)
+                                                   (bitmap->image label)
+                                                   label))
                         (tellv cocoa setFrame: #:type _NSRect 
                                (make-NSRect (make-NSPoint 0 0)
+                                            (if (label . is-a? . bitmap%)
                                                 (make-NSSize (send label get-width)
-                                                         (send label get-height))))])
+                                                             (send label get-height))
+                                                (tell #:type _NSSize label size))))])
                       cocoa)]
              [no-show? (memq 'deleted style)])
 

collects/mred/private/wx/cocoa/window.rkt

@@ -318,7 +318,15 @@
     (define/public (center a b) (void))
     (def/public-unimplemented refresh)
 
-    (def/public-unimplemented screen-to-client)
+    (define/public (screen-to-client xb yb)
+      (let ([p (tell #:type _NSPoint (get-cocoa-content) 
+                     convertPointFromBase: #:type _NSPoint
+                     (tell #:type _NSPoint (get-cocoa-window)
+                           convertScreenToBase:
+                           #:type _NSPoint (make-NSPoint (unbox xb) 
+                                                         (send (get-wx-window) flip-screen (unbox yb)))))])
+        (set-box! xb (inexact->exact (floor (NSPoint-x p))))
+        (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
 
     (define/public (client-to-screen xb yb)
       (let* ([p (tell #:type _NSPoint (get-cocoa-window)
@@ -328,8 +336,8 @@
                             convertPointToBase: #:type _NSPoint
                             (make-NSPoint (unbox xb) (flip-client (unbox yb)))))])
         (let ([new-y (send (get-wx-window) flip-screen (NSPoint-y p))])
-          (set-box! xb (NSPoint-x p))
+          (set-box! xb (inexact->exact (floor (NSPoint-x p))))
-          (set-box! yb new-y))))
+          (set-box! yb (inexact->exact (floor new-y))))))
       
     (def/public-unimplemented fit)
 

collects/mred/private/wx/common/freeze.rkt

@@ -15,20 +15,20 @@
 (define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer)
   #:c-id scheme_set_on_atomic_timeout)
 
-(define freezer-box (make-parameter #f))
+(define freezer-box (make-parameter null))
 (define freeze-tag (make-continuation-prompt-tag))
 
 ;; Runs `thunk' atomically, but cooperates with 
 ;; `constrained-reply' to continue a frozen
 ;; computation in non-atomic mode.
 (define (call-as-unfreeze-point thunk)
-  (let ([b (box #f)])
+  (let ([b (box null)])
     (parameterize ([freezer-box b])
       ;; In atomic mode:
       (as-entry (lambda () (thunk)))
       ;; Out of atomic mode:
-      (let ([k (unbox b)])
+      (let ([l (unbox b)])
-        (when k
+        (for ([k (in-list (reverse l))])
           (call-with-continuation-prompt ; to catch aborts
            (lambda ()
              (call-with-continuation-prompt
@@ -41,16 +41,21 @@
                                              (let ([now (current-inexact-milliseconds)])
                                                (lambda ()
                                                  ((current-inexact-milliseconds) . > . (+ now 200))))])
-  (unless (freezer-box)
+  (let ([b (freezer-box)])
+    (unless b
       (log-error "internal error: constrained-reply not within an unfreeze point"))
     (if (eq? (current-thread) (eventspace-handler-thread es))
+        (if (pair? b)
+            ;; already suspended, so push this work completely:
+            (set-box! b (cons thunk (unbox b)))
+            ;; try to do some work:
             (let* ([prev #f]
                    [ready? #f]
                    [handler (lambda ()
                               (when (and ready? (should-give-up?))
                                 (scheme_call_with_composable_no_dws
                                  (lambda (proc)
-                             (set-box! (freezer-box) proc)
+                                   (set-box! (freezer-box) (cons proc (freezer-box)))
                                    (scheme_restore_on_atomic_timeout prev)
                                    (scheme_abort_continuation_no_dws
                                     freeze-tag
@@ -70,7 +75,7 @@
                       (parameterize ([freezer-box #f])
                         (thunk))
                       (scheme_restore_on_atomic_timeout prev)))
-             freeze-tag)))))
+                   freeze-tag))))))
         (begin
           (log-error "internal error: wrong eventspace for constrained event handling\n")
-        default)))
+          default))))

collects/mred/private/wx/gtk/canvas.rkt

@@ -173,7 +173,9 @@
     ;; Avoid multiple queued paints:
     (define paint-queued? #f)
     ;; To handle paint requests that happen while on-paint
-    ;;  is being called already:
+    ;;  is being called already. kProbably doesn't happen,
+    ;;  because expose callabcks should be in the right
+    ;;  eventspace.
     (define now-drawing? #f)
     (define refresh-after-drawing? #f)
 

collects/mred/private/wx/gtk/dialog.rkt

@@ -1,12 +1,23 @@
 #lang scheme/base
 (require scheme/class
+         ffi/unsafe
           "../../syntax.rkt"
           "../common/queue.rkt"
+          "types.rkt"
+          "utils.rkt"
           "frame.rkt")
 
 (provide dialog%)
 
+(define GTK_WIN_POS_CENTER 1)
+(define GTK_WIN_POS_CENTER_ON_PARENT 4)
+
+(define-gtk gtk_window_set_position (_fun _GtkWidget _int -> _void))
+
 (defclass dialog% frame%
+  (inherit get-gtk
+           get-parent)
+
   (super-new [is-dialog? #t])
 
   (define close-sema #f)
@@ -18,6 +29,14 @@
         (set! close-sema #f)))
     (super direct-show on?))
 
+  (define/override (center dir wrt)
+    (if #f ; (eq? dir 'both)
+        (gtk_window_set_position (get-gtk) 
+                                 (if (get-parent)
+                                     GTK_WIN_POS_CENTER_ON_PARENT
+                                     GTK_WIN_POS_CENTER))
+        (super center dir wrt)))
+
   (define/override (show on?)
     (if on?
         (unless close-sema

collects/mred/private/wx/gtk/frame.rkt

@@ -8,6 +8,7 @@
          "window.rkt"
          "client-window.rkt"
          "widget.rkt"
+         "procs.rkt"
          "../common/queue.rkt")
 (unsafe!)
 
@@ -25,6 +26,7 @@
 (define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void))
 (define-gtk gtk_window_maximize (_fun _GtkWidget -> _void))
 (define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void))
+(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void))
 
 (define (handle-delete gtk)
   (let ([wx (gtk->wx gtk)])
@@ -113,6 +115,31 @@
     (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
       (void))
 
+    (define/override (center dir wrt)
+      (let ([w-box (box 0)]
+            [h-box (box 0)]
+            [sw-box (box 0)]
+            [sh-box (box 0)])
+        (get-size w-box h-box)
+        (display-size sw-box sh-box #t)
+        (let* ([sw (unbox sw-box)]
+               [sh (unbox sh-box)]
+               [fw (unbox w-box)]
+               [fh (unbox h-box)])
+          (set-top-position (if (or (eq? dir 'both)
+                                    (eq? dir 'horizontal))
+                                (/ (- sw fw) 2)
+                                -11111)
+                            (if (or (eq? dir 'both)
+                                    (eq? dir 'vertical))
+                                (/ (- sh fh) 2)
+                                -11111)))))
+
+    (define/override (set-top-position x y)
+      (gtk_widget_set_uposition gtk
+                                (if (= x -11111) -2 x)
+                                (if (= y -11111) -2 y)))
+
     (define/override (get-size wb hb)
       (let-values ([(w h) (gtk_window_get_size gtk)])
         (set-box! wb w)

collects/mred/private/wx/gtk/message.rkt

@@ -19,6 +19,7 @@
 (define-gtk gtk_label_new (_fun _string -> _GtkWidget))
 (define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void))
 (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void))
+(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget))
 
 (define (mnemonic-string s)
   (if (regexp-match? #rx"&" s)
@@ -38,6 +39,8 @@
         (gtk_label_set_text_with_mnemonic l s)))
     l))
 
+(define icon-size 6) ; = GTK_ICON_SIZE_DIALOG
+
 (defclass message% item%
   (init parent label
         x y
@@ -49,7 +52,10 @@
                           (not label))
                       (gtk_label_new_with_mnemonic (or label ""))
                       (if (symbol? label)
-                          (gtk_label_new (format "<~a>" label))
+                          (case label
+                            [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)]
+                            [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)]
+                            [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])
                           (gtk_image_new_from_pixbuf 
                            (bitmap->pixbuf label))))]
              [no-show? (memq 'deleted style)])

collects/mred/private/wx/gtk/window.rkt

@@ -235,7 +235,9 @@
       (unless (= h -1) (set! save-h h))
       (if parent
           (send parent set-child-size gtk save-x save-y save-w save-h)
-          (set-child-size gtk save-x save-y save-w save-h)))
+          (set-child-size gtk save-x save-y save-w save-h))
+      (set-top-position save-x save-y))
+    (define/public (set-top-position x y) (void))
     (define/public (set-child-size child-gtk x y w h)
       (gtk_widget_set_size_request child-gtk w h)
       (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h)))

collects/racket/draw/point.rkt

@@ -1,5 +1,6 @@
 #lang scheme/base
-(require scheme/class)
+(require scheme/class
+         "syntax.rkt")
 
 (provide point% point-x point-y
          list-of-pair-of-real?)
@@ -8,6 +9,10 @@
   (class object%
     (init-field [x 0.0]
                 [y 0.0])
+    (define/public (get-x) x)
+    (define/public (get-y) y)
+    (def/public (set-x [real? v]) (set! x (exact->inexact v)))
+    (def/public (set-y [real? v]) (set! y (exact->inexact v)))
     (super-new)))
 
 (define point-x (class-field-accessor point% x))