Def.hs

{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.AdvSTM.Def
-- Copyright   :  (c) HaskellWiki 2006-2007, Peter Robinson 2008
-- License     :  BSD3
-- 
-- Maintainer  :  Peter Robinson <robinson@ecs.tuwien.ac.at>
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
--
-- This is an internal module.
-----------------------------------------------------------------------------
 
module Control.Monad.AdvSTM.Def(AdvSTM(..),Env(..),TVarValue(..))
where

import qualified Control.Concurrent.STM as S
import Control.Concurrent.STM.TVar(TVar) 
import Control.Concurrent.STM.TMVar(TMVar) 
import Control.Concurrent(MVar,ThreadId)
import Control.Applicative(Alternative,(<|>),(<*>),empty)
import Control.Monad(Monad,MonadPlus,ap,liftM,mplus,mzero)
import Control.Monad.Reader(ReaderT,mapReaderT,runReaderT)

instance Functor AdvSTM where
    fmap  = liftM

instance Applicative AdvSTM where
    pure  = return
    (<*>) = ap 

instance Alternative AdvSTM where
    (<|>) = mplus
    empty = mzero

-- | Drop-in replacement for the STM monad
newtype AdvSTM a = AdvSTM (ReaderT Env S.STM a)
                deriving ( Monad
                         , MonadPlus
                         )



-- | The environment used for the Reader Monad
data Env = Env { commitTVar    :: TVar [IO ()]        -- the commit action(s)
               , commitClosure :: TVar ([IO ()] -> IO ())
               , retryDoneMVar     :: MVar (Maybe ()) -- (IO () -> IO ()) -- the retry action(s)
               , transThreadId :: ThreadId            -- the current ThreadId
               , listeners     :: TVar [(TMVar (),TVarValue)] -- ,TVar (Maybe ThreadId),TChan (Maybe ThreadId))]
                                    -- Contains communication facilities for modified TVars: 
                                    -- [(tVar-Lock,Old-tVar-Value,Maybe (current ThreadId)
                                    --  ,death-notice channel)]
               , debugModeVar :: TVar Bool
--               , isInRetryMode :: TVar Bool
               }

data TVarValue = forall a. TVarValue ((TVar a),a)