From 45fd6dc4dd71f752e25628d07a666aadc2e26e17 Mon Sep 17 00:00:00 2001 From: jao Date: Fri, 4 Feb 2022 00:07:54 +0000 Subject: Xmobar.App.CommandThreads -> Xmobar.Run.Loop --- src/Xmobar/App/CommandThreads.hs | 131 --------------------------------------- src/Xmobar/App/TextEventLoop.hs | 2 +- src/Xmobar/App/X11EventLoop.hs | 2 +- src/Xmobar/Run/Loop.hs | 128 ++++++++++++++++++++++++++++++++++++++ src/Xmobar/X11/Parsers.hs | 6 +- 5 files changed, 133 insertions(+), 136 deletions(-) delete mode 100644 src/Xmobar/App/CommandThreads.hs create mode 100644 src/Xmobar/Run/Loop.hs (limited to 'src') diff --git a/src/Xmobar/App/CommandThreads.hs b/src/Xmobar/App/CommandThreads.hs deleted file mode 100644 index 28bf926..0000000 --- a/src/Xmobar/App/CommandThreads.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- --- | --- Module: Xmobar.App.CommandThreads --- Copyright: (c) 2022 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Fri Jan 28, 2022 03:20 --- --- --- Running a thread for each defined Command --- ------------------------------------------------------------------------------- - -module Xmobar.App.CommandThreads ( initLoop - , loop - , newRefreshLock - , refreshLock) where - -import Control.Concurrent (forkIO) -import Control.Exception (bracket_, bracket, handle, SomeException(..)) -import Control.Concurrent.STM -import Control.Concurrent.Async (Async, async, cancel) -import Control.Monad (guard, void, unless) -import Data.Maybe (isJust) -import Data.Foldable (for_) - -import Xmobar.System.Signal -import Xmobar.Config.Types -import Xmobar.Run.Runnable (Runnable) -import Xmobar.Run.Exec (start, trigger, alias) -import Xmobar.Run.Template -import Xmobar.Run.Timer (withTimer) - -#ifdef DBUS -import Xmobar.System.DBus -#endif - -newRefreshLock :: IO (TMVar ()) -newRefreshLock = newTMVarIO () - -refreshLock :: TMVar () -> IO a -> IO a -refreshLock var = bracket_ lock unlock - where - lock = atomically $ takeTMVar var - unlock = atomically $ putTMVar var () - -refreshLockT :: TMVar () -> STM a -> STM a -refreshLockT var action = do - takeTMVar var - r <- action - putTMVar var () - return r - -type StartFunction = TMVar SignalType - -> TMVar () - -> [[([Async ()], TVar String)]] - -> IO () - -loop :: Config -> StartFunction -> IO () -loop conf starter = withDeferSignals $ do - cls <- mapM (parseTemplate (commands conf) (sepChar conf)) - (splitTemplate (alignSep conf) (template conf)) - let confSig = unSignalChan (signal conf) - sig <- maybe newEmptyTMVarIO pure confSig - unless (isJust confSig) $ setupSignalHandler sig - refLock <- newRefreshLock - withTimer (refreshLock refLock) $ - bracket (mapM (mapM $ startCommand sig) cls) - cleanupThreads - $ \vars -> do - starter sig refLock vars - -cleanupThreads :: [[([Async ()], a)]] -> IO () -cleanupThreads vars = - for_ (concat vars) $ \(asyncs, _) -> - for_ asyncs cancel - --- | Initialises context for an event loop, returning a TVar that --- will hold the current list of values computed by commands. -initLoop :: TMVar SignalType -> TMVar () -> [[([Async ()], TVar String)]] - -> IO (TVar [String]) -initLoop sig lock vs = do - tv <- newTVarIO ([] :: [String]) - _ <- forkIO (handle (handler "checker") (checker tv [] vs sig lock)) -#ifdef DBUS - runIPC sig -#endif - return tv - where - handler thing (SomeException e) = - void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) - --- | Runs a command as an independent thread and returns its Async handles --- and the TVar the command will be writing to. -startCommand :: TMVar SignalType - -> (Runnable,String,String) - -> IO ([Async ()], TVar String) -startCommand sig (com,s,ss) - | alias com == "" = do var <- newTVarIO is - atomically $ writeTVar var (s ++ ss) - return ([], var) - | otherwise = do var <- newTVarIO is - let cb str = atomically $ writeTVar var (s ++ str ++ ss) - a1 <- async $ start com cb - a2 <- async $ trigger com $ maybe (return ()) - (atomically . putTMVar sig) - return ([a1, a2], var) - where is = s ++ "Updating..." ++ ss - --- | Send signal to eventLoop every time a var is updated -checker :: TVar [String] - -> [String] - -> [[([Async ()], TVar String)]] - -> TMVar SignalType - -> TMVar () - -> IO () -checker tvar ov vs sig pauser = do - nval <- atomically $ refreshLockT pauser $ do - nv <- mapM concatV vs - guard (nv /= ov) - writeTVar tvar nv - return nv - atomically $ putTMVar sig Wakeup - checker tvar nval vs sig pauser - where - concatV = fmap concat . mapM (readTVar . snd) diff --git a/src/Xmobar/App/TextEventLoop.hs b/src/Xmobar/App/TextEventLoop.hs index e516298..ad7c33b 100644 --- a/src/Xmobar/App/TextEventLoop.hs +++ b/src/Xmobar/App/TextEventLoop.hs @@ -28,8 +28,8 @@ import Control.Concurrent.STM import Xmobar.System.Signal import Xmobar.Config.Types (Config(textOutputFormat), TextOutputFormat(..)) +import Xmobar.Run.Loop (initLoop, loop) import Xmobar.X11.Parsers (Segment, Widget(..), parseString, tColorsString, colorComponents) -import Xmobar.App.CommandThreads (initLoop, loop) -- | Starts the main event loop and threads textLoop :: Config -> IO () diff --git a/src/Xmobar/App/X11EventLoop.hs b/src/Xmobar/App/X11EventLoop.hs index b8897b5..662c777 100644 --- a/src/Xmobar/App/X11EventLoop.hs +++ b/src/Xmobar/App/X11EventLoop.hs @@ -59,7 +59,7 @@ import Xmobar.X11.Bitmap as Bitmap import Xmobar.X11.Types import Xmobar.System.Utils (safeIndex) -import Xmobar.App.CommandThreads (initLoop, loop) +import Xmobar.Run.Loop (initLoop, loop) #ifndef THREADED_RUNTIME import Xmobar.X11.Events(nextEvent') diff --git a/src/Xmobar/Run/Loop.hs b/src/Xmobar/Run/Loop.hs new file mode 100644 index 0000000..30ee112 --- /dev/null +++ b/src/Xmobar/Run/Loop.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Run.Loop +-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Fri Jan 28, 2022 03:20 +-- +-- +-- Running a thread for each defined Command in a loop +-- +------------------------------------------------------------------------------ + +module Xmobar.Run.Loop (initLoop, loop) where + +import Control.Concurrent (forkIO) +import Control.Exception (bracket_, bracket, handle, SomeException(..)) +import Control.Concurrent.STM +import Control.Concurrent.Async (Async, async, cancel) +import Control.Monad (guard, void, unless) +import Data.Maybe (isJust) +import Data.Foldable (for_) + +import Xmobar.System.Signal +import Xmobar.Config.Types +import Xmobar.Run.Runnable (Runnable) +import Xmobar.Run.Exec (start, trigger, alias) +import Xmobar.Run.Template +import Xmobar.Run.Timer (withTimer) + +#ifdef DBUS +import Xmobar.System.DBus +#endif + +newRefreshLock :: IO (TMVar ()) +newRefreshLock = newTMVarIO () + +refreshLock :: TMVar () -> IO a -> IO a +refreshLock var = bracket_ lock unlock + where + lock = atomically $ takeTMVar var + unlock = atomically $ putTMVar var () + +refreshLockT :: TMVar () -> STM a -> STM a +refreshLockT var action = do + takeTMVar var + r <- action + putTMVar var () + return r + +type StartFunction = TMVar SignalType + -> TMVar () + -> [[([Async ()], TVar String)]] + -> IO () + +loop :: Config -> StartFunction -> IO () +loop conf starter = withDeferSignals $ do + cls <- mapM (parseTemplate (commands conf) (sepChar conf)) + (splitTemplate (alignSep conf) (template conf)) + let confSig = unSignalChan (signal conf) + sig <- maybe newEmptyTMVarIO pure confSig + unless (isJust confSig) $ setupSignalHandler sig + refLock <- newRefreshLock + withTimer (refreshLock refLock) $ + bracket (mapM (mapM $ startCommand sig) cls) + cleanupThreads + $ \vars -> do + starter sig refLock vars + +cleanupThreads :: [[([Async ()], a)]] -> IO () +cleanupThreads vars = + for_ (concat vars) $ \(asyncs, _) -> + for_ asyncs cancel + +-- | Initialises context for an event loop, returning a TVar that +-- will hold the current list of values computed by commands. +initLoop :: TMVar SignalType -> TMVar () -> [[([Async ()], TVar String)]] + -> IO (TVar [String]) +initLoop sig lock vs = do + tv <- newTVarIO ([] :: [String]) + _ <- forkIO (handle (handler "checker") (checker tv [] vs sig lock)) +#ifdef DBUS + runIPC sig +#endif + return tv + where + handler thing (SomeException e) = + void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) + +-- | Runs a command as an independent thread and returns its Async handles +-- and the TVar the command will be writing to. +startCommand :: TMVar SignalType + -> (Runnable,String,String) + -> IO ([Async ()], TVar String) +startCommand sig (com,s,ss) + | alias com == "" = do var <- newTVarIO is + atomically $ writeTVar var (s ++ ss) + return ([], var) + | otherwise = do var <- newTVarIO is + let cb str = atomically $ writeTVar var (s ++ str ++ ss) + a1 <- async $ start com cb + a2 <- async $ trigger com $ maybe (return ()) + (atomically . putTMVar sig) + return ([a1, a2], var) + where is = s ++ "Updating..." ++ ss + +-- | Send signal to eventLoop every time a var is updated +checker :: TVar [String] + -> [String] + -> [[([Async ()], TVar String)]] + -> TMVar SignalType + -> TMVar () + -> IO () +checker tvar ov vs sig pauser = do + nval <- atomically $ refreshLockT pauser $ do + nv <- mapM concatV vs + guard (nv /= ov) + writeTVar tvar nv + return nv + atomically $ putTMVar sig Wakeup + checker tvar nval vs sig pauser + where + concatV = fmap concat . mapM (readTVar . snd) diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs index 4688760..4a7e4eb 100644 --- a/src/Xmobar/X11/Parsers.hs +++ b/src/Xmobar/X11/Parsers.hs @@ -24,9 +24,6 @@ module Xmobar.X11.Parsers ( parseString , TextRenderInfo(..) , Widget(..)) where -import Xmobar.Config.Types -import Xmobar.Run.Actions - import Control.Monad (guard, mzero) import Data.Maybe (fromMaybe) import Data.Int (Int32) @@ -34,6 +31,9 @@ import Text.ParserCombinators.Parsec import Text.Read (readMaybe) import Foreign.C.Types (CInt) +import Xmobar.Config.Types +import Xmobar.Run.Actions + data Widget = Icon String | Text String | Hspace Int32 deriving Show data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) -- cgit v1.2.3