suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

frame, dialog, and stock-icon repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-24 16:44:41 -05:00
parent 50d10998c0
commit 2f2341be6f
9 changed files with 156 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/mred/private/wx/cocoa/message.rkt
View File

@ -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)
(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)])

14
collects/mred/private/wx/cocoa/window.rkt
View File

@ -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)

79
collects/mred/private/wx/common/freeze.rkt
View File

@ -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))))

4
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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)

21
collects/mred/private/wx/gtk/dialog.rkt
View File

@ -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

27
collects/mred/private/wx/gtk/frame.rkt
View File

@ -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)

8
collects/mred/private/wx/gtk/message.rkt
View File

@ -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)])

4
collects/mred/private/wx/gtk/window.rkt
View File

@ -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)))

7
collects/racket/draw/point.rkt
View File

@ -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))