Add font-metrics hook

basis/core-text/core-text.factor

@@ -51,7 +51,7 @@ TUPLE: line font line metrics image disposed ;
 : compute-line-metrics ( line -- line-metrics )
     0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
     [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@
-    metrics boa ;
+    <metrics> ;
 
 : bounds>dim ( bounds -- dim )
     [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi

basis/core-text/fonts/fonts.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.syntax assocs core-foundation
 core-foundation.strings core-text.utilities destructors init
-kernel math memoize ;
+kernel math memoize fonts combinators ;
 IN: core-text.fonts
 
 TYPEDEF: void* CTFontRef
@@ -64,6 +64,12 @@ FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
    uint32_t symTraitMask
 ) ;
 
+FUNCTION: CGFloat CTFontGetAscent ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font ) ;
+
 CONSTANT: font-names
     H{
         { "monospace" "Monaco" }
@@ -97,6 +103,20 @@ MEMO: (cache-font) ( font -- open-font )
     ] with-destructors ;
 
 : cache-font ( font -- open-font )
-    clone f >>foreground f >>background (cache-font) ;
+    strip-font-colors (cache-font) ;
 
-[ \ (cache-font) reset-memoized ] "core-text.fonts" add-init-hook
+MEMO: (cache-font-metrics) ( font -- metrics )
+    (cache-font) {
+        [ drop 0 ]
+        [ CTFontGetAscent ]
+        [ CTFontGetDescent ]
+        [ CTFontGetLeading ]
+    } cleave <metrics> ;
+
+: cache-font-metrics ( font -- metrics )
+    strip-font-colors (cache-font-metrics) ;
+
+[
+    \ (cache-font) reset-memoized
+    \ (cache-font-metrics) reset-memoized
+] "core-text.fonts" add-init-hook

basis/fonts/fonts.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel colors colors.constants accessors combinators ;
+USING: kernel colors colors.constants accessors combinators math ;
 IN: fonts
 
 TUPLE: font
@@ -55,7 +55,13 @@ italic?
         "monospace" >>name
         12 >>size ;
 
-TUPLE: metrics width ascent descent leading ;
+: strip-font-colors ( font -- font' )
+    clone f >>background f >>foreground ;
+
+TUPLE: metrics width ascent descent height leading ;
+
+: <metrics> ( width ascent descent leading -- metrics )
+    [ 2dup + ] dip metrics boa ;
 
 TUPLE: selection string start end color ;
 

basis/ui/gadgets/editors/editors.factor

@@ -183,7 +183,7 @@ M: editor pref-dim*
     [ font>> ] [ control-value ] bi text-dim ;
 
 M: editor baseline
-    font>> "" line-metrics ascent>> ;
+    font>> font-metrics ascent>> ;
 
 : contents-changed ( model editor -- )
     swap

basis/ui/gadgets/line-support/line-support.factor

@@ -8,15 +8,21 @@ IN: ui.gadgets.line-support
 ! Some code shared by table and editor gadgets
 SLOT: font
 
+GENERIC: line-leading ( gadget -- n )
+
+M: gadget line-leading font>> font-metrics leading>> ;
+
 GENERIC: line-height ( gadget -- n )
 
-M: gadget line-height font>> "" text-height ;
+M: gadget line-height font>> font-metrics height>> ;
 
 : y>line ( y gadget -- n )
-    line-height /i ;
+    [ line-leading ] [ line-height ] bi
+    [ [ - ] keep ] dip + /i ;
 
 : line>y ( n gadget -- y )
-    line-height * ;
+    [ line-height ] [ line-leading ] bi
+    [ + * ] keep - ;
 
 : validate-line ( m gadget -- n )
     control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
@@ -43,7 +49,7 @@ GENERIC: draw-line ( line index gadget -- )
         [ first-visible-line ]
         [ last-visible-line ]
         [ control-value ]
-        [ line-height ]
+        [ [ line-leading ] [ line-height ] bi + ]
         [ ]
     } cleave '[
         0 over _ * 2array

basis/ui/text/core-text/core-text.factor

@@ -41,6 +41,9 @@ M: core-text-renderer offset>x ( n font string -- x )
     cached-line line>> swap f
     CTLineGetOffsetForStringIndex ;
 
+M: core-text-renderer font-metrics ( font -- metrics )
+    cache-font-metrics ;
+
 M: core-text-renderer line-metrics ( font string -- metrics )
     [ " " line-metrics clone 0 >>width ]
     [ cached-line metrics>> ]

basis/ui/text/text.factor

@@ -52,6 +52,8 @@ M: array text-dim
 
 : text-height ( font text -- h ) text-dim second ;
 
+HOOK: font-metrics font-renderer ( font -- metrics )
+
 HOOK: line-metrics font-renderer ( font string -- metrics )
 
 GENERIC: draw-text ( font text -- )