{-# LANGUAGE
        CPP,
        MultiParamTypeClasses,
        FlexibleInstances
  #-}

-- |This module exports no new symbols of its own.  It defines 
--  basic class instances for creating, reading, and writing 'TVar's and
--  (if available) 'TMVar's, and re-exports the types for which it defines 
--  instances as well as the 'atomically' function, which is indispensible
--  when playing with this stuff in ghci.
module Data.MRef.Instances.STM
    ( STM
#ifdef useTMVar
    , TMVar
#endif
    , TVar
    
    , atomically
    ) where

import Data.MRef.Types
import Data.StateRef (readReference, writeReference, newReference)
import Data.StateRef.Instances.STM ()

import Control.Concurrent.STM

-- MRef STM in IO monad
instance NewMRef (MRef STM a) IO a where
#ifdef useTMVar
    newMReference :: a -> IO (MRef STM a)
newMReference = (TMVar a -> MRef STM a) -> IO (TMVar a) -> IO (MRef STM a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TMVar a -> MRef STM a
forall sr (m :: * -> *) a.
(TakeMRef sr m a, PutMRef sr m a) =>
sr -> MRef m a
MRef (IO (TMVar a) -> IO (MRef STM a))
-> (a -> IO (TMVar a)) -> a -> IO (MRef STM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO (TMVar a)
forall a. a -> IO (TMVar a)
newTMVarIO
    newEmptyMReference :: IO (MRef STM a)
newEmptyMReference = (TMVar a -> MRef STM a) -> IO (TMVar a) -> IO (MRef STM a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TMVar a -> MRef STM a
forall sr (m :: * -> *) a.
(TakeMRef sr m a, PutMRef sr m a) =>
sr -> MRef m a
MRef IO (TMVar a)
forall a. IO (TMVar a)
newEmptyTMVarIO
#else
    newMReference = fmap MRef . newTVarIO . Just
    newEmptyMReference = fmap MRef (newTVarIO Nothing)
#endif
    
instance TakeMRef (MRef STM a) IO a where
    takeMReference :: MRef STM a -> IO a
takeMReference (MRef sr
ref) = STM a -> IO a
forall a. STM a -> IO a
atomically (sr -> STM a
forall sr (m :: * -> *) a. TakeMRef sr m a => sr -> m a
takeMReference sr
ref)
instance PutMRef (MRef STM a) IO a where
    putMReference :: MRef STM a -> a -> IO ()
putMReference (MRef sr
ref) = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sr -> a -> STM ()
forall sr (m :: * -> *) a. PutMRef sr m a => sr -> a -> m ()
putMReference sr
ref


#ifdef useTMVar
--TMVar in STM monad
instance HasMRef STM where
    newMRef :: a -> STM (MRef STM a)
newMRef a
x    = (TMVar a -> MRef STM a) -> STM (TMVar a) -> STM (MRef STM a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TMVar a -> MRef STM a
forall sr (m :: * -> *) a.
(TakeMRef sr m a, PutMRef sr m a) =>
sr -> MRef m a
MRef (a -> STM (TMVar a)
forall a. a -> STM (TMVar a)
newTMVar a
x)
    newEmptyMRef :: STM (MRef STM a)
newEmptyMRef = (TMVar a -> MRef STM a) -> STM (TMVar a) -> STM (MRef STM a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TMVar a -> MRef STM a
forall sr (m :: * -> *) a.
(TakeMRef sr m a, PutMRef sr m a) =>
sr -> MRef m a
MRef STM (TMVar a)
forall a. STM (TMVar a)
newEmptyTMVar
instance NewMRef (TMVar a) STM a where
    newMReference :: a -> STM (TMVar a)
newMReference = a -> STM (TMVar a)
forall a. a -> STM (TMVar a)
newTMVar
    newEmptyMReference :: STM (TMVar a)
newEmptyMReference = STM (TMVar a)
forall a. STM (TMVar a)
newEmptyTMVar

instance TakeMRef (TMVar a) STM a where
    takeMReference :: TMVar a -> STM a
takeMReference = TMVar a -> STM a
forall a. TMVar a -> STM a
takeTMVar
instance PutMRef (TMVar a) STM a where
    putMReference :: TMVar a -> a -> STM ()
putMReference = TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar

-- TMVar in IO monad
instance NewMRef (TMVar a) IO a where
    newMReference :: a -> IO (TMVar a)
newMReference = a -> IO (TMVar a)
forall a. a -> IO (TMVar a)
newTMVarIO
    newEmptyMReference :: IO (TMVar a)
newEmptyMReference = IO (TMVar a)
forall a. IO (TMVar a)
newEmptyTMVarIO
    
instance TakeMRef (TMVar a) IO a where
    takeMReference :: TMVar a -> IO a
takeMReference = STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> (TMVar a -> STM a) -> TMVar a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar a -> STM a
forall sr (m :: * -> *) a. TakeMRef sr m a => sr -> m a
takeMReference
instance PutMRef (TMVar a) IO a where
    putMReference :: TMVar a -> a -> IO ()
putMReference TMVar a
ref = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar a -> a -> STM ()
forall sr (m :: * -> *) a. PutMRef sr m a => sr -> a -> m ()
putMReference TMVar a
ref
#endif

-- incidental instances, which may occasionally be handy in a pinch
-- TVars containing "Maybe" values in STM monad.
-- Also use as default if TMVar isn't available.
#ifndef useTMVar
instance HasMRef STM where
    newMRef x    = fmap MRef (newTVar (Just x))
    newEmptyMRef = fmap MRef (newTVar Nothing)
#endif
instance NewMRef (TVar (Maybe a)) STM a where
    newMReference :: a -> STM (TVar (Maybe a))
newMReference = Maybe a -> STM (TVar (Maybe a))
forall sr (m :: * -> *) a. NewRef sr m a => a -> m sr
newReference (Maybe a -> STM (TVar (Maybe a)))
-> (a -> Maybe a) -> a -> STM (TVar (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
    newEmptyMReference :: STM (TVar (Maybe a))
newEmptyMReference = Maybe a -> STM (TVar (Maybe a))
forall sr (m :: * -> *) a. NewRef sr m a => a -> m sr
newReference Maybe a
forall a. Maybe a
Nothing

instance TakeMRef (TVar (Maybe a)) STM a where
    takeMReference :: TVar (Maybe a) -> STM a
takeMReference TVar (Maybe a)
ref = do
        Maybe a
x <- TVar (Maybe a) -> STM (Maybe a)
forall sr (m :: * -> *) a. ReadRef sr m a => sr -> m a
readReference TVar (Maybe a)
ref
        case Maybe a
x of
            Maybe a
Nothing -> STM a
forall a. STM a
retry
            Just a
x -> do
                TVar (Maybe a) -> Maybe a -> STM ()
forall sr (m :: * -> *) a. WriteRef sr m a => sr -> a -> m ()
writeReference TVar (Maybe a)
ref Maybe a
forall a. Maybe a
Nothing
                a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
instance PutMRef (TVar (Maybe a)) STM a where
    putMReference :: TVar (Maybe a) -> a -> STM ()
putMReference TVar (Maybe a)
ref a
val = do
        Maybe a
x <- TVar (Maybe a) -> STM (Maybe a)
forall sr (m :: * -> *) a. ReadRef sr m a => sr -> m a
readReference TVar (Maybe a)
ref
        case Maybe a
x of
            Maybe a
Nothing -> TVar (Maybe a) -> Maybe a -> STM ()
forall sr (m :: * -> *) a. WriteRef sr m a => sr -> a -> m ()
writeReference TVar (Maybe a)
ref (a -> Maybe a
forall a. a -> Maybe a
Just a
val)
            Just a
x -> STM ()
forall a. STM a
retry

-- TVars containing "Maybe" values in IO monad
instance NewMRef (TVar (Maybe a)) IO a where
    newMReference :: a -> IO (TVar (Maybe a))
newMReference = Maybe a -> IO (TVar (Maybe a))
forall sr (m :: * -> *) a. NewRef sr m a => a -> m sr
newReference (Maybe a -> IO (TVar (Maybe a)))
-> (a -> Maybe a) -> a -> IO (TVar (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
    newEmptyMReference :: IO (TVar (Maybe a))
newEmptyMReference = Maybe a -> IO (TVar (Maybe a))
forall sr (m :: * -> *) a. NewRef sr m a => a -> m sr
newReference Maybe a
forall a. Maybe a
Nothing
instance TakeMRef (TVar (Maybe a)) IO a where
    takeMReference :: TVar (Maybe a) -> IO a
takeMReference = STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a)
-> (TVar (Maybe a) -> STM a) -> TVar (Maybe a) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe a) -> STM a
forall sr (m :: * -> *) a. TakeMRef sr m a => sr -> m a
takeMReference
instance PutMRef (TVar (Maybe a)) IO a where
    putMReference :: TVar (Maybe a) -> a -> IO ()
putMReference TVar (Maybe a)
ref = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe a) -> a -> STM ()
forall sr (m :: * -> *) a. PutMRef sr m a => sr -> a -> m ()
putMReference TVar (Maybe a)
ref