TVar.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.AdvSTM.TVar
-- Copyright   :  (c) Peter Robinson 2009
-- License     :  BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  Peter Robinson <robinson@ecs.tuwien.ac.at>
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- 
--
-----------------------------------------------------------------------------

module Control.Concurrent.AdvSTM.TVar( -- * TVars
                                       TVar 
                                     , newTVar
                                     , newTVarIO
                                     , readTVar
                                     , writeTVar
                                     , readTVarAsync
                                     , writeTVarAsync
                                     )
where
import Control.Monad.AdvSTM.Class
  (readTVar,writeTVar,newTVar,TVar(TVar),valueTVar,readTVarAsync,writeTVarAsync)
import qualified Control.Concurrent.STM.TVar as OldTVar
import qualified Control.Concurrent.STM.TMVar as OldTMVar
import Control.Monad(liftM,ap)
{-
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TChan as OldTChan
import Control.Exception(throw,Deadlock(Deadlock))
import Control.Concurrent.AdvSTM(liftAdv,orElse,retry,readTVar,writeTVar,newTVar)
import Control.Monad.AdvSTM.Def(AdvSTM(AdvSTM),transThreadId,listeners,TVarValue(TVarValue))
import Control.Concurrent(ThreadId)
import Control.Monad.Reader(asks)
import Data.Maybe(isJust,Maybe,fromJust)
import qualified Data.Set as S
-}
--------------------------------------------------------------------------------

-- | See 'OldTVar.newTVarIO'
--
newTVarIO :: a -> IO (TVar a)
newTVarIO a = TVar `liftM` OldTVar.newTVarIO a
                   `ap`    OldTMVar.newTMVarIO ()
                   `ap`    OldTVar.newTVarIO Nothing

--------------------------------------------------------------------------------
{-
-- | See 'OldTVar.newTVar'
newTVar :: a -> AdvSTM (TVar a)
newTVar a = TVar `liftM` (liftAdv $ OldTVar.newTVar a) 
                 `ap`    (liftAdv $ OldTMVar.newTMVar ()) 
                 `ap`    (liftAdv $ OldTVar.newTVar Nothing)
-}
{-
--------------------------------------------------------------------------------

-- | Writes a value to a TVar. Blocks until the onCommit IO-action(s) are
-- complete. See 'onCommit' for details.
writeTVar :: TVar a -> a -> AdvSTM ()
writeTVar tvar a = do 
    commitLock <- liftAdv $ OldTMVar.tryTakeTMVar (onCommitLock tvar)
    -- Get ThreadID of current transaction:
    curTid     <- AdvSTM $ asks transThreadId   
    storedTid  <- liftAdv $ OldTVar.readTVar (currentTid tvar) 
    case commitLock of
        Nothing -> do
            if isJust storedTid && fromJust storedTid == curTid
              then throw Deadlock       -- No transaction during onCommit-phase!
              else retry
        Just _  -> do
            unless (isJust storedTid && (fromJust storedTid == curTid)) $ do
                -- First write access, update the ThreadId:
                liftAdv $ OldTVar.writeTVar (currentTid tvar) $ Just curTid
                -- Add this TVar to the onCommit-listener list:
                lsTVar <- AdvSTM $ asks listeners
                ls     <- liftAdv $ OldTVar.readTVar lsTVar
                -- Remember the old value for rollback:
                oldval <- liftAdv $ OldTVar.readTVar (valueTVar tvar)
                liftAdv $ OldTVar.writeTVar lsTVar $
                        (onCommitLock tvar,TVarValue (valueTVar tvar,oldval)) : ls
            
            liftAdv $ OldTVar.writeTVar (valueTVar tvar) a 
            liftAdv $ OldTMVar.putTMVar (onCommitLock tvar) ()


--------------------------------------------------------------------------------

-- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of 
-- the corresponding transaction are complete.
-- See 'onCommit' for a more detailed description of this behaviour.
readTVar :: TVar a -> AdvSTM a
readTVar tvar = do 
    commitLock <- liftAdv $ OldTMVar.tryTakeTMVar (onCommitLock tvar)
    case commitLock of
        Nothing -> do
            storedTid <- liftAdv $ OldTVar.readTVar (currentTid tvar) 
            curTid    <- AdvSTM $ asks transThreadId   
            if isJust storedTid && fromJust storedTid == curTid
              then throw Deadlock
              else retry
        Just _ -> do
            result <- liftAdv $ OldTVar.readTVar $ valueTVar tvar
            liftAdv $ OldTMVar.putTMVar (onCommitLock tvar) ()
            return result

--------------------------------------------------------------------------------
-}