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.

3 files changed, 22 insertions, 21 deletions

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