Support XFT multiple fonts

3 files changed, 101 insertions, 12 deletions

diff --git a/readme.md b/readme.md
index 2ddfb41..91be262 100644
--- a/readme.md
+++ b/readme.md
@@ -124,6 +124,10 @@ Otherwise, you'll need to install them yourself.
 
         font = "xft:Times New Roman-10:italic"
 
+     Or to have fallback fonts, just separate them by commas:
+
+        font = "xft:Open Sans:size=9,WenQuanYi Zen Hei:size=9"
+
 `with_mpd`
 :    Enables support for the [MPD] daemon. Requires the [libmpd] package.
 
diff --git a/src/MinXft.hsc b/src/MinXft.hsc
index 327e95e..3d3aadf 100644
--- a/src/MinXft.hsc
+++ b/src/MinXft.hsc
@@ -26,13 +26,18 @@ module MinXft ( AXftColor
               , freeAXftColor
               , withAXftDraw
               , drawXftString
+              , drawXftString'
               , drawXftRect
               , openAXftFont
               , closeAXftFont
               , xftTxtExtents
+              , xftTxtExtents'
               , xft_ascent
+              , xft_ascent'
               , xft_descent
+              , xft_descent'
               , xft_height
+              , xft_height'
               )
 
 where
@@ -45,6 +50,7 @@ import Foreign
 import Foreign.C.Types
 import Foreign.C.String
 import Codec.Binary.UTF8.String as UTF8
+import Data.Char (ord)
 
 #include <X11/Xft/Xft.h>
 
@@ -73,12 +79,21 @@ newtype AXftFont = AXftFont (Ptr AXftFont)
 xft_ascent :: AXftFont -> IO Int
 xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent}
 
+xft_ascent' :: [AXftFont] -> IO Int
+xft_ascent' = (fmap maximum) . (mapM xft_ascent)
+
 xft_descent :: AXftFont -> IO Int
 xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent}
 
+xft_descent' :: [AXftFont] -> IO Int
+xft_descent' = (fmap maximum) . (mapM xft_descent)
+
 xft_height :: AXftFont -> IO Int
 xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height}
 
+xft_height' :: [AXftFont] -> IO Int
+xft_height' = (fmap maximum) . (mapM xft_height)
+
 foreign import ccall "XftTextExtentsUtf8"
   cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()
 
@@ -90,6 +105,12 @@ xftTxtExtents d f string =
       cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph
       peek cglyph
 
+xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo
+xftTxtExtents' d fs string = do  
+    chunks <- getChunks d fs string
+    let (_, _, gi, _, _) = last chunks
+    return gi
+
 foreign import ccall "XftFontOpenName"
   c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont
 
@@ -101,6 +122,14 @@ openAXftFont dpy screen name =
 foreign import ccall "XftFontClose"
   closeAXftFont :: Display -> AXftFont -> IO ()
 
+foreign import ccall "XftCharExists"
+  cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool)
+
+xftCharExists :: Display -> AXftFont -> Char -> IO Bool
+xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c)
+  where
+    bool 0 = False
+    bool _ = True
 -- Drawing
 
 fi :: (Integral a, Num b) => a -> b
@@ -111,6 +140,9 @@ newtype AXftDraw = AXftDraw (Ptr AXftDraw)
 foreign import ccall "XftDrawCreate"
   c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw
 
+foreign import ccall "XftDrawDisplay"
+  c_xftDrawDisplay :: AXftDraw -> IO Display
+
 foreign import ccall "XftDrawDestroy"
   c_xftDrawDestroy :: AXftDraw -> IO ()
 
@@ -130,6 +162,49 @@ drawXftString d c f x y string =
     withArrayLen (map fi (UTF8.encode string))
       (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len))
 
