module Transient.EVars where
import Transient.Base
import qualified Data.Map as M
import Data.Typeable
import Control.Concurrent
import Control.Applicative
import Data.IORef
import Control.Monad.IO.Class
import Control.Monad.State
import Data.List(nub)
newtype EVars= EVars (IORef (M.Map Int [EventF])) deriving Typeable
data EVar a= EVar Int (IORef (Maybe a)) deriving Typeable
newEVar :: TransientIO (EVar a)
newEVar = Transient $ do
getSessionData `onNothing` do
ref <- liftIO $ newIORef M.empty
setSData $ EVars ref
return (EVars ref)
id <- genNewId
ref <- liftIO $ newIORef Nothing
return . Just $ EVar id ref
readEVar :: EVar a -> TransIO a
readEVar (EVar id ref1)= Transient $ do
mr <- liftIO $ readIORef ref1 !> "READEVAR"
case mr of
Just _ -> return mr
Nothing -> do
cont <- getCont
EVars ref <- getSessionData `onNothing` error "No Events context"
map <- liftIO $ readIORef ref
let Just conts= M.lookup id map <|> Just []
liftIO $ writeIORef ref $ M.insert id (cont:conts) map
return Nothing
writeEVar (EVar id ref1) x= Transient $ do
EVars ref <- getSessionData `onNothing` error "No Events context"
liftIO $ writeIORef ref1 $ Just x
map <- liftIO $ readIORef ref
let Just conts = M.lookup id map <|> Just []
len= length conts
runCont' len id ref
liftIO $ writeIORef ref1 Nothing
return $ Just ()
where
runCont' 0 _ _ = return ()
runCont' n id ref= do
map <- liftIO $ readIORef ref
let Just conts= M.lookup id map <|> Just []
let current= head conts
nexts= tail conts
runCont current
map' <- liftIO $ readIORef ref
let Just conts'= M.lookup id map' <|> Just []
if (length conts /= length conts') then return () else liftIO $ writeIORef ref $ M.insert id (nexts ++ [current]) map
runCont' (n 1) id ref
unsubscribe (EVar id _)= Transient $ do
EVars ref <- getSessionData `onNothing` error "No Events context"
map <- liftIO $ readIORef ref
let Just conts = M.lookup id map <|> Just []
liftIO $ writeIORef ref $ M.insert id (tail conts) map
return $ Just ()