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

-- |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.
--
--  Note that this module declares incoherent instances.  The universe should
--  refrain from imploding on itself as long as you don't define
--  \"instance MonadIO STM\".  However, hugs doesn't seem to support 
--  overlapping instances, so I may have to give up on the dream of MonadIO 
--  everywhere, or introduce some major conditional compilation stuff. (or
--  abandon hugs support)

module Data.StateRef.Instances.STM
    ( STM
    , TVar
#ifdef useTMVar
    , TMVar
#endif
    
    , atomically
    ) where

import Data.StateRef.Types
import Control.Monad.Trans
import Control.Concurrent.STM

-- (STM a) in STM and IO-compatible monads
instance ReadRef (STM a) STM a where
    readReference :: STM a -> STM a
readReference = STM a -> STM a
forall a. a -> a
id
instance MonadIO m => ReadRef (STM a) m a where
    readReference :: STM a -> m a
readReference = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (STM a -> IO a) -> STM a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically

-- TVar in STM monad
instance HasRef STM where
    newRef :: forall a. a -> STM (Ref STM a)
newRef a
x = do
        TVar a
sr <- a -> STM (TVar a)
forall a. a -> STM (TVar a)
newTVar a
x
        Ref STM a -> STM (Ref STM a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar a -> Ref STM a
forall sr (m :: * -> *) a. ModifyRef sr m a => sr -> Ref m a
Ref TVar a
sr)
instance NewRef (TVar a) STM a where
    newReference :: a -> STM (TVar a)
newReference = a -> STM (TVar a)
forall a. a -> STM (TVar a)
newTVar
instance ReadRef (TVar a) STM a where
    readReference :: TVar a -> STM a
readReference = TVar a -> STM a
forall a. TVar a -> STM a
readTVar
instance WriteRef (TVar a) STM a where
    writeReference :: TVar a -> a -> STM ()
writeReference = TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar
instance ModifyRef (TVar a) STM a where
    atomicModifyReference :: forall b. TVar a -> (a -> (a, b)) -> STM b
atomicModifyReference   = TVar a -> (a -> (a, b)) -> STM b
forall {m :: * -> *} {sr} {t} {a} {b}.
(Monad m, ReadRef sr m t, WriteRef sr m a) =>
sr -> (t -> (a, b)) -> m b
defaultAtomicModifyReference
    modifyReference :: TVar a -> (a -> a) -> STM ()
modifyReference         = TVar a -> (a -> a) -> STM ()
forall {m :: * -> *} {sr} {t} {a}.
(Monad m, ReadRef sr m t, WriteRef sr m a) =>
sr -> (t -> a) -> m ()
defaultModifyReference

-- TVar in IO-compatible monads
instance MonadIO m => NewRef (TVar a) m a where
    newReference :: a -> m (TVar a)
newReference = IO (TVar a) -> m (TVar a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar a) -> m (TVar a))
-> (a -> IO (TVar a)) -> a -> m (TVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO (TVar a)
forall a. a -> IO (TVar a)
newTVarIO
instance MonadIO m => ReadRef (TVar a) m a where
    readReference :: TVar a -> m a
readReference = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (TVar a -> IO a) -> TVar a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> (TVar a -> STM a) -> TVar a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> STM a
forall sr (m :: * -> *) a. ReadRef sr m a => sr -> m a
readReference
instance MonadIO m => WriteRef (TVar a) m a where
    writeReference :: TVar a -> a -> m ()
writeReference TVar a
ref = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 a -> a -> STM ()
forall sr (m :: * -> *) a. WriteRef sr m a => sr -> a -> m ()
writeReference TVar a
ref
instance MonadIO m => ModifyRef (TVar a) m a where
    modifyReference :: TVar a -> (a -> a) -> m ()
modifyReference TVar a
ref         = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ((a -> a) -> IO ()) -> (a -> a) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> ((a -> a) -> STM ()) -> (a -> a) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> (a -> a) -> STM ()
forall sr (m :: * -> *) a.
ModifyRef sr m a =>
sr -> (a -> a) -> m ()
modifyReference TVar a
ref
    atomicModifyReference :: forall b. TVar a -> (a -> (a, b)) -> m b
atomicModifyReference TVar a
ref   = IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> ((a -> (a, b)) -> IO b) -> (a -> (a, b)) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM b -> IO b
forall a. STM a -> IO a
atomically (STM b -> IO b)
-> ((a -> (a, b)) -> STM b) -> (a -> (a, b)) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> (a -> (a, b)) -> STM b
forall b. TVar a -> (a -> (a, b)) -> STM b
forall sr (m :: * -> *) a b.
ModifyRef sr m a =>
sr -> (a -> (a, b)) -> m b
atomicModifyReference TVar a
ref

-- @Ref STM@ in IO-compatible monads
instance MonadIO m => NewRef (Ref STM a) m a where
    newReference :: a -> m (Ref STM a)
newReference a
x = do
        TVar a
sr <- IO (TVar a) -> m (TVar a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO (TVar a)
forall a. a -> IO (TVar a)
newTVarIO a
x)
        Ref STM a -> m (Ref STM a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar a -> Ref STM a
forall sr (m :: * -> *) a. ModifyRef sr m a => sr -> Ref m a
Ref TVar a
sr)
instance MonadIO m => ReadRef (Ref STM a) m a where
    readReference :: Ref STM a -> m a
readReference (Ref sr
sr) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM a -> IO a
forall a. STM a -> IO a
atomically (sr -> STM a
forall sr (m :: * -> *) a. ReadRef sr m a => sr -> m a
readReference sr
sr))
instance MonadIO m => WriteRef (Ref STM a) m a where
    writeReference :: Ref STM a -> a -> m ()
