diff options
Diffstat (limited to 'src/XUtil.hsc')
| -rw-r--r-- | src/XUtil.hsc | 108 |
1 files changed, 35 insertions, 73 deletions
diff --git a/src/XUtil.hsc b/src/XUtil.hsc index b736c9c..21dcf3e 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -2,8 +2,8 @@ ----------------------------------------------------------------------------- -- | -- Module : XUtil --- Copyright : (C) 2007 Andrea Rossato --- (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- Copyright : (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- (C) 2007 Andrea Rossato -- License : BSD3 -- -- Maintainer : jao@gnu.org @@ -20,20 +20,17 @@ module XUtil , textExtents , textWidth , printString - , initColor , newWindow , nextEvent' , readFileSafe , hGetLineSafe , io , fi - , withColors - , DynPixel(..) ) where import Control.Concurrent import Control.Monad.Trans -import Data.IORef +import Control.Exception (SomeException, handle) import Foreign -- import Foreign.C.Types import Graphics.X11.Xlib hiding (textExtents, textWidth) @@ -51,10 +48,12 @@ import qualified System.IO as UTF8 (readFile,hGetLine) #endif #if defined XFT import Data.List -import Graphics.X11.Xft +import MinXft import Graphics.X11.Xrender #endif +import ColorCache + readFileSafe :: FilePath -> IO String #if defined XFT || defined UTF8 readFileSafe = UTF8.readFile @@ -73,11 +72,11 @@ hGetLineSafe = hGetLine data XFont = Core FontStruct | Utf8 FontSet #ifdef XFT - | Xft XftFont + | Xft AXftFont #endif --- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend --- Example: 'xft:Sans-10' +-- | When initFont gets a font name that starts with 'xft:' it switchs +-- to the Xft backend Example: 'xft:Sans-10' initFont :: Display ->String -> IO XFont initFont d s = #ifdef XFT @@ -92,33 +91,38 @@ initFont d s = fmap Core $ initCoreFont d s #endif +miscFixedFont :: String +miscFixedFont = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. initCoreFont :: Display -> String -> IO FontStruct initCoreFont d s = do - f <- catch getIt fallBack + f <- handle fallBack getIt addFinalizer f (freeFont d f) return f - where getIt = loadQueryFont d s - fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + where getIt = loadQueryFont d s + fallBack :: SomeException -> IO FontStruct + fallBack = const $ loadQueryFont d miscFixedFont -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. initUtf8Font :: Display -> String -> IO FontSet initUtf8Font d s = do setupLocale - (_,_,f) <- catch getIt fallBack + (_,_,f) <- handle fallBack getIt addFinalizer f (freeFontSet d f) return f - where getIt = createFontSet d s - fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + where getIt = createFontSet d s + fallBack :: SomeException -> IO ([String], String, FontSet) + fallBack = const $ createFontSet d miscFixedFont #ifdef XFT -initXftFont :: Display -> String -> IO XftFont +initXftFont :: Display -> String -> IO AXftFont initXftFont d s = do setupLocale - f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s) - addFinalizer f (xftFontClose d f) + f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s) + addFinalizer f (closeAXftFont d f) return f #endif @@ -127,7 +131,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 <- xftTextExtents dpy xftdraw s + gi <- xftTxtExtents dpy xftdraw s return $ xglyphinfo_xOff gi #endif @@ -142,8 +146,8 @@ textExtents (Utf8 fs) s = do return (ascent, descent) #ifdef XFT textExtents (Xft xftfont) _ = do - ascent <- fi `fmap` xftfont_ascent xftfont - descent <- fi `fmap` xftfont_descent xftfont + ascent <- fi `fmap` xft_ascent xftfont + descent <- fi `fmap` xft_descent xftfont return (ascent, descent) #endif @@ -163,59 +167,17 @@ 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) gc fc bc x y s = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen - withColors dpy [bc] $ \[bcolor] -> do - (a,d) <- textExtents fs s - gi <- xftTextExtents dpy font s - setForeground dpy gc bcolor - fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) - (y - fi (a + d)) - (fi $ xglyphinfo_xOff gi) - (fi $ 4 + a + d) - withXftDraw dpy drw visual colormap $ - \draw -> withXftColorName dpy visual colormap fc $ - \color -> xftDrawString draw color font x (y - 2) s +printString dpy drw fs@(Xft font) _ fc bc x y s = do + (a,d) <- textExtents fs s + gi <- xftTxtExtents dpy font 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) #endif -data DynPixel = DynPixel { allocated :: Bool - , pixel :: Pixel - } - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -initColor :: Display -> String -> IO DynPixel -initColor dpy c = (initColor' dpy c) `catch` - (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) - -type ColorCache = [(String, Color)] -{-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] - -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache - -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c - -initColor' :: Display -> String -> IO DynPixel -initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) - cached_color <- getCachedColor c - c' <- case cached_color of - Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c - putCachedColor c c'' - return c'' - return $ DynPixel True (color_pixel c') - -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a -withColors d cs f = do - ps <- mapM (io . initColor d) cs - f $ map pixel ps -- | Creates a window with the attribute override_redirect set to True. -- Windows Managers should not touch this kind of windows. |