summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/IPC/DBus.hs15
-rw-r--r--src/Signal.hs14
-rw-r--r--src/Xmobar.hs21
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