diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ColorCache.hs | 110 | ||||
| -rw-r--r-- | src/MinXft.hsc | 139 | ||||
| -rw-r--r-- | src/Window.hs | 22 | ||||
| -rw-r--r-- | src/XUtil.hsc | 108 | ||||
| -rw-r--r-- | src/Xmobar.hs | 55 |
5 files changed, 329 insertions, 105 deletions
diff --git a/src/ColorCache.hs b/src/ColorCache.hs new file mode 100644 index 0000000..6313a98 --- /dev/null +++ b/src/ColorCache.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: ColorCache +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 00:27 +-- +-- +-- Caching X colors +-- +------------------------------------------------------------------------------ + +#if defined XFT + +module ColorCache(withColors, withDrawingColors) where + +import MinXft +import Graphics.X11.Xlib + +#else +module ColorCache(withColors) where + +#endif + +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Exception (SomeException, handle) + +data DynPixel = DynPixel Bool Pixel + +initColor :: Display -> String -> IO DynPixel +initColor dpy c = handle black $ (initColor' dpy c) + where + black :: SomeException -> IO DynPixel + black = (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 (liftIO . initColor d) cs + f $ map (\(DynPixel _ pixel) -> pixel) ps + +#ifdef XFT + +type AXftColorCache = [(String, AXftColor)] +{-# NOINLINE xftColorCache #-} +xftColorCache :: IORef AXftColorCache +xftColorCache = unsafePerformIO $ newIORef [] + +getXftCachedColor :: String -> IO (Maybe AXftColor) +getXftCachedColor name = lookup name `fmap` readIORef xftColorCache + +putXftCachedColor :: String -> AXftColor -> IO () +putXftCachedColor name cptr = + modifyIORef xftColorCache $ \c -> (name, cptr) : c + +initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor' d v cm c = do + cc <- getXftCachedColor c + c' <- case cc of + Just col -> return col + _ -> do c'' <- mallocAXftColor d v cm c + putXftCachedColor c c'' + return c'' + return c' + +initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) + where + black :: SomeException -> IO AXftColor + black = (const $ initAXftColor' d v cm "black") + +withDrawingColors :: -- MonadIO m => + Display -> Drawable -> String -> String + -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () +withDrawingColors dpy drw fc bc f = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + fc' <- initAXftColor dpy visual colormap fc + bc' <- initAXftColor dpy visual colormap bc + withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' +#endif diff --git a/src/MinXft.hsc b/src/MinXft.hsc new file mode 100644 index 0000000..478b94a --- /dev/null +++ b/src/MinXft.hsc @@ -0,0 +1,139 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +------------------------------------------------------------------------------ +-- | +-- Module: MinXft +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007 +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 18:12 +-- +-- +-- Pared down Xft library, based on Graphics.X11.Xft and providing +-- explicit management of XftColors, so that they can be cached. +-- +-- Most of the code is lifted from Clemens's. +-- +------------------------------------------------------------------------------ + +module MinXft ( AXftColor + , AXftDraw + , AXftFont + , mallocAXftColor + , freeAXftColor + , withAXftDraw + , drawXftString + , drawXftRect + , openAXftFont + , closeAXftFont + , xftTxtExtents + , xft_ascent + , xft_descent + , xft_height + ) + +where + +import Graphics.X11 +import Graphics.X11.Xlib.Types +import Graphics.X11.Xrender + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Codec.Binary.UTF8.String as UTF8 + +#include <X11/Xft/Xft.h> + +-- Color Handling + +newtype AXftColor = AXftColor (Ptr AXftColor) + +foreign import ccall "XftColorAllocName" + cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) + +-- this is the missing bit in X11.Xft, not implementable from the +-- outside because XftColor does not export a constructor. +mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +mallocAXftColor d v cm n = do + color <- mallocBytes (#size XftColor) + withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) + return (AXftColor color) + +foreign import ccall "XftColorFree" + freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () + +-- Font handling + +newtype AXftFont = AXftFont (Ptr AXftFont) + +xft_ascent :: AXftFont -> IO Int +xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} + +xft_descent :: AXftFont -> IO Int +xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} + +xft_height :: AXftFont -> IO Int +xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} + +foreign import ccall "XftTextExtentsUtf8" + cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () + +xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo +xftTxtExtents d f string = + withArrayLen (map fi (UTF8.encode string)) $ + \len str_ptr -> alloca $ + \cglyph -> do + cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph + peek cglyph + +foreign import ccall "XftFontOpenName" + c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont + +openAXftFont :: Display -> Screen -> String -> IO AXftFont +openAXftFont dpy screen name = + withCAString name $ + \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname + +foreign import ccall "XftFontClose" + closeAXftFont :: Display -> AXftFont -> IO () + +-- Drawing + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +newtype AXftDraw = AXftDraw (Ptr AXftDraw) + +foreign import ccall "XftDrawCreate" + c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw + +foreign import ccall "XftDrawDestroy" + c_xftDrawDestroy :: AXftDraw -> IO () + +withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a +withAXftDraw d p v c act = do + draw <- c_xftDrawCreate d p v c + a <- act draw + c_xftDrawDestroy draw + return a + +foreign import ccall "XftDrawStringUtf8" + cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () + +drawXftString :: (Integral a1, Integral a) => + AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () +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)) + +foreign import ccall "XftDrawRect" + cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () + +drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => + AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () +drawXftRect draw color x y width height = + cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height) diff --git a/src/Window.hs b/src/Window.hs index 9b0c506..4678046 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -96,8 +96,11 @@ setProperties r c d w srs = do setTextProperty d w "xmobar" wM_CLASS setTextProperty d w "xmobar" wM_NAME - changeProperty32 d w a1 c1 propModeReplace $ map fi $ - getStrutValues r (position c) (getRootWindowHeight srs) + ismapped <- isMapped d w + changeProperty32 d w a1 c1 propModeReplace $ + if ismapped + then map fi $ getStrutValues r (position c) (getRootWindowHeight srs) + else replicate 12 0 changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral @@ -156,11 +159,16 @@ hideWindow d w = do a <- internAtom d "_NET_WM_STRUT_PARTIAL" False c <- internAtom d "CARDINAL" False changeProperty32 d w a c propModeReplace $ replicate 12 0 - unmapWindow d w - sync d False - -showWindow :: Display -> Window -> IO () -showWindow d w = mapWindow d w >> sync d False + unmapWindow d w >> sync d False + +showWindow :: Rectangle -> Config -> Display -> Window -> IO () +showWindow r cfg d w = do + srs <- getScreenInfo d + a <- internAtom d "_NET_WM_STRUT_PARTIAL" False + c <- internAtom d "CARDINAL" False + changeProperty32 d w a c propModeReplace $ map fi $ + getStrutValues r (position cfg) (getRootWindowHeight srs) + mapWindow d w >> sync d False isMapped :: Display -> Window -> IO Bool isMapped d w = fmap ism $ getWindowAttributes d w 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. diff --git a/src/Xmobar.hs b/src/Xmobar.hs index f531cb4..f8db6a5 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -49,6 +49,11 @@ import Runnable import Signal import Window import XUtil +import ColorCache + +#ifdef XFT +import Graphics.X11.Xft +#endif #ifdef DBUS import IPC.DBus @@ -77,6 +82,9 @@ runX xc f = runReaderT f xc -- | Starts the main event loop and threads startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () startLoop xcfg@(XConf _ _ w _ _) sig vs = do +#ifdef XFT + xftInitFtLibrary +#endif tv <- atomically $ newTVar [] _ <- forkIO (checker tv [] vs sig `catch` \(SomeException _) -> void (putStrLn "Thread checker failed")) @@ -132,7 +140,7 @@ checker tvar ov vs signal = do -- | Continuously wait for a signal from a thread or a interrupt handler eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO () -eventLoop tv xc@(XConf d _ w fs cfg) signal = do +eventLoop tv xc@(XConf d r w fs cfg) signal = do typ <- atomically $ takeTMVar signal case typ of Wakeup -> do @@ -148,7 +156,7 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do Hide t -> hide (t*100*1000) Reveal t -> reveal (t*100*1000) - Toggle t -> toggle (t*100*1000) + Toggle t -> toggle t TogglePersistent -> eventLoop tv xc { config = cfg { persistent = not $ persistent cfg } } signal @@ -156,27 +164,27 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do where isPersistent = not $ persistent cfg - hide t | t == 0 = do - when isPersistent $ hideWindow d w - eventLoop tv xc signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc signal + hide t + | t == 0 = + when isPersistent (hideWindow d w) >> eventLoop tv xc signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Hide 0) + eventLoop tv xc signal - reveal t | t == 0 = - if isPersistent - then do - r' <- repositionWin d w fs cfg - showWindow d w - eventLoop tv (XConf d r' w fs cfg) signal - else eventLoop tv xc signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc signal + reveal t + | t == 0 = do + when isPersistent (showWindow r cfg d w) + eventLoop tv xc signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) + eventLoop tv xc signal - toggle t = isMapped d w >>= \b -> if b then hide t else reveal t + toggle t = do + ismapped <- isMapped d w + atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) + eventLoop tv xc signal reposWindow rcfg = do r' <- repositionWin d w fs rcfg @@ -262,7 +270,7 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do let (conf,d) = (config &&& display) r Rectangle _ _ wid ht = rect r totSLen = foldr (\(_,_,len) -> (+) len) 0 sl - valign = (fi ht `div` 2) + (fi (as + ds) `div` 3) + valign = -1 + (fi ht + fi (as + ds)) `div` 2 remWidth = fi wid - fi totSLen offset = case a of C -> (remWidth + offs) `div` 2 @@ -271,8 +279,5 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do (fc,bc) = case break (==',') c of (f,',':b) -> (f, b ) (f, _) -> (f, bgColor conf) - withColors d [bc] $ \[bc'] -> do - io $ setForeground d gc bc' - io $ fillRectangle d dr gc offset 0 (fi l) ht io $ printString d dr fontst gc fc bc offset valign s printStrings dr gc fontst (offs + l) a xs |