x event loop clean-ups

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)