writeReference (Ref sr
sr) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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. WriteRef sr m a => sr -> a -> m ()
writeReference sr
sr
instance MonadIO m => ModifyRef (Ref STM a) m a where
    modifyReference :: Ref STM a -> (a -> a) -> m ()
modifyReference (Ref sr
sr)        = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ((a -> a) -> IO ()) -> (a -> a) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> ((a -> a) -> STM ()) -> (a -> a) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sr -> (a -> a) -> STM ()
forall sr (m :: * -> *) a.
ModifyRef sr m a =>
sr -> (a -> a) -> m ()
modifyReference sr
sr
    atomicModifyReference :: forall b. Ref STM a -> (a -> (a, b)) -> m b
atomicModifyReference (Ref sr
sr)  = IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> ((a -> (a, b)) -> IO b) -> (a -> (a, b)) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM b -> IO b
forall a. STM a -> IO a
atomically (STM b -> IO b)
-> ((a -> (a, b)) -> STM b) -> (a -> (a, b)) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sr -> (a -> (a, b)) -> STM b
forall b. sr -> (a -> (a, b)) -> STM b
forall sr (m :: * -> *) a b.
ModifyRef sr m a =>
sr -> (a -> (a, b)) -> m b
atomicModifyReference sr
sr

#ifdef useTMVar
-- TMVar in STM monad
instance NewRef (TMVar a) STM (Maybe a) where
    newReference :: Maybe a -> STM (TMVar a)
newReference Maybe a
Nothing = STM (TMVar a)
forall a. STM (TMVar a)
newEmptyTMVar
    newReference (Just a
x) = a -> STM (TMVar a)
forall a. a -> STM (TMVar a)
newTMVar a
x
instance ReadRef (TMVar a) STM (Maybe a) where
    readReference :: TMVar a -> STM (Maybe a)
readReference TMVar a
tmv = (a -> Maybe a) -> STM a -> STM (Maybe a)
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (TMVar a -> STM a
forall a. TMVar a -> STM a
readTMVar TMVar a
tmv) STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
`orElse` Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- TMVar in IO-compatible monad
instance MonadIO m => NewRef (TMVar a) m (Maybe a) where
    newReference :: Maybe a -> m (TMVar a)
newReference Maybe a
Nothing = IO (TMVar a) -> m (TMVar a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar a)
forall a. IO (TMVar a)
newEmptyTMVarIO
    newReference (Just a
x) = IO (TMVar a) -> m (TMVar a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO (TMVar a)
forall a. a -> IO (TMVar a)
newTMVarIO a
x)
instance MonadIO m => ReadRef (TMVar a) m (Maybe a) where
    readReference :: TMVar a -> m (Maybe a)
readReference = IO (Maybe a) -> m (Maybe a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a))
-> (TMVar a -> IO (Maybe a)) -> TMVar a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a))
-> (TMVar a -> STM (Maybe a)) -> TMVar a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar a -> STM (Maybe a)
forall sr (m :: * -> *) a. ReadRef sr m a => sr -> m a
readReference
#endif