diff options
| -rw-r--r-- | src/ColorCache.hs | 64 | ||||
| -rw-r--r-- | src/MinXft.hsc | 139 | ||||
| -rw-r--r-- | src/XUtil.hsc | 42 | ||||
| -rw-r--r-- | src/Xmobar.hs | 7 | ||||
| -rw-r--r-- | xmobar.cabal | 3 |
5 files changed, 220 insertions, 35 deletions
diff --git a/src/ColorCache.hs b/src/ColorCache.hs index 9a76a90..6313a98 100644 --- a/src/ColorCache.hs +++ b/src/ColorCache.hs @@ -7,7 +7,7 @@ -- -- Maintainer: jao@gnu.org -- Stability: unstable --- Portability: portable +-- Portability: unportable -- Created: Mon Sep 10, 2012 00:27 -- -- @@ -15,23 +15,25 @@ -- ------------------------------------------------------------------------------ +#if defined XFT + +module ColorCache(withColors, withDrawingColors) where + +import MinXft +import Graphics.X11.Xlib + +#else module ColorCache(withColors) where -#if defined XFT --- import Graphics.X11.Xft #endif + import Data.IORef -import Graphics.X11.Xlib import System.IO.Unsafe (unsafePerformIO) import Control.Monad.Trans (MonadIO, liftIO) import Control.Exception (SomeException, handle) -data DynPixel = DynPixel { allocated :: Bool - , pixel :: Pixel - } +data DynPixel = DynPixel Bool 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 = handle black $ (initColor' dpy c) where @@ -63,4 +65,46 @@ initColor' dpy c = do withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a withColors d cs f = do ps <- mapM (liftIO . initColor d) cs - f $ map pixel ps + 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/XUtil.hsc b/src/XUtil.hsc index 7683387..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 @@ -48,11 +48,11 @@ 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 (withColors) +import ColorCache readFileSafe :: FilePath -> IO String #if defined XFT || defined UTF8 @@ -72,7 +72,7 @@ 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 @@ -118,11 +118,11 @@ initUtf8Font d s = do 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 @@ -131,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 @@ -146,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 @@ -168,20 +168,14 @@ printString d p (Utf8 fs) gc fc bc x y s = #ifdef XFT printString dpy drw fs@(Xft font) _ fc bc x y s = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen (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) + 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 diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 3d17fad..f8db6a5 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -51,6 +51,10 @@ import Window import XUtil import ColorCache +#ifdef XFT +import Graphics.X11.Xft +#endif + #ifdef DBUS import IPC.DBus #endif @@ -78,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")) diff --git a/xmobar.cabal b/xmobar.cabal index c23aa1f..6fa4576 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -78,7 +78,7 @@ executable xmobar main-is: Main.hs other-modules: Xmobar, Config, Parsers, Commands, Localize, - XUtil, StatFS, Runnable, ColorCache, Window, + XUtil, StatFS, Runnable, ColorCache, Window Plugins, Plugins.CommandReader, Plugins.Date, Plugins.EWMH, Plugins.PipeReader, Plugins.StdinReader, Plugins.XMonadLog, Plugins.Utils, Plugins.Kbd, Plugins.Monitors, @@ -134,6 +134,7 @@ executable xmobar if flag(with_xft) || flag(all_extensions) build-depends: utf8-string == 0.3.*, X11-xft >= 0.2 && < 0.4 + other-modules: MinXft cpp-options: -DXFT if flag(with_utf8) || flag(all_extensions) |