module Data.IVar
( IVar, new, write, read
, Reader, nonblocking, blocking, combo
)
where
import Prelude hiding (read)
import Control.Concurrent.MVar
import Control.Applicative
import Data.IORef
import Data.Monoid
import Control.Monad
import Data.Unique
import Control.Exception
import qualified Data.Map as Map
data State a
= Value a
| NoValue (Map.Map Unique (a -> IO ()))
newtype IVar a = IVar (IORef (State a))
new :: IO (IVar a)
new = IVar <$> newIORef (NoValue Map.empty)
write :: IVar a -> a -> IO ()
write (IVar ref) x = block $ do
b <- atomicModifyIORef ref $ \v ->
case v of
Value a -> (v, Nothing)
NoValue blockers -> (Value x, Just blockers)
case b of
Nothing -> fail "Attempt to write to an IVar twice"
Just blockers -> do
mapM_ ($ x) (Map.elems blockers)
read :: IVar a -> Reader a
read var@(IVar ref) = Reader $ do
state <- readIORef ref
return $ case state of
Value x -> Left x
NoValue _ -> Right [LogEntry var (\x -> Reader (return (Left x)))]
addAction :: IVar a -> (a -> IO ()) -> IO Unique
addAction (IVar ref) action = do
actionid <- newUnique
block . join . atomicModifyIORef ref $ \v ->
case v of
Value x -> (v, action x)
NoValue blockers -> (NoValue (Map.insert actionid action blockers), return ())
return actionid
deleteAction :: IVar a -> Unique -> IO ()
deleteAction (IVar ref) actionid = do
atomicModifyIORef ref $ \v ->
case v of
Value x -> (v, ())
NoValue blockers ->
let m = Map.delete actionid blockers
in m `seq` (NoValue m, ())
data LogEntry a = forall r. LogEntry (IVar r) (r -> a)
instance Functor LogEntry where
fmap f (LogEntry v cc) = LogEntry v (f . cc)
newtype Reader a = Reader { runReader :: IO (Either a [LogEntry (Reader a)]) }
f +++ g = either (Left . f) (Right . g)
instance Functor Reader where
fmap f (Reader m) = Reader (fmap (f +++ (fmap.fmap.fmap) f) m)
instance Monad Reader where
return = Reader . return . Left
m >>= f = Reader $ do
r <- runReader m
case r of
Left x -> runReader $ f x
Right log -> return $ Right ((fmap.fmap) (>>= f) log)
instance Applicative Reader where
pure = return
(<*>) = ap
instance Monoid (Reader a) where
mempty = Reader . return . Right $ []
mappend m m' = Reader $ do
a <- runReader m
case a of
Left x -> return (Left x)
Right log -> do
b <- runReader m'
case b of
Left y -> return (Left y)
Right log' -> do
return (Right (log ++ log'))
instance MonadPlus Reader where
mzero = mempty
mplus = mappend
nonblocking :: Reader a -> IO (Maybe a)
nonblocking reader = do
r <- runReader reader
return $ case r of
Left x -> Just x
Right _ -> Nothing
blocking :: Reader a -> IO a
blocking reader = do
r <- runReader reader
case r of
Left x -> return x
Right log -> primBlocking log
primBlocking :: [LogEntry (Reader a)] -> IO a
primBlocking log = do
blocker <- newEmptyMVar
cleanup <- block . forM log $ \(LogEntry var action) -> do
ident <- addAction var (\v -> tryPutMVar blocker (action v) >> return ())
return $ deleteAction var ident
blocking =<< takeMVar blocker
combo :: Reader a -> IO (Either a (IO a))
combo reader = do
r <- runReader reader
case r of
Left x -> return (Left x)
Right log -> return . Right $ primBlocking log