cocoa: control fonts

original commit: ca64c25cf9f897c888531ef7ddf6b64260423d8e

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

@@ -0,0 +1,48 @@
+#lang racket/base
+(require racket/class
+         racket/draw
+         ffi/unsafe
+         ffi/unsafe/objc
+         "../../lock.rkt"
+         "const.rkt"
+         "utils.rkt"
+         "types.rkt")
+
+(provide font->NSFont)
+
+(import-class NSFont NSFontManager)
+
+(define NSItalicFontMask #x00000001)
+(define NSBoldFontMask #x00000002)
+
+(define (font->NSFont f)
+  (let* ([weight (send f get-weight)]
+         [style (send f get-style)]
+         [name (or (send f get-face)
+                   (send the-font-name-directory
+                         get-screen-name
+                         (send the-font-name-directory
+                               find-family-default-font-id
+                               (send f get-family))
+                         weight
+                         style))])
+    (atomically
+     (with-autorelease
+      (let ([f (tell NSFont 
+                     fontWithName: #:type _NSString name
+                     size: #:type _CGFloat (send f get-point-size))])
+        (if (and (eq? 'normal weight)
+                 (eq? 'normal style))
+            (begin
+              (retain f)
+              f)
+            (let ([fm (tell NSFontManager sharedFontManager)])
+              (let ([f (tell fm
+                             convertFont: f 
+                             toHaveTrait: #:type _int (bitwise-ior
+                                                       (if (eq? weight 'bold) NSBoldFontMask 0)
+                                                       (if (eq? style 'italic) NSItalicFontMask 0)))])
+                (begin
+                  (retain f)
+                  f)))))))))
+                    

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

@@ -2,10 +2,11 @@
 (require scheme/class
          scheme/foreign
          ffi/objc
-          "../../syntax.rkt"
+         "../../syntax.rkt"
          "window.rkt"
          "const.rkt"
-         "types.rkt")
+         "types.rkt"
+         "font.rkt")
 (unsafe!)
 (objc-unsafe!)
 
@@ -17,7 +18,9 @@
                        systemFontOfSize: #:type _CGFloat 13))
 
 (define (install-control-font cocoa font)
-  (tellv cocoa setFont: sys-font))
+  (if font
+      (tellv cocoa setFont: (font->NSFont font))
+      (tellv cocoa setFont: sys-font)))
 
 (defclass item% window%
   (inherit get-cocoa)

collects/mred/private/wx/cocoa/list-box.rkt

@@ -10,6 +10,7 @@
          "types.rkt"
          "const.rkt"
          "window.rkt"
+         "font.rkt"
          "../common/event.rkt")
 (unsafe!)
 (objc-unsafe!)
@@ -27,8 +28,12 @@
   [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
       (let ([wx (->wx wxb)])
         (tell
-         (tell (tell NSCell alloc) initTextCell: #:type _NSString 
-               (if wx (send wx get-row row) "???"))
+         (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString 
+                        (if wx (send wx get-row row) "???"))]
+               [font (send wx get-cell-font)])
+           (when font
+             (tellv c setFont: font))
+           c)
          autorelease))]
   [-a _void (doubleClicked: [_id sender])
       (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))]
@@ -106,6 +111,10 @@
 
   (def/public-unimplemented get-label-font)
 
+  (define cell-font (and font (font->NSFont font)))
+  (define/public (get-cell-font)
+    cell-font)
+
   (define/public (get-selection)
     (tell #:type _NSInteger content-cocoa selectedRow))
   (define/public (get-selections)

collects/tests/gracket/item.rkt

@@ -50,6 +50,10 @@
 			   20 'decorative 
 			   'normal 'bold
 			   #f))
+(define italic-font (send the-font-list find-or-create-font
+                          13 'roman
+                          'italic 'normal
+                          #f))
 (define ($ font) (or font normal-control-font))
 
 (define (make-h&s cp f)
@@ -2253,7 +2257,7 @@
       (make-radio-box "Stretchiness" '("Normal" "All Stretchy")
 		      p1 void))
     (define font-radio
-      (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big")
+      (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big" "Italic")
 		      p1 void))
     (define enabled-radio
       (make-radio-box "Initially" '("Enabled" "Disabled")
@@ -2276,7 +2280,8 @@
 		      (list-ref (list #f
 				      small-control-font
 				      tiny-control-font
-				      special-font)
+				      special-font
+                                      italic-font)
 				(send font-radio get-selection))
 		      (positive? (send enabled-radio get-selection))
 		      (positive? (send selection-radio get-selection))