diff options
Diffstat (limited to 'src/XUtil.hsc')
| -rw-r--r-- | src/XUtil.hsc | 88 |
1 files changed, 28 insertions, 60 deletions
diff --git a/src/XUtil.hsc b/src/XUtil.hsc index b736c9c..7683387 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -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) @@ -55,6 +52,8 @@ import Graphics.X11.Xft import Graphics.X11.Xrender #endif +import ColorCache (withColors) + readFileSafe :: FilePath -> IO String #if defined XFT || defined UTF8 readFileSafe = UTF8.readFile @@ -76,8 +75,8 @@ data XFont = Core FontStruct | Xft XftFont #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,26 +91,31 @@ 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 @@ -163,59 +167,23 @@ 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 +printString dpy drw fs@(Xft font) _ 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 + (a,d) <- textExtents fs s + gi <- xftTextExtents dpy font s + withXftDraw dpy drw visual colormap $ \draw -> + (withXftColorName dpy visual colormap bc $ \color -> + xftDrawRect draw color (x + 1 - fi (xglyphinfo_x gi)) + (y - (a + d) + 1) + (xglyphinfo_xOff gi) + (a + d) + ) >> + (withXftColorName dpy visual colormap fc $ \color -> + xftDrawString draw color 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. |