From 2f2341be6ff05b603e1ee742f352ec45851528a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 24 Jul 2010 16:44:41 -0500 Subject: [PATCH] frame, dialog, and stock-icon repairs --- collects/mred/private/wx/cocoa/message.rkt | 42 ++++++++++-- collects/mred/private/wx/cocoa/window.rkt | 14 +++- collects/mred/private/wx/common/freeze.rkt | 79 ++++++++++++---------- collects/mred/private/wx/gtk/canvas.rkt | 4 +- collects/mred/private/wx/gtk/dialog.rkt | 21 +++++- collects/mred/private/wx/gtk/frame.rkt | 27 ++++++++ collects/mred/private/wx/gtk/message.rkt | 8 ++- collects/mred/private/wx/gtk/window.rkt | 4 +- collects/racket/draw/point.rkt | 7 +- 9 files changed, 156 insertions(+), 50 deletions(-) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index bca6680fad..272a5cd08b 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/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 ""])] [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) - (make-NSSize (send label get-width) - (send label get-height))))]) + (if (label . is-a? . bitmap%) + (make-NSSize (send label get-width) + (send label get-height)) + (tell #:type _NSSize label size))))]) cocoa)] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 041805cabd..b6c07274d3 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/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! yb new-y)))) + (set-box! xb (inexact->exact (floor (NSPoint-x p)))) + (set-box! yb (inexact->exact (floor new-y)))))) (def/public-unimplemented fit) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 0183381f27..2dabeb9381 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/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)]) - (when k + (let ([l (unbox b)]) + (for ([k (in-list (reverse l))]) (call-with-continuation-prompt ; to catch aborts (lambda () (call-with-continuation-prompt @@ -41,36 +41,41 @@ (let ([now (current-inexact-milliseconds)]) (lambda () ((current-inexact-milliseconds) . > . (+ now 200))))]) - (unless (freezer-box) - (log-error "internal error: constrained-reply not within an unfreeze point")) - (if (eq? (current-thread) (eventspace-handler-thread es)) - (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) - (scheme_restore_on_atomic_timeout prev) - (scheme_abort_continuation_no_dws - freeze-tag - (lambda () default))) - freeze-tag) - (void)))] - [old (scheme_set_on_atomic_timeout handler)]) - (with-holding - handler - (call-with-continuation-prompt ; to catch aborts - (lambda () - (call-with-continuation-prompt ; for composable continuation - (lambda () - (set! prev old) - (set! ready? #t) - (begin0 - (parameterize ([freezer-box #f]) - (thunk)) - (scheme_restore_on_atomic_timeout prev))) - freeze-tag))))) - (begin - (log-error "internal error: wrong eventspace for constrained event handling\n") - default))) + (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) (cons proc (freezer-box))) + (scheme_restore_on_atomic_timeout prev) + (scheme_abort_continuation_no_dws + freeze-tag + (lambda () default))) + freeze-tag) + (void)))] + [old (scheme_set_on_atomic_timeout handler)]) + (with-holding + handler + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt ; for composable continuation + (lambda () + (set! prev old) + (set! ready? #t) + (begin0 + (parameterize ([freezer-box #f]) + (thunk)) + (scheme_restore_on_atomic_timeout prev))) + freeze-tag)))))) + (begin + (log-error "internal error: wrong eventspace for constrained event handling\n") + default)))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 0b0cbf819d..f3e0327941 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/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) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 6917c41218..9d3e4ee80f 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -1,12 +1,23 @@ #lang scheme/base (require scheme/class + ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" - "frame.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 diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 5c35cc8fef..12b081237f 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/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) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 0ce0b70db7..fdd2397cf3 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/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)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index bd0fbb6f69..e37b8f5045 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/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))) diff --git a/collects/racket/draw/point.rkt b/collects/racket/draw/point.rkt index 3e84b28559..1d5b95f780 100644 --- a/collects/racket/draw/point.rkt +++ b/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))