Refactoring: event loop handling simplifications

4 files changed, 69 insertions, 89 deletions

diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs
index 52cdca5..489bcd0 100644
--- a/src/Xmobar/App/Main.hs
+++ b/src/Xmobar/App/Main.hs
@@ -29,13 +29,13 @@ import Control.Monad (unless)
 import Xmobar.App.Config
 import Xmobar.Config.Types
 import Xmobar.Config.Parse
-import qualified Xmobar.X11.Loop as X11
-import qualified Xmobar.Text.Loop as Text
+import Xmobar.X11.Loop (x11Loop)
+import Xmobar.Text.Loop (textLoop)
 import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts)
 import Xmobar.App.Compile (recompile, trace)
 
 xmobar :: Config -> IO ()
-xmobar cfg = if textOutput cfg then Text.loop cfg else X11.loop cfg
+xmobar cfg = if textOutput cfg then textLoop cfg else x11Loop cfg
 
 configFromArgs :: Config -> IO Config
 configFromArgs cfg = getArgs >>= getOpts >>= doOpts cfg . fst
diff --git a/src/Xmobar/Run/Loop.hs b/src/Xmobar/Run/Loop.hs
index 30ee112..bda41ff 100644
--- a/src/Xmobar/Run/Loop.hs
+++ b/src/Xmobar/Run/Loop.hs
@@ -16,7 +16,7 @@
 --
 ------------------------------------------------------------------------------
 
-module Xmobar.Run.Loop (initLoop, loop) where
+module Xmobar.Run.Loop (LoopFunction, loop) where
 
 import Control.Concurrent (forkIO)
 import Control.Exception (bracket_, bracket, handle, SomeException(..))
@@ -53,13 +53,10 @@ refreshLockT var action = do
     putTMVar var ()
     return r
 
-type StartFunction = TMVar SignalType
-                     -> TMVar ()
-                     -> [[([Async ()], TVar String)]]
-                     -> IO ()
+type LoopFunction = TMVar SignalType -> TVar [String] -> IO ()
 
-loop :: Config -> StartFunction -> IO ()
-loop conf starter = withDeferSignals $ do
+loop :: Config -> LoopFunction -> IO ()
+loop conf looper = withDeferSignals $ do
   cls <- mapM (parseTemplate (commands conf) (sepChar conf))
                 (splitTemplate (alignSep conf) (template conf))
   let confSig = unSignalChan (signal conf)
@@ -70,7 +67,8 @@ loop conf starter = withDeferSignals $ do
     bracket (mapM (mapM $ startCommand sig) cls)
             cleanupThreads
             $ \vars -> do
-      starter sig refLock vars
+      tv <- initLoop sig refLock vars
+      looper sig tv
 
 cleanupThreads :: [[([Async ()], a)]] -> IO ()
 cleanupThreads vars =
diff --git a/src/Xmobar/Text/Loop.hs b/src/Xmobar/Text/Loop.hs
index 42c8700..2903aa9 100644
--- a/src/Xmobar/Text/Loop.hs
+++ b/src/Xmobar/Text/Loop.hs
@@ -14,48 +14,35 @@
 --
 ------------------------------------------------------------------------------
 
-module Xmobar.Text.Loop (loop) where
+module Xmobar.Text.Loop (textLoop) where
 
 import Prelude hiding (lookup)
 import System.IO
 
 import Control.Monad.Reader
 
-import Control.Concurrent.Async (Async)
 import Control.Concurrent.STM
 
 import Xmobar.System.Signal
-
 import Xmobar.Config.Types (Config)
-
-import qualified Xmobar.Run.Loop as Loop
-
+import Xmobar.Run.Loop (loop)
 import Xmobar.Run.Parsers (parseString)
-
 import Xmobar.Text.Output (formatSegment)
 
 -- | Starts the main event loop and threads
