From e9e180847a72ba91ea817fc3b5fc1a457e676747 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Aug 2010 19:39:43 -0600 Subject: [PATCH] enforce modality; more on-subwindow- callbacks; Cocoa font tweaks --- collects/ffi/unsafe.rkt | 3 +- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 61 +++++++++++++------ .../mred/private/wx/cocoa/group-panel.rkt | 6 +- collects/mred/private/wx/cocoa/list-box.rkt | 1 + collects/mred/private/wx/cocoa/message.rkt | 21 +++++-- collects/mred/private/wx/cocoa/radio-box.rkt | 2 +- collects/mred/private/wx/cocoa/slider.rkt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 7 +++ collects/mred/private/wx/common/queue.rkt | 13 ++++ collects/mred/private/wx/gtk/choice.rkt | 2 + collects/mred/private/wx/gtk/dialog.rkt | 17 ++++++ collects/mred/private/wx/gtk/frame.rkt | 21 ++++--- collects/mred/private/wx/gtk/menu-bar.rkt | 17 ++++++ collects/mred/private/wx/gtk/tab-panel.rkt | 2 + collects/mred/private/wx/gtk/window.rkt | 8 ++- collects/racket/draw/dc.rkt | 28 ++++++--- collects/racket/draw/font.rkt | 8 ++- 20 files changed, 173 insertions(+), 51 deletions(-) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 8f2271e5bd..53efa02b9a 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -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)))) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index f6dd2c7257..5cf3a5581a 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -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))))) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 98b1f8692b..e94fc82bec 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -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))))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index d21ed04990..81b5f05b60 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -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?) diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt index ef1c420004..73588a0a2e 100644 --- a/collects/mred/private/wx/cocoa/group-panel.rkt +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -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)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index c02bc1c014..7fda6f6e0f 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -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))] diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 6a09103fa8..68d5cc4474 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -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) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 6edf6fd04d..211410e68c 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -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))))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 679f42bd1e..c0a8e7804d 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -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))) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 3548c163a9..175e4d40b0 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -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]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 7cd2f75a00..81d09aac3d 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -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])) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index d6b4309b2d..c50a33712a 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -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)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index ccd5c549f8..ff7c532cb8 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -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) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index eee9934bf0..5cf001f891 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -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) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 06e8ee902a..ec99970b08 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -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)] diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 0f371ad8de..3e086852a0 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -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)]) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 5ff4a204c0..ab06e85db8 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -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) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 42782028de..0fb3fab9ee 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -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])) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 4124a6ba7a..5dece09820 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -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%) \ No newline at end of file + dc%) diff --git a/collects/racket/draw/font.rkt b/collects/racket/draw/font.rkt index 55d420042d..1aa46d1ca4 100644 --- a/collects/racket/draw/font.rkt +++ b/collects/racket/draw/font.rkt @@ -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)))) +