From c84a2e586563cce90f4324eb38bfb2e2207eb7fc Mon Sep 17 00:00:00 2001 From: jao Date: Thu, 22 Nov 2018 01:10:39 +0000 Subject: Wee refactorings --- src/lib/Xmobar.hs | 32 +++---- src/lib/Xmobar/Window.hs | 19 +++- src/lib/Xmobar/XUtil.hs | 194 ++++++++++++++++++++++++++++++++++++++ src/lib/Xmobar/XUtil.hsc | 235 ----------------------------------------------- 4 files changed, 227 insertions(+), 253 deletions(-) create mode 100644 src/lib/Xmobar/XUtil.hs delete mode 100644 src/lib/Xmobar/XUtil.hsc (limited to 'src/lib') diff --git a/src/lib/Xmobar.hs b/src/lib/Xmobar.hs index e4eb4b7..4172780 100644 --- a/src/lib/Xmobar.hs +++ b/src/lib/Xmobar.hs @@ -253,14 +253,14 @@ updateString :: Config -> TVar [String] updateString conf v = do s <- readTVarIO v let l:c:r:_ = s ++ repeat "" - io $ mapM (parseString conf) [l, c, r] + liftIO $ mapM (parseString conf) [l, c, r] updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> IO [([Action], Position, Position)] updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do let (d,fs) = (display &&& fontListS) conf strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] - strLn = io . mapM getCoords + strLn = liftIO . mapM getCoords iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw) getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) @@ -288,46 +288,46 @@ drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask let (c,d) = (config &&& display) r (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r - strLn = io . mapM getWidth + strLn = liftIO . mapM getWidth iconW i = maybe 0 Bitmap.width (lookup i $ iconS r) getWidth (Text s,cl,i,_) = textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw) getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) - p <- io $ createPixmap d w wid ht + p <- liftIO $ createPixmap d w wid ht (defaultDepthOfScreen (defaultScreenOfDisplay d)) #if XFT - when (alpha c /= 255) (io $ drawBackground d p (bgColor c) (alpha c) wr) + when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr) #endif withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do - gc <- io $ createGC d w + gc <- liftIO $ createGC d w #if XFT when (alpha c == 255) $ do #else do #endif - io $ setForeground d gc bgcolor - io $ fillRectangle d p gc 0 0 wid ht + liftIO $ setForeground d gc bgcolor + liftIO $ fillRectangle d p gc 0 0 wid ht -- write to the pixmap the new string printStrings p gc fs vs 1 L =<< strLn left printStrings p gc fs vs 1 R =<< strLn right printStrings p gc fs vs 1 C =<< strLn center -- draw border if requested - io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht + liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht -- copy the pixmap with the new string to the window - io $ copyArea d p w gc 0 0 wid ht 0 0 + liftIO $ copyArea d p w gc 0 0 wid ht 0 0 -- free up everything (we do not want to leak memory!) - io $ freeGC d gc - io $ freePixmap d p + liftIO $ freeGC d gc + liftIO $ freePixmap d p -- resync - io $ sync d True + liftIO $ sync d True verticalOffset :: (Integral b, Integral a, MonadIO m) => a -> Widget -> XFont -> Int -> Config -> m b verticalOffset ht (Text t) fontst voffs _ | voffs > -1 = return $ fi voffs | otherwise = do - (as,ds) <- io $ textExtents fontst t + (as,ds) <- liftIO $ textExtents fontst t let margin = (fi ht - fi ds - fi as) `div` 2 return $ fi as + margin - 1 verticalOffset ht (Icon _) _ _ conf @@ -355,8 +355,8 @@ printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do (f, _) -> (f, bgColor conf) valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf case s of - (Text t) -> io $ printString d dr fontst gc fc bc offset valign t alph - (Icon p) -> io $ maybe (return ()) + (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph + (Icon p) -> liftIO $ maybe (return ()) (drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r)) printStrings dr gc fontlist voffs (offs + l) a xs diff --git a/src/lib/Xmobar/Window.hs b/src/lib/Xmobar/Window.hs index c8228de..c8ba1bd 100644 --- a/src/lib/Xmobar/Window.hs +++ b/src/lib/Xmobar/Window.hs @@ -33,6 +33,18 @@ import Xmobar.XUtil -- $window +-- | 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 = if o then cWOverrideRedirect else 0 + allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes o + createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) + inputOutput visual attrmask attributes + -- | The function to create the initial window createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) createWin d fs c = do @@ -41,7 +53,7 @@ createWin d fs c = do rootw <- rootWindow d dflt (as,ds) <- textExtents fs "0" let ht = as + ds + 4 - r = setPosition c (position c) srs (fi ht) + r = setPosition c (position c) srs (fromIntegral ht) win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c) setProperties c d win setStruts r c d win srs @@ -55,11 +67,14 @@ repositionWin d win fs c = do srs <- getScreenInfo d (as,ds) <- textExtents fs "0" let ht = as + ds + 4 - r = setPosition c (position c) srs (fi ht) + r = setPosition c (position c) srs (fromIntegral ht) moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) setStruts r c d win srs return r +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle setPosition c p rs ht = case p' of diff --git a/src/lib/Xmobar/XUtil.hs b/src/lib/Xmobar/XUtil.hs new file mode 100644 index 0000000..5093e59 --- /dev/null +++ b/src/lib/Xmobar/XUtil.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XUtil +-- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz +-- (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.XUtil + ( XFont + , initFont + , initCoreFont + , initUtf8Font + , textExtents + , textWidth + , printString + , nextEvent' + , readFileSafe + , hGetLineSafe + ) where + +import Control.Concurrent +import Control.Monad (when) +import Control.Monad.Trans +import Control.Exception (SomeException, handle) +import Data.List +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 +import qualified System.IO as S (readFile,hGetLine) +#endif + +#if defined XFT +import Xmobar.MinXft +import Graphics.X11.Xrender +#endif + +import Xmobar.ColorCache + +readFileSafe :: FilePath -> IO String +#if defined XFT || defined UTF8 +readFileSafe = S.readFile +#else +readFileSafe = readFile +#endif + +hGetLineSafe :: Handle -> IO String +#if defined XFT || defined UTF8 +hGetLineSafe = S.hGetLine +#else +hGetLineSafe = hGetLine +#endif + +-- Hide the Core Font/Xft switching here +data XFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft [AXftFont] +#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 = + let xftPrefix = "xft:" in + if xftPrefix `isPrefixOf` s then +#ifdef XFT + fmap Xft $ initXftFont d s +#else + do + hPutStrLn stderr $ "Warning: Xmobar must be built with " + ++ "the with_xft flag to support font '" ++ s + ++ ".' Falling back on default." + initFont d miscFixedFont +#endif + else + fmap Utf8 $ initUtf8Font d s + +miscFixedFont :: String +miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" + +-- | 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 <- handle fallBack getIt + addFinalizer f (freeFont d f) + return f + 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 + (_,_,f) <- handle fallBack getIt + addFinalizer f (freeFontSet d f) + return f + where getIt = createFontSet d s + fallBack :: SomeException -> IO ([String], String, FontSet) + fallBack = const $ createFontSet d miscFixedFont + +#ifdef XFT +initXftFont :: Display -> String -> IO [AXftFont] +initXftFont d s = do + let fontNames = wordsBy (== ',') (drop 4 s) + mapM openFont fontNames + where + openFont fontName = do + f <- openAXftFont d (defaultScreenOfDisplay d) fontName + addFinalizer f (closeAXftFont d f) + return f + wordsBy p str = case dropWhile p str of + "" -> [] + str' -> w : wordsBy p str'' + where + (w, str'') = break p str' +#endif + +textWidth :: Display -> XFont -> String -> IO Int +textWidth _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s +textWidth _ (Core fs) s = return $ fromIntegral $ Xlib.textWidth fs s +#ifdef XFT +textWidth dpy (Xft xftdraw) s = do + gi <- xftTxtExtents' 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 = fromIntegral $ - (rect_y rl) + descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl) + return (ascent, descent) +#ifdef XFT +textExtents (Xft xftfonts) _ = do + ascent <- fromIntegral `fmap` xft_ascent' xftfonts + descent <- fromIntegral `fmap` xft_descent' xftfonts + return (ascent, descent) +#endif + +printString :: Display -> Drawable -> XFont -> GC -> String -> String + -> Position -> Position -> String -> Int -> IO () +printString d p (Core fs) gc fc bc x y s a = do + setFont d gc $ fontFromFontStruct fs + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + when (a == 255) (setBackground d gc bc') + drawImageString d p gc x y s + +printString d p (Utf8 fs) gc fc bc x y s a = + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + when (a == 255) (setBackground d gc bc') + liftIO $ wcDrawImageString d p fs gc x y s + +#ifdef XFT +printString dpy drw fs@(Xft fonts) _ fc bc x y s al = + withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do + when (al == 255) $ do + (a,d) <- textExtents fs s + gi <- xftTxtExtents' dpy fonts s + drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) + drawXftString' draw fc' fonts (toInteger x) (toInteger y) s +#endif + +-- | 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 diff --git a/src/lib/Xmobar/XUtil.hsc b/src/lib/Xmobar/XUtil.hsc deleted file mode 100644 index 05e6fad..0000000 --- a/src/lib/Xmobar/XUtil.hsc +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XUtil --- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz --- (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.XUtil - ( XFont - , initFont - , initCoreFont - , initUtf8Font - , textExtents - , textWidth - , printString - , newWindow - , nextEvent' - , readFileSafe - , hGetLineSafe - , io - , fi - ) where - -import Control.Concurrent -import Control.Monad (when) -import Control.Monad.Trans -import Control.Exception (SomeException, handle) -import Data.List -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 qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) -# else -import qualified System.IO as UTF8 (readFile,hGetLine) -# endif -#endif -#if defined XFT -import Xmobar.MinXft -import Graphics.X11.Xrender -#endif - -import Xmobar.ColorCache - -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 [AXftFont] -#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 = - let xftPrefix = "xft:" in - if xftPrefix `isPrefixOf` s then -#ifdef XFT - fmap Xft $ initXftFont d s -#else - do - hPutStrLn stderr $ "Warning: Xmobar must be built with " - ++ "the with_xft flag to support font '" ++ s - ++ ".' Falling back on default." - initFont d miscFixedFont -#endif - else -#if defined UTF8 || __GLASGOW_HASKELL__ >= 612 - fmap Utf8 $ initUtf8Font d s -#else - fmap Core $ initCoreFont d s -#endif - -miscFixedFont :: String -miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" - --- | 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 <- handle fallBack getIt - addFinalizer f (freeFont d f) - return f - 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) <- handle fallBack getIt - addFinalizer f (freeFontSet d f) - return f - where getIt = createFontSet d s - fallBack :: SomeException -> IO ([String], String, FontSet) - fallBack = const $ createFontSet d miscFixedFont - -#ifdef XFT -initXftFont :: Display -> String -> IO [AXftFont] -initXftFont d s = do - setupLocale - let fontNames = wordsBy (== ',') (drop 4 s) - mapM openFont fontNames - where - openFont fontName = do - f <- openAXftFont d (defaultScreenOfDisplay d) fontName - addFinalizer f (closeAXftFont d f) - return f - wordsBy p str = case dropWhile p str of - "" -> [] - str' -> w : wordsBy p str'' - where - (w, str'') = break p str' -#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 <- xftTxtExtents' 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 xftfonts) _ = do - ascent <- fi `fmap` xft_ascent' xftfonts - descent <- fi `fmap` xft_descent' xftfonts - return (ascent, descent) -#endif - -printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> String -> Int -> IO () -printString d p (Core fs) gc fc bc x y s a = do - setFont d gc $ fontFromFontStruct fs - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - drawImageString d p gc x y s - -printString d p (Utf8 fs) gc fc bc x y s a = - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - io $ wcDrawImageString d p fs gc x y s - -#ifdef XFT -printString dpy drw fs@(Xft fonts) _ fc bc x y s al = - withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do - when (al == 255) $ do - (a,d) <- textExtents fs s - gi <- xftTxtExtents' dpy fonts s - drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) - drawXftString' draw fc' fonts (toInteger x) (toInteger y) s -#endif - - --- | 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 = if o then cWOverrideRedirect else 0 - 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 -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 -- cgit v1.2.3