-loop :: Config -> IO ()
-loop conf = Loop.loop conf (startTextLoop' conf)
-
-startTextLoop' :: Config
-               -> TMVar SignalType
-               -> TMVar ()
-               -> [[([Async ()], TVar String)]]
-               -> IO ()
-startTextLoop' cfg sig pauser vs = do
-    hSetBuffering stdin LineBuffering
-    hSetBuffering stdout LineBuffering
-    tv <- Loop.initLoop sig pauser vs
-    eventLoop cfg tv sig
+textLoop :: Config -> IO ()
+textLoop conf = do
+  hSetBuffering stdin LineBuffering
+  hSetBuffering stdout LineBuffering
+  loop conf (eventLoop conf)
 
 -- | Continuously wait for a signal from a thread or a interrupt handler
-eventLoop :: Config -> TVar [String] -> TMVar SignalType -> IO ()
-eventLoop cfg tv signal = do
+eventLoop :: Config -> TMVar SignalType -> TVar [String] -> IO ()
+eventLoop cfg signal tv = do
   typ <- atomically $ takeTMVar signal
   case typ of
-    Wakeup -> updateString cfg tv >>= putStrLn >> eventLoop cfg tv signal
-    _ -> eventLoop cfg tv signal
+    Wakeup -> updateString cfg tv >>= putStrLn >> eventLoop cfg signal tv
+    _ -> eventLoop cfg signal tv
 
 updateString :: Config -> TVar [String] -> IO String
 updateString conf v = do
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs
index 840c16e..c74ae57 100644
--- a/src/Xmobar/X11/Loop.hs
+++ b/src/Xmobar/X11/Loop.hs
@@ -16,7 +16,7 @@
 --
 ------------------------------------------------------------------------------
 
-module Xmobar.X11.Loop (loop) where
+module Xmobar.X11.Loop (x11Loop) where
 
 import Prelude hiding (lookup)
 import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment)
@@ -27,7 +27,6 @@ import Graphics.X11.Xrandr
 import Control.Arrow ((&&&))
 import Control.Monad.Reader
 import Control.Concurrent
-import Control.Concurrent.Async (Async)
 import Control.Concurrent.STM
 import Control.Exception (handle, SomeException(..))
 import Data.Bits
@@ -59,7 +58,7 @@ import Xmobar.X11.Bitmap as Bitmap
 import Xmobar.X11.Types
 import Xmobar.System.Utils (safeIndex)
 
-import qualified Xmobar.Run.Loop as Loop
+import Xmobar.Run.Loop (loop)
 
 #ifndef THREADED_RUNTIME
 import Xmobar.X11.Events(nextEvent')
@@ -73,8 +72,8 @@ runX :: XConf -> X () -> IO ()
 runX xc f = runReaderT f xc
 
 -- | Starts the main event loop and threads
-loop :: Config -> IO ()
-loop conf = do
+x11Loop :: Config -> IO ()
+x11Loop conf = do
   initThreads
   d <- openDisplay ""
   fs <- initFont d (font conf)
@@ -82,58 +81,54 @@ loop conf = do
   let ic = Map.empty
       to = textOffset conf
       ts = textOffsets conf ++ replicate (length fl) (-1)
-  Loop.loop conf $ \sig lock vars -> do
-    (r,w) <- createWin d fs conf
-    startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf) sig lock vars
+  (r,w) <- createWin d fs conf
+  loop conf (startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf))
 
-startLoop :: XConf
-          -> TMVar SignalType
-          -> TMVar ()
-          -> [[([Async ()], TVar String)]]
-          -> IO ()
-startLoop xcfg@(XConf _ _ w _ _ _ _) sig pauser vs = do
+startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO ()
+startLoop xcfg@(XConf _ _ w _ _ _ _) sig tv = do
 #ifdef XFT
     xftInitFtLibrary
 #endif
-    tv <- Loop.initLoop sig pauser vs
 #ifdef THREADED_RUNTIME
-    _ <- forkOS (handle (handler "eventer") (eventer sig))
+    _ <- forkOS (handle (handler "X event handler") (handleXEvent w sig))
 #else
-    _ <- forkIO (handle (handler "eventer") (eventer sig))
+    _ <- forkIO (handle (handler "X event handler") (handleXEvent w sig))
 #endif
-    eventLoop tv xcfg [] sig
+    eventLoop xcfg [] sig tv
   where
     handler thing (SomeException e) =
       void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e)
