Add Font layer supporting an Xft backend. Make Tabbed.hs a user of this layer.

XMonad/Layout/Tabbed.hs

@@ -37,6 +37,7 @@ import qualified XMonad.StackSet as W
 import XMonad.Util.NamedWindows
 import XMonad.Util.Invisible
 import XMonad.Util.XUtils
+import XMonad.Util.Font
 
 -- $usage
 -- You can use this module with the following in your configuration file:
@@ -96,7 +97,7 @@ defaultTConf =
 data TabState =
     TabState { tabsWindows :: [(Window,Window)]
              , scr         :: Rectangle
-             , fontS       :: FontStruct -- FontSet
+             , font        :: XMonadFont
     }
 
 data Tabbed s a =
@@ -125,7 +126,7 @@ doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do
                                    tws <- createTabs conf sc ws
                                    return (ts {scr = sc, tabsWindows = zip tws ws})
   mapM_ showWindow $ map fst $ tabsWindows st
-  mapM_ (updateTab ishr conf (fontS st) width) $ tabsWindows st
+  mapM_ (updateTab ishr conf (font st) width) $ tabsWindows st
   return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) ishr conf))
 
 handleMess :: Shrinker s => Tabbed s Window -> SomeMessage -> X (Maybe (Tabbed s Window))
@@ -133,29 +134,39 @@ handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) ishr conf) m
     | Just e <- fromMessage m :: Maybe Event = handleEvent ishr conf st e     >> return Nothing
     | Just Hide             == fromMessage m = mapM_ hideWindow (map fst tws) >> return Nothing
     | Just ReleaseResources == fromMessage m = do mapM_ deleteWindow $ map fst tws
-                                                  releaseFont (fontS st)
+                                                  releaseXMF (font st)
                                                   return $ Just $ Tabbed (I Nothing) ishr conf
 handleMess _ _  = return Nothing
 
 handleEvent :: Shrinker s => s -> TConf -> TabState -> Event -> X ()
 -- button press
-handleEvent ishr conf (TabState    {tabsWindows = tws,   scr          = screen, fontS         = fs })
+handleEvent ishr conf (TabState    {tabsWindows = tws,   scr          = screen, font         = fs }) 
                       (ButtonEvent {ev_window   = thisw, ev_subwindow = thisbw, ev_event_type = t  })
     | t == buttonPress, tl <- map fst tws, thisw `elem` tl || thisbw `elem` tl  = do
   case lookup thisw tws of
     Just x  -> do focus x
                   updateTab ishr conf fs width (thisw, x)
     Nothing -> return ()
-    where width = rect_width screen `div` fromIntegral (length tws)
+    where
+      width = rect_width screen`div` fromIntegral (length tws)
+
+handleEvent ishr conf (TabState {tabsWindows = tws,   scr           = screen, font = fs }) 
+                      (AnyEvent {ev_window   = thisw, ev_event_type = t                 })
+-- expose
+    | thisw `elem` (map fst tws) && t == expose         = do
+  updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws)
+    where
+      width = rect_width screen`div` fromIntegral (length tws)
+
 -- propertyNotify
-handleEvent ishr conf (TabState      {tabsWindows = tws, scr = screen, fontS = fs })
+handleEvent ishr conf (TabState      {tabsWindows = tws, scr = screen, font = fs }) 
                       (PropertyEvent {ev_window   = thisw })
     | thisw `elem` (map snd tws) = do
   let tabwin = (fst $ fromJust $ find ((== thisw) . snd) tws, thisw)
   updateTab ishr conf fs width tabwin
     where width = rect_width screen `div` fromIntegral (length tws)
 -- expose
-handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs })
+handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, font = fs }) 
                       (ExposeEvent {ev_window   = thisw })
     | thisw `elem` (map fst tws) = do
   updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws)
@@ -164,7 +175,7 @@ handleEvent _ _ _ _ =  return ()
 
 initState :: TConf -> Rectangle -> [Window] -> X TabState
 initState conf sc ws = do
