From d52278f48d98f116d3a1ebd21000bf80d90b8c9d Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 22 Aug 2012 17:29:37 +0200 Subject: Allow multiple signals over dbus at once It's easy to implement, since arguments to dbus method calls are handed over as list anyway. It also removes the need for safeHead. Bottom line: extra functionality without extra cost. --- src/IPC/DBus.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 469a7c6..d755220 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -18,13 +18,12 @@ import Prelude hiding (catch) import DBus import DBus.Client -import Control.Monad (join, when) +import Control.Monad (when) import Control.Concurrent import Control.Exception (catch) import System.IO (stderr, hPutStrLn) import Signal -import Plugins.Utils (safeHead) busName :: BusName busName = busName_ "org.Xmobar.Control" @@ -56,8 +55,8 @@ sendSignalMethod mvst = method interfaceName sendSignalName sendSignalMethodCall :: MethodCall -> IO Reply sendSignalMethodCall mc = do - when ( methodCallMember mc == sendSignalName ) $ sendSignal $ - join $ safeHead $ map fromVariant $ methodCallBody mc + when ( methodCallMember mc == sendSignalName ) + $ mapM_ (sendSignal . fromVariant) (methodCallBody mc) return ( replyReturn [] ) sendSignal :: Maybe SignalType -> IO () -- cgit v1.2.3 From 68f9f51cd7e20190e1ef2fd95beaf7c852f11c81 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 22 Aug 2012 20:25:29 +0200 Subject: Refactor MVar SignalType to TMVar SignalType Replace MVar with TMVar from the STM package. This is common for ghc now. Since STM is used everywhere else in the src it also adds no additional dependencies. The main reason for this switch is, that readMVar, swapMVar, etc. are only atomically if there is no other producer for this MVar i.e. putMVar. For example readMVar is a combination of putMVar and takeMVar. Due to scheduling and readMVar's non-atomicity it is possible that values written to the MVar appear in the wrong order. Using TMVar fixes this problem, since it allows really atomical read/swap operations. --- src/IPC/DBus.hs | 8 ++++---- src/Signal.hs | 14 +++++++------- src/Xmobar.hs | 21 +++++++++++---------- 3 files changed, 22 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index d755220..60544a9 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -19,7 +19,7 @@ import Prelude hiding (catch) import DBus import DBus.Client import Control.Monad (when) -import Control.Concurrent +import Control.Concurrent.STM import Control.Exception (catch) import System.IO (stderr, hPutStrLn) @@ -34,7 +34,7 @@ objectPath = objectPath_ "/org/Xmobar/Control" interfaceName :: InterfaceName interfaceName = interfaceName_ "org.Xmobar.Control" -runIPC :: MVar SignalType -> IO () +runIPC :: TMVar SignalType -> IO () runIPC mvst = catch exportConnection printException where printException :: ClientError -> IO () @@ -44,7 +44,7 @@ runIPC mvst = catch exportConnection printException requestName client busName [ nameDoNotQueue ] export client objectPath [ sendSignalMethod mvst ] -sendSignalMethod :: MVar SignalType -> Method +sendSignalMethod :: TMVar SignalType -> Method sendSignalMethod mvst = method interfaceName sendSignalName (signature_ [variantType $ toVariant $ (undefined :: SignalType)]) (signature_ []) @@ -60,4 +60,4 @@ sendSignalMethod mvst = method interfaceName sendSignalName return ( replyReturn [] ) sendSignal :: Maybe SignalType -> IO () - sendSignal = maybe (return ()) (putMVar mvst) + sendSignal = maybe (return ()) (atomically . putTMVar mvst) diff --git a/src/Signal.hs b/src/Signal.hs index a003859..44fe4f9 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -19,7 +19,7 @@ module Signal where import Data.Typeable (Typeable) -import Control.Concurrent +import Control.Concurrent.STM import Control.Exception hiding (handle) import System.Posix.Signals @@ -52,19 +52,19 @@ parseSignalType :: String -> Maybe SignalType parseSignalType = fmap fst . safeHead . reads -- | Signal handling -setupSignalHandler :: IO (MVar SignalType) +setupSignalHandler :: IO (TMVar SignalType) setupSignalHandler = do - tid <- newEmptyMVar + tid <- newEmptyTMVarIO installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing return tid -updatePosHandler :: MVar SignalType -> IO () +updatePosHandler :: TMVar SignalType -> IO () updatePosHandler sig = do - putMVar sig Reposition + atomically $ putTMVar sig Reposition return () -changeScreenHandler :: MVar SignalType -> IO () +changeScreenHandler :: TMVar SignalType -> IO () changeScreenHandler sig = do - putMVar sig ChangeScreen + atomically $ putTMVar sig ChangeScreen return () diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 2dbba11..79234d2 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -75,7 +75,7 @@ runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc -- | Starts the main event loop and threads -startLoop :: XConf -> MVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () +startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () startLoop xcfg@(XConf _ _ w _ _) sig vs = do tv <- atomically $ newTVar [] _ <- forkIO (checker tv [] vs sig `catch` @@ -107,16 +107,16 @@ startLoop xcfg@(XConf _ _ w _ _) sig vs = do #endif ev <- getEvent e case ev of - ConfigureEvent {} -> putMVar signal Reposition - ExposeEvent {} -> putMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> putMVar signal Reposition + ConfigureEvent {} -> atomically $ putTMVar signal Reposition + ExposeEvent {} -> atomically $ putTMVar signal Wakeup + RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition _ -> return () -- | Send signal to eventLoop every time a var is updated checker :: TVar [String] -> [String] -> [[(Maybe ThreadId, TVar String)]] - -> MVar SignalType + -> TMVar SignalType -> IO () checker tvar ov vs signal = do nval <- atomically $ do @@ -124,16 +124,16 @@ checker tvar ov vs signal = do guard (nv /= ov) writeTVar tvar nv return nv - putMVar signal Wakeup + atomically $ putTMVar signal Wakeup checker tvar nval vs signal where concatV = fmap concat . mapM (readTVar . snd) -- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] -> XConf -> MVar SignalType -> IO () +eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO () eventLoop tv xc@(XConf d _ w fs cfg) signal = do - typ <- takeMVar signal + typ <- atomically $ takeTMVar signal case typ of Wakeup -> do runX xc (updateWin tv) @@ -186,7 +186,7 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do -- | Runs a command as an independent thread and returns its thread id -- and the TVar the command will be writing to. -startCommand :: MVar SignalType +startCommand :: TMVar SignalType -> (Runnable,String,String) -> IO (Maybe ThreadId, TVar String) startCommand sig (com,s,ss) @@ -196,7 +196,8 @@ startCommand sig (com,s,ss) | otherwise = do var <- atomically $ newTVar is let cb str = atomically $ writeTVar var (s ++ str ++ ss) h <- forkIO $ start com cb - _ <- forkIO $ trigger com ( maybe (return ()) (putMVar sig) ) + _ <- forkIO $ trigger com + $ maybe (return ()) (atomically . putTMVar sig) return (Just h,var) where is = s ++ "Updating..." ++ ss -- cgit v1.2.3