-    -- Reacts on events from X
-    eventer signal =
-      allocaXEvent $ \e -> do
-        dpy <- openDisplay ""
-        xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask
-        selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)
-
-        forever $ do
+
+-- | Translates X11 events received by w to signals handled by eventLoop
+handleXEvent :: Window -> TMVar SignalType -> IO ()
+handleXEvent w signal =
+  allocaXEvent $ \e -> do
+    dpy <- openDisplay ""
+    xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask
+    selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)
+
+    forever $ do
 #ifdef THREADED_RUNTIME
-          nextEvent dpy e
+      nextEvent dpy e
 #else
-          nextEvent' dpy e
+      nextEvent' dpy e
 #endif
-          ev <- getEvent e
-          case ev of
-            ConfigureEvent {} -> atomically $ putTMVar signal Reposition
-            ExposeEvent {} -> atomically $ putTMVar signal Wakeup
-            RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition
-            ButtonEvent {} -> atomically $
-                   putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
-            _ -> return ()
-
--- | Continuously wait for a signal from a thread or a interrupt handler
-eventLoop :: TVar [String]
-             -> XConf
-             -> [([Action], Position, Position)]
-             -> TMVar SignalType
-             -> IO ()
-eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do
+      ev <- getEvent e
+      case ev of
+        ConfigureEvent {} -> atomically $ putTMVar signal Reposition
+        ExposeEvent {} -> atomically $ putTMVar signal Wakeup
+        RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition
+        ButtonEvent {} -> atomically $
+               putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
+        _ -> return ()
+
+-- | Continuously wait for a signal from a thread or an interrupt handler
+eventLoop :: XConf
+          -> [([Action], Position, Position)]
+          -> TMVar SignalType
+          -> TVar [String]
+          -> IO ()
+eventLoop xc@(XConf d r w fs vos is cfg) as signal tv = do
       typ <- atomically $ takeTMVar signal
       case typ of
          Wakeup -> do
@@ -142,7 +137,7 @@ eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do
                      \c -> return xc { iconS = c }
             as' <- updateActions xc r str
             runX xc' $ drawInWin r str
-            eventLoop tv xc' as' signal
+            eventLoop xc' as' signal tv
 
          Reposition ->
             reposWindow cfg
@@ -156,38 +151,38 @@ eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do
          Toggle t -> toggle t
 
          TogglePersistent -> eventLoop
-            tv xc { config = cfg { persistent = not $ persistent cfg } } as signal
+            xc { config = cfg { persistent = not $ persistent cfg } } as signal tv
 
          Action but x -> action but x
 
     where
         isPersistent = not $ persistent cfg
-
+        loopOn = eventLoop xc as signal tv
         hide t
             | t == 0 =
-                when isPersistent (hideWindow d w) >> eventLoop tv xc as signal
+                when isPersistent (hideWindow d w) >> loopOn
             | otherwise = do
                 void $ forkIO
                      $ threadDelay t >> atomically (putTMVar signal $ Hide 0)
-                eventLoop tv xc as signal
+                loopOn
 
         reveal t
             | t == 0 = do
                 when isPersistent (showWindow r cfg d w)
-                eventLoop tv xc as signal
+                loopOn
             | otherwise = do
                 void $ forkIO
                      $ threadDelay t >> atomically (putTMVar signal $ Reveal 0)
-                eventLoop tv xc as signal
+                loopOn
 
         toggle t = do
             ismapped <- isMapped d w
             atomically (putTMVar signal $ if ismapped then Hide t else Reveal t)
-            eventLoop tv xc as signal
+            loopOn
 
         reposWindow rcfg = do
           r' <- repositionWin d w (NE.head fs) rcfg
-          eventLoop tv (XConf d r' w fs vos is rcfg) as signal
+          eventLoop (XConf d r' w fs vos is rcfg) as signal tv
 
         updateConfigPosition ocfg =
           case position ocfg of
@@ -205,7 +200,7 @@ eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do
             filter (\(Spawn b _) -> button `elem` b) $
             concatMap (\(a,_,_) -> a) $
             filter (\(_, from, to) -> x >= from && x <= to) as
-          eventLoop tv xc as signal
+          loopOn
 
 updateString :: Config -> TVar [String] -> IO [[Segment]]
 updateString conf v = do