diff options
author | Jose Antonio Ortega Ruiz <jao@gnu.org> | 2010-12-21 02:36:35 +0100 |
---|---|---|
committer | Jose Antonio Ortega Ruiz <jao@gnu.org> | 2010-12-21 02:36:35 +0100 |
commit | e3853a9cb2a9a2cffa174d1334e2ca8ba610f151 (patch) | |
tree | 13aa04faea320afe85636e23686280386c1c2910 /XUtil.hsc | |
parent | 598bfe5deeff079280e8513c55dc7bda3e8cf9a0 (diff) | |
download | xmobar-e3853a9cb2a9a2cffa174d1334e2ca8ba610f151.tar.gz xmobar-e3853a9cb2a9a2cffa174d1334e2ca8ba610f151.tar.bz2 |
Haskell sources moved to src/ to unclutter toplevel
Diffstat (limited to 'XUtil.hsc')
-rw-r--r-- | XUtil.hsc | 259 |
1 files changed, 0 insertions, 259 deletions
diff --git a/XUtil.hsc b/XUtil.hsc deleted file mode 100644 index d5bb591..0000000 --- a/XUtil.hsc +++ /dev/null @@ -1,259 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : XUtil --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unitn.it --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module XUtil - ( XFont - , initFont - , initCoreFont - , initUtf8Font - , textExtents - , textWidth - , printString - , initColor - , newWindow - , nextEvent' - , readFileSafe - , hGetLineSafe - , io - , fi - , withColors - , DynPixel(..) - ) where - -import Control.Concurrent -import Control.Monad.Trans -import Data.IORef -import Foreign -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import System.Mem.Weak ( addFinalizer ) -import System.Posix.Types (Fd(..)) -import System.IO -#if defined XFT || defined UTF8 -# if __GLASGOW_HASKELL__ < 612 -import Foreign.C -import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) -# else -import qualified System.IO as UTF8 (readFile,hGetLine) -# endif -#endif -#if defined XFT -import Data.List -import Graphics.X11.Xft -import Graphics.X11.Xrender -#endif - -readFileSafe :: FilePath -> IO String -#if defined XFT || defined UTF8 -readFileSafe = UTF8.readFile -#else -readFileSafe = readFile -#endif - -hGetLineSafe :: Handle -> IO String -#if defined XFT || defined UTF8 -hGetLineSafe = UTF8.hGetLine -#else -hGetLineSafe = hGetLine -#endif - --- Hide the Core Font/Xft switching here -data XFont = Core FontStruct - | Utf8 FontSet -#ifdef XFT - | Xft XftFont -#endif - --- | 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 - let xftPrefix = "xft:" in - if xftPrefix `isPrefixOf` s then - fmap Xft $ initXftFont d s - else -#endif -#if defined UTF8 || __GLASGOW_HASKELL__ >= 612 - fmap Utf8 $ initUtf8Font d s -#else - fmap Core $ initCoreFont d s -#endif - --- | 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 - addFinalizer f (freeFont d f) - return f - where getIt = loadQueryFont d s - fallBack = const $ loadQueryFont d "-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. -initUtf8Font :: Display -> String -> IO FontSet -initUtf8Font d s = do - setupLocale - (_,_,f) <- catch getIt fallBack - addFinalizer f (freeFontSet d f) - return f - where getIt = createFontSet d s - fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - -#ifdef XFT -initXftFont :: Display -> String -> IO XftFont -initXftFont d s = do - setupLocale - f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s) - addFinalizer f (xftFontClose d f) - return f -#endif - -textWidth :: Display -> XFont -> String -> IO Int -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 - return $ xglyphinfo_xOff gi -#endif - -textExtents :: XFont -> String -> IO (Int32,Int32) -textExtents (Core fs) s = do - let (_,a,d,_) = Xlib.textExtents fs s - return (a,d) -textExtents (Utf8 fs) s = do - let (_,rl) = wcTextExtents fs s - ascent = fi $ - (rect_y rl) - descent = fi $ rect_height rl + (fi $ rect_y rl) - return (ascent, descent) -#ifdef XFT -textExtents (Xft xftfont) _ = do - ascent <- fi `fmap` xftfont_ascent xftfont - descent <- fi `fmap` xftfont_descent xftfont - return (ascent, descent) -#endif - -printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> String -> IO () -printString d p (Core fs) gc fc bc x y s = do - setFont d gc $ fontFromFontStruct fs - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - setBackground d gc bc' - drawImageString d p gc x y s - -printString d p (Utf8 fs) gc fc bc x y s = - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - setBackground d gc bc' - 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 -#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. -newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window -newWindow dpy scr rw (Rectangle x y w h) o = do - let visual = defaultVisualOfScreen scr - attrmask = cWOverrideRedirect - allocaSetWindowAttributes $ - \attributes -> do - set_override_redirect attributes o - createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) - inputOutput visual attrmask attributes --- | A version of nextEvent that does not block in foreign calls. -nextEvent' :: Display -> XEventPtr -> IO () -nextEvent' d p = do - pend <- pending d - if pend /= 0 - then nextEvent d p - else do - threadWaitRead (Fd fd) - nextEvent' d p - where - fd = connectionNumber d - -io :: MonadIO m => IO a -> m a -io = liftIO - --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8) -#include <locale.h> -foreign import ccall unsafe "locale.h setlocale" - setlocale :: CInt -> CString -> IO CString - -setupLocale :: IO () -setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return () -# else -setupLocale :: IO () -setupLocale = return () -#endif |