-  fs  <- initFont (fontName conf)
+  fs  <- initXMF (fontName conf)
   tws <- createTabs conf sc ws
   return $ TabState (zip tws ws) sc fs
 
@@ -180,7 +191,7 @@ createTabs c (Rectangle x y wh ht) owl@(ow:ows) = do
   ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows
   return (w:ws)
 
-updateTab :: Shrinker s => s -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X ()
+updateTab :: Shrinker s => s -> TConf -> XMonadFont -> Dimension -> (Window,Window) -> X ()
 updateTab ishr c fs wh (tabw,ow) = do
   nw <- getName ow
   let ht                   = fromIntegral $ tabSize c :: Dimension
@@ -190,22 +201,26 @@ updateTab ishr c fs wh (tabw,ow) = do
   (bc',borderc',tc') <- focusColor ow
                            (inactiveColor c, inactiveBorderColor c, inactiveTextColor c)
                            (activeColor   c, activeBorderColor   c, activeTextColor   c)
-  let s    = shrinkIt ishr
+  dpy <- asks display
-      name = shrinkWhile s (\n -> textWidth fs n >
+  let s = shrinkIt ishr
-                            fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
+  name <- shrinkWhile s (\n -> do
+			   size <- io $ textWidthXMF dpy fs n
+			   return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
   paintAndWrite tabw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name
 
 shrink :: TConf -> Rectangle -> Rectangle
 shrink c (Rectangle x y w h) =
     Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c))
 
-shrinkWhile :: (String -> [String]) -> (String -> Bool) -> String -> String
+shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String
 shrinkWhile sh p x = sw $ sh x
-    where sw [n] = n
+    where sw [n] = return n
-          sw [] = ""
+          sw [] = return ""
-          sw (n:ns) | p n = sw ns
+          sw (n:ns) = do
-                    | otherwise = n
+	                cond <- p n
-
+			if cond
+			  then sw ns
+			  else return n
 
 data CustomShrink = CustomShrink
 instance Show CustomShrink where show _ = ""

XMonad/Prompt.hs

@@ -46,7 +46,7 @@ import Graphics.X11.Xlib.Extras
 import XMonad  hiding (config, io)
 import XMonad.Operations (initColor)
 import qualified XMonad.StackSet as W
-import XMonad.Util.XUtils
+import XMonad.Util.Font
 import XMonad.Util.XSelection (getSelection)
 
 import Control.Arrow ((***),(&&&))
@@ -169,12 +169,12 @@ mkXPrompt t conf compl action = do
   gc <- liftIO $ createGC d w
   liftIO $ setGraphicsExposures d gc False
   (hist,h) <- liftIO $ readHistory
-  fs <- initFont (font conf)
+  fs <- initCoreFont (font conf)
   liftIO $ setFont d gc $ fontFromFontStruct fs
   let st = initState d rw w s compl gc fs (XPT t) hist conf
   st' <- liftIO $ execStateT runXP st
 
-  releaseFont fs
+  releaseCoreFont fs
   liftIO $ freeGC d gc
   liftIO $ hClose h
   when (command st' /= "") $ do
@@ -445,8 +445,8 @@ printPrompt drw = do
                       in (prt ++ a, [head b], tail b)
       ht = height c
       (fsl,psl) = (textWidth fs *** textWidth fs) (f,p)
-      (_,asc,desc,_) = textExtents fs str
+  (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) (Left fs) str
-      y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc
+  let y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc
       x = (asc + desc) `div` 2
   fgcolor <- io $ initColor d $ fgColor c
   bgcolor <- io $ initColor d $ bgColor c
@@ -511,9 +511,8 @@ getComplWinDim compl = do
       (x,y) = case position c of
                 Top -> (0,ht)
                 Bottom -> (0, (0 + rem_height - actual_height))
-
+  (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) (Left fs) $ head compl
-  let (_,asc,desc,_) = textExtents fs $ head compl
+  let yp = fi $ (ht + fi (asc - desc)) `div` 2
-      yp = fi $ (ht + fi (asc - desc)) `div` 2
       xp = (asc + desc) `div` 2
       yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]
       xx = take (fi columns) [xp,(xp + max_compl_len)..]

XMonad/Util/Font.hs

@@ -0,0 +1,142 @@
+----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Util.Font
+-- Copyright   :  (c) 2007 Andrea Rossato
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  andrea.rossato@unibz.it
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A module for abstracting a font facility over Core fonts and Xft
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Util.Font  (
+                             -- * Usage:
+                             -- $usage
+			     XMonadFont
+                             , initXMF
+                             , releaseXMF
+                             , initCoreFont
+                             , releaseCoreFont
+                             , Align (..)
+                             , stringPosition
+			     , textWidthXMF
+			     , textExtentsXMF
+			     , printStringXMF
+			     , stringToPixel
+                            ) where
+
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xft
+import Graphics.X11.Xrender
+
+import Control.Monad.Reader
+import Data.List
+import XMonad
+import Foreign
+import XMonad.Operations
+
+-- Hide the Core Font/Xft switching here
+type XMonadFont = Either FontStruct XftFont
+
+-- $usage
+-- See Tabbed or Prompt for usage examples
+
+-- | Get the Pixel value for a named color: if an invalid name is
+-- given the black pixel will be returned.
+stringToPixel :: String -> X Pixel
+stringToPixel s = do
+  d <- asks display
+  io $ catch (getIt d) (fallBack d)
+    where getIt    d = initColor d s
+          fallBack d = const $ return $ blackPixel d (defaultScreen d)
+
+
+-- | Given a fontname returns the font structure. If the font name is
+--  not valid the default font will be loaded and returned.
+initCoreFont :: String -> X FontStruct
+initCoreFont s = do
+  d <- asks display
+  io $ catch (getIt d) (fallBack d)
+      where getIt    d = loadQueryFont d s
+            fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+
+releaseCoreFont :: FontStruct -> X ()
+releaseCoreFont fs = do
+  d <- asks display
+  io $ freeFont d fs
+
+-- | When initXMF gets a font name that starts with 'xft:' it switchs to the Xft backend
+-- Example: 'xft: Sans-10'
+initXMF :: String -> X XMonadFont
+initXMF s =
+  if xftPrefix `isPrefixOf` s then
+     do
+       dpy <- asks display
+       xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s)
+       return (Right xftdraw)
+  else
+      (initCoreFont s >>= (return . Left))
+  where xftPrefix = "xft:"
+
+releaseXMF :: XMonadFont -> X ()
+releaseXMF (Left fs) = releaseCoreFont fs
+releaseXMF (Right xftfont) = do
+  dpy <- asks display
+  io $ xftFontClose dpy xftfont
+
+textWidthXMF :: Display -> XMonadFont -> String -> IO Int
+textWidthXMF _   (Left fs) s = return $ fi $ textWidth fs s
+textWidthXMF dpy (Right xftdraw) s = do
+    gi <- xftTextExtents dpy xftdraw s
+    return $ xglyphinfo_width gi
+
+textExtentsXMF :: Display -> XMonadFont -> String -> IO (FontDirection,Int32,Int32,CharStruct)
+textExtentsXMF _ (Left fs) s = return $ textExtents fs s
+textExtentsXMF _ (Right xftfont) _ = do
+    ascent <- xftfont_ascent xftfont
+    descent <- xftfont_descent xftfont
+    return (error "Font direction touched", fi ascent, fi descent, error "Font overall size touched")
+
+-- | String position
+data Align = AlignCenter | AlignRight | AlignLeft
+
+-- | Return the string x and y 'Position' in a 'Rectangle', given a
+-- 'FontStruct' and the 'Align'ment
+stringPosition :: XMonadFont -> Rectangle -> Align -> String -> X (Position,Position)
+stringPosition fs (Rectangle _ _ w h) al s = do
+  dpy <- asks display
+  width <- io $ textWidthXMF dpy fs s
+  (_,a,d,_) <- io $ textExtentsXMF dpy fs s
+  let y         = fi $ ((h - fi (a + d)) `div` 2) + fi a;
+      x         = case al of
+                     AlignCenter -> fi (w `div` 2) - fi (width `div` 2)
+                     AlignLeft   -> 1
+                     AlignRight  -> fi (w - (fi width + 1));
+  return (x,y)
+
+
+printStringXMF :: Display -> Drawable -> XMonadFont -> GC -> String -> String
+            -> Position -> Position -> String  -> X ()
+printStringXMF d p (Left fs) gc fc bc x y s = do
+	 io $ setFont d gc $ fontFromFontStruct fs
+         [fc',bc'] <- mapM stringToPixel [fc,bc]
+	 io $ setForeground   d gc fc'
+	 io $ setBackground   d gc bc'
+	 io $ drawImageString d p gc x y s
+
+printStringXMF dpy drw (Right font) _ fc _ x y s = do
+  let screen = defaultScreenOfDisplay dpy;
+      colormap = defaultColormapOfScreen screen;
+      visual = defaultVisualOfScreen screen;
+  io $ withXftDraw dpy drw visual colormap $
+	 \draw -> withXftColorName dpy visual colormap fc $
+		    \color -> xftDrawString draw color font x y s
+
+
+-- | Short-hand for 'fromIntegral'
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral

