module Data.AVar (
AVar,
Transaction(..),
newAVar,
putMVar,
modAVar,
modAVar',
getAVar,
condModAVar,
swapAVar) where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import qualified Control.Exception as E
import System.Environment
data Transaction a =
Put a
| Get (MVar a)
| Mod (a -> a) (MVar (Maybe E.SomeException))
| forall b. Mod' (a -> (a,b)) (MVar (Either E.SomeException b))
| Atom (a -> Bool) (a -> a) (a -> a) (MVar (Either E.SomeException Bool))
data AVar a = AVar (Chan (Transaction a))
newAVar :: a -> IO (AVar a)
newAVar x = do
E.evaluate x
chan <- newChan :: IO (Chan (Transaction a))
forkIO (handler chan x)
return (AVar chan)
handler :: Chan (Transaction a) -> a -> IO b
handler chan !x = do
req <- readChan chan
case req of
Put a -> handler chan a
Get mvar -> do
putMVar mvar x
handler chan x
Mod f mvar -> do
let x' = f x
p <- E.catch (E.evaluate x' >> return Nothing)
(\e -> return (Just e))
putMVar mvar p
case p of
Nothing -> handler chan x'
_ -> handler chan x
Mod' f mvar -> do
let y@(a,b) = f x
p <- E.try (E.evaluate a >> E.evaluate b)
case p of
Right _ -> do
putMVar mvar (Right b)
handler chan a
(Left e) -> do
putMVar mvar (Left e)
handler chan x
Atom test y n res -> do
let t' = test x
y' = y x
n' = n x
tres <- E.try (E.evaluate t')
case tres of
rT@(Right True) -> do
run <- E.try (E.evaluate y')
case run of
Right x' -> putMVar res rT >> handler chan x'
Left e -> putMVar res (Left e) >> handler chan x
rF@(Right False) -> do
run <- E.try (E.evaluate n')
case run of
Right x' -> putMVar res rF >> handler chan x'
Left e -> putMVar res (Left e) >> handler chan x
Left e -> putMVar res (Left e) >> handler chan x
putAVar :: AVar a -> a -> IO ()
putAVar (AVar chan) x = writeChan chan (Put x)
modAVar :: AVar a -> (a -> a) -> IO (Maybe E.SomeException)
modAVar (AVar chan) f = do
res <- newEmptyMVar
writeChan chan (Mod f res)
takeMVar res
modAVar' :: AVar a -> (a -> (a,b)) -> IO (Either E.SomeException b)
modAVar' (AVar chan) f = do
res <- newEmptyMVar
writeChan chan (Mod' f res)
takeMVar res
getAVar :: AVar a -> IO a
getAVar (AVar chan) = do
res <- newEmptyMVar
writeChan chan (Get res)
takeMVar res
condModAVar :: AVar a
-> (a -> Bool)
-> (a -> a)
-> (a -> a)
-> IO (Either E.SomeException Bool)
condModAVar (AVar chan) p t f = do
res <- newEmptyMVar
writeChan chan (Atom p t f res)
takeMVar res
swapAVar :: (AVar a) -> a -> IO (Either E.SomeException a)
swapAVar (AVar chan) new = do
res <- newEmptyMVar
writeChan chan (Mod' (\old -> (new, old)) res)
takeMVar res
main = do
n <- getArgs >>= \xs -> if null xs then return 1000000 else (readIO.head) xs
var <- newAVar (0 :: Int)
m <- newEmptyMVar
forkIO $ test n var m
takeMVar m
where test 0 _ m = putMVar m ()
test n var m = do
res <- getAVar var
putAVar var (res + 1)
test (n1) var m