From b9bda593908e5972e93fab1f159cb3faae204855 Mon Sep 17 00:00:00 2001 From: Clemens Fruhwirth Date: Fri, 16 Nov 2007 13:06:53 +0100 Subject: Add Font layer supporting an Xft backend. Make Tabbed.hs a user of this layer. darcs-hash:20071116120653-ed0c4-9a8c7fbac69976bbc85701338f89cf085a1f1ddf.gz --- XMonad/Layout/Tabbed.hs | 51 +++++++++++------ XMonad/Prompt.hs | 15 +++-- XMonad/Util/Font.hs | 142 ++++++++++++++++++++++++++++++++++++++++++++++++ XMonad/Util/XUtils.hs | 74 +++++-------------------- xmonad-contrib.cabal | 3 +- 5 files changed, 198 insertions(+), 87 deletions(-) create mode 100644 XMonad/Util/Font.hs diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs index 0e5c496..bbd8526 100644 --- a/XMonad/Layout/Tabbed.hs +++ b/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 - name = shrinkWhile s (\n -> textWidth fs n > - fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + dpy <- asks display + let s = shrinkIt ishr + 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 - sw [] = "" - sw (n:ns) | p n = sw ns - | otherwise = n - + where sw [n] = return n + sw [] = return "" + sw (n:ns) = do + cond <- p n + if cond + then sw ns + else return n data CustomShrink = CustomShrink instance Show CustomShrink where show _ = "" diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs index bb4966b..6d1a85e 100644 --- a/XMonad/Prompt.hs +++ b/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 - y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc + (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) (Left fs) str + 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)) - - let (_,asc,desc,_) = textExtents fs $ head compl - yp = fi $ (ht + fi (asc - desc)) `div` 2 + (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) (Left fs) $ head compl + let 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)..] diff --git a/XMonad/Util/Font.hs b/XMonad/Util/Font.hs new file mode 100644 index 0000000..3ef0f7b --- /dev/null +++ b/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 diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs index 0c0682d..98db6d5 100644 --- a/XMonad/Util/XUtils.hs +++ b/XMonad/Util/XUtils.hs @@ -15,18 +15,14 @@ module XMonad.Util.XUtils ( -- * Usage: -- $usage - stringToPixel - , averagePixels - , initFont - , releaseFont + averagePixels , 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 --- examples +-- See Tabbed or DragPane for usage 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 = - paintWindow' w r bw bc borc ms +paintAndWrite w fs wh ht bw bc borc ffc fbc al str = do + (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 - io $ setFont d gc $ fontFromFontStruct fs - printString d p gc fc bc x y s + let (xmf,fc,bc,s) = fromJust str + printStringXMF d p xmf 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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 1d7ab29..d0e933f 100644 --- a/xmonad-contrib.cabal +++ b/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 -- cgit v1.2.3