diff options
| -rw-r--r-- | readme.md | 4 | ||||
| -rw-r--r-- | src/MinXft.hsc | 75 | ||||
| -rw-r--r-- | src/XUtil.hsc | 34 |
3 files changed, 101 insertions, 12 deletions
@@ -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 |