XMonad/Util/XUtils.hs

@@ -15,18 +15,14 @@
 module XMonad.Util.XUtils  ( 
                              -- * Usage:
                              -- $usage
-                             stringToPixel
+                               averagePixels
-                             , averagePixels
-                             , initFont
-                             , releaseFont
                              , createNewWindow
                              , showWindow
                              , hideWindow
                              , deleteWindow
                              , paintWindow
-                             , Align (..)
-                             , stringPosition
                              , paintAndWrite
+			     , stringToPixel
                             ) where
 
 
@@ -36,11 +32,10 @@ import Graphics.X11.Xlib.Extras
 import Control.Monad.Reader
 import Data.Maybe
 import XMonad
-import XMonad.Operations
+import XMonad.Util.Font
 
 -- $usage
--- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" for usage
+-- See Tabbed or DragPane for usage examples
--- examples
 
 -- | Get the Pixel value for a named color: if an invalid name is
 -- given the black pixel will be returned.
@@ -60,21 +55,6 @@ averagePixels p1 p2 f =
        let mn x1 x2 = round (fromIntegral x1 * f + fromIntegral x2 * (1-f))
        Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0)
        return p
-
--- | Given a fontname returns the fonstructure. If the font name is
---  not valid the default font will be loaded and returned.
-initFont :: String -> X FontStruct
-initFont s = do
-  d <- asks display
-  io $ catch (getIt d) (fallBack d)
-      where getIt    d = loadQueryFont d s
-            fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-
-releaseFont :: FontStruct -> X ()
-releaseFont fs = do
-  d <- asks display
-  io $ freeFont d fs
-
 -- | Create a simple window given a rectangle. If Nothing is given
 -- only the exposureMask will be set, otherwise the Just value.
 -- Use 'showWindow' to map and hideWindow to unmap.
