content: -----------------------------------------------------------------------------
  -- |
  -- Module      :  Control.Concurrent.SHFSTM
  -- Copyright   :  (c) D. Sabel, Goethe-University, Frankfurt a.M., Germany
  -- License     :  BSD-style 
  -- 
  -- Maintainer  :  sabel <at> ki.cs.uni-frankfurt.de
  -- Stability   :  experimental
  -- Portability :  non-portable (needs GHC and extensions)
  --
  --  
  -- This module implements the interface to the STM implementation.
  -----------------------------------------------------------------------------
  
  
  module Control.Concurrent.STM.STMMonad (
    -- * Types
    STM,
    TVar,
    -- * Operations in the 'STM'-monad
    newTVar,
    readTVar,
    writeTVar,
    retry,
    orElse,
    -- * Execution of 'STM'-transactions
    atomically,
    newTVarIO,
    --
    throwSTM,
    catchSTM,
    ) where
  
  import Prelude hiding(catch)
  import System.IO.Unsafe
  import Data.IORef
  import qualified Data.List
  import Control.Concurrent.STM.Internal.Map as Map
  import Control.Concurrent.STM.Internal.Set as Set
  import Control.Concurrent
  import Control.Exception
  import Control.Monad
  import Data.Maybe
  import Data.Typeable
  import Control.Concurrent.STM.Internal
  import Control.Concurrent.STM.Internal.TVar
  -- | The STM-monad
  
  
  
  
  -- The  data type STM, the operations store the continuation    
  data STM a = Return a 
             | forall b. NewTVar b (TVar b -> STM a)
             | forall b. ReadTVar (TVar b) (b -> STM a)
             | forall b. WriteTVar (TVar b) b (STM a)
             | Retry  
             | forall b. OrElse (STM b) (STM b) (b -> STM a) 
             | forall e. Exception e => Throw e
  
  
  instance Functor STM where
    fmap f x = x >>= (return . f)
  
  instance Applicative STM where
    pure = Return
    (<*>) = ap
     
  -- | The monad instance for 'STM'
  instance Monad STM where
    return = Return
    m >>= f = 
      case m of
        Return x -> f x
        Retry  -> Retry
        NewTVar x cont -> NewTVar x (cont >=> f)
        ReadTVar x cont -> ReadTVar x (cont >=> f)
        WriteTVar v x cont -> WriteTVar v x (cont >>= f)
        OrElse a1 a2 cont -> OrElse a1 a2 (cont >=> f)
        Throw e -> Throw e
        
  
  -- | 'newTVar' creates a new 'TVar' in the 'STM' monad
  
  newTVar :: a             -- ^ the content of the TVar
          -> STM (TVar a)  -- ^ the result
  newTVar a = NewTVar a return
  
  -- | 'readTVar' reads the content of a 'TVar' in the 'STM' monad
  
  readTVar :: TVar a       -- ^ the to-be-read 'TVar'
              -> STM a     -- ^ the result is an 'STM' action that returns the read content of the 'TVar'
  readTVar a = ReadTVar a return
  
  
  -- | 'writeTVar' writes new content into a 'TVar' in the 'STM' monad
  writeTVar :: TVar a  -- ^ the to-be-written 'TVar'
            -> a       -- ^ the new content
            -> STM ()
  writeTVar v x = WriteTVar v x (return ())
  
  
  throwSTM :: Exception e => e -> STM a
  throwSTM e = Throw e
  
  catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
  catchSTM act handle = error "catchSTM: not implemented yet"
  
  -- | 'orElse' composes two transactions: 
  -- 
  -- In 'orElse' @e1@ @e2@ first the transaction @e1@ is executed.
  -- If it is successful (i.e. commits), then 'orElse' @e1@ @e2@ is successful.
  -- If a 'retry' pops up, then 'orElse' @e1@ @e2@ proceeds with @e2@ ignoring
  -- then effects made by execution of @e1@.
  
  orElse :: STM a    -- ^ the first transaction
            -> STM a -- ^ the second transaction
            -> STM a -- ^ the composed transaction
            
  orElse a1 a2 = OrElse a1 a2 return
  
  -- | 'retry' aborts and restarts a transaction
  --
  --   Note that 'retry' has a /different/ semantics if it is used inside an argument of 'orElse':
  --
  --   If 'retry' pops up in the left @e1@ argument of 'orElse' @e1@ @e2@, then the transaction 
  --   corresponding to @ e1 @ is roll-back and transaction @e2@ is executed.
  --
  --   If 'retry' pops up in the right argument @e2@, then it behaves like a ususal 'retry'
  
  retry :: STM a
  retry = Retry
    
  
  -- | 'newTVarIO' creates new 'TVar' in the 'IO'-monad,
  --
  --   @ newTVarIO a @ is equivalent to 'atomically' @(@'newTVar'@ a)@
  newTVarIO :: a            -- ^ the content of the TVar
            -> IO (TVar a)  -- ^ the result is a TVar in the 'IO'-monad
  newTVarIO x = atomically (newTVar x)
  
     
  -- | 'atomically' executes an 'STM' transaction atomically in the 'IO'-monad
  atomically :: STM a -> IO a
  atomically act =
    do
      mid <- myThreadId
      tlog <- emptyTLOG
      catch (performSTM tlog act) 
            (\e -> case e of
                     RetryException   ->  do
                                            uninterruptibleMask_ ( do 
                                                     globalRetry tlog)
                                            atomically act
                     other -> putStrLn ("other exception" ++ show mid) >> error "error")
  
  
  performSTM :: TLOG -> STM a -> IO a
  performSTM tlog act =
    case act of 
      Return a -> do
                 commit tlog
                 return a
      Retry  -> do
                 waitForExternalRetry -- forever until a retry-exception is received
      NewTVar x cont -> do
                         tv <- newTVarWithLog tlog x
                         performSTM tlog (cont tv) 
      ReadTVar x cont -> do 
                          res <- readTVarWithLog tlog x
                          performSTM tlog (cont res) 
      WriteTVar v x cont -> do
                             writeTVarWithLog tlog v x
                             performSTM tlog cont 
      OrElse act1 act2 cont -> do           
                                orElseWithLog tlog -- adjust for left orElse
                                resl <- performOrElseLeft tlog act1
                                case resl of
                                  Just a -> performSTM tlog (cont a) 
                                  Nothing -> do
                                              orRetryWithLog tlog
                                              performSTM tlog (act2 >>= cont) 
      Throw e -> throw e
                                  
  performOrElseLeft :: TLOG -> STM a -> IO (Maybe a)
  performOrElseLeft tlog  act = 
     case act of 
      Return a -> do
                 return $ Just a
      Retry  -> do
                 return Nothing
      NewTVar x cont -> do
                         tv <- newTVarWithLog tlog x
                         performOrElseLeft tlog (cont tv)
      ReadTVar x cont -> do 
                          res <- readTVarWithLog tlog x
                          performOrElseLeft tlog (cont res)
      WriteTVar v x cont -> do
                             writeTVarWithLog tlog v x
                             performOrElseLeft tlog cont 
      OrElse act1 act2 cont -> do           
                                orElseWithLog tlog -- adjust for left orElse
                                resl <- performOrElseLeft tlog act1
                                case resl of
                                  Just a -> performOrElseLeft tlog (cont a) 
                                  Nothing -> do
                                              orRetryWithLog tlog
                                              performOrElseLeft tlog (act2 >>= cont) 
  
                                              
  waitForExternalRetry = 
   do
    x <- newEmptyMVar
    wait x
     where wait x  =  
              catch (takeMVar x >> return undefined) 
                    (\e -> case e of BlockedIndefinitelyOnMVar -> putStrLn "BLOCKED IN RETRYWAT" >> wait x
                                     _ -> throw e)
      
  