+drawXftString' :: (Integral a1, Integral a) =>
+                  AXftDraw -> AXftColor -> [AXftFont] -> a -> a1 -> String -> IO ()
+drawXftString' d c fs x y string = do
+    display <- c_xftDrawDisplay d
+    chunks <- getChunks display fs string
+    mapM_ (\(f, s, gi, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks
+
+-- Split string and determine fonts/offsets for individual parts
+getChunks disp fts str = do
+    chunks <- getFonts disp fts str
+    getOffsets disp (XGlyphInfo 0 0 0 0 0 0) chunks
+  where
+    -- Split string and determine fonts for individual parts
+    getFonts _ [] _ = return []
+    getFonts _ _ [] = return []
+    getFonts _ [ft] str = return [(ft, str)]
+    getFonts disp fonts@(ft:fts) str = do
+        -- Determine which glyph can be rendered by current font
+        glyphs <- mapM (xftCharExists disp ft) str
+        -- Split string into parts that can/cannot be rendered
+        let splits = split (runs glyphs) str
+        -- Determine which font to render each chunk with
+        concat `fmap` mapM (getFont disp fonts) splits
+
+    -- Determine fonts for substrings
+    getFont _ [ft] (_, str) = return [(ft, str)] -- Last font, use it
+    getFont _ (ft:fts) (True, str) = return [(ft, str)] -- Current font can render this substring
+    getFont disp (ft:fts) (False, str) = getFonts disp fts str -- Fallback to next font
+
+    -- Helpers
+    runs [] = []
+    runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t
+    split [] _ = []
+    split ((x, c):xs) str = let (h, t) = splitAt c str in (x, h) : split xs t
+
+    -- Determine coordinates for chunks using extents
+    getOffsets disp _ [] = return []
+    getOffsets disp (XGlyphInfo w h x y xo yo) ((f, s):chunks) = do
+        (XGlyphInfo w' h' x' y' xo' yo') <- xftTxtExtents disp f s
+        let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo')
+        rest <- getOffsets disp gi chunks
+        return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest
+
 foreign import ccall "XftDrawRect"
   cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()
 
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index b1e885c..b1611d6 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -72,7 +72,7 @@ hGetLineSafe = hGetLine
 data XFont = Core FontStruct
            | Utf8 FontSet
 #ifdef XFT
-           | Xft  AXftFont
+           | Xft  [AXftFont]
 #endif
 
 -- | When initFont gets a font name that starts with 'xft:' it switchs
@@ -118,12 +118,22 @@ initUtf8Font d s = do
             fallBack = const $ createFontSet d miscFixedFont
 
 #ifdef XFT
-initXftFont :: Display -> String -> IO AXftFont
+initXftFont :: Display -> String -> IO [AXftFont]
 initXftFont d s = do
   setupLocale
-  f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s)
-  addFinalizer f (closeAXftFont d f)
-  return f
+  let fontNames = wordsBy (== ',') (drop 4 s)
+  fonts <- mapM openFont fontNames
+  return fonts
+  where 
+    openFont fontName = do
+        f <- openAXftFont d (defaultScreenOfDisplay d) fontName
+        addFinalizer f (closeAXftFont d f)
+        return f
+    wordsBy p str = case dropWhile p str of
+                        ""   -> []
+                        str' -> w : wordsBy p str''
+                                where
+                                    (w, str'') = break p str'
 #endif
 
 textWidth :: Display -> XFont -> String -> IO Int
@@ -131,7 +141,7 @@ textWidth _   (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
 textWidth _   (Core fs) s = return $ fi $ Xlib.textWidth fs s
 #ifdef XFT
 textWidth dpy (Xft xftdraw) s = do
-    gi <- xftTxtExtents dpy xftdraw s
+    gi <- xftTxtExtents' dpy xftdraw s
     return $ xglyphinfo_xOff gi
 #endif
 
@@ -145,9 +155,9 @@ textExtents (Utf8 fs) s = do
       descent = fi $ rect_height rl + (fi $ rect_y rl)
   return (ascent, descent)
 #ifdef XFT
-textExtents (Xft xftfont) _ = do
-  ascent  <- fi `fmap` xft_ascent  xftfont
-  descent <- fi `fmap` xft_descent xftfont
+textExtents (Xft xftfonts) _ = do
+  ascent  <- fi `fmap` xft_ascent'  xftfonts
+  descent <- fi `fmap` xft_descent' xftfonts
   return (ascent, descent)
 #endif
 
@@ -167,15 +177,15 @@ printString d p (Utf8 fs) gc fc bc x y s =
       io $ wcDrawImageString d p fs gc x y s
 
 #ifdef XFT
-printString dpy drw fs@(Xft font) _ fc bc x y s = do
+printString dpy drw fs@(Xft fonts) _ fc bc x y s = do
   (a,d)  <- textExtents fs s
-  gi <- xftTxtExtents dpy font s
+  gi <- xftTxtExtents' dpy fonts s
   withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
     (drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi))
                           (y - (a + d) + 1)
                           (xglyphinfo_xOff gi)
                           (a + d)) >>
-    (drawXftString draw fc' font x (y - 2) s)
+    (drawXftString' draw fc' fonts x (y - 2) s)
 #endif