-- Implementation of MVar's using STM. module MutVar where import qualified Control.Concurrent as CC import qualified Control.Concurrent.STM as STM type MutVar a = STM.TVar (Maybe a) newEmptyMutVar :: STM.STM (MutVar a) newEmptyMutVar = STM.newTVar Nothing putMutVar :: MutVar a -> a -> STM.STM () putMutVar r x = do y <- STM.readTVar r case y of Nothing -> STM.writeTVar r (Just x) Just _ -> STM.retry takeMutVar :: MutVar a -> STM.STM a takeMutVar r = do y <- STM.readTVar r case y of Nothing -> STM.retry Just x -> do STM.writeTVar r Nothing return x readMutVar :: MutVar a -> STM.STM a readMutVar r = do x <- takeMutVar r putMutVar r x return x tryTakeMutVar :: MutVar a -> STM.STM (Maybe a) tryTakeMutVar r = do x <- takeMutVar r return (Just x) `STM.orElse` return Nothing test :: IO () test = do r <- STM.atomically newEmptyMutVar CC.forkIO $ child r rest r child :: MutVar Int -> IO () child r = do putStrLn "starting child" CC.threadDelay 2000000 -- wait (at least) two seconds putStrLn "putting" STM.atomically $ putMutVar r 42 putStrLn "concurrency!!" rest :: MutVar Int -> IO () rest r = do n <- STM.atomically $ takeMutVar r putStrLn $ "end: " ++ show n {- A few different outcomes: *MutVar> test Loading package syb ... linking ... done. Loading package array-0.2.0.0 ... linking ... done. Loading package stm-2.1.1.2 ... linking ... done. cosntcarting child urrency!! putting end: 42 *MutVar> test concurrency!! starting child putting end: 42 *MutVar> test concurrsetnacryt!i!n g child putting end: 42 -}