Refactor Core Foundation binding a bit, add new >cf word to convert Factor objects to CF values

basis/cocoa/application/application-docs.factor

@@ -8,12 +8,6 @@ HELP: <NSString>
 
 { <NSString> <CFString> CF>string } related-words
 
-HELP: <NSArray>
-{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
-{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
-
-{ <NSArray> <CFArray> } related-words
-
 HELP: with-autorelease-pool
 { $values { "quot" quotation } }
 { $description "Sets up a new " { $snippet "NSAutoreleasePool"  } ", calls the quotation and frees the pool." } ;

basis/cocoa/application/application.factor

@@ -1,27 +1,17 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.arrays core-foundation.data
 core-foundation.strings cocoa.messages cocoa cocoa.classes
 cocoa.runtime sequences threads init summary kernel.private
 assocs ;
 IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
-: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
-: <NSNumber> ( number -- alien ) <CFNumber> -> autorelease ;
-: <NSData> ( byte-array -- alien ) <CFData> -> autorelease ;
-: <NSDictionary> ( assoc -- alien )
-    NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
-    [
-        [
-            spin -> setObject:forKey:
-        ] curry assoc-each
-    ] keep ;
 
-: NSApplicationDelegateReplySuccess 0 ;
+C-ENUM:
-: NSApplicationDelegateReplyCancel  1 ;
+NSApplicationDelegateReplySuccess
-: NSApplicationDelegateReplyFailure 2 ;
+NSApplicationDelegateReplyCancel
+NSApplicationDelegateReplyFailure ;
 
 : with-autorelease-pool ( quot -- )
     NSAutoreleasePool -> new slip -> release ; inline
@@ -45,7 +35,8 @@ FUNCTION: void NSBeep ( ) ;
     [ NSNotificationCenter -> defaultCenter ] dip
     -> removeObserver: ;
 
-: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
+: cocoa-app ( quot -- )
+    [ call NSApp -> run ] with-cocoa ; inline
 
 : install-delegate ( receiver delegate -- )
     -> alloc -> init -> setDelegate: ;

basis/cocoa/pasteboard/pasteboard.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.accessors arrays kernel cocoa.messages
 cocoa.classes cocoa.application sequences cocoa core-foundation
@@ -15,7 +15,7 @@ IN: cocoa.pasteboard
     dup [ CF>string ] when ;
 
 : set-pasteboard-types ( seq pasteboard -- )
-    swap <NSArray> f -> declareTypes:owner: drop ;
+    swap <CFArray> -> autorelease f -> declareTypes:owner: drop ;
 
 : set-pasteboard-string ( str pasteboard -- )
     NSStringPboardType <NSString>

basis/cocoa/plists/plists.factor

@@ -1,42 +1,29 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays hashtables assocs sequences
+USING: strings arrays hashtables assocs sequences fry macros
 cocoa.messages cocoa.classes cocoa.application cocoa kernel
 namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types core-foundation core-foundation.data ;
+combinators alien.c-types words core-foundation
+core-foundation.data core-foundation.utilities ;
 IN: cocoa.plists
 
-GENERIC: >plist ( value -- plist )
+: >plist ( value -- plist ) >cf -> autorelease ;
-
-M: number >plist
-    <NSNumber> ;
-M: t >plist
-    <NSNumber> ;
-M: f >plist
-    <NSNumber> ;
-M: string >plist
-    <NSString> ;
-M: byte-array >plist
-    <NSData> ;
-M: hashtable >plist
-    [ [ >plist ] bi@ ] assoc-map <NSDictionary> ;
-M: sequence >plist
-    [ >plist ] map <NSArray> ;
 
 : write-plist ( assoc path -- )
-    [ >plist ] [ normalize-path <NSString> ] bi* 0
+    [ >plist ] [ normalize-path <NSString> ] bi* 0 -> writeToFile:atomically:
-    -> writeToFile:atomically:
     [ "write-plist failed" throw ] unless ;
 
 DEFER: plist>
 
+<PRIVATE
+
 : (plist-NSString>) ( NSString -- string )
     -> UTF8String ;
 
 : (plist-NSNumber>) ( NSNumber -- number )
     dup -> doubleValue dup >integer =
-    [ -> longLongValue ]
+    [ -> longLongValue ] [ -> doubleValue ] if ;
-    [ -> doubleValue ] if ;
 
 : (plist-NSData>) ( NSData -- byte-array )
     dup -> length <byte-array> [ -> getBytes: ] keep ;
@@ -48,21 +35,26 @@ DEFER: plist>
     dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with
     NSFastEnumeration-map >hashtable ;
 
-: plist> ( plist -- value )
-    {
-        { [ dup NSString     -> isKindOfClass: c-bool> ] [ (plist-NSString>)      ] }
-        { [ dup NSNumber     -> isKindOfClass: c-bool> ] [ (plist-NSNumber>)      ] }
-        { [ dup NSData       -> isKindOfClass: c-bool> ] [ (plist-NSData>)        ] }
-        { [ dup NSArray      -> isKindOfClass: c-bool> ] [ (plist-NSArray>)       ] }
-        { [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>)  ] }
-        [ ]
-    } cond ;
-
 : (read-plist) ( NSData -- id )
     NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
     [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
     *void* [ -> release "read-plist failed" throw ] when* ;
 
+MACRO: objc-class-case ( alist -- quot )
+    [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+
+PRIVATE>
+
+: plist> ( plist -- value )
+    {
+        { NSString [ (plist-NSString>) ] }
+        { NSNumber [ (plist-NSNumber>) ] }
+        { NSData [ (plist-NSData>) ] }
+        { NSArray [ (plist-NSArray>) ] }
+        { NSDictionary [ (plist-NSDictionary>) ] }
+        { NSObject [ ] }
+    } objc-class-case ;
+
 : read-plist ( path -- assoc )
     normalize-path <NSString>
     NSData swap -> dataWithContentsOfFile:

basis/core-foundation/attributed-strings/attributed-strings.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel core-foundation
+USING: alien.syntax kernel destructors core-foundation
-core-foundation.strings core-foundation.dictionaries ;
+core-foundation.utilities ;
 IN: core-foundation.attributed-strings
 
 TYPEDEF: void* CFAttributedStringRef
@@ -13,7 +13,7 @@ FUNCTION: CFAttributedStringRef CFAttributedStringCreate (
 ) ;
 
 : <CFAttributedString> ( string alist -- alien )
-    [ <CFString> ] [ <CFDictionary> ] bi*
+    [
-    [ [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate ]
+        [ >cf &CFRelease ] bi@
-    [ [ CFRelease ] bi@ ]
+        [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
-    2bi ;
+    ] with-destructors ;

basis/core-foundation/data/data.factor

@@ -1,55 +1,20 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.c-types sequences kernel math ;
+USING: alien.c-types alien.syntax core-foundation.numbers kernel math
+sequences core-foundation.numbers ;
 IN: core-foundation.data
 
 TYPEDEF: void* CFDataRef
-TYPEDEF: void* CFNumberRef
 TYPEDEF: void* CFSetRef
 
-TYPEDEF: int CFNumberType
-CONSTANT: kCFNumberSInt8Type 1
-CONSTANT: kCFNumberSInt16Type 2
-CONSTANT: kCFNumberSInt32Type 3
-CONSTANT: kCFNumberSInt64Type 4
-CONSTANT: kCFNumberFloat32Type 5
-CONSTANT: kCFNumberFloat64Type 6
-CONSTANT: kCFNumberCharType 7
-CONSTANT: kCFNumberShortType 8
-CONSTANT: kCFNumberIntType 9
-CONSTANT: kCFNumberLongType 10
-CONSTANT: kCFNumberLongLongType 11
-CONSTANT: kCFNumberFloatType 12
-CONSTANT: kCFNumberDoubleType 13
-CONSTANT: kCFNumberCFIndexType 14
-CONSTANT: kCFNumberNSIntegerType 15
-CONSTANT: kCFNumberCGFloatType 16
-CONSTANT: kCFNumberMaxType 16
-
 TYPEDEF: int CFPropertyListMutabilityOptions
 CONSTANT: kCFPropertyListImmutable 0
 CONSTANT: kCFPropertyListMutableContainers 1
 CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
 
-FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
-
 FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
 
 FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
 
-GENERIC: <CFNumber> ( number -- alien )
-
-M: integer <CFNumber>
-    [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
-
-M: float <CFNumber>
-    [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
-
-M: t <CFNumber>
-    drop f kCFNumberIntType 1 <int> CFNumberCreate ;
-
-M: f <CFNumber>
-    drop f kCFNumberIntType 0 <int> CFNumberCreate ;
-
 : <CFData> ( byte-array -- alien )
-    [ f ] dip dup length CFDataCreate ;
+    [ f ] dip dup length CFDataCreate ;

basis/core-foundation/numbers/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/numbers/numbers-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.numbers ;
+IN: core-foundation.numbers.tests

basis/core-foundation/numbers/numbers.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax kernel math core-foundation ;
+IN: core-foundation.numbers
+
+TYPEDEF: void* CFNumberRef
+
+TYPEDEF: int CFNumberType
+CONSTANT: kCFNumberSInt8Type 1
+CONSTANT: kCFNumberSInt16Type 2
+CONSTANT: kCFNumberSInt32Type 3
+CONSTANT: kCFNumberSInt64Type 4
+CONSTANT: kCFNumberFloat32Type 5
+CONSTANT: kCFNumberFloat64Type 6
+CONSTANT: kCFNumberCharType 7
+CONSTANT: kCFNumberShortType 8
+CONSTANT: kCFNumberIntType 9
+CONSTANT: kCFNumberLongType 10
+CONSTANT: kCFNumberLongLongType 11
+CONSTANT: kCFNumberFloatType 12
+CONSTANT: kCFNumberDoubleType 13
+CONSTANT: kCFNumberCFIndexType 14
+CONSTANT: kCFNumberNSIntegerType 15
+CONSTANT: kCFNumberCGFloatType 16
+CONSTANT: kCFNumberMaxType 16
+
+FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
+
+GENERIC: <CFNumber> ( number -- alien )
+
+M: integer <CFNumber>
+    [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
+M: float <CFNumber>
+    [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
+M: t <CFNumber>
+    drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
+M: f <CFNumber>
+    drop f kCFNumberIntType 0 <int> CFNumberCreate ;
+

basis/core-foundation/numbers/tags.txt

@@ -0,0 +1 @@
+unportable

basis/core-foundation/utilities/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/utilities/tags.txt

@@ -0,0 +1 @@
+unportable

basis/core-foundation/utilities/utilities-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.utilities ;
+IN: core-foundation.utilities.tests

basis/core-foundation/utilities/utilities.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math assocs kernel sequences byte-arrays strings
+hashtables alien destructors
+core-foundation.numbers core-foundation.strings
+core-foundation.arrays core-foundation.dictionaries
+core-foundation.data core-foundation ;
+IN: core-foundation.utilities
+
+GENERIC: (>cf) ( obj -- cf )
+
+M: number (>cf) <CFNumber> ;
+M: t (>cf) <CFNumber> ;
+M: f (>cf) <CFNumber> ;
+M: string (>cf) <CFString> ;
+M: byte-array (>cf) <CFData> ;
+M: hashtable (>cf) [ [ (>cf) &CFRelease ] bi@ ] assoc-map <CFDictionary> ;
+M: sequence (>cf) [ (>cf) &CFRelease ] map <CFArray> ;
+M: alien (>cf) CFRetain ;
+
+: >cf ( obj -- cf ) [ (>cf) ] with-destructors ;

basis/core-graphics/core-graphics.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.destructors alien.syntax
-destructors fry kernel math sequences
+destructors fry kernel math sequences libc
 core-graphics.types ;
 IN: core-graphics
 
@@ -69,15 +69,25 @@ FUNCTION: void CGContextSetTextPosition (
 
 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
 
-: <CGBitmapContext> ( data dim -- context )
+FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
-    [
+
-        [ first2 8 ] keep first 4 *
+<PRIVATE
-        CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease
+
-        kCGImageAlphaPremultipliedLast CGBitmapContextCreate
+: <CGBitmapContext> ( dim -- context )
-    ] with-destructors ;
+    [ product "uint" malloc-array &free ] [ first2 8 ] [ first 4 * ] tri
+    CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease
+    kCGImageAlphaPremultipliedLast CGBitmapContextCreate
+    [ "CGBitmapContextCreate failed" throw ] unless* ;
+
+: bitmap-data ( bitmap dim -- data )
+    [ CGBitmapContextGetData ]
+    [ product "uint" heap-size * ] bi*
+    memory>byte-array ;
+
+PRIVATE>
 
 : with-bitmap-context ( dim quot -- data )
-    '[
+    [
-        [ product "uint" <c-array> ] keep
+        [ [ <CGBitmapContext> &CGContextRelease ] keep ] dip
-        [ <CGBitmapContext> &CGContextRelease @ ] [ drop ] 2bi
+        [ nip call ] [ drop bitmap-data ] 3bi
     ] with-destructors ; inline

basis/core-text/core-text-tests.factor

@@ -3,11 +3,11 @@
 USING: tools.test core-text core-foundation
 core-foundation.dictionaries destructors
 arrays kernel generalizations math accessors
-combinators ;
+combinators hashtables ;
 IN: core-text.tests
 
 : test-font ( -- object )
-    "Helvetica" 12 <CTFont> ;
+    "Helvetica" kCTFontNameAttribute associate <CTFont> ;
 
 [ ] [ test-font CFRelease ] unit-test
 

basis/core-text/core-text.factor

@@ -1,28 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien alien.c-types alien.syntax kernel destructors words
+USING: arrays alien alien.c-types alien.syntax kernel
-parser accessors fry words hashtables sequences memoize
+destructors words parser accessors fry words hashtables
-assocs math math.functions locals init
+sequences memoize assocs math math.functions locals init
 core-foundation core-foundation.strings
-core-foundation.attributed-strings
+core-foundation.attributed-strings core-foundation.utilities
 core-graphics core-graphics.types ;
 IN: core-text
 
 TYPEDEF: void* CTLineRef
 TYPEDEF: void* CTFontRef
-
+TYPEDEF: void* CTFontDescriptorRef
-FUNCTION: CTFontRef CTFontCreateWithName (
-   CFStringRef name,
-   CGFloat size,
-   CGAffineTransform* matrix
-) ;
-
-: <CTFont> ( name size -- font )
-    [
-        [ <CFString> &CFRelease ] dip f CTFontCreateWithName
-    ] with-destructors ;
-
-MEMO: cached-font ( name size -- font ) <CTFont> ;
 
 <<
 
@@ -33,6 +21,52 @@ MEMO: cached-font ( name size -- font ) <CTFont> ;
 
 >>
 
+C-GLOBAL: kCTFontSymbolicTrait
+C-GLOBAL: kCTFontWeightTrait
+C-GLOBAL: kCTFontWidthTrait
+C-GLOBAL: kCTFontSlantTrait
+
+C-GLOBAL: kCTFontNameAttribute
+C-GLOBAL: kCTFontDisplayNameAttribute
+C-GLOBAL: kCTFontFamilyNameAttribute
+C-GLOBAL: kCTFontStyleNameAttribute
+C-GLOBAL: kCTFontTraitsAttribute
+C-GLOBAL: kCTFontVariationAttribute
+C-GLOBAL: kCTFontSizeAttribute
+C-GLOBAL: kCTFontMatrixAttribute
+C-GLOBAL: kCTFontCascadeListAttribute
+C-GLOBAL: kCTFontCharacterSetAttribute
+C-GLOBAL: kCTFontLanguagesAttribute
+C-GLOBAL: kCTFontBaselineAdjustAttribute
+C-GLOBAL: kCTFontMacintoshEncodingsAttribute
+C-GLOBAL: kCTFontFeaturesAttribute
+C-GLOBAL: kCTFontFeatureSettingsAttribute
+C-GLOBAL: kCTFontFixedAdvanceAttribute
+C-GLOBAL: kCTFontOrientationAttribute
+
+FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
+   CFDictionaryRef attributes
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithName (
+   CFStringRef name,
+   CGFloat size,
+   CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
+   CTFontDescriptorRef descriptor,
+   CGFloat size,
+   CGAffineTransform* matrix
+) ;
+
+: <CTFont> ( attrs -- font )
+    [
+        >cf &CFRelease
+        CTFontDescriptorCreateWithAttributes &CFRelease
+        0.0 f CTFontCreateWithFontDescriptor
+    ] with-destructors ;
+
 C-GLOBAL: kCTFontAttributeName
 C-GLOBAL: kCTKernAttributeName
 C-GLOBAL: kCTLigatureAttributeName
@@ -114,7 +148,4 @@ PRIVATE>
 
 : cached-line ( string font -- line ) (cached-line) 0 >>age ;
 
-[
+[ \ (cached-line) reset-memoized ] "core-text" add-init-hook
-    \ cached-font reset-memoized
-    \ (cached-line) reset-memoized
-] "core-text" add-init-hook

basis/ui/cocoa/text/text.factor

@@ -1,7 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors alien core-graphics.types core-text kernel
-namespaces sequences ui.gadgets.worlds ui.render opengl opengl.gl ;
+hashtables namespaces sequences ui.gadgets.worlds ui.render
+opengl opengl.gl destructors combinators combinators.smart
+core-foundation core-foundation.dictionaries core-foundation.numbers
+core-foundation.strings io.styles memoize ;
 IN: ui.cocoa.text
 
 SINGLETON: core-text-renderer
@@ -13,13 +16,46 @@ CONSTANT: font-names
         { "serif" "Times" }
     }
 
-USING: classes.algebra unicode.case.private ;
+: (bold) ( -- ) 1.0 kCTFontWeightTrait set ;
 
-: font-name/size ( font -- name size )
+: (italic) ( -- ) 1.0 kCTFontSlantTrait set ;
-    [ first font-names at-default ] [ third ] bi ;
+
+: font-traits ( style -- dictionary )
+    [
+        {
+            { plain [ ] }
+            { bold [ (bold) ] }
+            { italic [ (italic) ] }
+            { bold-italic [ (bold) (italic) ] }
+        } case
+    ] H{ } make-assoc ;
+
+: font-name-attr ( name -- )
+    font-names at-default kCTFontNameAttribute set ;
+
+: font-traits-attr ( style -- )
+    font-traits kCTFontTraitsAttribute set ;
+
+: font-size-attr ( size -- )
+    kCTFontSizeAttribute set ;
+
+: font-attrs ( font -- dictionary )
+    [
+        [
+            [
+                [ font-name-attr ]
+                [ font-traits-attr ]
+                [ font-size-attr ]
+                tri*
+            ] input<sequence
+        ] H{ } make-assoc
+    ] with-destructors ;
+
+MEMO: cache-font ( font -- open-font )
+    font-attrs <CTFont> ;
 
 M: core-text-renderer open-font
-    dup alien? [ font-name/size cached-font ] unless ;
+    dup alien? [ cache-font ] unless ;
 
 : string-dim ( open-font string -- dim )
     swap cached-line dim>> ;
@@ -30,11 +66,13 @@ M: core-text-renderer string-width ( open-font string -- w )
 M: core-text-renderer string-height ( open-font string -- h )
     [ " " ] when-empty string-dim second ;
 
-TUPLE: line-texture line texture age ;
+TUPLE: line-texture line texture age disposed ;
 
 : <line-texture> ( line -- texture )
     dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
-    0 \ line-texture boa ;
+    0 f \ line-texture boa ;
+
+M: line-texture dispose* texture>> delete-texture ;
 
 : line-texture ( string open-font -- texture )
     world get fonts>> [ cached-line <line-texture> ] 2cache ;
@@ -55,6 +93,9 @@ M: core-text-renderer draw-string ( font string loc -- )
     [ swap open-font line-texture draw-line-texture ] with-translation ;
 
 M: core-text-renderer x>offset ( x font string -- n )
-    swap cached-line swap 0 <CGPoint> CTLineGetStringIndexForPosition ;
+    swap open-font cached-line line>> swap 0 <CGPoint> CTLineGetStringIndexForPosition ;
+
+M: core-text-renderer free-fonts ( fonts -- )
+    values dispose-each ;
 
 core-text-renderer font-renderer set-global

basis/ui/freetype/freetype.factor

@@ -41,8 +41,7 @@ M: font hashcode* drop font hashcode* ;
     ] bind ;
 
 M: freetype-renderer free-fonts ( world -- )
-    [ handle>> select-gl-context ]
+    values [ second free-sprites ] each ;
-    [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
 
 : ttf-name ( font style -- name )
     2array H{

basis/ui/ui.factor

@@ -60,9 +60,12 @@ M: world graft*
     [ f >>handle drop ] tri ;
 
 : (ungraft-world) ( world -- )
-    [ free-fonts ]
+    {
-    [ hand-clicked close-global ]
+        [ handle>> select-gl-context ]
-    [ hand-gadget close-global ] tri ;
+        [ fonts>> free-fonts ]
+        [ hand-clicked close-global ]
+        [ hand-gadget close-global ]
+    } cleave ;
 
 M: world ungraft*
     [ (ungraft-world) ]