Merge remote-tracking branch 'jrk/replacemvar' into jrk

Conflicts:
	readme.md

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