@@ -118,24 +98,9 @@ paintWindow :: Window     -- ^ The window where to draw
 paintWindow w wh ht bw c bc =
     paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing
 
--- | String position
-data Align = AlignCenter | AlignRight | AlignLeft
-
--- | Return the string x and y 'Position' in a 'Rectangle', given a
--- 'FontStruct' and the 'Align'ment
-stringPosition :: FontStruct -> Rectangle -> Align -> String -> (Position,Position)
-stringPosition fs (Rectangle _ _ w h) al s = (x,y)
-    where width     = textWidth   fs s
-          (_,a,d,_) = textExtents fs s
-          y         = fi $ ((h - fi (a + d)) `div` 2) + fi a
-          x         = case al of 
-                        AlignCenter -> fi (w `div` 2) - fi (width `div` 2)
-                        AlignLeft   -> 1
-                        AlignRight  -> fi (w - (fi width + 1))
-
 -- | Fill a window with a rectangle and a border, and write a string at given position
 paintAndWrite :: Window     -- ^ The window where to draw 
-              -> FontStruct -- ^ The FontStruct
+              -> XMonadFont -- ^ XMonad Font for drawing
               -> Dimension  -- ^ Window width
               -> Dimension  -- ^ Window height 
               -> Dimension  -- ^ Border width
