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

enforce modality; more on-subwindow- callbacks; Cocoa font tweaks

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-04 19:39:43 -06:00
parent ff57455150
commit e9e180847a
20 changed files with 173 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/ffi/unsafe.rkt
View File

@ -558,7 +558,8 @@
;; parse keywords
(let loop ()
(let ([k (and (pair? xs) (pair? (cdr xs)) (car xs))])
(when (keyword? (syntax-e k))
(when (and (syntax? k)
(keyword? (syntax-e k)))
(kwd-set! k (cadr xs))
(set! xs (cddr xs))
(loop))))

2
collects/mred/private/wx/cocoa/button.rkt
View File

@ -24,7 +24,7 @@
(define MIN-BUTTON-WIDTH 72)
(define-objc-class MyButton NSButton
#:mixins (FocusResponder)
#:mixins (FocusResponder KeyMouseResponder)
[wx]
(-a _void (clicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked)))))

2
collects/mred/private/wx/cocoa/choice.rkt
View File

@ -19,7 +19,7 @@
(import-class NSPopUpButton)
(define-objc-class MyPopUpButton NSPopUpButton
#:mixins (FocusResponder)
#:mixins (FocusResponder KeyMouseResponder)
[wx]
(-a _void (clicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked)))))

61
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -27,16 +27,20 @@
(define empty-mb (new menu-bar%))
(define root-fake-frame #f)
(define dialog-level-counter 0)
(define-objc-mixin (MyWindowMethods Superclass)
[wx]
[-a _scheme (getEventspace)
(send wx get-eventspace)]
[-a _BOOL (canBecomeKeyWindow) #t]
[-a _BOOL (canBecomeKeyWindow)
(not (other-modal? wx))]
[-a _BOOL (canBecomeMainWindow) #t]
[-a _BOOL (windowShouldClose: [_id win])
(queue-window-event wx (lambda ()
(when (send wx on-close)
(send wx direct-show #f))))
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f)))))
#f]
[-a _void (windowDidResize: [_id notification])
(when wx
@ -149,7 +153,21 @@
(tell NSGraphicsContext graphicsContextWithWindow: cocoa)))
(define is-a-dialog? is-dialog?)
(define dialog-level 0)
(define/public (frame-is-dialog?) is-a-dialog?)
(define/public (frame-relative-dialog-status win)
;; called in event-pump thread
(cond
[is-a-dialog? (let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other]))]
[else #f]))
(define/override (get-dialog-level)
;; called in event-pump thread
dialog-level)
(define/public (clean-up)
;; When a window is resized, then any drawing that is in flight
@ -171,25 +189,32 @@
(set! front #f)
(send empty-mb install))
(if on?
(if (and is-a-dialog?
(let ([p (get-parent)])
(and p
(not (send p get-sheet)))))
(let ([p (get-parent)])
(send p set-sheet this)
(tell (tell NSApplication sharedApplication)
beginSheet: cocoa
modalForWindow: (send p get-cocoa)
modalDelegate: #f
didEndSelector: #:type _SEL #f
contextInfo: #f))
(tellv cocoa makeKeyAndOrderFront: #f))
(begin
(when is-a-dialog?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(if (and is-a-dialog?
(let ([p (get-parent)])
(and p
(not (send p get-sheet)))))
(let ([p (get-parent)])
(send p set-sheet this)
(tell (tell NSApplication sharedApplication)
beginSheet: cocoa
modalForWindow: (send p get-cocoa)
modalDelegate: #f
didEndSelector: #:type _SEL #f
contextInfo: #f))
(tellv cocoa makeKeyAndOrderFront: #f)))
(begin
(when is-a-dialog?
(set! dialog-level 0)
(let ([p (get-parent)])
(when (and p
(eq? this (send p get-sheet)))
(send p set-sheet #f))))
(send p set-sheet #f)
(tell (tell NSApplication sharedApplication)
endSheet: cocoa))))
(tellv cocoa orderOut: #f)
(let ([next
(let* ([pool (tell (tell NSAutoreleasePool alloc) init)]
@ -316,7 +341,7 @@
(define/public (set-modified on?)
;; Use standardWindowButton: ...
(void))
(define/public (create-status-line) (void))
(define/public (set-status-text s) (void))
(def/public-unimplemented status-line-exists?)

6
collects/mred/private/wx/cocoa/group-panel.rkt
View File

@ -14,6 +14,10 @@
(import-class NSBox)
(define-objc-class MyBox NSBox
#:mixins (FocusResponder KeyMouseResponder)
[wx])
(defclass group-panel% (panel-mixin window%)
(init parent
x y w h
@ -24,7 +28,7 @@
(super-new [parent parent]
[cocoa
(let ([cocoa (as-objc-allocation
(tell (tell NSBox alloc) init))])
(tell (tell MyBox alloc) init))])
(when label
(tellv cocoa setTitle: #:type _NSString label)
(tellv cocoa sizeToFit))

1
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -22,6 +22,7 @@
(import-protocol NSTableViewDataSource)
(define-objc-class MyTableView NSTableView
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
(tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))]

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

@ -4,10 +4,11 @@
ffi/objc
racket/draw/bitmap
"../../syntax.rkt"
"item.rkt"
"utils.rkt"
"types.rkt"
"image.rkt")
"window.rkt"
"item.rkt"
"utils.rkt"
"types.rkt"
"image.rkt")
(unsafe!)
(objc-unsafe!)
@ -30,6 +31,14 @@
#:type _NSString
"NSApplicationPath")))
(define-objc-class MyTextField NSTextField
#:mixins (FocusResponder KeyMouseResponder)
[wx])
(define-objc-class MyImageView NSImageView
#:mixins (FocusResponder KeyMouseResponder)
[wx])
(defclass message% item%
(init parent label
x y
@ -59,9 +68,9 @@
[cocoa
(if (string? label)
(as-objc-allocation
(tell (tell NSTextField alloc) init))
(tell (tell MyTextField alloc) init))
(as-objc-allocation
(tell (tell NSImageView alloc) init)))])
(tell (tell MyImageView alloc) init)))])
(cond
[(string? label)
(init-font cocoa font)

2
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -24,7 +24,7 @@
(define NSListModeMatrix 2)
(define-objc-class MyMatrix NSMatrix
#:mixins (FocusResponder)
#:mixins (FocusResponder KeyMouseResponder)
[wx]
(-a _void (clicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked)))))

2
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -22,7 +22,7 @@
(import-class NSSlider)
(define-objc-class MySlider NSSlider
#:mixins (FocusResponder)
#:mixins (FocusResponder KeyMouseResponder)
[wx]
(-a _void (changed: [_id sender])
(queue-window-event wx (lambda () (send wx changed)))

1
collects/mred/private/wx/cocoa/tab-panel.rkt
View File

@ -18,6 +18,7 @@
(import-protocol NSTabViewDelegate)
(define-objc-class MyTabView NSTabView
#:mixins (FocusResponder KeyMouseResponder)
#:protocols (NSTabViewDelegate)
[wx]
(-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])

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

@ -8,6 +8,7 @@
"types.rkt"
"keycode.rkt"
"../common/event.rkt"
"../common/queue.rkt"
"../../syntax.rkt"
"../common/freeze.rkt")
(unsafe!)
@ -180,6 +181,10 @@
(define/public (get-cocoa-window) (send parent get-cocoa-window))
(define/public (get-wx-window) (send parent get-wx-window))
(define/public (get-dialog-level)
;; called in event-pump thread
(send parent get-dialog-level))
(define/public (make-graphics-context)
(and parent
(send parent make-graphics-context)))
@ -294,11 +299,13 @@
(define/public (dispatch-on-char e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-char this e) #t]
[just-pre? #f]
[else (when enabled? (on-char e)) #t]))
(define/public (dispatch-on-event e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-event this e) #t]
[just-pre? #f]
[else (when enabled? (on-event e)) #t]))

13
collects/mred/private/wx/common/queue.rkt
View File

@ -2,6 +2,7 @@
(require ffi/unsafe
racket/draw/utils
ffi/unsafe/atomic
racket/class
"rbtree.rkt"
"../../lock.rkt"
"handlers.rkt")
@ -35,6 +36,7 @@
register-frame-shown
get-top-level-windows
other-modal?
queue-quit-event)
@ -329,9 +331,20 @@
'frame-remove)))
(define (get-top-level-windows)
;; called in event-pump thread
(hash-map (eventspace-frames-hash (current-eventspace))
(lambda (k v) k)))
(define (other-modal? win)
;; called in event-pump thread
(let loop ([frames (get-top-level-windows)])
(and (pair? frames)
(let ([status (send (car frames) frame-relative-dialog-status win)])
(case status
[(#f) (loop (cdr frames))]
[(same) #f]
[(other) #t])))))
(define (queue-quit-event)
;; called in event-pump thread
(queue-event main-eventspace (application-quit-handler) 'med))

2
collects/mred/private/wx/gtk/choice.rkt
View File

@ -62,6 +62,8 @@
[callback cb]
[no-show? (memq 'deleted style)])
(connect-key-and-mouse button-gtk)
(gtk_combo_box_set_active gtk 0)
(set-auto-size)

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

@ -18,6 +18,8 @@
(define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void))
(define dialog-level-counter 0)
(defclass dialog% frame%
(inherit get-gtk
get-parent)
@ -32,7 +34,22 @@
(when p
(gtk_window_set_transient_for (get-gtk) (send p get-gtk))))
(define dialog-level 0)
(define/override (get-dialog-level) dialog-level)
(define/override (frame-relative-dialog-status win)
(let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other])))
(define/override (direct-show on?)
(when on?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(unless on?
(set! dialog-level 0))
(unless on?
(when close-sema
(semaphore-post close-sema)

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

@ -52,14 +52,14 @@
(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void))
(define (handle-delete gtk)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda ()
(when (send wx on-close)
(send wx direct-show #f))))))
(define handle_delete
(function-ptr handle-delete
(_fun #:atomic? #t _GtkWidget -> _gboolean)))
(define-signal-handler connect-delete "delete-event"
(_fun _GtkWidget -> _gboolean)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda ()
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f))))))))
(define-signal-handler connect-configure "configure-event"
(_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
@ -121,7 +121,7 @@
(set-size x y w h)
(g_signal_connect gtk "delete_event" handle_delete)
(connect-delete gtk)
(connect-configure gtk)
(when label
@ -159,6 +159,9 @@
(define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1)))
(define/public (get-dc-lock) dc-lock)
(define/override (get-dialog-level) 0)
(define/public (frame-relative-dialog-status win) #f)
(define/override (center dir wrt)
(let ([w-box (box 0)]
[h-box (box 0)]

17
collects/mred/private/wx/gtk/menu-bar.rkt
View File

@ -3,6 +3,7 @@
scheme/foreign
"../../syntax.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"widget.rkt"
"utils.rkt"
"types.rkt")
@ -49,7 +50,17 @@
(define/public (get-top-window) (send parent get-top-window))
(super-new)))
(define-signal-handler connect-menu-key-press "key-press-event"
(_fun _GtkWidget _GdkEventKey-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(other-modal? wx))))
(define-signal-handler connect-menu-button-press "button-press-event"
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(other-modal? wx))))
(defclass menu-bar% widget%
(define menus null)
@ -59,12 +70,18 @@
(define/public (get-gtk) gtk)
(connect-menu-key-press gtk)
(connect-menu-button-press gtk)
(define top-wx #f)
(define/public (set-top-window top)
(set! top-wx top))
(define/public (get-top-window)
top-wx)
(define/public (get-dialog-level)
(send top-wx get-dialog-level))
(define/public (set-label-top pos str)
(let ([l (list-ref menus pos)])
(let ([item-gtk (car l)])

2
collects/mred/private/wx/gtk/tab-panel.rkt
View File

@ -86,6 +86,8 @@
[extra-gtks (list client-gtk)]
[no-show? (memq 'deleted style)])
(connect-key-and-mouse gtk)
(set-auto-size)
(define callback void)

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

@ -5,6 +5,7 @@
"../../syntax.rkt"
"../common/event.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"keycode.rkt"
"queue.rkt"
"utils.rkt"
@ -107,7 +108,8 @@
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
(lambda (gtk event)
(unless (gtk_widget_is_focus gtk)
(gtk_widget_grab_focus gtk))
(unless (other-modal? (gtk->wx gtk))
(gtk_widget_grab_focus gtk)))
(do-button-event gtk event #f #f)))
(define-signal-handler connect-button-release "button-release-event"
@ -335,6 +337,8 @@
(define/public (get-top-win) (send parent get-top-win))
(define/public (get-dialog-level) (send parent get-dialog-level))
(define/public (get-size xb yb)
(set-box! xb save-w)
(set-box! yb save-h))
@ -365,11 +369,13 @@
(define/public (handles-events?) #f)
(define/public (dispatch-on-char e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-char this e) #t]
[just-pre? #f]
[else (when enabled? (on-char e)) #t]))
(define/public (dispatch-on-event e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-event this e) #t]
[just-pre? #f]
[else (when enabled? (on-event e)) #t]))

28
collects/racket/draw/dc.rkt
View File

@ -48,6 +48,8 @@
(real? (vector-ref v 4))
(real? (vector-ref v 5))))
(define substitute-fonts? (memq (system-type) '(macosx)))
;; dc-backend : interface
;;
;; This is the interface that the backend specific code must implement
@ -933,7 +935,8 @@
(when attrs (pango_layout_set_attributes layout attrs))
(pango_layout_set_text layout s)
(let ([next-s
(if (zero? (pango_layout_get_unknown_glyphs_count layout))
(if (or (not substitute-fonts?)
(zero? (pango_layout_get_unknown_glyphs_count layout)))
#f
;; look for the first character in the string without a glyph
(let ([ok-count
@ -953,7 +956,7 @@
(pango_layout_set_text layout (substring s 0 (max 1 ok-count)))
(when (zero? ok-count)
;; find a face that works for the long character:
(install-alternate-face layout font desc attrs))
(install-alternate-face (string-ref s 0) layout font desc attrs context))
(substring s (max 1 ok-count))))])
(when draw?
(cairo_move_to cr (+ x w) y)
@ -986,9 +989,10 @@
(pango_layout_set_font_description layout desc)
(when attrs (pango_layout_set_attributes layout attrs))
(pango_layout_set_text layout (string ch))
(unless (zero? (pango_layout_get_unknown_glyphs_count layout))
(unless (or (not substitute-fonts?)
(zero? (pango_layout_get_unknown_glyphs_count layout)))
;; No good glyph; look for an alternate face
(install-alternate-face layout font desc attrs))
(install-alternate-face ch layout font desc attrs context))
(hash-set! layouts key layout)
layout)))])
(pango_cairo_update_layout cr layout)
@ -1006,9 +1010,11 @@
(when rotate? (cairo_restore cr))))))))
(define/private (install-alternate-face layout font desc attrs)
(define/private (install-alternate-face ch layout font desc attrs context)
(or
(for/or ([face (in-list (get-face-list))])
(for/or ([face (in-list
;; Hack: prefer Lucida Grande
(cons "Lucida Grande" (get-face-list)))])
(let ([desc (get-pango (make-object font%
(send font get-point-size)
face
@ -1198,7 +1204,8 @@
(with-cr
#f
cr
(let ([desc (get-pango font)])
(let ([desc (get-pango font)]
[attrs (send font get-pango-attrs)])
(unless context
(set! context (pango_cairo_create_context cr)))
(let ([layout (pango_layout_new context)])
@ -1206,8 +1213,11 @@
(pango_layout_set_text layout (string c))
(pango_cairo_update_layout cr layout)
(begin0
(zero? (pango_layout_get_unknown_glyphs_count layout))
(or (zero? (pango_layout_get_unknown_glyphs_count layout))
(and substitute-fonts?
(install-alternate-face c layout font desc attrs context)
(zero? (pango_layout_get_unknown_glyphs_count layout))))
(g_object_unref layout))))))
)
dc%)
dc%)

8
collects/racket/draw/font.rkt
View File

@ -194,5 +194,9 @@
(define (get-face-list [mode 'all])
(map pango_font_family_get_name
(pango_font_map_list_families
(pango_cairo_font_map_get_default))))
(let ([fams (pango_font_map_list_families
(pango_cairo_font_map_get_default))])
(if (eq? mode 'mono)
(filter pango_font_family_is_monospace fams)
fams))))