diff options
author | jao <jao@gnu.org> | 2022-09-11 18:54:34 +0100 |
---|---|---|
committer | jao <jao@gnu.org> | 2022-09-11 19:22:57 +0100 |
commit | 7b6542e6b13d5457509a3bf79e3ad3ad9a42e48e (patch) | |
tree | 136e52af523e4a6924705a92393ebabcc5b95363 | |
parent | d7299a0b80f0b15f820a1b7533549e306755441c (diff) | |
download | xmobar-7b6542e6b13d5457509a3bf79e3ad3ad9a42e48e.tar.gz xmobar-7b6542e6b13d5457509a3bf79e3ad3ad9a42e48e.tar.bz2 |
x event loop clean-ups
-rw-r--r-- | src/Xmobar/Run/Parsers.hs | 5 | ||||
-rw-r--r-- | src/Xmobar/X11/Bitmap.hs | 23 | ||||
-rw-r--r-- | src/Xmobar/X11/CairoDraw.hs | 2 | ||||
-rw-r--r-- | src/Xmobar/X11/Loop.hs | 125 | ||||
-rw-r--r-- | src/Xmobar/X11/Types.hs | 7 | ||||
-rw-r--r-- | src/Xmobar/X11/XlibDraw.hs | 6 |
6 files changed, 75 insertions, 93 deletions
diff --git a/src/Xmobar/Run/Parsers.hs b/src/Xmobar/Run/Parsers.hs index 8da7204..de983fd 100644 --- a/src/Xmobar/Run/Parsers.hs +++ b/src/Xmobar/Run/Parsers.hs @@ -82,10 +82,7 @@ colorComponents conf c = (f,',':b) -> (f, b) (f, _) -> (f, bgColor conf) -allParsers :: TextRenderInfo - -> FontIndex - -> Maybe [Action] - -> Parser [Segment] +allParsers :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] allParsers c f a = textParser c f a <|> try (iconParser c f a) <|> try (hspaceParser c f a) diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs index 026cd5c..027462d 100644 --- a/src/Xmobar/X11/Bitmap.hs +++ b/src/Xmobar/X11/Bitmap.hs @@ -14,17 +14,16 @@ module Xmobar.X11.Bitmap ( updateCache , drawBitmap - , Bitmap(..)) where + , Bitmap(..) + , BitmapCache) where import Control.Monad import Control.Monad.Trans(MonadIO(..)) -import Data.Map hiding (map, filter) -import Graphics.X11.Xlib +import Data.Map hiding (map) +import Graphics.X11.Xlib hiding (Segment) import System.Directory (doesFileExist) import System.FilePath ((</>)) import System.Mem.Weak ( addFinalizer ) -import Xmobar.Run.Actions (Action) -import Xmobar.Run.Parsers (TextRenderInfo(..), Widget(..)) import Xmobar.X11.ColorCache #ifdef XPM @@ -53,14 +52,12 @@ data Bitmap = Bitmap { width :: Dimension , bitmapType :: BitmapType } -updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath - -> [[(Widget, TextRenderInfo, Int, Maybe [Action])]] - -> IO (Map FilePath Bitmap) -updateCache dpy win cache iconRoot ps = do - let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps - icons (Icon _, _, _, _) = True - icons _ = False - expandPath path@('/':_) = path +type BitmapCache = Map FilePath Bitmap + +updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> [FilePath] + -> IO BitmapCache +updateCache dpy win cache iconRoot paths = do + let expandPath path@('/':_) = path expandPath path@('.':'/':_) = path expandPath path@('.':'.':'/':_) = path expandPath path = iconRoot </> path diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs index 9dac493..714041d 100644 --- a/src/Xmobar/X11/CairoDraw.hs +++ b/src/Xmobar/X11/CairoDraw.hs @@ -65,7 +65,7 @@ drawInPixmap gc p s = do liftIO $ withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render lookupXBitmap :: XConf -> String -> Maybe B.Bitmap -lookupXBitmap xconf path = lookup path (iconS xconf) +lookupXBitmap xconf path = lookup path (iconCache xconf) drawXBitmap :: XConf -> GC -> Pixmap -> BitmapDrawer drawXBitmap xconf gc p h v path = do diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 8f74b79..4cf4b8f 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -19,7 +19,7 @@ module Xmobar.X11.Loop (x11Loop) where import Prelude hiding (lookup) -import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment) +import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment, Button) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama import Graphics.X11.Xrandr @@ -111,59 +111,44 @@ x11EventLoop w signal = putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) _ -> return () --- | Continuously wait for a signal from a thread or an interrupt handler --- The list of actions provide also the positions of clickable rectangles +-- | Continuously wait for a signal from a thread or an interrupt handler. +-- The list of actions provides the positions of clickable rectangles, +-- and there is a mutable variable for received signals and the list +-- of strings updated by running monitors. signalLoop :: XConf -> [([Action], Position, Position)] -> TMVar SignalType -> TVar [String] -> IO () -signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do - typ <- atomically $ takeTMVar signal - case typ of - Wakeup -> do - segs <- updateSegments cfg tv - xc' <- updateCache d w is (iconRoot cfg) segs >>= - \c -> return xc { iconS = c } - as' <- runX xc' $ drawInWin segs - signalLoop xc' as' signal tv - - Reposition -> - reposWindow cfg - - ChangeScreen -> do - ncfg <- updateConfigPosition cfg - reposWindow ncfg - - Hide t -> hide (t*100*1000) - Reveal t -> reveal (t*100*1000) - Toggle t -> toggle t - - TogglePersistent -> signalLoop - xc { config = cfg { persistent = not $ persistent cfg } } as signal tv - - SetAlpha a -> signalLoop xc { config = cfg { alpha = a}} as signal tv - - Action but x -> action but x - +signalLoop xc@(XConf d r w fs vos is cfg) actions signal strs = do + typ <- atomically $ takeTMVar signal + case typ of + Wakeup -> wakeup + Action button x -> runActions actions button x >> loopOn + Reposition -> reposWindow cfg + ChangeScreen -> updateConfigPosition d cfg >>= reposWindow + Hide t -> hiderev t Hide hideWindow + Reveal t -> hiderev t Reveal (showWindow r cfg) + Toggle t -> toggle t + TogglePersistent -> updateCfg $ cfg {persistent = not $ persistent cfg} + SetAlpha a -> updateCfg $ cfg {alpha = a} where - isPersistent = not $ persistent cfg - loopOn = signalLoop xc as signal tv - hide t - | t == 0 = - when isPersistent (hideWindow d w) >> loopOn + loopOn' xc' = signalLoop xc' actions signal strs + loopOn = loopOn' xc + updateCfg cfg' = loopOn' (xc {config = cfg'}) + + wakeup = do + segs <- parseSegments cfg strs + xc' <- updateIconCache xc segs + actions' <- runX xc' $ drawInWin segs + signalLoop xc' actions' signal strs + + hiderev t sign op + | t == 0 = unless (persistent cfg) (op d w) >> loopOn | otherwise = do void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - loopOn - - reveal t - | t == 0 = do - when isPersistent (showWindow r cfg d w) - loopOn - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) + $ threadDelay (t*100*1000) >> + atomically (putTMVar signal $ sign 0) loopOn toggle t = do @@ -173,28 +158,32 @@ signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do reposWindow rcfg = do r' <- repositionWin d w (NE.head fs) rcfg - signalLoop (XConf d r' w fs vos is rcfg) as signal tv - - updateConfigPosition ocfg = - case position ocfg of - OnScreen n o -> do - srs <- getScreenInfo d - return (if n == length srs - then - (ocfg {position = OnScreen 1 o}) - else - (ocfg {position = OnScreen (n+1) o})) - o -> return (ocfg {position = OnScreen 1 o}) - - action button x = do - mapM_ runAction $ - filter (\(Spawn b _) -> button `elem` b) $ - concatMap (\(a,_,_) -> a) $ - filter (\(_, from, to) -> x >= from && x <= to) as - loopOn - -updateSegments :: Config -> TVar [String] -> IO [[Segment]] -updateSegments conf v = do + signalLoop (XConf d r' w fs vos is rcfg) actions signal strs + +parseSegments :: Config -> TVar [String] -> IO [[Segment]] +parseSegments conf v = do s <- readTVarIO v let l:c:r:_ = s ++ repeat "" liftIO $ mapM (parseString conf) [l, c, r] + +updateIconCache :: XConf -> [[Segment]] -> IO XConf +updateIconCache xc@(XConf d _ w _ _ c cfg) segs = do + c' <- updateCache d w c (iconRoot cfg) [p | (Icon p, _, _, _) <- concat segs] + return $ xc {iconCache = c'} + +updateConfigPosition :: Display -> Config -> IO Config +updateConfigPosition disp cfg = + case position cfg of + OnScreen n o -> do + srs <- getScreenInfo disp + return (if n == length srs + then (cfg {position = OnScreen 1 o}) + else (cfg {position = OnScreen (n+1) o})) + o -> return (cfg {position = OnScreen 1 o}) + +runActions :: [([Action], Position, Position)] -> Button -> Position -> IO () +runActions actions button pos = + mapM_ runAction $ + filter (\(Spawn b _) -> button `elem` b) $ + concatMap (\(a,_,_) -> a) $ + filter (\(_, from, to) -> pos >= from && pos <= to) actions diff --git a/src/Xmobar/X11/Types.hs b/src/Xmobar/X11/Types.hs index a403e11..e94967b 100644 --- a/src/Xmobar/X11/Types.hs +++ b/src/Xmobar/X11/Types.hs @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.Types --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2018, 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -15,11 +15,10 @@ ------------------------------------------------------------------------------ -module Xmobar.X11.Types (X, XConf (..)) where +module Xmobar.X11.Types (X, XConf (..), Bitmap (..), XFont (..)) where import Graphics.X11.Xlib import Control.Monad.Reader -import Data.Map import qualified Data.List.NonEmpty as NE import Xmobar.X11.Bitmap @@ -36,6 +35,6 @@ data XConf = , window :: Window , fontListS :: NE.NonEmpty XFont , verticalOffsets :: NE.NonEmpty Int - , iconS :: Map FilePath Bitmap + , iconCache :: BitmapCache , config :: Config } diff --git a/src/Xmobar/X11/XlibDraw.hs b/src/Xmobar/X11/XlibDraw.hs index 77de23b..15a0ec7 100644 --- a/src/Xmobar/X11/XlibDraw.hs +++ b/src/Xmobar/X11/XlibDraw.hs @@ -56,7 +56,7 @@ drawInPixmap gc p wid ht ~[left,center,right] = do fs = fontListS r vs = verticalOffsets r strLn = liftIO . mapM getWidth - iconW i = maybe 0 B.width (lookup i $ iconS r) + iconW i = maybe 0 B.width (lookup i $ iconCache r) getWidth (Text s,cl,i,_) = textWidth d (safeIndex fs i) s >>= \tw -> return (Text s,cl,i,fi tw) getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) @@ -161,7 +161,7 @@ printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign ay ht' t alph (Icon p) -> liftIO $ maybe (return ()) (B.drawBitmap d dr gc fc bc offset valign) - (lookup p (iconS r)) + (lookup p (iconCache r)) (Hspace _) -> liftIO $ return () let triBoxes = tBoxes c dropBoxes = filter (\(_,b) -> b `notElem` triBoxes) boxes @@ -269,7 +269,7 @@ updateActions (Rectangle _ _ wid _) ~[left,center,right] = do fs = fontListS conf strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)] strLn = liftIO . mapM getCoords - iconW i = maybe 0 B.width (lookup i $ iconS conf) + iconW i = maybe 0 B.width (lookup i $ iconCache conf) getCoords (Text s,_,i,a) = textWidth d (safeIndex fs i) s >>= \tw -> return (a, 0, fi tw) getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) |