@@ -146,47 +111,36 @@ paintAndWrite :: Window     -- ^ The window where to draw
               -> Align      -- ^ String 'Align'ment
               -> String     -- ^ String to be printed
               -> X ()
-paintAndWrite w fs wh ht bw bc borc ffc fbc al str =
+paintAndWrite w fs wh ht bw bc borc ffc fbc al str = do
-    paintWindow' w r bw bc borc ms
+    (x,y) <- stringPosition fs (Rectangle 0 0 wh ht) al str
+    paintWindow' w (Rectangle x y wh ht) bw bc borc ms
     where ms    = Just (fs,ffc,fbc,str)
-          r     = Rectangle x y wh ht
-          (x,y) = stringPosition fs (Rectangle 0 0 wh ht) al str
 
 -- This stuf is not exported
 
-paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (FontStruct,String,String,String) -> X ()
+paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (XMonadFont,String,String,String) -> X ()
 paintWindow' win (Rectangle x y wh ht) bw color b_color str = do
   d  <- asks display
   p  <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d)
   gc <- io $ createGC d p
   -- draw
   io $ setGraphicsExposures d gc False
-  [c',bc'] <- mapM stringToPixel [color,b_color]
+  [color',b_color'] <- mapM stringToPixel [color,b_color]
   -- we start with the border
-  io $ setForeground d gc bc'
+  io $ setForeground d gc b_color'
   io $ fillRectangle d p gc 0 0 wh ht
   -- and now again
-  io $ setForeground d gc c'
+  io $ setForeground d gc color'
   io $ fillRectangle d p gc (fi bw) (fi bw) ((wh - (bw * 2))) (ht - (bw * 2))
   when (isJust str) $ do
-    let (fs,fc,bc,s) = fromJust str
+    let (xmf,fc,bc,s) = fromJust str
-    io $ setFont d gc $ fontFromFontStruct fs
+    printStringXMF d p xmf gc fc bc x y s
-    printString d p gc fc bc x y s
   -- copy the pixmap over the window
   io $ copyArea      d p win gc 0 0 wh ht 0 0
   -- free the pixmap and GC
   io $ freePixmap    d p
   io $ freeGC        d gc
 
--- | Prints a string on a 'Drawable'
-printString :: Display -> Drawable -> GC -> String -> String
-            -> Position -> Position -> String  -> X ()
-printString d drw gc fc bc x y s = do
-  [fc',bc'] <- mapM stringToPixel [fc,bc]
-  io $ setForeground   d gc fc'
-  io $ setBackground   d gc bc'
-  io $ drawImageString d drw gc x y s
-
 -- | Short-hand for 'fromIntegral'
 fi :: (Integral a, Num b) => a -> b
 fi = fromIntegral

xmonad-contrib.cabal

@@ -26,7 +26,7 @@ library
     else
         build-depends: base < 3
 
-    build-depends:      mtl, unix, X11==1.3.0.20071111, xmonad==0.4
+    build-depends:      mtl, unix, X11==1.3.0.20071111, xmonad==0.4, utf8-string, X11-xft
     ghc-options:        -Wall -Werror
     exposed-modules:    Documentation
                         XMonad.Actions.Commands
@@ -106,6 +106,7 @@ library
                         XMonad.Util.Dmenu
                         XMonad.Util.Dzen
                         XMonad.Util.EZConfig
+                        XMonad.Util.Font
                         XMonad.Util.Invisible
                         XMonad.Util.NamedWindows
                         XMonad.Util.Run