diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/IPC/DBus.hs | 15 | ||||
| -rw-r--r-- | src/Signal.hs | 14 | ||||
| -rw-r--r-- | src/Xmobar.hs | 21 |
3 files changed, 25 insertions, 25 deletions
diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 469a7c6..60544a9 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.Concurrent +import Control.Monad (when) +import Control.Concurrent.STM import Control.Exception (catch) import System.IO (stderr, hPutStrLn) import Signal -import Plugins.Utils (safeHead) busName :: BusName busName = busName_ "org.Xmobar.Control" @@ -35,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 () @@ -45,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_ []) @@ -56,9 +55,9 @@ 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 () - 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 |